packages feed

HaRe (empty) → 0.6

raw patch · 1191 files changed

+167817/−0 lines, 1191 filesdep +basedep +containersdep +directorysetup-changedbinary-added

Dependencies added: base, containers, directory, filepath, ghc, haskell98, hint, mtl, network, pretty, process, syb

Files

+ .DS_Store view

binary file changed (absent → 6148 bytes)

+ ._.DS_Store view

binary file changed (absent → 82 bytes)

+ ._HaRe.cabal view

binary file changed (absent → 287 bytes)

+ ._README.txt view

binary file changed (absent → 287 bytes)

+ HaRe.cabal view
@@ -0,0 +1,38 @@+Name:                           HaRe+Version:                        0.6+Author:                         Chris Brown, Huiqing Li, Simon Thompson+Maintainer:                     Chris Brown+Stability:                      Provisional+Bug-Reports:                    mailto:chrisb@cs.st-andrews.ac.uk+License:                        BSD3+License-File:                   LICENSE+Homepage:                       www.cs.kent.ac.uk/projects/refactor-fp+Description:                    A full Haskell 98 refactoring tool. HaRe supports the full Haskell 98 standard, implemented in Haskell and supporting Emacs and VIm. +Synopsis:                       the Haskell Refactorer.+Category:                       Development, Refactoring+Cabal-Version:                  >= 1.6+Build-Type:                     Simple+Data-Dir:                       misc+Data-Files:                     haskell-refac.el, refactor.vim, Prelude.hs, *.hs, dupReport, dupAnswers, dupPositions, dupTransforms, dupClassAnswer, dupClassTransform, mergeCache, evaluateResult, genFoldCache+++Executable hare-evaluate+        Main-Is:                refactorer/evaluate.hs+        GHC-Options:            -irefactorer -fno-cse -fglasgow-exts  +        Build-Depends:          base >=3 && <= 4, hint, filepath+        Other-Modules:          Paths_hare++Executable hare+        Main-Is:                refactorer/pfe.hs+        GHC-Options:            -itools/base/parse2/LexerSpec/:tools/base/parse2/LexerGen::tools/base/lib:tools/base/parse2/Lexer/:tools/base/tests/HbcLibraries:refactorer/:StrategyLib-4.0-beta/library/:StrategyLib-4.0-beta/src:StrategyLib-4.0-beta/models/deriving/:tools/base/parse2:tools/base/AST:tools/base/modules:tools/base/pretty/:tools/base/defs/:tools/base/:tools/base/lib/Monads/:tools/base/parse2/Parser/:tools/base/syntax:tools/base/TI:tools/pfe:tools/base/transforms:tools/base/transforms/Deriving:tools/hs2html/ -fno-cse -fglasgow-exts  +        Build-Depends:          base >= 3 && <= 4, syb, network, ghc, haskell98, containers, hint, mtl, directory, pretty, process, filepath+        Extensions:             CPP, MultiParamTypeClasses, OverlappingInstances, UndecidableInstances, FunctionalDependencies, NoMonomorphismRestriction+        Other-Modules:          Paths_hare++Executable hare-client+        Main-Is:                refactorer/pfe_client.hs+        GHC-Options:            -itools/base/parse2/LexerSpec/:tools/base/parse2/LexerGen::tools/base/lib:tools/base/parse2/Lexer/:tools/base/tests/HbcLibraries:refactorer/:StrategyLib-4.0-beta/library/:StrategyLib-4.0-beta/src:StrategyLib-4.0-beta/models/deriving/:tools/base/parse2:tools/base/AST:tools/base/modules:tools/base/pretty/:tools/base/defs/:tools/base/:tools/base/lib/Monads/:tools/base/parse2/Parser/:tools/base/syntax:tools/base/TI:tools/pfe:tools/base/transforms:tools/base/transforms/Deriving:tools/hs2html/ -fno-cse -fglasgow-exts  +        Build-Depends:          base >= 3 && <= 4, syb, network, ghc, haskell98, containers, hint, mtl, directory, pretty, process, filepath+        Extensions:             CPP, MultiParamTypeClasses, OverlappingInstances, UndecidableInstances, FunctionalDependencies, NoMonomorphismRestriction+        Other-Modules:          Paths_hare+
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2005, University of Kent. All rights reserved.++Redistribution and use in source and binary forms, with or+without modification, are permitted provided that the following+conditions are met:++- Redistributions of source code must retain the above copyright+  notice, this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above+  copyright notice, this list of conditions and the following+  disclaimer in the documentation and/or other materials provided+  with the distribution.++- Neither the name of the University nor the names of its+  contributors may be used to endorse or promote products derived+  from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.txt view
@@ -0,0 +1,537 @@++                      _   _         ____+                     | | | | __ _  |  _ \ ___+                     | |_| |/ _` | | |_) / _ \+                     |  _  | (_| | |  _ <  __/+                     |_| |_|\__,_| |_| \_\___|++                    HaRe, the Haskell Refactorer+                a snapshot of our current prototype+                             07/07/2010+      http://www.cs.kent.ac.uk/projects/refactor-fp/hare.html++--------------------------------------------------------------------------------++This snapshot includes most dependencies (version A below), and+should build and work on Windows/Cygwin and Unix, with either gvim+6.2 or with emacs 21.4. ++HaRe_07072010 (HaRe 0.6) is still a prototype, made available so+you can play with basic refactoring support for Haskell, and give us+feedback or bug reports (see below for changes since HaRe 0.5 and+known remaining issues). The major new feature in this 0.6 release -+apart from bug fixes - is a number of new refactorings.+WE DO NOT RECOMMEND TO USE THIS PROTOTYPE ON YOUR PRODUCTION SOURCES JUST YET!++--------------------------------------------------------------------------------++--------------- what you need ++0 basics:++  1. ghc-6.12.1+  2. hint-0.3.2.3 (available from cabal)+  3. unix/gnu tools (or cygwin tools, if on windows)+  4. vim or emacs (we've tested with gvim 6.2 and with emacs 21.4)+  5. If you intend on running the test suite, HUnit-1.0.++A [recommended] partial build +  (fewer tools needed, but tied to particular snapshot):++  1. fetch refactorer snapshot. this includes:+    - modified Programatica snapshot (includes happy output)+    - refactorer sources+++--------------- one easy way to arrange these things++the following text assumes this directory structure+and unix/cygwin tools (adapt makefile if necessary):+++  README.txt            <- you're reading this+  makefile+  editors               <- editor interface scripts for Vim/Emacs+  refactorer            <- refactorer ++  StrategyLib-4.0-beta  <- Strafunski's library for strategic programming+  diffs                 <- modified files for tools+  tools                 <- programatica snapshot++You might want to check the paths in makefile,+refactorer/HuMakefile and refactorer/myghc--make for sanity wrt to+your system (you should not actually need Happy for A). They should+work without change on windows/cygwin (windows/mingw has also been+reported to work), and feedback from the first release suggests the+same for unixish systems, from Max OS X to Linux (please let us know+if not, or if you can add new platforms). ++If on Suns, the call to ghc in refactorer/myghc--make needs a little+looking after: in principle, you could remove the SunOS*) case and+use the default case *). In practice, at least on Suns, you will+want to make sure that ghc uses the linker from binutils instead of+the Sun linker (order of magnitude difference in linking time..),+which is what setting GCC_EXEC_PREFIX before calling ghc does - just+put in the path to your local binutils installation.++***IMPORTANT*** for Mac OS users: please make sure that the .gvimrc+file contains the lines+ +          set noguipty+          set nocompatible+  ++--------------- how to build   ++  1. run: +          runhaskell Setup.hs configure --prefix /path/to/hare+          (where /path/to/hare is a folder with read/write access)+          runhaskell Setup.hs build+          runhaskell Setup.hs install+          +--------------- how to use++  2. load the scripted interface into your favourite editor+     (you may or may not want to include this in your standard+      startup files for Haskell)++    - emacs: +      M-x load-file /path/to/hare/share/hare-0.6/haskell-refac.el+      M-x haskell-refac-mode+      (to switch off: M-x haskell-refac-mode)+      You will then need to customize HaRe to point to your installation+      so Programatica can find its chase files.+      In the refactoring menu, go to customize -> chasepaths.+      Replace HaskellLibraries with:  /path/to/hare/share/hare-0.6+      Choose Save.++    - gvim:+      :source editors/refactor.vim+      :RefacStart	(or select start from menu)+      :RefacStop	(or select stop from menu)+      You will then need to customize HaRe to point to your installation+      so Programatica can find its chase files.+      In the refactoring menu, go to customize -> chasepaths.+      Replace HaskellLibraries with:  /path/to/hare/share/hare-0.6+      Choose Save.++  3. this should give you a menu with refactoring commands,+     and a separate refactoring process.++  4. the Programatica frontend we use is project-based.  before+     doing any refactorings, you have to start a project (select+     "new" to start a project with only the current module in it,+     then select "chase" to add the Prelude modules). project+     settings are kept in a "hi" directory, created in the current+     directory (it is recommended to edit files from within the+     directory they reside in).  ++     ***IMPORTANT:*** Please re-create your projects once you have +     updated your HaRe to a new snapshot/release.++  5. for most refactorings, the editor interface will pass the+     current filename (should be the module name, as well), the+     refactoring command, and the current cursor position. For+     some refactorings, you'll also need to highlight an +     expression, or enter a new name. Here's the current list:+     +     Introduce Pattern Match    : place cursor over pattern variable+     +     Introduce Sub pattern      : place cursor over pattern variable+     +     Introduce Case Expression  : place cursor over pattern variable+     +     Generative Fold            : highlight expression to fold. +                                  Must have equation in comment directly before+                                  definition of highlighted expression.+     +     Clone Analysis             : select from menu+     +     Clone Extraction           : highlight clone from the clone class to extract, follow+                                  step-by-step instructions.+     +     Converting Let to Where    : place cursor at start of identifer whose+                                  definition is to be moved+     +     Converting Where to Let    : place cursor at start of identifer whose+                                  definition is to be moved.+     +     create type signatures     : select from menu+     +     remove redundant declarations+                                : highlight definition to clean up+     +     add constructor to data+    type                        : place cursor at start of data type, you'll+                                  be prompted to add the new Constructor+                                  name, followed by any Type parameters as a +                                  complete string+     Split a tuple              : place cureso at start of top level definition that+                                  returns a tuple. +                                  +     Slicing based on a subexpression+                                : highlight sub-expression to extract.+                                +     Instantiate a general pattern+                                : select a function equation and enter +                                  the new instances for each pattern in the argument set.+                                  +     +    +     Extract an expression      : highlight an expression within a definition+     Convert data type to+     newtype                    : place cursor at start of data type+     +     add definition to merge    : place cursor at start of definition that is to be merged+     +     merge definitions          : use "add definition for merge" for each definition to be merged.+                                  then choose merge definitions from menu.+                                  +     fold function definition   : highlight function equation to fold against.+     +     fold constant definition   : highlight constant equation to foldl against.+     +     convert pattern to an as pattern+                                : highlight pattern to convert.+    +     unfold references to as patterns+                                : place cursor over as pattern name.+                                +     remove field from a data type+                                : place cursor at start of field to remove.+                                +     add field to data type+                                : place cursor over start of constructor.+                                  enter new field name.+                                  +     +                                    +     add debug information      : add trace calls to function by placing cursor at the+                                  start of the function to trace+     ++     rename                     : place cursor at start of identifier to+                                  be renamed, you'll be prompted for a+                                  new name++     Lift def to top level      : place cursor at start of identifier +                                  whose definition is to be moved+     Lift def one level         : place cursor at start of identifier +                                  whose definition is to be moved+     Demote                     : place cursor at start of identifier +                                  whose definition is to be moved+     Introduce new def          : highlight expression to be named,+                                  you'll be prompted for a new name+     Unfold def                 : place cursor at start of identifier +                                  where its definition is to be unfolded+     Generalise def             : place cursor at start of identifier +                                  where its definition is to be unfolded+     Remove def                 : place cursor at start of identifier +                                  whose definition is to be removed+     Duplicate def              : place cursor at start of identifier +                                  whose definition is to be duplicated,+                                  you'll be prompted for a new name++     Add one parameter          : place cursor at start of identifier +                                  whose definition is to be modified,+                                  you'll be prompted for a new name+     rm one parameter           : place cursor in formal parameter +                                  which is to be removed+   +     Move def to another module : place cursor at start of the identifier+                                  whose definition is to be moved, you'll+                                  be prompted for the module name+     Clean imports              : cursor position does not matter, just +                                  choose the command from the refactor menu+     Make import explicit       : place cursor at the start of the module +                                  name in the import declaration+     Add to export              : place cursor at start of the identifier+                                  which is to be added to the export+     Remove from export         : place cursor at start of the entry to +                                  be removed in the export list+     From concrete to abstract data type: place cursor at start of the data type name+     Add field names            : place cursor at start of the data type name+     Add discriminators         : place cursor at start of the data type name+     Add constructors           : place cursor at start of the data type name+     Eliminate nested patterns  : place cursor at start of the data type name+     Eliminate patterns         : place cursor at start of the data type name+     Create an ADT module       : place cursor at start of the data type name+     Eliminate intermidiate list: cusor position does not matter, just choose +                                  the command from the menu.+6. If the 'Customize' menu in Emacs does not work, you can do the customisation by:+   M-x customize-group / haskell-refac+++--------------- known issues++- the editor interface still needs improvement, although+  all known bugs have been fixed (windows vim users: it is +  recommended to install vim in its standard location). ++- there is no standard for associating comments with+  semantic entities. we use heuristics to decide when+  to move/remove comments together with definitions+  => these heuristics may not match everyone's +     commenting style++  outline: ++    when (re-)moving a definition, we also (re-)move the last+    consecutive comments right before this definition (with at most one+    empty line between the comments and the definition); we also+    (re-)move the comment whose start location is in the same line as+    the definition's last line of code. ++  Example:++    ....+    --Comment1++    --Comment2+    --Comment3++    fun1 x =  x+1  --Comment4+    --Comment5 ++    ...+     +  In this case, Comment2, Comment3 and Comment4 belong to function fun1.++- if you're routinely working in a mixed Windows/Unix setup, you'll+  notice that the file-format (encoding of line endings) of HaRe+  output depends on whether you're using a Windows or a Unix HaRe, +  not on whether the input is in Windows or Unix format.++- the Programatica frontend is currently limited to Haskell 98++- the Programatica frontend does not work with no-source files.++---------------change from 08/05/2009+-- general+   + make HaRe compatible with the latest version of GHC+   + ported to hint library, as an abstraction for GHC API.+   + bug fixes.++---------------change from 22/11/2006+-- general+   + make HaRE compatible with the latest version of GHC+   + several refactorings and bug fixes relating to slicing refactorings have +     been added+   + API has been extended+   + Now uses GHC API for some refactorings ++---------------changes from 15/04/2005+-- general+   + make HaRe compatable with the latest version of GHC and Programatica.+   + Several refactorings related to slicing and data types have been +     added.   +   + A pointwise to pointfree transformation has been added.++---------------changes from 11/03/2005+-- bugfix+   -- Introduce new defintion: only replaced the highlighted expression if the expression+      contains negative numbers.+   -- checking for inscoped identifiers.+   -- checking for conflicting export list.  +---------------changes from 03/12/2004+--gereral+  removed the unnecessary files in the snapshot.++--bugfix+   -- Introduce new definition: only replaced the highlighted expression if the expression+      contains literals.+----------------changes from 19/11/2004++-- general+  +   + Updated to a new Programatica version which supports hierarchical modules.+  +   + Adding an refactoring to the editor now only need to modify only file.++-- bugfixes+   + the 'Customize' menu did not work.   ++----------------changes from 16/09/2004++-- general++  + The API. An API for program analysis and tranformation. Together with Programatica and Strafunski,+    this API can be used for the implementation for elementary refactorings. The file that contains +    this API is RefacUtils.hs (the module name is RefacUtils). You can find the documentation for the+    API at HaRe_20012008/refactorer/doc. +    +  + The hidden token stream manipulation. The basic idea is to move the token stream manipulations+    from the implementation of individual refactorings to the API, so that a program transformation+    function from the API modifies not only the AST but also the token stream. This liberates the +    implementator of refactoring from caring about the token stream. ++  + For those users who are interested in the implementation of refactorings, we have written and +    documented the implementation of two very simple refactorings: swapping the first two arguments+    of a function, and from it-then-else expression to case expression. You can find the implementation+    at HaRe_20012008/refactorer/RefacSwapArgs.hs, and HaRe_20012008/refactorer/RefacCase.hs.++  + We have a test suite to HaRe 0.3, and you can find it at HaRe_20012008/testing. There is a README file+    to explain how it works.+++--------------- changes from  09/08/2004   ++-- bugfixes+   + demote directly recursive definition.+   + non-break space++---------------changes from 26/04/2004+- features+   + The refactor menu has been switched to hierarchical menus to reduce clutter.+   + In 'generalise a definition', 'replace all' has been switched on. ++- refactoring+   - new refactorings:+    + 'from concrete to abstract data type': transforms a concrete data type defintion into an abstract one.+      This is a composite refactoring. It consists of five elementary refactorings:+      + 'Add field names': add field names to a data type declaration.+      + 'Add disriminators': add a discriminator for each data constructor defined in the identified data type.+      + 'Add constructors': add a constructor function for each data constructor defined in the identified data type.+      + 'Eliminate nested patterns': remove patterns nested in a pattern specified by the data constructor defined+                                     in the identified data type.+      + 'Eliminate patterns': remove those patterns specified by the data constructor defined in the identified data type.+      + 'Create an ADT module': create the ADT module interface.+    + 'eliminate intermidiate list' (this refactoring is still in an experimental stage)++   -bug fixes+    + After generalising a function with a type signature, the type signature is now commented out in the program source.+    + wrong layout when refactoring on operator functions.+    + wrong layout when refactoring on an expression ending with [] or ()++--------------- changes from 26/02/2004++- general ++   - update to a new Programmatica version  ++- refactoring++   - new refactorings:+     + 'move def to another module' : move a definition from the current+                                      module to a user-specified module+     + 'clean imports'        : remove redundancies from the imports +     + 'make import implicit' : make the used entities from an+                                import explicit in the declaration+     + 'add to export'        : add an entity to the export list+     + 'remove from export'   : remove an entity from the export list+   +   - bugfixes:++    + qualified uses of a top-level identifier becomes +      unqualified after its definition has been demoted. ++--------------- changes from 27/01/2004++- refactoring++  - features:+    + in 'introduce a new definition', 'replace all' has been+      switched on. The refactorer should be able to detect all+      identical expressions in the scope.+    + operators can now be renamed++  - bugfixes:+    + module names can differ from file names+    + avoid dangling parenthesis after unfoldDef +      (could trigger layout rule syntax errors)+    + do not reverse names of new variables introduced+      by unfoldDef (did you know that 0_x is legal?-)+    + do not trip over hard tabs+    + give an error message when trying to lifting a definition +      in a class/instance declaration to the top level.+    + only write client modules when they are really changed.+    + renaming data types should not rename data constructors as well+    + lifting defs should not add globally available ids as parameters+    + the reported layout bugs with lifitng and intro new defs have+      been fixed++  - known issues+    + hard tabs are not counted correctly yet+    + refactorings shouldn't introduce hard tabs!++- editor interfaces++  - features:+    + Emacs: thanks to help from JP Bernardy, we have now moved the+      emacs lisp script to a subset that both Emacs and XEmacs can +      work with; in the process, the gui has been cleaned up a bit+      and should now operate more like a normal minor mode.. +    + Vim: don't try to open files modified by the refactorer,+      unless they are already associated with a buffer; show+      warning dialog instead (now in line with emacs version)++  - bugfixes:+    + Emacs: don't create separate refactoring processes per buffer++  - known issues+    + in Vim, it is still possible to start refactorings while+      there are modified buffers (fixed in Emacs a while ago)++--------------- changes from 01/10/2003++- general:++  - Programatica and HaRe have added workarounds for the Template+    Haskell syntax problems in ghc-6.0, so HaRe now builds with+    ghc-6.0.1 (ghc-6.2.1 has introduced yet another change, so does+    not work yet..)++  - upgraded to StrategyLib-4.0-beta ++- refactoring:++  - Programatica frontend does now give source location information+    for all literals+    => refactorings should no longer have problems with String and+       Char literals ++  - HaRe is now module-aware: all refactorings have been updated to+    try and take import/export relations into account.+  +  - following your requests, HaRe can now work with literate Haskell+    files. This relies on some guesswork, so expect to find some+    rough corners - please report your experience so we can try to+    fix problems. Might also interact oddly with our heuristics for+    attaching comments to definitions.++  - Automatic renaming has been disabled during liftOneLevel, +    liftToTopLevel, demote and generaliseDef. In the case that one+    of these refactorings will cause name clash/capture, the user +    will be prompted to do renaming first.++  - refactoring bugfixes:+    + introNewDef and generaliseDef now replace the marked expression+      itself, not the first occurrence of the marked expression+    + wrong layout during liftOneLevel+    + non-exhaustive case in RefacLocUtils.hs+    + missing parentheses during generaliseDef+    + a parameter can be now be removed from a direct recursive+      definition if it is not used in the definition.+    + when adding an parameter to a direct recursive definition, use+      the new formal parameter name, instead of the default actual argument+      name, as the actual argument inside this function.+    + the way to created a new name has been changed. For example add a+      new parameter 'y' to a definition 'f', the default argument name is+      f_y instead of 'f_y_1'.             +    + erroneous caching of export list+    + multi-module undo+    ...++- editor interfaces:++  - Emacs now reloads files modified by the refactorer without+    prompting the user, and warns when a refactoring has changed+    files not currently opened.++  - editor interface bugfixes:+    Emacs:+    + the error-in-mini-buffer effects preventing file reloading+      in some Emacs configurations were finally traced and+      eliminated (the stopwatch issue also seems to be gone).+    + refac buffer now automatically scrolls to last line+    + refactorings are now blocked while there are unsaved buffers
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ StrategyLib-4.0-beta/.DS_Store view

binary file changed (absent → 6148 bytes)

+ StrategyLib-4.0-beta/._.DS_Store view

binary file changed (absent → 82 bytes)

+ StrategyLib-4.0-beta/COPYING view
@@ -0,0 +1,1 @@+See www.sourceforge.net/Strafunski
+ StrategyLib-4.0-beta/ChangeLog view
@@ -0,0 +1,24 @@+Changes in StrategyLib version 5.0++- Upgraded to GHC 6.4.1, which involved:+  - importing qualified modules from hierarchical libraries+  - adapting to renamings in Data.Dynamics++Changes in StrategyLib version 4.0++- moved Strafunski to sourceforge.+- examples of using class Data see examples/twosorts-deriving+- eliminated use of configuration, automake etc.+- for makerules see subdir "scripts"+- everything works fine with John Meacham's DrIFT 2.0.1+- removed src/Monads.hs --- too many clashes ...+- removed src/Breadthfirst.hs --- could become an example+- removed src/Xml* for the moment, which was disabled anyway+- some examples did not make it into the new distribution+- added mchoicesTP to interface of StrategyPrimitives next to mchoicesTU+- removed some weird functions from the interface of StrategyPrimitives:+  - unTP          (not very useful in usercode anyway)+  - unTU          (not very useful in usercode anyway)+  - applyOnKidsTU (a bit untyped for certain models)+  - applicable    (not needed in usercode)+  - uniTP, uniTU  (not used anywhere, very expensive)
+ StrategyLib-4.0-beta/INSTALL view
@@ -0,0 +1,30 @@+This a pure source distribution of Strafunski's StrategyLib.++Everything should work out of the box.++You can use the library if you have hugs or ghc installed.  If you+want to generate Term instances for Datatypes, you will need+DrIFT. For the examples included in the distribution, the generated+files are however shipped, so that you don't need DrIFT if you just+want to play with distribution.++The distribution was tested with the following configuration:++- ghci/ghc 6.2+- ghci/ghc 6.0.1 (works too but not eariler versions)+- hugs version November 2002 (don't use earlier versions)+- DrIFT 2.0.1 (don't use earlier versions)+- gmake 3.79.1 (most versions should do)+- examples/twosorts-deriving needs an unreleased GHC version++All these programs are expected to be in your path.++Run "gmake check" to test the distribution if you like. There are also+more specific targets for running examples. For example, the most+simple example, i.e., "twosorts-drift-default" is ran with hugs as+follows:++> cd examples/twosorts-drift-default+> gmake test-hugs++For all other information see the file README.
+ StrategyLib-4.0-beta/Makefile view
@@ -0,0 +1,114 @@+###############################################################################+#+# Environment for makerules+#++StrategyLib = .+Model       = drift-default+subdirs     = library models scripts examples+version     = ${shell cat VERSION}+www	    = fluit.cs.vu.nl:/home/ralf/www/Strafunski/+++###############################################################################+#+# Create awareness of different checking options+#++check:+	@echo+	@echo " Options:"+	@echo "  Enter \"${MAKE} check-hugs\" to check with hugs Nov 2002."+	@echo "  Enter \"${MAKE} check-ghci\" to check with ghci 6.0.1/6.2."+	@echo "  Enter \"${MAKE} check-ghc\"  to check with ghc  6.0.1/6.2."+	@echo "  Enter \"${MAKE} check-all\"  to check everything, i.e.:"+	@echo "         - check with hugs, ghci, and ghc"+	@echo "         - regenerate all derived instances with DrIFT 2.0.1"+	@echo++++###############################################################################+#+# Check everything+#++check-all:+	${MAKE} very-clean+	${MAKE} check-ghci+	${MAKE} check-ghc+#	${MAKE} check-hugs+++###############################################################################+#+# Build a distribution+#++dist:+	@${RM} -r /tmp/StrategyLib-${version}+	@ln -s ${PWD} /tmp/StrategyLib-${version}+	@(cd /tmp;\+	  zip -q -r StrategyLib-${version}.zip \+	   `find StrategyLib-${version} -follow \+             -name Makefile -or -name "makerules.*" -or \+	     -name "*.hs" -or -name "*.lhs" -or\+	     -name "*.html" -or -name "*.css" -or -name "haskell_icon.gif" -or \+	     -name README -or -name AUTHORS -or -name COPYING -or \+	     -name ChangeLog -or -name INSTALL -or -name VERSION -or \+	     -name TODO -or -name TestMain -or -name "*.correct" -or \+	     -name "*.joos" | grep -v "/out/" | grep -v "out.hs"` \+	 )+	@${RM} -r /tmp/StrategyLib-${version}+	@echo "Created distribution in: /tmp/StrategyLib-${version}.zip"++distcheck:+	$(MAKE) dist+	@(cd /tmp; \+	  unzip -q /tmp/StrategyLib-${version}.zip \+	 )+	@(cd /tmp/StrategyLib-${version}; \+	  ${MAKE} check-all \+	 )+	@${RM} -rf /tmp/StrategyLib-${version}+	@echo "****************"+	@echo "/tmp/StrategyLib-${version}.zip is ready for distribution"+	@echo "****************"+++###############################################################################+#+# Documentation+#++docDir		= ./documentation++haddock:+	mkdir -p ${docDir}+	haddock -o ${docDir} -h --title=StrategyLib \+	  `find ./library -name "*.hs" -or -name "*.lhs"` \+	  `find ./models/${Model} -name "*.hs" -or -name "*.lhs"`+++###############################################################################+#+# Release to the Strafunski site+#++release-cp:+	scp -p /tmp/StrategyLib-${version}.zip ${www}+	scp -p -r ${docDir} ${www}++release: distcheck haddock+	gmake release-cp+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.check+include ${StrategyLib}/scripts/makerules.recurse+
+ StrategyLib-4.0-beta/README view
@@ -0,0 +1,142 @@+------------------------------------------------------------------------------++StrategyLib --- a library for generic programming with functional strategies++README file++Table of contents++- Cross references (files with further information)+- Subdirectories of the source distribution+- Prerequisites for using the library and running examples+- Checking the installation (just do a "gmake check")+- Targets used by Makefile system+- Supported models of functional strategies+- ++------------------------------------------------------------------------------+++Cross references+----------------++AUTHORS   --- authors of Strafunski+COPYING   --- BSD-style copyright+INTALL    --- recommeneded versions of hugs/ghc/ghci/DrIFT+VERSION   --- version of StrategyLib+ChangeLog --- changes compared to previous version+TODO      --- issues to be addressed in the future+++------------------------------------------------------------------------------+++Subdirectories of the source distribution+-----------------------------------------++library  --- implementation of functional strategies and StrategLib's themes+models   --- different models of functional strategies+scripts  --- reusable scripts (mainly includes for Makefiles)+examples --- examples of using functional strategies+++------------------------------------------------------------------------------+++Prerequisites for using the library and running examples+--------------------------------------------------------++Either ghc or hugs or both, and maybe DrIFT.+See the file INSTALL for details.+++------------------------------------------------------------------------------+++Checking the installation+-------------------------++Just type in "gmake check" which provides you with a list of options+to check the distribution in different ways. The options differ+regarding the used Haskell implementations and regarding the fact+whether derived modules are to be regenerated with DrIFT or the+shipped versions will be used as is.+++-------------------------------------------------------------------------------+++Targets used by Makefile system+-------------------------------++You don't need to "make" anything since this is a source distribution,+but there are some make targets to run examples and do other things.+In applications of StrategyLib, one is encouraged to reuse some includes+for Makefiles as provided in subdirectory "scripts".+++Targets in examples/*/Makefiles:++ run-hugs   --- run Main.hs with hugs+ run-ghci   --- run Main.hs with ghci+ run-ghc    --- run Main.hs with ghc + derive     --- run DrIFT if needed+++Recursive clean targets:++ clean      --- remove backup files, object code, etc.+ very-clean --- also remove modules generated by DrIFT+++Targets in the top-level Makefile:++ check      --- list detailed check options+ dist       --- build a distribution (to be implemented)+++-------------------------------------------------------------------------------+++Supported models of functional strategies+-----------------------------------------+ +We have played with quite a few models, and most of them are somewhat+supported by DrIFT, but for simplicity we only exercise two models in+the present distribution; see subdirectory "models":+ +- drift-default: a model based on a specific universal term representation+- deriving:      a model based on GHC's support for the Typeable/Data classes+ +Most subdirectories of ${StrategyLib}/examples assume the+"drift-default" model. In fact, we only demonstrate the difference for+the two models by having a "twosorts-drift-default" vs. a+"twosorts-deriving" example.+++-------------------------------------------------------------------------------+++Examples+--------++Examples are hosted in subdirectory examples.++two-sorts-drift-default --- the most trivial example; good for studying+two-sorts-derving       --- a variation requiring GHC's deriving support+little-lambda           --- a trivial example of language processing+joos-padl02             --- refactoring for a Java-subset (see PADL'02 paper)+joos-rule02             --- refactoring for a Java-subset (see RULE'02 paper)+haskell                 --- transformation of Haskell itself+++-------------------------------------------------------------------------------+++Links+-----++- DrIFT      --- http://repetae.net/john/computer/haskell/DrIFT/+- Strafunski --- http://www.cs.vu.nl/Strafunski/ +                 http://strafunski.sourceforge.net/+
+ StrategyLib-4.0-beta/TODO view
@@ -0,0 +1,2 @@+- Omitted some examples compared to V3; more could still be added.+
+ StrategyLib-4.0-beta/VERSION view
@@ -0,0 +1,1 @@+5.0
+ StrategyLib-4.0-beta/examples/Makefile view
@@ -0,0 +1,23 @@+###############################################################################+#+# Environment for makerules+#++StrategyLib = ..+subdirs     =	two-sorts-drift-default	\+		little-lambda \+		joos-padl02 \+		joos-rule02 \+		two-sorts-deriving \+		haskell+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.all+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.check+include ${StrategyLib}/scripts/makerules.recurse
+ StrategyLib-4.0-beta/examples/haskell/DoElim.hs view
@@ -0,0 +1,71 @@+module DoElim (doElim) where++-------------------------------------------------------------------------------++--- This module implements a transformation that implements de-sugaring+--- of Haskell's "do" notation++-------------------------------------------------------------------------------++import Language.Haskell.Syntax+import SyntaxTermInstances+import StrategyLib+import Monad++-- Elimination of do notation -------------------------------------------------++doElim 	   :: (Term a, MonadPlus m) => a -> m a+doElim h   =  applyTP (innermost (monoTP doElim1)) h++doElim1    :: MonadPlus m => HsExp -> m HsExp+doElim1 (HsDo [HsQualifier e]) 	+  = return e+doElim1 (HsDo (HsQualifier e:stmts))	+  = return (HsInfixApp e (HsQVarOp (hsSymbol ">>")) (HsDo stmts))+doElim1 (HsDo (HsGenerator _ p e:stmts))+  = do ok <- new_name+       return (letPattern ok p e stmts)+doElim1 (HsDo (HsLetStmt decls:stmts))+  = return (HsLet decls (HsDo stmts))+doElim1 _                      +  = mzero++-- Auxiliaries ----------------------------------------------------------------++letPattern ok p e stmts+  = let fail    = hsIdent "fail"        +        failmsg = "Error: pattern-match failure in do-expression."+        mthen   = HsQVarOp (hsSymbol ">>=")+    in (HsLet [HsFunBind [HsMatch noSrcLoc (HsIdent ok) [p] (HsUnGuardedRhs (HsDo stmts)) []],HsFunBind [HsMatch noSrcLoc (HsIdent ok) [HsPWildCard] (HsUnGuardedRhs (HsApp (HsVar fail) (HsLit (HsString failmsg)))) []]] (HsInfixApp e mthen (HsVar (hsIdent ok))))++noSrcLoc = SrcLoc "" 0 0 ++hsSymbol s = (UnQual (HsSymbol s))+hsIdent s  = (UnQual (HsIdent s))++new_name :: Monad m => m String+new_name = return "ok"++-- Test terms -----------------------------------------------------------------++do1+  = let silly  = HsIdent "silly"+        aap    = hsIdent "aap"+        aap'   = HsIdent "aap"+        noot   = hsIdent "noot"+        noot'  = HsIdent "noot"+        return = hsIdent "return" +        bind   = hsSymbol ">>="+    in HsModule noSrcLoc (Module "Do1") Nothing [] [HsFunBind [HsMatch (SrcLoc "" 3 12) silly [HsPVar noot'] (HsUnGuardedRhs (HsDo [HsGenerator noSrcLoc (HsPVar aap') (HsVar noot),HsQualifier (HsApp (HsVar return) (HsVar aap))])) []]]++nodo1 +  = let silly  = HsIdent "silly"+        aap    = hsIdent "aap"+        aap'   = HsIdent "aap"+        noot   = hsIdent "noot"+        noot'  = HsIdent "noot"+        return = hsIdent "return" +        bind   = hsSymbol ">>="+    in HsModule noSrcLoc (Module "Do1") Nothing [] [HsFunBind [HsMatch (SrcLoc "" 3 12) silly [HsPVar noot'] (HsUnGuardedRhs (HsInfixApp (HsVar noot) (HsQVarOp bind) (HsLambda noSrcLoc [HsPVar aap'] (HsApp (HsVar return) (HsVar aap))))) []]]++-------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/haskell/HsChaseImports.hs view
@@ -0,0 +1,149 @@+module HsChaseImports where++-------------------------------------------------------------------------------    ++-- This module implements import chasing for Haskell.++-------------------------------------------------------------------------------    ++import HsIOWrap(parseWrap')+import StrategyLib+import HsModuleCollection+import Language.Haskell.Syntax+import Language.Haskell.Parser+import Language.Haskell.Pretty+import SyntaxTermInstances+import IO+import System+import qualified Literate+import Monad+import Control.Monad.Identity++-------------------------------------------------------------------------------    ++hsIOwrapChasing transform+  = do [pth,m,d] <- getArgs+       errLn "Import chasing..."+       errLn ("Start from:  "++m)+       errLn ("Search path: "++pth)+       errLn ("Writing results in:"++d)+       let dirs = breakPath pth+       ms <- hsChaseFrom dirs m+       ms' <- transform ms+       mapM_ (writeModule d) ms'++writeModule :: String -> (ModuleName,[ModuleName],HsModule) -> IO ()+writeModule d (n,is,m)+  = do let sout = (prettyPrint m)++"\n"+       let fout = d++"/"++n++".hs"+       errLn ("Writing module "++n++" to file "++fout)+       writeFile fout sout+       +-- Break path argument into directory names+breakPath :: String -> [String]+breakPath x = case break (==':') x of+	(p,(_:pp)) -> p: breakPath pp+	(p,[]) -> [p]+ +-- Start chasing from a single module.++hsChaseFrom dirs m+  = hsChaseWith dirs [m] [] [] onModule onMissing+ where+  onModule n i m a = return $ a++[(n,i,m)]+  onMissing _ = return+  +-- General import chase algorithm++hsChaseWith :: [FilePath] -> [ModuleName] -> [ModuleName] -> a +            -> (ModuleName -> [ModuleName] -> HsModule -> a -> IO a) +	    -> (ModuleName                             -> a -> IO a)+	    -> IO a+hsChaseWith dirs todo done accu onModule onMissing+ = chase todo done accu+   where+    chase [] done accu+      = do errLn "Import chasing complete."+           return accu+    chase (m:ms) done accu+      | m `elem` done = chase ms done accu+      | otherwise     = processFile `mplus` skipFile+     where+       processFile +         = do sin <- readHsFile dirs m+	      case (parseWrap' (fromLiterate sin)) of+	        Left pin  +		  -> let is = getImports pin+                     in do accu' <- onModule m is pin accu+		           chase (ms++is) (m:done) accu'+	        Right msg +		  -> do errLn ("Failed to parse "++m++": "++msg)+		        accu' <- onMissing m accu+		        chase ms (m:done) accu'     +       skipFile    +         = do errLn ("Did not find module "++m++": skipping.")+	      accu' <- onMissing m accu+	      chase ms (m:done) accu'++--- Extraction of imports ----------------------------------------------------++getImports :: HsModule -> [String]+getImports m+ = runIdentity (applyTU (full_tdTU worker) m)+   where+     worker :: TU [String] Identity+     worker =  adhocTU (constTU []) (\i -> return [getName i])++     getName :: HsImportDecl -> String+     getName (HsImportDecl _ (Module mid) _ _ _) = mid+++--- I/O Auxilliaries ---------------------------------------------------------++errLn str = hPutStrLn stderr str++readHsFile dirs basename+  = do errLn ("Starting search for: "++basename)+       readFileSearching dirs basename ["hs","lhs"]+  +-- Search for a file in given directories with alternative extensions++readFileSearching dirs basename exts+  = do results <- mapM tryReadFile fnames+       case dropWhile hasFailed results of+         ((Right (fc,fn)):_) +	     -> errLn ("Read file: "++fn) >> return fc+	 _   -> errLn ("Could not find file: "++basename) >> mzero                  +    where +      fnames = [d++'/':basename++'.':e | d <- dirs, e <- exts]+      hasFailed (Left _) = True+      hasFailed _        = False+      tryReadFile fn = try ( readFile fn >>= \fc -> return (fc,fn) )+      +      +--handle literate scripts -----------------------------------------------------++fromLiterate str+  = fromLit (isLit str) str+  +isLit :: String -> Bool+isLit =  any isLitLine . lines+         where +	   isLitLine ('>':_) = True+	   isLitLine _       = False++-- Rest is taken from DrIFT++-- NB we don't do the latex-style literate scripts currently.+fromLit True txt = case Literate.process txt of+			  ([],s) -> s+			  (e,_) -> error e+fromLit False txt = txt++toLit True = unlines . map (\l -> '>':l)  . lines+toLit False = id       + +isLiterate :: String -> Bool+isLiterate = any ((=='>'). head) . words      ++-------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/haskell/HsDeadCodeElim.hs view
@@ -0,0 +1,67 @@+module HsDeadCodeElim where++-------------------------------------------------------------------------------++-- This module implements dead code elimination for Haskell.+-- Under construction!!!+-- We are not yet faithfully dealing with qualified vs. unqualified names.+-- Same holds for module level analysis.++-------------------------------------------------------------------------------++import Language.Haskell.Syntax+import HsModuleCollection+import SyntaxTermInstances+import StrategyLib+import HsFreeNames+import Monad+import List++-- Dead code elimination ------------------------------------------------------++-- This function removes unused local declarations++hsElimDeadCode :: (Term t, MonadPlus m) => t -> m t+hsElimDeadCode = applyTP (full_tdTP worker)+  where+    worker = idTP `adhocTP` match++    match (HsMatch sl fun pats rhs {-where-} decls)+      = do (pf,pd) <- hsFreeAndDeclared pats+           (rf,rd) <- hsFreeAndDeclared rhs+           (df,dd) <- hsFreeAndDeclaredList decls+           decls'  <- filterM (hsTestDecl ((df `union` rf) \\ pd)) decls+           return (HsMatch sl fun pats rhs decls')++hsTestDecl :: MonadPlus m => [HsQName] -> HsDecl -> m Bool+hsTestDecl names decl+  = do (_,[name]) <- hsFreeAndDeclared decl+       return $ name `elem` names+       +-- Application extraction ----------------------------------------------------++-- This function removed unused top declarations from+-- a list of modules, until it reaches a fixpoint.++hsExtrAppl :: MonadPlus m+         => [(ModuleName,[ModuleName],HsModule)] +         -> m [(ModuleName,[ModuleName],HsModule)]++hsExtrAppl l@(h:t)+  = do l' <- mapM worker t >>= return . (:) h+       if l==l' then return l else hsExtrAppl l'+  where+    worker (n,i,m@(HsModule sl n' i' e' ds))+      = do clients <- return $ filter (\e@(_,i',_) -> n `elem` i') l+           (imp,_) <- hsFreeAndDeclared clients+           ds'     <- filterM (hsTestDecl imp) ds+           return (n,i,HsModule sl n' i' e' ds')++-- Missing instance generated by DrIFT --------------------------------------	   +	   +instance Eq HsModule where+    (HsModule aa ab ac ad ae) == (HsModule aa' ab' ac' ad' ae') +           = aa == aa' && ab == ab' && ac == ac' && ad == ad' && ae == ae'+    _ == _ = False++-------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/haskell/HsExtract.hs view
@@ -0,0 +1,44 @@+module Main where++-------------------------------------------------------------------------------++-- An (incomplete) application extractor for Haskell.+-- First, redudant modules are discarded.+-- Then, dead code is eliminated from remaining modules.++-------------------------------------------------------------------------------++import HsFreeNames+import HsDeadCodeElim+import HsChaseImports+import Monad+import Language.Haskell.Syntax+import HsModuleCollection++-------------------------------------------------------------------------------++main+  = do putStrLn "\nHaskell application extraction:"+       hsIOwrapChasing (\x -> report x >>= extr >>= report >>= elim >>= report)+       putStrLn "Done.\n"+    where+       extr,elim :: ModuleCollection -> IO ModuleCollection+       extr = hsExtrAppl+       elim = hsElimDeadCode+	+-- Comment the following line to obtain intermediate reports:	+report ms = return ms	   +report ms+  = do putStrLn "\n== Report =="+       mapM worker ms+    where+      worker (n,i,m)+        = do (fn,dn) <- hsFreeAndDeclared m+             putStrLn $ "  Module "++n++":"+             putStrLn $ "    imports:           " ++ (show i) +             putStrLn $ "    free names:        " ++ (show fn) +             putStrLn $ "    declared names:    " ++ (show dn)+	     return (n,i,m)+	     +-------------------------------------------------------------------------------+
+ StrategyLib-4.0-beta/examples/haskell/HsFreeNames.hs view
@@ -0,0 +1,105 @@+module HsFreeNames where++-------------------------------------------------------------------------------++-- This module implements free name analysis for Haskell.+-- Under construction!!!+-- We are not yet faithfully dealing with qualified vs. unqualified names.+-- Same holds for module level analysis.++-------------------------------------------------------------------------------++import Language.Haskell.Syntax+import SyntaxTermInstances+import StrategyLib+import Data.List+import Control.Monad+import Data.Monoid+++-------------------------------------------------------------------------------++-- The main function of analysis.+-- We use the stop_td scheme.+-- We define ad hoc cases for several syntactical domains.+-- Ad hoc cases are meant to restart recursion.+++hsFreeAndDeclared :: (Term t, MonadPlus m) => t -> m ([HsQName],[HsQName])+hsFreeAndDeclared = applyTU (stop_tdTU worker)+  where+    worker = failTU `adhocTU` exp+                    `adhocTU` pat+                    `adhocTU` match+                    `adhocTU` alt+                    `adhocTU` decls+                    `adhocTU` stmts++    exp (HsVar qn)             = return ([qn],[])+    exp (HsCon qn)             = return ([qn],[])+    exp (HsLambda _ pats body)+      = do (pf,pd) <- hsFreeAndDeclared pats+           (bf,bd) <- hsFreeAndDeclared body+           return ((bf `union` pf) \\ pd,[])+    exp (HsLet decls exp)   +      = do (df,dd) <- hsFreeAndDeclared decls+           (ef,ed) <- hsFreeAndDeclared exp+           return (df `union` (ef \\ dd),[])+    exp (HsListComp exp stmts)+      = hsFreeAndDeclared (stmts ++ [HsQualifier exp])+    exp (HsRecConstr qn e)     = addFree qn (hsFreeAndDeclared e)+    exp _                      = mzero+       +    pat (HsPVar n)             = return ([],[UnQual n])+    pat (HsPInfixApp p1 qn p2) = addFree qn (hsFreeAndDeclared [p1,p2])+    pat (HsPApp qn pats)       = addFree qn (hsFreeAndDeclared pats)+    pat (HsPRec qn fields)     = addFree qn (hsFreeAndDeclared fields)+    pat _                      = mzero++    match (HsMatch _ fun pats rhs {-where-} decls)+      = do (pf,pd) <- hsFreeAndDeclared pats+           (rf,rd) <- hsFreeAndDeclared rhs+           (df,dd) <- hsFreeAndDeclared decls+	   let qfun = UnQual fun+           return ( pf `union` (((rf \\ (dd `union` [qfun]) `union` df) \\ pd)),+                    [qfun] )++    alt (HsAlt _ pat exp decls) +      = do (pf,pd) <- hsFreeAndDeclared pat+           (ef,ed) <- hsFreeAndDeclared exp+           (df,dd) <- hsFreeAndDeclared decls+           return (pf `union` (((ef \\ dd) `union` df) \\ pd),[])++    decls (ds::[HsDecl])+      = do (f,d) <- hsFreeAndDeclaredList ds+           return (f \\ d, d)++    stmts (HsGenerator _ pat exp:stmts)+      = do (pf,pd) <- hsFreeAndDeclared pat+           (ef,ed) <- hsFreeAndDeclared exp+           (sf,sd) <- hsFreeAndDeclared stmts+           return (pf `union` ef `union` (sf \\ pd),[])+    stmts (HsLetStmt decls:stmts)+      = do (df,dd) <- hsFreeAndDeclared decls+           (sf,sd) <- hsFreeAndDeclared stmts+           return (df `union` (sf \\ dd),[])+    stmts _ = mzero++    addFree free mfd = do (f,d) <- mfd+                          return ([free] `union` f,d)++hsFreeAndDeclaredList :: (Term t, MonadPlus m) => [t] -> m ([HsQName],[HsQName])+hsFreeAndDeclaredList l+  = do fds <- mapM hsFreeAndDeclared l+       return ( foldr union [] (map fst fds),+                foldr union [] (map snd fds) )++-------------------------------------------------------------------------------++-- This should go somewhere else.++-- instance (Monoid a, Monoid b) => Monoid (a,b) where+--   mappend (a,b) (a',b') = (mappend a a', mappend b b')+--   mempty                = (mempty,mempty)+ +-------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/haskell/HsIOWrap.hs view
@@ -0,0 +1,43 @@+module HsIOWrap where++-------------------------------------------------------------------------------++--- This module provides wrapper functions for analyses and transformations+--- that take care of file IO, parsing and pretty-printing.++-------------------------------------------------------------------------------++import System+import Language.Haskell.Syntax(HsModule,SrcLoc(..))+import Language.Haskell.Parser+import Language.Haskell.Pretty(prettyPrint)+import IO++--- Transformation wrapper ----------------------------------------------------++hsIOwrap transform+  = do [fin,fout] <- getArgs+       hPutStrLn stderr ("Reading file: "++fin)+       sin        <- readFile fin+       let pin    = parseWrap sin+       let Just pout = transform pin+       let sout = (prettyPrint pout)++"\n"+       hPutStrLn stderr ("Writing file: "++fout)+       writeFile fout sout+       +------------------------------------------------------------------------       +       +parseWrap :: String -> HsModule+parseWrap x = forceResult (parseModule x)++parseWrap' :: String -> Either HsModule String+parseWrap' x+        = case (parseModule x) of+            (ParseOk x)              -> Left x+            (ParseFailed _ msg)      -> Right msg++forceResult :: ParseResult a -> a+forceResult (ParseOk x)         = x+forceResult (ParseFailed _ msg) = error msg++-------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/haskell/HsModuleCollection.hs view
@@ -0,0 +1,7 @@+module HsModuleCollection where++import Language.Haskell.Syntax (HsModule)++type ModuleName = String+type Module = (ModuleName,[ModuleName],HsModule)+type ModuleCollection = [Module]
+ StrategyLib-4.0-beta/examples/haskell/HsTransform.hs view
@@ -0,0 +1,35 @@+module Main where++-------------------------------------------------------------------------------++--- This module provides a main function that pipelines all example +--- transformations, and applies them to the input file specified at the+--- command line.++-------------------------------------------------------------------------------++import Language.Haskell.Syntax+import SyntaxTermInstances+import DoElim+import NewTypeIntro+import HsIOWrap+import IO++--- Main program --------------------------------------------------------------++main + = do hPutStrLn stderr "\nHaskell transformations:"+      hPutStrLn stderr "  * elimination of 'do' expressions"+      hPutStrLn stderr "  * conversion of data to newtype declarations"+      hsIOwrap (mpipe [doElim,newtypeIntro])+      hPutStrLn stderr "Done.\n"++++--- Helpers -------------------------------------------------------------------++mpipe [] x	= return x+mpipe (f:fs) x  = f x >>= mpipe fs++-------------------------------------------------------------------------------+
+ StrategyLib-4.0-beta/examples/haskell/Literate.lhs view
@@ -0,0 +1,100 @@+Literate comments+-----------------++[This file contains an executable version of a program for processing+literate scripts.  The original version of this program appeared in+Appendix C of the Haskell report, version 1.2.  This version has been+updated for Haskell 1.3.]++>module Literate where+> import System(getArgs)+> import Char++Many Haskell implementations support the ``literate comment''+convention, first developed by Richard Bird and Philip Wadler for+Orwell, and inspired in turn by Donald Knuth's ``literate programming''.+The convention is not part of the Haskell language, but it is+supported by the implementations known to us (Chalmers, Glasgow,+and Yale).++The literate style encourages comments by making them the default.+A line in which ">" is the first character is treated as part of+the program; all other lines are comment.  Within the program part,+the usual "--" and "{- -}" comment conventions may still be used.+To capture some cases where one omits an ">" by mistake, it is an+error for a program line to appear adjacent to a non-blank comment+line, where a line is taken as blank if it consists only of+whitespace.++By convention, the style of comment is indicated by the file+extension, with ".hs" indicating a usual Haskell file, and ".lhs"+indicating a literate Haskell file.++To make this precise, we present a literate Haskell program to+convert literate programs.  The program expects a single name "file"+on the command line, reads "file.lhs", and either writes the+corresponding program to "file.hs" or prints error messages to+"stderr".++Each of the lines in a literate script is a program line, a blank+line, or a comment line.  In the first case, the text is kept with+the line.++> data Classified  =  Program String | Blank | Comment++In a literate program, program lines begins with a `>' character,+blank lines contain only whitespace, and all other lines are comment+lines.++> classify                       	::  String -> Classified+> classify ('>':s)			=   Program s+> classify s  |  all isSpace s		=   Blank+> classify s  |  otherwise		=   Comment++In the corresponding program, program lines have the leading `>'+replaced by a leading space, to preserve tab alignments.++> unclassify                		::  Classified -> String+> unclassify (Program s)		=   " " ++ s+> unclassify Blank			=   ""+> unclassify Comment			=   ""++Process a literate program into error messages (if any) and the+corresponding non-literate program.++> process   	::  String -> (String, String)+> process lhs	=   (es, hs)+>		where	cs  =  map classify (lines lhs)+>			es  =  unlines (errors cs)+>			hs  =  unlines (map unclassify cs)++Check that each program line is not adjacent to a comment line.++> errors	::  [Classified] -> [String]+> errors cs	=   concat (zipWith3 adjacent [1..] cs (tail cs))++Given a line number and a pair of adjacent lines, generate a list+of error messages, which will contain either one entry or none.++> adjacent	::  Int -> Classified -> Classified -> [String]+> adjacent n (Program _) Comment  =  [message n "program" "comment"]+> adjacent n Comment (Program _)  =  [message n "comment" "program"]+> adjacent n this           next  =  []++> message n p c = "Line "++show n++": "++p++" line before "++c++" line."++The main program gets name "file", reads "file.lhs", and either+writes the corresponding program to "file.hs" or prints error+messages on "stdout".++> main    :: IO ()+> main     = do strs <- getArgs+>               case strs of+>                 [str] -> delit str+>                 _     -> fail "Too many or too few arguments"++> delit f  = do lhs <- readFile (f ++ ".lhs")+>               case (process lhs) of+>	          ([],hs) -> writeFile (f ++ ".hs") hs+>	          (es,_)  -> putStr es+
+ StrategyLib-4.0-beta/examples/haskell/Makefile view
@@ -0,0 +1,61 @@+# refer to StrategyLib top-level directory+StrategyLib = ../..+Model       = drift-default++# find source of Language.Haskell.Syntax+Syntax      = ${shell locate -n1 libraries/Language/Haskell/Syntax.hs}++# list the modules to be derived with DrIFT+derive=SyntaxTermInstances.hs++# include the reusable makerules+include ${StrategyLib}/scripts/makerules.opts+include ${StrategyLib}/scripts/makerules.run+include ${StrategyLib}/scripts/makerules.drift+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.recurse++hugs-opts   += +N +o++## The top level targets:++check-hugs: check-HsTransform-hugs check-HsExtract-hugs++check-ghci:++check-ghc: check-HsTransform-ghc check-HsExtract-ghc++## Auxiliary targets:++check-HsExtract-hugs: derive+	(cd testsuite; runhugs Top)+	$(RM) -rf out+	mkdir out+	runhugs ${hugs-opts} HsExtract.hs testsuite Top out+	(cd out; runhugs Top)+	+check-HsExtract-ghc: derive+	(cd testsuite; runhugs Top)+	$(RM) -rf out+	mkdir out+	ghc ${ghc-opts} --make HsExtract.hs -o HsExtract+	./HsExtract testsuite Top out+	(cd out; runhugs Top)++check-HsTransform-hugs: derive+	$(RM) -f TestDoElim_out.hs+	runhugs ${hugs-opts} HsTransform.hs TestDoElim.hs TestDoElim_out.hs+	diff TestDoElim_out.hs TestDoElim_correct.hs++check-HsTransform-ghc: derive+	$(RM) -f TestDoElim_out.hs+	ghc ${ghc-opts} --make HsTransform.hs -o HsTransform+	./HsTransform TestDoElim.hs TestDoElim_out.hs+	diff TestDoElim_out.hs TestDoElim_correct.hs++SyntaxTermInstances.hs: ${Syntax}+	echo "module SyntaxTermInstances where" > $@+	echo "import Language.Haskell.Syntax" >> $@+	echo "import TermRep" >> $@+	DrIFT -g Term -g Typeable -r $< >> $@+
+ StrategyLib-4.0-beta/examples/haskell/NewTypeIntro.hs view
@@ -0,0 +1,32 @@+module NewTypeIntro where++-------------------------------------------------------------------------------++--- This module implements a "data" to "newtype" conversion++-------------------------------------------------------------------------------++import Language.Haskell.Syntax+import SyntaxTermInstances+import StrategyLib++-- The main transformation function++newtypeIntro :: HsModule -> Maybe HsModule+newtypeIntro =  applyTP (full_tdTP (adhocTP idTP newtypeIntro1))++{-+   This rewrite rule looks for all data declarations which+   should be better newtype declarations. To do so, we need+   to find data declarations with one constructor application.+   In addition, the constructor application is required to+   have exactly one parameter (cf. Haskell 98 report).+-}++newtypeIntro1 :: HsDecl -> Maybe HsDecl+newtypeIntro1 (HsDataDecl s c n ps [cd@(HsConDecl _ _ [_])] ns) +  = Just (HsNewTypeDecl s c n ps cd ns)+newtypeIntro1 x+  = Just x++-------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/haskell/README view
@@ -0,0 +1,29 @@+------------------------------------------------------------------------------++ANALYSIS and TRANSFORMATION of HASKELL ITSELF++1. HsTransform++   This program performs some simple source-to-source+   transformations on Haskell programs, namely:+   +   o Elimination of "do" expressions, +     see Haskell Report section 3.14+     +   o Introduction of "newtype" declarations,+     in favour of particular "data" declarations.+++2. HsExtract++   This program performs "Application Extraction" for Haskell.+   Given a set of user modules and library modules it extracts+   a set of modules that only contain functions reachable from+   the top level functions of a given Top module.+++For both programs, we make use of the Haskell abstract syntax, parser, and+pretty-printer as provided by the library package Language.Haskell.++------------------------------------------------------------------------------+
+ StrategyLib-4.0-beta/examples/haskell/SyntaxTermInstances.hs view
@@ -0,0 +1,443 @@+module SyntaxTermInstances where+import Language.Haskell.Syntax+import TermRep+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "/usr/lib/hugs/libraries/Language/Haskell/Syntax.hs" #-}+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Term SrcLoc where+    explode (x::SrcLoc) = TermRep (toDyn x, f x, g x) where+	f (SrcLoc aa ab ac) = [explode aa,explode ab,explode ac]+	g (SrcLoc _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac] -> toDyn ((SrcLoc (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac))::SrcLoc) ; _ -> error "Term explosion error."++-- _tc_SrcLocTc = mkTyCon "SrcLoc"+-- instance Typeable SrcLoc where+--     typeOf x = mkTyConApp _tc_SrcLocTc [ ]++instance Term Module where+    explode (x::Module) = TermRep (toDyn x, f x, g x) where+	f (Module aa) = [explode aa]+	g (Module _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((Module (TermRep.fDyn aa))::Module) ; _ -> error "Term explosion error."++-- _tc_ModuleTc = mkTyCon "Module"+-- instance Typeable Module where+--     typeOf x = mkTyConApp _tc_ModuleTc [ ]++instance Term HsSpecialCon where+    explode (x::HsSpecialCon) = TermRep (toDyn x, f x, g x) where+	f HsUnitCon = []+	f HsListCon = []+	f HsFunCon = []+	f (HsTupleCon aa) = [explode aa]+	f HsCons = []+	g HsUnitCon xs = case TermRep.fArgs xs of [] -> toDyn ((HsUnitCon)::HsSpecialCon) ; _ -> error "Term explosion error."+	g HsListCon xs = case TermRep.fArgs xs of [] -> toDyn ((HsListCon)::HsSpecialCon) ; _ -> error "Term explosion error."+	g HsFunCon xs = case TermRep.fArgs xs of [] -> toDyn ((HsFunCon)::HsSpecialCon) ; _ -> error "Term explosion error."+	g (HsTupleCon _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsTupleCon (TermRep.fDyn aa))::HsSpecialCon) ; _ -> error "Term explosion error."+	g HsCons xs = case TermRep.fArgs xs of [] -> toDyn ((HsCons)::HsSpecialCon) ; _ -> error "Term explosion error."++-- _tc_HsSpecialConTc = mkTyCon "HsSpecialCon"+-- instance Typeable HsSpecialCon where+--     typeOf x = mkTyConApp _tc_HsSpecialConTc [ ]++instance Term HsQName where+    explode (x::HsQName) = TermRep (toDyn x, f x, g x) where+	f (Qual aa ab) = [explode aa,explode ab]+	f (UnQual ac) = [explode ac]+	f (Special ad) = [explode ad]+	g (Qual _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((Qual (TermRep.fDyn aa) (TermRep.fDyn ab))::HsQName) ; _ -> error "Term explosion error."+	g (UnQual _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((UnQual (TermRep.fDyn ac))::HsQName) ; _ -> error "Term explosion error."+	g (Special _) xs = case TermRep.fArgs xs of [ad] -> toDyn ((Special (TermRep.fDyn ad))::HsQName) ; _ -> error "Term explosion error."++-- _tc_HsQNameTc = mkTyCon "HsQName"+-- instance Typeable HsQName where+--     typeOf x = mkTyConApp _tc_HsQNameTc [ ]++instance Term HsName where+    explode (x::HsName) = TermRep (toDyn x, f x, g x) where+	f (HsIdent aa) = [explode aa]+	f (HsSymbol ab) = [explode ab]+	g (HsIdent _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsIdent (TermRep.fDyn aa))::HsName) ; _ -> error "Term explosion error."+	g (HsSymbol _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsSymbol (TermRep.fDyn ab))::HsName) ; _ -> error "Term explosion error."++-- _tc_HsNameTc = mkTyCon "HsName"+-- instance Typeable HsName where+--     typeOf x = mkTyConApp _tc_HsNameTc [ ]++instance Term HsQOp where+    explode (x::HsQOp) = TermRep (toDyn x, f x, g x) where+	f (HsQVarOp aa) = [explode aa]+	f (HsQConOp ab) = [explode ab]+	g (HsQVarOp _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsQVarOp (TermRep.fDyn aa))::HsQOp) ; _ -> error "Term explosion error."+	g (HsQConOp _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsQConOp (TermRep.fDyn ab))::HsQOp) ; _ -> error "Term explosion error."++-- _tc_HsQOpTc = mkTyCon "HsQOp"+-- instance Typeable HsQOp where+--     typeOf x = mkTyConApp _tc_HsQOpTc [ ]++instance Term HsOp where+    explode (x::HsOp) = TermRep (toDyn x, f x, g x) where+	f (HsVarOp aa) = [explode aa]+	f (HsConOp ab) = [explode ab]+	g (HsVarOp _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsVarOp (TermRep.fDyn aa))::HsOp) ; _ -> error "Term explosion error."+	g (HsConOp _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsConOp (TermRep.fDyn ab))::HsOp) ; _ -> error "Term explosion error."++-- _tc_HsOpTc = mkTyCon "HsOp"+-- instance Typeable HsOp where+--     typeOf x = mkTyConApp _tc_HsOpTc [ ]++instance Term HsCName where+    explode (x::HsCName) = TermRep (toDyn x, f x, g x) where+	f (HsVarName aa) = [explode aa]+	f (HsConName ab) = [explode ab]+	g (HsVarName _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsVarName (TermRep.fDyn aa))::HsCName) ; _ -> error "Term explosion error."+	g (HsConName _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsConName (TermRep.fDyn ab))::HsCName) ; _ -> error "Term explosion error."++-- _tc_HsCNameTc = mkTyCon "HsCName"+-- instance Typeable HsCName where+--     typeOf x = mkTyConApp _tc_HsCNameTc [ ]++instance Term HsModule where+    explode (x::HsModule) = TermRep (toDyn x, f x, g x) where+	f (HsModule aa ab ac ad ae) = [explode aa,explode ab,explode ac,explode ad,explode ae]+	g (HsModule _ _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad,ae] -> toDyn ((HsModule (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad) (TermRep.fDyn ae))::HsModule) ; _ -> error "Term explosion error."++-- _tc_HsModuleTc = mkTyCon "HsModule"+-- instance Typeable HsModule where+--     typeOf x = mkTyConApp _tc_HsModuleTc [ ]++instance Term HsExportSpec where+    explode (x::HsExportSpec) = TermRep (toDyn x, f x, g x) where+	f (HsEVar aa) = [explode aa]+	f (HsEAbs ab) = [explode ab]+	f (HsEThingAll ac) = [explode ac]+	f (HsEThingWith ad ae) = [explode ad,explode ae]+	f (HsEModuleContents af) = [explode af]+	g (HsEVar _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsEVar (TermRep.fDyn aa))::HsExportSpec) ; _ -> error "Term explosion error."+	g (HsEAbs _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsEAbs (TermRep.fDyn ab))::HsExportSpec) ; _ -> error "Term explosion error."+	g (HsEThingAll _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((HsEThingAll (TermRep.fDyn ac))::HsExportSpec) ; _ -> error "Term explosion error."+	g (HsEThingWith _ _) xs = case TermRep.fArgs xs of [ad,ae] -> toDyn ((HsEThingWith (TermRep.fDyn ad) (TermRep.fDyn ae))::HsExportSpec) ; _ -> error "Term explosion error."+	g (HsEModuleContents _) xs = case TermRep.fArgs xs of [af] -> toDyn ((HsEModuleContents (TermRep.fDyn af))::HsExportSpec) ; _ -> error "Term explosion error."++-- _tc_HsExportSpecTc = mkTyCon "HsExportSpec"+-- instance Typeable HsExportSpec where+--     typeOf x = mkTyConApp _tc_HsExportSpecTc [ ]++instance Term HsImportDecl where+    explode (x::HsImportDecl) = TermRep (toDyn x, f x, g x) where+	f (HsImportDecl aa ab ac ad ae) = [explode aa,explode ab,explode ac,explode ad,explode ae]+	g (HsImportDecl _ _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad,ae] -> toDyn ((HsImportDecl (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad) (TermRep.fDyn ae))::HsImportDecl) ; _ -> error "Term explosion error."++-- _tc_HsImportDeclTc = mkTyCon "HsImportDecl"+-- instance Typeable HsImportDecl where+--     typeOf x = mkTyConApp _tc_HsImportDeclTc [ ]++instance Term HsImportSpec where+    explode (x::HsImportSpec) = TermRep (toDyn x, f x, g x) where+	f (HsIVar aa) = [explode aa]+	f (HsIAbs ab) = [explode ab]+	f (HsIThingAll ac) = [explode ac]+	f (HsIThingWith ad ae) = [explode ad,explode ae]+	g (HsIVar _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsIVar (TermRep.fDyn aa))::HsImportSpec) ; _ -> error "Term explosion error."+	g (HsIAbs _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsIAbs (TermRep.fDyn ab))::HsImportSpec) ; _ -> error "Term explosion error."+	g (HsIThingAll _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((HsIThingAll (TermRep.fDyn ac))::HsImportSpec) ; _ -> error "Term explosion error."+	g (HsIThingWith _ _) xs = case TermRep.fArgs xs of [ad,ae] -> toDyn ((HsIThingWith (TermRep.fDyn ad) (TermRep.fDyn ae))::HsImportSpec) ; _ -> error "Term explosion error."++-- _tc_HsImportSpecTc = mkTyCon "HsImportSpec"+-- instance Typeable HsImportSpec where+--     typeOf x = mkTyConApp _tc_HsImportSpecTc [ ]++instance Term HsAssoc where+    explode (x::HsAssoc) = TermRep (toDyn x, f x, g x) where+	f HsAssocNone = []+	f HsAssocLeft = []+	f HsAssocRight = []+	g HsAssocNone xs = case TermRep.fArgs xs of [] -> toDyn ((HsAssocNone)::HsAssoc) ; _ -> error "Term explosion error."+	g HsAssocLeft xs = case TermRep.fArgs xs of [] -> toDyn ((HsAssocLeft)::HsAssoc) ; _ -> error "Term explosion error."+	g HsAssocRight xs = case TermRep.fArgs xs of [] -> toDyn ((HsAssocRight)::HsAssoc) ; _ -> error "Term explosion error."++-- _tc_HsAssocTc = mkTyCon "HsAssoc"+-- instance Typeable HsAssoc where+--     typeOf x = mkTyConApp _tc_HsAssocTc [ ]++instance Term HsDecl where+    explode (x::HsDecl) = TermRep (toDyn x, f x, g x) where+	f (HsTypeDecl aa ab ac ad) = [explode aa,explode ab,explode ac,explode ad]+	f (HsDataDecl ae af ag ah ai aj) = [explode ae,explode af,explode ag,explode ah,explode ai,explode aj]+	f (HsInfixDecl ak al am an) = [explode ak,explode al,explode am,explode an]+	f (HsNewTypeDecl ao ap aq ar as at) = [explode ao,explode ap,explode aq,explode ar,explode as,explode at]+	f (HsClassDecl au av aw ax ay) = [explode au,explode av,explode aw,explode ax,explode ay]+	f (HsInstDecl az aA aB aC aD) = [explode az,explode aA,explode aB,explode aC,explode aD]+	f (HsDefaultDecl aE aF) = [explode aE,explode aF]+	f (HsTypeSig aG aH aI) = [explode aG,explode aH,explode aI]+	f (HsFunBind aJ) = [explode aJ]+	f (HsPatBind aK aL aM aN) = [explode aK,explode aL,explode aM,explode aN]+	g (HsTypeDecl _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad] -> toDyn ((HsTypeDecl (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad))::HsDecl) ; _ -> error "Term explosion error."+	g (HsDataDecl _ _ _ _ _ _) xs = case TermRep.fArgs xs of [ae,af,ag,ah,ai,aj] -> toDyn ((HsDataDecl (TermRep.fDyn ae) (TermRep.fDyn af) (TermRep.fDyn ag) (TermRep.fDyn ah) (TermRep.fDyn ai) (TermRep.fDyn aj))::HsDecl) ; _ -> error "Term explosion error."+	g (HsInfixDecl _ _ _ _) xs = case TermRep.fArgs xs of [ak,al,am,an] -> toDyn ((HsInfixDecl (TermRep.fDyn ak) (TermRep.fDyn al) (TermRep.fDyn am) (TermRep.fDyn an))::HsDecl) ; _ -> error "Term explosion error."+	g (HsNewTypeDecl _ _ _ _ _ _) xs = case TermRep.fArgs xs of [ao,ap,aq,ar,as,at] -> toDyn ((HsNewTypeDecl (TermRep.fDyn ao) (TermRep.fDyn ap) (TermRep.fDyn aq) (TermRep.fDyn ar) (TermRep.fDyn as) (TermRep.fDyn at))::HsDecl) ; _ -> error "Term explosion error."+	g (HsClassDecl _ _ _ _ _) xs = case TermRep.fArgs xs of [au,av,aw,ax,ay] -> toDyn ((HsClassDecl (TermRep.fDyn au) (TermRep.fDyn av) (TermRep.fDyn aw) (TermRep.fDyn ax) (TermRep.fDyn ay))::HsDecl) ; _ -> error "Term explosion error."+	g (HsInstDecl _ _ _ _ _) xs = case TermRep.fArgs xs of [az,aA,aB,aC,aD] -> toDyn ((HsInstDecl (TermRep.fDyn az) (TermRep.fDyn aA) (TermRep.fDyn aB) (TermRep.fDyn aC) (TermRep.fDyn aD))::HsDecl) ; _ -> error "Term explosion error."+	g (HsDefaultDecl _ _) xs = case TermRep.fArgs xs of [aE,aF] -> toDyn ((HsDefaultDecl (TermRep.fDyn aE) (TermRep.fDyn aF))::HsDecl) ; _ -> error "Term explosion error."+	g (HsTypeSig _ _ _) xs = case TermRep.fArgs xs of [aG,aH,aI] -> toDyn ((HsTypeSig (TermRep.fDyn aG) (TermRep.fDyn aH) (TermRep.fDyn aI))::HsDecl) ; _ -> error "Term explosion error."+	g (HsFunBind _) xs = case TermRep.fArgs xs of [aJ] -> toDyn ((HsFunBind (TermRep.fDyn aJ))::HsDecl) ; _ -> error "Term explosion error."+	g (HsPatBind _ _ _ _) xs = case TermRep.fArgs xs of [aK,aL,aM,aN] -> toDyn ((HsPatBind (TermRep.fDyn aK) (TermRep.fDyn aL) (TermRep.fDyn aM) (TermRep.fDyn aN))::HsDecl) ; _ -> error "Term explosion error."++-- _tc_HsDeclTc = mkTyCon "HsDecl"+-- instance Typeable HsDecl where+--     typeOf x = mkTyConApp _tc_HsDeclTc [ ]++instance Term HsMatch where+    explode (x::HsMatch) = TermRep (toDyn x, f x, g x) where+	f (HsMatch aa ab ac ad ae) = [explode aa,explode ab,explode ac,explode ad,explode ae]+	g (HsMatch _ _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad,ae] -> toDyn ((HsMatch (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad) (TermRep.fDyn ae))::HsMatch) ; _ -> error "Term explosion error."++-- _tc_HsMatchTc = mkTyCon "HsMatch"+-- instance Typeable HsMatch where+--     typeOf x = mkTyConApp _tc_HsMatchTc [ ]++instance Term HsConDecl where+    explode (x::HsConDecl) = TermRep (toDyn x, f x, g x) where+	f (HsConDecl aa ab ac) = [explode aa,explode ab,explode ac]+	f (HsRecDecl ad ae af) = [explode ad,explode ae,explode af]+	g (HsConDecl _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac] -> toDyn ((HsConDecl (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac))::HsConDecl) ; _ -> error "Term explosion error."+	g (HsRecDecl _ _ _) xs = case TermRep.fArgs xs of [ad,ae,af] -> toDyn ((HsRecDecl (TermRep.fDyn ad) (TermRep.fDyn ae) (TermRep.fDyn af))::HsConDecl) ; _ -> error "Term explosion error."++-- _tc_HsConDeclTc = mkTyCon "HsConDecl"+-- instance Typeable HsConDecl where+--     typeOf x = mkTyConApp _tc_HsConDeclTc [ ]++instance Term HsBangType where+    explode (x::HsBangType) = TermRep (toDyn x, f x, g x) where+	f (HsBangedTy aa) = [explode aa]+	f (HsUnBangedTy ab) = [explode ab]+	g (HsBangedTy _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsBangedTy (TermRep.fDyn aa))::HsBangType) ; _ -> error "Term explosion error."+	g (HsUnBangedTy _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsUnBangedTy (TermRep.fDyn ab))::HsBangType) ; _ -> error "Term explosion error."++-- _tc_HsBangTypeTc = mkTyCon "HsBangType"+-- instance Typeable HsBangType where+--     typeOf x = mkTyConApp _tc_HsBangTypeTc [ ]++instance Term HsRhs where+    explode (x::HsRhs) = TermRep (toDyn x, f x, g x) where+	f (HsUnGuardedRhs aa) = [explode aa]+	f (HsGuardedRhss ab) = [explode ab]+	g (HsUnGuardedRhs _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsUnGuardedRhs (TermRep.fDyn aa))::HsRhs) ; _ -> error "Term explosion error."+	g (HsGuardedRhss _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsGuardedRhss (TermRep.fDyn ab))::HsRhs) ; _ -> error "Term explosion error."++-- _tc_HsRhsTc = mkTyCon "HsRhs"+-- instance Typeable HsRhs where+--     typeOf x = mkTyConApp _tc_HsRhsTc [ ]++instance Term HsGuardedRhs where+    explode (x::HsGuardedRhs) = TermRep (toDyn x, f x, g x) where+	f (HsGuardedRhs aa ab ac) = [explode aa,explode ab,explode ac]+	g (HsGuardedRhs _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac] -> toDyn ((HsGuardedRhs (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac))::HsGuardedRhs) ; _ -> error "Term explosion error."++-- _tc_HsGuardedRhsTc = mkTyCon "HsGuardedRhs"+-- instance Typeable HsGuardedRhs where+--     typeOf x = mkTyConApp _tc_HsGuardedRhsTc [ ]++instance Term HsQualType where+    explode (x::HsQualType) = TermRep (toDyn x, f x, g x) where+	f (HsQualType aa ab) = [explode aa,explode ab]+	g (HsQualType _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((HsQualType (TermRep.fDyn aa) (TermRep.fDyn ab))::HsQualType) ; _ -> error "Term explosion error."++-- _tc_HsQualTypeTc = mkTyCon "HsQualType"+-- instance Typeable HsQualType where+--     typeOf x = mkTyConApp _tc_HsQualTypeTc [ ]++instance Term HsType where+    explode (x::HsType) = TermRep (toDyn x, f x, g x) where+	f (HsTyFun aa ab) = [explode aa,explode ab]+	f (HsTyTuple ac) = [explode ac]+	f (HsTyApp ad ae) = [explode ad,explode ae]+	f (HsTyVar af) = [explode af]+	f (HsTyCon ag) = [explode ag]+	g (HsTyFun _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((HsTyFun (TermRep.fDyn aa) (TermRep.fDyn ab))::HsType) ; _ -> error "Term explosion error."+	g (HsTyTuple _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((HsTyTuple (TermRep.fDyn ac))::HsType) ; _ -> error "Term explosion error."+	g (HsTyApp _ _) xs = case TermRep.fArgs xs of [ad,ae] -> toDyn ((HsTyApp (TermRep.fDyn ad) (TermRep.fDyn ae))::HsType) ; _ -> error "Term explosion error."+	g (HsTyVar _) xs = case TermRep.fArgs xs of [af] -> toDyn ((HsTyVar (TermRep.fDyn af))::HsType) ; _ -> error "Term explosion error."+	g (HsTyCon _) xs = case TermRep.fArgs xs of [ag] -> toDyn ((HsTyCon (TermRep.fDyn ag))::HsType) ; _ -> error "Term explosion error."++-- _tc_HsTypeTc = mkTyCon "HsType"+-- instance Typeable HsType where+--     typeOf x = mkTyConApp _tc_HsTypeTc [ ]++instance Term HsLiteral where+    explode (x::HsLiteral) = TermRep (toDyn x, f x, g x) where+	f (HsInt aa) = [explode aa]+	f (HsChar ab) = [explode ab]+	f (HsString ac) = [explode ac]+	f (HsFrac ad) = [explode ad]+	f (HsCharPrim ae) = [explode ae]+	f (HsStringPrim af) = [explode af]+	f (HsIntPrim ag) = [explode ag]+	f (HsFloatPrim ah) = [explode ah]+	f (HsDoublePrim ai) = [explode ai]+	g (HsInt _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsInt (TermRep.fDyn aa))::HsLiteral) ; _ -> error "Term explosion error."+	g (HsChar _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsChar (TermRep.fDyn ab))::HsLiteral) ; _ -> error "Term explosion error."+	g (HsString _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((HsString (TermRep.fDyn ac))::HsLiteral) ; _ -> error "Term explosion error."+	g (HsFrac _) xs = case TermRep.fArgs xs of [ad] -> toDyn ((HsFrac (TermRep.fDyn ad))::HsLiteral) ; _ -> error "Term explosion error."+	g (HsCharPrim _) xs = case TermRep.fArgs xs of [ae] -> toDyn ((HsCharPrim (TermRep.fDyn ae))::HsLiteral) ; _ -> error "Term explosion error."+	g (HsStringPrim _) xs = case TermRep.fArgs xs of [af] -> toDyn ((HsStringPrim (TermRep.fDyn af))::HsLiteral) ; _ -> error "Term explosion error."+	g (HsIntPrim _) xs = case TermRep.fArgs xs of [ag] -> toDyn ((HsIntPrim (TermRep.fDyn ag))::HsLiteral) ; _ -> error "Term explosion error."+	g (HsFloatPrim _) xs = case TermRep.fArgs xs of [ah] -> toDyn ((HsFloatPrim (TermRep.fDyn ah))::HsLiteral) ; _ -> error "Term explosion error."+	g (HsDoublePrim _) xs = case TermRep.fArgs xs of [ai] -> toDyn ((HsDoublePrim (TermRep.fDyn ai))::HsLiteral) ; _ -> error "Term explosion error."++-- _tc_HsLiteralTc = mkTyCon "HsLiteral"+-- instance Typeable HsLiteral where+--     typeOf x = mkTyConApp _tc_HsLiteralTc [ ]++instance Term HsExp where+    explode (x::HsExp) = TermRep (toDyn x, f x, g x) where+	f (HsVar aa) = [explode aa]+	f (HsCon ab) = [explode ab]+	f (HsLit ac) = [explode ac]+	f (HsInfixApp ad ae af) = [explode ad,explode ae,explode af]+	f (HsApp ag ah) = [explode ag,explode ah]+	f (HsNegApp ai) = [explode ai]+	f (HsLambda aj ak al) = [explode aj,explode ak,explode al]+	f (HsLet am an) = [explode am,explode an]+	f (HsIf ao ap aq) = [explode ao,explode ap,explode aq]+	f (HsCase ar as) = [explode ar,explode as]+	f (HsDo at) = [explode at]+	f (HsTuple au) = [explode au]+	f (HsList av) = [explode av]+	f (HsParen aw) = [explode aw]+	f (HsLeftSection ax ay) = [explode ax,explode ay]+	f (HsRightSection az aA) = [explode az,explode aA]+	f (HsRecConstr aB aC) = [explode aB,explode aC]+	f (HsRecUpdate aD aE) = [explode aD,explode aE]+	f (HsEnumFrom aF) = [explode aF]+	f (HsEnumFromTo aG aH) = [explode aG,explode aH]+	f (HsEnumFromThen aI aJ) = [explode aI,explode aJ]+	f (HsEnumFromThenTo aK aL aM) = [explode aK,explode aL,explode aM]+	f (HsListComp aN aO) = [explode aN,explode aO]+	f (HsExpTypeSig aP aQ aR) = [explode aP,explode aQ,explode aR]+	f (HsAsPat aS aT) = [explode aS,explode aT]+	f HsWildCard = []+	f (HsIrrPat aU) = [explode aU]+	g (HsVar _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsVar (TermRep.fDyn aa))::HsExp) ; _ -> error "Term explosion error."+	g (HsCon _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsCon (TermRep.fDyn ab))::HsExp) ; _ -> error "Term explosion error."+	g (HsLit _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((HsLit (TermRep.fDyn ac))::HsExp) ; _ -> error "Term explosion error."+	g (HsInfixApp _ _ _) xs = case TermRep.fArgs xs of [ad,ae,af] -> toDyn ((HsInfixApp (TermRep.fDyn ad) (TermRep.fDyn ae) (TermRep.fDyn af))::HsExp) ; _ -> error "Term explosion error."+	g (HsApp _ _) xs = case TermRep.fArgs xs of [ag,ah] -> toDyn ((HsApp (TermRep.fDyn ag) (TermRep.fDyn ah))::HsExp) ; _ -> error "Term explosion error."+	g (HsNegApp _) xs = case TermRep.fArgs xs of [ai] -> toDyn ((HsNegApp (TermRep.fDyn ai))::HsExp) ; _ -> error "Term explosion error."+	g (HsLambda _ _ _) xs = case TermRep.fArgs xs of [aj,ak,al] -> toDyn ((HsLambda (TermRep.fDyn aj) (TermRep.fDyn ak) (TermRep.fDyn al))::HsExp) ; _ -> error "Term explosion error."+	g (HsLet _ _) xs = case TermRep.fArgs xs of [am,an] -> toDyn ((HsLet (TermRep.fDyn am) (TermRep.fDyn an))::HsExp) ; _ -> error "Term explosion error."+	g (HsIf _ _ _) xs = case TermRep.fArgs xs of [ao,ap,aq] -> toDyn ((HsIf (TermRep.fDyn ao) (TermRep.fDyn ap) (TermRep.fDyn aq))::HsExp) ; _ -> error "Term explosion error."+	g (HsCase _ _) xs = case TermRep.fArgs xs of [ar,as] -> toDyn ((HsCase (TermRep.fDyn ar) (TermRep.fDyn as))::HsExp) ; _ -> error "Term explosion error."+	g (HsDo _) xs = case TermRep.fArgs xs of [at] -> toDyn ((HsDo (TermRep.fDyn at))::HsExp) ; _ -> error "Term explosion error."+	g (HsTuple _) xs = case TermRep.fArgs xs of [au] -> toDyn ((HsTuple (TermRep.fDyn au))::HsExp) ; _ -> error "Term explosion error."+	g (HsList _) xs = case TermRep.fArgs xs of [av] -> toDyn ((HsList (TermRep.fDyn av))::HsExp) ; _ -> error "Term explosion error."+	g (HsParen _) xs = case TermRep.fArgs xs of [aw] -> toDyn ((HsParen (TermRep.fDyn aw))::HsExp) ; _ -> error "Term explosion error."+	g (HsLeftSection _ _) xs = case TermRep.fArgs xs of [ax,ay] -> toDyn ((HsLeftSection (TermRep.fDyn ax) (TermRep.fDyn ay))::HsExp) ; _ -> error "Term explosion error."+	g (HsRightSection _ _) xs = case TermRep.fArgs xs of [az,aA] -> toDyn ((HsRightSection (TermRep.fDyn az) (TermRep.fDyn aA))::HsExp) ; _ -> error "Term explosion error."+	g (HsRecConstr _ _) xs = case TermRep.fArgs xs of [aB,aC] -> toDyn ((HsRecConstr (TermRep.fDyn aB) (TermRep.fDyn aC))::HsExp) ; _ -> error "Term explosion error."+	g (HsRecUpdate _ _) xs = case TermRep.fArgs xs of [aD,aE] -> toDyn ((HsRecUpdate (TermRep.fDyn aD) (TermRep.fDyn aE))::HsExp) ; _ -> error "Term explosion error."+	g (HsEnumFrom _) xs = case TermRep.fArgs xs of [aF] -> toDyn ((HsEnumFrom (TermRep.fDyn aF))::HsExp) ; _ -> error "Term explosion error."+	g (HsEnumFromTo _ _) xs = case TermRep.fArgs xs of [aG,aH] -> toDyn ((HsEnumFromTo (TermRep.fDyn aG) (TermRep.fDyn aH))::HsExp) ; _ -> error "Term explosion error."+	g (HsEnumFromThen _ _) xs = case TermRep.fArgs xs of [aI,aJ] -> toDyn ((HsEnumFromThen (TermRep.fDyn aI) (TermRep.fDyn aJ))::HsExp) ; _ -> error "Term explosion error."+	g (HsEnumFromThenTo _ _ _) xs = case TermRep.fArgs xs of [aK,aL,aM] -> toDyn ((HsEnumFromThenTo (TermRep.fDyn aK) (TermRep.fDyn aL) (TermRep.fDyn aM))::HsExp) ; _ -> error "Term explosion error."+	g (HsListComp _ _) xs = case TermRep.fArgs xs of [aN,aO] -> toDyn ((HsListComp (TermRep.fDyn aN) (TermRep.fDyn aO))::HsExp) ; _ -> error "Term explosion error."+	g (HsExpTypeSig _ _ _) xs = case TermRep.fArgs xs of [aP,aQ,aR] -> toDyn ((HsExpTypeSig (TermRep.fDyn aP) (TermRep.fDyn aQ) (TermRep.fDyn aR))::HsExp) ; _ -> error "Term explosion error."+	g (HsAsPat _ _) xs = case TermRep.fArgs xs of [aS,aT] -> toDyn ((HsAsPat (TermRep.fDyn aS) (TermRep.fDyn aT))::HsExp) ; _ -> error "Term explosion error."+	g HsWildCard xs = case TermRep.fArgs xs of [] -> toDyn ((HsWildCard)::HsExp) ; _ -> error "Term explosion error."+	g (HsIrrPat _) xs = case TermRep.fArgs xs of [aU] -> toDyn ((HsIrrPat (TermRep.fDyn aU))::HsExp) ; _ -> error "Term explosion error."++-- _tc_HsExpTc = mkTyCon "HsExp"+-- instance Typeable HsExp where+--     typeOf x = mkTyConApp _tc_HsExpTc [ ]++instance Term HsPat where+    explode (x::HsPat) = TermRep (toDyn x, f x, g x) where+	f (HsPVar aa) = [explode aa]+	f (HsPLit ab) = [explode ab]+	f (HsPNeg ac) = [explode ac]+	f (HsPInfixApp ad ae af) = [explode ad,explode ae,explode af]+	f (HsPApp ag ah) = [explode ag,explode ah]+	f (HsPTuple ai) = [explode ai]+	f (HsPList aj) = [explode aj]+	f (HsPParen ak) = [explode ak]+	f (HsPRec al am) = [explode al,explode am]+	f (HsPAsPat an ao) = [explode an,explode ao]+	f HsPWildCard = []+	f (HsPIrrPat ap) = [explode ap]+	g (HsPVar _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsPVar (TermRep.fDyn aa))::HsPat) ; _ -> error "Term explosion error."+	g (HsPLit _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsPLit (TermRep.fDyn ab))::HsPat) ; _ -> error "Term explosion error."+	g (HsPNeg _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((HsPNeg (TermRep.fDyn ac))::HsPat) ; _ -> error "Term explosion error."+	g (HsPInfixApp _ _ _) xs = case TermRep.fArgs xs of [ad,ae,af] -> toDyn ((HsPInfixApp (TermRep.fDyn ad) (TermRep.fDyn ae) (TermRep.fDyn af))::HsPat) ; _ -> error "Term explosion error."+	g (HsPApp _ _) xs = case TermRep.fArgs xs of [ag,ah] -> toDyn ((HsPApp (TermRep.fDyn ag) (TermRep.fDyn ah))::HsPat) ; _ -> error "Term explosion error."+	g (HsPTuple _) xs = case TermRep.fArgs xs of [ai] -> toDyn ((HsPTuple (TermRep.fDyn ai))::HsPat) ; _ -> error "Term explosion error."+	g (HsPList _) xs = case TermRep.fArgs xs of [aj] -> toDyn ((HsPList (TermRep.fDyn aj))::HsPat) ; _ -> error "Term explosion error."+	g (HsPParen _) xs = case TermRep.fArgs xs of [ak] -> toDyn ((HsPParen (TermRep.fDyn ak))::HsPat) ; _ -> error "Term explosion error."+	g (HsPRec _ _) xs = case TermRep.fArgs xs of [al,am] -> toDyn ((HsPRec (TermRep.fDyn al) (TermRep.fDyn am))::HsPat) ; _ -> error "Term explosion error."+	g (HsPAsPat _ _) xs = case TermRep.fArgs xs of [an,ao] -> toDyn ((HsPAsPat (TermRep.fDyn an) (TermRep.fDyn ao))::HsPat) ; _ -> error "Term explosion error."+	g HsPWildCard xs = case TermRep.fArgs xs of [] -> toDyn ((HsPWildCard)::HsPat) ; _ -> error "Term explosion error."+	g (HsPIrrPat _) xs = case TermRep.fArgs xs of [ap] -> toDyn ((HsPIrrPat (TermRep.fDyn ap))::HsPat) ; _ -> error "Term explosion error."++-- _tc_HsPatTc = mkTyCon "HsPat"+-- instance Typeable HsPat where+--     typeOf x = mkTyConApp _tc_HsPatTc [ ]++instance Term HsPatField where+    explode (x::HsPatField) = TermRep (toDyn x, f x, g x) where+	f (HsPFieldPat aa ab) = [explode aa,explode ab]+	g (HsPFieldPat _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((HsPFieldPat (TermRep.fDyn aa) (TermRep.fDyn ab))::HsPatField) ; _ -> error "Term explosion error."++-- _tc_HsPatFieldTc = mkTyCon "HsPatField"+-- instance Typeable HsPatField where+--     typeOf x = mkTyConApp _tc_HsPatFieldTc [ ]++instance Term HsStmt where+    explode (x::HsStmt) = TermRep (toDyn x, f x, g x) where+	f (HsGenerator aa ab ac) = [explode aa,explode ab,explode ac]+	f (HsQualifier ad) = [explode ad]+	f (HsLetStmt ae) = [explode ae]+	g (HsGenerator _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac] -> toDyn ((HsGenerator (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac))::HsStmt) ; _ -> error "Term explosion error."+	g (HsQualifier _) xs = case TermRep.fArgs xs of [ad] -> toDyn ((HsQualifier (TermRep.fDyn ad))::HsStmt) ; _ -> error "Term explosion error."+	g (HsLetStmt _) xs = case TermRep.fArgs xs of [ae] -> toDyn ((HsLetStmt (TermRep.fDyn ae))::HsStmt) ; _ -> error "Term explosion error."++-- _tc_HsStmtTc = mkTyCon "HsStmt"+-- instance Typeable HsStmt where+--     typeOf x = mkTyConApp _tc_HsStmtTc [ ]++instance Term HsFieldUpdate where+    explode (x::HsFieldUpdate) = TermRep (toDyn x, f x, g x) where+	f (HsFieldUpdate aa ab) = [explode aa,explode ab]+	g (HsFieldUpdate _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((HsFieldUpdate (TermRep.fDyn aa) (TermRep.fDyn ab))::HsFieldUpdate) ; _ -> error "Term explosion error."++-- _tc_HsFieldUpdateTc = mkTyCon "HsFieldUpdate"+-- instance Typeable HsFieldUpdate where+--     typeOf x = mkTyConApp _tc_HsFieldUpdateTc [ ]++instance Term HsAlt where+    explode (x::HsAlt) = TermRep (toDyn x, f x, g x) where+	f (HsAlt aa ab ac ad) = [explode aa,explode ab,explode ac,explode ad]+	g (HsAlt _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad] -> toDyn ((HsAlt (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad))::HsAlt) ; _ -> error "Term explosion error."++-- _tc_HsAltTc = mkTyCon "HsAlt"+-- instance Typeable HsAlt where+--     typeOf x = mkTyConApp _tc_HsAltTc [ ]++instance Term HsGuardedAlts where+    explode (x::HsGuardedAlts) = TermRep (toDyn x, f x, g x) where+	f (HsUnGuardedAlt aa) = [explode aa]+	f (HsGuardedAlts ab) = [explode ab]+	g (HsUnGuardedAlt _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((HsUnGuardedAlt (TermRep.fDyn aa))::HsGuardedAlts) ; _ -> error "Term explosion error."+	g (HsGuardedAlts _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((HsGuardedAlts (TermRep.fDyn ab))::HsGuardedAlts) ; _ -> error "Term explosion error."++-- _tc_HsGuardedAltsTc = mkTyCon "HsGuardedAlts"+-- instance Typeable HsGuardedAlts where+--     typeOf x = mkTyConApp _tc_HsGuardedAltsTc [ ]++instance Term HsGuardedAlt where+    explode (x::HsGuardedAlt) = TermRep (toDyn x, f x, g x) where+	f (HsGuardedAlt aa ab ac) = [explode aa,explode ab,explode ac]+	g (HsGuardedAlt _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac] -> toDyn ((HsGuardedAlt (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac))::HsGuardedAlt) ; _ -> error "Term explosion error."++-- _tc_HsGuardedAltTc = mkTyCon "HsGuardedAlt"+-- instance Typeable HsGuardedAlt where+--     typeOf x = mkTyConApp _tc_HsGuardedAltTc [ ]++--  Imported from other files :-
+ StrategyLib-4.0-beta/examples/haskell/TestDoElim.hs view
@@ -0,0 +1,7 @@+module TestDoElim where++main = do putStrLn "Hello World"+          let hello =  "Hello"+	  world     <- return "World"+	  do let again = "Again"+	     putStrLn (hello++" "++world++" "++again)
+ StrategyLib-4.0-beta/examples/haskell/TestDoElim_correct.hs view
@@ -0,0 +1,9 @@+module TestDoElim where+main+  = putStrLn "Hello World" >>+      let hello = "Hello" in+        let ok world+              = let again = "Again" in+                  putStrLn (hello ++ " " ++ world ++ " " ++ again)+            ok _ = fail "Error: pattern-match failure in do-expression."+          in return "World" >>= ok
+ StrategyLib-4.0-beta/examples/haskell/testsuite/Bottom.hs view
@@ -0,0 +1,4 @@+module Bottom where++liveFun1 deadVar1 liveVar2+  = [liveVar2]
+ StrategyLib-4.0-beta/examples/haskell/testsuite/DeadModule.hs view
@@ -0,0 +1,4 @@+module DeadModule where++deadFun1 x y+  = [x,y]
+ StrategyLib-4.0-beta/examples/haskell/testsuite/Top.hs view
@@ -0,0 +1,17 @@+module Main where++import Bottom+import DeadModule++main :: IO ()+main = putStr ""++top = liveFun1 1 (liveFun2 2)++liveFun2 liveVar+ = liveFun3 liveVar+   where+     liveFun3 x = x+     deadFun3 y = y++
+ StrategyLib-4.0-beta/examples/joos-padl02/Datatypes.hs view
@@ -0,0 +1,98 @@+{----------------------------------------------------------------------------++Abstract syntax of JOOS, based on:++    David A. Watt. JOOS action semantics. Version 1, available from+    http://www.dcs.gla.ac.uk/~daw/publications/JOOS.ps, October 1997. ++Modifications:++  o StatFocus+  o StringLiterals++----------------------------------------------------------------------------}++module Datatypes where++import TermRep+import Monad++data Assignment		= Assignment Identifier Expression+                          deriving (Eq, Show)+data InstanceCreation	= InstanceCreation Identifier Arguments+                          deriving (Eq, Show)+data MethodInvocation	= ExpressionInvocation Expression Identifier Arguments+			| SuperInvocation Identifier Arguments+                          deriving (Eq, Show)+data Arguments		= Arguments [Expression]+                          deriving (Eq, Show)+data Expression		= Literal Literal+			| Identifier Identifier+			| This+			| PrefixExpr PrefixOperator Expression+			| InfixExpr Expression InfixOperator Expression+			| AndOrExpr Expression AndOr Expression+			| InstanceOf Expression Identifier+			| TypeCast Type Expression+			| BracketExpr Expression+			| AssignmentExpr Assignment+			| InstanceCreationExpr InstanceCreation+			| MethodInvocationExpr MethodInvocation+                          deriving (Eq, Show)+data AndOr		= AND | OR+                          deriving (Eq, Show)+data PrefixOperator	= Neg | Fac+                          deriving (Eq, Show)+data InfixOperator	= Eq | NEQ | Lt | Gt | LEQ | GEQ+			| PLUS | MINUS | MUL | DIV | MOD+                          deriving (Eq, Show)+data Literal		= BooleanLit BooleanLiteral+			| IntegerLit IntegerLiteral+			| Null+			| StringLit StringLiteral+                          deriving (Eq, Show)+data BooleanLiteral	= TRUE | FALSE+                          deriving (Eq, Show)+type IntegerLiteral	= Integer+type StringLiteral	= String+type Identifier		= String++data BlockStatements	= BlockStatements [VariableDeclaration] [Statement]+                          deriving (Eq, Show)+data Statement		= Skip+			| Block BlockStatements+			| AssignmentStat Assignment+			| InstanceCreationStat InstanceCreation+			| MethodInvocationStat MethodInvocation+			| ReturnStat (Maybe Expression)+			| IfStat Expression Statement Statement+			| WhileStat Expression Statement+                       --- Additions+                        | StatFocus Statement+                          deriving (Eq, Show)++data ClassDeclaration	= ClassDecl FinalOpt Identifier Identifier+                            [FieldDeclaration]+                            ConstructorDeclaration+			    [MethodDeclaration]+                          deriving (Eq, Show)+type FinalOpt		= Bool+data FieldDeclaration	= FieldDecl Type Identifier+                          deriving (Eq, Show)+data ConstructorDeclaration+			= ConstructorDecl Identifier FormalParameters+                            Arguments BlockStatements+                          deriving (Eq, Show)+data MethodDeclaration	= MethodDecl (Maybe Type) Identifier FormalParameters+                            BlockStatements+                          deriving (Eq, Show)+data FormalParameters	= FormalParams [FormalParameter]+                          deriving (Eq, Show)+data FormalParameter	= FormalParam Type Identifier+                          deriving (Eq, Show)+data VariableDeclaration+			= VariableDecl Type Identifier+                          deriving (Eq, Show)+data Type		= INT | BOOLEAN | Type Identifier+                          deriving (Eq, Show)+
+ StrategyLib-4.0-beta/examples/joos-padl02/DatatypesTermInstances.hs view
@@ -0,0 +1,263 @@+module DatatypesTermInstances where+import Datatypes+import TermRep+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "Datatypes.hs" #-}+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Term Assignment where+    explode (x::Assignment) = TermRep (toDyn x, f x, g x) where+	f (Assignment aa ab) = [explode aa,explode ab]+	g (Assignment _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((Assignment (TermRep.fDyn aa) (TermRep.fDyn ab))::Assignment) ; _ -> error "Term explosion error."++_tc_AssignmentTc = mkTyCon "Assignment"+instance Typeable Assignment where+    typeOf x = mkTyConApp _tc_AssignmentTc [ ]++instance Term InstanceCreation where+    explode (x::InstanceCreation) = TermRep (toDyn x, f x, g x) where+	f (InstanceCreation aa ab) = [explode aa,explode ab]+	g (InstanceCreation _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((InstanceCreation (TermRep.fDyn aa) (TermRep.fDyn ab))::InstanceCreation) ; _ -> error "Term explosion error."++_tc_InstanceCreationTc = mkTyCon "InstanceCreation"+instance Typeable InstanceCreation where+    typeOf x = mkTyConApp _tc_InstanceCreationTc [ ]++instance Term MethodInvocation where+    explode (x::MethodInvocation) = TermRep (toDyn x, f x, g x) where+	f (ExpressionInvocation aa ab ac) = [explode aa,explode ab,explode ac]+	f (SuperInvocation ad ae) = [explode ad,explode ae]+	g (ExpressionInvocation _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac] -> toDyn ((ExpressionInvocation (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac))::MethodInvocation) ; _ -> error "Term explosion error."+	g (SuperInvocation _ _) xs = case TermRep.fArgs xs of [ad,ae] -> toDyn ((SuperInvocation (TermRep.fDyn ad) (TermRep.fDyn ae))::MethodInvocation) ; _ -> error "Term explosion error."++_tc_MethodInvocationTc = mkTyCon "MethodInvocation"+instance Typeable MethodInvocation where+    typeOf x = mkTyConApp _tc_MethodInvocationTc [ ]++instance Term Arguments where+    explode (x::Arguments) = TermRep (toDyn x, f x, g x) where+	f (Arguments aa) = [explode aa]+	g (Arguments _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((Arguments (TermRep.fDyn aa))::Arguments) ; _ -> error "Term explosion error."++_tc_ArgumentsTc = mkTyCon "Arguments"+instance Typeable Arguments where+    typeOf x = mkTyConApp _tc_ArgumentsTc [ ]++instance Term Expression where+    explode (x::Expression) = TermRep (toDyn x, f x, g x) where+	f (Literal aa) = [explode aa]+	f (Identifier ab) = [explode ab]+	f This = []+	f (PrefixExpr ac ad) = [explode ac,explode ad]+	f (InfixExpr ae af ag) = [explode ae,explode af,explode ag]+	f (AndOrExpr ah ai aj) = [explode ah,explode ai,explode aj]+	f (InstanceOf ak al) = [explode ak,explode al]+	f (TypeCast am an) = [explode am,explode an]+	f (BracketExpr ao) = [explode ao]+	f (AssignmentExpr ap) = [explode ap]+	f (InstanceCreationExpr aq) = [explode aq]+	f (MethodInvocationExpr ar) = [explode ar]+	g (Literal _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((Literal (TermRep.fDyn aa))::Expression) ; _ -> error "Term explosion error."+	g (Identifier _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((Identifier (TermRep.fDyn ab))::Expression) ; _ -> error "Term explosion error."+	g This xs = case TermRep.fArgs xs of [] -> toDyn ((This)::Expression) ; _ -> error "Term explosion error."+	g (PrefixExpr _ _) xs = case TermRep.fArgs xs of [ac,ad] -> toDyn ((PrefixExpr (TermRep.fDyn ac) (TermRep.fDyn ad))::Expression) ; _ -> error "Term explosion error."+	g (InfixExpr _ _ _) xs = case TermRep.fArgs xs of [ae,af,ag] -> toDyn ((InfixExpr (TermRep.fDyn ae) (TermRep.fDyn af) (TermRep.fDyn ag))::Expression) ; _ -> error "Term explosion error."+	g (AndOrExpr _ _ _) xs = case TermRep.fArgs xs of [ah,ai,aj] -> toDyn ((AndOrExpr (TermRep.fDyn ah) (TermRep.fDyn ai) (TermRep.fDyn aj))::Expression) ; _ -> error "Term explosion error."+	g (InstanceOf _ _) xs = case TermRep.fArgs xs of [ak,al] -> toDyn ((InstanceOf (TermRep.fDyn ak) (TermRep.fDyn al))::Expression) ; _ -> error "Term explosion error."+	g (TypeCast _ _) xs = case TermRep.fArgs xs of [am,an] -> toDyn ((TypeCast (TermRep.fDyn am) (TermRep.fDyn an))::Expression) ; _ -> error "Term explosion error."+	g (BracketExpr _) xs = case TermRep.fArgs xs of [ao] -> toDyn ((BracketExpr (TermRep.fDyn ao))::Expression) ; _ -> error "Term explosion error."+	g (AssignmentExpr _) xs = case TermRep.fArgs xs of [ap] -> toDyn ((AssignmentExpr (TermRep.fDyn ap))::Expression) ; _ -> error "Term explosion error."+	g (InstanceCreationExpr _) xs = case TermRep.fArgs xs of [aq] -> toDyn ((InstanceCreationExpr (TermRep.fDyn aq))::Expression) ; _ -> error "Term explosion error."+	g (MethodInvocationExpr _) xs = case TermRep.fArgs xs of [ar] -> toDyn ((MethodInvocationExpr (TermRep.fDyn ar))::Expression) ; _ -> error "Term explosion error."++_tc_ExpressionTc = mkTyCon "Expression"+instance Typeable Expression where+    typeOf x = mkTyConApp _tc_ExpressionTc [ ]++instance Term AndOr where+    explode (x::AndOr) = TermRep (toDyn x, f x, g x) where+	f AND = []+	f OR = []+	g AND xs = case TermRep.fArgs xs of [] -> toDyn ((AND)::AndOr) ; _ -> error "Term explosion error."+	g OR xs = case TermRep.fArgs xs of [] -> toDyn ((OR)::AndOr) ; _ -> error "Term explosion error."++_tc_AndOrTc = mkTyCon "AndOr"+instance Typeable AndOr where+    typeOf x = mkTyConApp _tc_AndOrTc [ ]++instance Term PrefixOperator where+    explode (x::PrefixOperator) = TermRep (toDyn x, f x, g x) where+	f Neg = []+	f Fac = []+	g Neg xs = case TermRep.fArgs xs of [] -> toDyn ((Neg)::PrefixOperator) ; _ -> error "Term explosion error."+	g Fac xs = case TermRep.fArgs xs of [] -> toDyn ((Fac)::PrefixOperator) ; _ -> error "Term explosion error."++_tc_PrefixOperatorTc = mkTyCon "PrefixOperator"+instance Typeable PrefixOperator where+    typeOf x = mkTyConApp _tc_PrefixOperatorTc [ ]++instance Term InfixOperator where+    explode (x::InfixOperator) = TermRep (toDyn x, f x, g x) where+	f Eq = []+	f NEQ = []+	f Lt = []+	f Gt = []+	f LEQ = []+	f GEQ = []+	f PLUS = []+	f MINUS = []+	f MUL = []+	f DIV = []+	f MOD = []+	g Eq xs = case TermRep.fArgs xs of [] -> toDyn ((Eq)::InfixOperator) ; _ -> error "Term explosion error."+	g NEQ xs = case TermRep.fArgs xs of [] -> toDyn ((NEQ)::InfixOperator) ; _ -> error "Term explosion error."+	g Lt xs = case TermRep.fArgs xs of [] -> toDyn ((Lt)::InfixOperator) ; _ -> error "Term explosion error."+	g Gt xs = case TermRep.fArgs xs of [] -> toDyn ((Gt)::InfixOperator) ; _ -> error "Term explosion error."+	g LEQ xs = case TermRep.fArgs xs of [] -> toDyn ((LEQ)::InfixOperator) ; _ -> error "Term explosion error."+	g GEQ xs = case TermRep.fArgs xs of [] -> toDyn ((GEQ)::InfixOperator) ; _ -> error "Term explosion error."+	g PLUS xs = case TermRep.fArgs xs of [] -> toDyn ((PLUS)::InfixOperator) ; _ -> error "Term explosion error."+	g MINUS xs = case TermRep.fArgs xs of [] -> toDyn ((MINUS)::InfixOperator) ; _ -> error "Term explosion error."+	g MUL xs = case TermRep.fArgs xs of [] -> toDyn ((MUL)::InfixOperator) ; _ -> error "Term explosion error."+	g DIV xs = case TermRep.fArgs xs of [] -> toDyn ((DIV)::InfixOperator) ; _ -> error "Term explosion error."+	g MOD xs = case TermRep.fArgs xs of [] -> toDyn ((MOD)::InfixOperator) ; _ -> error "Term explosion error."++_tc_InfixOperatorTc = mkTyCon "InfixOperator"+instance Typeable InfixOperator where+    typeOf x = mkTyConApp _tc_InfixOperatorTc [ ]++instance Term Literal where+    explode (x::Literal) = TermRep (toDyn x, f x, g x) where+	f (BooleanLit aa) = [explode aa]+	f (IntegerLit ab) = [explode ab]+	f Null = []+	f (StringLit ac) = [explode ac]+	g (BooleanLit _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((BooleanLit (TermRep.fDyn aa))::Literal) ; _ -> error "Term explosion error."+	g (IntegerLit _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((IntegerLit (TermRep.fDyn ab))::Literal) ; _ -> error "Term explosion error."+	g Null xs = case TermRep.fArgs xs of [] -> toDyn ((Null)::Literal) ; _ -> error "Term explosion error."+	g (StringLit _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((StringLit (TermRep.fDyn ac))::Literal) ; _ -> error "Term explosion error."++_tc_LiteralTc = mkTyCon "Literal"+instance Typeable Literal where+    typeOf x = mkTyConApp _tc_LiteralTc [ ]++instance Term BooleanLiteral where+    explode (x::BooleanLiteral) = TermRep (toDyn x, f x, g x) where+	f TRUE = []+	f FALSE = []+	g TRUE xs = case TermRep.fArgs xs of [] -> toDyn ((TRUE)::BooleanLiteral) ; _ -> error "Term explosion error."+	g FALSE xs = case TermRep.fArgs xs of [] -> toDyn ((FALSE)::BooleanLiteral) ; _ -> error "Term explosion error."++_tc_BooleanLiteralTc = mkTyCon "BooleanLiteral"+instance Typeable BooleanLiteral where+    typeOf x = mkTyConApp _tc_BooleanLiteralTc [ ]++instance Term BlockStatements where+    explode (x::BlockStatements) = TermRep (toDyn x, f x, g x) where+	f (BlockStatements aa ab) = [explode aa,explode ab]+	g (BlockStatements _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((BlockStatements (TermRep.fDyn aa) (TermRep.fDyn ab))::BlockStatements) ; _ -> error "Term explosion error."++_tc_BlockStatementsTc = mkTyCon "BlockStatements"+instance Typeable BlockStatements where+    typeOf x = mkTyConApp _tc_BlockStatementsTc [ ]++instance Term Statement where+    explode (x::Statement) = TermRep (toDyn x, f x, g x) where+	f Skip = []+	f (Block aa) = [explode aa]+	f (AssignmentStat ab) = [explode ab]+	f (InstanceCreationStat ac) = [explode ac]+	f (MethodInvocationStat ad) = [explode ad]+	f (ReturnStat ae) = [explode ae]+	f (IfStat af ag ah) = [explode af,explode ag,explode ah]+	f (WhileStat ai aj) = [explode ai,explode aj]+	f (StatFocus ak) = [explode ak]+	g Skip xs = case TermRep.fArgs xs of [] -> toDyn ((Skip)::Statement) ; _ -> error "Term explosion error."+	g (Block _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((Block (TermRep.fDyn aa))::Statement) ; _ -> error "Term explosion error."+	g (AssignmentStat _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((AssignmentStat (TermRep.fDyn ab))::Statement) ; _ -> error "Term explosion error."+	g (InstanceCreationStat _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((InstanceCreationStat (TermRep.fDyn ac))::Statement) ; _ -> error "Term explosion error."+	g (MethodInvocationStat _) xs = case TermRep.fArgs xs of [ad] -> toDyn ((MethodInvocationStat (TermRep.fDyn ad))::Statement) ; _ -> error "Term explosion error."+	g (ReturnStat _) xs = case TermRep.fArgs xs of [ae] -> toDyn ((ReturnStat (TermRep.fDyn ae))::Statement) ; _ -> error "Term explosion error."+	g (IfStat _ _ _) xs = case TermRep.fArgs xs of [af,ag,ah] -> toDyn ((IfStat (TermRep.fDyn af) (TermRep.fDyn ag) (TermRep.fDyn ah))::Statement) ; _ -> error "Term explosion error."+	g (WhileStat _ _) xs = case TermRep.fArgs xs of [ai,aj] -> toDyn ((WhileStat (TermRep.fDyn ai) (TermRep.fDyn aj))::Statement) ; _ -> error "Term explosion error."+	g (StatFocus _) xs = case TermRep.fArgs xs of [ak] -> toDyn ((StatFocus (TermRep.fDyn ak))::Statement) ; _ -> error "Term explosion error."++_tc_StatementTc = mkTyCon "Statement"+instance Typeable Statement where+    typeOf x = mkTyConApp _tc_StatementTc [ ]++instance Term ClassDeclaration where+    explode (x::ClassDeclaration) = TermRep (toDyn x, f x, g x) where+	f (ClassDecl aa ab ac ad ae af) = [explode aa,explode ab,explode ac,explode ad,explode ae,explode af]+	g (ClassDecl _ _ _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad,ae,af] -> toDyn ((ClassDecl (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad) (TermRep.fDyn ae) (TermRep.fDyn af))::ClassDeclaration) ; _ -> error "Term explosion error."++_tc_ClassDeclarationTc = mkTyCon "ClassDeclaration"+instance Typeable ClassDeclaration where+    typeOf x = mkTyConApp _tc_ClassDeclarationTc [ ]++instance Term FieldDeclaration where+    explode (x::FieldDeclaration) = TermRep (toDyn x, f x, g x) where+	f (FieldDecl aa ab) = [explode aa,explode ab]+	g (FieldDecl _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((FieldDecl (TermRep.fDyn aa) (TermRep.fDyn ab))::FieldDeclaration) ; _ -> error "Term explosion error."++_tc_FieldDeclarationTc = mkTyCon "FieldDeclaration"+instance Typeable FieldDeclaration where+    typeOf x = mkTyConApp _tc_FieldDeclarationTc [ ]++instance Term ConstructorDeclaration where+    explode (x::ConstructorDeclaration) = TermRep (toDyn x, f x, g x) where+	f (ConstructorDecl aa ab ac ad) = [explode aa,explode ab,explode ac,explode ad]+	g (ConstructorDecl _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad] -> toDyn ((ConstructorDecl (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad))::ConstructorDeclaration) ; _ -> error "Term explosion error."++_tc_ConstructorDeclarationTc = mkTyCon "ConstructorDeclaration"+instance Typeable ConstructorDeclaration where+    typeOf x = mkTyConApp _tc_ConstructorDeclarationTc [ ]++instance Term MethodDeclaration where+    explode (x::MethodDeclaration) = TermRep (toDyn x, f x, g x) where+	f (MethodDecl aa ab ac ad) = [explode aa,explode ab,explode ac,explode ad]+	g (MethodDecl _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad] -> toDyn ((MethodDecl (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad))::MethodDeclaration) ; _ -> error "Term explosion error."++_tc_MethodDeclarationTc = mkTyCon "MethodDeclaration"+instance Typeable MethodDeclaration where+    typeOf x = mkTyConApp _tc_MethodDeclarationTc [ ]++instance Term FormalParameters where+    explode (x::FormalParameters) = TermRep (toDyn x, f x, g x) where+	f (FormalParams aa) = [explode aa]+	g (FormalParams _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((FormalParams (TermRep.fDyn aa))::FormalParameters) ; _ -> error "Term explosion error."++_tc_FormalParametersTc = mkTyCon "FormalParameters"+instance Typeable FormalParameters where+    typeOf x = mkTyConApp _tc_FormalParametersTc [ ]++instance Term FormalParameter where+    explode (x::FormalParameter) = TermRep (toDyn x, f x, g x) where+	f (FormalParam aa ab) = [explode aa,explode ab]+	g (FormalParam _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((FormalParam (TermRep.fDyn aa) (TermRep.fDyn ab))::FormalParameter) ; _ -> error "Term explosion error."++_tc_FormalParameterTc = mkTyCon "FormalParameter"+instance Typeable FormalParameter where+    typeOf x = mkTyConApp _tc_FormalParameterTc [ ]++instance Term VariableDeclaration where+    explode (x::VariableDeclaration) = TermRep (toDyn x, f x, g x) where+	f (VariableDecl aa ab) = [explode aa,explode ab]+	g (VariableDecl _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((VariableDecl (TermRep.fDyn aa) (TermRep.fDyn ab))::VariableDeclaration) ; _ -> error "Term explosion error."++_tc_VariableDeclarationTc = mkTyCon "VariableDeclaration"+instance Typeable VariableDeclaration where+    typeOf x = mkTyConApp _tc_VariableDeclarationTc [ ]++instance Term Type where+    explode (x::Type) = TermRep (toDyn x, f x, g x) where+	f INT = []+	f BOOLEAN = []+	f (Type aa) = [explode aa]+	g INT xs = case TermRep.fArgs xs of [] -> toDyn ((INT)::Type) ; _ -> error "Term explosion error."+	g BOOLEAN xs = case TermRep.fArgs xs of [] -> toDyn ((BOOLEAN)::Type) ; _ -> error "Term explosion error."+	g (Type _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((Type (TermRep.fDyn aa))::Type) ; _ -> error "Term explosion error."++_tc_TypeTc = mkTyCon "Type"+instance Typeable Type where+    typeOf x = mkTyConApp _tc_TypeTc [ ]++--  Imported from other files :-
+ StrategyLib-4.0-beta/examples/joos-padl02/Extraction.hs view
@@ -0,0 +1,76 @@+------------------------------------------------------------------------------++module Extraction where++import Monad+import StrategyLib hiding (replaceFocus)+import VarsAnalyses+import Datatypes+++--- Method extraction --------------------------------------------------------++                                                         --- Main strategy ---++extractMethod :: (Term t, MonadPlus m) => t -> m t+extractMethod joos = applyTP (once_tdTP (monoTP extrMethFromCls)) joos++extrMethFromCls :: MonadPlus m => ClassDeclaration -> m ClassDeclaration+extrMethFromCls (ClassDecl fin nm sup fs cs ds)+  = do (pars,body) <- ifLegalGetParsAndBody ds+       ds' <- replaceFocus pars (ds++[constructMethod pars body])+       return (ClassDecl fin nm sup fs cs ds')++                        --- Check legality and extract parameters and body ---++ifLegalGetParsAndBody :: (Term t, MonadPlus m)+                      => t -> m ([([Char],Type)],Statement)+ifLegalGetParsAndBody ds+  = applyTU (once_peTU [] appendLocals ifLegalGetParsAndBody1) ds+  where ifLegalGetParsAndBody1 env+          = getFocus `passTU` \s ->+            ifthenTU (voidTP (isLegal env))+            ( freeUseVars env `passTU` \pars ->+              constTU (pars,s) )+        appendLocals env = op2TU appendMap (tryTU declVars) (constTU env)++                     --- Replace focussed statement with method invocation ---++replaceFocus :: (Term t, MonadPlus m) => [(Identifier,Type)] -> t -> m t+replaceFocus pars ds = applyTP (once_tdTP (replaceFocus1 pars)) ds+  where replaceFocus1 pars = getFocus `passTP` \_ -> +                             monoTP (const (return (constructMethodCall pars)))++                                                        --- Legality check ---++isLegal :: MonadPlus m => [([Char],Type)] -> TP m+isLegal env        = freeDefVars env `passTP` \env' ->+                     if null env' then notTU (once_tdTU getReturn) else failTP++                                            --- Retreive focused statement ---++getFocus :: MonadPlus m => TU Statement m+getFocus =  monoTU (\s -> case s of (StatFocus s') -> return s'+                                    _              -> mzero )++                                           --- Test for a return statement ---++getReturn :: MonadPlus m => TU (Maybe Expression) m+getReturn =  monoTU (\s -> case s of (ReturnStat x) -> return x+                                     _              -> mzero )++                                                      --- Code generattion ---++constructMethod :: [(Identifier,Type)] -> Statement -> MethodDeclaration+constructMethod pars body+  = MethodDecl Nothing "newMethod"+       (FormalParams fpars) (BlockStatements [] [body])+    where fpars = map (\(v,t) -> FormalParam t v) pars++constructMethodCall :: [(Identifier,Type)] -> Statement+constructMethodCall pars+  = MethodInvocationStat +       (ExpressionInvocation This "newMethod" (Arguments args))+    where args = map (\(v,t) -> Identifier v) pars++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/joos-padl02/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import MainIO++main = mainIO "fowler.joos" "Test.log"+
+ StrategyLib-4.0-beta/examples/joos-padl02/MainIO.hs view
@@ -0,0 +1,34 @@+------------------------------------------------------------------------------++module MainIO where++import StrategyLib hiding (replaceFocus)+import VarsAnalyses+import Extraction+import ParseLib (papply)+import Datatypes+import Parser++------------------------------------------------------------------------------++mainIO = pWrap parseClassDeclaration performExtraction (return.show)++pWrap parser trafo pper f1 f2+  = do s  <- readFile f1+       t  <- pApply parser s+       t' <- trafo t+       s' <- pper t'+       writeFile f2 s'++pApply p s+  = case okParses of+      []     -> fail "Parse failed!!\n"+      [x]    -> putStrLn "Status: successful parse." >> return (fst x)+      (x:xs) -> putStrLn "WARNING: ambiguous parse." >> return (fst x)+    where okParses = filter (null.snd) (papply p s)+      +performExtraction t+  = case extractMethod t of+       Just t'  -> putStrLn "Status: successful extraction." >> return t'+       Nothing  -> putStrLn "WARNING: extraction failed." >> return t+
+ StrategyLib-4.0-beta/examples/joos-padl02/Makefile view
@@ -0,0 +1,18 @@+###############################################################################+#+# Environment for makerules+#++StrategyLib = ../..+derive      = DatatypesTermInstances.hs+Model       = drift-default+subdirs     = testsuite+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.examples+
+ StrategyLib-4.0-beta/examples/joos-padl02/ParseLib.hs view
@@ -0,0 +1,186 @@+{-----------------------------------------------------------------------------++                 A LIBRARY OF MONADIC PARSER COMBINATORS++                              29th July 1996+                           Revised, October 1996+                       Revised again, November 1998++                 Graham Hutton               Erik Meijer+            University of Nottingham    University of Utrecht++This Haskell 98 script defines a library of parser combinators, and is taken+from sections 1-6 of our article "Monadic Parser Combinators".  Some changes+to the library have been made in the move from Gofer to Haskell:++   * Do notation is used in place of monad comprehension notation;++   * The parser datatype is defined using "newtype", to avoid the overhead+     of tagging and untagging parsers with the P constructor.++-----------------------------------------------------------------------------}++module ParseLib+   (Parser, item, papply, (+++), sat, many, many1, sepby, sepby1, chainl,+    chainl1, chainr, chainr1, ops, bracket, char, digit, lower, upper,+    letter, alphanum, string, ident, nat, int, spaces, comment, junk,+    parse, token, natural, integer, symbol, identifier, module Monad) where++import Char+import Monad++infixr 5 +++++--- The parser monad ---------------------------------------------------------++newtype Parser a   = P (String -> [(a,String)])++instance Functor Parser where+   -- map         :: (a -> b) -> (Parser a -> Parser b)+   fmap f (P p)    = P (\inp -> [(f v, out) | (v,out) <- p inp])++instance Monad Parser where+   -- return      :: a -> Parser a+   return v        = P (\inp -> [(v,inp)])++   -- >>=         :: Parser a -> (a -> Parser b) -> Parser b+   (P p) >>= f     = P (\inp -> concat [papply (f v) out | (v,out) <- p inp])++instance MonadPlus Parser where+   -- mzero            :: Parser a+   mzero                = P (\inp -> [])++   -- mplus            :: Parser a -> Parser a -> Parser a+   (P p) `mplus` (P q)  = P (\inp -> (p inp ++ q inp))++--- Other primitive parser combinators ---------------------------------------++item              :: Parser Char+item               = P (\inp -> case inp of+                                   []     -> []+                                   (x:xs) -> [(x,xs)])++force             :: Parser a -> Parser a+force (P p)        = P (\inp -> let x = p inp in+                                (fst (head x), snd (head x)) : tail x)++first             :: Parser a -> Parser a+first (P p)        = P (\inp -> case p inp of+                                   []     -> []+                                   (x:xs) -> [x])++papply            :: Parser a -> String -> [(a,String)]+papply (P p) inp   = p inp++--- Derived combinators ------------------------------------------------------++(+++)             :: Parser a -> Parser a -> Parser a+p +++ q            = first (p `mplus` q)++sat               :: (Char -> Bool) -> Parser Char+sat p              = do {x <- item; if p x then return x else mzero}++many              :: Parser a -> Parser [a]+many p             = force (many1 p +++ return [])++many1             :: Parser a -> Parser [a]+many1 p            = do {x <- p; xs <- many p; return (x:xs)}++sepby             :: Parser a -> Parser b -> Parser [a]+p `sepby` sep      = (p `sepby1` sep) +++ return []++sepby1            :: Parser a -> Parser b -> Parser [a]+p `sepby1` sep     = do {x <- p; xs <- many (do {sep; p}); return (x:xs)}++chainl            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a+chainl p op v      = (p `chainl1` op) +++ return v++chainl1           :: Parser a -> Parser (a -> a -> a) -> Parser a+p `chainl1` op     = do {x <- p; rest x}+                     where+                        rest x = do {f <- op; y <- p; rest (f x y)}+                                 +++ return x++chainr            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a+chainr p op v      = (p `chainr1` op) +++ return v++chainr1           :: Parser a -> Parser (a -> a -> a) -> Parser a+p `chainr1` op     = do {x <- p; rest x}+                     where+                        rest x = do {f <- op; y <- p `chainr1` op; return (f x y)}+                                 +++ return x++ops               :: [(Parser a, b)] -> Parser b+ops xs             = foldr1 (+++) [do {p; return op} | (p,op) <- xs]++bracket           :: Parser a -> Parser b -> Parser c -> Parser b+bracket open p close = do {open; x <- p; close; return x}++--- Useful parsers -----------------------------------------------------------++char              :: Char -> Parser Char+char x             = sat (\y -> x == y)++digit             :: Parser Char+digit              = sat isDigit++lower             :: Parser Char+lower              = sat isLower++upper             :: Parser Char+upper              = sat isUpper++letter            :: Parser Char+letter             = sat isAlpha++alphanum          :: Parser Char+alphanum           = sat isAlphaNum++string            :: String -> Parser String+string ""          = return ""+string (x:xs)      = do {char x; string xs; return (x:xs)}++ident             :: Parser String+ident              = do {x <- lower; xs <- many alphanum; return (x:xs)}++nat               :: Parser Int+nat                = do {x <- digit; return (digitToInt x)} `chainl1` return op+                     where+                        m `op` n = 10*m + n++int               :: Parser Int+int                = do {char '-'; n <- nat; return (-n)} +++ nat++--- Lexical combinators ------------------------------------------------------++spaces            :: Parser ()+spaces             = do {many1 (sat isSpace); return ()}++comment           :: Parser ()+comment            = do {string "--"; many (sat (\x -> x /= '\n')); return ()}++junk              :: Parser ()+junk               = do {many (spaces +++ comment); return ()}++parse             :: Parser a -> Parser a+parse p            = do {junk; p}++token             :: Parser a -> Parser a+token p            = do {v <- p; junk; return v}++--- Token parsers ------------------------------------------------------------++natural           :: Parser Int+natural            = token nat++integer           :: Parser Int+integer            = token int++symbol            :: String -> Parser String+symbol xs          = token (string xs)++identifier        :: [String] -> Parser String+identifier ks      = token (do {x <- ident; if not (elem x ks) then return x+                                                               else mzero})++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/joos-padl02/Parser.hs view
@@ -0,0 +1,296 @@+{-----------------------------------------------------------------------------++This parser for JOOS is based on:++    David A. Watt. JOOS action semantics. Version 1, available from+    http://www.dcs.gla.ac.uk/~daw/publications/JOOS.ps, October 1997. ++Several small adaptations were made to parse more Java fragments:++  - Identifiers may now contain underscores.+  - method invocations of the form m(args) are now accepted, and +    interpreted as this.m(args).++-----------------------------------------------------------------------------}++module Parser where++import ParseLib+import Datatypes++parseAssignment+  = do i <- parseIdentifier +       parseSymbol ":="+       e <- parseExpression+       return (Assignment i e) ++parseInstanceCreation+  = do parseSymbol "new"+       i    <- parseIdentifier+       args <- bracket (parseSymbol "(") parseArguments (parseSymbol ")")+       return (InstanceCreation i args)++parseMethodInvocation+  = do e <- parseExpression+       case e of+         (MethodInvocationExpr mi) -> return mi+         _                         -> mzero++parseSuperMethodInvocation+  = do parseSymbol "super"+       parseSymbol "."+       i <- parseIdentifier+       args <- bracket (parseSymbol "(") parseArguments (parseSymbol ")")+       return (SuperInvocation i args)++parseMethodInvocationRemainder e+  = do parseSymbol "."+       i <- parseIdentifier+       parseSymbol "("+       args <- parseArguments+       parseSymbol ")"+       return (ExpressionInvocation e i args)+    ++++    case e of+      (Identifier i) -> do parseSymbol "("+                           args <- parseArguments+                           parseSymbol ")"+                           return (ExpressionInvocation This i args)+      _              -> mzero++parseArguments+  = fmap Arguments (sepby parseExpression (parseSymbol ","))++parseExpression +  = do e <- parseExpression1+       parseExpressionRemainder e++parseExpressionRemainder e+  = do e' <- (fmap MethodInvocationExpr (parseMethodInvocationRemainder e))+             ++++             do op <- parseInfixOperator+                e2 <- parseExpression+                return (InfixExpr e op e2)+             ++++             do parseSymbol "instanceof"+                i <- parseIdentifier+                return (InstanceOf e i)+             ++++             do ao <- parseAndOr+                e2 <- parseExpression+                return (AndOrExpr e ao e2)+       parseExpressionRemainder e'+    ++++    return e+      +parseExpression1+  = fmap Literal parseLiteral+    ++++    fmap Identifier parseIdentifier+    ++++    do { parseSymbol "this"; return This }+    ++++    do op <- parsePrefixOperator+       e  <- parseExpression+       return (PrefixExpr op e)+    ++++    do t <- bracket (parseSymbol "(") parseType (parseSymbol ")")+       e <- parseExpression+       return (TypeCast t e)+    ++++    do (bracket (parseSymbol "(") parseExpression (parseSymbol ")"))+    ++++    fmap AssignmentExpr parseAssignment+    ++++    fmap InstanceCreationExpr parseInstanceCreation+    ++++    fmap MethodInvocationExpr parseSuperMethodInvocation++parsePrefixOperator+  = do { parseSymbol "-"; return Neg }+    ++++    do { parseSymbol "!"; return Fac }++parseInfixOperator+  = symbols [("==",Eq),("!=",NEQ),("<",Lt),(">",Gt),("<=",LEQ),(">=",GEQ),+             ("+",PLUS),("-",MINUS),("*",MUL),("/",DIV),("%",MOD)]++parseAndOr+  = do { parseSymbol "||"; return OR }+    +++ +    do { parseSymbol "&&"; return AND }++parseLiteral+  = fmap BooleanLit parseBooleanLiteral+    ++++    fmap IntegerLit parseIntegerLiteral+    ++++    do { parseSymbol "null"; return Null }+    ++++    fmap StringLit parseStringLiteral++parseBooleanLiteral+  = do { parseSymbol "true"; return TRUE }+    ++++    do { parseSymbol "false"; return FALSE }++parseIntegerLiteral+  = fmap toInteger natural++parseStringLiteral+  = token (bracket (char '"') (many (sat (/='"') )) (char '"'))++parseIdentifier+  = parse joosIdent++parseBlockStatements+  = do vds <- many parseVariableDeclaration+       ss  <- many parseStatement+       return (BlockStatements vds ss)++parseStatement+  = parseStatementNoBlock+    ++++    fmap Block ( bracket (parseSymbol "{") +                         parseBlockStatements+                         (parseSymbol "}") )++parseStatementNoBlock+  = symbols [(";",Skip)]+    ++++    do a <- parseAssignment+       parseSymbol ";"+       return (AssignmentStat a)+    ++++    do i <- parseInstanceCreation+       parseSymbol ";"+       return (InstanceCreationStat i)+    ++++    do m <- parseMethodInvocation+       parseSymbol ";"+       return (MethodInvocationStat m)+    ++++    do parseSymbol "return"+       e <- optional parseExpression+       parseSymbol ";"+       return (ReturnStat e)+    ++++    do parseSymbol "if"+       c <- bracket (parseSymbol "(") parseExpression (parseSymbol ")")+       parseSymbol "then"+       t <- parseStatement+       parseSymbol "else"+       e <- parseStatement+       return (IfStat c t e)+    ++++    do parseSymbol "while" +       c <- bracket (parseSymbol "(") parseExpression (parseSymbol ")")+       s <- parseStatement+       return (WhileStat c s)+    ++++    fmap StatFocus ( bracket (parseSymbol "<<")+                             parseStatement+                             (parseSymbol ">>") )+++parseClassDeclaration+  = do parseSymbol "public"+       f <- do { parseSymbol "final"; return True } +++ return False+       parseSymbol "class"+       cn <- parseIdentifier+       parseSymbol "extends"+       scn <- parseIdentifier+       parseSymbol "{"+       fds <- many parseFieldDeclaration+       cd  <- parseConstructorDeclaration+       mds <- many parseMethodDeclaration+       parseSymbol "}"+       return (ClassDecl f cn scn fds cd mds)++parseFieldDeclaration+  = do parseSymbol "private"+       t <- parseType +       i <- parseIdentifier+       return (FieldDecl t i)++parseConstructorDeclaration+  = do parseSymbol "public"+       mn <- parseIdentifier+       parseSymbol "("+       pars <- parseFormalParameters+       parseSymbol ")"+       parseSymbol "{"+       parseSymbol "super"+       args <- bracket (parseSymbol "(") parseArguments (parseSymbol ")")+       body <- parseBlockStatements+       parseSymbol "}"+       return (ConstructorDecl mn pars args body)++parseMethodDeclaration+  = do parseSymbol "public"+       t <- ( do { parseSymbol "void"; return Nothing }+              ++++              fmap Just parseType )+       mn <- parseIdentifier+       parseSymbol "("+       pars <- parseFormalParameters+       parseSymbol ")"+       parseSymbol "{"+       body <- parseBlockStatements+       parseSymbol "}"+       return (MethodDecl t mn pars body)++parseFormalParameters+  = fmap FormalParams (sepby parseFormalParameter (parseSymbol ","))++parseFormalParameter+  = do t <- parseType+       i <- parseIdentifier+       return (FormalParam t i)++parseVariableDeclaration+  = do t <- parseType+       i <- parseIdentifier+       parseSymbol ";"+       return (VariableDecl t i)++parseType+  = do { parseSymbol "int"; return INT }+    ++++    do { parseSymbol "boolean"; return BOOLEAN }+    ++++    fmap Type parseIdentifier+++--- Auxiliary ---------------------------------------------------------------++parseSymbol = parse . symbol++joosIdent :: Parser String+joosIdent = token (do{ i <- joos_ident; if not (elem i ks) then return i+                                                           else mzero })+            where ks = ["new","super","this","instanceof","null",+                        "true","false","return","if","else","while",+                        "public","final","extends","private","int","boolean"]++joos_ident = do {x <- sat isJOOSalpha; xs <- many joos_alphanum; return (x:xs)}+             where joos_alphanum = sat isJOOSalphanum+                   isJOOSalphanum c = isAlphaNum' c || (c=='_')+                   isJOOSalpha c    = isAlpha' c    || (c=='_')++symbols :: [(String,a)] -> Parser a+symbols ss+  = foldr (\(sym,a) p -> do {parseSymbol sym; return a} +++ p ) mzero ss++optional p = fmap Just p +++ return Nothing++-- These are not present in all preludes.+-- Therefore, we repeat them with primed names.+isUpper' c              =  c >= 'A'   &&  c <= 'Z'+isLower' c              =  c >= 'a'   &&  c <= 'z'+isAlpha' c              =  isUpper' c  ||  isLower' c+isDigit' c              =  c >= '0'   &&  c <= '9'+isAlphaNum' c           =  isAlpha' c  ||  isDigit' c+++-----------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/joos-padl02/README view
@@ -0,0 +1,16 @@+------------------------------------------------------------------------------++EXTRACT METHOD REFACTORING for JOOS++This example is explained in the article+"Typed Combinators for Generic Traversal".++JOOS is a purely object-oriented subset of Java designed by Laurie Hendren.+It is used for research experiments and education. The grammar has 24 +non-terminals and 61 productions. The abstract Haskell syntax of JOOS+was extracted from:++    David A. Watt. JOOS action semantics. Version 1, available from+    http://www.dcs.gla.ac.uk/~daw/publications/JOOS.ps, October 1997. ++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/joos-padl02/Test.correct view
@@ -0,0 +1,1 @@+ClassDecl False "Fowler" "Object" [] (ConstructorDecl "Fowler" (FormalParams []) (Arguments []) (BlockStatements [] [Skip])) [MethodDecl Nothing "printOwning" (FormalParams [FormalParam (Type "double") "amount"]) (BlockStatements [] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),MethodInvocationStat (ExpressionInvocation This "newMethod" (Arguments [Identifier "amount"]))]),MethodDecl Nothing "newMethod" (FormalParams [FormalParam (Type "double") "amount"]) (BlockStatements [] [Block (BlockStatements [] [MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))])])]
+ StrategyLib-4.0-beta/examples/joos-padl02/VarsAnalyses.hs view
@@ -0,0 +1,112 @@+------------------------------------------------------------------------------++module VarsAnalyses where++import Datatypes+import DatatypesTermInstances+import StrategyLib hiding (replaceFocus)+import Control.Monad+import Data.Monoid+import Data.List++--- Variable analyses --------------------------------------------------------++                                                        --- Used variables ---++useVar (Identifier i) = return [i]+useVar _              = return []++collectVars 	:: Monad m => TU [Identifier] m+collectVars 	 = full_tdTU (adhocTU (constTU []) useVar)+++                                        --- Declared variables (with type) ---++declVars	:: Monad m => TU [(Identifier,Type)] m+declVars	 = adhocTU (adhocTU (constTU []) declVarsBlock) declVarsMeth+	where declVarsBlock (BlockStatements vds _)+                = return (map (\(VariableDecl t i) -> (i,t)) vds)+              declVarsMeth (MethodDecl _ _ (FormalParams fps) _)+                = return (map (\(FormalParam t i) -> (i,t)) fps)+++-- To take field declarations and formal parameters of constructor +-- methods into account as well, we could have used the the following+-- code.++declVarsConstr (ConstructorDecl _ (FormalParams fps) _ _)+  = return (map (\(FormalParam t i) -> (i,t)) fps)+declVarsClass  (ClassDecl _ _ _ fds _ _)+  = return (map (\(FieldDecl t i) -> (i,t)) fds)++                                                     --- Defined variables ---++defVar (Assignment i _) = return [i]++                                   --- Two kinds of free variable analysis ---++freeUseVars env+  = dotTU nubMap (typed_free_vars env (adhocTU (constTU []) useVar) declVars)+freeDefVars env+  = dotTU nubMap (typed_free_vars env (adhocTU (constTU []) defVar) declVars)+++{-----------------------------------------------------------------------------++NOTE:++Generic functionality for variable analyses is to be found in the+library/NameTheme.hs. The below analyses are variations on some of the+functions in the NameTheme. These variations are kept to avoid deviation+from the code that was published in "Typed Combinators for Generic +Traversal".+++There are the following generic algorithms for free variable analysis:++   free_vars:       strategy that returns the set of free variables of a term+   typed_free_vars: strategy that returns a map of the free variables of a+                      term to their types.++   Parameters:+     getvars:    strategy that returns the variables used in a node+     declvars:   strategy that returns the variables declared in a node++-----------------------------------------------------------------------------}++------------------------------------------------------------------------------++free_vars :: (Monad m, Eq var) => TU [var] m -> TU [var] m -> TU [var] m+free_vars getvars declvars+  = op2TU union +    getvars+    ( op2TU (\\) (allTU union [] (free_vars getvars declvars))+                  declvars )++typed_free_vars :: (Monad m, Eq v)+                => [(v,t)] -> TU [v] m -> TU [(v,t)] m -> TU [(v,t)] m+typed_free_vars env getvars declvars+  = dotTU (flip appendMap env) declvars `passTU` \env' ->+    op2TU appendMap+          (dotTU (flip restrictMap env') getvars)+          (op2TU diffMap +                 (allTU (++) [] (typed_free_vars env' getvars declvars))+                 declvars)+++--- Map operations -----------------------------------------------------------++keyEq (k1,_) (k2,_)		 = k1 == k2+nubMap map			 = nubBy keyEq map+appendMap map1 map2		 = map1++map2+filterMap map keys		 = filter (\(k,_) -> k `elem` keys) map+diffMap map1 map2		 = diffMap' map1 (map fst map2)+restrictMap keys map		 = filter (\(k,_) -> k `elem` keys) map++diffMap' [] keys      		 = []+diffMap' (kv@(k,v):map) keys	 = if (k `elem` keys) +					then (diffMap' map keys) +					else (kv:diffMap' map keys)+++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/joos-padl02/fowler.joos view
@@ -0,0 +1,18 @@+public class Fowler extends Object {++  public Fowler() {+    super();+  }++  public void printOwning(double amount) {+    this.printBanner();+ +  << {+    --Print banner+    System_out.println("name:" + _name);+    System_out.println("amount" + amount);+  } >>+  }++}+
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import MainIO+import System++main = do +         [f1,f2] <- getArgs+         mainIO f1 f2
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/Makefile view
@@ -0,0 +1,49 @@+###############################################################################+#+# Environment for makerules+#++StrategyLib = ../../..+Model       = drift-default++tests =	fowler.log			\+	fowlerAssign.log		\+	fowlerDoubles.log		\+	fowlerWrongAssign.log		\+	fowlerWrongReturn.log+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.all+include ${StrategyLib}/scripts/makerules.opts+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.recurse+++###############################################################################+#+# Testsuite is only tested with runhugs.+#++check-hugs:+	(cd ..; ${MAKE} derive)+	rm -f *.log+	${MAKE} ${tests}++check-ghci:++check-ghc:+++###############################################################################+#+# Rules for producing test logs+#++%.log: %.joos+	runhugs	${hugs-opts} -P..: Main.hs $*.joos $*.log+	diff $*.log $*.correct
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/fowler.correct view
@@ -0,0 +1,1 @@+ClassDecl False "Fowler" "Object" [] (ConstructorDecl "Fowler" (FormalParams []) (Arguments []) (BlockStatements [] [Skip])) [MethodDecl Nothing "printOwning" (FormalParams [FormalParam (Type "double") "amount"]) (BlockStatements [] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),MethodInvocationStat (ExpressionInvocation This "newMethod" (Arguments [Identifier "amount"]))]),MethodDecl Nothing "newMethod" (FormalParams [FormalParam (Type "double") "amount"]) (BlockStatements [] [Block (BlockStatements [] [MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))])])]
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/fowler.joos view
@@ -0,0 +1,18 @@+public class Fowler extends Object {++  public Fowler() {+    super();+  }++  public void printOwning(double amount) {+    this.printBanner();+ +  << {+    --Print banner+    System_out.println("name:" + _name);+    System_out.println("amount" + amount);+  } >>+  }++}+
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/fowlerAssign.correct view
@@ -0,0 +1,1 @@+ClassDecl False "Fowler" "Object" [] (ConstructorDecl "Fowler" (FormalParams []) (Arguments []) (BlockStatements [] [Skip])) [MethodDecl Nothing "printOwning" (FormalParams [FormalParam (Type "double") "amount"]) (BlockStatements [] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),MethodInvocationStat (ExpressionInvocation This "newMethod" (Arguments [Identifier "amount"]))]),MethodDecl Nothing "newMethod" (FormalParams [FormalParam (Type "double") "amount"]) (BlockStatements [] [Block (BlockStatements [] [MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")])),Block (BlockStatements [VariableDecl INT "amount"] [AssignmentStat (Assignment "amount" (Literal (IntegerLit 1)))])])])]
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/fowlerAssign.joos view
@@ -0,0 +1,21 @@+public class Fowler extends Object {++  public Fowler() {+    super();+  }++  public void printOwning(double amount) {+    this.printBanner();+ +  << {+    --Print banner+    System_out.println("name:" + _name);+    System_out.println("amount" + amount);+    { int amount;+      amount := 1;+    }+  } >>+  }++}+
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/fowlerDoubles.correct view
@@ -0,0 +1,1 @@+ClassDecl False "Fowler" "Object" [] (ConstructorDecl "Fowler" (FormalParams []) (Arguments []) (BlockStatements [] [Skip])) [MethodDecl Nothing "printOwning" (FormalParams [FormalParam (Type "double") "amount"]) (BlockStatements [VariableDecl (Type "Triple") "amount"] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),MethodInvocationStat (ExpressionInvocation This "newMethod" (Arguments [Identifier "amount"]))]),MethodDecl Nothing "newMethod" (FormalParams [FormalParam (Type "Triple") "amount"]) (BlockStatements [] [Block (BlockStatements [] [MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))])])]
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/fowlerDoubles.joos view
@@ -0,0 +1,19 @@+public class Fowler extends Object {++  public Fowler() {+    super();+  }++  public void printOwning(double amount) {+    Triple amount;+    this.printBanner();+ +  << {+    --Print banner+    System_out.println("name:" + _name);+    System_out.println("amount" + amount);+  } >>+  }++}+
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/fowlerWrongAssign.correct view
@@ -0,0 +1,1 @@+ClassDecl False "Fowler" "Object" [] (ConstructorDecl "Fowler" (FormalParams []) (Arguments []) (BlockStatements [] [Skip])) [MethodDecl Nothing "printOwning" (FormalParams [FormalParam (Type "double") "amount"]) (BlockStatements [VariableDecl (Type "Name") "name"] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),StatFocus (Block (BlockStatements [] [AssignmentStat (Assignment "name" (Identifier "_name")),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))]))])]
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/fowlerWrongAssign.joos view
@@ -0,0 +1,21 @@+public class Fowler extends Object {++  public Fowler() {+    super();+  }++  public void printOwning(double amount) {+    Name name;+    this.printBanner();+ +  << {+    name := _name;++    --Print banner+    System_out.println("name:" + _name);+    System_out.println("amount" + amount);+  } >>+  }++}+
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/fowlerWrongReturn.correct view
@@ -0,0 +1,1 @@+ClassDecl False "Fowler" "Object" [] (ConstructorDecl "Fowler" (FormalParams []) (Arguments []) (BlockStatements [] [Skip])) [MethodDecl Nothing "printOwning" (FormalParams [FormalParam (Type "double") "amount"]) (BlockStatements [VariableDecl (Type "Name") "name"] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),StatFocus (Block (BlockStatements [] [MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),ReturnStat Nothing,MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))]))])]
+ StrategyLib-4.0-beta/examples/joos-padl02/testsuite/fowlerWrongReturn.joos view
@@ -0,0 +1,20 @@+public class Fowler extends Object {++  public Fowler() {+    super();+  }++  public void printOwning(double amount) {+    Name name;+    this.printBanner();+ +  << {+    --Print banner+    System_out.println("name:" + _name);+    return;+    System_out.println("amount" + amount);+  } >>+  }++}+
+ StrategyLib-4.0-beta/examples/joos-rule02/Datatypes.hs view
@@ -0,0 +1,95 @@+{----------------------------------------------------------------------------++Abstract syntax of JOOS, based on:++    David A. Watt. JOOS action semantics. Version 1, available from+    http://www.dcs.gla.ac.uk/~daw/publications/JOOS.ps, October 1997. ++----------------------------------------------------------------------------}++module Datatypes where++++data Program		= Program [Class] Block+                          deriving (Show,Eq)++data Assignment		= Assignment Identifier Expression+                          deriving (Show,Eq)+data InstanceCreation	= InstanceCreation Identifier Arguments+                          deriving (Show,Eq)+data MethodInvocation	= ExpressionInvocation Expression Identifier Arguments+			| SuperInvocation Identifier Arguments+                          deriving (Show,Eq)+data Arguments		= Arguments [Expression]+                          deriving (Show,Eq)+data Expression		= Literal Literal+			| Identifier Identifier+			| This+			| PrefixExpr PrefixOperator Expression+			| InfixExpr Expression InfixOperator Expression+			| AndOrExpr Expression AndOr Expression+			| InstanceOf Expression Identifier+			| TypeCast Type Expression+			| BracketExpr Expression+			| AssignmentExpr Assignment+			| InstanceCreationExpr InstanceCreation+			| MethodInvocationExpr MethodInvocation+                          deriving (Show,Eq)+data AndOr		= AND | OR+                          deriving (Show,Eq)++data PrefixOperator	= Neg | Fac+                          deriving (Show,Eq)+data InfixOperator	= Eq | NEQ | Lt | Gt | LEQ | GEQ+			| PLUS | MINUS | MUL | DIV | MOD+                          deriving (Show,Eq)+data Literal		= BooleanLit BooleanLiteral+			| IntegerLit IntegerLiteral+			| Null+			| StringLit StringLiteral+                          deriving (Show,Eq)+data BooleanLiteral	= TRUE | FALSE+                          deriving (Show,Eq)+type IntegerLiteral	= Integer+type StringLiteral	= String+type Identifier		= String++data Block	= Block [VarDecl] [Statement]+                          deriving (Show,Eq)+data Statement		= Skip+			| BlockStat Block+			| AssignmentStat Assignment+			| InstanceCreationStat InstanceCreation+			| MethodInvocationStat MethodInvocation+			| ReturnStat (Maybe Expression)+			| IfStat Expression Statement Statement+			| WhileStat Expression Statement+                       --- Additions+                        | StatementFocus Statement+                          deriving (Show,Eq)++data Class	= ClassDecl FinalOpt Identifier Identifier+                            [FieldDeclaration]+                            Constructor+			    [MethodDecl]+                          deriving (Show,Eq)+type FinalOpt		= Bool+data FieldDeclaration	= FieldDecl Type Identifier+                          deriving (Show,Eq)+data Constructor+			= ConstructorDecl Identifier Formals+                            Arguments Block+                          deriving (Show,Eq)+data MethodDecl	= MethodDecl (Maybe Type) Identifier Formals Block+                       --- Additions+                        | MethodDeclFocus [MethodDecl]+                          deriving (Show,Eq)+data Formals	= Formals [Formal]+                          deriving (Show,Eq)+data Formal	= Formal Type Identifier+                          deriving (Show,Eq)+data VarDecl	= VarDecl Type Identifier+                  deriving (Show,Eq)+data Type	= INT | BOOLEAN | Type Identifier+                  deriving (Show,Eq)
+ StrategyLib-4.0-beta/examples/joos-rule02/DatatypesTermInstances.hs view
@@ -0,0 +1,274 @@+module DatatypesTermInstances where+import Datatypes+import TermRep+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "Datatypes.hs" #-}+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Term Program where+    explode (x::Program) = TermRep (toDyn x, f x, g x) where+	f (Program aa ab) = [explode aa,explode ab]+	g (Program _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((Program (TermRep.fDyn aa) (TermRep.fDyn ab))::Program) ; _ -> error "Term explosion error."++_tc_ProgramTc = mkTyCon "Program"+instance Typeable Program where+    typeOf x = mkTyConApp _tc_ProgramTc [ ]++instance Term Assignment where+    explode (x::Assignment) = TermRep (toDyn x, f x, g x) where+	f (Assignment aa ab) = [explode aa,explode ab]+	g (Assignment _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((Assignment (TermRep.fDyn aa) (TermRep.fDyn ab))::Assignment) ; _ -> error "Term explosion error."++_tc_AssignmentTc = mkTyCon "Assignment"+instance Typeable Assignment where+    typeOf x = mkTyConApp _tc_AssignmentTc [ ]++instance Term InstanceCreation where+    explode (x::InstanceCreation) = TermRep (toDyn x, f x, g x) where+	f (InstanceCreation aa ab) = [explode aa,explode ab]+	g (InstanceCreation _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((InstanceCreation (TermRep.fDyn aa) (TermRep.fDyn ab))::InstanceCreation) ; _ -> error "Term explosion error."++_tc_InstanceCreationTc = mkTyCon "InstanceCreation"+instance Typeable InstanceCreation where+    typeOf x = mkTyConApp _tc_InstanceCreationTc [ ]++instance Term MethodInvocation where+    explode (x::MethodInvocation) = TermRep (toDyn x, f x, g x) where+	f (ExpressionInvocation aa ab ac) = [explode aa,explode ab,explode ac]+	f (SuperInvocation ad ae) = [explode ad,explode ae]+	g (ExpressionInvocation _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac] -> toDyn ((ExpressionInvocation (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac))::MethodInvocation) ; _ -> error "Term explosion error."+	g (SuperInvocation _ _) xs = case TermRep.fArgs xs of [ad,ae] -> toDyn ((SuperInvocation (TermRep.fDyn ad) (TermRep.fDyn ae))::MethodInvocation) ; _ -> error "Term explosion error."++_tc_MethodInvocationTc = mkTyCon "MethodInvocation"+instance Typeable MethodInvocation where+    typeOf x = mkTyConApp _tc_MethodInvocationTc [ ]++instance Term Arguments where+    explode (x::Arguments) = TermRep (toDyn x, f x, g x) where+	f (Arguments aa) = [explode aa]+	g (Arguments _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((Arguments (TermRep.fDyn aa))::Arguments) ; _ -> error "Term explosion error."++_tc_ArgumentsTc = mkTyCon "Arguments"+instance Typeable Arguments where+    typeOf x = mkTyConApp _tc_ArgumentsTc [ ]++instance Term Expression where+    explode (x::Expression) = TermRep (toDyn x, f x, g x) where+	f (Literal aa) = [explode aa]+	f (Identifier ab) = [explode ab]+	f This = []+	f (PrefixExpr ac ad) = [explode ac,explode ad]+	f (InfixExpr ae af ag) = [explode ae,explode af,explode ag]+	f (AndOrExpr ah ai aj) = [explode ah,explode ai,explode aj]+	f (InstanceOf ak al) = [explode ak,explode al]+	f (TypeCast am an) = [explode am,explode an]+	f (BracketExpr ao) = [explode ao]+	f (AssignmentExpr ap) = [explode ap]+	f (InstanceCreationExpr aq) = [explode aq]+	f (MethodInvocationExpr ar) = [explode ar]+	g (Literal _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((Literal (TermRep.fDyn aa))::Expression) ; _ -> error "Term explosion error."+	g (Identifier _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((Identifier (TermRep.fDyn ab))::Expression) ; _ -> error "Term explosion error."+	g This xs = case TermRep.fArgs xs of [] -> toDyn ((This)::Expression) ; _ -> error "Term explosion error."+	g (PrefixExpr _ _) xs = case TermRep.fArgs xs of [ac,ad] -> toDyn ((PrefixExpr (TermRep.fDyn ac) (TermRep.fDyn ad))::Expression) ; _ -> error "Term explosion error."+	g (InfixExpr _ _ _) xs = case TermRep.fArgs xs of [ae,af,ag] -> toDyn ((InfixExpr (TermRep.fDyn ae) (TermRep.fDyn af) (TermRep.fDyn ag))::Expression) ; _ -> error "Term explosion error."+	g (AndOrExpr _ _ _) xs = case TermRep.fArgs xs of [ah,ai,aj] -> toDyn ((AndOrExpr (TermRep.fDyn ah) (TermRep.fDyn ai) (TermRep.fDyn aj))::Expression) ; _ -> error "Term explosion error."+	g (InstanceOf _ _) xs = case TermRep.fArgs xs of [ak,al] -> toDyn ((InstanceOf (TermRep.fDyn ak) (TermRep.fDyn al))::Expression) ; _ -> error "Term explosion error."+	g (TypeCast _ _) xs = case TermRep.fArgs xs of [am,an] -> toDyn ((TypeCast (TermRep.fDyn am) (TermRep.fDyn an))::Expression) ; _ -> error "Term explosion error."+	g (BracketExpr _) xs = case TermRep.fArgs xs of [ao] -> toDyn ((BracketExpr (TermRep.fDyn ao))::Expression) ; _ -> error "Term explosion error."+	g (AssignmentExpr _) xs = case TermRep.fArgs xs of [ap] -> toDyn ((AssignmentExpr (TermRep.fDyn ap))::Expression) ; _ -> error "Term explosion error."+	g (InstanceCreationExpr _) xs = case TermRep.fArgs xs of [aq] -> toDyn ((InstanceCreationExpr (TermRep.fDyn aq))::Expression) ; _ -> error "Term explosion error."+	g (MethodInvocationExpr _) xs = case TermRep.fArgs xs of [ar] -> toDyn ((MethodInvocationExpr (TermRep.fDyn ar))::Expression) ; _ -> error "Term explosion error."++_tc_ExpressionTc = mkTyCon "Expression"+instance Typeable Expression where+    typeOf x = mkTyConApp _tc_ExpressionTc [ ]++instance Term AndOr where+    explode (x::AndOr) = TermRep (toDyn x, f x, g x) where+	f AND = []+	f OR = []+	g AND xs = case TermRep.fArgs xs of [] -> toDyn ((AND)::AndOr) ; _ -> error "Term explosion error."+	g OR xs = case TermRep.fArgs xs of [] -> toDyn ((OR)::AndOr) ; _ -> error "Term explosion error."++_tc_AndOrTc = mkTyCon "AndOr"+instance Typeable AndOr where+    typeOf x = mkTyConApp _tc_AndOrTc [ ]++instance Term PrefixOperator where+    explode (x::PrefixOperator) = TermRep (toDyn x, f x, g x) where+	f Neg = []+	f Fac = []+	g Neg xs = case TermRep.fArgs xs of [] -> toDyn ((Neg)::PrefixOperator) ; _ -> error "Term explosion error."+	g Fac xs = case TermRep.fArgs xs of [] -> toDyn ((Fac)::PrefixOperator) ; _ -> error "Term explosion error."++_tc_PrefixOperatorTc = mkTyCon "PrefixOperator"+instance Typeable PrefixOperator where+    typeOf x = mkTyConApp _tc_PrefixOperatorTc [ ]++instance Term InfixOperator where+    explode (x::InfixOperator) = TermRep (toDyn x, f x, g x) where+	f Eq = []+	f NEQ = []+	f Lt = []+	f Gt = []+	f LEQ = []+	f GEQ = []+	f PLUS = []+	f MINUS = []+	f MUL = []+	f DIV = []+	f MOD = []+	g Eq xs = case TermRep.fArgs xs of [] -> toDyn ((Eq)::InfixOperator) ; _ -> error "Term explosion error."+	g NEQ xs = case TermRep.fArgs xs of [] -> toDyn ((NEQ)::InfixOperator) ; _ -> error "Term explosion error."+	g Lt xs = case TermRep.fArgs xs of [] -> toDyn ((Lt)::InfixOperator) ; _ -> error "Term explosion error."+	g Gt xs = case TermRep.fArgs xs of [] -> toDyn ((Gt)::InfixOperator) ; _ -> error "Term explosion error."+	g LEQ xs = case TermRep.fArgs xs of [] -> toDyn ((LEQ)::InfixOperator) ; _ -> error "Term explosion error."+	g GEQ xs = case TermRep.fArgs xs of [] -> toDyn ((GEQ)::InfixOperator) ; _ -> error "Term explosion error."+	g PLUS xs = case TermRep.fArgs xs of [] -> toDyn ((PLUS)::InfixOperator) ; _ -> error "Term explosion error."+	g MINUS xs = case TermRep.fArgs xs of [] -> toDyn ((MINUS)::InfixOperator) ; _ -> error "Term explosion error."+	g MUL xs = case TermRep.fArgs xs of [] -> toDyn ((MUL)::InfixOperator) ; _ -> error "Term explosion error."+	g DIV xs = case TermRep.fArgs xs of [] -> toDyn ((DIV)::InfixOperator) ; _ -> error "Term explosion error."+	g MOD xs = case TermRep.fArgs xs of [] -> toDyn ((MOD)::InfixOperator) ; _ -> error "Term explosion error."++_tc_InfixOperatorTc = mkTyCon "InfixOperator"+instance Typeable InfixOperator where+    typeOf x = mkTyConApp _tc_InfixOperatorTc [ ]++instance Term Literal where+    explode (x::Literal) = TermRep (toDyn x, f x, g x) where+	f (BooleanLit aa) = [explode aa]+	f (IntegerLit ab) = [explode ab]+	f Null = []+	f (StringLit ac) = [explode ac]+	g (BooleanLit _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((BooleanLit (TermRep.fDyn aa))::Literal) ; _ -> error "Term explosion error."+	g (IntegerLit _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((IntegerLit (TermRep.fDyn ab))::Literal) ; _ -> error "Term explosion error."+	g Null xs = case TermRep.fArgs xs of [] -> toDyn ((Null)::Literal) ; _ -> error "Term explosion error."+	g (StringLit _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((StringLit (TermRep.fDyn ac))::Literal) ; _ -> error "Term explosion error."++_tc_LiteralTc = mkTyCon "Literal"+instance Typeable Literal where+    typeOf x = mkTyConApp _tc_LiteralTc [ ]++instance Term BooleanLiteral where+    explode (x::BooleanLiteral) = TermRep (toDyn x, f x, g x) where+	f TRUE = []+	f FALSE = []+	g TRUE xs = case TermRep.fArgs xs of [] -> toDyn ((TRUE)::BooleanLiteral) ; _ -> error "Term explosion error."+	g FALSE xs = case TermRep.fArgs xs of [] -> toDyn ((FALSE)::BooleanLiteral) ; _ -> error "Term explosion error."++_tc_BooleanLiteralTc = mkTyCon "BooleanLiteral"+instance Typeable BooleanLiteral where+    typeOf x = mkTyConApp _tc_BooleanLiteralTc [ ]++instance Term Block where+    explode (x::Block) = TermRep (toDyn x, f x, g x) where+	f (Block aa ab) = [explode aa,explode ab]+	g (Block _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((Block (TermRep.fDyn aa) (TermRep.fDyn ab))::Block) ; _ -> error "Term explosion error."++_tc_BlockTc = mkTyCon "Block"+instance Typeable Block where+    typeOf x = mkTyConApp _tc_BlockTc [ ]++instance Term Statement where+    explode (x::Statement) = TermRep (toDyn x, f x, g x) where+	f Skip = []+	f (BlockStat aa) = [explode aa]+	f (AssignmentStat ab) = [explode ab]+	f (InstanceCreationStat ac) = [explode ac]+	f (MethodInvocationStat ad) = [explode ad]+	f (ReturnStat ae) = [explode ae]+	f (IfStat af ag ah) = [explode af,explode ag,explode ah]+	f (WhileStat ai aj) = [explode ai,explode aj]+	f (StatementFocus ak) = [explode ak]+	g Skip xs = case TermRep.fArgs xs of [] -> toDyn ((Skip)::Statement) ; _ -> error "Term explosion error."+	g (BlockStat _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((BlockStat (TermRep.fDyn aa))::Statement) ; _ -> error "Term explosion error."+	g (AssignmentStat _) xs = case TermRep.fArgs xs of [ab] -> toDyn ((AssignmentStat (TermRep.fDyn ab))::Statement) ; _ -> error "Term explosion error."+	g (InstanceCreationStat _) xs = case TermRep.fArgs xs of [ac] -> toDyn ((InstanceCreationStat (TermRep.fDyn ac))::Statement) ; _ -> error "Term explosion error."+	g (MethodInvocationStat _) xs = case TermRep.fArgs xs of [ad] -> toDyn ((MethodInvocationStat (TermRep.fDyn ad))::Statement) ; _ -> error "Term explosion error."+	g (ReturnStat _) xs = case TermRep.fArgs xs of [ae] -> toDyn ((ReturnStat (TermRep.fDyn ae))::Statement) ; _ -> error "Term explosion error."+	g (IfStat _ _ _) xs = case TermRep.fArgs xs of [af,ag,ah] -> toDyn ((IfStat (TermRep.fDyn af) (TermRep.fDyn ag) (TermRep.fDyn ah))::Statement) ; _ -> error "Term explosion error."+	g (WhileStat _ _) xs = case TermRep.fArgs xs of [ai,aj] -> toDyn ((WhileStat (TermRep.fDyn ai) (TermRep.fDyn aj))::Statement) ; _ -> error "Term explosion error."+	g (StatementFocus _) xs = case TermRep.fArgs xs of [ak] -> toDyn ((StatementFocus (TermRep.fDyn ak))::Statement) ; _ -> error "Term explosion error."++_tc_StatementTc = mkTyCon "Statement"+instance Typeable Statement where+    typeOf x = mkTyConApp _tc_StatementTc [ ]++instance Term Class where+    explode (x::Class) = TermRep (toDyn x, f x, g x) where+	f (ClassDecl aa ab ac ad ae af) = [explode aa,explode ab,explode ac,explode ad,explode ae,explode af]+	g (ClassDecl _ _ _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad,ae,af] -> toDyn ((ClassDecl (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad) (TermRep.fDyn ae) (TermRep.fDyn af))::Class) ; _ -> error "Term explosion error."++_tc_ClassTc = mkTyCon "Class"+instance Typeable Class where+    typeOf x = mkTyConApp _tc_ClassTc [ ]++instance Term FieldDeclaration where+    explode (x::FieldDeclaration) = TermRep (toDyn x, f x, g x) where+	f (FieldDecl aa ab) = [explode aa,explode ab]+	g (FieldDecl _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((FieldDecl (TermRep.fDyn aa) (TermRep.fDyn ab))::FieldDeclaration) ; _ -> error "Term explosion error."++_tc_FieldDeclarationTc = mkTyCon "FieldDeclaration"+instance Typeable FieldDeclaration where+    typeOf x = mkTyConApp _tc_FieldDeclarationTc [ ]++instance Term Constructor where+    explode (x::Constructor) = TermRep (toDyn x, f x, g x) where+	f (ConstructorDecl aa ab ac ad) = [explode aa,explode ab,explode ac,explode ad]+	g (ConstructorDecl _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad] -> toDyn ((ConstructorDecl (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad))::Constructor) ; _ -> error "Term explosion error."++_tc_ConstructorTc = mkTyCon "Constructor"+instance Typeable Constructor where+    typeOf x = mkTyConApp _tc_ConstructorTc [ ]++instance Term MethodDecl where+    explode (x::MethodDecl) = TermRep (toDyn x, f x, g x) where+	f (MethodDecl aa ab ac ad) = [explode aa,explode ab,explode ac,explode ad]+	f (MethodDeclFocus ae) = [explode ae]+	g (MethodDecl _ _ _ _) xs = case TermRep.fArgs xs of [aa,ab,ac,ad] -> toDyn ((MethodDecl (TermRep.fDyn aa) (TermRep.fDyn ab) (TermRep.fDyn ac) (TermRep.fDyn ad))::MethodDecl) ; _ -> error "Term explosion error."+	g (MethodDeclFocus _) xs = case TermRep.fArgs xs of [ae] -> toDyn ((MethodDeclFocus (TermRep.fDyn ae))::MethodDecl) ; _ -> error "Term explosion error."++_tc_MethodDeclTc = mkTyCon "MethodDecl"+instance Typeable MethodDecl where+    typeOf x = mkTyConApp _tc_MethodDeclTc [ ]++instance Term Formals where+    explode (x::Formals) = TermRep (toDyn x, f x, g x) where+	f (Formals aa) = [explode aa]+	g (Formals _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((Formals (TermRep.fDyn aa))::Formals) ; _ -> error "Term explosion error."++_tc_FormalsTc = mkTyCon "Formals"+instance Typeable Formals where+    typeOf x = mkTyConApp _tc_FormalsTc [ ]++instance Term Formal where+    explode (x::Formal) = TermRep (toDyn x, f x, g x) where+	f (Formal aa ab) = [explode aa,explode ab]+	g (Formal _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((Formal (TermRep.fDyn aa) (TermRep.fDyn ab))::Formal) ; _ -> error "Term explosion error."++_tc_FormalTc = mkTyCon "Formal"+instance Typeable Formal where+    typeOf x = mkTyConApp _tc_FormalTc [ ]++instance Term VarDecl where+    explode (x::VarDecl) = TermRep (toDyn x, f x, g x) where+	f (VarDecl aa ab) = [explode aa,explode ab]+	g (VarDecl _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((VarDecl (TermRep.fDyn aa) (TermRep.fDyn ab))::VarDecl) ; _ -> error "Term explosion error."++_tc_VarDeclTc = mkTyCon "VarDecl"+instance Typeable VarDecl where+    typeOf x = mkTyConApp _tc_VarDeclTc [ ]++instance Term Type where+    explode (x::Type) = TermRep (toDyn x, f x, g x) where+	f INT = []+	f BOOLEAN = []+	f (Type aa) = [explode aa]+	g INT xs = case TermRep.fArgs xs of [] -> toDyn ((INT)::Type) ; _ -> error "Term explosion error."+	g BOOLEAN xs = case TermRep.fArgs xs of [] -> toDyn ((BOOLEAN)::Type) ; _ -> error "Term explosion error."+	g (Type _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((Type (TermRep.fDyn aa))::Type) ; _ -> error "Term explosion error."++_tc_TypeTc = mkTyCon "Type"+instance Typeable Type where+    typeOf x = mkTyConApp _tc_TypeTc [ ]++--  Imported from other files :-
+ StrategyLib-4.0-beta/examples/joos-rule02/Instance.hs view
@@ -0,0 +1,151 @@+module Instance where++import Prelude+import Monad+import Control.Monad.Identity+import Data.List+import StrategyLib+import Datatypes+import DatatypesTermInstances+++-- Datatype for types of relevant JOOS identifiers+data TypeJoos = ExprType Type++-- not needed for the present refactorings+              | MethodType (Maybe Type) Formals++                                      +-- Declared names (with type)+declaredJoos :: TU [(Identifier,TypeJoos)] Identity+declaredJoos =  adhocTU (adhocTU (constTU [])  +                  (Identity . declaredBlock))  +                  (Identity . declaredMeth)+  where+    declaredBlock (Block vds _)+      = map (\(VarDecl t i) -> (i,ExprType t)) vds+    declaredMeth (MethodDecl r i f@(Formals fps) _)+      = map (\(Formal t i) -> (i,ExprType t)) fps++++-- Defined names (without type)+definedJoos :: TU [Identifier] Identity+definedJoos =  adhocTU (constTU []) (Identity . definedAssignment)+  where+   definedAssignment (Assignment i _) = [i]++++-- Used names (without type)+usedJoos :: TU [Identifier] Identity+usedJoos =  adhocTU (adhocTU (constTU [])+              (Identity . usedExpression))+              (Identity . usedInvocation)+  where+    -- needed for extract+    usedExpression (Identifier i) = [i]+    usedExpression _              = []++    -- needed for eliminate but not for introduce and extract+    usedInvocation (ExpressionInvocation _ i _) = [i]+    usedInvocation (SuperInvocation i _)        = [i]++++-- Referenced names (without type)+referencedJoos :: TU [Identifier] Identity+referencedJoos =  op2TU (++) definedJoos usedJoos++++-- Method abstractions as needed for method extraction+instance Abstraction+           MethodDecl           -- abstr+           Identifier           -- name+           TypeJoos             -- tpe+           Statement            -- apply+  where+    getAbstrName  (MethodDecl _ i _ _) = Just i++    getAbstrParas (MethodDecl _ _ (Formals fps) _) =+      Just (map (\(Formal t i) -> (i,ExprType t)) fps)++    getAbstrBody  (MethodDecl _ _ _ b)  = Just (BlockStat b)++    getApplyName (MethodInvocationStat+                  (ExpressionInvocation This n _)) = Just n++    getApplyParas = undefined++    constrAbstr n l a =+      maybe Nothing+            (\fps -> Just (MethodDecl Nothing n (Formals fps) (toBlock a)))+            (mapM toFormal l)+     where+       toBlock a = Block [] [a]+       toFormal (i,tpe) = case tpe of+                           ExprType t -> Just (Formal t i)+                           _          -> Nothing      ++    constrApply n l =+      maybe Nothing+            (\aps -> Just (MethodInvocationStat+                           (ExpressionInvocation This n (Arguments aps))))+            (mapM toActual l)+     where+       toActual (i,tpe) = case tpe of+                           ExprType _ -> Just (Identifier i)+                           _          -> Nothing+++-- Focus on statements+wrapStatement = StatementFocus+unwrapStatement (StatementFocus x) = Just x+unwrapStatement _                  = Nothing++-- Focus on a list of method declarations+wrapMethods xs = [MethodDeclFocus xs]+unwrapMethods [MethodDeclFocus xs] = Just xs+unwrapMethods _                    = Nothing++-- Focus on a single method declaration+wrapMethod x = MethodDeclFocus [x]+unwrapMethod (MethodDeclFocus [x]) = Just x+unwrapMethod _                 = Nothing++++-- Type of transformation on JOOS programs+type TrafoJoos = Program -> Maybe Program++++-- Introduction of a method declaration+introduceJoos :: MethodDecl -> TrafoJoos+introduceJoos =  introduce declaredJoos referencedJoos unwrapMethods++++-- Extraction of a statement to constitute a new method declaration+extractJoos :: Identifier -> TrafoJoos+extractJoos = extract+               declaredJoos+               referencedJoos+               unwrapStatement+               wrapMethods+               unwrapMethods+               check+ where+  check _ f = and [noReturns f, noFrees f]+  noReturns = maybe True (const False) .+              applyTU (once_tdTU (adhocTU failTU+                (\s -> case s of+                   ReturnStat _ -> Just ()+                   _            -> Nothing)))+  noFrees = (==) [] . freeNames declaredJoos definedJoos+++-- Elimination of JOOS method declarations+eliminateJoos :: TrafoJoos+eliminateJoos = eliminate declaredJoos referencedJoos unwrapMethod
+ StrategyLib-4.0-beta/examples/joos-rule02/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import MainIO++main = mainIO "extract-fine.joos" "Test.log"+
+ StrategyLib-4.0-beta/examples/joos-rule02/MainIO.hs view
@@ -0,0 +1,98 @@+module MainIO where++import Prelude+import Monad+import System+import StrategyLib+import ParseLib+import Datatypes+import Parser+import Instance++++--- Main function for I/O and transformation ---------------------------------++mainIO f1 f2+  = do {+         str          <- readFile f1;+         (trafo,prog) <- pApply parseTestFile str;+         prog'        <- tApply trafo prog;+         str'         <- (return.show) prog';+         writeFile f2 str'+       }++++--- Parsing transformation scripts -------------------------------------------++parseTestFile :: Parser (TrafoJoos, Program)+parseTestFile = do {+                  td <- parseTrafoDeclaration;+                  parseSymbol "in";+                  prog <- parseProgram;+                  return (td,prog)+                }+++parseTrafoDeclaration :: Parser TrafoJoos+parseTrafoDeclaration =+ do { parseSymbol "declare";+      md <- parseMethodDecl;+      return (introduceJoos md)+    }+ ++++ do { parseSymbol "eliminate";+      return eliminateJoos+    }+ ++++ do { parseSymbol "extract";+      i <- parseIdentifier;+      return (extractJoos i)+    }+++--- Report on result of parsing ----------------------------------------------++pApply p s+  = case okParses of+      []     -> Monad.fail "ERROR: parsing failed!!\n"+      [x]    -> putStrLn "Status: successful parse." >> return (fst x)+      (x:xs) -> putStrLn "WARNING: ambiguous parse." >> return (fst x)+    where okParses = filter (null.snd) (papply p s)++++--- Report on result of transformation ---------------------------------------++tApply trafo prog+ =+   case trafo prog of+    Nothing    -> putStrLn "WARNING: refactoring failed."    >> return prog+    Just prog' -> putStrLn "Status: successful refactoring." >> return prog' ++++--- Illustrative code for focus selection  -----------------------------------++selectStatement :: Term t => t -> Maybe Statement+selectStatement =  applyTU selectStatementStrategy+  where+    selectStatementStrategy :: TU Statement Maybe+    selectStatementStrategy =  +      (adhocTU failTU +               (\stat -> case stat of+                           StatementFocus stat' -> Just stat'+                           _                    -> Nothing))+      `choiceTU`+      oneTU selectStatementStrategy++------------------------------------------------------------------------------++selectStatement' :: Term t => t -> Maybe Statement+selectStatement' =  selectFocus unwrapStatememt+ where+  unwrapStatememt (StatementFocus stat') = Just stat'+  unwrapStatememt _ = Nothing++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/joos-rule02/Makefile view
@@ -0,0 +1,18 @@+###############################################################################+#+# Environment for makerules+#++StrategyLib = ../..+derive      = DatatypesTermInstances.hs+Model       = drift-default+subdirs     = testsuite+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.examples+
+ StrategyLib-4.0-beta/examples/joos-rule02/ParseLib.hs view
@@ -0,0 +1,186 @@+{-----------------------------------------------------------------------------++                 A LIBRARY OF MONADIC PARSER COMBINATORS++                              29th July 1996+                           Revised, October 1996+                       Revised again, November 1998++                 Graham Hutton               Erik Meijer+            University of Nottingham    University of Utrecht++This Haskell 98 script defines a library of parser combinators, and is taken+from sections 1-6 of our article "Monadic Parser Combinators".  Some changes+to the library have been made in the move from Gofer to Haskell:++   * Do notation is used in place of monad comprehension notation;++   * The parser datatype is defined using "newtype", to avoid the overhead+     of tagging and untagging parsers with the P constructor.++-----------------------------------------------------------------------------}++module ParseLib+   (Parser, item, papply, (+++), sat, many, many1, sepby, sepby1, chainl,+    chainl1, chainr, chainr1, ops, bracket, char, digit, lower, upper,+    letter, alphanum, string, ident, nat, int, spaces, comment, junk,+    parse, token, natural, integer, symbol, identifier, module Monad) where++import Char+import Monad++infixr 5 +++++--- The parser monad ---------------------------------------------------------++newtype Parser a   = P (String -> [(a,String)])++instance Functor Parser where+   -- map         :: (a -> b) -> (Parser a -> Parser b)+   fmap f (P p)    = P (\inp -> [(f v, out) | (v,out) <- p inp])++instance Monad Parser where+   -- return      :: a -> Parser a+   return v        = P (\inp -> [(v,inp)])++   -- >>=         :: Parser a -> (a -> Parser b) -> Parser b+   (P p) >>= f     = P (\inp -> concat [papply (f v) out | (v,out) <- p inp])++instance MonadPlus Parser where+   -- mzero            :: Parser a+   mzero                = P (\inp -> [])++   -- mplus            :: Parser a -> Parser a -> Parser a+   (P p) `mplus` (P q)  = P (\inp -> (p inp ++ q inp))++--- Other primitive parser combinators ---------------------------------------++item              :: Parser Char+item               = P (\inp -> case inp of+                                   []     -> []+                                   (x:xs) -> [(x,xs)])++force             :: Parser a -> Parser a+force (P p)        = P (\inp -> let x = p inp in+                                (fst (head x), snd (head x)) : tail x)++first             :: Parser a -> Parser a+first (P p)        = P (\inp -> case p inp of+                                   []     -> []+                                   (x:xs) -> [x])++papply            :: Parser a -> String -> [(a,String)]+papply (P p) inp   = p inp++--- Derived combinators ------------------------------------------------------++(+++)             :: Parser a -> Parser a -> Parser a+p +++ q            = first (p `mplus` q)++sat               :: (Char -> Bool) -> Parser Char+sat p              = do {x <- item; if p x then return x else mzero}++many              :: Parser a -> Parser [a]+many p             = force (many1 p +++ return [])++many1             :: Parser a -> Parser [a]+many1 p            = do {x <- p; xs <- many p; return (x:xs)}++sepby             :: Parser a -> Parser b -> Parser [a]+p `sepby` sep      = (p `sepby1` sep) +++ return []++sepby1            :: Parser a -> Parser b -> Parser [a]+p `sepby1` sep     = do {x <- p; xs <- many (do {sep; p}); return (x:xs)}++chainl            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a+chainl p op v      = (p `chainl1` op) +++ return v++chainl1           :: Parser a -> Parser (a -> a -> a) -> Parser a+p `chainl1` op     = do {x <- p; rest x}+                     where+                        rest x = do {f <- op; y <- p; rest (f x y)}+                                 +++ return x++chainr            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a+chainr p op v      = (p `chainr1` op) +++ return v++chainr1           :: Parser a -> Parser (a -> a -> a) -> Parser a+p `chainr1` op     = do {x <- p; rest x}+                     where+                        rest x = do {f <- op; y <- p `chainr1` op; return (f x y)}+                                 +++ return x++ops               :: [(Parser a, b)] -> Parser b+ops xs             = foldr1 (+++) [do {p; return op} | (p,op) <- xs]++bracket           :: Parser a -> Parser b -> Parser c -> Parser b+bracket open p close = do {open; x <- p; close; return x}++--- Useful parsers -----------------------------------------------------------++char              :: Char -> Parser Char+char x             = sat (\y -> x == y)++digit             :: Parser Char+digit              = sat isDigit++lower             :: Parser Char+lower              = sat isLower++upper             :: Parser Char+upper              = sat isUpper++letter            :: Parser Char+letter             = sat isAlpha++alphanum          :: Parser Char+alphanum           = sat isAlphaNum++string            :: String -> Parser String+string ""          = return ""+string (x:xs)      = do {char x; string xs; return (x:xs)}++ident             :: Parser String+ident              = do {x <- lower; xs <- many alphanum; return (x:xs)}++nat               :: Parser Int+nat                = do {x <- digit; return (digitToInt x)} `chainl1` return op+                     where+                        m `op` n = 10*m + n++int               :: Parser Int+int                = do {char '-'; n <- nat; return (-n)} +++ nat++--- Lexical combinators ------------------------------------------------------++spaces            :: Parser ()+spaces             = do {many1 (sat isSpace); return ()}++comment           :: Parser ()+comment            = do {string "--"; many (sat (\x -> x /= '\n')); return ()}++junk              :: Parser ()+junk               = do {many (spaces +++ comment); return ()}++parse             :: Parser a -> Parser a+parse p            = do {junk; p}++token             :: Parser a -> Parser a+token p            = do {v <- p; junk; return v}++--- Token parsers ------------------------------------------------------------++natural           :: Parser Int+natural            = token nat++integer           :: Parser Int+integer            = token int++symbol            :: String -> Parser String+symbol xs          = token (string xs)++identifier        :: [String] -> Parser String+identifier ks      = token (do {x <- ident; if not (elem x ks) then return x+                                                               else mzero})++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/joos-rule02/Parser.hs view
@@ -0,0 +1,353 @@+{-----------------------------------------------------------------------------++This parser for JOOS is based on:++    David A. Watt. JOOS action semantics. Version 1, available from+    http://www.dcs.gla.ac.uk/~daw/publications/JOOS.ps, October 1997. ++Several small adaptations were made to parse more Java fragments:++  - Identifiers may now contain underscores.+  - method invocations of the form m(args) are now accepted, and +    interpreted as this.m(args).++-----------------------------------------------------------------------------}++module Parser where++import ParseLib+import Datatypes+++parseAssignment+  = do i <- parseIdentifier +       parseSymbol ":="+       e <- parseExpression+       return (Assignment i e) +++parseInstanceCreation+  = do parseSymbol "new"+       i    <- parseIdentifier+       args <- bracket (parseSymbol "(") parseArguments (parseSymbol ")")+       return (InstanceCreation i args)+++parseMethodInvocation+  = do e <- parseExpression+       case e of+         (MethodInvocationExpr mi) -> return mi+         _                         -> mzero+++parseSuperMethodInvocation+  = do parseSymbol "super"+       parseSymbol "."+       i <- parseIdentifier+       args <- bracket (parseSymbol "(") parseArguments (parseSymbol ")")+       return (SuperInvocation i args)+++parseMethodInvocationRemainder e+  = do parseSymbol "."+       i <- parseIdentifier+       parseSymbol "("+       args <- parseArguments+       parseSymbol ")"+       return (ExpressionInvocation e i args)+    ++++    case e of+      (Identifier i) -> do parseSymbol "("+                           args <- parseArguments+                           parseSymbol ")"+                           return (ExpressionInvocation This i args)+      _              -> mzero+++parseArguments+  = fmap Arguments (sepby parseExpression (parseSymbol ","))+++parseExpression +  = do e <- parseExpression1+       parseExpressionRemainder e+++parseExpressionRemainder e+  = do e' <- (fmap MethodInvocationExpr (parseMethodInvocationRemainder e))+             ++++             do op <- parseInfixOperator+                e2 <- parseExpression+                return (InfixExpr e op e2)+             ++++             do parseSymbol "instanceof"+                i <- parseIdentifier+                return (InstanceOf e i)+             ++++             do ao <- parseAndOr+                e2 <- parseExpression+                return (AndOrExpr e ao e2)+       parseExpressionRemainder e'+    ++++    return e++      +parseExpression1+  = fmap Literal parseLiteral+    ++++    fmap Identifier parseIdentifier+    ++++    do { parseSymbol "this"; return This }+    ++++    do op <- parsePrefixOperator+       e  <- parseExpression+       return (PrefixExpr op e)+    ++++    do t <- bracket (parseSymbol "(") parseType (parseSymbol ")")+       e <- parseExpression+       return (TypeCast t e)+    ++++    do (bracket (parseSymbol "(") parseExpression (parseSymbol ")"))+    ++++    fmap AssignmentExpr parseAssignment+    ++++    fmap InstanceCreationExpr parseInstanceCreation+    ++++    fmap MethodInvocationExpr parseSuperMethodInvocation+++parsePrefixOperator+  = do { parseSymbol "-"; return Neg }+    ++++    do { parseSymbol "!"; return Fac }+++parseInfixOperator+  = symbols [("==",Eq),("!=",NEQ),("<",Lt),(">",Gt),("<=",LEQ),(">=",GEQ),+             ("+",PLUS),("-",MINUS),("*",MUL),("/",DIV),("%",MOD)]+++parseAndOr+  = do { parseSymbol "||"; return OR }+    +++ +    do { parseSymbol "&&"; return AND }+++parseLiteral+  = fmap BooleanLit parseBooleanLiteral+    ++++    fmap IntegerLit parseIntegerLiteral+    ++++    do { parseSymbol "null"; return Null }+    ++++    fmap StringLit parseStringLiteral+++parseBooleanLiteral+  = do { parseSymbol "true"; return TRUE }+    ++++    do { parseSymbol "false"; return FALSE }+++parseIntegerLiteral+  = fmap toInteger natural+++parseStringLiteral+  = token (bracket (char '"') (many (sat (/='"') )) (char '"'))+++parseIdentifier+  = parse joosIdent+++parseBlock+  = do vds <- many parseVarDeclaration+       ss  <- many parseStatement+       return (Block vds ss)+++parseStatement+  = parseStatementNoBlock+    ++++    fmap BlockStat ( bracket (parseSymbol "{") +                              parseBlock+                             (parseSymbol "}") )+++parseStatementNoBlock+  = symbols [(";",Skip)]+    ++++    do a <- parseAssignment+       parseSymbol ";"+       return (AssignmentStat a)+    ++++    do i <- parseInstanceCreation+       parseSymbol ";"+       return (InstanceCreationStat i)+    ++++    do m <- parseMethodInvocation+       parseSymbol ";"+       return (MethodInvocationStat m)+    ++++    do parseSymbol "return"+       e <- optional parseExpression+       parseSymbol ";"+       return (ReturnStat e)+    ++++    do parseSymbol "if"+       c <- bracket (parseSymbol "(") parseExpression (parseSymbol ")")+       parseSymbol "then"+       t <- parseStatement+       parseSymbol "else"+       e <- parseStatement+       return (IfStat c t e)+    ++++    do parseSymbol "while" +       c <- bracket (parseSymbol "(") parseExpression (parseSymbol ")")+       s <- parseStatement+       return (WhileStat c s)+    ++++    fmap StatementFocus ( bracket (parseSymbol "<")+                                  parseStatement+                                  (parseSymbol ">") )+++parseClassDeclaration+  = do parseSymbol "public"+       f <- do { parseSymbol "final"; return True } +++ return False+       parseSymbol "class"+       cn <- parseIdentifier+       parseSymbol "extends"+       scn <- parseIdentifier+       parseSymbol "{"+       fds <- many parseFieldDeclaration+       cd  <- parseConstructorDeclaration+       mds <- parseMethodDecls+       parseSymbol "}"+       return (ClassDecl f cn scn fds cd mds)+++parseProgram+  = do cds <- many parseClassDeclaration+       bs  <- parseBlock+       return (Program cds bs)+++parseFieldDeclaration+  = do parseSymbol "private"+       t <- parseType +       i <- parseIdentifier+       return (FieldDecl t i)+++parseConstructorDeclaration+  = do parseSymbol "public"+       mn <- parseIdentifier+       parseSymbol "("+       pars <- parseFormals+       parseSymbol ")"+       parseSymbol "{"+       parseSymbol "super"+       args <- bracket (parseSymbol "(") parseArguments (parseSymbol ")")+       body <- parseBlock+       parseSymbol "}"+       return (ConstructorDecl mn pars args body)+++parseMethodDecls+  = +    do {+         mds <- ( bracket (parseSymbol "<<")+                          (many1 parseMethodDecl)+                          (parseSymbol ">>") );+         return [MethodDeclFocus mds]+       }+    ++++    ( many ( parseMethodDecl+             ++++             parseFocusedMethodDecl+           )+    )+++parseFocusedMethodDecl+  = do { parseSymbol "<";+         md <- parseMethodDecl;+         parseSymbol ">";+         return (MethodDeclFocus [md])+       }+++parseMethodDecl+  = do parseSymbol "public"+       t <- ( do { parseSymbol "void"; return Nothing }+              ++++              fmap Just parseType )+       mn <- parseIdentifier+       parseSymbol "("+       pars <- parseFormals+       parseSymbol ")"+       parseSymbol "{"+       body <- parseBlock+       parseSymbol "}"+       return (MethodDecl t mn pars body)+++parseFormals+  = fmap Formals (sepby parseFormal (parseSymbol ","))+++parseFormal+  = do t <- parseType+       i <- parseIdentifier+       return (Formal t i)+++parseVarDeclaration+  = do t <- parseType+       i <- parseIdentifier+       parseSymbol ";"+       return (VarDecl t i)+++parseType+  = do { parseSymbol "int"; return INT }+    ++++    do { parseSymbol "boolean"; return BOOLEAN }+    ++++    fmap Type parseIdentifier++++--- Auxiliary ---------------------------------------------------------------++parseSymbol = parse . symbol++joosIdent :: Parser String+joosIdent = token (do{ i <- joos_ident; if not (elem i ks) then return i+                                                           else mzero })+            where ks = ["new","super","this","instanceof","null",+                        "true","false","return","if","else","while",+                        "public","final","extends","private","int","boolean"]++joos_ident = do {x <- sat isJOOSalpha; xs <- many joos_alphanum; return (x:xs)}+             where joos_alphanum = sat isJOOSalphanum+                   isJOOSalphanum c = isAlphaNum' c || (c=='_')+                   isJOOSalpha c    = isAlpha' c    || (c=='_')++symbols :: [(String,a)] -> Parser a+symbols ss+  = foldr (\(sym,a) p -> do {parseSymbol sym; return a} +++ p ) mzero ss++optional p = fmap Just p +++ return Nothing++-- These are not present in all preludes.+-- Therefore, we repeat them with primed names.+isUpper' c              =  c >= 'A'   &&  c <= 'Z'+isLower' c              =  c >= 'a'   &&  c <= 'z'+isAlpha' c              =  isUpper' c  ||  isLower' c+isDigit' c              =  c >= '0'   &&  c <= '9'+isAlphaNum' c           =  isAlpha' c  ||  isDigit' c++-----------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/joos-rule02/Test.correct view
@@ -0,0 +1,1 @@+Program [ClassDecl False "Statement" "Object" [] (ConstructorDecl "Statement" (Formals []) (Arguments []) (Block [] [Skip])) [MethodDecl Nothing "printDetails" (Formals []) (Block [] [BlockStat (Block [] [MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))])]),MethodDecl Nothing "printOwning" (Formals [Formal (Type "double") "amount"]) (Block [] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),MethodInvocationStat (ExpressionInvocation This "printDetails" (Arguments []))])]] (Block [] [])
+ StrategyLib-4.0-beta/examples/joos-rule02/extract-fine.joos view
@@ -0,0 +1,30 @@+--+-- This refactoring is feasible.+--++extract+  +  printDetails++in++  public class Statement extends Object {++    public Statement() {+      super();+    }++    public void printOwning(double amount) {++      this.printBanner();+ +      < {+      -- Print details+      System_out.println("name:" + _name);+      System_out.println("amount" + amount);+      } >++    }++  }+
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import MainIO+import System++main = do +         [f1,f2] <- getArgs+         mainIO f1 f2
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/Makefile view
@@ -0,0 +1,51 @@+###############################################################################+#+# Environment for makerules+#++StrategyLib = ../../..+Model       = drift-default++tests = introduce-fine.log              \+	introduce-wrong-def.log \+	eliminate-fine.log              \+	eliminate-wrong.log             \+	extract-fine.log                \+	extract-wrong-assign.log        \+	extract-wrong-return.log+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.all+include ${StrategyLib}/scripts/makerules.opts+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.recurse+++###############################################################################+#+# Testsuite is only tested with runhugs.+#++check-hugs:+	(cd ..; ${MAKE} derive)+	rm -f *.log+	${MAKE} ${tests}++check-ghci:++check-ghc:+++###############################################################################+#+# Rules for producing test logs+#++%.log: %.joos+	runhugs	${hugs-opts} -P..: Main.hs $*.joos $*.log+	diff $*.log $*.correct
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/declare-fine.joos view
@@ -0,0 +1,33 @@+--+-- This refactoring is feasible.+--++declare++  public void Dummy() {+  }++in++  public class Statement extends Object {++    public Statement() {+      super();+    }++    << ++    public void printOwning(double amount) {++      this.printBanner();++      --Print details+      System_out.println("name:" + _name);+      System_out.println("amount" + amount);++    }++    >>++  }+
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/declare-wrong.joos view
@@ -0,0 +1,37 @@+--+-- This can't work because there is already a Dummy method in the way.+--++declare++  public void Dummy() {+  }++in++  public class Statement extends Object {++    public Statement() {+      super();+    }++    << ++    public void Dummy() {+    }++    public void printOwning(double amount) {++      this.printBanner();++      -- Print details++      System_out.println("name:" + _name);+      System_out.println("amount" + amount);++    }++    >>++  }+
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/eliminate-fine.correct view
@@ -0,0 +1,1 @@+Program [ClassDecl False "Statement" "Object" [] (ConstructorDecl "Statement" (Formals []) (Arguments []) (Block [] [Skip])) [MethodDecl Nothing "printOwning" (Formals [Formal (Type "double") "amount"]) (Block [] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))])]] (Block [] [])
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/eliminate-fine.joos view
@@ -0,0 +1,31 @@+--+-- This refactoring is feasible.+--++eliminate++in++  public class Statement extends Object {++    public Statement() {+      super();+    }++    <+    public void Dummy() {+    }+    >++    public void printOwning(double amount) {++      this.printBanner();++      -- Print details+      System_out.println("name:" + _name);+      System_out.println("amount" + amount);++    }++  }+
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/eliminate-wrong.correct view
@@ -0,0 +1,1 @@+Program [ClassDecl False "Statement" "Object" [] (ConstructorDecl "Statement" (Formals []) (Arguments []) (Block [] [Skip])) [MethodDeclFocus [MethodDecl Nothing "Dummy" (Formals []) (Block [] [])],MethodDecl Nothing "printOwning" (Formals [Formal (Type "double") "amount"]) (Block [] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),MethodInvocationStat (ExpressionInvocation This "Dummy" (Arguments [])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))])]] (Block [] [])
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/eliminate-wrong.joos view
@@ -0,0 +1,33 @@+--+-- We cannot eliminate the Dummy method because we refer to it.+-- ++eliminate++in++  public class Statement extends Object {++    public Statement() {+      super();+    }++    <+    public void Dummy() {+    }+    >++    public void printOwning(double amount) {++      this.printBanner();++      Dummy();++      -- Print details+      System_out.println("name:" + _name);+      System_out.println("amount" + amount);++    }++  }+
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/extract-fine.correct view
@@ -0,0 +1,1 @@+Program [ClassDecl False "Statement" "Object" [] (ConstructorDecl "Statement" (Formals []) (Arguments []) (Block [] [Skip])) [MethodDecl Nothing "printDetails" (Formals []) (Block [] [BlockStat (Block [] [MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))])]),MethodDecl Nothing "printOwning" (Formals [Formal (Type "double") "amount"]) (Block [] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),MethodInvocationStat (ExpressionInvocation This "printDetails" (Arguments []))])]] (Block [] [])
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/extract-fine.joos view
@@ -0,0 +1,30 @@+--+-- This refactoring is feasible.+--++extract+  +  printDetails++in++  public class Statement extends Object {++    public Statement() {+      super();+    }++    public void printOwning(double amount) {++      this.printBanner();+ +      < {+      -- Print details+      System_out.println("name:" + _name);+      System_out.println("amount" + amount);+      } >++    }++  }+
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/extract-wrong-assign.correct view
@@ -0,0 +1,1 @@+Program [ClassDecl False "Statement" "Object" [] (ConstructorDecl "Statement" (Formals []) (Arguments []) (Block [] [Skip])) [MethodDecl Nothing "printOwning" (Formals [Formal (Type "double") "amount"]) (Block [VarDecl (Type "double") "foo"] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),StatementFocus (BlockStat (Block [] [AssignmentStat (Assignment "foo" (Literal (StringLit "foo"))),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))]))])]] (Block [] [])
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/extract-wrong-assign.joos view
@@ -0,0 +1,33 @@+--+-- This refactoring is feasible.+--++extract+  +  printDetails++in++  public class Statement extends Object {++    public Statement() {+      super();+    }++    public void printOwning(double amount) {++      double foo;++      this.printBanner();+ +      < {+      foo := "foo";+      -- Print details+      System_out.println("name:" + _name);+      System_out.println("amount" + amount);+      } >++    }++  }+
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/extract-wrong-return.correct view
@@ -0,0 +1,1 @@+Program [ClassDecl False "Statement" "Object" [] (ConstructorDecl "Statement" (Formals []) (Arguments []) (Block [] [Skip])) [MethodDecl Nothing "printOwning" (Formals [Formal (Type "double") "amount"]) (Block [] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),StatementFocus (BlockStat (Block [] [MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")])),ReturnStat Nothing]))])]] (Block [] [])
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/extract-wrong-return.joos view
@@ -0,0 +1,31 @@+--+-- This refactoring is feasible.+--++extract+  +  printDetails++in++  public class Statement extends Object {++    public Statement() {+      super();+    }++    public void printOwning(double amount) {++      this.printBanner();+ +      < {+      -- Print details+      System_out.println("name:" + _name);+      System_out.println("amount" + amount);+      return;+      } >++    }++  }+
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/introduce-fine.correct view
@@ -0,0 +1,1 @@+Program [ClassDecl False "Statement" "Object" [] (ConstructorDecl "Statement" (Formals []) (Arguments []) (Block [] [Skip])) [MethodDecl Nothing "Dummy" (Formals []) (Block [] []),MethodDecl Nothing "printOwning" (Formals [Formal (Type "double") "amount"]) (Block [] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))])]] (Block [] [])
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/introduce-fine.joos view
@@ -0,0 +1,33 @@+--+-- This refactoring is feasible.+--++declare++  public void Dummy() {+  }++in++  public class Statement extends Object {++    public Statement() {+      super();+    }++    << ++    public void printOwning(double amount) {++      this.printBanner();++      --Print details+      System_out.println("name:" + _name);+      System_out.println("amount" + amount);++    }++    >>++  }+
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/introduce-wrong-def.correct view
@@ -0,0 +1,1 @@+Program [ClassDecl False "Statement" "Object" [] (ConstructorDecl "Statement" (Formals []) (Arguments []) (Block [] [Skip])) [MethodDeclFocus [MethodDecl Nothing "Dummy" (Formals []) (Block [] []),MethodDecl Nothing "printOwning" (Formals [Formal (Type "double") "amount"]) (Block [] [MethodInvocationStat (ExpressionInvocation This "printBanner" (Arguments [])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "name:")) PLUS (Identifier "_name")])),MethodInvocationStat (ExpressionInvocation (Identifier "System_out") "println" (Arguments [InfixExpr (Literal (StringLit "amount")) PLUS (Identifier "amount")]))])]]] (Block [] [])
+ StrategyLib-4.0-beta/examples/joos-rule02/testsuite/introduce-wrong-def.joos view
@@ -0,0 +1,37 @@+--+-- This can't work because there is already a Dummy method in the way.+--++declare++  public void Dummy() {+  }++in++  public class Statement extends Object {++    public Statement() {+      super();+    }++    << ++    public void Dummy() {+    }++    public void printOwning(double amount) {++      this.printBanner();++      -- Print details++      System_out.println("name:" + _name);+      System_out.println("amount" + amount);++    }++    >>++  }+
+ StrategyLib-4.0-beta/examples/little-lambda/Datatypes.hs view
@@ -0,0 +1,26 @@+{-----------------------------------------------------------------------------++			Example: LITTLE LAMBDA++			     StrategyLib++                   Ralf Laemmel                Joost Visser+               CWI & VU, Amsterdam            CWI, Amsterdam++-----------------------------------------------------------------------------}++module Datatypes where++--- Grammar ------------------------------------------------------------------++data Type = TVar Identifier+          | Arrow Type Type+          deriving (Show,Eq)+data Expr = Var Identifier+          | Apply Expr Expr+          | Lambda Identifier Type Expr+          deriving (Show,Eq)++type Identifier = String++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/examples/little-lambda/DatatypesTermInstances.hs view
@@ -0,0 +1,31 @@+module DatatypesTermInstances where+import Datatypes+import TermRep+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "Datatypes.hs" #-}+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Term Type where+    explode (x::Type) = TermRep (toDyn x, f x, g x) where+	f (TVar aa) = [explode aa]+	f (Arrow ab ac) = [explode ab,explode ac]+	g (TVar _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((TVar (TermRep.fDyn aa))::Type) ; _ -> error "Term explosion error."+	g (Arrow _ _) xs = case TermRep.fArgs xs of [ab,ac] -> toDyn ((Arrow (TermRep.fDyn ab) (TermRep.fDyn ac))::Type) ; _ -> error "Term explosion error."++_tc_TypeTc = mkTyCon "Type"+instance Typeable Type where+    typeOf x = mkTyConApp _tc_TypeTc [ ]++instance Term Expr where+    explode (x::Expr) = TermRep (toDyn x, f x, g x) where+	f (Var aa) = [explode aa]+	f (Apply ab ac) = [explode ab,explode ac]+	f (Lambda ad ae af) = [explode ad,explode ae,explode af]+	g (Var _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((Var (TermRep.fDyn aa))::Expr) ; _ -> error "Term explosion error."+	g (Apply _ _) xs = case TermRep.fArgs xs of [ab,ac] -> toDyn ((Apply (TermRep.fDyn ab) (TermRep.fDyn ac))::Expr) ; _ -> error "Term explosion error."+	g (Lambda _ _ _) xs = case TermRep.fArgs xs of [ad,ae,af] -> toDyn ((Lambda (TermRep.fDyn ad) (TermRep.fDyn ae) (TermRep.fDyn af))::Expr) ; _ -> error "Term explosion error."++_tc_ExprTc = mkTyCon "Expr"+instance Typeable Expr where+    typeOf x = mkTyConApp _tc_ExprTc [ ]++--  Imported from other files :-
+ StrategyLib-4.0-beta/examples/little-lambda/Main.hs view
@@ -0,0 +1,64 @@+{-----------------------------------------------------------------------------++			Example: LITTLE LAMBDA++			     StrategyLib++                   Ralf Laemmel                Joost Visser+               CWI & VU, Amsterdam            CWI, Amsterdam++-----------------------------------------------------------------------------}++module Main where++import StrategyLib+import Monad+import Control.Monad.Identity+import Datatypes+import DatatypesTermInstances++--- Terms for testing --------------------------------------------------------++type1 = TVar "AAP"+type2 = TVar "NOOT"+type3 = Arrow type1 type2++expr1 = Var "aap"+expr2 = Var "noot"+expr3 = Apply expr1 expr2+expr4 = Lambda "mies" type3 expr3++--- Example strategies -------------------------------------------------------++isType :: Type -> Maybe Type+isType = return++containsTypes	       = once_tdTP (adhocTP failTP isType)+testContainsTypes      = applyTP containsTypes expr4++getVar :: Expr -> Identity [Identifier]+getVar (Var i)         = return [i]+getVar (Lambda i _ _ ) = return [i]+getVar _               = return []++testCollect 	:: [Identifier]+testCollect	 = runIdentity+                    (applyTU (full_tdTU (adhocTU (constTU []) getVar)) expr4)++testShow        :: [String]+testShow         = runIdentity+                    (applyTU (full_tdTU myShowTU) expr4)+ where+  myShowTU = constTU []+             `adhocTU` (\(x::Expr)-> return [show x])+             `adhocTU` (\(x::Type)-> return [show x])+             `adhocTU` (\(x::Identifier)-> return [show x])++------------------------------------------------------------------------------++main = writeFile "Test.log"+                 (  show testContainsTypes ++ "\n"+                 ++ show testCollect       ++ "\n"+                 ++ show testShow          ++ "\n"+                 )+
+ StrategyLib-4.0-beta/examples/little-lambda/Makefile view
@@ -0,0 +1,9 @@+# refer to StrategyLib top-level directory+StrategyLib = ../..+Model       = drift-default++# list the modules to be derived with DrIFT+derive=DatatypesTermInstances.hs++# include the reusable makerules+include ${StrategyLib}/scripts/makerules.examples
+ StrategyLib-4.0-beta/examples/little-lambda/Test.correct view
@@ -0,0 +1,3 @@+Just (Lambda "mies" (Arrow (TVar "AAP") (TVar "NOOT")) (Apply (Var "aap") (Var "noot")))+["mies","aap","noot"]+["Lambda \"mies\" (Arrow (TVar \"AAP\") (TVar \"NOOT\")) (Apply (Var \"aap\") (Var \"noot\"))","\"mies\"","Arrow (TVar \"AAP\") (TVar \"NOOT\")","TVar \"AAP\"","\"AAP\"","TVar \"NOOT\"","\"NOOT\"","Apply (Var \"aap\") (Var \"noot\")","Var \"aap\"","\"aap\"","Var \"noot\"","\"noot\""]
+ StrategyLib-4.0-beta/examples/two-sorts-deriving/Datatypes.hs view
@@ -0,0 +1,13 @@+--- A simple system of mutually recursive datatypes --------------------------++module Datatypes where++import Data.Generics++data SortA = SortA1 SortB | SortA2 deriving (Show,Typeable,Data)+data SortB = SortB Integer SortA   deriving (Show,Typeable,Data)++++------------------------------------------------------------------------------+
+ StrategyLib-4.0-beta/examples/two-sorts-deriving/Main.hs view
@@ -0,0 +1,38 @@+--- Main module for TwoSorts example -----------------------------------------++module Main where++import StrategyLib+import Datatypes++--- Test case: Apply idTP to an integer --------------------------------------++test1 = (applyTP idTP 1)::Maybe Integer++--- Test case: Increment when faced with an integer --------------------------++strat2 :: Monad m => TP m+strat2  = adhocTP idTP (\x -> return (x + 1::Integer))+test2   = applyTP strat2 1 :: Maybe Integer++--- Test case: Negate when faced with a Boolean ------------------------------++strat3 :: Monad m => TP m+strat3  = adhocTP idTP (return . not)+test3   = applyTP strat3 True :: Maybe Bool++--- Test case: Increment all integers one can find ---------------------------++term4   = SortA1 (SortB 1 (SortA1 (SortB 2 (SortA1 (SortB 3 SortA2)))))+strat4 :: Monad m => TP m+strat4  = full_tdTP strat2+test4   = applyTP strat4 term4 :: Maybe SortA++------------------------------------------------------------------------------++main = writeFile "Test.log"+                 (  show test1 ++ "\n"+                 ++ show test2 ++ "\n"+                 ++ show test3 ++ "\n"+                 ++ show test4 ++ "\n"+                 )
+ StrategyLib-4.0-beta/examples/two-sorts-deriving/Makefile view
@@ -0,0 +1,48 @@+###############################################################################+#+# Environment for makerules+# This model only works with >= GHC 6.2+#++StrategyLib = ../..+Model       = deriving+++###############################################################################+#+# Run targets for a specific GHC version+#++run-ghci:+	ghci ${ghc-opts} Main.hs < ${StrategyLib}/scripts/TestMain+	diff Test.log Test.correct++run-ghc:+	@echo "To be implemented."+++###############################################################################+#+# Remaining run and check targets are empty because:+#  - it does not work for hugs anyway (so no run-hugs and check-hugs),+#  - and only works for specific version of ghc (so no check-ghc*).+#++run-hugs:++check-hugs:++check-ghc:++check-ghci:+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.opts+include ${StrategyLib}/scripts/makerules.drift+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.recurse
+ StrategyLib-4.0-beta/examples/two-sorts-deriving/README view
@@ -0,0 +1,2 @@+This model only works with >= GHC 6.2.+
+ StrategyLib-4.0-beta/examples/two-sorts-deriving/Test.correct view
@@ -0,0 +1,4 @@+Just 1+Just 2+Just False+Just (SortA1 (SortB 2 (SortA1 (SortB 3 (SortA1 (SortB 4 SortA2))))))
+ StrategyLib-4.0-beta/examples/two-sorts-drift-default/Datatypes.hs view
@@ -0,0 +1,9 @@+--- A simple system of mutually recursive datatypes --------------------------++module Datatypes where++data SortA = SortA1 SortB | SortA2 deriving Show+data SortB = SortB Integer SortA   deriving Show++------------------------------------------------------------------------------+
+ StrategyLib-4.0-beta/examples/two-sorts-drift-default/DatatypesTermInstances.hs view
@@ -0,0 +1,27 @@+module DatatypesTermInstances where+import Datatypes+import TermRep+{- Generated by DrIFT (Automatic class derivations for Haskell) -}+{-# LINE 1 "Datatypes.hs" #-}+{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance Term SortA where+    explode (x::SortA) = TermRep (toDyn x, f x, g x) where+	f (SortA1 aa) = [explode aa]+	f SortA2 = []+	g (SortA1 _) xs = case TermRep.fArgs xs of [aa] -> toDyn ((SortA1 (TermRep.fDyn aa))::SortA) ; _ -> error "Term explosion error."+	g SortA2 xs = case TermRep.fArgs xs of [] -> toDyn ((SortA2)::SortA) ; _ -> error "Term explosion error."++_tc_SortATc = mkTyCon "SortA"+instance Typeable SortA where+    typeOf x = mkTyConApp _tc_SortATc [ ]++instance Term SortB where+    explode (x::SortB) = TermRep (toDyn x, f x, g x) where+	f (SortB aa ab) = [explode aa,explode ab]+	g (SortB _ _) xs = case TermRep.fArgs xs of [aa,ab] -> toDyn ((SortB (TermRep.fDyn aa) (TermRep.fDyn ab))::SortB) ; _ -> error "Term explosion error."++_tc_SortBTc = mkTyCon "SortB"+instance Typeable SortB where+    typeOf x = mkTyConApp _tc_SortBTc [ ]++--  Imported from other files :-
+ StrategyLib-4.0-beta/examples/two-sorts-drift-default/Main.hs view
@@ -0,0 +1,39 @@+--- Main module for TwoSorts example -----------------------------------------++module Main where++import StrategyLib+import Datatypes+import DatatypesTermInstances++--- Test case: Apply idTP to an integer --------------------------------------++test1 = (applyTP idTP 1)::Maybe Integer++--- Test case: Increment when faced with an integer --------------------------++strat2 :: Monad m => TP m+strat2  = adhocTP idTP (\x -> return (x + 1::Integer))+test2   = applyTP strat2 1 :: Maybe Integer++--- Test case: Negate when faced with a Boolean ------------------------------++strat3 :: Monad m => TP m+strat3  = adhocTP idTP (return . not)+test3   = applyTP strat3 True :: Maybe Bool++--- Test case: Increment all integers one can find ---------------------------++term4   = SortA1 (SortB 1 (SortA1 (SortB 2 (SortA1 (SortB 3 SortA2)))))+strat4 :: Monad m => TP m+strat4  = full_tdTP strat2+test4   = applyTP strat4 term4 :: Maybe SortA++------------------------------------------------------------------------------++main = writeFile "Test.log"+                 (  show test1 ++ "\n"+                 ++ show test2 ++ "\n"+                 ++ show test3 ++ "\n"+                 ++ show test4 ++ "\n"+                 )
+ StrategyLib-4.0-beta/examples/two-sorts-drift-default/Makefile view
@@ -0,0 +1,17 @@+###############################################################################+#+# Environment for makerules+#++StrategyLib = ../..+derive      = DatatypesTermInstances.hs+Model       = drift-default+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.examples+
+ StrategyLib-4.0-beta/examples/two-sorts-drift-default/Test.correct view
@@ -0,0 +1,4 @@+Just 1+Just 2+Just False+Just (SortA1 (SortB 2 (SortA1 (SortB 3 (SortA1 (SortB 4 SortA2))))))
+ StrategyLib-4.0-beta/library/ChaseImports.hs view
@@ -0,0 +1,131 @@+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module+-- defines a generic algorithm for import chasing. This algorithm is not+-- strategic in nature itself, but usually it will be instantiated with+-- strategic functions for a particular object language.++-----------------------------------------------------------------------------} ++module ChaseImports (+-- * Type synonym+ ChaseName,+-- * Generic import chasing+ chaseWith,+ chaseFile, findFile+) where++import Monad+import IO+import System.Directory+import Control.Monad.Error () -- This import gives us (MonadPlus IO) !!+++------------------------------------------------------------------------------+-- * Type synonym++-- | The type of names of chaseable things. Synonym of 'String'.+type ChaseName = String++++------------------------------------------------------------------------------+-- * Generic import chasing++-- | A generic import chasing function. The type of the final result is a+--   parameter, which will usually be instantiated to a list of parsed+--   modules.+chaseWith +  :: [FilePath]		  -- ^ path (list of directories to search)+  -> [ChaseName]	  -- ^ todo (list of modules still to find)+  -> [ChaseName]          -- ^ done (list of modules already found)+  -> accu     		  -- ^ initial (start value of accumulator)+  -> ([FilePath] -> ChaseName -> IO (Either cu String))   +                          -- ^ parse (function that attempt to find and parse a module)+  -> (cu -> [ChaseName])  -- ^ imports (function that extracts imports from+                          --   a parse result)+  -> (ChaseName -> [ChaseName] -> cu -> accu -> IO accu)  +                          -- ^ on module (function that computes a new+			  --   accumulator from a parse result)+  -> (ChaseName -> accu -> IO accu) 		  +                          -- ^ on missing (function that computes a new+			  --   accumulator value when parsing failed)+  -> IO accu              -- ^ result (accumulated value)+chaseWith dirs todo done accu parseFile getImports onModule onMissing+ = chase todo done accu+   where+    chase [] done accu+      = do errLn "Import chasing complete."+           return accu+    chase (m:ms) done accu+      | m `elem` done = chase ms done accu+      | otherwise     = processFile `mplus` skipFile+     where+       processFile +         = do parse_result <- parseFile dirs m+	      case parse_result of+	        Left pin  +		  -> let is = getImports pin+                     in do accu' <- onModule m is pin accu+		           chase (ms++is) (m:done) accu'+	        Right msg +		  -> do errLn ("Failed to parse "++m++": "++msg)+		        accu' <- onMissing m accu+		        chase ms (m:done) accu'     +       skipFile    +         = do errLn ("Could not find module "++m++": skipping.")+	      accu' <- onMissing m accu+	      chase ms (m:done) accu'++++-- | Read a file from a number of possible directories, given a+--   base name and a list of possible extensions. Returns the content+--   of the file it found.+chaseFile :: [FilePath]          -- ^ path (directories to search)+          -> String              -- ^ base name+	  -> [String]            -- ^ possible extensions+	  -> IO String           -- ^ contents of file+chaseFile dirs basename exts+  = do results <- mapM tryReadFile fnames+       case dropWhile hasFailed results of+         ((Right (fc,fn)):_) +	     -> errLn ("Read file: "++fn) >> return fc+	 _   -> errLn ("Could not find file: "++basename) >> mzero                  +    where +      fnames = [d++'/':basename++'.':e | d <- dirs, e <- exts]+      hasFailed (Left _) = True+      hasFailed _        = False+      tryReadFile fn = try ( readFile fn >>= \fc -> return (fc,fn) )++      +-- | Find a file in a number of possible directories, given a+--   base name and a list of possible extensions. Returns the full+--   name of the file it found.+findFile :: [FilePath]          -- ^ path (directories to search)+         -> String              -- ^ base name+	 -> [String]            -- ^ possible extensions+	 -> IO FilePath         -- ^ contents of file+findFile dirs basename exts+  = do existingFileNames <- filterM doesFileExist fnames+       case existingFileNames of+         (fn:_) +	     -> errLn ("Found file: "++fn) >> return fn+	 _   -> errLn ("Could not find file: "++basename) >> mzero                  +    where +      fnames = [d++'/':basename++'.':e | d <- dirs, e <- exts]+      +++------------------------------------------------------------------------------+-- * Progress and error messages ++-- | Helper function for reporting errors and progress to stderr+errLn str = hPutStrLn stderr str+++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/ContainerTheme.hs view
@@ -0,0 +1,175 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module+-- provides combinators which allow one to use strategies to construct+-- generic containers.++------------------------------------------------------------------------------++module ContainerTheme (+	module ContainerTheme,+) where++import StrategyPrelude +import Control.Monad+import Data.Monoid++------------------------------------------------------------------------------+-- * Pointwise function update++-- | Pointwise modification of monomorphic functions+modify :: Eq x => (x -> y) -> x -> y -> (x -> y)+modify f x y = \x' -> if x == x' then y else f x'++-- | Pointwise modification of type-preserving strategies+modifyTP :: (MonadPlus m, Eq t, Term t) => TP m -> t -> m t -> TP m+modifyTP f t = adhocTP f . modify (applyTP f) t++-- | Pointwise modification of type-unifying strategies+modifyTU :: (MonadPlus m, Eq t, Term t) => TU a m -> t -> m a -> TU a m+modifyTU f t = adhocTU f . modify (applyTU f) t++------------------------------------------------------------------------------+-- * Generic Set (not observable)++-- | Type of generic sets+type GSet = TU () Maybe++-- | Empty generic set.+emptyGSet	:: GSet+emptyGSet	=  failTU++-- | Completely filled generic set+fullGSet	:: GSet+fullGSet	=  constTU mempty++-- | Add an element to a generic set+addGSet 	:: (Eq t, Term t) => t -> GSet -> GSet+addGSet t s 	=  modifyTU s t (return mempty)++-- | Remove an element from a generic set+removeGSet	:: (Eq t, Term t) => t -> GSet -> GSet+removeGSet t s  =  modifyTU s t mzero++-- | Test whether a given element is contained in a generic set+containsGSet 	:: (Eq t, Term t) => t -> GSet -> Bool+containsGSet t s=  maybe False (const True) (applyTU s t)++------------------------------------------------------------------------------+-- * Generic Map (not observable)++-- | Type of generic maps+type GMap value = TU value Maybe++-- | Empty generic map+emptyGMap	:: GMap v+emptyGMap	=  failTU++-- | Remove an element from a generic map (my key)+removeGMap	:: (Eq t, Term t) => t -> GMap v -> GMap v+removeGMap t s  =  modifyTU s t mzero++-- | Test whether an element with given key is contained in a generic map+containsGMap 	:: (Eq t, Term t) => t -> GMap v -> Bool+containsGMap t s=  maybe False (const True) (applyTU s t)++-- | Add an entry with given key and value to a generic map+putGMap 	:: (Eq t, Term t) => t -> v -> GMap v -> GMap v+putGMap t v s	=  modifyTU s t (return v)++-- | Obtain the value for a given key from a generic map+getGMap 	:: (Eq t, Term t) => t -> GMap v -> Maybe v+getGMap t s	=  applyTU s t+++------------------------------------------------------------------------------+--- Generic List (observable per type) ---------------------------------------++type GList = (Integer -> TP Maybe,Integer)++sizeGList (_,i)	= i+indxGList (f,_) = f++emptyGList	:: GList+emptyGList	=  (const failTP,0)++addGList	:: Term t => t -> GList -> GList +addGList t l	=  (modify f s e,s+1)+                   where s  = sizeGList l+		         f  = indxGList l+                         e = monoTP (const (return t))	+			 	 +putGList	:: Term t => Integer -> t -> GList -> GList +putGList i t l	=  if i < s then (modify f i e,s)+                            else l+                   where s  = sizeGList l+		         f  = indxGList l+                         e = monoTP (const (return t))	+			 	 +getGList	:: Term t => Integer -> GList -> Maybe t +getGList i l	=  if i < s then applyTP (f i) undefined+                            else Nothing+                   where f  = indxGList l+		         s  = sizeGList l+	+mapGListTP 	:: TP Maybe -> GList -> GList+mapGListTP s l	=  (nth (map forElem [0..size-1]),size)+                   where forElem   :: Integer -> TP Maybe+		         forElem i =  (indxGList l i) `seqTP` s+			 size = sizeGList l+			 +mapGListTU 	:: Term t => (t -> ()) -> TU a Maybe -> GList -> [Maybe a]+mapGListTU g s l=  map forElem [0..size-1]+                   where forElem i +		           = applyTU ((indxGList l i) `seqTU` s) t+			 size = sizeGList l+			 (t,()) = (undefined,g t)	+			  +elemsGList 	:: Term t => (t -> ()) -> GList -> [t]+elemsGList g l	=  filterJust (map forElem [0..size-1])+                   where forElem i +		           = applyTP (indxGList l i) t+			 size = sizeGList l+			 (t,()) = (error "NOTERM",g t)	 +			 filterJust as	= map unJust (filter isJust as)+                         unJust (Just t) = t+                         isJust (Just _) = True+                         isJust Nothing  = False++-- Variation on !! but now for Integer iso Int+nth             :: [a] -> Integer -> a+nth (x:_)  0       = x+nth (_:xs) n | n>0 = nth xs (n-1)+nth (_:_)  _       = error "ContainterTheme.nth: negative index"+nth []     _       = error "ContainerTheme.nth: index too large"++------------------------------------------------------------------------------+--- Assign unique codes to terms of any type ---------------------------------++type Coder 		=  (Int,TU Int Maybe)++noCode 			:: Coder+noCode 			=  (0,failTU)++getCode 		:: Term x => Coder -> x -> Maybe Int+getCode (_,s) 		=  applyTU s++setCode 		:: (Term x, Eq x) => Coder -> x -> Int -> Coder+setCode (i,s) x i' 	=  (i,modifyTU s x (return i'))++nextCode 		:: Coder -> (Int,Coder)+nextCode (i,s) 		=  (i,(i+1,s))++enCode 			:: (Term x, Eq x) => Coder -> x -> Coder+enCode c x 		=  maybe gen found (getCode c x)+  			   where+                             gen = let (i,c') = nextCode c +                                   in setCode c' x i+                             found = const c++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/EffectTheme.hs view
@@ -0,0 +1,178 @@+------------------------------------------------------------------------------ +-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module+-- provides combinators to localize monadic effects.+--+------------------------------------------------------------------------------ ++module EffectTheme (+	-- * Replace one strategy monad by another+	mrunTP, mrunTU,+	-- * Add an effect to the strategy monad+	liftTP, liftTU,+	-- * Remove an effect from the strategy monad +	unliftTP, unliftTU,+	-- * Localize specific effects+	-- ** Localize the partiality effect +	guaranteeSuccessTP, guaranteeSuccessTU, +	unsafeGuaranteeSuccessTP,+	-- ** Localize the state effect +	localStateTP, localStateTU,+) where+++import Monad+import MonadRun+import Control.Monad.Trans+import StrategyPrelude+import OverloadingTheme+import StrategyPrimitives+++------------------------------------------------------------------------------++-- * Replace one strategy monad by another++-- The two monads are unrelated.+-- The first is run, and the resulting value is returned in the other.+-- We use the `run' function of one monad, and the `return' function+-- of the other.++-- | Replace the monad in a type-preserving strategy, given a monad+--   algebra (see 'MonadRun') for the monad that is replaced. The two +--   monads are unrelated, so none of the effects in the monad that is+--   replaced carry over to the one that replaces it.+mrunTP 		:: (Monad m, Monad m', MonadRun s m) +		=> (forall a . s a a) -> TP m -> TP m'+mrunTP alg	=  msubstTP (mrun alg)++-- | Replace the monad in a type-unifying strategy, given a monad+--   algebra (see 'MonadRun') for the monad that is replaced. The two +--   monads are unrelated, so none of the effects in the monad that is+--   replaced carry over to the one that replaces it.+mrunTU 		:: (Monad m, Monad m', MonadRun s m) +		=> s a a -> TU a m -> TU a m'+mrunTU alg	=  msubstTU (mrun alg)+++------------------------------------------------------------------------------+-- * Add an effect to the strategy monad++-- | Add an effect to the monad in a type-preserving strategy. +--   The monads are related by a monad transformer, so the effects of the+--   incoming monad are preserved in the result monad. We use the `lift'+--   function of the monad transformer.+liftTP	:: (Monad (t m), Monad m, MonadTrans t) => TP m -> TP (t m)+liftTP	= msubstTP lift++-- | Add an effect to the monad in a type-unifying strategy. +--   The monads are related by a monad transformer, so the effects of the+--   incoming monad are preserved in the result monad. We use the `lift'+--   function of the monad transformer.+liftTU	:: (Monad (t m), Monad m, MonadTrans t) => TU a m -> TU a (t m)+liftTU	= msubstTU lift+++------------------------------------------------------------------------------+-- * Remove an effect from the strategy monad ++-- | remove an effect from the monad of a type-preserving strategy.+--   The monads are related by a monad untransformer (see 'MonadUnTrans'),+--   so the effects of the incoming monad are preserved in the result+--   monad, except for the effect for which a monad algebra is supplied.+unliftTP 		:: (Monad (t m), Monad m, MonadUnTrans s t) +			=> (forall a . s a a) -> TP (t m) -> TP m+unliftTP alg 		=  msubstTP (unlift alg)++-- | remove an effect from the monad of a type-unifying strategy.+--   The monads are related by a monad untransformer (see 'MonadUnTrans'),+--   so the effects of the incoming monad are preserved in the result+--   monad, except for the effect for which a monad algebra is supplied.+unliftTU 		:: (Monad (t m), Monad m, MonadUnTrans s t) +			=> s a a -> TU a (t m) -> TU a m+unliftTU alg 		=  msubstTU (unlift alg)++-- Does not work:+-- unliftS alg 		=  msubstS (unlift alg)+++------------------------------------------------------------------------------+-- * Localize specific effects++-- ** Localize the partiality effect ++-- Safe versions provide default to cope with Nothing.+-- Note the explicit universal quantification of this value+-- in the TP case.++-- | Localize the partiality effect in a type-preserving strategy. A+--   default value must be supplied to be used to recover from+--   failure. Since this default parameter is universally quantified,+--   only 'undefined' and 'error ...' can be used to instantiate it.+--   See also 'unsafeGuaranteeSuccessTP.+guaranteeSuccessTP :: (Monad (t m), Monad m, MonadUnTrans MaybeAlg t) +      => (forall a . a)   -- ^ default value (Note: universally quantified!)+      -> TP (t m)         -- ^ type-preserving partial strategy+      -> TP m             -- ^ type-preserving strategy without partiality+guaranteeSuccessTP x s+  = unliftTP (MaybeAlg x id) s++-- | Localize the partiality effect in a type-unifying strategy. A+--   default value must be supplied to be used to recover from+--   failure. +guaranteeSuccessTU :: (Monad (t m), Monad m, MonadUnTrans MaybeAlg t) +           => a             -- ^ default value+           -> TU a (t m)    -- ^ type-preserving partial strategy+	   -> TU a m        -- ^ type-preserving strategy without partiality+guaranteeSuccessTU x s+  = unliftTU (MaybeAlg x id) s++-- Does not work:+-- guaranteeSuccessS :: (Monad (t m), Monad m, MonadUnTrans MaybeAlg t) +--                   => a -> TU a (t m) -> TU a m+-- guaranteeSuccessS x s+--   = msubstS (unlift (MaybeAlg x id)) s++-- | Unsafe version of 'guaranteeSuccessTP'. This version uses uses `undefined'+--   to recover from failure. For the type-preserving case, this is the only+--   possible default value.+unsafeGuaranteeSuccessTP :: (Monad (t m), Monad m, MonadUnTrans MaybeAlg t) +                         => TP (t m) -> TP m+unsafeGuaranteeSuccessTP s+  = guaranteeSuccessTP undefined s+  +-- | Unsafe version of 'guaranteeSuccessTU'. This version uses uses `undefined'+--   to recover from failure. Use 'guaranteeSuccessTU' instead.+unsafeGuaranteeSuccessTU :: (Monad (t m), Monad m, MonadUnTrans MaybeAlg t) +                         => TU a (t m) -> TU a m+unsafeGuaranteeSuccessTU s+  = guaranteeSuccessTU undefined s++-- Does not work:+-- unsafeGuaranteeSuccessS s+--   = guaranteeSuccessS undefined s++------------------------------------------------------------------------------+-- ** Localize the state effect ++-- | Localize the state of a type-preserving strategy. The first argument+--   represents the initial state.  +localStateTP :: (Monad (t m), Monad m, MonadUnTrans (StateAlg s) t) +             => s -> TP (t m) -> TP m +localStateTP s+  = unliftTP (StateAlg s fst)++-- | Localize the state of a type-unifying strategy. The first argument+--   represents the initial state.  +localStateTU :: (Monad (t m), Monad m, MonadUnTrans (StateAlg s) t) +             => s -> TU a (t m) -> TU a m +localStateTU s+  = unliftTU (StateAlg s fst)++     +------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/FixpointTheme.hs view
@@ -0,0 +1,59 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module +-- defines combinators that iterate until some kind of fixpoint is reached.+--+------------------------------------------------------------------------------++module FixpointTheme where++import StrategyPrelude+import FlowTheme+import TraversalTheme+import Monad+++------------------------------------------------------------------------------+-- * Fixpoint Iteration +++-- | Exhaustive repeated application at the root of the input term+repeatTP        :: MonadPlus m => TP m -> TP m+repeatTP s      =  tryTP (seqTP s (repeatTP s))++++------------------------------------------------------------------------------+-- * Fixpoint Traversal +++-- | Exhaustive repeated application throughout the input term.+reduce 		:: MonadPlus m => TP m -> TP m+reduce s 	=  repeatTP (someTP (reduce s) `choiceTP` s)++-- | Exhaustive repeated application according to the left-most+--   outermost traversal strategy.+outermost  	:: MonadPlus m => TP m -> TP m+outermost s	=  repeatTP (once_tdTP s)++-- | Exhaustive repeated application according to the left-most+--   innermost traversal strategy, implemented in a naive way.+--   Use 'innermost' instead.+innermost'	:: MonadPlus m => TP m -> TP m+innermost' s	=  repeatTP (once_buTP s)++-- | Exhaustive repeated application according to the left-most+--   innermost traversal strategy, implemented in a more +--   efficient way.+innermost	:: MonadPlus m => TP m -> TP m+innermost s	=  allTP (innermost s) +                   `seqTP` +                   (tryTP (s `seqTP` (innermost s)))++------------------------------------------------------------------------------+
+ StrategyLib-4.0-beta/library/FlowTheme.hs view
@@ -0,0 +1,194 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module +-- defines combinators to wire up control and data flow. Whenever possible,+-- we define the combinators in an overloaded fashion but we provide+-- type-specialised variants for TP and TU for convenience.++------------------------------------------------------------------------------++module FlowTheme where++import StrategyPrelude+import OverloadingTheme+import Control.Monad+import Data.Monoid+++------------------------------------------------------------------------------+-- * Try: recover from failure++-- | Attempt a strategy 's', but recover if it fails.+tryS         :: (StrategyPlus s m, StrategyMonoid s m) => s m -> s m+tryS s       =  s `choiceS` skipS++-- | Attempt a type-preserving strategy 's', but if it fails, return the+--   input term unchanged.+tryTP        :: MonadPlus m => TP m -> TP m+tryTP        =  tryS++-- | Attempt a type-unifying strategy 's', but if it fails, return the+--   'mempty' element of a 'Monoid'.+tryTU        :: (MonadPlus m, Monoid u) => TU u m -> TU u m+tryTU  	     =  tryS+++------------------------------------------------------------------------------+-- * Test: ignore result, but retain effects++-- | Test for a strategy's success in a type-preserving context.+testS           :: Strategy s m => s m -> TP m+testS s         =  voidS s `passS` const idTP++-- | Test for a type-preserving strategy's success in a+--   type-preserving context.+testTP 		:: Monad m => TP m -> TP m+testTP  	=  testS++-- | Test for a type-unifying strategy's success in a +--   type-preserving context.+testTU 		:: Monad m => TU a m -> TP m+testTU  	=  testS+++------------------------------------------------------------------------------+-- * If-then-else: pass value from condition to then-clause++-- | If 'c' succeeds, pass its value to the then-clause 't', +--   otherwise revert to the else-clause 'e'.+ifS       :: StrategyPlus s m => TU u m -> (u -> s m) -> s m -> s m+ifS c t e =  ((c `passTU` (constTU . Just)) `choiceTU` constTU Nothing)+             `passS`+             maybe e t++-- | If 'c' succeeds, pass its value to the then-clause 't', +--   otherwise revert to the else-clause 'e'.+ifTP      :: MonadPlus m => TU u m -> (u -> TP m) -> TP m -> TP m+ifTP      =  ifS++-- | If 'c' succeeds, pass its value to the then-clause 't', +--   otherwise revert to the else-clause 'e'.+ifTU      :: MonadPlus m => TU u m -> (u -> TU u' m) -> TU u' m -> TU u' m+ifTU      =  ifS+++------------------------------------------------------------------------------+-- * If-then: disciplined form of a guarding++-- | Guard then-clause 't' by the void-valued type-unifying+--   condition 'c'.+ifthenS     :: Strategy s m => TU () m -> s m -> s m+ifthenS c t =  c `passS` const t++-- | Guard type-preserving then-clause 't' by the void-valued type-unifying+--   condition 'c'.+ifthenTP    :: Monad m => TU () m -> TP m -> TP m+ifthenTP    =  ifthenS++-- | Guard type-unifying then-clause 't' by the void-valued type-unifying+--   condition 'c'.+ifthenTU    :: Monad m => TU () m -> TU u m -> TU u m+ifthenTU    =  ifthenS+++------------------------------------------------------------------------------+-- * Not: negation by failure ++-- | Invert the success-value of strategy 's'.+notS    :: StrategyPlus s m => s m -> TP m+notS s  =  ifS (voidS s) (const failTP) idTP++-- | Invert the success-value of type-preserving strategy 's'. Its output+--   term (in case of success) will be ignored.+notTP   :: MonadPlus m => TP m -> TP m+notTP   =  notS++-- | Invert the success-value of type-unifying strategy 's'. Its output+--   value (in case of success) will be ignored.+notTU   :: MonadPlus m => TU u m -> TP m+notTU   = notS+++------------------------------------------------------------------------------+-- * Exclusive choice++-- | Succeed if exactly one argument strategy succeeds.+xchoiceS        :: StrategyPlus s m => s m -> s m -> s m+s `xchoiceS` s' =  (notS s' `seqS` s) `choiceS` (notS s `seqS` s')++-- | Succeed if exactly one argument strategy succeeds.+xchoiceTP       :: MonadPlus m => TP m -> TP m -> TP m+xchoiceTP       =  choiceS++-- | Succeed if exactly one argument strategy succeeds.+xchoiceTU       :: MonadPlus m => TU u m -> TU u m -> TU u m+xchoiceTU       =  choiceS+++------------------------------------------------------------------------------+-- * Generic filter, derived from monomorphic predicate++-- | If predicate 'g' holds for the input term, return it as output term,+--   otherwise fail.+filterTP        :: (Term t, MonadPlus m) => (t -> Bool) -> TP m+filterTP g      =  monoTP (\x -> if g x then return x else mzero)++-- | If predicate 'g' holds for the input term, return it as output value,+--   otherwise fail.+filterTU        :: (Term t, MonadPlus m) => (t -> Bool) -> TU t m+filterTU g      =  monoTU (\x -> if g x then return x else mzero)+++------------------------------------------------------------------------------+-- * Generic ticker, derived from monomorphic predicate++-- | If predicate 'g' holds for the input term, +--   return 1 otherwise return 0.+tickTU 	        :: (Monad m, Term t, Num n) => (t -> Bool) -> TU n m+tickTU g        =  adhocTU (constTU 0) (\t -> return (if g t then 1 else 0))+++------------------------------------------------------------------------------+-- * Type guards++-- | Type guard (function type), i.e., guard that does not observe values+type TypeGuard a =  a -> ()++-- | Type guard (function). +--   Typical usage:+--+-- @ +--   full_tdTU (typeTickTU (typeGuard::TypeGuard MyType))+-- @+typeGuard	 :: TypeGuard a+typeGuard	 =  const ()++------------------------------------------------------------------------------+-- * Generic ticker, derived from type guard++-- | If type guard holds for the input term, +--   return 1 otherwise return 0.+typeTickTU  	 :: (Term t, Monad m, Num n) => TypeGuard t -> TU n m+typeTickTU g	 =  adhocTU (constTU 0) ((\() -> return 1) . g)+++------------------------------------------------------------------------------+-- * Generic filters,  derived from type guard++-- | If type guard holds for the input term, return it as output term,+--   otherwise fail. +typeFilterTP     :: (Term t, MonadPlus m) => TypeGuard t -> TP m+typeFilterTP g   =  monoTP (\x -> ((\() -> return x) . g) x)++-- | If type guard holds for the input term, return it as output value,+--   otherwise fail. +typeFilterTU     :: (Term t, MonadPlus m) => TypeGuard t -> TU t m+typeFilterTU g   =  monoTU (\x -> ((\() -> return x) . g) x)+++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/KeyholeTheme.hs view
@@ -0,0 +1,114 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module+-- defines a number combinators for keyhole operations, i.e. for operations+-- that have ordinary parametric or adhoc polymorhpic types, but employ+-- strategies inside.++------------------------------------------------------------------------------+ +module KeyholeTheme where++import Monad+import Control.Monad.Identity +import MonadicFunctions+import StrategyPrelude+import OverloadingTheme+import PathTheme+import FlowTheme+import TraversalTheme+++------------------------------------------------------------------------------+-- * Focus++-- | Select the identified focus.+--   Fails if no subterm can be selected.+selectFocus :: (Term f, Term t)+            => (f -> Maybe f)	-- ^ Identify focus+            -> t 		-- ^ Input term+            -> Maybe f		-- ^ Focused term+selectFocus unwrap = applyTU (once_tdTU (adhocTU failTU unwrap))++-- | Replace the identified focus.+--   Fails if no subterm can be replaced.+replaceFocus :: (Term t, Term t') +             => (t -> Maybe t)		-- Transform focus+             -> t'			-- Input term+             -> Maybe t'		-- Output term+replaceFocus trafo = applyTP (once_tdTP (adhocTP failTP trafo))++-- | Delete the focus assuming it is an element in a list. +--   Fails if no deletion can be performed.+deleteFocus :: (Term f, Term [f], Term t)+            => (f -> Maybe f)	-- ^ Identify focus+            -> t		-- ^ Input term+            -> Maybe t		-- ^ Output term without focused entity+deleteFocus unwrap = applyTP (once_tdTP (adhocTP failTP filterF))+  where +    filterF xs = do { xs' <- filterM pred xs;+                      guard (length xs - 1 == length xs');+                      return xs'+                    }+    pred x = (unwrap x >>= \_ -> return False)+             `mplus`+             return True++-- | Find the host of the focused entity, i.e. a superterm of the+--   focussed subterm.+selectHost :: (Term f, Term h, Term t)+           => (f -> Maybe f)	-- ^ Get focus+           -> (h -> Maybe h)	-- ^ Get host+           -> t			-- ^ Input term+           -> Maybe h 		-- ^ Located host+selectHost getFocus getHost+  = applyTU ( adhocTU failTU getHost+              `aboveS`+              (adhocTU failTU (\f -> getFocus f >>= return . const ())) )++-- Mark a host of a focused entity.+markHost :: (Term f, Term h, Term t)+         => (f -> Bool)		-- ^ Test focus+         -> (h -> h)		-- ^ Wrap host+         -> t			-- ^ Input term+         -> Maybe t		-- ^ Output term+markHost testFocus wrapHost =+  applyTP (host `aboveS` focus)+ where+   host = adhocTP failTP (Just . wrapHost)+   focus = adhocTU failTU (guard . testFocus)++++------------------------------------------------------------------------------+-- * Listification++-- | Put all nodes of a certain type into a list.+listify 	:: (Term x, Term y) => x -> [y]+listify 	=  runIdentity . applyTU worker  +  where+    worker  = op2TU (++) process recurse +    process = adhocTU (constTU []) (\x -> return [x])+    recurse = allTU (++) [] worker++-- | Put all nodes of type 'String' into a list. This is a type-specialization+--   of 'listify'.+strings 	:: Term x => x -> [String]+strings 	=  listify++------------------------------------------------------------------------------ +-- * Keyhole versions of basic strategy combinators.++-- | Apply the argument function to the unique subterm of the input term.+--   Fail if the input term has more subterms or if the subterm is not of+--   the appropriate type. This is a keyhole version of the traversal+--   combinator 'injTP'+inj 		:: (MonadPlus m, Term x, Term c) => (c -> m c) -> (x -> m x)+inj f 		=  applyTP (injTP (adhocTP failTP f))++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/Makefile view
@@ -0,0 +1,5 @@+StrategyLib = ..+include ${StrategyLib}/scripts/makerules.all+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.check+include ${StrategyLib}/scripts/makerules.recurse
+ StrategyLib-4.0-beta/library/MetricsTheme1.hs view
@@ -0,0 +1,105 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module +-- defines combinators to define metrics extractors.++------------------------------------------------------------------------------++module MetricsTheme where++import Control.Monad+import Data.Monoid+import StrategyPrelude+import OverloadingTheme+import FlowTheme++------------------------------------------------------------------------------+-- * An abstract datatype for metrics++-- | The type of metrics+type Metrics2 		=  MetricName -> Integer++-- | The type of metric names+type MetricName		=  String++-- | Create 'Metrics' with given initial value for all metrics.+initMetrics		:: Integer -> Metrics2+initMetrics n       	=  \key -> n++-- | Create 'Metrics' with 0 as initial value for all metrics.+initMetrics0		:: Metrics2+initMetrics0  		=  initMetrics 0++-- | Create 'Metrics' with+--initTypeMetrics 	:: MetricName -> a -> Metrics+--initTypeMetrics key _   =  incMetrics1 key initMetrics0++-- | Increment metric with the given name with the given value.+incMetrics		:: MetricName -> Integer -> Metrics2 -> Metrics2+incMetrics key n m 	=  \key' -> let val = m key' +                                    in if key'==key then val+n else val+				    +-- | Increment metric with the given name by 1.+incMetrics1 		:: MetricName -> Metrics2 -> Metrics2				    +incMetrics1 key m 	=  incMetrics key 1 m++-- | Print value of metric with the given name.+putMetricLn		:: MetricName -> Metrics2 -> IO ()+putMetricLn key m 	=  putStrLn $ key++" = "++show (m key)++++-- * Metrics as monoids +instance Monoid Metrics2 where+  mempty        = initMetrics0+  mappend m1 m2 = \s -> (m1 s) + (m2 s) +++------------------------------------------------------------------------------+-- * Strategy combinators for metrics++-- | Additionally collect type-based metrics.+typeMetric +  :: (MonadPlus m, Term a)+  => TU Metrics2 m 	   -- ^ Metric collecting strategy+  -> (MetricName,a -> ())  -- ^ Name of the metric and type guard+  -> TU Metrics2 m          -- ^ Strategy that additionally collects type-based metrics+typeMetric s (key,g)+  = op2TU mappend+          (tryTU (ifthenTU (voidTU (typeFilterTU g))+			   (constTU (incMetrics1 key initMetrics0)))) +          (tryTU s)+++-- | Additionally collect predicate-based metrics.+predMetric +  :: (MonadPlus m, Term b) +  => TU Metrics2 m 	    -- ^ Strategy that collects metrics+  -> (MetricName,b -> m ()) -- ^ Name of the metric, and predicate+  -> TU Metrics2 m	    -- ^ Strategy that additionally collects predicate-based metric+predMetric s (key,g)+  = op2TU mappend +          (tryTU (ifthenTU (monoTU g)+                           (constTU (incMetrics1 key initMetrics0))))+          (tryTU s)++------------------------------------------------------------------------------+-- * Generic metric algorithms++-- | Generic algorithm for computing nesting depth+depthWith :: MonadPlus m +          => TU () m      -- ^ Recognize relevant contructs+	  -> TU Int m     -- ^ Count nesting depth of relevant constructs.+depthWith s		+  =  allTU' ((:[]) `dotTU` depthWith s) `passTU` \ds ->+     let max_d = maximum (0:ds)+     in  (s `passTU` \() -> constTU (max_d + 1))+         `choiceTU`+         (constTU max_d)++-------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/MonadMaybe.hs view
@@ -0,0 +1,107 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module introduces the MaybeT monad transformer.+-- It is basically a simplification of the ErrorT monad transformer.++------------------------------------------------------------------------------++module MonadMaybe ( ++ MaybeT(..)++) where++import Monad+import Control.Monad.Fix+import Control.Monad.Trans+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State+import Control.Monad.RWS+import Control.Monad.Cont+import IO+import Control.Monad.Error++------------------------------------------------------------------------------++-- | The monad transformer 'MaybeT'.+newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }++instance (Monad m) => Functor (MaybeT m) where+	fmap f m = MaybeT $ do+		a <- runMaybeT m+		case a of+			Nothing -> return (Nothing)+			Just  r -> return (Just  (f r))++instance (Monad m) => Monad (MaybeT m) where+	return a = MaybeT $ return (Just  a)+	m >>= k  = MaybeT $ do+		a <- runMaybeT m+		case a of+			Nothing -> return (Nothing)+			Just  r -> runMaybeT (k r)+	fail msg = MaybeT $ return (Nothing)++instance (Monad m) => MonadPlus (MaybeT m) where+	mzero       = MaybeT $ return (Nothing)+	m `mplus` n = MaybeT $ do+		a <- runMaybeT m+		case a of+			Nothing -> runMaybeT n+			Just  r -> return (Just  r)++instance (MonadFix m) => MonadFix (MaybeT m) where+	mfix f = MaybeT $ mfix $ \a -> runMaybeT $ f $ case a of+		Just  r -> r+		_       -> error "empty mfix argument"++{-+instance (Monad m) => MonadError e (MaybeT m) where+	throwError l     = MaybeT $ return (Nothing)+	m `catchError` h = MaybeT $ do+		a <- runMaybeT m+		case a of+			Nothing -> runMaybeT (h l)+			Just  r -> return (Just  r)+-}++instance MonadTrans (MaybeT) where+	lift m = MaybeT $ do+		a <- m+		return (Just  a)++instance (MonadIO m) => MonadIO (MaybeT m) where+	liftIO = lift . liftIO++instance (MonadReader r m) => MonadReader r (MaybeT m) where+	ask       = lift ask+	local f m = MaybeT $ local f (runMaybeT m)++instance (MonadWriter w m) => MonadWriter w (MaybeT m) where+	tell     = lift . tell+	listen m = MaybeT $ do+		(a, w) <- listen (runMaybeT m)+		return $ case a of+			Nothing -> Nothing+			Just  r -> Just  (r, w)+	pass   m = MaybeT $ pass $ do+		a <- runMaybeT m+		return $ case a of+			Nothing      -> (Nothing, id)+			Just  (r, f) -> (Just  r, f)++instance (MonadState s m) => MonadState s (MaybeT m) where+	get = lift get+	put = lift . put++instance (MonadCont m) => MonadCont (MaybeT m) where+	callCC f = MaybeT $+		callCC $ \c ->+		runMaybeT (f (\a -> MaybeT $ c (Just  a)))++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/MonadRun.hs view
@@ -0,0 +1,190 @@+------------------------------------------------------------------------------ +-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module +-- provides non-strategic functionality for running monads and unlifting+-- monad transformers. In a sense, this is dual to the 'return' and 'lift'+-- functionality of the 'Monad' and 'MonadTrans' classes.+--+------------------------------------------------------------------------------++module MonadRun where++import Control.Monad.Trans+import Control.Monad.Identity+import Control.Monad.State+import Control.Monad.List+import MonadMaybe+import Control.Monad.Error+import System.IO.Unsafe (unsafePerformIO) -- for running IO monads+++------------------------------------------------------------------------------+-- * Monad algebras++-- | The algebra for the partiality effect of 'Maybe' and 'MaybeT'.+data MaybeAlg a b	= MaybeAlg { nothing :: b, just :: a -> b }++-- | The algebra for the error effect of 'Either' and 'ErrorT'.+data ErrorAlg e a b 	= ErrorAlg { left :: e -> b, right :: a -> b } ++-- | The algebra for the non-determinacy effect of '[]' and 'ListT'.+data ListAlg a b	= ListAlg { nil :: b, cons :: a -> b -> b }++-- | The algebra for the state effect of 'State' and 'StateT'.+data StateAlg s a b 	= StateAlg { first :: s,         -- ^ initial state+				     next :: (a,s) -> b  -- ^ state transformer+				   }++--evalStateAlg s = StateAlg (\f -> fst (f s)) +--execStateAlg s = StateAlg (\f -> snd (f s)) +++------------------------------------------------------------------------------+-- * Running monads++-- | The class of monads for which a 'run' function is defined that+--   executes the computation of the monad.+class MonadRun s m | m -> s where+  -- | The overloaded function run takes as first argument an "algebra" which+  -- captures the ingredients necessary to run the particular monad at hand.+  -- This algebra is parameterized with the domain and co-domain of run.+  run :: s a b -> m a -> b++-- | Running the 'Identity' monad.+--   The algebra for the 'Identity' monad is a unary function.+instance MonadRun (->) Identity where+  run alg = alg . runIdentity++-- | Running the 'Maybe' monad.+instance MonadRun MaybeAlg Maybe where+  run alg = maybe (nothing alg) (just alg)++-- | Running the error monad.+instance MonadRun (ErrorAlg e) (Either e) where+  run alg = either (left alg) (right alg)++-- | Running the list monad.+instance MonadRun ListAlg [] where+  run alg = foldr (cons alg) (nil alg)++-- | Running the 'State' monad.+instance MonadRun (StateAlg s) (State s) where  +  run alg = \ma -> next alg (runState ma (first alg))++-- | Running the 'IO' monad. +--   Note: uses 'unsafePerformIO'!+instance MonadRun (->) IO where+  run alg = alg . unsafePerformIO  ++-- | Exchange one monad by another.+--   This function runs one monad, and puts its value in another. This is+--   basically a monadic version of the 'run' function itself. Note that the two+--   monads are unrelated, so none of the effects of the incoming monad are+--   transferred to the result monad.+mrun 		:: (MonadRun s m ,Monad m') => s a b -> m a -> m' b+mrun alg ma 	=  return (run alg ma)+++------------------------------------------------------------------------------+-- * Unlifting monad transformers ++-- | Just as a base monad can be run to remove the monad, so can a transformed+--   monad be unlifted to remove the transformer and obtain the original monad.+class MonadUnTrans s t | t -> s where+  -- | The overloaded function 'unlift' for monad transformers takes as first +  --   argument an "algebra" just like the run function for base monads. For+  --   each monad transformer, the same algebra is used as for the base monad+  --   of which the transformer is the parameterized variant.+  unlift :: Monad m => s a b -> t m a -> m b++-- | Unlifting the list monad transformer.+instance MonadUnTrans ListAlg ListT where+  unlift alg ma = do as <- runListT ma +                     return (foldr (cons alg) (nil alg) as)++-- | Unlifting the partiality monad transformer.+instance MonadUnTrans MaybeAlg MaybeT where+  unlift alg ma = do ea <- runMaybeT ma+                     return (maybe (nothing alg) (just alg) ea) +		     +-- | Unlifting the error monad transformer.+instance MonadUnTrans (ErrorAlg e) (ErrorT e) where+  unlift alg ma = do ea <- runErrorT ma+                     return (either (left alg) (right alg) ea) +		     	+-- | Unlifting the state monad transformer+instance MonadUnTrans (StateAlg s) (StateT s) where+  unlift alg ma = do as <- runStateT ma (first alg)+                     return (next alg as) ++-- * Monadic choice combinators that confine the partiality effect++-- Result of pair programming with Alberto Pardo++-- ** Monadic choice++-- | Monadic choice combinator that confines the partiality effect to+--   the first argument. This is a variation on 'mplus' which allows+--   the partiality effect to spread to both arguments and to the result.	  +mplus' 		:: (Monad m, MonadUnTrans MaybeAlg t) +       		=> t m b -> m b -> m b+m1 `mplus'` m2 	=  unlift (MaybeAlg m2 return) m1 >>= id++-- | Monadic choice combinator. Generalization of 'mplus'' that takes a list+--   of choice arguments rather than a single one.+mswitch			:: (Monad m, MonadUnTrans MaybeAlg t) +       			=> [t m b]   -- ^ choice branches+			-> m b       -- ^ otherwise+			-> m b       -- ^ result+mswitch [] m		=  m+mswitch (tm:tms) m	=  tm `mplus'` (mswitch tms m)	+	+-- | Specialization of 'mswitch' for MaybeT.+mayswitch		:: (Monad m) => [MaybeT m b] -> m b -> m b+mayswitch tms m		=  (foldr mplus mzero tms) `mplus'` m +++-- ** Monadic function choice++-- | Monadic function choice combinator that confines the partiality effect+--   to the first argument. This is a variation on 'mchoice' which+--   allows the partiality effect to spread to both arguments and to the+--   result.+mchoice' :: (Monad m, MonadUnTrans MaybeAlg t) +         => (a -> t m b) -> (a -> m b) -> a -> m b+f `mchoice'` g = \a -> do ea <- unlift (MaybeAlg Nothing Just) (f a)+			  maybe (g a) (return) ea++-- | Monadic function choice combinator. Generalization of 'mchoice'' that+--   takes a list of choice arguments rather than a single one.+mchoices		:: (Monad m, MonadUnTrans MaybeAlg t, MonadPlus (t m))+                        => [a -> t m b] -> (a -> m b) -> a -> m b+mchoices fs f		=  \a -> mswitch' (map (\f -> f a) fs) (f a)+++-- ** Implementation variants++-- | Implementation variant of 'mswitch' in terms of foldr.+mswitch0		:: (Monad m, MonadUnTrans MaybeAlg t) +       			=> [t m b] -> m b -> m b+mswitch0 tms m          =  foldr mplus' m tms	++-- | Implementation variant of 'mswitch' with 'mplus'' expanded:+mswitch1		:: (Monad m, MonadUnTrans MaybeAlg t) +       			=> [t m b] -> m b -> m b+mswitch1 [] m		=  m+mswitch1 (tm:tms) m	=  unlift (MaybeAlg (mswitch1 tms m) return) tm >>= id 		++-- | Implementation variant of 'mswitch' where the unlift is postponed+--   to the very end.+mswitch'		:: (Monad m, MonadUnTrans MaybeAlg t, +                            MonadPlus (t m)) +       			=> [t m b] -> m b -> m b+mswitch' tms m		=  (foldr mplus mzero tms) `mplus'` m ++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/MonadicFunctions.hs view
@@ -0,0 +1,76 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module+-- defines auxilliary monadic functions, some of which serve as parametric+-- polymorphic prototypes for actual strategy combinators.++------------------------------------------------------------------------------++module MonadicFunctions where++import Monad+++------------------------------------------------------------------------------+-- * The identity monad ++-- | Identity type constructor.+newtype Id a = Id a++-- | Unwrap identity type constructor+unId 		:: Id a -> a+unId (Id x) 	 = x++instance Monad Id where+ return = Id+ (Id x) >>= f = f x+++------------------------------------------------------------------------------+-- * Recover from partiality++-- | Force success. If the argument value corresponds to failure, +--   a run-time error will occur.+succeed :: Maybe x -> x+succeed (Just x) = x+succeed Nothing  = error "Didn't succeed!."+ +------------------------------------------------------------------------------+-- * Prototypes for strategy combinators seq, let, choice++-- | Sequential composition of monadic functions+mseq 		:: Monad m => (a -> m b) -> (b -> m c) -> a -> m c+f `mseq` g    	=  \x -> f x >>= g ++-- | Sequential composition with value passing; a kind of monadic let.+mlet 		:: Monad m => (a -> m b) -> (b -> a -> m c) -> a -> m c+f `mlet` g    	=  \x -> f x >>= \y -> g y x++-- | Choice combinator for monadic functions+mchoice 	:: MonadPlus m => (a -> m b) -> (a -> m b) -> a -> m b+f `mchoice` g 	=  \x -> (f x) `mplus` (g x)++------------------------------------------------------------------------------+-- * Guards and conditionals++-- | Type guard described by the argument type of a function.+argtype     :: MonadPlus m => (x -> y) -> x -> m ()+argtype _ _ =  return ()+++-- | Type guard described by a type of a value.+valtype :: MonadPlus m => x -> x -> m ()+valtype _ _ = return ()++-- | A kind of monadic conditional.+ifM :: MonadPlus m => m a -> (a -> m c) -> (m c) -> (m c)+ifM ma f mc = ((ma >>= \a -> return (Just a))+               `mplus` (return Nothing)+              ) >>= maybe mc f++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/MoreMonoids.hs view
@@ -0,0 +1,24 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module+-- defines additional instances of the Monoid class.++------------------------------------------------------------------------------++module MoreMonoids where++import Data.Monoid++------------------------------------------------------------------------------++-- | Any 'Num' is a 'Monoid'.+instance Num a => Monoid a where+ mempty = 0+ mappend = (+)++-----------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/NameTheme.hs view
@@ -0,0 +1,74 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module+-- provides algorithms to collect names and their types.++------------------------------------------------------------------------------ ++module NameTheme where++import Monad+import List+import StrategyPrelude+import OverloadingTheme+import FlowTheme+import TraversalTheme+import Control.Monad.Identity hiding (fail)+++------------------------------------------------------------------------------ +-- * Free name analysis++-- | Generic free name analysis algorithm (without types)+freeNames :: (Eq name, Term t)+          => TU [(name,tpe)] Identity	-- ^ Identify declarations+          -> TU [name] Identity		-- ^ Identify references+          -> t				-- ^ Input term+          -> [name]			-- ^ Free names+freeNames declared referenced =+   runIdentity .+   applyTU (all_recTU (op2TU combine)+                      (op2TU (,) declared referenced))+  where+   combine (decs,refs) recs =+    (refs `union` recs) \\ (map fst decs)++-- | Generic free name analysis algorithm with types+freeTypedNames :: (Eq name, Term t)+               => TU [(name,tpe)] Identity -- ^ Identify declarations+               -> TU [name] Identity	   -- ^ Identify references+               -> [(name,tpe)]		   -- ^ Derived declarations+               -> t			   -- ^ Input term+               -> [(name,tpe)]	   	   -- ^ Free names with types+freeTypedNames declared referenced types t =+   filter (\e -> elem (fst e) names) types+  where+    names = freeNames declared referenced t+++------------------------------------------------------------------------------ +-- * Bound name analysis++-- | Accumulate declarations for focus +boundTypedNames :: (Term f, Term t, Eq name)+                => TU [(name,tpe)] Identity	-- Identify declarations+                -> (f -> Maybe f)		-- Get focus+                -> t				-- Input term+                -> Maybe ([(name,tpe)],f)	-- Derived declarations+boundTypedNames declared unwrap =+   applyTU (once_pe (adhocTU failTU . stop) bind [])+  where+    stop inh =+      (maybe Nothing (Just . (,) inh)) .+      unwrap+    bind inh =+      msubstTU (Just . runIdentity) declared `passTU` \decs ->+      constTU (unionBy byName decs inh)+    byName = \a -> \a' -> fst a == fst a'++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/OverloadingTheme.hs view
@@ -0,0 +1,143 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module+-- overloads basic combinators to enable uniform treatment of TU and TP+-- strategies. The overloading scheme is motivated in the +-- "... Polymorphic Symphony" paper. The names in the present module+-- deviate from the paper in that they are postfixed by an "...S" +-- in order to rule out name clashes and to avoid labour-intensive+-- resolution. The class constraints in this module seem to be outrageous+-- but this has to do with a type inferencing bug for class hierarchies+-- in hugs. This bug is removed in the October 2002 release.++------------------------------------------------------------------------------ ++module OverloadingTheme where++import Control.Monad+import Data.Monoid+import StrategyPrelude+++------------------------------------------------------------------------------ +-- * Unconstrained ++-- | Overload completely unconstrained strategy combinators +class Monad m => Strategy s m+  where+    voidS :: s m -> TU () m     +    -- | Sequential composition          +    seqS  :: TP m -> s m -> s m   +    -- | Sequential composition with value passing        +    passS :: TU a m -> (a -> s m) -> s m  +  +instance Monad m => Strategy TP m+  where+    voidS = voidTP+    seqS  = seqTP+    passS = passTP++instance Monad m => Strategy (TU a) m+  where+    voidS = voidTU+    seqS  = seqTU+    passS = passTU++-- | Overload apply and adhoc combinators+class (Strategy s m, Monad m, Term t) => StrategyApply s m t x | s t -> x+  where+    -- | Strategy application+    applyS :: s m -> t -> m x            +    -- | Dynamic type case+    adhocS :: s m -> (t -> m x) -> s m   ++instance (Monad m, Term t) => StrategyApply TP m t t+  where+    applyS = applyTP+    adhocS = adhocTP++instance (Monad m, Term t) => StrategyApply (TU a) m t a+  where+    applyS = applyTU+    adhocS = adhocTU++------------------------------------------------------------------------------ +-- * Involving Monoid, MonadPlus, ++-- | Overload basic combinators which might involve a monoid+class (Monad m, Strategy s m) => StrategyMonoid s m+  where+    -- | Identity (success)+    skipS    :: s m     +    -- | Push down to all children             +    allS     :: s m -> s m   +    -- | Combine sequentially        +    combS    :: s m -> s m -> s m    ++instance (Monad m, Strategy TP m) => StrategyMonoid TP m+  where+    skipS    = idTP+    allS     = allTP+    combS    = seqTP++instance (Monad m, Monoid u, Strategy (TU u) m) => StrategyMonoid (TU u) m+  where+    skipS    = constTU mempty+    allS     = allTU'+    combS    = op2TU mappend++++-- | Overload basic combinators which involve MonadPlus+class (Strategy s m, Monad m, MonadPlus m) => StrategyPlus s m+  where+    -- | Failure+    failS   :: s m     +    -- | Choice             +    choiceS :: s m -> s m -> s m    +    -- | Push down to a single child+    oneS    :: s m -> s m           ++instance (Monad m, MonadPlus m, Strategy TP m) => StrategyPlus TP m+  where+    failS   = failTP+    choiceS = choiceTP+    oneS    = oneTP++instance (Monad m, MonadPlus m, Strategy (TU u) m) => StrategyPlus (TU u) m+  where+    failS   = failTU+    choiceS = choiceTU+    oneS    = oneTU+++-- | Overloaded lifting with failure +monoS 	:: (StrategyApply s m t x, StrategyPlus s m) +   	=> (t -> m x) +	-> s m+monoS f = adhocS failS f+++------------------------------------------------------------------------------ +-- * Effect substitution (see "EffectTheme").++-- | Overload msubst combinator (Experimental)+class StrategyMSubst s+  where+    -- | Substitute one monad for another+    msubstS :: (Monad m, Monad m') => (forall t . m t -> m' t) -> s m -> s m'+    +instance StrategyMSubst TP+  where+    msubstS f = msubstTP f+    +instance StrategyMSubst (TU a)+  where+    msubstS f = msubstTU f    ++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/PathTheme.hs view
@@ -0,0 +1,83 @@+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. In this module, we+-- define path combinator to constrain selection and transformation of nodes or+-- subtrees by path conditions.+ +-----------------------------------------------------------------------------} ++module PathTheme where++import StrategyPrelude+import OverloadingTheme+import FlowTheme+import TraversalTheme+import Monad+++------------------------------------------------------------------------------+-- * Below++-- ** Strictly below++-- | Select or transform a node below a node where a condition holds.+-- We find the top-most node which admits selection or transformation+-- below the top-most node which meets the condition. Thus, the+-- distance between guard and application node is minimized.+belowS           :: (MonadPlus m, Strategy s m, StrategyPlus s m)+                 => s m -> TU () m -> s m+s `belowS`   s'  =  (oneS s) `beloweqS` s'++-- ** Below or at the same height++-- | Select or transform a node below or at a node where a condition holds.+beloweqS         :: (MonadPlus m, Strategy s m, StrategyPlus s m)+                 => s m -> TU () m -> s m+s `beloweqS` s'  =  once_td (ifthenS s' (once_td s))++-- ** Type-specialised versions++-- | Apply a transformation strictly below a node where a condition holds.+belowTP		   :: MonadPlus m => TP m -> TU () m -> TP m+belowTP            =  belowS++-- | Apply a transformation below or at a node where a condition holds.+beloweqTP          :: MonadPlus m => TP m -> TU () m -> TP m+beloweqTP          =  beloweqS++++------------------------------------------------------------------------------+-- * Above++-- ** Strictly above++-- | Select or transform a node above a node where a condition holds. The+--   distance between guard and application node is minimized.+aboveS           :: (MonadPlus m, Strategy s m, StrategyPlus s m)+                 => s m -> TU () m -> s m+s `aboveS`   s'  =  s `aboveeqS` (oneTU s')++-- ** Above or at the same height++-- | Select or transform a node above or at a node where a condition holds.+aboveeqS         :: (MonadPlus m, Strategy s m, StrategyPlus s m)+                 => s m -> TU () m -> s m+s `aboveeqS` s'  =  once_bu (ifthenS (once_tdTU s') s)++-- ** Type-specialised versions++-- | Apply a transformation strictly above a node where a condition holds.+aboveTP            :: MonadPlus m => TP m -> TU () m -> TP m+aboveTP            =  aboveS++-- | Apply a transformation above or at a node where a condition holds.+aboveeqTP          :: MonadPlus m => TP m -> TU () m -> TP m+aboveeqTP          =  aboveeqS++------------------------------------------------------------------------------+
+ StrategyLib-4.0-beta/library/RefactoringTheme.hs view
@@ -0,0 +1,149 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module +-- defines generic refactoring functionality. See the paper "Towards+-- Generic Refactoring" by Ralf Laemmel. See also +-- generic-refactoring in the examples directory.++------------------------------------------------------------------------------++module RefactoringTheme where++import StrategyPrelude+import Control.Monad.Identity hiding (fail)+import KeyholeTheme+import NameTheme+++------------------------------------------------------------------------------+-- * The abstraction interface++-- | Class of abstractions+class (+       -- Syntactical domains+       Term abstr,	-- Term type for abstraction+       Eq name,		-- Names of abstraction+       Term [abstr],	-- Lists of abstractions+       Term apply	-- Applications+      )+        => Abstraction abstr name tpe apply++      -- Dependencies between syntactical domains+      | abstr            -> name,+        abstr            -> tpe,+        abstr            -> apply,+        apply            -> name,+        apply            -> abstr++  where++    -- Observers+    getAbstrName  :: abstr -> Maybe name+    getAbstrParas :: abstr -> Maybe [(name,tpe)]+    getAbstrBody  :: abstr -> Maybe apply+    getApplyName  :: apply -> Maybe name+    getApplyParas :: apply -> Maybe [(name,tpe)]++    -- Constructors+    constrAbstr   :: name -> [(name,tpe)] -> apply -> Maybe abstr+    constrApply   :: name -> [(name,tpe)] -> Maybe apply++++------------------------------------------------------------------------------+-- * Removal++-- | Remove an unused abstraction+eliminate :: (Term prog, Abstraction abstr name tpe apply)+          => TU [(name,tpe)] Identity	-- ^ Identify declarations+	  -> TU [name] Identity		-- ^ Identify references+          -> (abstr -> Maybe abstr)	-- ^ Unwrap abstraction+          -> prog			-- ^ Input program+          -> Maybe prog			-- ^ Output program++eliminate declared referenced unwrap prog+  = do { abstr <- selectFocus unwrap prog;+         name  <- getAbstrName abstr;+         ()    <- unusedAbstr name;+                  deleteFocus unwrap prog+       }++  where++    -- Check if name is unused by optionally navigating to the relevant scope+    unusedAbstr name = maybe (notIsFree prog) notIsFree selectScope+      where+        argtype   :: Monad m => (x -> y) -> x -> m x+        argtype _ =  return  +        selectScope = selectHost unwrap (argtype unwrap) prog+        notIsFree scope+          = do +               scope' <- deleteFocus unwrap scope+               names  <- return (freeNames declared referenced scope')+               guard (not (elem name names))+++------------------------------------------------------------------------------+-- * Insertion++-- | Insert a new abstraction+introduce :: (Term prog, Abstraction abstr name tpe apply)+        => TU [(name,tpe)] Identity 	-- ^ Identify declarations+        -> TU [name] Identity		-- ^ Identify references+        -> ([abstr] -> Maybe [abstr])	-- ^ Unwrap scope with abstractions+        -> abstr			-- ^ Abstraction to be inserted+        -> prog				-- ^ Input program+        -> Maybe prog			-- ^ Output program++introduce declared referenced unwrap abstr =+ replaceFocus (\abstrlist -> +   do+       abstrlist' <- unwrap abstrlist+       name       <- getAbstrName abstr+       free       <- return $ freeNames declared referenced abstrlist'+       def        <- mapM getAbstrName abstrlist'+       guard (and [not (elem name free), not (elem name def)])+       return (abstr:abstrlist') )+++------------------------------------------------------------------------------+-- * Generic extraction (say fold)++-- | Extract an abstraction+extract :: (Term prog, Abstraction abstr name tpe apply)+        => TU [(name,tpe)] Identity	    	-- ^ Identify declarations+	-> TU [name] Identity		    	-- ^ Identify references+        -> (apply -> Maybe apply)	    	-- ^ Unwrap focus+        -> ([abstr] -> [abstr])	    	    	-- ^ Wrap host+        -> ([abstr] -> Maybe [abstr])	    	-- ^ Unwrap host+        -> ([(name,tpe)] -> apply -> Bool)	-- ^ Check focus+	-> name				    	-- ^ Name for abstraction+        -> prog				    	-- ^ Input program+        -> Maybe prog			    	-- ^ Output program++extract declared referenced unwrap wrap unwrap' check name prog+  = do+       -- Operate on focus+       (bound,focus) <- boundTypedNames declared unwrap prog+       free          <- return $ freeTypedNames declared referenced bound focus+       guard (check bound focus)+ +       -- Construct abstraction+       abstr       <- constrAbstr name free focus+ +       -- Insert abstraction+       prog'       <- markHost (maybe False (const True) . unwrap) wrap prog+       prog''      <- introduce declared referenced unwrap' abstr prog'+    +       -- Construct application+       apply       <- constrApply name free++       -- Replace focus by application+       replaceFocus (maybe Nothing (const (Just apply)) . unwrap) prog''++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/StrategyInfix.hs view
@@ -0,0 +1,49 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module +-- indicates how some strategy combinators could be denoted via infix+-- combinators.++-----------------------------------------------------------------------------}++module StrategyInfix where++import StrategyPrelude+import OverloadingTheme++infixl 1  >>>, >>>=, >>>-+infixl 2  -+++-- | Sequential composition+(>>>) 		:: Strategy s m => TP m -> s m -> s m+s >>> s'	= s `seqS` s'++-- | Sequential composition with value passing+(>>>=) 		:: Strategy s m => TU a m -> (a -> s m) -> s m+s >>>= s'	= s `passS` s'++-- | Sequential composition, ignoring value from first strategy+(>>>-) 		:: Strategy s m => TU a m -> s m -> s m+s >>>- s'	= s `passS` \_ -> s'++-- | Dynamic type-case+(-+) 		:: StrategyApply s m t x => s m -> (t -> m x) -> s m+s -+ f          = s `adhocS` f++{-+tst :: TP Maybe+tst = idTP >>> failS -+ f -+ f++f (x::Char) = return x++mytest :: Maybe Char+mytest = applyTP tst 'a'++mytest2 :: Maybe Bool +mytest2 = applyTP tst True+-}
+ StrategyLib-4.0-beta/library/StrategyLib.hs view
@@ -0,0 +1,72 @@+------------------------------------------------------------------------------ +-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal.  This is the+-- top-level module of the library. One only needs to import this module to+-- use the entire library. Some base modules are exported as well because+-- they are commonly used.++------------------------------------------------------------------------------ ++module StrategyLib (++ module Monad,+ module Control.Monad.Fix,+ module Control.Monad.Trans,+ Identity(..),+-- MaybeT(..),+ State(..),+ StateT(..),+ module Data.Monoid,+ module MoreMonoids,++ module StrategyPrelude,+ module StrategyInfix,++ module OverloadingTheme,+ module TraversalTheme,+ module FlowTheme,+ module FixpointTheme,+ module KeyholeTheme,+ module NameTheme,+ module PathTheme,+ module EffectTheme,+ module ContainerTheme,+ module RefactoringTheme,+-- module MetricsTheme,+ + module ChaseImports++) where++import Monad+import Control.Monad.Fix+import Control.Monad.Trans+import Control.Monad.Identity+import MonadMaybe+import Control.Monad.State+import Data.Monoid+import MoreMonoids++import StrategyPrelude+import StrategyInfix++import OverloadingTheme+import FixpointTheme+import PathTheme+import NameTheme+import KeyholeTheme+import EffectTheme+import ContainerTheme hiding (modify)+import FlowTheme+import TraversalTheme+import RefactoringTheme+--import MetricsTheme++import ChaseImports++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/StrategyPrelude.hs view
@@ -0,0 +1,117 @@+------------------------------------------------------------------------------ +-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module+-- is basically a wrapper for the strategy primitives plus some extra+-- basic strategy combinators that can be defined immediately in terms+-- of the primitive ones.++------------------------------------------------------------------------------++module StrategyPrelude (+  module StrategyPrimitives,+  module StrategyPrelude+) where++import StrategyPrimitives+import Control.Monad+import Data.Monoid+++------------------------------------------------------------------------------ +-- * Useful defaults for strategy update (see 'adhocTU' and 'adhocTP').++-- | Type-preserving identity. Returns the incoming term without change.+idTP		:: Monad m => TP m+idTP		=  paraTP return++-- | Type-preserving failure. Always fails, independent of the incoming+--   term. Uses 'MonadPlus' to model partiality.+failTP          :: MonadPlus m => TP m+failTP          =  paraTP (const mzero)++-- | Type-unifying failure. Always fails, independent of the incoming+--   term. Uses 'MonadPlus' to model partiality.+failTU          :: MonadPlus m => TU a m+failTU          =  paraTU (const mzero)++-- | Type-unifying constant strategy. Always returns the argument value 'a',+--   independent of the incoming term.+constTU         :: Monad m => a -> TU a m+constTU a       =  paraTU (const (return a))++-- | Type-unifying monadic constant strategy. Always performs the argument+--   computation 'a', independent of the incoming term. This is a monadic+--   variation of 'constTU'.+compTU         :: Monad m => m a -> TU a m+compTU a       =  paraTU (const a)+++------------------------------------------------------------------------------ +-- * Lift a function to a strategy type with failure as default ++-- | Apply the monomorphic, type-preserving argument function, if its +--   input type matches the input term's type. Otherwise, fail.+monoTP          :: (Term a, MonadPlus m) => (a -> m a) -> TP m+monoTP          =  adhocTP failTP++-- | Apply the monomorphic, type-unifying argument function, if its +--   input type matches the input term's type. Otherwise, fail.+monoTU 		:: (Term a, MonadPlus m) => (a -> m b) -> TU b m+monoTU  	=  adhocTU failTU+++------------------------------------------------------------------------------ +-- * Function composition++-- | Sequential ccomposition of monomorphic function and type-unifying strategy.+--   In other words, after the type-unifying strategy 's' has been applied, +--   the monomorphic function 'f' is applied to the resulting value.+dotTU        :: Monad m => (a -> b) -> TU a m -> TU b m+dotTU f s    =  s `passTU` (constTU . f)+++-- | Parallel combination of two type-unifying strategies with a binary+--   combinator. In other words, the values resulting from applying the+--   type-unifying strategies are combined to a final value by applying+--   the combinator 'o'.++op2TU :: Monad m => (a -> b -> c) -> TU a m -> TU b m -> TU c m+op2TU o s s' =  s  `passTU` \a ->+                s' `passTU` \b ->+                constTU (o a b)+++------------------------------------------------------------------------------ +-- * Reduce a strategy's performance to its effects++-- | Reduce a type-preserving strategy to a type-unifying one that+--   ignores its result term and returns void, but retains its +--   monadic effects.+voidTP    :: Monad m => TP m -> TU () m+voidTP s  =  s `seqTU` constTU ()++-- | Reduce a type-unifying strategy to a type-unifying one that+--   ignores its result value and returns void, but retains its +--   monadic effects.+voidTU    :: Monad m => TU u m -> TU () m+voidTU s  =  s `passTU` \_ -> constTU ()+++------------------------------------------------------------------------------ +-- * Shape test combinators++-- | Test for constant term, i.e.\ having no subterms.+con      :: MonadPlus m => TP m+con      =  allTP failTP	++-- | Test for compound term, i.e.\ having at least one subterm.+com 	 :: MonadPlus m => TP m+com      =  oneTP idTP+++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/library/TraversalTheme.hs view
@@ -0,0 +1,190 @@+------------------------------------------------------------------------------+-- | +-- Maintainer	: Ralf Laemmel, Joost Visser+-- Stability	: experimental+-- Portability	: portable+--+-- This module is part of 'StrategyLib', a library of functional strategy+-- combinators, including combinators for generic traversal. This module defines+-- traversal schemes. Such schemes have formed the core of StrategyLib+-- since its first release. The portfolio as it stands now captures part+-- of the design in the paper "... Polymorphic Symphony".++------------------------------------------------------------------------------++module TraversalTheme where++import StrategyPrelude+import OverloadingTheme+import FlowTheme+import Control.Monad+import Data.Monoid+++------------------------------------------------------------------------------+-- * Recursive traversal++------------------------------------------------------------------------------+-- ** Full traversals+--+--    * td -- top-down+--    * bu -- bottom-up ++-- | Full type-preserving traversal in top-down order.+full_tdTP	:: Monad m => TP m -> TP m+full_tdTP s	=  s `seqTP` (allTP (full_tdTP s))++-- | Full type-preserving traversal in bottom-up order.+full_buTP 	:: Monad m => TP m -> TP m+full_buTP s	=  (allTP (full_buTP s)) `seqTP` s++-- | Full type-unifying traversal in top-down order.+full_tdTU 	:: (Monad m, Monoid a) => TU a m -> TU a m+full_tdTU s	=  op2TU mappend s (allTU' (full_tdTU s))++++------------------------------------------------------------------------------+-- ** Traversals with stop conditions ++-- | Top-down type-preserving traversal that is cut of below nodes+--   where the argument strategy succeeds.+stop_tdTP 	:: MonadPlus m => TP m -> TP m+stop_tdTP s	=  s `choiceTP` (allTP (stop_tdTP s))++-- | Top-down type-unifying traversal that is cut of below nodes+--   where the argument strategy succeeds.+stop_tdTU 	:: (MonadPlus m, Monoid a) => TU a m -> TU a m+stop_tdTU s	=  s `choiceTU` (allTU' (stop_tdTU s))++++------------------------------------------------------------------------------+-- ** Single hit traversal ++-- | Top-down type-preserving traversal that performs its argument+--   strategy at most once.+once_tdTP 	:: MonadPlus m => TP m -> TP m+once_tdTP s	=  s `choiceTP` (oneTP (once_tdTP s))++-- | Top-down type-unifying traversal that performs its argument+--   strategy at most once.+once_tdTU 	:: MonadPlus m => TU a m -> TU a m+once_tdTU s	=  s `choiceTU` (oneTU (once_tdTU s))++-- | Bottom-up type-preserving traversal that performs its argument+--   strategy at most once.+once_buTP 	:: MonadPlus m => TP m -> TP m+once_buTP s	=  (oneTP (once_buTP s)) `choiceTP` s++-- | Bottom-up type-unifying traversal that performs its argument+--   strategy at most once.+once_buTU 	:: MonadPlus m => TU a m -> TU a m+once_buTU s	=  (oneTU (once_buTU s)) `choiceTU` s++++------------------------------------------------------------------------------+-- ** Traversal with environment propagation++-- | Top-down type-unifying traversal with propagation of an environment.+once_peTU :: MonadPlus m +          => e 		     -- ^ initial environment+	  -> (e -> TU e m)   -- ^ environment modification at downward step+	  -> (e -> TU a m)   -- ^ extraction of value, dependent on environment+	  -> TU a m+once_peTU e s' s = s e+                   `choiceTU`+                   (s' e `passTU` \e' -> oneTU (once_peTU e' s' s))+++------------------------------------------------------------------------------+-- * One-layer traversal++------------------------------------------------------------------------------+-- ** Defined versions of some primitive one-layer traversal combinators++-- For performance and uniformity reasons, anyTP and someTP are +-- primitives, but they could have been defined as follows:++-- | Use 'anyTP' instead.+anyTP'		:: MonadPlus m => TP m -> TP m+anyTP' s	=  allTP (tryTP s)++-- | Use 'someTP' instead.+someTP'		:: MonadPlus m => TP m -> TP m+someTP' s	=  (testTP (notTP (allTP (notTP s)))) `seqTP` (anyTP s)++++------------------------------------------------------------------------------+-- ** Recursive completion of one-layer traversal ++-- | Recursive completion of full type-preserving one-layer traverasal+all_recTU :: (Monoid a, Monad m) +          => (t -> TU a m -> TU a m)      -- ^ binary strategy combinator+          -> t                            -- ^ argument strategy+	  -> TU a m                       -- ^ result strategy+all_recTU o s = s `o` allTU' (all_recTU o s)++-- | Recursive completion of type-preserving one-layer traversal that+--   succeeds exactly once.+one_recTU :: MonadPlus m +          => (t -> TU a m -> TU a m)      -- ^ binary strategy combinator+          -> t                            -- ^ argument strategy+	  -> TU a m                       -- ^ result strategy+one_recTU o s = s `o` oneTU (one_recTU o s)+++------------------------------------------------------------------------------+-- * Overloading and synonyms++------------------------------------------------------------------------------+-- ** Overloaded schemes for traversal +--   See the paper "... Polymorphic symphony" for a discussion ++-- | Full top-down traversal (overloaded between 'TU' and 'TP').+full_td 	:: StrategyMonoid s m => s m -> s m+full_td s	=  s `combS` (allS (full_td s))++-- | One-hit top-down traversal (overloaded between 'TU' and 'TP').+once_td 	:: StrategyPlus s m => s m -> s m +once_td s       =  s `choiceS` (oneS (once_td s))++-- | One-hit bottom-up traversal (overloaded between 'TU' and 'TP').+once_bu 	:: StrategyPlus s m => s m -> s m+once_bu s       =  (oneS (once_bu s)) `choiceS` s++-- | One-hit top-down traversal with environment propagation +--   (overloaded between 'TU' and 'TP').+once_pe         :: StrategyPlus s m => (e -> s m) -> (e -> TU e m) -> e -> s m+once_pe s s' e  =  s e `choiceS` (s' e `passS` (\e' -> oneS (once_pe s s' e)))++++------------------------------------------------------------------------------+-- ** Some synonyms for convenience ++-- | See 'full_tdTP'.+topdown   :: Monad m => TP m -> TP m+topdown   =  full_tdTP++-- | See 'full_tdTU'.+crush     :: (Monad m, Monoid u) => TU u m -> TU u m +crush     =  full_tdTU++-- | Type-specialised version of 'crush', which works with lists instead of+--   any arbitrary monoid.+collect   :: Monad m => TU [a] m -> TU [a] m +collect   =  crush++-- | See 'once_tdTU'.+select    :: MonadPlus m => TU u m -> TU u m +select    =  once_tdTU++-- | See 'once_peTU'.+selectenv :: MonadPlus m => e -> (e -> TU e m) -> (e -> TU a m) -> TU a m+selectenv =  once_peTU+++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/models/Makefile view
@@ -0,0 +1,5 @@+StrategyLib = ..+subdirs     = drift-default deriving+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.check+include ${StrategyLib}/scripts/makerules.recurse
+ StrategyLib-4.0-beta/models/deriving/Makefile view
@@ -0,0 +1,31 @@+###############################################################################+#+# Environment for makerules+# This model only works with GHC HEAD; so put in your path :-)+#++StrategyLib = ../..+Model       = ghc-deriving+ghci        = /home/ralf/cvsprojects/cvs.haskell.org/fptools/ghc/compiler/stage2/ghc-inplace --interactive+++###############################################################################+#+# ghci session for debugging purposes +#++ghci:+	${ghci} ${ghc-opts} StrategyPrimitives.hs++#	${ghci} ${ghc-opts} ${StrategyLib}/library/StrategyLib.hs+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.opts+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.check+include ${StrategyLib}/scripts/makerules.recurse
+ StrategyLib-4.0-beta/models/deriving/StrategyPrimitives.hs view
@@ -0,0 +1,208 @@+{-----------------------------------------------------------------------------++A model of functional strategies using Data.Generics as of >= GHC 6.2.+(The version of Data.Generics as of GHC 6.0 is not applicable here.)+Strategy application, strategy update, and traversal are different from+the original Strafunski model. Most other combinators (seqT?, ...) are+retained as is.++-----------------------------------------------------------------------------} ++module StrategyPrimitives (++  Term,+  TP,         TU,+  paraTP,     paraTU,+  applyTP,    applyTU,+  adhocTP,    adhocTU,+  msubstTP,   msubstTU,+  seqTP,      seqTU,+  passTP,     passTU,+  choiceTP,   choiceTU,+  mchoicesTP, mchoicesTU,+  allTP,      allTU, allTU',+  oneTP,      oneTU,+  anyTP,      anyTU, anyTU',+  someTP,     someTU, someTU',+  injTP++) where++import TermRep+import Data.Generics+import Control.Monad+import Data.Monoid+import MonadicFunctions+import MonadRun+++--- Strategy representation --------------------------------------------------++newtype Monad m =>+        TP m =+               MkTP (forall x. Data x => x -> m x)++newtype Monad m =>+        TU a m =+                 MkTU (forall x. Data x => x -> m a)++unTP (MkTP f)	 = f+unTU (MkTU f)	 = f++++--- Parametricially polymorphic strategies -----------------------------------++paraTP 		:: Monad m => (forall t. t -> m t) -> TP m+paraTP f	=  MkTP f++paraTU 		:: Monad m => (forall t. t -> m a) -> TU a m+paraTU f	=  MkTU f+++--- Strategy application -----------------------------------------------------++applyTP         :: (Monad m, Data x) => TP m -> x -> m x+applyTP         =  unTP++applyTU 	:: (Monad m, Data x) => TU a m -> x -> m a+applyTU         =  unTU++++--- Strategy update ----------------------------------------------------------++adhocTP :: (Monad m, Data t) => TP m -> (t -> m t) -> TP m+adhocTP s f = MkTP (unTP s `extM` f)++adhocTU :: (Monad m, Data t) => TU a m -> (t -> m a) -> TU a m+adhocTU s f = MkTU (unTU s `extQ` f)++++--- Effect manipulation ------------------------------------------------------++                                               -- Replace one monad by another++msubstTP	:: (Monad m, Monad m') +		=> (forall t . m t -> m' t) -> TP m -> TP m'+msubstTP e f	=  MkTP (\x -> e ((unTP f) x))++msubstTU	:: (Monad m, Monad m') +		=> (m a -> m' a) -> TU a m -> TU a m'+msubstTU e f	=  MkTU (\x -> e ((unTU f) x))++++--- Deterministic combinators ------------------------------------------------++    -- Type-preserving++seqTP 		:: Monad m => TP m -> TP m -> TP m+seqTP f g 	=  MkTP ((unTP f) `mseq` (unTP g))++passTP 		:: Monad m => TU a m -> (a -> TP m) -> TP m+passTP f g 	=  MkTP ((unTU f) `mlet` (\y -> unTP (g y)))++    -- Type-unifying++seqTU 		:: Monad m => TP m -> TU a m -> TU a m+seqTU f g	=  MkTU ((unTP f) `mseq` (unTU g))++passTU 		:: Monad m => TU a m -> (a -> TU b m) -> TU b m+passTU f g	=  MkTU ((unTU f) `mlet` (\y -> unTU (g y))) ++++--- Combinators for partiality and non-determinism ---------------------------++    -- Type-preserving++choiceTP 	:: MonadPlus m => TP m -> TP m -> TP m+choiceTP f g	=  MkTP ((unTP f) `mchoice` (unTP g))++    -- Type-unifying++choiceTU 	:: MonadPlus m => TU a m -> TU a m -> TU a m+choiceTU f g	=  MkTU ((unTU f) `mchoice` (unTU g))++-- With localization of partiality:++mchoicesTP fs f		=  MkTP (\a -> mchoices (map unTP fs) (unTP f) a)++mchoicesTU fs f		=  MkTU (\a -> mchoices (map unTU fs) (unTU f) a)++++--- Traversal combinators ----------------------------------------------------++    -- Type-preserving++-- Succeed for all children+allTP 	   :: Monad m => TP m -> TP m+allTP s    =  MkTP (gmapM (applyTP s))+++-- Succeed for one child; don't care about the other children+oneTP 	   :: MonadPlus m => TP m -> TP m+oneTP s	   =  MkTP (gmapMo (applyTP s))+++-- Succeed for as many children as possible+anyTP      :: MonadPlus m => TP m -> TP m+anyTP s    =  allTP (s `choiceTP` paraTP return)+++-- Succeed for as many children as possible but at least for one+someTP	   :: MonadPlus m => TP m -> TP m+someTP s   =  MkTP (gmapMp (applyTP s))+++-- Simulate injection+injTP      :: MonadPlus m => TP m -> TP m     +injTP s    =  (MkTU (return . glength))+              `passTP`+              (\x -> if x == 1 then allTP s else paraTP (const mzero))+++    -- Type-unifying++allTU 		:: Monad m => (a -> a -> a) -> a -> TU a m -> TU a m+allTU op2 u s   =  MkTU (\x -> fold (gmapQ (applyTU s) x))+  where+    fold l = foldM op2' u l+    op2' x c = c >>= \y -> return (x `op2` y)+++allTU' 		:: (Monad m, Monoid a) => TU a m -> TU a m+allTU'		=  allTU mappend mempty+++oneTU 		:: MonadPlus m => TU a m -> TU a m+oneTU s		=  MkTU (\x -> fold (gmapQ (applyTU s) x))+  where+    fold [] = mzero+    fold (h:t) = (h >>= \x -> return x)+                 `mplus`+                 fold t+++anyTU		:: MonadPlus m => (a -> a -> a) -> a -> TU a m -> TU a m+anyTU op2 u s   =  allTU op2 u (s `choiceTU` paraTU (const (return u)))+++anyTU'		:: (MonadPlus m, Monoid a) => TU a m -> TU a m+anyTU' 		=  anyTU mappend mempty+++someTU	 	:: MonadPlus m => (a -> a -> a) -> a -> TU a m -> TU a m+someTU op2 u s	=  MkTU (\x -> fold False (gmapQ (applyTU s) x))+  where+    fold False [] = mzero+    fold True  [] = return u+    fold b (h:t)  = (h >>= \x -> fold True t >>= \y -> return (x `op2` y))+                    `mplus`+                    fold b t++someTU'	 	:: (Monoid a, MonadPlus m) => TU a m -> TU a m+someTU'		=  someTU mappend mempty
+ StrategyLib-4.0-beta/models/deriving/TermRep.hs view
@@ -0,0 +1,16 @@+-- +-- We use a little trick to turn the Data class into Strafunski's Term class.+-- No idea if this is going to work.+-- Cannot be tested right now because of GHC bugs.+-- ++module TermRep (+ Term+) where++import Data.Generics++class Data x => Term x++instance (Typeable x, Data x) => Term x+
+ StrategyLib-4.0-beta/models/drift-default/Makefile view
@@ -0,0 +1,30 @@+###############################################################################+#+# Environment for makerules+#++StrategyLib = ../..+Model       = drift-default+++###############################################################################+#+# Haskell sessions for debugging purposes +#++hugs:+	hugs ${hugs-opts} ${StrategyLib}/library/StrategyLib.hs++ghci:+	ghci ${ghc-opts} ${StrategyLib}/library/StrategyLib.hs+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.opts+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.check+include ${StrategyLib}/scripts/makerules.recurse
+ StrategyLib-4.0-beta/models/drift-default/StrategyPrimitives.hs view
@@ -0,0 +1,281 @@+{-----------------------------------------------------------------------------++ 	          A LIBRARY OF FUNCTIONAL STRATEGY COMBINATORS++		                  StrategyLib++                   Ralf Laemmel                Joost Visser+               CWI & VU, Amsterdam         CWI & SIG, Amsterdam++This module is part of a library of functional strategy combinators,+including combinators for generic traversal. The generic function+representation that relies on a universal term representation is+defined in this module. The safety of the generic function combinators+is guaranteed by not exporting the data constructor MkTP.++-----------------------------------------------------------------------------} ++module StrategyPrimitives (++  Term,+  TP,         TU,       -- Note: MkTP is not exported, MkTU could be exported+  paraTP,     paraTU,+  applyTP,    applyTU,+  adhocTP,    adhocTU,+  msubstTP,   msubstTU,+  seqTP,      seqTU,+  passTP,     passTU,+  choiceTP,   choiceTU,+  mchoicesTP, mchoicesTU,+  allTP,      allTU, allTU',+  oneTP,      oneTU,+  anyTP,      anyTU, anyTU',+  someTP,     someTU, someTU',+  injTP++) where++import TermRep+import Monad+import Data.Monoid+import MonadicFunctions+import MonadRun+++--- Strategy representation --------------------------------------------------++newtype TP m  	 = MkTP (TermRep -> m TermRep)+newtype TU a m	 = MkTU (TermRep -> m a)++unTP 		:: TP m -> TermRep -> m TermRep+unTP (MkTP f)	 = f++unTU 		:: TU a m -> TermRep -> m a+unTU (MkTU f)	 = f+++--- Parametricially polymorphic strategies -----------------------------------++paraTP 		:: Monad m => (forall t. t -> m t) -> TP m+paraTP f	=  MkTP f++paraTU 		:: Monad m => (forall t. t -> m a) -> TU a m+paraTU f	=  MkTU f+++--- Strategy application -----------------------------------------------------++applyTP 	:: (Monad m, Term t) => TP m -> t -> m t+applyTP s t	=  do { t' <- unTP s (explode t); return (implode t') }++applyTU 	:: (Monad m, Term t) => TU a m -> t -> m a+applyTU s t	=  unTU s (explode t)++applyOnKids 	:: Monad m => ([TermRep] -> m [TermRep]) -> TP m+applyOnKids s	=  MkTP (\ t -> s (getChildren t) >>= \ks' ->+                                return (getConstr t ks'))++applyOnKidsTU 	:: ([TermRep] -> m a) -> TU a m+applyOnKidsTU s	=  MkTU (\ t -> s (getChildren t))++++--- Strategy update ----------------------------------------------------------++adhocTP 	:: (Monad m, Term t) => TP m -> (t -> m t) -> TP m+adhocTP s f	=  MkTP (\u -> if applicable f u +                               then do t <- f (implode u)+                                       return (explode t)+                               else (unTP s u) )++adhocTU	 	:: (Monad m, Term t) => TU a m -> (t -> m a) -> TU a m+adhocTU s f	=  MkTU (\u -> if applicable f u+                               then (f (implode u))+                               else (unTU s u) )+++applicable 	:: Typeable a => (a -> b) -> TermRep -> Bool+applicable f u  =  case u `hasTypeOf` (undefined `withArgType` f) of+                     Just _  -> True+		     Nothing -> False+                   where withArgType :: a -> (a -> x) -> a+                         withArgType a f = a++-- Applicability of a monomorphic function to a universal term representation+-- is defined by comparing the type representation of the argument type of the+-- function with the type representation of the term representation at hand.+++--- Effect manipulation ------------------------------------------------------++                                               -- Replace one monad by another+					       +msubstTP	:: (Monad m, Monad m') +		=> (forall t . m t -> m' t) -> TP m -> TP m'+msubstTP e f	=  MkTP (\x -> e ((unTP f) x))++msubstTU	:: (Monad m, Monad m') +		=> (m a -> m' a) -> TU a m -> TU a m'+msubstTU e f	=  MkTU (\x -> e ((unTU f) x))++++--- Deterministic combinators ------------------------------------------------++    -- Type-preserving++seqTP 		:: Monad m => TP m -> TP m -> TP m+seqTP f g 	=  MkTP ((unTP f) `mseq` (unTP g))++passTP 		:: Monad m => TU a m -> (a -> TP m) -> TP m+passTP f g 	=  MkTP ((unTU f) `mlet` (\y -> unTP (g y)))++    -- Type-unifying++seqTU 		:: Monad m => TP m -> TU a m -> TU a m+seqTU f g	=  MkTU ((unTP f) `mseq` (unTU g))++passTU 		:: Monad m => TU a m -> (a -> TU b m) -> TU b m+passTU f g	=  MkTU ((unTU f) `mlet` (\y -> unTU (g y))) +++--- Combinators for partiality and non-determinism ---------------------------++    -- Type-preserving++choiceTP 	:: MonadPlus m => TP m -> TP m -> TP m+choiceTP f g	=  MkTP ((unTP f) `mchoice` (unTP g))++    -- Type-unifying++choiceTU 	:: MonadPlus m => TU a m -> TU a m -> TU a m+choiceTU f g	=  MkTU ((unTU f) `mchoice` (unTU g))++-- With localization of partiality:++mchoicesTP fs f		=  MkTP (\a -> mchoices (map unTP fs) (unTP f) a)++mchoicesTU fs f		=  MkTU (\a -> mchoices (map unTU fs) (unTU f) a)+++--- Traversal combinators ----------------------------------------------------++    -- Type-preserving++-- Succeed for all children+allTP 		:: Monad m => TP m -> TP m+allTP s		=  applyOnKids (mapM (unTP s))++-- Succeed for one child; don't care about the other children+oneTP 		:: MonadPlus m => TP m -> TP m+oneTP s		=  applyOnKids (oneM (unTP s))++-- Succeed for as many children as possible+anyTP 		:: MonadPlus m => TP m -> TP m+anyTP s		=  applyOnKids (anyM (unTP s))++-- Succeed for as many children as possible but at least for one+someTP	 	:: MonadPlus m => TP m -> TP m+someTP s	=  applyOnKids (someM (unTP s))++-- Simulate injection+injTP           :: MonadPlus m => TP m -> TP m     +injTP s         =  MkTP (\t -> +                          case (getChildren t) of +                           [k] -> unTP s k >>= \k' ->+                                  return (getConstr t [k'])+                           _ -> mzero)                                  ++    -- Helpers++oneM f []	= mzero+oneM f (x:xs)	= do { x' <- (f x); return (x':xs) }+                  `mplus`+		  do { xs' <- oneM f xs; return (x:xs') }++uniM f []	= mzero+uniM f (x:xs)	= do { x' <- (f x); () <- noneV f xs; return (x':xs) }+		  `mplus`+		  do { () <- noneV f [x]; xs' <- uniM f xs; return (x:xs') }++noneV f []	= return ()+noneV f (x:xs)  = ((f x >>= \_ -> return True) `mplus` (return False))+                  >>= \b -> if b then mzero+                                 else noneV f xs++anyM f []	= return []+anyM f (x:xs)	= do x'  <- ((f x) `mplus` (return x))+                     xs' <-  anyM f xs+                     return (x':xs')++someM f []	= mzero+someM f (x:xs)	= do { x'  <- f x; xs' <- anyM f xs; return (x':xs') }+                  `mplus`+                  do { xs' <- someM f xs; return (x:xs') }++    -- Type-unifying++allTU 		:: Monad m => (a -> a -> a) -> a -> TU a m -> TU a m+allTU op2 u s   =  applyOnKidsTU (foldM cons u)+		     where cons i c = do c' <- (unTU s c)+		                         return (i `op2` c')++allTU' 		:: (Monad m, Monoid a) => TU a m -> TU a m+allTU'		=  allTU mappend mempty++oneTU 		:: MonadPlus m => TU a m -> TU a m+oneTU s		=  applyOnKidsTU (foldr cons mzero)+		   where cons c i = (unTU s c) `mplus` i++anyTU		:: MonadPlus m => (a -> a -> a) -> a -> TU a m -> TU a m+anyTU op2 u s	=  applyOnKidsTU (foldM (anyTUcons op2 (unTU s)) u)++anyTU'		:: (MonadPlus m, Monoid a) => TU a m -> TU a m+anyTU' 		=  anyTU mappend mempty++someTU	 	:: MonadPlus m => (a -> a -> a) -> a -> TU a m -> TU a m+someTU op2 u s	=  applyOnKidsTU (someTUfold op2 u (unTU s))++someTU'	 	:: (Monoid a, MonadPlus m) => TU a m -> TU a m+someTU'		=  someTU mappend mempty+++    -- Helpers++anyTUcons op2 f i c+  = do { c' <- f c; return (i `op2` c') }+       `mplus`+       return i++someTUfold op2 u f [] = mzero+someTUfold op2 u f (x:xs)+	= do c <- f x+             i <- (foldM (anyTUcons op2 f) u) xs+             return (i `op2` c)+             `mplus`+             someTUfold op2 u f xs+++--- Illustration of type safety ----------------------------------------------++-- The safety of this model of strategies relies on hiding of MkTP. The+-- following term demonstrates unsafe use of the MkTP constructor. We catch a+-- universal representation which arose from a string and we throw it in for+-- the result of a type-preserving function. Clearly, if we attempt to apply+-- the inner type-preserving strategy to a Boolean constant, then we end up+-- with an implosion error.++brokenTerm	 = applyTU +                     (MkTU (\u -> applyTP (MkTP (const (Just u))) True)) +                     "BREAK"++-- If the paraTP constructor function is used instead, the resulting term+-- is not typable:+--+-- untypableTerm = applyTU +--                  (MkTU (\u -> applyTP (paraTP (const (return u))) True)) +--                  "BREAK"+--+-- Thus, by not exporting MkTP, safety is guaranteed.++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/models/drift-default/TermRep.hs view
@@ -0,0 +1,167 @@+{-----------------------------------------------------------------------------++	         A LIBRARY OF FUNCTIONAL STRATEGY COMBINATORS++		                  StrategyLib++                   Ralf Laemmel                Joost Visser+               CWI & VU, Amsterdam            CWI, Amsterdam++This module is part of a library of functional strategy combinators,+including combinators for generic traversal. The universal term+representation on which the functional strategy representation relies+is defined in this module. Most users will not be concerned with any+of the entities defined here.++This particular model for term representation is based on a+contribution by John Meacham (john@repetae.net).++-----------------------------------------------------------------------------} ++{-# OPTIONS -fglasgow-exts #-}++module TermRep(module Data.Dynamic, module TermRep)  where++-- TermRep.hs Copyright (c) 2002 John Meacham+-- john@repetae.net++-- Changes by Joost Visser:+--   * desugared pattern guards to case expressions+--   * made liberal type annotations more specific+--   * commented-out instances for datatypes unknown to Hugs+--   * added some auxilliary functions +--   * added instance for String that views strings as basic+--     datatypes, i.e. as having no children++import Data.Dynamic+import Maybe(fromJust)+import Complex+import qualified IO+--import IOExts++--- The universal term representation type -----------------------------------++-- a TermRep contains a Dynamicized term as well as a (lazily generated) list+-- of all its subchildren, and a constructor function to rebuild modified +-- terms.++newtype TermRep = TermRep (Dynamic, [TermRep], ([TermRep] -> Dynamic))++--- The term interface -------------------------------------------------------+++class Typeable t => Term t where+   explode :: t -> TermRep+   explode x = let dx = toDyn x in TermRep (dx, [], (\[] -> dx))++implode :: Typeable t => TermRep -> t+implode (TermRep (x,_,_)) = fromJust $ fromDynamic x++getChildren (TermRep (_,ks,_))   = ks+getConstr   (TermRep (_,_ ,c))   = \ks -> TermRep (c ks,ks,c)+getTypeRep t                     = typeOf t+hasTypeOf (TermRep (dx,_,_)) (x::t)+  = ((fromDynamic dx)::Maybe t)++--- Instances for basic types and basic type constructors --------------------++instance Show TermRep where+    show (TermRep (x,y,_)) = show x -- ++ "(" ++ show y ++ ")"++_tc_Rational = mkTyCon "Rational"+instance Typeable Rational where+    typeOf _ = mkTyConApp _tc_Rational []++instance Term String+instance Term Int+instance Term Char+instance Term Integer+instance Term Bool+instance Term Float+instance Term Double+instance Term Dynamic+instance Term Rational+instance Term ()+--instance Term a => Term (IORef a)+instance (Typeable a) => Term (IO a)+instance (Typeable a, Typeable b) => Term (a -> b)+instance Term Ordering+--instance Term IO.Handle+--instance Term IO.IOMode+--instance Term IO.BufferMode+--instance Term IO.SeekMode++{-+instance (RealFloat a, Term a) => Term (Complex a) where+    explode (x::t) = TermRep (toDyn x, f x, g) where+	f (a :+ b) = [explode a, explode b]+	--g xs | [x,y] <- fArgs xs = toDyn ((fDyn x :+ fDyn y)::t)+	g xs = case fArgs xs of [x,y] -> toDyn ((fDyn x :+ fDyn y)::t)+-}+	+fDyn :: Typeable a => Dynamic -> a+--fDyn x = fromJust $ fromDynamic x+fDyn x = fromDyn x (error "fDyn")++fArgs :: [TermRep] -> [Dynamic]+fArgs xs = map (\(TermRep (x,_,_)) -> x) xs++{- considering cons as node with two kids :+instance Term a => Term [a] where+    explode (x::[a]) = TermRep (toDyn x, f x, g x) where+	f (x:xs) = [explode x, explode xs]+	f [] = []+	g (_:_) [TermRep (x,_,_),TermRep (xs,_,_)] +                = toDyn ((fDyn x: fDyn xs)::[a])+	g [] [] = toDyn ([]::[a])+-}++-- considering each element as a kid:+instance Term a => Term [a] where+    explode (x::[a]) = TermRep (toDyn x, f x, g x) where+	f xs    = map explode xs+	g _ ts  = toDyn ((map (\(TermRep (x,_,_)) -> fDyn x) ts)::[a])++instance (Term a,Term b) => Term (a,b) where+    explode (x::(a,b)) = TermRep (toDyn x, f x, g) where+	f (x,y) = [explode x, explode y]	+--	g xs | [x,y] <- fArgs xs = toDyn ((fDyn x,fDyn y)::t)+    	g xs = case fArgs xs of [x,y] -> toDyn ((fDyn x,fDyn y)::(a,b))+    ++instance (Term a,Term b, Term c) => Term (a,b,c) where+    explode (x::(a,b,c)) = TermRep (toDyn x, f x, g) where+	f (x,y,z) = [explode x, explode y, explode z]	+--	g xs | [x,y,z] <- fArgs xs = toDyn ((fDyn x,fDyn y,fDyn z)::t)+	g xs = case fArgs xs of +                 [x,y,z] -> toDyn ((fDyn x,fDyn y,fDyn z)::(a,b,c))++instance (Term a, Term b, Term c, Term d) => Term (a, b, c, d) where+    explode (x::(a,b,c,d)) = TermRep (toDyn x, f x, g) where+	f (x,y,z,a) = [explode x, explode y, explode z, explode a]	+	g xs = case fArgs xs of +                 [x,y,z,a] -> toDyn ((fDyn x,fDyn y,fDyn z,fDyn a)::(a,b,c,d))++instance Term a => Term (Maybe a) where+    explode (x::(Maybe a)) = TermRep (toDyn x, f x, g x) where+	f (Just x) = [explode x]+	f Nothing = []+	g (Just _) xs = case fArgs xs of +                          [x] -> toDyn ((Just (fDyn x))::(Maybe a))+	g Nothing [] = toDyn (Nothing::(Maybe a))++instance (Term a, Term b) => Term (Either a b) where+    explode (x::(Either a b)) = TermRep (toDyn x, f x, g x) where+	f (Left x) = [explode x]+	f (Right x) = [explode x]+	g (Left _) xs = case fArgs xs of +                          [x] -> toDyn ((Left (fDyn x)) ::(Either a b))+	g (Right _) xs = case fArgs xs of +                          [x] -> toDyn ((Right (fDyn x))::(Either a b))++--_tc_IORef = mkTyCon "IORef"+--instance Typeable a => Typeable (IORef a) where+--    typeOf _ = mkAppTy _tc_IORef +--                       [typeOf ((undefined:: IORef a -> a) undefined)] ++------------------------------------------------------------------------------
+ StrategyLib-4.0-beta/scripts/Makefile view
@@ -0,0 +1,5 @@+StrategyLib = ..+include ${StrategyLib}/scripts/makerules.all+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.check+include ${StrategyLib}/scripts/makerules.recurse
+ StrategyLib-4.0-beta/scripts/TestMain view
@@ -0,0 +1,4 @@+main+:q+-- This invokes the main function in an interpreter session.+
+ StrategyLib-4.0-beta/scripts/makerules.all view
@@ -0,0 +1,10 @@+###############################################################################+#+# Reminder+# ++nothing-to-do:+	@echo+	@echo " Note: there is no general \"all\" target"+	@echo " (because there is nothing to be built)."+	@echo
+ StrategyLib-4.0-beta/scripts/makerules.check view
@@ -0,0 +1,13 @@+###############################################################################+#+# Check targets that recurse+#++check-hugs:+	${MAKE} recurse target=check-hugs++check-ghci:+	${MAKE} recurse target=check-ghci++check-ghc:+	${MAKE} recurse target=check-ghc
+ StrategyLib-4.0-beta/scripts/makerules.clean view
@@ -0,0 +1,22 @@+###############################################################################+#+# These are the kind of files that are subject to normal clean-up.+#++clean:+	@rm -f *~+	@rm -f Main+	@rm -f *.log+	@rm -f *.hi+	@rm -f *.o+	@${MAKE} recurse target=clean+++###############################################################################+#+# Here we also remove files that could be derived with DrIFT.+#++very-clean: clean+	@rm -f *TermInstances.hs+	@${MAKE} recurse target=clean
+ StrategyLib-4.0-beta/scripts/makerules.drift view
@@ -0,0 +1,19 @@+###############################################################################+#+# Alias for "gmake ${derive}"+#++derive: ${derive}+++###############################################################################+#+# This is how we generate Term instances for the default model.+#++%TermInstances.hs: %.hs+	echo "module $*TermInstances where" > $@+	echo "import $*" >> $@+	echo "import TermRep" >> $@+	DrIFT -g Term -g Typeable -r $< | \+	  sed s/mkAppTy/mkTyConApp/g >> $@
+ StrategyLib-4.0-beta/scripts/makerules.examples view
@@ -0,0 +1,28 @@+###############################################################################+#+# Check targets that run local example and recurse+#++check-hugs:+	${MAKE} run-hugs+	${MAKE} recurse target=check-hugs++check-ghci:+	${MAKE} run-ghci+	${MAKE} recurse target=check-ghci++check-ghc:+	${MAKE} run-ghc+	${MAKE} recurse target=check-ghc+++###############################################################################+#+# Reusable includes+#++include ${StrategyLib}/scripts/makerules.opts+include ${StrategyLib}/scripts/makerules.run+include ${StrategyLib}/scripts/makerules.drift+include ${StrategyLib}/scripts/makerules.clean+include ${StrategyLib}/scripts/makerules.recurse
+ StrategyLib-4.0-beta/scripts/makerules.opts view
@@ -0,0 +1,18 @@+###############################################################################+#+# These are the options that will do for the examples in the distribution.+#++haskell-path = ${StrategyLib}/library:${StrategyLib}/models/${Model}:++ghc-opts =	-fglasgow-exts				\+		-fallow-overlapping-instances		\+		-fallow-undecidable-instances		\+	        -package data				\+	        -package lang \+		-i${haskell-path}++hugs-opts =	-98 					\+		+o 					\+		+N                                      \+		-P${haskell-path}
+ StrategyLib-4.0-beta/scripts/makerules.recurse view
@@ -0,0 +1,19 @@+###############################################################################+#+# This target is needed for recursion into subdirectories.+#++#recurse:+#	@for subdir in ${subdirs}; do	\+#	  (cd $$subdir; ${MAKE} ${target});	\+#	done++SUBDIRS	= ${subdirs}++.PHONY: recurse $(SUBDIRS)++recurse: $(SUBDIRS)++$(SUBDIRS):+	$(MAKE) -C $@ ${target}+
+ StrategyLib-4.0-beta/scripts/makerules.run view
@@ -0,0 +1,29 @@+###############################################################################+#+# Here we use a very simple test target to run hugs in an example directory.+#++run-hugs: derive+	hugs ${hugs-opts} Main.hs < ${StrategyLib}/scripts/TestMain+	diff Test.log Test.correct+++###############################################################################+#+# Here we use a very simple test target to run ghci in an example directory.+#++run-ghci: derive+	ghci ${ghc-opts} Main.hs < ${StrategyLib}/scripts/TestMain+	diff Test.log Test.correct+++###############################################################################+#+# Here we use a test target to compile and run a program.+#++run-ghc: derive+	ghc ${ghc-opts} --make Main.hs -o Main+	./Main+	diff Test.log Test.correct
+ misc/._haskell-refac.el view

binary file changed (absent → 289 bytes)

+ misc/._refactor.vim view

binary file changed (absent → 286 bytes)

+ misc/Array.hs view
@@ -0,0 +1,81 @@+module  Array ( +    module Ix,  -- export all of Ix +    Array, array, listArray, (!), bounds, indices, elems, assocs, +    accumArray, (//), accum, ixmap ) where++import Prelude+import Ix+import List( (\\) )++infixl 9  !, //++data (Ix a) => Array a b = MkArray (a,a) (a -> b)++--array       :: (Ix a) => (a,a) -> [(a,b)] -> Array a b+array b ivs =+    if and [inRange b i | (i,_) <- ivs]+        then MkArray b $+                     \j -> let vs = [v | (i,v) <- ivs, i == j]+                           in case vs of+                                [v]   -> v+                                []    -> error "Array.!: undefined array element"+                                _     -> error "Array.!: multiply defined array element"+                     +        else error "Array.array: out-of-range array association"++--listArray             :: (Ix a) => (a,a) -> [b] -> Array a b+listArray b vs        =  array b (zipWith (\ a b -> (a,b)) (range b) vs)++(!)                   :: (Ix a) => Array a b -> a -> b+(!) (MkArray _ f)     =  f++bounds                :: (Ix a) => Array a b -> (a,a)+bounds (MkArray b _)  =  b++indices               :: (Ix a) => Array a b -> [a]+indices               =  range . bounds++elems                 :: (Ix a) => Array a b -> [b]+elems a               =  [a!i | i <- indices a]++assocs                :: (Ix a) => Array a b -> [(a,b)]+assocs a              =  [(i, a!i) | i <- indices a]++--(//)                  :: (Ix a) => Array a b -> [(a,b)] -> Array a b+a // us               =  array (bounds a)+                            ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]+                             ++ us)++--accum                 :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)]+--                                   -> Array a b+accum f               =  foldl (\a (i,v) -> a // [(i,f (a!i) v)])++--accumArray            :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)]+--                                   -> Array a b+accumArray f z b      =  accum f (array b [(i,z) | i <- range b])++--ixmap                 :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c+--                                         -> Array a c+ixmap b f a           = array b [(i, a ! f i) | i <- range b]+++instance  (Ix ix)         => Functor (Array ix) where+    fmap fn (MkArray b f) =  MkArray b (fn . f) ++instance  (Eq a,Ix a, Eq b)  => Eq (Array a b)  where+    a == a'             =  assocs a == assocs a'++instance  (Ix a,Ord a, Ord b) => Ord (Array a b)  where+    a <=  a'            =  assocs a <=  assocs a'++instance  (Ix a, Show a, Show b) => Show (Array a b)  where+    showsPrec p a = showParen (p > 9) (+                    showString "array " .+                    shows (bounds a) . showChar ' ' .+                    shows (assocs a)                  )++instance  (Eq a,Ix a, Read a, Read b) => Read (Array a b)  where+    readsPrec p = readParen (p > 9)+           (\r -> [(array b as, u) | ("array",s) <- lex r,+                                     (b,t)       <- reads s,+                                     (as,u)      <- reads t   ])
+ misc/CPUTime.hs view
@@ -0,0 +1,5 @@+module CPUTime where+import Prelude++foreign import getCPUTime :: IO Integer+foreign import cpuTimePrecision :: Integer
+ misc/Char.hs view
@@ -0,0 +1,149 @@+module Char(+    isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower, +    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, +    digitToInt, intToDigit,+    toUpper, toLower,+    ord, chr,+    readLitChar, showLitChar, lexLitChar,+    Char,String+ )+where+import Prelude+import PreludeBuiltin+import Numeric(readDec, readOct, lexDigits, readHex)+import Array+import Ix++isAscii, isControl, isPrint, isSpace            :: Char -> Bool+isUpper, isLower, isAlpha, isDigit, isAlphanum  :: Char -> Bool++isAscii c     =  c < '\x80'++isLatin1 c = c <= '\xff'++isControl c   =  c < ' ' || c >= '\DEL' && c <= '\x9f'++isPrint c     =  c >= ' '   &&  c <= '~' || c >= '\xa0'++isSpace c     =  c == ' '   || c == '\t'  || c == '\n'  || c == '\r'  ||+                               c == '\f'  || c == '\v' || c=='\xa0'++isUpper c     =+        c >= 'A' && c <= 'Z' ++isLower c     =+        c >= 'a' && c <= 'z'++isAlpha c     =  isUpper c  ||  isLower c+isDigit c     =  c >= '0'   &&  c <= '9'+isAlphanum c  =  isAlpha c  ||  isDigit c+isAlphaNum = isAlphanum++toUpper, toLower      :: Char -> Char++toUpper c | isLower c  = chr (ord c - ord 'a' + ord 'A')+          | otherwise  = c++toLower c | isUpper c  = chr (ord c - ord 'A' + ord 'a')+          | otherwise  = c++minChar, maxChar      :: Char+minChar                = chr 0+maxChar                = chr 255+++isOctDigit c             =  c >= '0' && c <= '7'++isHexDigit c             =  isDigit c || c >= 'A' && c <= 'F' ||+                                         c >= 'a' && c <= 'f'+-- Digit conversion operations+digitToInt :: Char -> Int+digitToInt c+  | isDigit c            =  fromEnum c - fromEnum '0'+  | c >= 'a' && c <= 'f' =  fromEnum c - fromEnum 'a' + 10+  | c >= 'A' && c <= 'F' =  fromEnum c - fromEnum 'A' + 10+  | otherwise            =  error "Char.digitToInt: not a digit"++intToDigit :: Int -> Char+intToDigit i+  | i >= 0  && i <=  9   =  toEnum (fromEnum '0' + i)+  | i >= 10 && i <= 15   =  toEnum (fromEnum 'a' + i - 10)+  | otherwise            =  error "Char.intToDigit: not a digit"++ord c = primCharToInt c+chr n = primIntToChar n+++-- Text functions+--readLitChar             :: ReadS Char+readLitChar ('\\':s)    =  readEsc s+        where+        readEsc ('a':s)  = [('\a',s)]+        readEsc ('b':s)  = [('\b',s)]+        readEsc ('f':s)  = [('\f',s)]+        readEsc ('n':s)  = [('\n',s)]+        readEsc ('r':s)  = [('\r',s)]+        readEsc ('t':s)  = [('\t',s)]+        readEsc ('v':s)  = [('\v',s)]+        readEsc ('\\':s) = [('\\',s)]+        readEsc ('"':s)  = [('"',s)]+        readEsc ('\'':s) = [('\'',s)]+        readEsc ('^':c:s) | c >= '@' && c <= '_'+                         = [(chr (ord c - ord '@'), s)]+        readEsc s@(d:_) | isDigit d+                         = [(chr n, t) | (n,t) <- readDec s]+        readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]+        readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]+        readEsc s@(c:_) | isUpper c+                         = let table = ('\DEL', "DEL") : assocs asciiTab+                           in case [(c,s') | (c, mne) <- table,+                                             ([],s') <- [match mne s]]+                              of (pr:_) -> [pr]+                                 []     -> []+        readEsc _        = []++	match                         :: (Eq a) => [a] -> [a] -> ([a],[a])+	match (x:xs) (y:ys) | x == y  =  match xs ys+	match xs     ys               =  (xs,ys)++readLitChar (c:s)       =  [(c,s)]+--}+showLitChar               :: Char -> ShowS+showLitChar c | c > '\DEL' =  showChar '\\' . +                              protectEsc isDigit (shows (ord c))+showLitChar '\DEL'         =  showString "\\DEL"+showLitChar '\\'           =  showString "\\\\"+showLitChar c | c >= ' '   =  showChar c+showLitChar '\a'           =  showString "\\a"+showLitChar '\b'           =  showString "\\b"+showLitChar '\f'           =  showString "\\f"+showLitChar '\n'           =  showString "\\n"+showLitChar '\r'           =  showString "\\r"+showLitChar '\t'           =  showString "\\t"+showLitChar '\v'           =  showString "\\v"+showLitChar '\SO'          =  protectEsc (== 'H') (showString "\\SO")+showLitChar c              =  showString ('\\' : asciiTab!c)++protectEsc p f             = f . cont+                             where cont s@(c:_) | p c = "\\&" ++ s+                                   cont s             = s+asciiTab = listArray ('\NUL', ' ')+           ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",+            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI", +            "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",+            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US", +            "SP"] ++--lexLitChar          :: ReadS String+lexLitChar ('\\':s) =  [('\\':esc, t) | (esc,t) <- lexEsc s]+        where+          lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]+          lexEsc s@(d:_)   | isDigit d               = lexDigits s+          lexEsc ('^':c:s) | c >= '@' && c <= '_'    = [(['^',c],s)]+          -- Very crude approximation to \XYZ.  Let readers work this out.+          lexEsc s@(c:_)   | isUpper c               = [span isCharName s]+          lexEsc _                                   = []+          isCharName c = isUpper c || isDigit c++lexLitChar (c:s)    =  [([c],s)]+lexLitChar ""       =  []
+ misc/Complex.hs view
@@ -0,0 +1,95 @@+module Complex(Complex((:+)), realPart, imagPart, conjugate, mkPolar,+               cis, polar, magnitude, phase)  where+--import Prelude++infix  6  :+++data  (RealFloat a)     => Complex a = !a :+ !a  deriving (Eq,Read,Show)+++realPart, imagPart :: (RealFloat a) => Complex a -> a+realPart (x:+y)  =  x+imagPart (x:+y)  =  y++conjugate  :: (RealFloat a) => Complex a -> Complex a+conjugate (x:+y) =  x :+ (-y)++mkPolar  :: (RealFloat a) => a -> a -> Complex a+mkPolar r theta  =  r * cos theta :+ r * sin theta++cis  :: (RealFloat a) => a -> Complex a+cis theta  =  cos theta :+ sin theta++polar  :: (RealFloat a) => Complex a -> (a,a)+polar z  =  (magnitude z, phase z)++magnitude :: (RealFloat a) => Complex a -> a+magnitude (x:+y) =  scaleFloat k+     (sqrt ((scaleFloat mk x)^(2::Int) + (scaleFloat mk y)^(2::Int)))+    where k  = max (exponent x) (exponent y)+          mk = - k++phase :: (RealFloat a) => Complex a -> a+phase (0 :+ 0) = 0+phase (x :+ y) = atan2 y x+++instance  (RealFloat a) => Num (Complex a)  where+    (x:+y) + (x':+y') =  (x+x') :+ (y+y')+    (x:+y) - (x':+y') =  (x-x') :+ (y-y')+    (x:+y) * (x':+y') =  (x*x'-y*y') :+ (x*y'+y*x')+    negate (x:+y) =  negate x :+ negate y+    abs z =  magnitude z :+ 0+    signum 0 =  0+    signum z@(x:+y) =  (x/r) :+ (y/r)  where r = magnitude z+    fromInteger n =  fromInteger n :+ 0++instance  (RealFloat a) => Fractional (Complex a)  where+    (x:+y) / (x':+y') =  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d+       where x'' = scaleFloat k x'+	     y'' = scaleFloat k y'+	     k   = - max (exponent x') (exponent y')+	     d   = x'*x'' + y'*y''++    fromRational a =  fromRational a :+ 0++instance  (RealFloat a) => Floating (Complex a) where+    pi             =  pi :+ 0+    exp (x:+y)     =  expx * cos y :+ expx * sin y+                      where expx = exp x+    log z          =  log (magnitude z) :+ phase z++    sqrt 0         =  0+    sqrt z@(x:+y)  =  u :+ (if y < 0 then -v else v)+                      where (u,v) = if x < 0 then (v',u') else (u',v')+                            v'    = abs y / (u'*2)+                            u'    = sqrt ((magnitude z + abs x) / 2)++    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y+    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)+    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))+                      where sinx  = sin x+                            cosx  = cos x+                            sinhy = sinh y+                            coshy = cosh y++    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x+    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x+    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)+                      where siny  = sin y+                            cosy  = cos y+                            sinhx = sinh x+                            coshx = cosh x++    asin z@(x:+y)  =  y':+(-x')+                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))+    acos z@(x:+y)  =  y'':+(-x'')+                      where (x'':+y'') = log (z + ((-y'):+x'))+                            (x':+y')   = sqrt (1 - z*z)+    atan z@(x:+y)  =  y':+(-x')+                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))++    asinh z        =  log (z + sqrt (1+z*z))+    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))+    atanh z        =  log ((1+z) / sqrt (1-z*z))+
+ misc/Directory.hs view
@@ -0,0 +1,25 @@+module Directory where+import Prelude+import Time(ClockTime)++data Permissions+  = Permissions { readable, writable, executable, searchable :: Bool }+  deriving ( Eq, Ord, Read, Show )++foreign import createDirectory :: FilePath -> IO ()+foreign import removeDirectory :: FilePath -> IO ()+foreign import removeFile :: FilePath -> IO ()+foreign import renameDirectory  :: FilePath -> FilePath -> IO ()+foreign import renameFile  :: FilePath -> FilePath -> IO ()++foreign import getDirectoryContents  :: FilePath -> IO [FilePath]+foreign import getCurrentDirectory  :: IO FilePath+foreign import setCurrentDirectory  :: FilePath -> IO ()++foreign import doesFileExist :: FilePath -> IO Bool+foreign import doesDirectoryExist :: FilePath -> IO Bool++foreign import getPermissions :: FilePath -> IO Permissions+foreign import setPermissions :: FilePath -> Permissions -> IO ()++foreign import getModificationTime :: FilePath -> IO ClockTime
+ misc/IO.hs view
@@ -0,0 +1,76 @@+module IO(module IO,module PreludeIO) where+import Prelude+import PreludeIO++data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode+                    deriving (Eq, Ord, {-Ix,-} Bounded, Enum, Read, Show)+data BufferMode  =  NoBuffering | LineBuffering +                 |  BlockBuffering (Maybe Int)+                    deriving (Eq, Ord, Read, Show)+data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd+                    deriving (Eq, Ord, {-Ix,-} Bounded, Enum, Read, Show)++--- Unimplemented things:+hSetBuffering mode handle = return ()+---++data PrimHandle+instance Eq PrimHandle+instance Show PrimHandle++foreign import prim_stdin :: PrimHandle+foreign import prim_stdout :: PrimHandle+foreign import prim_stderr :: PrimHandle+foreign import primHPutChar :: PrimHandle -> Char -> IO ()+foreign import primHPutStr :: PrimHandle -> String -> IO ()+foreign import primHFlush :: PrimHandle -> IO ()++newtype Handle = Handle PrimHandle deriving (Eq,Show)++stdin = Handle prim_stdin+stdout = Handle prim_stdout+stderr = Handle prim_stderr++foreign import openFile :: FilePath -> IOMode -> IO Handle+foreign import hClose :: Handle -> IO ()+foreign import hGetLine :: Handle -> IO String+foreign import hGetContents :: Handle -> IO String++hPutChar (Handle h) c = primHPutChar h c+hPutStr (Handle h) s = primHPutStr h s+hPutStrLn h s = hPutStr h s >> hPutChar h '\n'+hPrint h x = hPutStrLn h (show x)++hFlush (Handle h) = primHFlush h++---++ioeGetErrorString (IOE k s) = s++ioErrorKind (IOE k _) = k++isEOFError e = ioErrorKind e == EOFError+isUserError e = ioErrorKind e == UserError+isDoesNotExistError e = ioErrorKind e == DoesNotExistError++---+try            :: IO a -> IO (Either IOError a)+try f          =  catch (fmap Right f) (return . Left)++bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c+bracket before after m =+  do    x  <- before+        rs <- try (m x)+        after x+	returnTry rs++-- variant of the above where middle computation doesn't want x+bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c+bracket_ before after m =+  do     x  <- before+         rs <- try m+         after x+	 returnTry rs++returnTry (Right r) = return r+returnTry (Left  e) = ioError e
+ misc/Ix.hs view
@@ -0,0 +1,55 @@+module Ix ( Ix(range, index, inRange), rangeSize ) where+import Prelude++class  (Ord a) => Ix a  where+    range               :: (a,a) -> [a]+    index               :: (a,a) -> a -> Int+    inRange             :: (a,a) -> a -> Bool++rangeSize :: Ix a => (a,a) -> Int+rangeSize b@(l,h) | null (range b) = 0+                  | otherwise      = index b h + 1 +-- NB: replacing "null (range b)" by  "l > h" fails if+-- the bounds are tuples.  For example,+--  (2,1) > (1,2), +-- but +-- range ((2,1),(1,2)) = []+++instance  Ix Char  where+    range (m,n) = [m..n]+    index b@(c,c') ci+        | inRange b ci  =  fromEnum ci - fromEnum c+        | otherwise     =  error "Ix.index: Index out of range."+    inRange (c,c') i    =  c <= i && i <= c'++instance  Ix Int  where+    range (m,n) = [m..n]+    index b@(m,n) i+        | inRange b i   =  i - m+        | otherwise     =  error "Ix.index: Index out of range."+    inRange (m,n) i     =  m <= i && i <= n+++instance  Ix Integer  where+    range (m,n) = [m..n]+    index b@(m,n) i+        | inRange b i   =  fromInteger (i - m)+        | otherwise     =  error "Ix.index: Index out of range."+    inRange (m,n) i     =  m <= i && i <= n+++--instance (Ix a,Ix b) => Ix (a, b) -- as derived, for all tuples+--instance Ix Bool                  -- as derived+--instance Ix Ordering              -- as derived+--instance Ix ()                    -- as derived++++instance  (Ix a, Ix b)  => Ix (a,b) where+    range ((l,l'),(u,u'))+         = [(i,i') | i <- range (l,u), i' <- range (l',u')]+    index ((l,l'),(u,u')) (i,i')+         =  index (l,u) i * rangeSize (l',u') + index (l',u') i'+    inRange ((l,l'),(u,u')) (i,i')+         = inRange (l,u) i && inRange (l',u') i'
+ misc/List.hs view
@@ -0,0 +1,273 @@+module List (+    elemIndex, elemIndices,+    find, findIndex, findIndices,+    nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy,+    union, unionBy, intersect, intersectBy,+    intersperse, transpose, partition, group, groupBy,+    inits, tails, isPrefixOf, isSuffixOf,+    mapAccumL, mapAccumR,+    sort, sortBy, insert, insertBy, maximumBy, minimumBy,+    genericLength, genericTake, genericDrop,+    genericSplitAt, genericIndex, genericReplicate,+    zip4, zip5, zip6, zip7,+    zipWith4, zipWith5, zipWith6, zipWith7,+    unzip4, unzip5, unzip6, unzip7, unfoldr,++    -- ...and what the Prelude exports+    --[]((:), []),+    map, (++), concat, filter,+    head, last, tail, init, null, length, (!!),+    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,+    iterate, repeat, replicate, cycle,+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    lines, words, unlines, unwords, reverse, and, or,+    any, all, elem, notElem, lookup,+    sum, product, maximum, minimum, concatMap,+    zip, zip3, zipWith, zipWith3, unzip, unzip3+    ) where++import Prelude+import Maybe( listToMaybe )++infix 5 \\ --++elemIndex               :: Eq a => a -> [a] -> Maybe Int+elemIndex x             =  findIndex (x ==)++elemIndices             :: Eq a => a -> [a] -> [Int]+elemIndices x           =  findIndices (x ==)++find                    :: (a -> Bool) -> [a] -> Maybe a+find p                  =  listToMaybe . filter p++findIndex               :: (a -> Bool) -> [a] -> Maybe Int+findIndex p             =  listToMaybe . findIndices p++findIndices             :: (a -> Bool) -> [a] -> [Int]+findIndices p xs        =  [ i | (x,i) <- zip xs [0..], p x ]++nub                     :: Eq a => [a] -> [a]+nub                     =  nubBy (==)++nubBy                   :: (a -> a -> Bool) -> [a] -> [a]+nubBy eq []             =  []+nubBy eq (x:xs)         =  x : nubBy eq (filter (\y -> not (eq x y)) xs)++delete                  :: Eq a => a -> [a] -> [a]+delete                  =  deleteBy (==)++deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]+deleteBy eq x []        = []+deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys++(\\)                    :: Eq a => [a] -> [a] -> [a]+(\\)                    =  foldl (flip delete)++deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]+deleteFirstsBy eq       =  foldl (flip (deleteBy eq))++union                   :: Eq a => [a] -> [a] -> [a]+union                   =  unionBy (==)++unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]+unionBy eq xs ys        =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs++intersect               :: Eq a => [a] -> [a] -> [a]+intersect               =  intersectBy (==)++intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]+intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]++intersperse             :: a -> [a] -> [a]+intersperse sep []      =  []+intersperse sep [x]     =  [x]+intersperse sep (x:xs)  =  x : sep : intersperse sep xs++-- transpose is lazy in both rows and columns,+--   and works for non-rectangular 'matrices'+-- For example, transpose [[1,2],[3,4,5],[]]  =  [[1,3],[2,4],[5]]+-- Note that [h | (h:t) <- xss] is not the same as (map head xss)+-- because the former discards empty sublists inside xss+transpose                :: [[a]] -> [[a]]+transpose []  = []+transpose ([]     : xss) = transpose xss+transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) :+   transpose (xs : [t | (h:t) <- xss])++partition               :: (a -> Bool) -> [a] -> ([a],[a])+partition p xs          =  foldr select ([],[]) xs+                           where select x (ts,fs) | p x       = (x:ts,fs)+                                                  | otherwise = (ts, x:fs)++-- group splits its list argument into a list of lists of equal, adjacent+-- elements.  e.g.,+-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]+group                   :: Eq a => [a] -> [[a]]+group                   =  groupBy (==)++groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]+groupBy eq []           =  []+groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs+                           where (ys,zs) = span (eq x) xs++-- inits xs returns the list of initial segments of xs, shortest first.+-- e.g., inits "abc" == ["","a","ab","abc"]+inits                   :: [a] -> [[a]]+inits []                =  [[]]+inits (x:xs)            =  [[]] ++ map (x:) (inits xs)++-- tails xs returns the list of all final segments of xs, longest first.+-- e.g., tails "abc" == ["abc", "bc", "c",""]+tails                   :: [a] -> [[a]]+tails []                =  [[]]+tails xxs@(_:xs)        =  xxs : tails xs++isPrefixOf               :: Eq a => [a] -> [a] -> Bool+isPrefixOf []     _      =  True+isPrefixOf _      []     =  False+isPrefixOf (x:xs) (y:ys) =  x == y && isPrefixOf xs ys++isSuffixOf              :: Eq a => [a] -> [a] -> Bool+isSuffixOf x y          =  reverse x `isPrefixOf` reverse y++mapAccumL               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccumL f s []        =  (s, [])+mapAccumL f s (x:xs)    =  (s'',y:ys)+                           where (s', y ) = f s x+                                 (s'',ys) = mapAccumL f s' xs++mapAccumR               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccumR f s []        =  (s, [])+mapAccumR f s (x:xs)    =  (s'', y:ys)+                           where (s'',y ) = f s' x+                                 (s', ys) = mapAccumR f s xs++unfoldr :: (b -> Maybe (a,b)) -> b -> [a]+unfoldr f b = case f b of+	        Nothing    -> []+		Just (a,b) -> a : unfoldr f b++sort                    :: (Ord a) => [a] -> [a]+sort                    =  sortBy compare++sortBy                  :: (a -> a -> Ordering) -> [a] -> [a]+sortBy cmp              =  foldr (insertBy cmp) []++insert :: (Ord a) => a -> [a] -> [a]+insert = insertBy compare++insertBy                :: (a -> a -> Ordering) -> a -> [a] -> [a]+insertBy cmp x []       =  [x]+insertBy cmp x ys@(y:ys')+                        =  case cmp x y of+                                GT -> y : insertBy cmp x ys'+                                _  -> x : ys++maximumBy               :: (a -> a -> Ordering) -> [a] -> a+maximumBy cmp []        =  error "List.maximumBy: empty list"+maximumBy cmp xs        =  foldl1 max xs+                        where+                           max x y = case cmp x y of+                                        GT -> x+                                        _  -> y++minimumBy               :: (a -> a -> Ordering) -> [a] -> a+minimumBy cmp []        =  error "List.minimumBy: empty list"+minimumBy cmp xs        =  foldl1 min xs+                        where+                           min x y = case cmp x y of+                                        GT -> y+                                        _  -> x++--genericLength           :: (Integral a) => [b] -> a+genericLength []        =  0+genericLength (x:xs)    =  1 + genericLength xs++--genericTake             :: (Integral a) => a -> [b] -> [b]+genericTake _ []        =  []+genericTake 0 _         =  []+genericTake n (x:xs)+   | n > 0              =  x : genericTake (n-1) xs+   | otherwise          =  error "List.genericTake: negative argument"++--genericDrop             :: (Integral a) => a -> [b] -> [b]+genericDrop 0 xs        =  xs+genericDrop _ []        =  []+genericDrop n (_:xs)+   | n > 0              =  genericDrop (n-1) xs+   | otherwise          =  error "List.genericDrop: negative argument"++--genericSplitAt          :: (Integral a) => a -> [b] -> ([b],[b])+genericSplitAt 0 xs     =  ([],xs)+genericSplitAt _ []     =  ([],[])+genericSplitAt n (x:xs)+   | n > 0              =  (x:xs',xs'')+   | otherwise          =  error "List.genericSplitAt: negative argument"+       where (xs',xs'') =  genericSplitAt (n-1) xs++--genericIndex            :: (Integral a) => [b] -> a -> b+genericIndex (x:_)  0   =  x+genericIndex (x:xs) n+        | n > 0         =  genericIndex xs (n-1)+        | otherwise     =  error "List.genericIndex: negative argument"+genericIndex _ _        =  error "List.genericIndex: index too large"++--genericReplicate        :: (Integral a) => a -> b -> [b]+genericReplicate n x    =  genericTake n (repeat x)++zip4                    :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]+zip4                    =  zipWith4 (,,,)++zip5                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]+zip5                    =  zipWith5 (,,,,)++zip6                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [(a,b,c,d,e,f)]+zip6                    =  zipWith6 (,,,,,)++zip7                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [g] -> [(a,b,c,d,e,f,g)]+zip7                    =  zipWith7 (,,,,,,)++zipWith4                :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]+zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)+                        =  z a b c d : zipWith4 z as bs cs ds+zipWith4 _ _ _ _ _      =  []++zipWith5                :: (a->b->c->d->e->f) ->+                           [a]->[b]->[c]->[d]->[e]->[f]+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)+                        =  z a b c d e : zipWith5 z as bs cs ds es+zipWith5 _ _ _ _ _ _    =  []++zipWith6                :: (a->b->c->d->e->f->g) ->+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]+zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)+                        =  z a b c d e f : zipWith6 z as bs cs ds es fs+zipWith6 _ _ _ _ _ _ _  =  []++zipWith7                :: (a->b->c->d->e->f->g->h) ->+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]+zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)+                   =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs+zipWith7 _ _ _ _ _ _ _ _ = []++unzip4                  :: [(a,b,c,d)] -> ([a],[b],[c],[d])+unzip4                  =  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->+                                        (a:as,b:bs,c:cs,d:ds))+                                 ([],[],[],[])++unzip5                  :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])+unzip5                  =  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->+                                        (a:as,b:bs,c:cs,d:ds,e:es))+                                 ([],[],[],[],[])++unzip6                  :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])+unzip6                  =  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->+                                        (a:as,b:bs,c:cs,d:ds,e:es,f:fs))+                                 ([],[],[],[],[],[])++unzip7          :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])+unzip7          =  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->+                                (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))+                         ([],[],[],[],[],[],[])
+ misc/Locale.hs view
@@ -0,0 +1,32 @@+module Locale(TimeLocale(..), defaultTimeLocale) where+import Prelude++data TimeLocale = TimeLocale {+        wDays  :: [(String, String)],   -- full and abbreviated week days+        months :: [(String, String)],   -- full and abbreviated months+        amPm   :: (String, String),     -- AM/PM symbols+        dateTimeFmt, dateFmt,           -- formatting strings+          timeFmt, time12Fmt :: String     +        } --deriving (Eq, Ord, Show)++defaultTimeLocale :: TimeLocale +defaultTimeLocale =  TimeLocale { +        wDays  = [("Sunday",   "Sun"),  ("Monday",    "Mon"),   +                  ("Tuesday",  "Tue"),  ("Wednesday", "Wed"), +                  ("Thursday", "Thu"),  ("Friday",    "Fri"), +                  ("Saturday", "Sat")],++        months = [("January",   "Jan"), ("February",  "Feb"),+                  ("March",     "Mar"), ("April",     "Apr"),+                  ("May",       "May"), ("June",      "Jun"),+                  ("July",      "Jul"), ("August",    "Aug"),+                  ("September", "Sep"), ("October",   "Oct"),+                  ("November",  "Nov"), ("December",  "Dec")],++        amPm = ("AM", "PM"),+        dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y",+        dateFmt = "%m/%d/%y",+        timeFmt = "%H:%M:%S",+        time12Fmt = "%I:%M:%S %p"+        }+
+ misc/Maybe.hs view
@@ -0,0 +1,40 @@+module Maybe(+    isJust, isNothing,+    fromJust, fromMaybe, listToMaybe, maybeToList,+    catMaybes, mapMaybe,++    -- ...and what the Prelude exports+    Maybe(Nothing, Just),+    maybe+  ) where+import Prelude --(Maybe(..))++isJust                 :: Maybe a -> Bool+isJust (Just a)        =  True+isJust Nothing         =  False++isNothing        :: Maybe a -> Bool+isNothing        =  not . isJust++fromJust               :: Maybe a -> a+fromJust (Just a)      =  a+fromJust Nothing       =  error "Maybe.fromJust: Nothing"++fromMaybe              :: a -> Maybe a -> a+fromMaybe d Nothing    =  d+fromMaybe d (Just a)   =  a++maybeToList            :: Maybe a -> [a]+maybeToList Nothing    =  []+maybeToList (Just a)   =  [a]++listToMaybe            :: [a] -> Maybe a+listToMaybe []         =  Nothing+listToMaybe (a:_)      =  Just a+ +catMaybes              :: [Maybe a] -> [a]+catMaybes ms           =  [ m | Just m <- ms ]++mapMaybe               :: (a -> Maybe b) -> [a] -> [b]+mapMaybe f             =  catMaybes . map f+
+ misc/Monad.hs view
@@ -0,0 +1,95 @@+module Monad {-(+    MonadPlus(mzero, mplus),+    join, guard, when, unless, ap,+    msum,+    filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM, +    liftM, liftM2, liftM3, liftM4, liftM5,++    -- ...and what the Prelude exports+    Monad((>>=), (>>), return, fail),+    Functor(fmap),+    mapM, mapM_, sequence, sequence_, (=<<), +    ) -} where+import Prelude++-- The MonadPlus class definition++class  (Monad m) => MonadPlus m  where+    mzero  :: m a+    mplus  :: m a -> m a -> m a+++-- Instances of MonadPlus++instance  MonadPlus Maybe  where+    mzero                 = Nothing++    Nothing `mplus` ys    =  ys+    xs      `mplus` ys    =  xs++instance  MonadPlus []  where+    mzero =  []+    mplus = (++)+++-- Functions    +++msum  :: MonadPlus m => [m a] -> m a+msum xs  =  foldr mplus mzero xs++join             :: (Monad m) => m (m a) -> m a+join x           =  x >>= id++when             :: (Monad m) => Bool -> m () -> m ()+when p s         =  if p then s else return ()++unless           :: (Monad m) => Bool -> m () -> m ()+unless p s       =  when (not p) s++ap               :: (Monad m) => m (a -> b) -> m a -> m b+ap               =  liftM2 ($)++--guard            :: MonadPlus m => Bool -> m ()+guard p          =  if p then return () else mzero++mapAndUnzipM     :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])+mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip++zipWithM         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+zipWithM f xs ys =  sequence (zipWith f xs ys)++zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)++foldM            :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a+foldM f a []     =  return a+foldM f a (x:xs) =  f a x >>= \ y -> foldM f y xs++filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]+filterM p []     = return []+filterM p (x:xs) = do { b  <- p x;+			ys <- filterM p xs; +			return (if b then (x:ys) else ys)+		   }++liftM            :: (Monad m) => (a -> b) -> (m a -> m b)+liftM f          =  \a -> do { a' <- a; return (f a') }++liftM2           :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)+liftM2 f         =  \a b -> do { a' <- a; b' <- b; return (f a' b') }++liftM3           :: (Monad m) => (a -> b -> c -> d) ->+                                 (m a -> m b -> m c -> m d)+liftM3 f         =  \a b c -> do { a' <- a; b' <- b; c' <- c;+				   return (f a' b' c') }++liftM4           :: (Monad m) => (a -> b -> c -> d -> e) ->+                                 (m a -> m b -> m c -> m d -> m e)+liftM4 f         =  \a b c d -> do { a' <- a; b' <- b; c' <- c; d' <- d;+				     return (f a' b' c' d') }++liftM5           :: (Monad m) => (a -> b -> c -> d -> e -> f) ->+                                 (m a -> m b -> m c -> m d -> m e -> m f)+liftM5 f         =  \a b c d e -> do { a' <- a; b' <- b; c' <- c; d' <- d;+				       e' <- e; return (f a' b' c' d' e') }
+ misc/Numeric.hs view
@@ -0,0 +1,309 @@+module Numeric(fromRat,+               showSigned, showInt,+               readSigned, readInt,+               readDec, readOct, readHex,+               floatToDigits,+               showEFloat, showFFloat, showGFloat, showFloat, +               readFloat, lexDigits) where++import Prelude+import Char+import Ratio+import Array++default()++-- This converts a rational to a floating.  This should be used in the+-- Fractional instances of Float and Double.++fromRat :: (RealFloat a) => Rational -> a+fromRat x = +    if x == 0 then encodeFloat 0 0              -- Handle exceptional cases+    else if x < 0 then - fromRat' (-x)          -- first.+    else fromRat' x++-- Conversion process:+-- Scale the rational number by the RealFloat base until+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).+-- Then round the rational to an Integer and encode it with the exponent+-- that we got from the scaling.+-- To speed up the scaling process we compute the log2 of the number to get+-- a first guess of the exponent.+fromRat' :: (RealFloat a) => Rational -> a+fromRat' x = undefined{-r+  where b = floatRadix r+        p = floatDigits r+        (minExp0, _) = floatRange r+        minExp = minExp0 - p            -- the real minimum exponent+        xMin = toRational (expt b (p-1))+        xMax = toRational (expt b p)+        p0 = (integerLogBase b (numerator x) -+              integerLogBase b (denominator x) - p) `max` minExp+        f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1+        (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)+        r = encodeFloat (round x') p'-}++-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.+scaleRat :: Rational -> Int -> Rational -> Rational -> +             Int -> Rational -> (Rational, Int)+scaleRat b minExp xMin xMax p x =+    if p <= minExp then+        (x, p)+    else if x >= xMax then+        scaleRat b minExp xMin xMax (p+1) (x/b)+    else if x < xMin  then+        scaleRat b minExp xMin xMax (p-1) (x*b)+    else+        (x, p)++-- Exponentiation with a cache for the most common numbers.+minExpt = 0::Int+maxExpt = 1100::Int+expt :: Integer -> Int -> Integer+expt base n =+    if base == 2 && n >= minExpt && n <= maxExpt then+        expts!n+    else+        base^n++expts :: Array Int Integer+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]++-- Compute the (floor of the) log of i in base b.+-- Simplest way would be just divide i by b until it's smaller then b,+-- but that would be very slow!  We are just slightly more clever.+integerLogBase :: Integer -> Integer -> Int+integerLogBase b i =+     if i < b then+        0+     else+        -- Try squaring the base first to cut down the number of divisions.+        let l = 2 * integerLogBase (b*b) i+            doDiv :: Integer -> Int -> Int+            doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)+        in  doDiv (i `div` (b^l)) l+++-- Misc utilities to show integers and floats ++showSigned    :: Real a => (a -> ShowS) -> Int -> a -> ShowS+showSigned showPos p x | x < 0 = showParen (p > 6)+                                           (showChar '-' . showPos (-x))+                       | otherwise = showPos x++-- showInt is used for positive numbers only+showInt    :: Integral a => a -> ShowS+--showInt    :: Integral a => a -> String->String -- for hs2alfa+showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers"+            | otherwise =+              let (n',d) = quotRem n 10+                  r'     = chr (fromEnum '0' + fromIntegral d) : r+              in  if n' == 0 then r' else showInt n' r'+++readSigned :: (Real a) => ReadS a -> ReadS a+readSigned readPos = readParen False read'+                     where read' r  = read'' r +++                                      [(-x,t) | ("-",s) <- lex r,+                                                (x,t)   <- read'' s]+                           read'' r = [(n,s)  | (str,s) <- lex r,+                                                (n,"")  <- readPos str]+++-- readInt reads a string of digits using an arbitrary base.  +-- Leading minus signs must be handled elsewhere.++readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a+readInt radix isDig digToInt s =+   [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)+          | (ds,r) <- nonnull isDig s ]++-- Unsigned readers for various bases+readDec, readOct, readHex :: (Integral a) => ReadS a+readDec = readInt 10 isDigit digitToInt+readOct = readInt  8 isOctDigit digitToInt+readHex = readInt 16 isHexDigit digitToInt++showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showFloat      :: (RealFloat a) => a -> ShowS++showEFloat d x =  showString (formatRealFloat FFExponent d x)+showFFloat d x =  showString (formatRealFloat FFFixed d x)+showGFloat d x =  showString (formatRealFloat FFGeneric d x)+showFloat      =  showGFloat Nothing ++-- These are the format types.  This type is not exported.++data FFFormat = FFExponent | FFFixed | FFGeneric++formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String+formatRealFloat fmt decs x = s+  where base = 10+        s = if isNaN x then +                "NaN"+            else if isInfinite x then +                if x < 0 then "-Infinity" else "Infinity"+            else if x < 0 || isNegativeZero x then +                '-' : doFmt fmt (floatToDigits (toInteger base) (-x))+            else +                doFmt fmt (floatToDigits (toInteger base) x)+        doFmt fmt (is, e) =+            let ds = map intToDigit is+            in  case fmt of+                FFGeneric -> +                    doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)+                          (is, e)+--{ -+                FFExponent ->+                    case decs of+                    Nothing ->+                        case ds of+                         ['0'] -> "0.0e0"+                         [d]   -> d : ".0e" ++ show (e-1)+                         d:ds  -> d : '.' : ds ++ 'e':show (e-1)+                    Just dec ->+                        let dec' = max dec 1 in+                        case is of+                         [0] -> '0':'.':take dec' (repeat '0') ++ "e0"+                         _ ->+                          let (ei, is') = roundTo base (dec'+1) is+                              d:ds = map intToDigit+                                         (if ei > 0 then init is' else is')+                          in d:'.':ds  ++ "e" ++ show (e-1+ei)+                FFFixed ->+                    case decs of+                    Nothing ->+                        let f 0 s ds = mk0 s ++ "." ++ mk0 ds+                            f n s "" = f (n-1) (s++"0") ""+                            f n s (d:ds) = f (n-1) (s++[d]) ds+                            mk0 "" = "0"+                            mk0 s = s+                        in  f e "" ds+                    Just dec ->+                        let dec' = max dec 0 in+                        if e >= 0 then+                            let (ei, is') = roundTo base (dec' + e) is+                                (ls, rs) = splitAt (e+ei) (map intToDigit is')+                            in  (if null ls then "0" else ls) ++ +                                (if null rs then "" else '.' : rs)+                        else+                            let (ei, is') = roundTo base dec'+                                              (replicate (-e) 0 ++ is)+                                d : ds = map intToDigit+                                            (if ei > 0 then is' else 0:is')+                            in  d : '.' : ds+--}++roundTo :: Int -> Int -> [Int] -> (Int, [Int])+roundTo base d is = case f d is of+		     (x, is)+			 | x==0 -> (0, is)+			 | x==1 -> (1, 1 : is)+  where b2 = base `div` 2+        f n [] = (0, replicate n 0)+        f 0 (i:_) = (if i >= b2 then 1 else 0, [])+        f d (i:is) = +            let (c, ds) = f (d-1) is+                i' = c + i+            in  if i' == base then (1, 0:ds) else (0, i':ds)++--+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"+-- by R.G. Burger and R. K. Dybvig, in PLDI 96.+-- This version uses a much slower logarithm estimator.  It should be improved.++-- This function returns a list of digits (Ints in [0..base-1]) and an+-- exponent.++floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)++floatToDigits _ 0 = ([0], 0)+floatToDigits base x =+    let (f0, e0) = decodeFloat x+        (minExp0, _) = floatRange x+        p = floatDigits x+        b = floatRadix x+        minExp = minExp0 - p            -- the real minimum exponent+        -- Haskell requires that f be adjusted so denormalized numbers+        -- will have an impossibly low exponent.  Adjust for this.+        (f, e) = let n = minExp - e0+                 in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)++        (r, s, mUp, mDn) =+           if e >= 0 then+               let be = b^e in+               if f == b^(p-1) then+                   (f*be*b*2, 2*b, be*b, b)+               else+                   (f*be*2, 2, be, be)+           else+               if e > minExp && f == b^(p-1) then+                   (f*b*2, b^(-e+1)*2, b, 1)+               else+                   (f*2, b^(-e)*2, 1, 1)+        k = +            let k0 =+                    if b==2 && base==10 then+                        -- logBase 10 2 is slightly bigger than 3/10 so+                        -- the following will err on the low side.  Ignoring+                        -- the fraction will make it err even more.+                        -- Haskell promises that p-1 <= logBase b f < p.+                        (p - 1 + e0) * 3 `div` 10+                    else+                        ceiling ((log (fromInteger (f+1)::Double) + +                                 fromIntegral e * log (fromInteger b)) / +                                  log (fromInteger base))+                fixup n =+                    if n >= 0 then+                        if r + mUp <= expt base n * s then n else fixup (n+1)+                    else+                        if expt base (-n) * (r + mUp) <= s then n+                                                           else fixup (n+1)+            in  fixup k0++        gen ds rn sN mUpN mDnN =+            let (dn, rn') = (rn * base) `divMod` sN+                mUpN' = mUpN * base+                mDnN' = mDnN * base+            in  case (rn' < mDnN', rn' + mUpN' > sN) of+                (True,  False) -> dn : ds+                (False, True)  -> dn+1 : ds+                (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds+                (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'+        rds =+            if k >= 0 then+                gen [] r (s * expt base k) mUp mDn+            else+                let bk = expt base (-k)+                in  gen [] (r * bk) s (mUp * bk) (mDn * bk)+    in  (map fromIntegral (reverse rds), k)++++-- This floating point reader uses a less restrictive syntax for floating+-- point than the Haskell lexer.  The `.' is optional.++readFloat     :: (RealFloat a) => ReadS a+readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,+                                                       (k,t)   <- readExp s]+                 where readFix r = [(read (ds++ds'), length ds', t)+                                        | (ds,d) <- lexDigits r,+                                          (ds',t) <- lexFrac d ]++                       lexFrac ('.':ds) = lexDigits ds+                       lexFrac s        = [("",s)]        ++                       readExp (e:s) | e `elem` "eE" = readExp' s+                       readExp s                     = [(0,s)]++                       readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]+                       readExp' ('+':s) = readDec s+                       readExp' s       = readDec s++lexDigits        :: ReadS String +lexDigits        =  nonnull isDigit++nonnull          :: (Char -> Bool) -> ReadS String+nonnull p s      =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
+ misc/Prelude.hs view
@@ -0,0 +1,686 @@+module Prelude (+    module PreludeList, module PreludeText, module PreludeIO,+    module Prelude{-+    Bool(False, True),+    Maybe(Nothing, Just),+    Either(Left, Right),+    Ordering(LT, EQ, GT),+    Char, String, Int, Integer, Float, Double, Rational, IO,++--      These built-in types are defined in the Prelude, but+--      are denoted by built-in syntax, and cannot legally+--      appear in an export list.+--  List type:+     []((:), [])+--  Tuple types: (,), (,,), etc.+--  Trivial type: ()+--  Functions: (->)++    Eq((==), (/=)),+    Ord(compare, (<), (<=), (>=), (>), max, min),+    Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,+         enumFromTo, enumFromThenTo),+    Bounded(minBound, maxBound),+    Num((+), (-), (*), negate, abs, signum, fromInteger),+    Real(toRational),+    Integral(quot, rem, div, mod, quotRem, divMod, toInteger),+    Fractional((/), recip, fromRational),+    Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,+             asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),+    RealFrac(properFraction, truncate, round, ceiling, floor),+    RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,+              encodeFloat, exponent, significand, scaleFloat, isNaN,+              isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2),+    Monad((>>=), (>>), return, fail),+    Functor(fmap),+    mapM, mapM_, sequence, sequence_, (=<<),+    maybe, either,+    (&&), (||), not, otherwise,+    subtract, even, odd, gcd, lcm, (^), (^^),+    fromIntegral, realToFrac,+    fst, snd, curry, uncurry, id, const, (.), flip, ($), until,+    asTypeOf, error, undefined,+    seq, ($!)-}+  ) where++import PreludeBuiltin  -- Contains all `prim' values+import PreludeList+import PreludeText+import PreludeIO(FilePath, IOError, ioError, userError, catch,+		 putChar, putStr, putStrLn, print,+		 getChar, getLine, getContents, interact,+		 readFile, writeFile, appendFile, readIO, readLn)+import Ratio( Ratio )+import Ix++type Rational =  Ratio Integer -- the type checker refers to Prelude.Rational!!!++infixr 9  .+infixr 8  ^, ^^, **+infixl 7  *, /, `quot`, `rem`, `div`, `mod`+infixl 6  +, -++-- The (:) operator is built-in syntax, and cannot legally be given+-- a fixity declaration; but its fixity is given by:+infixr 5  :++infix  4  ==, /=, <, <=, >=, >+infixr 3  &&+infixr 2  ||+infixl 1  >>, >>=+infixr 1  =<<+infixr 0  $, $!, `seq`++-- Standard types, classes, instances and related functions++-- Equality and Ordered classes++class  Eq a  where+    (==), (/=)       :: a -> a -> Bool++        -- Minimal complete definition:+        --      (==) or (/=)+    x /= y           =  not (x == y)+    x == y           =  not (x /= y)++class  (Eq a) => Ord a  where+    compare              :: a -> a -> Ordering+    (<), (<=), (>=), (>) :: a -> a -> Bool+    max, min             :: a -> a -> a++        -- Minimal complete definition:+        --      (<=) or compare+        -- Using compare can be more efficient for complex types.+    compare x y+         | x == y    =  EQ+         | x <= y    =  LT+         | otherwise =  GT++    x <= y           =  compare x y /= GT+    x <  y           =  compare x y == LT+    x >= y           =  compare x y /= LT+    x >  y           =  compare x y == GT++-- note that (min x y, max x y) = (x,y) or (y,x)+    max x y+         | x <= y    =  y+         | otherwise =  x+    min x y+         | x <= y    =  x+         | otherwise =  y++-- Enumeration and Bounded classes++class  Enum a  where+    succ, pred       :: a -> a+    toEnum           :: Int -> a+    fromEnum         :: a -> Int+    enumFrom         :: a -> [a]             -- [n..]+    enumFromThen     :: a -> a -> [a]        -- [n,n'..]+    enumFromTo       :: a -> a -> [a]        -- [n..m]+    enumFromThenTo   :: a -> a -> a -> [a]   -- [n,n'..m]++        -- Minimal complete definition:+        --      toEnum, fromEnum+--+-- NOTE: these default methods only make sense for types+--   that map injectively into Int using fromEnum+--  and toEnum.+    succ             =  toEnum . (+1) . fromEnum+    pred             =  toEnum . (subtract 1) . fromEnum+    enumFrom x       =  map toEnum [fromEnum x ..]+    enumFromTo x y   =  map toEnum [fromEnum x .. fromEnum y]+    enumFromThen x y =  map toEnum [fromEnum x, fromEnum y ..]+    enumFromThenTo x y z =+                        map toEnum [fromEnum x, fromEnum y .. fromEnum z]++class  Bounded a  where+    minBound         :: a+    maxBound         :: a++-- Numeric classes++class  (Eq a, Show a) => Num a  where+    (+), (-), (*)    :: a -> a -> a+    negate           :: a -> a+    abs, signum      :: a -> a+    fromInteger      :: Integer -> a++        -- Minimal complete definition:+        --      All, except negate or (-)+    x - y            =  x + negate y+    negate x         =  0 - x++class  (Num a, Ord a) => Real a  where+    toRational       ::  a -> Rational++class  (Real a, Enum a) => Integral a  where+    quot, rem        :: a -> a -> a+    div, mod         :: a -> a -> a+    quotRem, divMod  :: a -> a -> (a,a)+    toInteger        :: a -> Integer++        -- Minimal complete definition:+        --      quotRem, toInteger+    n `quot` d       =  q  where (q,r) = quotRem n d+    n `rem` d        =  r  where (q,r) = quotRem n d+    n `div` d        =  q  where (q,r) = divMod n d+    n `mod` d        =  r  where (q,r) = divMod n d+    divMod n d       =  if signum r == - signum d then (q-1, r+d) else qr+                        where qr@(q,r) = quotRem n d++class  (Num a) => Fractional a  where+    (/)              :: a -> a -> a+    recip            :: a -> a+    fromRational     :: Rational -> a++        -- Minimal complete definition:+        --      fromRational and (recip or (/))+    recip x          =  1 / x+    x / y            =  x * recip y++class  (Fractional a) => Floating a  where+    pi                  :: a+    exp, log, sqrt      :: a -> a+    (**), logBase       :: a -> a -> a+    sin, cos, tan       :: a -> a+    asin, acos, atan    :: a -> a+    sinh, cosh, tanh    :: a -> a+    asinh, acosh, atanh :: a -> a++        -- Minimal complete definition:+        --      pi, exp, log, sin, cos, sinh, cosh+        --      asin, acos, atan+        --      asinh, acosh, atanh+    x ** y           =  exp (log x * y)+    logBase x y      =  log y / log x+    sqrt x           =  x ** 0.5+    tan  x           =  sin  x / cos  x+    tanh x           =  sinh x / cosh x++class  (Real a, Fractional a) => RealFrac a  where+    properFraction   :: (Integral b) => a -> (b,a)+    truncate, round  :: (Integral b) => a -> b+    ceiling, floor   :: (Integral b) => a -> b++        -- Minimal complete definition:+        --      properFraction+    truncate x       =  m  where (m,_) = properFraction x++    round x          =  let (n,r) = properFraction x+                            m     = if r < 0 then n - 1 else n + 1+                          in case signum (abs r - 0.5) of+                                -1 -> n+                                0  -> if even n then n else m+                                1  -> m++    ceiling x        =  if r > 0 then n + 1 else n+                        where (n,r) = properFraction x++    floor x          =  if r < 0 then n - 1 else n+                        where (n,r) = properFraction x++class  (RealFrac a, Floating a) => RealFloat a  where+    floatRadix       :: a -> Integer+    floatDigits      :: a -> Int+    floatRange       :: a -> (Int,Int)+    decodeFloat      :: a -> (Integer,Int)+    encodeFloat      :: Integer -> Int -> a+    exponent         :: a -> Int+    significand      :: a -> a+    scaleFloat       :: Int -> a -> a+    isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE+                     :: a -> Bool+    atan2            :: a -> a -> a++        -- Minimal complete definition:+        --      All except exponent, significand,+        --                 scaleFloat, atan2+    exponent x       =  if m == 0 then 0 else n + floatDigits x+                        where (m,n) = decodeFloat x++    significand x    =  encodeFloat m (- floatDigits x)+                        where (m,_) = decodeFloat x++    scaleFloat k x   =  encodeFloat m (n+k)+                        where (m,n) = decodeFloat x++    atan2 y x+      | x>0           =  atan (y/x)+      | x==0 && y>0   =  pi/2+      | x<0  && y>0   =  pi + atan (y/x)+      |(x<=0 && y<0)  ||+       (x<0 && isNegativeZero y) ||+       (isNegativeZero x && isNegativeZero y)+                      = -atan2 (-y) x+      | y==0 && (x<0 || isNegativeZero x)+                      =  pi    -- must be after the previous test on zero y+      | x==0 && y==0  =  y     -- must be after the other double zero tests+      | otherwise     =  x + y -- x or y is a NaN, return a NaN (via +)++-- Numeric functions++subtract         :: (Num a) => a -> a -> a+subtract         =  flip (-)++even, odd        :: (Integral a) => a -> Bool+even n           =  n `rem` 2 == 0+odd n            =  not (even n)++gcd              :: (Integral a) => a -> a -> a+gcd 0 0          =  error "Prelude.gcd: gcd 0 0 is undefined"+gcd x y          =  gcd' (abs x) (abs y)+                    where gcd' x 0  =  x+                          gcd' x y  =  gcd' y (x `rem` y)++lcm              :: (Integral a) => a -> a -> a+lcm _ 0          =  0+lcm 0 _          =  0+lcm x y          =  abs ((x `quot` (gcd x y)) * y)++(^)              :: (Num a, Integral b) => a -> b -> a+x ^ 0            =  1+x ^ n | n > 0    =  f x (n-1) x+                    where f _ 0 y = y+                          f x n y = if n==0 then y else g x n  where+                                    g x n | even n  = g (x*x) (n `quot` 2)+                                          | otherwise = f x (n-1) (x*y)+_ ^ _            = error "Prelude.^: negative exponent"++(^^)             :: (Fractional a, Integral b) => a -> b -> a+x ^^ n           =  if n >= 0 then x^n else recip (x^(-n))++fromIntegral     :: (Integral a, Num b) => a -> b+fromIntegral     =  fromInteger . toInteger++realToFrac     :: (Real a, Fractional b) => a -> b+realToFrac      =  fromRational . toRational++-- Monadic classes++class  Functor f  where+    fmap              :: (a -> b) -> f a -> f b++class  Monad m  where+    (>>=)  :: m a -> (a -> m b) -> m b+    (>>)   :: m a -> m b -> m b+    return :: a -> m a+    fail   :: String -> m a++        -- Minimal complete definition:+        --      (>>=), return+    m >> k  =  m >>= \ x -> k+    fail s  = error s++sequence       :: Monad m => [m a] -> m [a]+sequence       =  foldr mcons (return [])+                    where mcons p q = p >>= \x -> q >>= \y -> return (x:y)++sequence_      :: Monad m => [m a] -> m ()+sequence_      =  foldr (>>) (return ())++-- The xxxM functions take list arguments, but lift the function or+-- list element to a monad type++mapM             :: Monad m => (a -> m b) -> [a] -> m [b]+mapM f as        =  sequence (map f as)++mapM_            :: Monad m => (a -> m b) -> [a] -> m ()+mapM_ f as       =  sequence_ (map f as)++(=<<)            :: Monad m => (a -> m b) -> m a -> m b+f =<< x          =  x >>= f++-- Trivial type++data  ()  =  ()  deriving (Eq, Ord, Enum, Bounded, Ix)++-- Function type++--data a -> b  -- No constructor for functions is exported.+data (->) a b++-- identity function++id               :: a -> a+id x             =  x++-- constant function++const            :: a -> b -> a+const x _        =  x++-- function composition++(.)              :: (b -> c) -> (a -> b) -> a -> c+f . g            =  \ x -> f (g x)++-- flip f  takes its (first) two arguments in the reverse order of f.++flip             :: (a -> b -> c) -> b -> a -> c+flip f x y       =  f y x++seq = primSeq++-- right-associating infix application operators+-- (useful in continuation-passing style)++($), ($!) :: (a -> b) -> a -> b+f $  x    =  f x+f $! x    =  x `seq` f x++-- Boolean type++data  Bool  =  False | True    deriving (Eq, Ord, Enum, Read, Show, Bounded, Ix)++-- Boolean functions++(&&), (||)       :: Bool -> Bool -> Bool+True  && x       =  x+False && _       =  False+True  || _       =  True+False || x       =  x+++not              :: Bool -> Bool+not True         =  False+not False        =  True++otherwise        :: Bool+otherwise        =  True++-- Character type++data Char -- = ... 'a' | 'b' ... -- 2^16 unicode values++instance  Eq Char  where+    c == c'          =  fromEnum c == fromEnum c'++instance  Ord Char  where+    c <= c'          =  fromEnum c <= fromEnum c'++instance  Enum Char  where+    toEnum            = primIntToChar+    fromEnum          = primCharToInt+    enumFrom c        = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]+    enumFromThen c c' = map toEnum [fromEnum c, fromEnum c' .. fromEnum lastChar]+                      where lastChar :: Char+                            lastChar | c' < c    = minBound+                                     | otherwise = maxBound++instance  Bounded Char  where+    minBound            =  '\0'+    maxBound            =  primUnicodeMaxChar++type  String = [Char]++-- Maybe type++data  Maybe a  =  Nothing | Just a      deriving (Eq, Ord, Read, Show)++maybe              :: b -> (a -> b) -> Maybe a -> b+maybe n f Nothing  =  n+maybe n f (Just x) =  f x++instance  Functor Maybe  where+    fmap f Nothing    =  Nothing+    fmap f (Just x)   =  Just (f x)+++instance  Monad Maybe  where+    (Just x) >>= k   =  k x+    Nothing  >>= k   =  Nothing+    return           =  Just+    fail s           =  Nothing++-- Either type++data  Either a b  =  Left a | Right b   deriving (Eq, Ord, Read, Show)++either               :: (a -> c) -> (b -> c) -> Either a b -> c+either f g (Left x)  =  f x+either f g (Right y) =  g y++-- IO type++data  IO a -- abstract++instance  Functor IO where+   fmap f x           =  x >>= (return . f)++instance Monad IO where+   (>>=)  = undefined -- ...+   return = undefined -- ...+   fail s = ioError (userError s)++-- Ordering type++data  Ordering  =  LT | EQ | GT+          deriving (Eq, Ord, Enum, Read, Show, Bounded, Ix)+--instance Eq Ordering++-- For use in derived Ord instances:+lexOrder EQ o = o+lexOrder o  _ = o++-- Standard numeric types.  The data declarations for these types cannot+-- be expressed directly in Haskell since the constructor lists would be+-- far too large.++data  Int  -- =  minBound ... -1 | 0 | 1 ... maxBound++instance  Eq       Int  where (==) = primIntEq+instance  Ord      Int  where (<=) = primIntLte+instance  Num      Int  where+  (+) = primIntAdd; (-) = primIntSub; (*) = primIntMul+  negate = primIntNegate; abs = primIntAbs; signum = primIntSignum+  fromInteger = primInteger2Int++instance  Real     Int  --where ...++instance  Integral Int  where+   toInteger = primInt2Integer+   n `quotRem` d = (n `primIntQuot` d,n `primIntRem` d)++instance  Enum     Int  where toEnum = id; fromEnum = id+  +instance  Bounded  Int  --where ...++data  Integer  -- =  ... -1 | 0 | 1 ...++instance  Eq       Integer  where (==) = primIntegerEq+instance  Ord      Integer  where (<=) = primIntegerLte+instance  Num      Integer  where+  (+) = primIntegerAdd; (-) = primIntegerSub; (*) = primIntegerMul+  negate = primIntegerNegate; abs = primIntegerAbs; signum = primIntegerSignum+  fromInteger = id++instance  Enum     Integer  where+  succ x = x+1+  pred x = x-1+  toEnum = primInt2Integer+  fromEnum = fromInteger+  enumFrom x = x:enumFrom (succ x)+  enumFromTo x y = if x<=y then x:enumFromTo (succ x) y else []++instance  Real     Integer  --where ...+instance  Integral Integer  where+   toInteger = id+   n `quotRem` d = (n `primIntegerQuot` d,n `primIntegerRem` d)++data  Float++instance  Eq         Float  where (==) = undefined -- avoid looping+instance  Ord        Float  where (<=) = undefined -- avoid looping+instance  Num        Float  --where ...+instance  Real       Float  --where ...+instance  Fractional Float  --where ...+instance  Floating   Float  --where ...+instance  RealFrac   Float  --where ...+instance  RealFloat  Float  --where ...++data  Double++instance  Eq         Double  where (==) = undefined -- avoid looping+instance  Ord        Double  where (<=) = undefined -- avoid looping+instance  Num        Double  --where ...+instance  Real       Double  --where ...+instance  Fractional Double  --where ...+instance  Floating   Double  --where ...+instance  RealFrac   Double  --where ...+instance  RealFloat  Double  --where ...++-- The Enum instances for Floats and Doubles are slightly unusual.+-- The `toEnum' function truncates numbers to Int.  The definitions+-- of enumFrom and enumFromThen allow floats to be used in arithmetic+-- series: [0,0.1 .. 0.95].  However, roundoff errors make these somewhat+-- dubious.  This example may have either 10 or 11 elements, depending on+-- how 0.1 is represented.++instance  Enum Float  where+    succ x           =  x+1+    pred x           =  x-1+    toEnum           =  fromIntegral+    fromEnum         =  fromInteger . truncate   -- may overflow+    enumFrom         =  numericEnumFrom+    enumFromThen     =  numericEnumFromThen+    enumFromTo       =  numericEnumFromTo+    enumFromThenTo   =  numericEnumFromThenTo++instance  Enum Double  where+    succ x           =  x+1+    pred x           =  x-1+    toEnum           =  fromIntegral+    fromEnum         =  fromInteger . truncate   -- may overflow+    enumFrom         =  numericEnumFrom+    enumFromThen     =  numericEnumFromThen+    enumFromTo       =  numericEnumFromTo+    enumFromThenTo   =  numericEnumFromThenTo+++numericEnumFrom         :: (Fractional a) => a -> [a]+numericEnumFromThen     :: (Fractional a) => a -> a -> [a]+numericEnumFromTo       :: (Fractional a, Ord a) => a -> a -> [a]+numericEnumFromThenTo   :: (Fractional a, Ord a) => a -> a -> a -> [a]++numericEnumFrom         =  iterate (+1)+numericEnumFromThen n m =  iterate (+(m-n)) n+numericEnumFromTo n m   =  takeWhile (<= m+1/2) (numericEnumFrom n)+numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')+                             where+                               p | n' > n    = (<= m + (n'-n)/2)+                                 | otherwise = (>= m + (n'-n)/2)++-- Lists++-- This data declaration is not legal Haskell+-- but it indicates the idea++data [a] =  [] | a : [a]  deriving (Eq, Ord)+--instance Eq a => Eq [a]+--instance Ord a => Ord [a]++instance Functor [] where+    fmap = map++instance  Monad []  where+    m >>= k          = concat (map k m)+    return x         = [x]+    fail s           = []++-- Tuples (supported upto size 15, as required by the Haskell 98 report)++data  (a,b)+   =  (,) a b+   deriving (Eq, Ord, Bounded) -- Show/Read in PreludeText, Ix in Ix+data  (a,b,c)+   =  (,,) a b c+   deriving (Eq, Ord, Bounded, Show, Read, Ix)+data  (a,b,c,d)+   =  (,,,) a b c d+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e)+   =  (,,,,) a b c d e+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f)+   =  (,,,,,) a b c d e f+  deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g)+   =  (,,,,,,) a b c d e f g+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h)+   =  (,,,,,,,) a b c d e f g h+  deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i)+   =  (,,,,,,,,) a b c d e f g h i+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j)+   =  (,,,,,,,,,) a b c d e f g h i j+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j,k)+   =  (,,,,,,,,,,) a b c d e f g h i j k+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j,k,l)+   =  (,,,,,,,,,,,) a b c d e f g h i j k l+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j,k,l,m)+   =  (,,,,,,,,,,,,) a b c d e f g h i j k l m+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j,k,l,m,n)+   =  (,,,,,,,,,,,,,) a b c d e f g h i j k l m n+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)+   =  (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o+   deriving (Eq, Ord, Bounded, Show, Read)+++-- component projections for pairs:+-- (NB: not provided for triples, quadruples, etc.)++fst              :: (a,b) -> a+fst (x,y)        =  x++snd              :: (a,b) -> b+snd (x,y)        =  y++-- curry converts an uncurried function to a curried function;+-- uncurry converts a curried function to a function on pairs.++curry            :: ((a, b) -> c) -> a -> b -> c+curry f x y      =  f (x, y)++uncurry          :: (a -> b -> c) -> ((a, b) -> c)+uncurry f p      =  f (fst p) (snd p)++-- Misc functions++-- until p f  yields the result of applying f until p holds.++until            :: (a -> Bool) -> (a -> a) -> a -> a+until p f x+     | p x       =  x+     | otherwise =  until p f (f x)++-- asTypeOf is a type-restricted version of const.  It is usually used+-- as an infix operator, and its typing forces its first argument+-- (which is usually overloaded) to have the same type as the second.++asTypeOf         :: a -> a -> a+asTypeOf         =  const++-- error stops execution and displays an error message++error            :: String -> a+error            =  primError++-- It is expected that compilers will recognize this and insert error+-- messages that are more appropriate to the context in which undefined+-- appears.++undefined        :: a+undefined        =  error "Prelude.undefined"++{-P:+-- For the P-Logic extension:+data Prop+-}
+ misc/PreludeBuiltin.hs view
@@ -0,0 +1,42 @@+module PreludeBuiltin where++foreign import primIntToChar   :: Int -> Char+foreign import primCharToInt   :: Char -> Int+foreign import primInteger2Int :: Integer -> Int+foreign import primUnicodeMaxChar :: Char -- = '\xffff'++foreign import primIntEq       :: Int -> Int -> Bool+foreign import primIntLte      :: Int -> Int -> Bool++foreign import primIntAdd      :: Int -> Int -> Int+foreign import primIntSub      :: Int -> Int -> Int+foreign import primIntMul      :: Int -> Int -> Int+foreign import primIntQuot     :: Int -> Int -> Int+foreign import primIntRem      :: Int -> Int -> Int+foreign import primIntNegate   :: Int -> Int+foreign import primIntAbs      :: Int -> Int+foreign import primIntSignum   :: Int -> Int++foreign import primError       :: String -> a++foreign import primSeq         :: a -> b -> b++primIntQuotRem x y = (x `primIntQuot` y,x `primIntRem` y)++primCharEq c c' = primCharToInt c `primIntEq` primCharToInt c'+primCharLte c c' = primCharToInt c `primIntLte` primCharToInt c'++foreign import primInteger2Int     :: Integer -> Int+foreign import primInt2Integer     :: Int -> Integer++foreign import primIntegerLte      :: Integer -> Integer -> Bool+foreign import primIntegerEq       :: Integer -> Integer -> Bool++foreign import primIntegerAdd      :: Integer -> Integer -> Integer+foreign import primIntegerSub      :: Integer -> Integer -> Integer+foreign import primIntegerMul      :: Integer -> Integer -> Integer+foreign import primIntegerQuot     :: Integer -> Integer -> Integer+foreign import primIntegerRem      :: Integer -> Integer -> Integer+foreign import primIntegerNegate   :: Integer -> Integer+foreign import primIntegerAbs      :: Integer -> Integer+foreign import primIntegerSignum   :: Integer -> Integer
+ misc/PreludeIO.hs view
@@ -0,0 +1,84 @@+module PreludeIO {-(+    FilePath, IOError(..), ioError, userError, catch,+    putChar, putStr, putStrLn, print,+    getChar, getLine, getContents, interact,+    readFile, writeFile, appendFile, readIO, readLn+  )-} where++import PreludeBuiltin++type  FilePath = String++data IOErrorKind+  = EOFError          +  | OtherError+  | UserError+  | AlreadyExistsError +  | DoesNotExistError +  | AlreadyInUseError +  | FullError         +  | IllegalOperation  +  | PermissionError   +  deriving (Eq)+--instance Eq IOErrorKind++-- The internals of this type are system dependent:+data IOError = IOE IOErrorKind String --deriving (Eq)++instance  Show IOError  --where ...+instance  Eq IOError  --where ...++ioError          ::  IOError -> IO a+ioError          =   undefined--primIOError++userError        ::  String -> IOError+userError        =   IOE UserError++catch            ::  IO a -> (IOError -> IO a) -> IO a+catch            =   undefined--primCatch++putChar          :: Char -> IO ()+putChar          =  undefined--primPutChar++putStr           :: String -> IO ()+putStr s         =  mapM_ putChar s++putStrLn         :: String -> IO ()+putStrLn s       =  do putStr s+                       putStr "\n"++print            :: Show a => a -> IO ()+print x          =  putStrLn (show x)++getChar          :: IO Char+getChar          =  undefined--primGetChar++getLine          :: IO String+getLine          =  do c <- getChar+                       if c == '\n' then return "" else+                          do s <- getLine+                             return (c:s)+++foreign import getContents      :: IO String+foreign import readFile         :: FilePath -> IO String+foreign import writeFile        :: FilePath -> String -> IO ()+foreign import appendFile       :: FilePath -> String -> IO ()++interact         ::  (String -> String) -> IO ()+interact f       =  do s <- getContents+                       putStr (f s)+++  -- raises an exception instead of an error++readIO   :: Read a => String -> IO a+readIO s =  case [x | (x,t) <- reads s, ("","") <- lex t] of+              [x] -> return x+              []  -> ioError (userError "Prelude.readIO: no parse")+              _   -> ioError (userError "Prelude.readIO: ambiguous parse")++readLn           :: Read a => IO a+readLn           =  do l <- getLine+                       r <- readIO l+                       return r
+ misc/PreludeList.hs view
@@ -0,0 +1,316 @@++-- Standard list functions++module PreludeList (+    map, (++), filter, concat,+    head, last, tail, init, null, length, (!!),+    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,+    iterate, repeat, replicate, cycle,+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    lines, words, unlines, unwords, reverse, and, or,+    any, all, elem, notElem, lookup,+    sum, product, maximum, minimum, concatMap,+    zip, zip3, zipWith, zipWith3, unzip, unzip3)+  where++import qualified Char(isSpace)++infixl 9  !!+infixr 5  +++infix  4  `elem`, `notElem`++-- Map and append++map :: (a -> b) -> [a] -> [b]+map f []     = []+map f (x:xs) = f x : map f xs++(++) :: [a] -> [a] -> [a]+[]     ++ ys = ys+(x:xs) ++ ys = x : (xs ++ ys)++filter :: (a -> Bool) -> [a] -> [a]+filter p [] = []+filter p (x:xs) | p x       = x : filter p xs+                | otherwise = filter p xs++concat :: [[a]] -> [a]+concat xss = foldr (++) [] xss++-- head and tail extract the first element and remaining elements,+-- respectively, of a list, which must be non-empty.  last and init+-- are the dual functions working from the end of a finite list,+-- rather than the beginning.++head             :: [a] -> a+head (x:_)       =  x+head []          =  error "Prelude.head: empty list"++last             :: [a] -> a+last [x]         =  x+last (_:xs)      =  last xs+last []          =  error "Prelude.last: empty list"++tail             :: [a] -> [a]+tail (_:xs)      =  xs+tail []          =  error "Prelude.tail: empty list"++init             :: [a] -> [a]+init [x]         =  []+init (x:xs)      =  x : init xs+init []          =  error "Prelude.init: empty list"++null             :: [a] -> Bool+null []          =  True+null (_:_)       =  False++-- length returns the length of a finite list as an Int.++length           :: [a] -> Int+length []        =  0+length (_:l)     =  1 + length l++-- List index (subscript) operator, 0-origin++(!!)                :: [a] -> Int -> a+xs     !! n | n < 0 =  error "Prelude.!!: negative index"+[]     !! _         =  error "Prelude.!!: index too large"+(x:_)  !! n | n==0  =  x+(_:xs) !! n         =  xs !! (n-1)++-- foldl, applied to a binary operator, a starting value (typically the+-- left-identity of the operator), and a list, reduces the list using+-- the binary operator, from left to right:+--  foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn+-- foldl1 is a variant that has no starting value argument, and  thus must+-- be applied to non-empty lists.  scanl is similar to foldl, but returns+-- a list of successive reduced values from the left:+--      scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]+-- Note that  last (scanl f z xs) == foldl f z xs.+-- scanl1 is similar, again without the starting element:+--      scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]++foldl            :: (a -> b -> a) -> a -> [b] -> a+foldl f z []     =  z+foldl f z (x:xs) =  foldl f (f z x) xs++foldl1           :: (a -> a -> a) -> [a] -> a+foldl1 f (x:xs)  =  foldl f x xs+foldl1 _ []      =  error "Prelude.foldl1: empty list"++scanl            :: (a -> b -> a) -> a -> [b] -> [a]+scanl f q xs     =  q : (case xs of+                            []   -> []+                            x:xs -> scanl f (f q x) xs)++scanl1           :: (a -> a -> a) -> [a] -> [a]+scanl1 f (x:xs)  =  scanl f x xs+scanl1 _ []      =  []++-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the+-- above functions.++foldr            :: (a -> b -> b) -> b -> [a] -> b+foldr f z []     =  z+foldr f z (x:xs) =  f x (foldr f z xs)++foldr1           :: (a -> a -> a) -> [a] -> a+foldr1 f [x]     =  x+foldr1 f (x:xs)  =  f x (foldr1 f xs)+foldr1 _ []      =  error "Prelude.foldr1: empty list"++scanr             :: (a -> b -> b) -> b -> [a] -> [b]+scanr f q0 []     =  [q0]+scanr f q0 (x:xs) =  f x q : qs+                     where qs@(q:_) = scanr f q0 xs++scanr1          :: (a -> a -> a) -> [a] -> [a]+scanr1 f []     =  []+scanr1 f [x]    =  [x]+scanr1 f (x:xs) =  f x q : qs+                   where qs@(q:_) = scanr1 f xs++-- iterate f x returns an infinite list of repeated applications of f to x:+-- iterate f x == [x, f x, f (f x), ...]++iterate          :: (a -> a) -> a -> [a]+iterate f x      =  x : iterate f (f x)++-- repeat x is an infinite list, with x the value of every element.++repeat           :: a -> [a]+repeat x         =  xs where xs = x:xs++-- replicate n x is a list of length n with x the value of every element++replicate        :: Int -> a -> [a]+replicate n x    =  take n (repeat x)++-- cycle ties a finite list into a circular one, or equivalently,+-- the infinite repetition of the original list.  It is the identity+-- on infinite lists.++cycle            :: [a] -> [a]+cycle []         =  error "Prelude.cycle: empty list"+cycle xs         =  xs' where xs' = xs ++ xs'++-- take n, applied to a list xs, returns the prefix of xs of length n,+-- or xs itself if n > length xs.  drop n xs returns the suffix of xs+-- after the first n elements, or [] if n > length xs.  splitAt n xs+-- is equivalent to (take n xs, drop n xs).++take                   :: Int -> [a] -> [a]+take n _      | n <= 0 =  []+take _ []              =  []+take n (x:xs)          =  x : take (n-1) xs++drop                   :: Int -> [a] -> [a]+drop n xs     | n <= 0 =  xs+drop _ []              =  []+drop n (_:xs)          =  drop (n-1) xs++splitAt                  :: Int -> [a] -> ([a],[a])+splitAt n xs             =  (take n xs, drop n xs)++-- takeWhile, applied to a predicate p and a list xs, returns the longest+-- prefix (possibly empty) of xs of elements that satisfy p.  dropWhile p xs+-- returns the remaining suffix.  span p xs is equivalent to+-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.++takeWhile               :: (a -> Bool) -> [a] -> [a]+takeWhile p []          =  []+takeWhile p (x:xs)+            | p x       =  x : takeWhile p xs+            | otherwise =  []++dropWhile               :: (a -> Bool) -> [a] -> [a]+dropWhile p []          =  []+dropWhile p xs@(x:xs')+            | p x       =  dropWhile p xs'+            | otherwise =  xs++span, break             :: (a -> Bool) -> [a] -> ([a],[a])+span p []            = ([],[])+span p xs@(x:xs')+            | p x       =  (x:ys,zs)+            | otherwise =  ([],xs)+                           where (ys,zs) = span p xs'++break p                 =  span (not . p)++-- lines breaks a string up into a list of strings at newline characters.+-- The resulting strings do not contain newlines.  Similary, words+-- breaks a string up into a list of words, which were delimited by+-- white space.  unlines and unwords are the inverse operations.+-- unlines joins lines with terminating newlines, and unwords joins+-- words with separating spaces.++lines            :: String -> [String]+lines ""         =  []+lines s          =  let (l, s') = break (== '\n') s+                      in  l : case s' of+                                []      -> []+                                (_:s'') -> lines s''++words            :: String -> [String]+words s          =  case dropWhile Char.isSpace s of+                      "" -> []+                      s' -> w : words s''+                            where (w, s'') = break Char.isSpace s'++unlines          :: [String] -> String+unlines          =  concatMap (++ "\n")++unwords          :: [String] -> String+unwords []       =  ""+unwords ws       =  foldr1 (\w s -> w ++ ' ':s) ws++-- reverse xs returns the elements of xs in reverse order.  xs must be finite.++reverse          :: [a] -> [a]+reverse          =  foldl (flip (:)) []++-- and returns the conjunction of a Boolean list.  For the result to be+-- True, the list must be finite; False, however, results from a False+-- value at a finite index of a finite or infinite list.  or is the+-- disjunctive dual of and.++and, or          :: [Bool] -> Bool+and              =  foldr (&&) True+or               =  foldr (||) False++-- Applied to a predicate and a list, any determines if any element+-- of the list satisfies the predicate.  Similarly, for all.++any, all         :: (a -> Bool) -> [a] -> Bool+any p            =  or . map p+all p            =  and . map p++-- elem is the list membership predicate, usually written in infix form,+-- e.g., x `elem` xs.  notElem is the negation.++elem, notElem    :: (Eq a) => a -> [a] -> Bool+elem x           =  any (== x)+notElem x        =  all (/= x)++-- lookup key assocs looks up a key in an association list.++lookup           :: (Eq a) => a -> [(a,b)] -> Maybe b+lookup key []    =  Nothing+lookup key ((x,y):xys)+    | key == x   =  Just y+    | otherwise  =  lookup key xys++-- sum and product compute the sum or product of a finite list of numbers.++sum, product     :: (Num a) => [a] -> a+sum              =  foldl (+) 0+product          =  foldl (*) 1++-- maximum and minimum return the maximum or minimum value from a list,+-- which must be non-empty, finite, and of an ordered type.++maximum, minimum :: (Ord a) => [a] -> a+maximum []       =  error "Prelude.maximum: empty list"+maximum xs       =  foldl1 max xs++minimum []       =  error "Prelude.minimum: empty list"+minimum xs       =  foldl1 min xs++concatMap        :: (a -> [b]) -> [a] -> [b]+concatMap f      =  concat . map f++-- zip takes two lists and returns a list of corresponding pairs.  If one+-- input list is short, excess elements of the longer list are discarded.+-- zip3 takes three lists and returns a list of triples.  Zips for larger+-- tuples are in the List library++zip              :: [a] -> [b] -> [(a,b)]+zip              =  zipWith (,)++zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]+zip3             =  zipWith3 (,,)++-- The zipWith family generalises the zip family by zipping with the+-- function given as the first argument, instead of a tupling function.+-- For example, zipWith (+) is applied to two lists to produce the list+-- of corresponding sums.++zipWith          :: (a->b->c) -> [a]->[b]->[c]+zipWith z (a:as) (b:bs)+                 =  z a b : zipWith z as bs+zipWith _ _ _    =  []++zipWith3         :: (a->b->c->d) -> [a]->[b]->[c]->[d]+zipWith3 z (a:as) (b:bs) (c:cs)+                 =  z a b c : zipWith3 z as bs cs+zipWith3 _ _ _ _ =  []++-- unzip transforms a list of pairs into a pair of lists.++unzip            :: [(a,b)] -> ([a],[b])+unzip            =  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])++unzip3           :: [(a,b,c)] -> ([a],[b],[c])+unzip3           =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))+                          ([],[],[])
+ misc/PreludeText.hs view
@@ -0,0 +1,230 @@+module PreludeText {-(+    ReadS, ShowS,+    Read(readsPrec, readList),+    Show(showsPrec, showList),+    reads, shows, show, read, lex,+    showChar, showString, readParen, showParen )-} where++-- The instances of Read and Show for+-- Bool, Char, Maybe, Either, Ordering+-- are done via "deriving" clauses in Prelude.hs++import Char(isSpace, isAlpha, isDigit, isAlphaNum,+            showLitChar, readLitChar, lexLitChar)++import Numeric(showSigned, showInt, readSigned, readDec, showFloat,+               readFloat, lexDigits)++type  ReadS a  = String -> [(a,String)]++type  ShowS    = String -> String++class  Read a  where+    readsPrec        :: Int -> ReadS a+    readList         :: ReadS [a]++-- Minimal complete definition:+-- readsPrec+    readList         = readParen False (\r -> [pr | ("[",s)  <- lex r,+                                                    pr       <- readl s])+                       where readl  s = [([],t)   | ("]",t)  <- lex s] +++                                        [(x:xs,u) | (x,t)    <- reads s,+                                                    (xs,u)   <- readl' t]+                             readl' s = [([],t)   | ("]",t)  <- lex s] +++                                        [(x:xs,v) | (",",t)  <- lex s,+                                                    (x,u)    <- reads t,+                                                    (xs,v)   <- readl' u]++class  Show a  where+    showsPrec        :: Int -> a -> ShowS+    show             :: a -> String+    showList         :: [a] -> ShowS++-- Mimimal complete definition:+-- show or showsPrec+    showsPrec _ x s   = show x ++ s++    show x        = showsPrec 0 x ""++    showList []       = showString "[]"+    showList (x:xs)   = showChar '[' . shows x . showl xs+                        where showl []     = showChar ']'+                              showl (x:xs) = showChar ',' . shows x .+                                             showl xs++reads            :: (Read a) => ReadS a+reads            =  readsPrec 0++shows            :: (Show a) => a -> ShowS+shows            =  showsPrec 0++read             :: (Read a) => String -> a+read s           =  case parses of+                         [x] -> x+                         []  -> error "Prelude.read: no parse"+                         _   -> error "Prelude.read: ambiguous parse"+  where parses = [x | (x,t) <- reads s, ("","") <- lex t]++showChar         :: Char -> ShowS+showChar         =  (:)++showString       :: String -> ShowS+showString       =  (++)++showParen        :: Bool -> ShowS -> ShowS+showParen b p    =  if b then showChar '(' . p . showChar ')' else p++-- Basic printing combinators (nonstd, for use in derived Show instances):++showParenArg :: Int -> ShowS -> ShowS+showParenArg d = showParen (10<=d)++showArgument x = showChar ' ' . showsPrec 10 x++-- Basic parsing combinators (nonstd, for use in derived Read instances):++readToken x t s = [(x,r)|(t',r)<-lex s,t'==t]++readParenArg :: Int -> ReadS a -> ReadS a+readParenArg d = readParen (10<=d)+readArgument s = readsPrec 10 s++rf `readAp` rx = \ s0 -> [(f x,s2) | (f,s1)<-rf s0,(x,s2)<-rx s1]++readChoice rd1 rd2 s = rd1 s ++ rd2 s++---+readParen        :: Bool -> ReadS a -> ReadS a+readParen b g    =  if b then mandatory else optional+                    where optional r  = g r ++ mandatory r+                          mandatory r = [(x,u) | ("(",s) <- lex r,+                                                 (x,t)   <- optional s,+                                                 (")",u) <- lex t    ]++-- This lexer is not completely faithful to the Haskell lexical syntax.+-- Current limitations:+--    Qualified names are not handled properly+--    Octal and hexidecimal numerics are not recognized as a single token+--    Comments are not treated properly++--lex              :: ReadS String+lex ""           =  [("","")]+lex (c:s)+   | isSpace c   =  lex (dropWhile isSpace s)+lex ('\'':s)     =  [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,+                                         ch /= "'" ]+lex ('"':s)      =  [('"':str, t)      | (str,t) <- lexString s]+                    where+                    lexString ('"':s) = [("\"",s)]+                    lexString s = [(ch++str, u)+                                         | (ch,t)  <- lexStrItem s,+                                           (str,u) <- lexString t  ]++                    lexStrItem ('\\':'&':s) =  [("\\&",s)]+                    lexStrItem ('\\':c:s) | isSpace c+                                           =  [("\\&",t) |+                                               '\\':t <-+                                                   [dropWhile isSpace s]]+                    lexStrItem s           =  lexLitChar s++lex (c:s) | isSingle c = [([c],s)]+          | isSym c    = [(c:sym,t)       | (sym,t) <- [span isSym s]]+          | isAlpha c  = [(c:nam,t)       | (nam,t) <- [span isIdChar s]]+          | isDigit c  = [(c:ds++fe,t)    | (ds,s)  <- [span isDigit s],+                                            (fe,t)  <- lexFracExp s     ]+          | otherwise  = []    -- bad character+             where+              isSingle c =  c `elem` ",;()[]{}_`"+              isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"+              isIdChar c =  isAlphaNum c || c `elem` "_'"++              lexFracExp ('.':c:cs) | isDigit c+                            = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),+                                               (e,u)  <- lexExp t]+              lexFracExp s  = lexExp s++              lexExp (e:s) | e `elem` "eE"+                       = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",+                                                 (ds,u) <- lexDigits t] +++                         [(e:ds,t)   | (ds,t) <- lexDigits s]+              lexExp s = [("",s)]++instance  Show Int  where+    showsPrec n = showsPrec n . toInteger+-- Converting to Integer avoids+-- possible difficulty with minInt++instance  Read Int  where+  readsPrec p r = [(fromInteger i, t) | (i,t) <- readsPrec p r]+-- Reading at the Integer type avoids+-- possible difficulty with minInt++instance  Show Integer  where+    showsPrec           = showSigned showInt++instance  Read Integer  where+    readsPrec p         = readSigned readDec++instance  Show Float  where+    showsPrec p         = showFloat+++instance  Read Float  where+    readsPrec p         = readFloat++instance  Show Double  where+    showsPrec p         = showFloat++instance  Read Double  where+    readsPrec p         = readFloat++instance  Show ()  where+    showsPrec p () = showString "()"++instance Read () where+    readsPrec p    = readParen False+                            (\r -> [((),t) | ("(",s) <- lex r,+                                             (")",t) <- lex s ] )++instance  Show Char  where+    showsPrec p '\'' = showString "'\\''"+    showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''++    showList cs = showChar '"' . showl cs+                 where showl ""       = showChar '"'+                       showl ('"':cs) = showString "\\\"" . showl cs+                       showl (c:cs)   = showLitChar c . showl cs++instance  Read Char  where+    readsPrec p      = readParen False+                            (\r -> [(c,t) | ('\'':s,t)<- lex r,+                                            (c,"\'")  <- readLitChar s])++    readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,+                                               (l,_)      <- readl s ])+        where readl ('"':s)      = [("",s)]+              readl ('\\':'&':s) = readl s+              readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,+                                               (cs,u) <- readl t       ]++instance  (Show a) => Show [a]  where+    showsPrec p      = showList++instance  (Read a) => Read [a]  where+    readsPrec p      = readList++-- Tuples++instance  (Show a, Show b) => Show (a,b)  where+    showsPrec p (x,y) = showChar '(' . shows x . showChar ',' .+                                       shows y . showChar ')'++instance  (Read a, Read b) => Read (a,b)  where+    readsPrec p       = readParen False+                            (\r -> [((x,y), w) | ("(",s) <- lex r,+                                                 (x,t)   <- reads s,+                                                 (",",u) <- lex t,+                                                 (y,v)   <- reads u,+                                                 (")",w) <- lex v ] )++-- Other tuples have similar Read and Show instances
+ misc/Random.hs view
@@ -0,0 +1,234 @@+------------------------------------------------------------------------------+-- Standard Library: Random numbers+--+-- Suitable for use with Hugs 98+--+-- The code in this file draws heavily from several different sources,+-- including the implementations in previous Hugs and GHC implementations.+-- Much of this was done by Sigbjorn Finne.  If there are mistakes here,+-- blame me.  The random number generation itself is based on a published+-- article by L'Ecuyer that was transliterated into Haskell by Lennart+-- Augustsson.  See the comments below for further details.+------------------------------------------------------------------------------++module Random(+	RandomGen(next, split),+	StdGen, mkStdGen,+	Random( random,   randomR,+		randoms,  randomRs,+		randomIO, randomRIO ),+	getStdRandom, getStdGen, setStdGen, newStdGen+  ) where++import IOExts  ( IORef, newIORef, writeIORef, readIORef,+		 unsafePerformIO+	       )+import Numeric ( showInt, showSigned, readDec )+import Char(ord,chr,isSpace)++-- The RandomGen class: ------------------------------------------------------++class RandomGen g where+   next  :: g -> (Int, g)+   split :: g -> (g, g)+++-- An efficient and portable combined random number generator: ---------------+--+-- The June 1988 (v31 #6) issue of the Communications of the ACM has an+-- article by Pierre L'Ecuyer called, "Efficient and Portable Combined+-- Random Number Generators".  Here is the Portable Combined Generator of+-- L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.+-- +-- Transliterator: Lennart Augustsson+-- sof 1/99 - code brought (kicking and screaming) into the new Random+-- world..+------------------------------------------------------------------------------++data StdGen = StdGen Int Int++mkStdGen	      :: Int -> StdGen+mkStdGen seed          = StdGen (s1+1) (s2+1)+                         where s       = abs seed+			       (q, s1) = s `divMod` 2147483562+			       s2      = q `mod` 2147483398++stdFromString         :: String -> (StdGen, String)+stdFromString s        = (mkStdGen num, rest)+	where (cs, rest) = splitAt 6 s+              num        = foldl (\a x -> x + 3 * a) 1 (map ord cs)++stdNext               :: StdGen -> (Int, StdGen)+stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')+	where	z'   = if z < 1 then z + 2147483562 else z+		z    = s1'' - s2''++		k    = s1 `quot` 53668+		s1'  = 40014 * (s1 - k * 53668) - k * 12211+		s1'' = if s1' < 0 then s1' + 2147483563 else s1'+    +		k'   = s2 `quot` 52774+		s2'  = 40692 * (s2 - k' * 52774) - k' * 3791+		s2'' = if s2' < 0 then s2' + 2147483399 else s2'++stdSplit            :: StdGen -> (StdGen, StdGen)+stdSplit std@(StdGen s1 s2)+                     = (left, right)+                       where+                        -- no statistical foundation for this!+                        left    = StdGen new_s1 t2+                        right   = StdGen t1 new_s2++                        new_s1 | s1 == 2147483562 = 1+                               | otherwise        = s1 + 1++                        new_s2 | s2 == 1          = 2147483398+                               | otherwise        = s2 - 1++                        StdGen t1 t2 = snd (next std)++-- A standard instance of RandomGen: -----------------------------------------++instance RandomGen StdGen where+  next  = stdNext+  split = stdSplit++instance Show StdGen where+  showsPrec p (StdGen s1 s2)+    = showSigned showInt p s1 .  showChar ' ' . showSigned showInt p s2++instance Read StdGen where+  readsPrec p = \ r ->+    case try_read r of+       r@[_] -> r+       _     -> [stdFromString r] -- because it shouldn't ever fail.+    where +      try_read r = do+         (s1, r1) <- readDec (dropWhile isSpace r)+	 (s2, r2) <- readDec (dropWhile isSpace r1)+	 return (StdGen s1 s2, r2)+++-- The Random class: ---------------------------------------------------------++class Random a where+  -- Minimal complete definition: random and randomR+  random          :: RandomGen g => g -> (a, g)+  randomR         :: RandomGen g => (a,a) -> g -> (a,g)+  +  randoms         :: RandomGen g => g -> [a]++  randomRs        :: RandomGen g => (a,a) -> g -> [a]++  randomIO        :: IO a++  randomRIO       :: (a,a) -> IO a++  randomRIO range  = getStdRandom (randomR range)+  randomRs ival g  = x : randomRs ival g' where (x,g') = randomR ival g+  randomIO	   = getStdRandom random+  randoms  g       = x : randoms g' where (x,g') = random g++instance Random Int where+  random g        = randomR (minBound,maxBound) g+  randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g++instance Random Char where+  random g	  = randomR (minBound,maxBound) g+  randomR (a,b) g = +      case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of+        (x,g) -> (chr x, g)++instance Random Bool where+  random g	  = randomR (minBound,maxBound) g+  randomR (a,b) g = +      case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of+        (x, g) -> (int2Bool x, g)+       where+         bool2Int False = 0+         bool2Int True  = 1++	 int2Bool 0	= False+	 int2Bool _	= True+ +instance Random Integer where+  random g	 = randomR (toInteger (minBound::Int),+                            toInteger (maxBound::Int)) g+  randomR ival g = randomIvalInteger ival g++instance Random Double where+  random g       = randomR (0::Double,1) g+  randomR ival g = randomIvalDouble ival id g+  +-- hah, so you thought you were saving cycles by using Float?+instance Random Float where+  random g        = randomIvalDouble (0::Double,1) realToFrac g+  randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g+++-- Auxiliary functions: ------------------------------------------------------++randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)+randomIvalInteger (l,h) rng+ | l > h     = randomIvalInteger (h,l) rng+ | otherwise = case (f n 1 rng) of+                 (v, rng') -> (fromInteger (l + v `mod` k), rng')+   where+     k = h - l + 1+     b = 2147483561+     n = iLogBase b k++     f 0 acc g = (acc, g)+     f n acc g = let (x,g') = next g+		 in f (n-1) (fromIntegral x + acc * b) g'++randomIvalDouble :: (RandomGen g, Fractional a)+			=> (Double, Double) -> (Double -> a) -> g -> (a, g)+randomIvalDouble (l,h) fromDouble rng +  | l > h     = randomIvalDouble (h,l) fromDouble rng+  | otherwise = +       case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of+         (x, rng') -> +	    let+	     scaled_x = +		fromDouble ((l+h)/2) + +                fromDouble ((h-l) / realToFrac intRange) *+		fromIntegral (x::Int)+	    in+	    (scaled_x, rng')++intRange :: Integer+intRange  = toInteger (maxBound::Int) - toInteger (minBound::Int)++iLogBase :: Integer -> Integer -> Integer+iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)+++-- The global standard random number generator: ------------------------------++foreign import getRandomSeed :: IO Integer++global_rng    :: IORef StdGen+global_rng     = unsafePerformIO (do seed <- getRandomSeed+                                     newIORef (mkStdGen (fromIntegral seed)))++setStdGen     :: StdGen -> IO ()+setStdGen sgen = writeIORef global_rng sgen++getStdGen     :: IO StdGen+getStdGen      = readIORef global_rng++newStdGen     :: IO StdGen+newStdGen      = do rng <- getStdGen+                    let (a,b) = split rng+                    setStdGen a+                    return b++getStdRandom  :: (StdGen -> (a,StdGen)) -> IO a+getStdRandom f = do rng	<- getStdGen+                    let (v, new_rng) = f rng+                    setStdGen new_rng+                    return v+++------------------------------------------------------------------------------
+ misc/Ratio.hs view
@@ -0,0 +1,107 @@+-- Standard functions on rational numbers++module  Ratio (+    Ratio, Rational, (%), numerator, denominator, approxRational ) where+import Prelude++infixl 7  %++prec = 7 :: Int++data  (Integral a)      => Ratio a = !a :% !a  deriving (Eq)+--instance Eq a => Eq (Ratio a)+--type  Rational          =  Ratio Integer++intRat x = x % 1++instance  (Show a{-Integral a-})  => Show (Ratio a)  where+    showsPrec p (x:%y)  =  showParen (p > prec)+                               (shows x . showString " % " . shows y)++--instance Eq a => Eq (Ratio a) where  n1:%d1 == n2:%d2 = n1==n2 && d1==d2++--(%)                     :: (Integral a) => a -> a -> Ratio a+numerator, denominator  :: (Integral a) => Ratio a -> a+--approxRational          :: (RealFrac a) => a -> a -> Rational+++-- "reduce" is a subsidiary function used only in this module.+-- It normalises a ratio by dividing both numerator+-- and denominator by their greatest common divisor.+--+-- E.g., 12 `reduce` 8    ==  3 :%   2+--       12 `reduce` (-8) ==  3 :% (-2)++reduce _ 0              =  error "Ratio.% : zero denominator"+reduce x y              =  (x `quot` d) :% (y `quot` d)+                           where d = gcd x y++x % y                   =  reduce (x * signum y) (abs y)++numerator (x :% _)      =  x++denominator (_ :% y)    =  y+++instance  (Ord a,Num a{-Integral a-})  => Ord (Ratio a)  where+    (x:%y) <= (x':%y')  =  x * y' <= x' * y+    (x:%y) <  (x':%y')  =  x * y' <  x' * y++instance  (Num a,Integral a)  => Num (Ratio a)  {-where+    (x:%y) + (x':%y')   =  reduce (x*y' + x'*y) (y*y')+    (x:%y) * (x':%y')   =  reduce (x * x') (y * y')+    negate (x:%y)       =  (-x) :% y+    abs (x:%y)          =  abs x :% y+    signum (x:%y)       =  signum x :% 1+    fromInteger x       =  fromInteger x :% 1-}++instance  (Integral a)  => Real (Ratio a)  where+    toRational (x:%y)   =  toInteger x :% toInteger y++instance  (Ord a,Num a,Integral a)  => Fractional (Ratio a){-  where+    (x:%y) / (x':%y')   =  (x*y') % (y*x')+    recip (x:%y)        =  if x < 0 then (-y) :% (-x) else y :% x+    fromRational (x:%y) =  fromInteger x :% fromInteger y-}++{-+properFractionRatio (x:%y) = case quotRem x y of+	                      (q,r) -> (fromIntegral q, r:%y)+-}+++instance  (Integral a)  => RealFrac (Ratio a) where+    properFraction (x:%y) = case quotRem x y of+	                      (q,r) -> (fromIntegral q, r:%y)++instance  (Integral a)  => Enum (Ratio a) {- where+    toEnum           =  fromIntegral+    fromEnum         =  fromInteger . truncate -- May overflow+    enumFrom         =  numericEnumFrom -- These numericEnumXXX functions+    enumFromThen     =  numericEnumFromThen -- are as defined in Prelude.hs+    enumFromTo       =  numericEnumFromTo -- but not exported from it!+    enumFromThenTo   =  numericEnumFromThenTo+-}++instance  (Read a, Integral a)  => Read (Ratio a) {- where+    readsPrec p  =  readParen (p > prec)+                              (\r -> [(x%y,u) | (x,s)   <- reads r,+                                                ("%",t) <- lex s,+                                                (y,u)   <- reads t ])+-}++approxRational x eps    =  simplest (x-eps) (x+eps)+        where simplest x y | y < x      =  simplest y x+                           | x == y     =  xr+                           | x > 0      =  simplest' n d n' d'+                           | y < 0      =  - simplest' (-n') d' (-n) d+                           | otherwise  =  0 :% 1+                                        where xr@(n:%d) = toRational x+                                              (n':%d')  = toRational y++              simplest' n d n' d'       -- assumes 0 < n%d < n'%d'+                        | r == 0     =  q :% 1+                        | q /= q'    =  (q+1) :% 1+                        | otherwise  =  (q*n''+d'') :% n''+                                     where (q,r)      =  quotRem n d+                                           (q',r')    =  quotRem n' d'+                                           (n'':%d'') =  simplest' d' r' d r
+ misc/System.hs view
@@ -0,0 +1,24 @@+module System where+import Prelude++foreign import system :: String -> IO ExitCode+foreign import progLine :: [String]+foreign import getEnv :: String -> IO String+++data ExitCode = ExitSuccess | ExitFailure Int deriving (Eq,Ord,Show,Read)+--instance Show ExitCode++getArgs :: IO [String]+getProgName :: IO String++getArgs = return progArgs+getProgName = return progName++exitWith :: ExitCode -> IO a+exitWith e = error ("exithWith "++show e)++exitFailure :: IO a+exitFailure = exitWith (ExitFailure 1) -- system dependent...++progName:progArgs=progLine
+ misc/Time.hs view
@@ -0,0 +1,139 @@+module Time {-(+        ClockTime, +        Month(January,February,March,April,May,June,+              July,August,September,October,November,December),+        Day(Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday),+	CalendarTime(CalendarTime, ctYear, ctMonth, ctDay, ctHour, ctMin,+     ctPicosec, ctWDay, ctYDay, ctTZName, ctTZ, ctIsDST),+	TimeDiff(TimeDiff, tdYear, tdMonth, tdDay, +	 tdHour, tdMin, tdSec, tdPicosec),+        getClockTime, addToClockTime, diffClockTimes,+        toCalendarTime, toUTCTime, toClockTime,+        calendarTimeToString, formatCalendarTime )-} where++import Prelude+import Ix(Ix)+import Locale --(TimeLocale(..),defaultTimeLocale)+import Char ( intToDigit )++newtype ClockTime+   = ClockTime Int+  deriving (Eq,Ord,Show)+  -- The Show instance is a deviation from Haskell 98, provided for+  -- compatibility with Hugs and GHC.++data Month =  January   | February | March    | April+           |  May       | June     | July     | August+           |  September | October  | November | December+           deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)+--instance Enum Month++data Day   =  Sunday | Monday  | Tuesday  | Wednesday | Thursday +           |  Friday | Saturday+           deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)+--instance Enum Day++data CalendarTime = CalendarTime {+                ctYear                          :: Int,+                ctMonth                         :: Month,+                ctDay, ctHour, ctMin, ctSec     :: Int,+                ctPicosec                       :: Integer,+                ctWDay                          :: Day,+                ctYDay                          :: Int,+                ctTZName                        :: String,+                ctTZ                            :: Int,+                ctIsDST                         :: Bool+        } deriving (Eq, Ord, Read, Show)++data TimeDiff = TimeDiff {+                tdYear, tdMonth, tdDay, tdHour, tdMin, tdSec :: Int,+                tdPicosec                                    :: Integer+        } deriving (Eq, Ord, Read, Show)+++getClockTime            :: IO ClockTime+getClockTime            = undefined           -- Implementation-dependent++addToClockTime          :: TimeDiff     -> ClockTime -> ClockTime+addToClockTime td ct    =  undefined          -- Implementation-dependent++diffClockTimes          :: ClockTime    -> ClockTime -> TimeDiff+diffClockTimes ct1 ct2  =  undefined          -- Implementation-dependent++toCalendarTime          :: ClockTime    -> IO CalendarTime+toCalendarTime ct       =  undefined          -- Implementation-dependent++toUTCTime               :: ClockTime    -> CalendarTime+toUTCTime ct            =  undefined          -- Implementation-dependent++toClockTime             :: CalendarTime -> ClockTime+toClockTime cal         =  undefined          -- Implementation-dependent++calendarTimeToString    :: CalendarTime -> String+calendarTimeToString    =  formatCalendarTime defaultTimeLocale "%c"++formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String+formatCalendarTime l fmt ct@(CalendarTime year mon day hour min sec sdec +                                           wday yday tzname _ _) =+        doFmt fmt+  where doFmt ('%':c:cs) = decode c ++ doFmt cs+        doFmt (c:cs) = c : doFmt cs+        doFmt "" = ""++        to12 :: Int -> Int+        to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'++        decode 'A' = fst (wDays l  !! fromEnum wday)+        decode 'a' = snd (wDays l  !! fromEnum wday)+        decode 'B' = fst (months l !! fromEnum mon)+        decode 'b' = snd (months l !! fromEnum mon)+        decode 'h' = snd (months l !! fromEnum mon)+        decode 'C' = show2 (year `quot` 100)+        decode 'c' = doFmt (dateTimeFmt l)+        decode 'D' = doFmt "%m/%d/%y"+        decode 'd' = show2 day+        decode 'e' = show2' day+        decode 'H' = show2 hour+        decode 'I' = show2 (to12 hour)+        decode 'j' = show3 yday+        decode 'k' = show2' hour+        decode 'l' = show2' (to12 hour)+        decode 'M' = show2 min+        decode 'm' = show2 (fromEnum mon+1)+        decode 'n' = "\n"+        decode 'p' = (if hour < 12 then fst else snd) (amPm l)+        decode 'R' = doFmt "%H:%M"+        decode 'r' = doFmt (time12Fmt l)+        decode 'T' = doFmt "%H:%M:%S"+        decode 't' = "\t"+        decode 'S' = show2 sec+        --decode 's' = undefined                -- Implementation-dependent+        decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7)+        decode 'u' = show (let n = fromEnum wday in +                           if n == 0 then 7 else n)+        decode 'V' = +            let (week, days) = +                   (yday + 7 - if fromEnum wday > 0 then +                               fromEnum wday - 1 else 6) `divMod` 7+            in  show2 (if days >= 4 then+                          week+1 +                       else if week == 0 then 53 else week)++        decode 'W' = +            show2 ((yday + 7 - if fromEnum wday > 0 then +                               fromEnum wday - 1 else 6) `div` 7)+        decode 'w' = show (fromEnum wday)+        decode 'X' = doFmt (timeFmt l)+        decode 'x' = doFmt (dateFmt l)+        decode 'Y' = show year+        decode 'y' = show2 (year `rem` 100)+        decode 'Z' = tzname+        decode '%' = "%"+        decode c   = [c]++show2, show2', show3 :: Int -> String+show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)]++show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x++show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100)
+ misc/dupAnswers view
+ misc/dupClassAnswer view
+ misc/dupClassTransform view
+ misc/dupPositions view
+ misc/dupReport view
+ misc/dupTransforms view
+ misc/evaluateResult view
+ misc/genFoldCache view
+ misc/haskell-refac.el view
@@ -0,0 +1,1594 @@+;; a minor mode for Haskell refactoring+;+; (generated automatically, manual edits may be lost)+;+;  put this file in your Emacs load-path, and add something +;  like this to your .emacs (the hook assumes that you're +;  using haskell-mode, and always want to enable the refactoring+;  minor mode when entering haskell-mode):+;+;   (autoload 'haskell-refac-mode "haskell-refac"+;      "Minor mode for refactoring Haskell programs" t)+;   (add-hook 'haskell-mode-hook 'haskell-refac-mode)+;++;; menu silently disappears if this defvar is moved after define-minor-mode..+(defvar haskell-refac-mode-map (make-sparse-keymap "Refactor"))+(define-minor-mode haskell-refac-mode+  "Toggle Haskell Refactoring mode.+   With no argument, this command toggles the mode. +   Non-null prefix argument turns on the mode.+   Null prefix argument turns off the mode.++   When Haskell Refactoring mode is enabled, the \"Refactor\"+   menu provides access to a list of refactorings. These are+   implemented as commands of an external refactoring tool+   (default hare, see option haskell-refac-refactorer).+   "+  ;; The initial value.+  nil+  ;; The indicator for the mode line.+  " HaRe 28/06/2010 "+  ;; The minor mode bindings.+  nil+)++;;JP: Quick & dirty: add hooks for the mode we are defining...+;; Alternative is not to use define-minor-mode+(add-hook 'haskell-refac-mode-on-hook 'turn-on-haskell-refac)+(add-hook 'haskell-refac-mode-off-hook 'turn-off-haskell-refac)++;;JP: moved to top+(defvar haskell-refac-output-marker (make-marker))+(defvar haskell-refac-buffer-list nil)++(defgroup haskell-refac nil "Haskell refactoring options")++(defcustom haskell-refac-refactorer "hare"+	"*Path to Haskell refactoring tool"+	:type 'file+	:group 'haskell-refac)++(defcustom haskell-refac-chasePaths (cons (expand-file-name ".") '("HaskellLibraries"))+	"*List of directories to chase for missing files (including Prelude!)"+	:type '(repeat directory)+	:group 'haskell-refac)++;;JP: easy-menu should work with Emacs too+(easy-menu-define+ haskell-refac-menu+ haskell-refac-mode-map+ "Haskell refactorer minor mode menu"+ '("Refactor"+++("Projects"+   ["New project" haskell-refac-new  :active t]+   ["Add file" haskell-refac-add  :active t]+   ["Chase imports" haskell-refac-chase  :active t]+   ["List files" haskell-refac-files  :active t]+)++("Names/Scopes"+   ["Rename" haskell-refac-rename  :active t]+   ["Lift def to top level" haskell-refac-liftToTopLevel  :active t]+   ["Lift def one level" haskell-refac-liftOneLevel  :active t]+   ["Demote def" haskell-refac-demote  :active t]+   ["Create Type Signatures" haskell-refac-refacTypeSig  :active t]+   ["ReadFile" haskell-refac-parseAnswers  :active t]+   ["Convert Let to Where" haskell-refac-letToWhere  :active t]+   ["Convert Where to Let" haskell-refac-whereToLet  :active t]+   ["Introduce patterns over an argument position" haskell-refac-introPattern  :active t]+   ["Introduce case analysis" haskell-refac-introCase  :active t]+   ["Fold term against pattern variable" haskell-refac-foldPattern  :active t]+)++("Slicing"+   ["Remove redundant declarations" haskell-refac-refacRedunDec  :active t]+   ["Slicing based on a subexpression" haskell-refac-refacSlicing  :active t]+   ["Slicing a tuple" haskell-refac-refacSlicTuple  :active t]+   ["Merge definitions" haskell-refac-refacMerge  :active t]+   ["Add definition for merge" haskell-refac-refacCacheMerge  :active t]+   ["Instantiate a general pattern" haskell-refac-refacInstantiate  :active t]+)++("Fold/Unfold"+   ["Unfold def" haskell-refac-unfoldDef  :active t]+   ["Fold Definition" haskell-refac-subFunctionDef  :active t]+   ["Generative Fold of Definition" haskell-refac-genFold  :active t]+   ["Select an equation for generative fold" haskell-refac-genFoldCache  :active t]+   ["Convert pattern to use an as pattern" haskell-refac-refacAsPatterns  :active t]+   ["Unfold references to AS patterns" haskell-refac-refacUnfoldAsPatterns  :active t]+   ["Simplify Expression via Symbolic Evalutaion" haskell-refac-simplifyExpr  :active t]+)++("Definitions"+   ["Introduce new def" haskell-refac-introNewDef  :active t]+   ["Generalise def" haskell-refac-generaliseDef  :active t]+   ["Remove def" haskell-refac-removeDef  :active t]+   ["Duplicate def" haskell-refac-duplicateDef  :active t]+   ["Add one parameter" haskell-refac-addOneParameter  :active t]+   ["Rm one parameter" haskell-refac-rmOneParameter  :active t]+   ["Move def to another module" haskell-refac-moveDefBtwMod  :active t]+   ["Converts guards to an if then else" haskell-refac-guardToIte  :active t]+   ["Shortcut Deforestration" haskell-refac-deforest  :active t]+)++("Import/Export"+   ["Clean imports" haskell-refac-cleanImports  :active t]+   ["Make import explicit" haskell-refac-mkImpExplicit  :active t]+   ["Add to export" haskell-refac-addToExport  :active t]+   ["Remove from export" haskell-refac-rmFromExport  :active t]+)++("Data types"+   ["Add field labels" haskell-refac-addFieldLabels  :active t]+   ["Add discriminators" haskell-refac-addDiscriminators  :active t]+   ["Add constructors" haskell-refac-addConstructors  :active t]+   ["eliminate nested patterns" haskell-refac-elimNestedPatterns  :active t]+   ["eliminate patterns" haskell-refac-elimPatterns  :active t]+   ["Create an ADT module" haskell-refac-createADTMod  :active t]+   ["From concrete to abstract data type" haskell-refac-fromAlgebraicToADT  :active t]+   ["Add a new constructor to a data type" haskell-refac-refacAddCon  :active t]+   ["Remove a constructor from a data type" haskell-refac-refacRmCon  :active t]+   ["Remove a field from a data type" haskell-refac-refacRemoveField  :active t]+   ["Add a field to a data type" haskell-refac-refacAddField  :active t]+)++("Duplicate Code"+   ["Duplicate Code Analysis" haskell-refac-duplicateCode  :active t]+   ["Transform Duplicate Code" haskell-refac-goDup  :active t]+   +)++   ["undo" haskell-refac-undo  :active t]++   "-"+   ["Customize" (customize-group 'haskell-refac) t]+   ))++(defun turn-on-haskell-refac ()+  "Turn on Haskell Refactoring support"+  (interactive)++  (if (not (buffer-file-name))+    (message-box "Error: can only refactor if buffer is associated with file")++    (progn +      ;; keep track of buffers involved in refactoring++      (add-to-list 'haskell-refac-buffer-list (buffer-name) )++      ;; key bindings and menu entries++      (easy-menu-add haskell-refac-menu)+      (hare-selection-init)++      ;; refactoring sub-process, only one, please++      (unless (get-process "haskell-refac-process")+        (start-process "haskell-refac-process" "*refac*"+            haskell-refac-refactorer "emacs")++        ; does this work on unix as well, or do we need to be os-specific?+        ;;JP: XEmacs doesn't know this+        ;;(set-process-coding-system (get-process "haskell-refac-process") +        ;;                           'raw-text-dos 'raw-text-unix)++        (set-marker haskell-refac-output-marker 0 (get-buffer-create "*refac*"))++        (set-process-filter (get-process "haskell-refac-process") +                            'haskell-refac-process-filter) ) ) )+)++(defun haskell-refac-process-filter (proc string)+     (let* ((refac-buffer (process-buffer proc)) +            (refac-end-mark (process-mark proc))+            (refac-buffer-window (display-buffer refac-buffer))+            (modified nil))+       (with-current-buffer refac-buffer+           ;; Insert the text, advancing the process marker.+           (goto-char refac-end-mark)+           (insert string)+           (set-marker refac-end-mark (point))+           ;; has the refactorer changed files on disk?+           (save-excursion+               (goto-char (marker-position haskell-refac-output-marker))+               (let ((found nil))+                  (while (setq found (re-search-forward "^\\(message\\|modified\\): \\(.*\\)\n" nil t)) +                    (progn+                      (let ((cmd (match-string 1)) (param (match-string 2)))+                       (goto-char found)+                       (set-marker haskell-refac-output-marker found)+                       (cond+                         ((string= cmd "modified") (setq modified (cons param modified)))+                         ((string= cmd "message")  (message-box param))+                         )+                      )+                     ) )+               )+           )+       )+       (save-selected-window +         (select-window refac-buffer-window)+         (goto-char (marker-position refac-end-mark))+         (recenter -2))+       (dolist (f modified) +         (let ((buffer (get-file-buffer f)))+           (if buffer (with-current-buffer buffer (revert-buffer nil t t))+             (message-box (format "modified unopened file: %s" f)))))+     )+)++(defun turn-off-haskell-refac ()+  "Turn off Haskell Refactoring support"+  (interactive)+  (delete (buffer-name) haskell-refac-buffer-list)+  (easy-menu-remove haskell-refac-menu)+  (if (null haskell-refac-buffer-list) +    (set-process-filter (get-process "haskell-refac-process") nil)+    (kill-process "haskell-refac-process")+    (kill-buffer "*refac*")+  )+  )++;; try to provide command to call pfe with current+;; file name and position in file++(defun line-no ()+  "grmpff. does anyone understand count-lines?"+  (+ (if (eq 0 (current-column)) 1 0)+     (count-lines (point-min) (point)))+  )++(defun line-no-pos (pos)+  "grmpff. why no parameter to current-column?"+  (save-excursion+    (goto-char pos)+    (+ (if (eq 0 (current-column)) 1 0)+       (count-lines (point-min) (point))))+  )++(defun current-column-pos (pos)+  "grmpff. why no parameter to current-column?"+  (save-excursion+    (goto-char pos) (current-column))+  )+++(defun haskell-refac-new ()+  "new"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "new " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-add ()+  "add"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "add " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-chase ()+  "chase"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "chase " (mapconcat 'identity (append +		haskell-refac-chasePaths) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-files ()+  "files"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "files " (mapconcat 'identity (append ) " ")+         "\n"))+     )+  ) )++++(defun haskell-refac-rename ( name1)+  "rename"+  (interactive "sNew name? \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "rename " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-liftToTopLevel ()+  "liftToTopLevel"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "liftToTopLevel " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-liftOneLevel ()+  "liftOneLevel"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "liftOneLevel " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-demote ()+  "demote"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "demote " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacTypeSig ()+  "refacTypeSig"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacTypeSig " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-parseAnswers ()+  "parseAnswers"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "parseAnswers " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-letToWhere ()+  "letToWhere"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "letToWhere " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-whereToLet ()+  "whereToLet"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "whereToLet " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-introPattern ()+  "introPattern"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "introPattern " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-introCase ()+  "introCase"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "introCase " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-foldPattern ( name1 start2 end2)+  "foldPattern"+  (interactive "sName of pattern variable: \nr")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "foldPattern " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no-pos start2))+		(number-to-string (+ 1 (current-column-pos start2)))+		(number-to-string (line-no-pos end2))+		(number-to-string (+ 1 (current-column-pos end2))))) " ")+         "\n"))+     )+  ) )++++(defun haskell-refac-refacRedunDec ( start1 end1)+  "refacRedunDec"+  (interactive "r")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacRedunDec " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no-pos start1))+		(number-to-string (+ 1 (current-column-pos start1)))+		(number-to-string (line-no-pos end1))+		(number-to-string (+ 1 (current-column-pos end1))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacSlicing ( start1 end1)+  "refacSlicing"+  (interactive "r")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacSlicing " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no-pos start1))+		(number-to-string (+ 1 (current-column-pos start1)))+		(number-to-string (line-no-pos end1))+		(number-to-string (+ 1 (current-column-pos end1))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacSlicTuple ( name2)+  "refacSlicTuple"+  (interactive "sElements to slice: (A for all; (x,_x,_) for some): \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacSlicTuple " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))+		(list name2)) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacMerge ( name1)+  "refacMerge"+  (interactive "sName for new definition: \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacMerge " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacCacheMerge ()+  "refacCacheMerge"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacCacheMerge " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacInstantiate ( name2)+  "refacInstantiate"+  (interactive "spatterns: \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacInstantiate " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))+		(list name2)) " ")+         "\n"))+     )+  ) )++++(defun haskell-refac-unfoldDef ()+  "unfoldDef"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "unfoldDef " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-subFunctionDef ( start1 end1)+  "subFunctionDef"+  (interactive "r")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "subFunctionDef " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no-pos start1))+		(number-to-string (+ 1 (current-column-pos start1)))+		(number-to-string (line-no-pos end1))+		(number-to-string (+ 1 (current-column-pos end1))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-genFold ( start1 end1)+  "genFold"+  (interactive "r")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "genFold " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no-pos start1))+		(number-to-string (+ 1 (current-column-pos start1)))+		(number-to-string (line-no-pos end1))+		(number-to-string (+ 1 (current-column-pos end1))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-genFoldCache ()+  "genFoldCache"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "genFoldCache " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacAsPatterns ( name1 start2 end2)+  "refacAsPatterns"+  (interactive "sName for Pattern: \nr")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacAsPatterns " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no-pos start2))+		(number-to-string (+ 1 (current-column-pos start2)))+		(number-to-string (line-no-pos end2))+		(number-to-string (+ 1 (current-column-pos end2))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacUnfoldAsPatterns ( start1 end1)+  "refacUnfoldAsPatterns"+  (interactive "r")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacUnfoldAsPatterns " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no-pos start1))+		(number-to-string (+ 1 (current-column-pos start1)))+		(number-to-string (line-no-pos end1))+		(number-to-string (+ 1 (current-column-pos end1))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-simplifyExpr ( start1 end1)+  "simplifyExpr"+  (interactive "r")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "simplifyExpr " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no-pos start1))+		(number-to-string (+ 1 (current-column-pos start1)))+		(number-to-string (line-no-pos end1))+		(number-to-string (+ 1 (current-column-pos end1))))) " ")+         "\n"))+     )+  ) )++++(defun haskell-refac-introNewDef ( name1 start2 end2)+  "introNewDef"+  (interactive "sName for new definition? \nr")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "introNewDef " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no-pos start2))+		(number-to-string (+ 1 (current-column-pos start2)))+		(number-to-string (line-no-pos end2))+		(number-to-string (+ 1 (current-column-pos end2))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-generaliseDef ( name1 start2 end2)+  "generaliseDef"+  (interactive "sname of new parameter? \nr")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "generaliseDef " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no-pos start2))+		(number-to-string (+ 1 (current-column-pos start2)))+		(number-to-string (line-no-pos end2))+		(number-to-string (+ 1 (current-column-pos end2))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-removeDef ()+  "removeDef"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "removeDef " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-duplicateDef ( name1)+  "duplicateDef"+  (interactive "sName for duplicate? \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "duplicateDef " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-addOneParameter ( name1)+  "addOneParameter"+  (interactive "sname of new parameter? \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "addOneParameter " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-rmOneParameter ()+  "rmOneParameter"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "rmOneParameter " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-moveDefBtwMod ( name1)+  "moveDefBtwMod"+  (interactive "sname of the destination module? \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "moveDefBtwMod " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-guardToIte ()+  "guardToIte"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "guardToIte " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-deforest ()+  "deforest"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "deforest " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))) " ")+         "\n"))+     )+  ) )++++(defun haskell-refac-cleanImports ()+  "cleanImports"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "cleanImports " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-mkImpExplicit ()+  "mkImpExplicit"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "mkImpExplicit " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-addToExport ()+  "addToExport"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "addToExport " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-rmFromExport ()+  "rmFromExport"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "rmFromExport " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )++++(defun haskell-refac-addFieldLabels ()+  "addFieldLabels"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "addFieldLabels " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-addDiscriminators ()+  "addDiscriminators"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "addDiscriminators " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-addConstructors ()+  "addConstructors"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "addConstructors " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-elimNestedPatterns ()+  "elimNestedPatterns"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "elimNestedPatterns " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-elimPatterns ()+  "elimPatterns"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "elimPatterns " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-createADTMod ()+  "createADTMod"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "createADTMod " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-fromAlgebraicToADT ()+  "fromAlgebraicToADT"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "fromAlgebraicToADT " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacAddCon ( name1)+  "refacAddCon"+  (interactive "sEnter text for constructor and parameters: \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacAddCon " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacRmCon ()+  "refacRmCon"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacRmCon " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacRemoveField ( name1)+  "refacRemoveField"+  (interactive "sEnter position of field to be removed: \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacRemoveField " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacAddField ( name1)+  "refacAddField"+  (interactive "sType of Field : \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacAddField " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)+		(list (number-to-string (line-no)) (number-to-string (+ 1 (current-column))))) " ")+         "\n"))+     )+  ) )++++(defun haskell-refac-duplicateCode ( name1)+  "duplicateCode"+  (interactive "sClone Token Size: \n")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "duplicateCode " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list name1)) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacDupTrans ( start1 end1)+  "refacDupTrans"+  (interactive "r")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacDupTrans " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no-pos start1))+		(number-to-string (+ 1 (current-column-pos start1)))+		(number-to-string (line-no-pos end1))+		(number-to-string (+ 1 (current-column-pos end1))))) " ")+         "\n"))+     )+  ) )+++(defun haskell-refac-refacIdentify ( start1 end1)+  "refacIdentify"+  (interactive "r")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacIdentify " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no-pos start1))+		(number-to-string (+ 1 (current-column-pos start1)))+		(number-to-string (line-no-pos end1))+		(number-to-string (+ 1 (current-column-pos end1))))) " ")+         "\n"))+     )+  ) )++++(defun haskell-refac-undo ()+  "undo"+  (interactive "")+  (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "undo " (mapconcat 'identity (append ) " ")+         "\n"))+     )+  ) )+++; ----------------------------- Hare selection++(defun hare-selection-init ()+  (interactive)+  (define-minor-mode hare-selection-mode+    "Hare selection+     In selection buffer, use [tab] to jump to current entry,+     and [(control k)] to delete current entry.+    "+    nil+    " Hare selection "+    '(([tab] . hare-select-goto)+      ([(control k)] . hare-select-goto-delete)+      )+    )+  (with-current-buffer (get-buffer-create "*hare-selection*")+    (hare-selection-mode t)+    )+  (defvar hare-selection '())+  (easy-menu-change '("Refactor") "Selection"+    '(["Clear selection" hare-select-clear :active t]+      ["Add to selection" hare-select-add :active t]+      ["Delete from selection" hare-select-delete :active t]+      ["Show selection" hare-select-display :active t]+      ["Visit next entry" hare-select-goto-next :active t]+      ["Visit current entry" hare-select-goto :active t]+      ["Visit previous entry" hare-select-goto-previous :active t]+     )+    )+  )+(defun hare-select-clear()+  (interactive)+  (setq hare-selection '())+  (hare-select-update)+  )+(defun hare-select-add () +  (interactive) +  (setq hare-selection+        (append hare-selection+                `((,(point) ,(current-buffer) ,(thing-at-point 'line)))+                )+        )+  (hare-select-update)+  )+(defun hare-select-goto-delete ()+  (interactive)+  (hare-select-goto)+  (hare-select-delete)+  )+(defun hare-select-delete ()+  (interactive)+  (setq hare-selection +	(hare-select-delete-aux `(,(point) ,(current-buffer)) hare-selection)+	)+  (hare-select-update)+  )+(defun hare-select-delete-aux (e l)+  (if (null l)+      l+      (let ((h (car l)) (r (cdr l)))+	(if (equal e `(,(nth 0 h) ,(nth 1 h)))+	  (hare-select-delete-aux e r)+	  (cons h (hare-select-delete-aux e r))+	  )+	)+      )+  )+(defun hare-select-update ()+  (interactive)+  (save-excursion+    (set-buffer (get-buffer-create "*hare-selection*"))+    (erase-buffer)+    (insert (mapconcat 'hare-select-get-line hare-selection ""))+    (delete-blank-lines)+    )+  )+(defun hare-select-display ()+  (interactive)+  (save-excursion+    (pop-to-buffer (get-buffer-create "*hare-selection*"))+    (erase-buffer)+    (insert (mapconcat 'hare-select-get-line hare-selection ""))+    (shrink-window-if-larger-than-buffer)+    )+  )+(defun hare-select-goto-next ()+  (interactive)+  (set-buffer (get-buffer-create "*hare-selection*"))+  (forward-line 1)+  (hare-select-goto)+  )+(defun hare-select-goto-previous ()+  (interactive)+  (set-buffer (get-buffer-create "*hare-selection*"))+  (forward-line -1)+  (hare-select-goto)+  )+(defun hare-select-goto ()+  (interactive)+  (set-buffer (get-buffer-create "*hare-selection*"))+  (let ((i (- (line-no-pos (point)) 1)))+    (message (concat (number-to-string i) (buffer-name (nth 1 (nth i hare-selection)))))+    (pop-to-buffer (nth 1 (nth i hare-selection)))+    (goto-char (nth 0 (nth i hare-selection)))+    )+  )+(defun hare-select-get-line (pos)+  (save-excursion+    (set-buffer (cadr pos))+    (goto-char (car pos))+    (concat +	 "\"" (buffer-file-name (cadr pos)) "\" "+	 (number-to-string (line-no-pos (car pos))) " "+	 (number-to-string (current-column-pos (car pos))) " : "+	 (nth 2 pos)+	 )+    )+  )+(defun haskell-refac-goDup ( start1 end1)+  "clonesExtraction"+  (interactive "r")+  (progn +   (let (modified)+     (dolist (b (buffer-list) modified)+       (let* ((n (buffer-name b)) (n1 (substring n 0 1)))+        (if (and (not (or (string= " " n1) (string= "*" n1))) (buffer-modified-p b))+          (setq modified (cons (buffer-name b) modified)))))+     (if modified (message-box (format "there are modified buffers: %s" modified))+       (process-send-string "haskell-refac-process" +         (concat+         +         "refacIdentify " (mapconcat 'identity (append +		(list (if (buffer-file-name) (buffer-file-name) "<missing filename>"))+		(list (number-to-string (line-no-pos start1))+		(number-to-string (+ 1 (current-column-pos start1)))+		(number-to-string (line-no-pos end1))+		(number-to-string (+ 1 (current-column-pos end1))))) " ")+         "\n"))++     )+  )+  (haskell-refac-parseAnswers2)+  +) )++(defun haskell-refac-parseAnswers2 ()+  "parseAnswers2"+  (interactive "") +  (progn+    (process-send-string "haskell-refac-process" (concat+         "parseAnswers " (mapconcat 'identity (append +		+		(list "")) " ")+         "\n"))+    (let ((F (read-from-minibuffer "Would you like to extract this expression?"))    )  +    (if (equal F  "q") +         (process-send-string "haskell-refac-process" (concat+          "refacDupTrans " (mapconcat 'identity (append +		  (list "")) " ")+         "\n"))+         (progn+          (process-send-string "haskell-refac-process" (concat+           "parseAnswers " (mapconcat 'identity (append +		+		   (list F)) " ")+           "\n"))+           (haskell-refac-parseAnswers2)+           "\n")))+  )+) 
+ misc/mergeCache view
+ misc/refactor.vim view
@@ -0,0 +1,968 @@+" Vim/GVim interface to Haskell refactorer+" (generated automatically - manual edits may be lost)++" use :source <file> to load this into vim/gvim+++let g:haskell_refac_version = "HaRe 28/06/2010"++if !exists("g:haskell_refac_refactorer")+	let g:haskell_refac_refactorer = "hare"+endif++if !exists("g:haskell_refac_refactorer_client")+	let g:haskell_refac_refactorer_client = "hare_client"+endif++if !exists("g:haskell_refac_chasePaths")+	let g:haskell_refac_chasePaths = getcwd() . " HaskellLibraries"+endif++if !exists("g:haskell_refac_showWindow")+	let g:haskell_refac_showWindow = 1+endif++function! Myinput(p)+     if version >=602+        call inputsave()+     endif+        let x=input(a:p)+     if version >=602+        call inputrestore()+     endif+        return x+endfunction+++function! Haskell_refac_new()+	let fileName0 = expand("%:p")++call Haskell_refac_client_cmd(" new"." ".fileName0)+endfunction+++function! Haskell_refac_add()+	let fileName0 = expand("%:p")++call Haskell_refac_client_cmd(" add"." ".fileName0)+endfunction+++function! Haskell_refac_chase()++call Haskell_refac_client_cmd(" chase"." ". g:haskell_refac_chasePaths)+endfunction+++function! Haskell_refac_files()++call Haskell_refac_client_cmd(" files")+endfunction++++function! Haskell_refac_rename()+	let fileName0 = expand("%:p")+	let name1 = Myinput("New name? ")+	let line2 = line(".")+	let column2 = col(".")++call Haskell_refac_client_cmd(" rename"." ".fileName0." ".name1." ".line2." ".column2)+endfunction+++function! Haskell_refac_liftToTopLevel()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" liftToTopLevel"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_liftOneLevel()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" liftOneLevel"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_demote()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" demote"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_refacTypeSig()+	let fileName0 = expand("%:p")++call Haskell_refac_client_cmd(" refacTypeSig"." ".fileName0)+endfunction+++function! Haskell_refac_parseAnswers()+	let fileName0 = expand("%:p")++call Haskell_refac_client_cmd(" parseAnswers"." ".fileName0)+endfunction+++function! Haskell_refac_letToWhere()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" letToWhere"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_whereToLet()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" whereToLet"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_introPattern()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" introPattern"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_introCase()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" introCase"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_foldPattern()+	let fileName0 = expand("%:p")+	let name1 = Myinput("Name of pattern variable: ")+	let start2 = line("'<")." ".col("'<")+	let end2 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" foldPattern"." ".fileName0." ".name1." ".start2." ".end2)+endfunction++++function! Haskell_refac_refacRedunDec()+	let fileName0 = expand("%:p")+	let start1 = line("'<")." ".col("'<")+	let end1 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" refacRedunDec"." ".fileName0." ".start1." ".end1)+endfunction+++function! Haskell_refac_refacSlicing()+	let fileName0 = expand("%:p")+	let start1 = line("'<")." ".col("'<")+	let end1 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" refacSlicing"." ".fileName0." ".start1." ".end1)+endfunction+++function! Haskell_refac_refacSlicTuple()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")+	let name2 = Myinput("Elements to slice: (A for all; (x,_x,_) for some): ")++call Haskell_refac_client_cmd(" refacSlicTuple"." ".fileName0." ".line1." ".column1." ".name2)+endfunction+++function! Haskell_refac_refacMerge()+	let fileName0 = expand("%:p")+	let name1 = Myinput("Name for new definition: ")++call Haskell_refac_client_cmd(" refacMerge"." ".fileName0." ".name1)+endfunction+++function! Haskell_refac_refacCacheMerge()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" refacCacheMerge"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_refacInstantiate()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")+	let name2 = Myinput("patterns: ")++call Haskell_refac_client_cmd(" refacInstantiate"." ".fileName0." ".line1." ".column1." ".name2)+endfunction++++function! Haskell_refac_unfoldDef()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" unfoldDef"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_subFunctionDef()+	let fileName0 = expand("%:p")+	let start1 = line("'<")." ".col("'<")+	let end1 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" subFunctionDef"." ".fileName0." ".start1." ".end1)+endfunction+++function! Haskell_refac_genFold()+	let fileName0 = expand("%:p")+	let start1 = line("'<")." ".col("'<")+	let end1 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" genFold"." ".fileName0." ".start1." ".end1)+endfunction+++function! Haskell_refac_genFoldCache()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" genFoldCache"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_refacAsPatterns()+	let fileName0 = expand("%:p")+	let name1 = Myinput("Name for Pattern: ")+	let start2 = line("'<")." ".col("'<")+	let end2 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" refacAsPatterns"." ".fileName0." ".name1." ".start2." ".end2)+endfunction+++function! Haskell_refac_refacUnfoldAsPatterns()+	let fileName0 = expand("%:p")+	let start1 = line("'<")." ".col("'<")+	let end1 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" refacUnfoldAsPatterns"." ".fileName0." ".start1." ".end1)+endfunction+++function! Haskell_refac_simplifyExpr()+	let fileName0 = expand("%:p")+	let start1 = line("'<")." ".col("'<")+	let end1 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" simplifyExpr"." ".fileName0." ".start1." ".end1)+endfunction++++function! Haskell_refac_introNewDef()+	let fileName0 = expand("%:p")+	let name1 = Myinput("Name for new definition? ")+	let start2 = line("'<")." ".col("'<")+	let end2 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" introNewDef"." ".fileName0." ".name1." ".start2." ".end2)+endfunction+++function! Haskell_refac_generaliseDef()+	let fileName0 = expand("%:p")+	let name1 = Myinput("name of new parameter? ")+	let start2 = line("'<")." ".col("'<")+	let end2 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" generaliseDef"." ".fileName0." ".name1." ".start2." ".end2)+endfunction+++function! Haskell_refac_removeDef()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" removeDef"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_duplicateDef()+	let fileName0 = expand("%:p")+	let name1 = Myinput("Name for duplicate? ")+	let line2 = line(".")+	let column2 = col(".")++call Haskell_refac_client_cmd(" duplicateDef"." ".fileName0." ".name1." ".line2." ".column2)+endfunction+++function! Haskell_refac_addOneParameter()+	let fileName0 = expand("%:p")+	let name1 = Myinput("name of new parameter? ")+	let line2 = line(".")+	let column2 = col(".")++call Haskell_refac_client_cmd(" addOneParameter"." ".fileName0." ".name1." ".line2." ".column2)+endfunction+++function! Haskell_refac_rmOneParameter()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" rmOneParameter"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_moveDefBtwMod()+	let fileName0 = expand("%:p")+	let name1 = Myinput("name of the destination module? ")+	let line2 = line(".")+	let column2 = col(".")++call Haskell_refac_client_cmd(" moveDefBtwMod"." ".fileName0." ".name1." ".line2." ".column2)+endfunction+++function! Haskell_refac_guardToIte()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" guardToIte"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_deforest()+	let fileName0 = expand("%:p")++call Haskell_refac_client_cmd(" deforest"." ".fileName0)+endfunction++++function! Haskell_refac_cleanImports()+	let fileName0 = expand("%:p")++call Haskell_refac_client_cmd(" cleanImports"." ".fileName0)+endfunction+++function! Haskell_refac_mkImpExplicit()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" mkImpExplicit"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_addToExport()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" addToExport"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_rmFromExport()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" rmFromExport"." ".fileName0." ".line1." ".column1)+endfunction++++function! Haskell_refac_addFieldLabels()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" addFieldLabels"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_addDiscriminators()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" addDiscriminators"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_addConstructors()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" addConstructors"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_elimNestedPatterns()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" elimNestedPatterns"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_elimPatterns()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" elimPatterns"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_createADTMod()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" createADTMod"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_fromAlgebraicToADT()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" fromAlgebraicToADT"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_refacAddCon()+	let fileName0 = expand("%:p")+	let name1 = Myinput("Enter text for constructor and parameters: ")+	let line2 = line(".")+	let column2 = col(".")++call Haskell_refac_client_cmd(" refacAddCon"." ".fileName0." ".name1." ".line2." ".column2)+endfunction+++function! Haskell_refac_refacRmCon()+	let fileName0 = expand("%:p")+	let line1 = line(".")+	let column1 = col(".")++call Haskell_refac_client_cmd(" refacRmCon"." ".fileName0." ".line1." ".column1)+endfunction+++function! Haskell_refac_refacRemoveField()+	let fileName0 = expand("%:p")+	let name1 = Myinput("Enter position of field to be removed: ")+	let line2 = line(".")+	let column2 = col(".")++call Haskell_refac_client_cmd(" refacRemoveField"." ".fileName0." ".name1." ".line2." ".column2)+endfunction+++function! Haskell_refac_refacAddField()+	let fileName0 = expand("%:p")+	let name1 = Myinput("Type of Field : ")+	let line2 = line(".")+	let column2 = col(".")++call Haskell_refac_client_cmd(" refacAddField"." ".fileName0." ".name1." ".line2." ".column2)+endfunction++++function! Haskell_refac_duplicateCode()+	let fileName0 = expand("%:p")+	let name1 = Myinput("Clone Token Size: ")++call Haskell_refac_client_cmd(" duplicateCode"." ".fileName0." ".name1)+endfunction+++function! Haskell_refac_refacDupTrans()+	let fileName0 = expand("%:p")+	let start1 = line("'<")." ".col("'<")+	let end1 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" refacDupTrans"." ".fileName0." ".start1." ".end1)+endfunction+++function! Haskell_refac_refacIdentify()+	let fileName0 = expand("%:p")+	let start1 = line("'<")." ".col("'<")+	let end1 = line("'>")." ".col("'>")+call Haskell_refac_client_cmd(" refacIdentify"." ".fileName0." ".start1." ".end1)+endfunction++++function! Haskell_refac_undo()++call Haskell_refac_client_cmd(" undo")+endfunction+++command! New :echo Haskell_refac_new()+command! Add :echo Haskell_refac_add()+command! Chase :echo Haskell_refac_chase()+command! Files :echo Haskell_refac_files()++command! Rename :echo Haskell_refac_rename()+command! LiftToTopLevel :echo Haskell_refac_liftToTopLevel()+command! LiftOneLevel :echo Haskell_refac_liftOneLevel()+command! Demote :echo Haskell_refac_demote()+command! RefacTypeSig :echo Haskell_refac_refacTypeSig()+command! ParseAnswers :echo Haskell_refac_parseAnswers()+command! LetToWhere :echo Haskell_refac_letToWhere()+command! WhereToLet :echo Haskell_refac_whereToLet()+command! IntroPattern :echo Haskell_refac_introPattern()+command! IntroCase :echo Haskell_refac_introCase()+command! FoldPattern :echo Haskell_refac_foldPattern()++command! RefacRedunDec :echo Haskell_refac_refacRedunDec()+command! RefacSlicing :echo Haskell_refac_refacSlicing()+command! RefacSlicTuple :echo Haskell_refac_refacSlicTuple()+command! RefacMerge :echo Haskell_refac_refacMerge()+command! RefacCacheMerge :echo Haskell_refac_refacCacheMerge()+command! RefacInstantiate :echo Haskell_refac_refacInstantiate()++command! UnfoldDef :echo Haskell_refac_unfoldDef()+command! SubFunctionDef :echo Haskell_refac_subFunctionDef()+command! GenFold :echo Haskell_refac_genFold()+command! GenFoldCache :echo Haskell_refac_genFoldCache()+command! RefacAsPatterns :echo Haskell_refac_refacAsPatterns()+command! RefacUnfoldAsPatterns :echo Haskell_refac_refacUnfoldAsPatterns()+command! SimplifyExpr :echo Haskell_refac_simplifyExpr()++command! IntroNewDef :echo Haskell_refac_introNewDef()+command! GeneraliseDef :echo Haskell_refac_generaliseDef()+command! RemoveDef :echo Haskell_refac_removeDef()+command! DuplicateDef :echo Haskell_refac_duplicateDef()+command! AddOneParameter :echo Haskell_refac_addOneParameter()+command! RmOneParameter :echo Haskell_refac_rmOneParameter()+command! MoveDefBtwMod :echo Haskell_refac_moveDefBtwMod()+command! GuardToIte :echo Haskell_refac_guardToIte()+command! Deforest :echo Haskell_refac_deforest()++command! CleanImports :echo Haskell_refac_cleanImports()+command! MkImpExplicit :echo Haskell_refac_mkImpExplicit()+command! AddToExport :echo Haskell_refac_addToExport()+command! RmFromExport :echo Haskell_refac_rmFromExport()++command! AddFieldLabels :echo Haskell_refac_addFieldLabels()+command! AddDiscriminators :echo Haskell_refac_addDiscriminators()+command! AddConstructors :echo Haskell_refac_addConstructors()+command! ElimNestedPatterns :echo Haskell_refac_elimNestedPatterns()+command! ElimPatterns :echo Haskell_refac_elimPatterns()+command! CreateADTMod :echo Haskell_refac_createADTMod()+command! FromAlgebraicToADT :echo Haskell_refac_fromAlgebraicToADT()+command! RefacAddCon :echo Haskell_refac_refacAddCon()+command! RefacRmCon :echo Haskell_refac_refacRmCon()+command! RefacRemoveField :echo Haskell_refac_refacRemoveField()+command! RefacAddField :echo Haskell_refac_refacAddField()++command! DuplicateCode :echo Haskell_refac_duplicateCode()+command! RefacDupTrans :echo Haskell_refac_refacDupTrans()+command! RefacIdentify :echo Haskell_refac_refacIdentify()++command! Undo :echo Haskell_refac_undo()++" --------------------------------------------------- menu+if has("menu")+	if exists("b:haskell_refac_menu")+		aunmenu Haskell(Refac)+	endif++	200amenu Haskell(Refac).-Change-      :++	amenu Haskell(Refac).Projects.New\ project :New<cr>+	tmenu Haskell(Refac).Projects.New\ project <fileName> Start new project with current file+	amenu Haskell(Refac).Projects.Add\ file :Add<cr>+	tmenu Haskell(Refac).Projects.Add\ file <fileName> Add current file to project+	amenu Haskell(Refac).Projects.Chase\ imports :Chase<cr>+	tmenu Haskell(Refac).Projects.Chase\ imports <option (chasePaths)> Chase to add missing files to project+	amenu Haskell(Refac).Projects.List\ files :Files<cr>+	tmenu Haskell(Refac).Projects.List\ files List files in project++	amenu Haskell(Refac).Names/Scopes.Rename :Rename<cr>+	tmenu Haskell(Refac).Names/Scopes.Rename <fileName> <name (New name? )> <line> <column> Rename a variable name+	amenu Haskell(Refac).Names/Scopes.Lift\ def\ to\ top\ level :LiftToTopLevel<cr>+	tmenu Haskell(Refac).Names/Scopes.Lift\ def\ to\ top\ level <fileName> <line> <column> Lift a local declaration to top level+	amenu Haskell(Refac).Names/Scopes.Lift\ def\ one\ level :LiftOneLevel<cr>+	tmenu Haskell(Refac).Names/Scopes.Lift\ def\ one\ level <fileName> <line> <column> Lift a local declaration one level up+	amenu Haskell(Refac).Names/Scopes.Demote\ def :Demote<cr>+	tmenu Haskell(Refac).Names/Scopes.Demote\ def <fileName> <line> <column> Demote a declaration to where it is used+	amenu Haskell(Refac).Names/Scopes.Create\ Type\ Signatures :RefacTypeSig<cr>+	tmenu Haskell(Refac).Names/Scopes.Create\ Type\ Signatures <fileName> Generates type signatures for top-level definitions using GHC.+	amenu Haskell(Refac).Names/Scopes.ReadFile :ParseAnswers<cr>+	tmenu Haskell(Refac).Names/Scopes.ReadFile <fileName> Read in an answer+	amenu Haskell(Refac).Names/Scopes.Convert\ Let\ to\ Where :LetToWhere<cr>+	tmenu Haskell(Refac).Names/Scopes.Convert\ Let\ to\ Where <fileName> <line> <column> Converts a let expression into a where equation.+	amenu Haskell(Refac).Names/Scopes.Convert\ Where\ to\ Let :WhereToLet<cr>+	tmenu Haskell(Refac).Names/Scopes.Convert\ Where\ to\ Let <fileName> <line> <column> Converts a where equation into a let expression+	amenu Haskell(Refac).Names/Scopes.Introduce\ patterns\ over\ an\ argument\ position :IntroPattern<cr>+	tmenu Haskell(Refac).Names/Scopes.Introduce\ patterns\ over\ an\ argument\ position <fileName> <line> <column> Replace variable with exhaustive set of patterns+	amenu Haskell(Refac).Names/Scopes.Introduce\ case\ analysis :IntroCase<cr>+	tmenu Haskell(Refac).Names/Scopes.Introduce\ case\ analysis <fileName> <line> <column> Introduction of cases analysis via a pattern variable+	amenu Haskell(Refac).Names/Scopes.Fold\ term\ against\ pattern\ variable :FoldPattern<cr>+	tmenu Haskell(Refac).Names/Scopes.Fold\ term\ against\ pattern\ variable <fileName> <name (Name of pattern variable: )> <line> <column> <line> <column> Folds a sub-expression against a pattern variable++	amenu Haskell(Refac).Slicing.Remove\ redundant\ declarations :RefacRedunDec<cr>+	tmenu Haskell(Refac).Slicing.Remove\ redundant\ declarations <fileName> <line> <column> <line> <column> Removes redundant declarations in a where clause or expression+	amenu Haskell(Refac).Slicing.Slicing\ based\ on\ a\ subexpression :RefacSlicing<cr>+	tmenu Haskell(Refac).Slicing.Slicing\ based\ on\ a\ subexpression <fileName> <line> <column> <line> <column> Slices a subexpression+	amenu Haskell(Refac).Slicing.Slicing\ a\ tuple :RefacSlicTuple<cr>+	tmenu Haskell(Refac).Slicing.Slicing\ a\ tuple <fileName> <line> <column> <name (Elements to slice: (A for all; (x,_x,_) for some): )> slices a definition which returns a tuple+	amenu Haskell(Refac).Slicing.Merge\ definitions :RefacMerge<cr>+	tmenu Haskell(Refac).Slicing.Merge\ definitions <fileName> <name (Name for new definition: )> Merges multiple definitions to form one single definition.+	amenu Haskell(Refac).Slicing.Add\ definition\ for\ merge :RefacCacheMerge<cr>+	tmenu Haskell(Refac).Slicing.Add\ definition\ for\ merge <fileName> <line> <column> Adds a definition to the cache for merging.+	amenu Haskell(Refac).Slicing.Instantiate\ a\ general\ pattern :RefacInstantiate<cr>+	tmenu Haskell(Refac).Slicing.Instantiate\ a\ general\ pattern <fileName> <line> <column> <name (patterns: )> Instantiates patterns in a generalised function clause++	amenu Haskell(Refac).Fold/Unfold.Unfold\ def :UnfoldDef<cr>+	tmenu Haskell(Refac).Fold/Unfold.Unfold\ def <fileName> <line> <column> Unfold a definition+	amenu Haskell(Refac).Fold/Unfold.Fold\ Definition :SubFunctionDef<cr>+	tmenu Haskell(Refac).Fold/Unfold.Fold\ Definition <fileName> <line> <column> <line> <column> Folds against a definition+	amenu Haskell(Refac).Fold/Unfold.Generative\ Fold\ of\ Definition :GenFold<cr>+	tmenu Haskell(Refac).Fold/Unfold.Generative\ Fold\ of\ Definition <fileName> <line> <column> <line> <column> Replace an instance of the right hand side of a definition by the corresponding left hand side, creating a new recursive definition.+	amenu Haskell(Refac).Fold/Unfold.Select\ an\ equation\ for\ generative\ fold :GenFoldCache<cr>+	tmenu Haskell(Refac).Fold/Unfold.Select\ an\ equation\ for\ generative\ fold <fileName> <line> <column> Places an selcted equation into a cache for use by generative fold.+	amenu Haskell(Refac).Fold/Unfold.Convert\ pattern\ to\ use\ an\ as\ pattern :RefacAsPatterns<cr>+	tmenu Haskell(Refac).Fold/Unfold.Convert\ pattern\ to\ use\ an\ as\ pattern <fileName> <name (Name for Pattern: )> <line> <column> <line> <column> Converts all appropriate patterns to use an as binding.+	amenu Haskell(Refac).Fold/Unfold.Unfold\ references\ to\ AS\ patterns :RefacUnfoldAsPatterns<cr>+	tmenu Haskell(Refac).Fold/Unfold.Unfold\ references\ to\ AS\ patterns <fileName> <line> <column> <line> <column> Converts all references to an as pattern to the actuall pattern.+	amenu Haskell(Refac).Fold/Unfold.Simplify\ Expression\ via\ Symbolic\ Evalutaion :SimplifyExpr<cr>+	tmenu Haskell(Refac).Fold/Unfold.Simplify\ Expression\ via\ Symbolic\ Evalutaion <fileName> <line> <column> <line> <column> Attempts to simplify a case expression.++	amenu Haskell(Refac).Definitions.Introduce\ new\ def :IntroNewDef<cr>+	tmenu Haskell(Refac).Definitions.Introduce\ new\ def <fileName> <name (Name for new definition? )> <line> <column> <line> <column> Introduce a new definition+	amenu Haskell(Refac).Definitions.Generalise\ def :GeneraliseDef<cr>+	tmenu Haskell(Refac).Definitions.Generalise\ def <fileName> <name (name of new parameter? )> <line> <column> <line> <column> Generalise a definition+	amenu Haskell(Refac).Definitions.Remove\ def :RemoveDef<cr>+	tmenu Haskell(Refac).Definitions.Remove\ def <fileName> <line> <column> Remove a definition if it is no used+	amenu Haskell(Refac).Definitions.Duplicate\ def :DuplicateDef<cr>+	tmenu Haskell(Refac).Definitions.Duplicate\ def <fileName> <name (Name for duplicate? )> <line> <column> Duplicate a definition at the same level+	amenu Haskell(Refac).Definitions.Add\ one\ parameter :AddOneParameter<cr>+	tmenu Haskell(Refac).Definitions.Add\ one\ parameter <fileName> <name (name of new parameter? )> <line> <column> Add parameter (default undefined)+	amenu Haskell(Refac).Definitions.Rm\ one\ parameter :RmOneParameter<cr>+	tmenu Haskell(Refac).Definitions.Rm\ one\ parameter <fileName> <line> <column> Remove unused parameter+	amenu Haskell(Refac).Definitions.Move\ def\ to\ another\ module :MoveDefBtwMod<cr>+	tmenu Haskell(Refac).Definitions.Move\ def\ to\ another\ module <fileName> <name (name of the destination module? )> <line> <column> Move a definition from one module to another module+	amenu Haskell(Refac).Definitions.Converts\ guards\ to\ an\ if\ then\ else :GuardToIte<cr>+	tmenu Haskell(Refac).Definitions.Converts\ guards\ to\ an\ if\ then\ else <fileName> <line> <column> Converts guards to an if then else+	amenu Haskell(Refac).Definitions.Shortcut\ Deforestration :Deforest<cr>+	tmenu Haskell(Refac).Definitions.Shortcut\ Deforestration <fileName> A (partial) implementation of the warm fusion algorithm++	amenu Haskell(Refac).Import/Export.Clean\ imports :CleanImports<cr>+	tmenu Haskell(Refac).Import/Export.Clean\ imports <fileName> Tidy up the import list of the current module+	amenu Haskell(Refac).Import/Export.Make\ import\ explicit :MkImpExplicit<cr>+	tmenu Haskell(Refac).Import/Export.Make\ import\ explicit <fileName> <line> <column> Make the used entities explicit+	amenu Haskell(Refac).Import/Export.Add\ to\ export :AddToExport<cr>+	tmenu Haskell(Refac).Import/Export.Add\ to\ export <fileName> <line> <column> Add an identifier to the export list+	amenu Haskell(Refac).Import/Export.Remove\ from\ export :RmFromExport<cr>+	tmenu Haskell(Refac).Import/Export.Remove\ from\ export <fileName> <line> <column> Remove an identifier from the export list++	amenu Haskell(Refac).Data\ types.Add\ field\ labels :AddFieldLabels<cr>+	tmenu Haskell(Refac).Data\ types.Add\ field\ labels <fileName> <line> <column> Add field labels to a data type declaration+	amenu Haskell(Refac).Data\ types.Add\ discriminators :AddDiscriminators<cr>+	tmenu Haskell(Refac).Data\ types.Add\ discriminators <fileName> <line> <column> Add discriminator functions to a data type declaration+	amenu Haskell(Refac).Data\ types.Add\ constructors :AddConstructors<cr>+	tmenu Haskell(Refac).Data\ types.Add\ constructors <fileName> <line> <column> Add constructor functions to a data type declaration+	amenu Haskell(Refac).Data\ types.Eliminate\ nested\ patterns :ElimNestedPatterns<cr>+	tmenu Haskell(Refac).Data\ types.Eliminate\ nested\ patterns <fileName> <line> <column> Eliminate nested pattern matchings+	amenu Haskell(Refac).Data\ types.Eliminate\ patterns :ElimPatterns<cr>+	tmenu Haskell(Refac).Data\ types.Eliminate\ patterns <fileName> <line> <column> Eliminate pattern matchings+	amenu Haskell(Refac).Data\ types.Create\ an\ ADT\ module :CreateADTMod<cr>+	tmenu Haskell(Refac).Data\ types.Create\ an\ ADT\ module <fileName> <line> <column> Create an new ADT module+	amenu Haskell(Refac).Data\ types.From\ concrete\ to\ abstract\ data\ type :FromAlgebraicToADT<cr>+	tmenu Haskell(Refac).Data\ types.From\ concrete\ to\ abstract\ data\ type <fileName> <line> <column> Transforms an algebraic data type to an ADT+	amenu Haskell(Refac).Data\ types.Add\ a\ new\ constructor\ to\ a\ data\ type :RefacAddCon<cr>+	tmenu Haskell(Refac).Data\ types.Add\ a\ new\ constructor\ to\ a\ data\ type <fileName> <name (Enter text for constructor and parameters: )> <line> <column> Adds a new constructor to a data type+	amenu Haskell(Refac).Data\ types.Remove\ a\ constructor\ from\ a\ data\ type :RefacRmCon<cr>+	tmenu Haskell(Refac).Data\ types.Remove\ a\ constructor\ from\ a\ data\ type <fileName> <line> <column> Removes constructor from a data type+	amenu Haskell(Refac).Data\ types.Remove\ a\ field\ from\ a\ data\ type :RefacRemoveField<cr>+	tmenu Haskell(Refac).Data\ types.Remove\ a\ field\ from\ a\ data\ type <fileName> <name (Enter position of field to be removed: )> <line> <column> Removes a field from a data type+	amenu Haskell(Refac).Data\ types.Add\ a\ field\ to\ a\ data\ type :RefacAddField<cr>+	tmenu Haskell(Refac).Data\ types.Add\ a\ field\ to\ a\ data\ type <fileName> <name (Type of Field : )> <line> <column> Adds a field to a data type++	amenu Haskell(Refac).Duplicate\ Code.Duplicate\ Code\ Analysis :DuplicateCode<cr>+	tmenu Haskell(Refac).Duplicate\ Code.Duplicate\ Code\ Analysis <fileName> <name (Clone Token Size: )> Analysis a project for code duplication.+	amenu Haskell(Refac).Duplicate\ Code.Transform\ Duplicate\ Code :RefacDupTrans<cr>+	tmenu Haskell(Refac).Duplicate\ Code.Transform\ Duplicate\ Code <fileName> <line> <column> <line> <column> Transforms duplicate code+	amenu Haskell(Refac).Duplicate\ Code.Identify\ Class :RefacIdentify<cr>+	tmenu Haskell(Refac).Duplicate\ Code.Identify\ Class <fileName> <line> <column> <line> <column> identifies a clone class++	amenu Haskell(Refac).Undo :Undo<cr>+	tmenu Haskell(Refac).Undo One step back in refactorer history++	amenu Haskell(Refac).-Custom- :+	amenu Haskell(Refac).version :echo g:haskell_refac_version<cr>+	amenu Haskell(Refac).customize :call Customize()<cr>+	tmenu Haskell(Refac).customize customize paths and options+	amenu Haskell(Refac).start :RefacStart<cr>+	tmenu Haskell(Refac).start start refactorer+	amenu Haskell(Refac).stop :RefacStop<cr>+	tmenu Haskell(Refac).stop stop refactorer++	amenu disable Haskell(Refac).*+	amenu enable Haskell(Refac).version+	amenu enable Haskell(Refac).customize+	amenu enable Haskell(Refac).start+++	let b:haskell_refac_menu = "yes"+endif++function! Customize()+  let current=bufname("%")+  if bufexists("customize")+      set switchbuf+=useopen+      sbuf ^customize$+    else+      new customize+  endif+  set buftype=nofile+  set bufhidden=delete+  set noswapfile+  execute "%d"+  set tw=0+  map <buffer> _ok :exe getline(3)<cr>:exe getline(4)<cr>:exe getline(5)<cr>:q<cr>+  call append(0,"let g:haskell_refac_showWindow=".g:haskell_refac_showWindow)+  call append(0,"let g:haskell_refac_chasePaths='".g:haskell_refac_chasePaths."'")+  call append(0,"let g:haskell_refac_refactorer='".g:haskell_refac_refactorer."'")+  call append(0,"\" (you might want to add these lines to your vimrc)")+  call append(0,"\" To customize, edit values, then type \"_ok\"")+endfunction++if has("win32")+  function! Haskell_refac_start()+    let @r=''+    redir @r+    silent execute ":!start /min ".g:haskell_refac_refactorer." vim ".escape($VIMRUNTIME,' ')."\\".v:progname." ".v:servername+    au VimLeave * call Haskell_refac_client_cmd('stop')+    redir END+    call Haskell_refac_msg(0,@r)+  +    amenu enable Haskell(Refac).*+    amenu disable Haskell(Refac).start+    amenu disable Haskell(Refac).customize+  endfunction++  function! Haskell_refac_client_cmd(cmd)+    let @r=''+    redir @r+    "to rescue users of behave mswin+    normal gV+    silent execute ":!start /min ".g:haskell_refac_refactorer_client." ".a:cmd+    redir END+    call Haskell_refac_msg(0,@r)+  endfunction+else+  if executable(v:progname)+    function! Haskell_refac_start()+      let @r=''+      redir @r+      silent execute ":!".g:haskell_refac_refactorer." vim ".v:progname." ".v:servername." >log.txt 2>&1 &"+      au VimLeave * call Haskell_refac_client_cmd('stop')+      redir END+      call Haskell_refac_msg(0,@r)+    +      amenu enable Haskell(Refac).*+      amenu disable Haskell(Refac).start+      amenu disable Haskell(Refac).customize+    endfunction++    function! Haskell_refac_client_cmd(cmd)+      let @r=''+      redir @r+      silent execute ":!".g:haskell_refac_refactorer_client." ".a:cmd+      redir END+      call Haskell_refac_msg(0,@r)+    endfunction+  else+  echoerr "cannot find path to executable"+  endif+endif++function! Haskell_refac_stop()+  call Haskell_refac_client_cmd('stop')++  amenu disable Haskell(Refac).*+  amenu enable Haskell(Refac).start+  amenu enable Haskell(Refac).version+  amenu enable Haskell(Refac).customize+endfunction++command! RefacStart :call Haskell_refac_start()+command! RefacStop :call Haskell_refac_stop()++function! Haskell_refac_modified(f)+    set switchbuf+=useopen+    if bufexists(a:f)+      execute ":sbuf ".a:f+      edit+    else+      call Haskell_refac_msg(1,"modified file: ".a:f."  (not currently opened)")+    endif+endfunction++function! Haskell_refac_msg(dialog,msg)+  let visible = bufwinnr('^refac$')+  if bufexists('^refac$')+    set switchbuf+=useopen+    sbuf ^refac$+    call append(line('$'),a:msg)+    if visible==-1 +      hide +    else +      sbuf % +    endif+  else+    hide new refac+    set bufhidden=hide+    set buftype=nofile+    set noswapfile+    call append(line('$'),a:msg)+    hide+  endif+ if a:dialog+   call confirm(a:msg)+ endif+endfunction++"--------------------- HaRe selection++function! Hare_withSelection(existsCmd,emptyCmd)+  let visible = bufwinnr('^hare-selection$')+  if bufexists('hare-selection')+    set switchbuf+=useopen+    sbuf ^hare-selection$++    exe a:existsCmd++    if visible==-1 +      hide +    else +      sbuf % +    endif+  else++    exe a:emptyCmd+    +  endif+endfunction++function! Hare_createSelection(entry)+  hide new hare-selection+  set bufhidden=hide+  set buftype=nofile+  set noswapfile+  map <buffer> <cr> :call Hare_sel_goto(0) <cr>+  call setline(1,a:entry)+  hide+endfunction++function! Hare_sel_clear()+  call Hare_withSelection(":bunload! hare-selection",":call confirm('empty selection')")+endfunction++function! Hare_sel_add_aux(entry)+  if nextnonblank(1)+    call append(line('$'),a:entry)+  else+    call setline(1,a:entry)+  endif+endfunction++function! Hare_sel_add()+  let l=line(".")+  let c=col(".")+  let entry="\"" . bufname("") . "\" " . l . " " . c . " : " . getline(l)+  let entry='"'.escape(entry,'"').'"'+  call Hare_withSelection(":call Hare_sel_add_aux(".entry.")",":call Hare_createSelection(".entry.")")+endfunction++function! Hare_sel_delete()+  let l=line(".")+  let c=col(".")+  let prefix="\"" . bufname("") . "\" " . l . " " . c . " : "+  call Hare_withSelection(":g/^".prefix."/d",":call confirm('empty selection')")+endfunction++function! Hare_sel_display()+  if bufexists('hare-selection')+    set switchbuf+=useopen+    sbuf ^hare-selection$+    normal J+    resize 5+  else+    call confirm('empty selection')+  endif+endfunction++function! Hare_sel_goto(motion)+  let visible = bufwinnr('^hare-selection$')+  if bufexists('hare-selection')+    set switchbuf+=useopen+    sbuf ^hare-selection$+    call cursor(line(".")+a:motion,0)+    let l=getline(".")+    let buffer=matchstr(l,"\"[^\"]*\" ")+    let buffer=strpart(buffer,1,strlen(buffer)-3)+    let i=matchend(l,"\"[^\"]*\" ")+    let l=strpart(l,i)+    let lnr=matchstr(l,"[0-9][0-9]*")+    let j=stridx(l," ")+    let cnr=matchstr(l,"[0-9][0-9]*",j)+    if visible==-1 +      hide +    else +      sbuf % +    endif+    "call confirm(buffer ." ".lnr." ".cnr)+    exe ":sbuf " . buffer+    call cursor(lnr,cnr)+  else+    call confirm('empty selection')+  endif+endfunction++amenu Haskell(Refac).Selection.Clear\ selection :call Hare_sel_clear()<cr>+tmenu Haskell(Refac).Selection.Clear\ selection clear selection+amenu Haskell(Refac).Selection.Add\ to\ selection :call Hare_sel_add()<cr>+tmenu Haskell(Refac).Selection.Add\ to\ selection add current position to selection+amenu Haskell(Refac).Selection.Delete\ from\ selection :call Hare_sel_delete()<cr>+tmenu Haskell(Refac).Selection.Delete\ from\ selection delete current position from selection+amenu Haskell(Refac).Selection.Show\ selection :call Hare_sel_display()<cr>+tmenu Haskell(Refac).Selection.Show\ selection show selection+amenu Haskell(Refac).Selection.Visit\ next\ entry :call Hare_sel_goto(1)<cr>+tmenu Haskell(Refac).Selection.Visit\ next\ entry visit next entry+amenu Haskell(Refac).Selection.Visit\ current\ entry :call Hare_sel_goto(0)<cr>+tmenu Haskell(Refac).Selection.Visit\ current\ entry visit current entry+amenu Haskell(Refac).Selection.Visit\ previous\ entry :call Hare_sel_goto(-1)<cr>+tmenu Haskell(Refac).Selection.Visit\ previous\ entry visit previous entry++
+ refactorer/._Evaluate.hs view
binary file changed (absent → 309 bytes)
+ refactorer/._LocalSettings.hs view
binary file changed (absent → 305 bytes)
+ refactorer/._RefacAddCon.hs view
binary file changed (absent → 313 bytes)
+ refactorer/._RefacGenDef.hs view
binary file changed (absent → 308 bytes)
+ refactorer/._RefacIntroPattern.hs view
binary file changed (absent → 308 bytes)
+ refactorer/._RefacLetWhere.hs view
binary file changed (absent → 308 bytes)
+ refactorer/._RefacMerge.hs view
binary file changed (absent → 308 bytes)
+ refactorer/._RefacMoveDef.hs view
binary file changed (absent → 308 bytes)
+ refactorer/._RefacNewDef.hs view
binary file changed (absent → 309 bytes)
+ refactorer/._RefacSimplify.hs view
binary file changed (absent → 309 bytes)
+ refactorer/._RefacSlicTuple.hs view
binary file changed (absent → 308 bytes)
+ refactorer/._RefacTypeSig.hs view
binary file changed (absent → 306 bytes)
+ refactorer/._RefacUtils.hs view
binary file changed (absent → 312 bytes)
+ refactorer/._TypeCheck.hs view
binary file changed (absent → 314 bytes)
+ refactorer/AddRefactoringToInterface.txt view
@@ -0,0 +1,90 @@+
+--------------------- How to add a refactoring to the editor interface -----------------
+
+After having built a refactoring, in order to invoke the refactoring from the editor interface, 
+you only need to modify the file:'GenEditorInterfaces.hs' from the 'editors' directory.
+
+Next, we take the two refactorings :'swapping arguments' and "from if-then-else to Case" as examples 
+to explain where and how to modify. Assume you are now ready to edit the 'GenEditorInterfaces.hs'. 
+
+1) Swapping arguments. This refactoring is implemented in the module 'RefacSwapArgs' in file
+   'RefacSwapArgs.hs'. The refactoring name is 'swapArgs', and is the only name exported by this
+   module. 
+
+Step 1. Find the definition of 'pfeRefactoringCmds'. In the right hand side, you can find a 
+        do statement like: putStrLn $ unlines [ ... ]. Add ',"import RefacSwapArgs"  right 
+        after the second-last element in the list. 
+
+Step 2. Find the definition of 'cmds' which defines the menu structure. Add an entry for swapping
+        arguments in an proper sub-menu, say 'Definitions' in this case, like this:
+
+           editParameters "Swap Arguments" "swapArgs" 
+           swapArgs $ fileName $ positionPar $ 
+           comment "Swap the first two arguments of a function"
+
+        where, "Swap Arguments" is what will appear in the menu menu, "swapArgs" again is the
+        refactoring  name. This refactoring takes a file name and a position (lines number and
+        column number) as parameters ('Par' means parameter).
+
+Step 3. Add a top-level function named as 'swapArgs' (same as the refactoring name) including its 
+        type signature to this module. This function just prints out some information about the 
+        parameters. In the case for 'swapArgs', it can be like:
+
+          swapArgs :: String -> Int -> Int -> IO ()
+          swapArgs f l c = putStrLn $ ">swapArgs filename: " ++f++" line: "++show l ++" column: " ++ show c
+
+Step 4. Go to the root directory of HaRe , say HaRe_19112004, and run: make.
+
+
+Step 5. Reload the interface file for your editor (In emacs : M-x load-file editors/haskell-refac.el), you
+        should be able to see the newly added entry in the Definitions sub-menu in the Refactor menu.
+
+2). From If-then-else to Case.
+
+    Follow the same steps as for swapping arguments. The only differences are in step 2 and 3.
+ 
+    In step 2, when adding an entry to 'cmds', use 'regionPar' other than 'positionPar', as this 
+    refactoring needs the user to highlight an area in the program source. So in the definition of 
+    'cmds' you need to add:
+
+        editParameters "From if to case" "ifToCase"
+          ifToCase $ fileNamePar $ regionPar $
+          comment "From it to case"
+
+
+    In step 3, Corresponding to step 2, add the following function to the module. This function 
+    takes four Int parameters which represent the start and end position of the highlighted area.
+
+      ifToCase :: String ->Int -> Int -> Int -> Int -> IO ()
+      ifToCase f ls cs le ce = putStrLn $
+           ">from if to case: "++f
+           ++" line: "++show ls++" column: "++show cs
+           ++" line: "++show le++" column: "++show ce
+
+Note: All the above code actually is already there, just has been commented out.
+
+
+
+
+
+    
+ 
+        
+
+
+       
+
+        
+
+     
+       
+         
+
+   
+       
+ 
+   
+    
+ 
+
+ 

+ refactorer/DuplicateCode.hs view
@@ -0,0 +1,997 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  DuplicateCode+-- Copyright   :  (c) Christopher Brown 2007+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a duplicate code analysis tool+-- that works over the HaRe infrastructure.+-- Comparing two Haskell source files at the token stream level+-- this module constructs a report based on the structural +-- duplication of the two source files.+--+-- VERSION+-- -------+-- 02 January 2007: 0.0 -- basic implementation set up.+-- 22 Januray 2007: 0.1 -- fully working alpha equivalence with textual output+--                         in the form of a report.+--+-- 31 July 2008: 0.2  -- rewrite to compare expressions via AST using +--                       avoidance of capture.+--+-----------------------------------------------------------------------------++module DuplicateCode where+import Time+import PrettyPrint+import System.IO.Unsafe+import PosSyntax hiding (ModuleName, HsName, SN)+import SourceNames +import ScopeModule+import UniqueNames hiding (srcLoc)+import HsName+import HsLexerPass1+import PNT +import TiPNT+import SimpleGraphs(reverseGraph,reachable)+import HsTokens+import RefacTypeSyn+import RefacLocUtils+import Data.Char+import GHC.Unicode+import AbstractIO+import Maybe+import List+import RefacUtils+import LocalSettings+import Data.Function+import RefacGenFold (expToPat)+++-- as this module is not a transformation, we will not need to modify+-- the source files in question. It is still necessary to import the +-- HaRe API, in all it's glory, to gain access to tree traversals.++type Group = ([HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP],[HsExpP]) ++emptyGroup = ([],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[])+++-- define the clone type; E = clone is an Expression;+--                        G = clone is a list of Generators: monadic patterns;+--                        S = clone is a monadic sequence (including generators).+data CloneType = E (HsExpP, String) | G (HsStmtP, String) | S (HsStmtP, String)+                    deriving (Eq, Show, Read, Ord)++-- the filenames need to be given with their full file path+-- unless they appear in the same directory as the executable.++-- We use the concept of a line number quite a lot, so let's define it:++type LineNumber = Int++-- the idea is to look for expressions of a particular+-- size and repetition. For the moment, we use two constants+-- to define this...+-- expressionSize = 5+-- expression size is a variable to determine the size of the expressions+-- we need to look for expressions as close to size 10 as possible.++expressionRep = 1+-- expressionRep determines how many times a particular expression+-- may occur in a code clone. +-- for example: x + y + z      x + y occurs twice...+++duplicateCode args+  = do let +           fileName1    = args!!0    +           expressionSize = read (args!!1) :: Int  +       AbstractIO.putStrLn "duplicateCode Analysis" +       timeone <- AbstractIO.getClockTime+       -- we work over a project, so we take the name of the current +       -- (hopefully main module) and work over it all, in turn....+       let fileName2 = fileName1+       modName <- fileNameToModName fileName1+       +       -- the analysis should be perform over the main module...+       -- get a list of all the modules that are imported directly, or indirectly,+       -- by Main...+       servers<-serverModsAndFiles modName -- returns [(module name ,filename)] +       -- we arn't interested in the libraries yet though.+       -- I guess it's OK to strip away those not defined in current directory...+              +       let directory = getDirectory fileName1+           servers' = stripServers servers directory+       rest <- parseAll expressionSize servers' -- hardServers  +       modInfo1@(inscps1, exps1, mod1, tokList1) <- parseSourceFile fileName1+       -- for each module in our project, we need to normalise the token streams.+       -- we then concatenate the token streams together, and perform+       -- a big analysis over that. Question? How do we remember+       -- which module we are talking about?+       -- tokList1' <- normaliseTokens fileName1 mod1 tokList1+       -- AbstractIO.putStrLn tokList1'++       -- normalize the AST. We Alpa-Reduce all local variables+       -- to "$" (as they can be passed in as parameters)+       -- top level decs are left alone.+       -- mod' <- renameAST mod1+       +       asts <- genExpList expressionSize tokList1 mod1+       let groupAST = groupExps asts emptyGroup+       duplications <- loop expressionSize ((mod1, tokList1, fileName1, groupAST):rest) +       duplications' <- removeDuplicates (concat duplications)+       -- display generates a report of the duplications+       -- and writes them to a file for further processing...+       +       let display = prettyPrint duplications' (map (\(x,y,z,_) -> (y,z)) ((mod1, tokList1, fileName1, groupAST):rest)) +           duplications'' = prettyPrint2 duplications' (map (\(x,y,z,_) -> (y,z)) ((mod1, tokList1, fileName1, groupAST):rest)) +       AbstractIO.writeFile reportFilePath display+       +       -- for now, print this to the screen also+       AbstractIO.writeFile transFilePath (show duplications'')+       AbstractIO.writeFile answerFilePath ""+       AbstractIO.putStrLn ("Clone analysis complete. Report delivered to: " ++ reportFilePath)+       timetwo <- AbstractIO.getClockTime  +       AbstractIO.putStrLn $ show $ diffClockTimes timetwo timeone++--Takes an AST and returns a list of tuples containing the string equivalent of the+-- Expression name, and the start & finish locations of the Expression+-- genExpList :: (Term t) => t -> [HsExpP]+genExpList expressionSize tokList ast = applyTU (full_tdTU ( constTU [] `adhocTU` isExp)) ast+    where +    +             isExp (Exp (HsTuple [])) = return []+             isExp (Exp (HsList [])) = return []+             isExp (Exp (HsLet _ _)) = return []+             isExp (a::HsExpP)= do+                                let (start, end)  = getStartEndLoc tokList a+                                let tokExpression = getToks (start, end) tokList+                                if (length (filter (not. isWhite') tokExpression)) < expressionSize+                                     then return []+                                     else return [a]+++getGroup :: HsExpP -> Group -> [HsExpP]+getGroup (Exp (HsId x)) g = getId g+getGroup (Exp (HsLit s i)) g = getLit g+getGroup (Exp (HsInfixApp _ _ _)) g = getInfix g+getGroup (Exp (HsApp _ _)) g = getApp g+getGroup (Exp (HsNegApp _ _)) g = getNegApp g+getGroup (Exp (HsLambda _ _)) g = getLambda g+getGroup (Exp (HsLet _ _)) g = getLet g+getGroup (Exp (HsIf _ _ _)) g = getIf g+getGroup (Exp (HsCase _ _)) g = getCase g+getGroup (Exp (HsDo _)) g = getDo g+getGroup (Exp (HsTuple _)) g = getTuple g+getGroup (Exp (HsList _)) g = getList g+getGroup (Exp (HsParen _)) g = getParen g+getGroup (Exp (HsLeftSection _ _)) g = getLeft g+getGroup (Exp (HsRightSection _ _)) g = getRight g+getGroup (Exp (HsRecConstr _ _ _)) g = getRecConstr g+getGroup (Exp (HsRecUpdate _ _ _)) g = getRecUpdate g+getGroup (Exp (HsEnumFrom _)) g = getEnumFrom g+getGroup (Exp (HsEnumFromTo _ _)) g = getEnumFromTo g+getGroup (Exp (HsEnumFromThen _ _)) g = getEnumFromThen g+getGroup (Exp (HsEnumFromThenTo _ _ _)) g = getEnumFromThenTo g+getGroup (Exp (HsListComp _)) g = getListComp g+getGroup (Exp (HsExpTypeSig _ _ _ _)) g = getTypeSig g+getGroup (Exp (HsAsPat _ _)) g = getAsPat g+getGroup (Exp (HsWildCard)) g = getWildCard g+getGroup (Exp (HsIrrPat _)) g = getIrrPat g++getId :: Group -> [HsExpP]+getId (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = a+getLit :: Group -> [HsExpP]+getLit (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = b+getInfix :: Group -> [HsExpP]+getInfix (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = c+getApp :: Group -> [HsExpP]+getApp (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = d+getNegApp :: Group -> [HsExpP]+getNegApp (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = e+getLambda :: Group -> [HsExpP]+getLambda (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = f+getLet :: Group -> [HsExpP]+getLet (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = g+getIf :: Group -> [HsExpP]+getIf (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = h +getCase :: Group -> [HsExpP]+getCase (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = i +getDo :: Group -> [HsExpP]+getDo (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = j  +getTuple :: Group -> [HsExpP]+getTuple (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = k+getList :: Group -> [HsExpP]+getList (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = l +getParen :: Group -> [HsExpP]+getParen (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = m+getLeft :: Group -> [HsExpP]+getLeft (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = n+getRight :: Group -> [HsExpP]+getRight (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = o  +getRecConstr :: Group -> [HsExpP]+getRecConstr (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = p +getRecUpdate :: Group -> [HsExpP]+getRecUpdate (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = q +getEnumFrom :: Group -> [HsExpP]+getEnumFrom (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = r +getEnumFromTo :: Group -> [HsExpP]+getEnumFromTo (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = s +getEnumFromThen :: Group -> [HsExpP]+getEnumFromThen (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = t  +getEnumFromThenTo :: Group -> [HsExpP]+getEnumFromThenTo (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = u +getListComp :: Group -> [HsExpP]+getListComp (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = v +getTypeSig :: Group -> [HsExpP]+getTypeSig (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = w +getAsPat :: Group -> [HsExpP]+getAsPat (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = x +getWildCard :: Group -> [HsExpP]+getWildCard (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = y +getIrrPat :: Group -> [HsExpP]+getIrrPat (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = z  +++     +groupExps :: [HsExpP] -> Group -> Group+groupExps [] g = g+groupExps (e@(Exp (HsId x)):es) g = groupExps es (addId e g)+groupExps (e@(Exp (HsLit s i)):es) g = groupExps es (addLit e g)+groupExps (e@(Exp (HsInfixApp _ _ _)):es) g = groupExps es (addInfix e g)+groupExps (e@(Exp (HsApp _ _)):es) g = groupExps es (addApp e g)+groupExps (e@(Exp (HsNegApp _ _)):es) g = groupExps es (addNegApp e g)+groupExps (e@(Exp (HsLambda _ _)):es) g = groupExps es (addLambda e g)+groupExps (e@(Exp (HsLet _ _)):es) g = groupExps es (addLet e g)+groupExps (e@(Exp (HsIf _ _ _)):es) g = groupExps es (addIf e g)+groupExps (e@(Exp (HsCase _ _)):es) g = groupExps es (addCase e g)+groupExps (e@(Exp (HsDo _)):es) g = groupExps es (addDo e g)+groupExps (e@(Exp (HsTuple _)):es) g = groupExps es (addTuple e g)+groupExps (e@(Exp (HsList _)):es) g = groupExps es (addList e g)+groupExps (e@(Exp (HsParen _)):es) g = groupExps es (addParen e g)+groupExps (e@(Exp (HsLeftSection _ _)):es) g = groupExps es (addLeft e g)+groupExps (e@(Exp (HsRightSection _ _)):es) g = groupExps es (addRight e g)+groupExps (e@(Exp (HsRecConstr _ _ _)):es) g = groupExps es (addRecConstr e g)+groupExps (e@(Exp (HsRecUpdate _ _ _)):es) g = groupExps es (addRecUpdate e g)+groupExps (e@(Exp (HsEnumFrom _)):es) g = groupExps es (addEnumFrom e g)+groupExps (e@(Exp (HsEnumFromTo _ _)):es) g = groupExps es (addEnumFromTo e g)+groupExps (e@(Exp (HsEnumFromThen _ _)):es) g = groupExps es (addEnumFromThen e g)+groupExps (e@(Exp (HsEnumFromThenTo _ _ _)):es) g = groupExps es (addEnumFromThenTo e g)+groupExps (e@(Exp (HsListComp _)):es) g = groupExps es (addListComp e g)+groupExps (e@(Exp (HsExpTypeSig _ _ _ _)):es) g = groupExps es (addTypeSig e g)+groupExps (e@(Exp (HsAsPat _ _)):es) g = groupExps es (addAsPat e g)+groupExps (e@(Exp (HsWildCard)):es) g = groupExps es (addWildCard e g)+groupExps (e@(Exp (HsIrrPat _)):es) g = groupExps es (addIrrPat e g)++addId :: HsExpP -> Group -> Group+addId e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = ((a++[e1]),b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+addLit :: HsExpP -> Group -> Group+addLit e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,(b++[e1]),c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+addInfix :: HsExpP -> Group -> Group+addInfix e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,(c++[e1]),d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+addApp :: HsExpP -> Group -> Group+addApp e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,(d++[e1]),e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+addNegApp :: HsExpP -> Group -> Group+addNegApp e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,(e++[e1]),f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+addLambda :: HsExpP -> Group -> Group+addLambda e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,(f++[e1]),g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+addLet :: HsExpP -> Group -> Group+addLet e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,(g++[e1]),h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+addIf :: HsExpP -> Group -> Group+addIf e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,(h++[e1]),i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) +addCase :: HsExpP -> Group -> Group+addCase e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,(i++[e1]),j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) +addDo :: HsExpP -> Group -> Group+addDo e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,(j++[e1]),k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)  +addTuple :: HsExpP -> Group -> Group+addTuple e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,(k++[e1]),l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) +addList :: HsExpP -> Group -> Group+addList e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,(l++[e1]),m,n,o,p,q,r,s,t,u,v,w,x,y,z) +addParen :: HsExpP -> Group -> Group+addParen e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,(m++[e1]),n,o,p,q,r,s,t,u,v,w,x,y,z)+addLeft :: HsExpP -> Group -> Group+addLeft e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,(n++[e1]),o,p,q,r,s,t,u,v,w,x,y,z)+addRight :: HsExpP -> Group -> Group+addRight e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,(o++[e1]),p,q,r,s,t,u,v,w,x,y,z)  +addRecConstr :: HsExpP -> Group -> Group+addRecConstr e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,(p++[e1]),q,r,s,t,u,v,w,x,y,z) +addRecUpdate :: HsExpP -> Group -> Group+addRecUpdate e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,(q++[e1]),r,s,t,u,v,w,x,y,z) +addEnumFrom :: HsExpP -> Group -> Group+addEnumFrom e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,(r++[e1]),s,t,u,v,w,x,y,z) +addEnumFromTo :: HsExpP -> Group -> Group+addEnumFromTo e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,(s++[e1]),t,u,v,w,x,y,z) +addEnumFromThen :: HsExpP -> Group -> Group+addEnumFromThen e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,(t++[e1]),u,v,w,x,y,z)  +addEnumFromThenTo :: HsExpP -> Group -> Group+addEnumFromThenTo e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,(u++[e1]),v,w,x,y,z) +addListComp :: HsExpP -> Group -> Group+addListComp e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,(v++[e1]),w,x,y,z) +addTypeSig :: HsExpP -> Group -> Group+addTypeSig e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,(w++[e1]),x,y,z) +addAsPat :: HsExpP -> Group -> Group+addAsPat e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,(x++[e1]),y,z) +addWildCard :: HsExpP -> Group -> Group+addWildCard e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,w,r,s,t,u,v,w,x,(y++[e1]),z) +addIrrPat :: HsExpP -> Group -> Group+addIrrPat e1 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z)+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,(z++[e1]))   +loop _ [] = return []+loop eSize a@((x,y,m,g):xs)+  = do +        let list' = numberList 0 ((x,y,m,g):xs)+        dups <- mapM (calculateInstances eSize (x,y,m,g)) ((x,y,m,g):xs)+        dups' <- loop' eSize ((tail list')++[(x,y,m,g,0)]) 0+        return (dups ++ dups')+        -- return dups' +          where+             numberList _ [] = []+             numberList n ((x,y,m,g):xs) = (x,y,m,g,n):numberList (n+1) xs+++loop' _ [] _ = return []+loop' eSize ((x,y,m,g,z):xs) n + | z == n = return []+ | otherwise = do+                  dups <- mapM (calculateInstances eSize (x,y,m,g)) ((x,y,m,g):(map (\(x,y,m,g,z) -> (x,y,m,g)) xs))+                  rest <- loop' eSize (xs++[(x,y,m,g,z)]) n +                  -- return rest+                  return (dups ++ rest)+++parseAll _ [] = return []+parseAll eSize ((m,f):xs) = do+                          (_,_,mod, tok) <- parseSourceFile f+                          rest <- parseAll eSize xs+                          modName <- fileNameToModName f+                          asts <- genExpList eSize tok mod+                          let groupAST = groupExps asts emptyGroup+                          return ((mod, tok, f, groupAST) : rest)++normaliseTokens f mod t+  = do+       let whiteRemoved = filter (not. isWhite') t+           normalised = removedIdents f mod whiteRemoved+           normalised' = stringIt normalised+       return normalised'+        where+          removedIdents :: Term t => String -> t -> [PosToken] -> [PosToken]+          removedIdents _ _ [] = []+          removedIdents f mod (a@(Varid, (Pos x y z,s)):xs)   +             | findTopLevel f y z mod = a : removedIdents f mod xs+             | otherwise = (Varid, (Pos x y z,"$")) : removedIdents f mod xs+          removedIdents f mod (a@(Conid, (Pos x y z,s)):xs)+             | findTopLevel f y z mod = a : removedIdents f mod xs+             | otherwise = (Conid, (Pos x y z,"$")) : removedIdents f mod xs+          removedIdents f mod (a@(Varsym, (Pos x y z,s)):xs)+             | findTopLevel f y z mod = a : removedIdents f mod xs+             | otherwise = (Varsym, (Pos x y z,"$")) : removedIdents f mod xs+          removedIdents f mod (a@(Consym, (Pos x y z,s)):xs)+             | findTopLevel f y z mod = a : removedIdents f mod xs+             | otherwise = (Consym, (Pos x y z,"$")) : removedIdents f mod xs+             +          removedIdents f mod (a@(Qvarid, (Pos x y z,s)):xs)   +             | findTopLevel f y z mod = a : removedIdents f mod xs+             | otherwise = (Qvarid, (Pos x y z,"$")) : removedIdents f mod xs+          removedIdents f mod (a@(Qconid, (Pos x y z,s)):xs)+             | findTopLevel f y z mod = a : removedIdents f mod xs+             | otherwise = (Qconid, (Pos x y z,"$")) : removedIdents f mod xs+          removedIdents f mod (a@(Qvarsym, (Pos x y z,s)):xs)+             | findTopLevel f y z mod = a : removedIdents f mod xs+             | otherwise = (Qvarsym, (Pos x y z,"$")) : removedIdents f mod xs+          removedIdents f mod (a@(Qconsym, (Pos x y z,s)):xs)+             | findTopLevel f y z mod = a : removedIdents f mod xs+             | otherwise = (Qconsym, (Pos x y z,"$")) : removedIdents f mod xs+          removedIdents f mod (a@(IntLit, (Pos x y z,s)):xs)+             = (IntLit, (Pos x y z, "$")) : removedIdents f mod xs+          removedIdents f mod (a@(FloatLit, (Pos x y z,s)):xs)+             = (FloatLit, (Pos x y z, "$")) : removedIdents f mod xs+          removedIdents f mod (a@(CharLit, (Pos x y z,s)):xs)+             = (CharLit, (Pos x y z, "$")) : removedIdents f mod xs+          removedIdents f mod (a@(StringLit, (Pos x y z,s)):xs)+             = (StringLit, (Pos x y z, "$")) : removedIdents f mod xs+          removedIdents f mod (x:xs) = x: removedIdents f mod xs+                     +          findTopLevel :: Term t => String -> Int -> Int -> t -> Bool           +          findTopLevel f x y t = isTopLevelPNT (locToPNT f (x,y) t)++getDirectory :: String -> String+getDirectory f+  = reverse $ dropWhile (=='/') (dropWhile (/='/') (reverse f))+  +stripServers :: [(ModuleName, String)] -> String -> [(ModuleName, String)]+stripServers [] d = []+stripServers (a@(x,y):xs)  d+ | d == getDirectory y = a : stripServers xs d+ | otherwise           = stripServers xs d++addIndex :: [ [(a,b)] ] -> [ [(a,b,Int)] ]+addIndex (x:xs) = addIndex' 0 x : addIndex xs+                    where+                      addIndex' i ((x,y):xs) = (x,y,i) : addIndex' (i+1) xs +++-- removeDuplicates = groupBy (foldExp `on` fst) . nub . concat++removeDuplicates x = do let x' = nubBy sameOccurrence (sort (concat x))++                        es <- mapM renameExp' x'+                        let g' = groupBy (foldExpOrDo `on` (\(x,y,z) -> x)) es +                            x2 = removeSubEntities  $ nubBy (sameOccurrence2 `on` fst) (map (\(x,y,z) -> (y,z)) (concat (remove1Ele g')))+                        es2 <- mapM renameExp' x2+                        let g2 = groupBy (foldExpOrDo `on` (\(x,y,z) -> x)) es2++                        return g2+                        +foldExpOrDo :: HsExpP -> HsExpP -> Bool+foldExpOrDo e@(Exp (HsDo _)) e2@(Exp (HsDo _))+ = foldDoNormal [] [] e e2+foldExpOrDo e1 e2 = foldExp [] [] e1 e2                  +                        +remove1Ele [] = []+remove1Ele (x:xs) + | length x == 1 = remove1Ele xs+ | otherwise = x : remove1Ele xs++++removeSubEntities' x [] = False+removeSubEntities' (x,z) ((y,m):ys)+  | findEntityWithLocation x y && z == m = True+  | otherwise = removeSubEntities' (x,z) ys++removeSubEntities (x:xs)+  | removeSubEntities' x xs = removeSubEntities2  x (xs++[x])+  | otherwise = x : removeSubEntities2  x (xs++[x])+removeSubEntities [] = []+  +removeSubEntities2 x (y:ys) + | x == y = []+ | removeSubEntities' y ys = removeSubEntities2  x (ys++[y]) + | otherwise = y : removeSubEntities2  x (ys++[y])  ++takeSubEntities (x:xs)+ | removeSubEntities' x xs = x : takeSubEntities2 x (xs++[x])+ | otherwise = takeSubEntities2 x (xs ++ [x])+takeSubEntities2 x (y:ys)+ | x == y = []+ | removeSubEntities' y ys = y : takeSubEntities2 x (ys++[y])+ | otherwise = takeSubEntities2 x (ys++[y])+++renameExp' (a,b) = do+                       a' <- renameExp a+                       return (a',a,b)++-- a variation on groupBy; groups by comparing one element to all other elements...+-- groupBy' 		::  (a -> a -> Bool) -> [a] -> [b] -> [[b]]+groupBy' _  []	[]	=  []+groupBy' eq (x:xs) (a:as)	=  (a:ys) : groupBy' eq xs' as'+                              where ((ls,ys),(os, zs)) = span' (eq x) xs as+                                    (xs', as') = filterIt ys xs as+                                    +                                    filterIt _ [] [] = ([],[])+                                    filterIt _ [] _  = ([],[])+                                    filterIt _ _ []  = ([],[])+                                    filterIt list1 (x:xs) (y:ys)+                                      | y `elem` list1 = filterIt list1 xs ys+                                      | otherwise = let (ls, zs) = filterIt list1 xs ys in  (x:ls, y:zs)+                                     +                 +span'                    :: (a -> Bool) -> [a] -> [b] -> (([a], [b]),([a], [b]))+span' _ xs@[] ys@[]           =  ((xs,ys),(xs, ys))+span' p xs@(x:xs') ds@(a:as')+         | p x          =  let ((ls,ys),(os,zs)) = span' p xs' as' in (((x:ls),(a:ys)),(os,zs))+         | otherwise    =  span' p xs' as'  -- (([],[]),(xs',as'))+      +calculateInstances expressionSize a@(mod1, tokList1, name1, group) b@(mod2, tokList2, name2, group2)+ = do  +       rest <- (applyTU (full_tdTU (constTU [] `adhocTU` inExp)) mod1)+       return rest+     where+       inExp (e1::HsExpP)+         = do+             -- res <- traverseExp a b e1 +             -- AbstractIO.putStrLn ("comparing " ++ name1 ++ " with " ++ name2)+             res <- findExp expressionSize a b e1  +             if res == []+               then return []+               else return res+         ++findExp _ _ _ (Exp (HsList [])) = return []+findExp _ _ _ (Exp (HsTuple [])) = return [] +findExp _ _ _ (Exp (HsLet _ _)) = return []+findExp expressionSize (mod1, tokList1, name1, group1) (mod2, tokList2, name2, group2) e1@(Exp (HsDo _))+ = do+        let (start, end)  = getStartEndLoc tokList1 e1+        let tokExpression = getToks (start, end) tokList1   +        if (length (filter (not. isWhite) tokExpression)) < expressionSize+             then return []+             else -- find occurrences of this expression within mod2+              do+               newE1 <- renameExp e1+               occurs <- findExpressionDo (e1,name1) newE1 (mod2, tokList2, name2) (getGroup newE1 group2)+               if occurs == []+                then return []+                else do +                  return [occurs]+findExp expressionSize (mod1, tokList1, name1, group1) (mod2, tokList2, name2, group2) e1+ = do+        -- tokenize expression+        -- tokenized expression must be bigger than+        -- expressionSize!+        let (start, end)  = getStartEndLoc tokList1 e1+        let tokExpression = getToks (start, end) tokList1   +        if (length (filter (not. isWhite) tokExpression)) < expressionSize+                then return []+                else -- find occurrences of this expression within mod2+                 do+                  newE1 <- renameExp e1+                  occurs <- findExpression e1 newE1 (mod2, tokList2, name2) (getGroup newE1 group2)+                  if occurs == []+                   then return []+                   else do +                    return [ (e1, name1) : occurs]+      +      +-- find the occurrences of e1 within mod1  +findExpressionDo (e1@(Exp (HsDo s)),name1) newE1 (mod1, tokList1, name2) (e2:exps)+       | sameOccurrence e1 e2 = do rest <- findExpressionDo (e1,name1) newE1 (mod1, tokList1, name1) exps+                                   return rest+       | otherwise+          = do newE2 <- renameExp e2+               let (pred, stmt2, stmt1) = foldDo [] [] (newE1,e1) (newE2,e2)+               -- error $ show stmt+               if pred +                  then+                    do+                       rest <- findExpressionDo (e1,name1) newE1 (mod1, tokList1, name1) exps+                       return ((stmt1, name1) : ((stmt2, name2) : rest ))+                  else do rest <- findExpressionDo (e1,name1) newE1 (mod1, tokList1, name1) exps+                          return rest +findExpressionDo _ _ _ _ = return []+    +findExpression _ _ _ [] = return []+                                                       +findExpression e1 newE1 (mod1, tokList1, name1) (e2:exps)+       | sameOccurrence e1 e2 = do rest <- findExpression e1 newE1 (mod1, tokList1, name1) exps+                                   return rest+       | otherwise +           = do    +                                      +                newE2 <- renameExp e2        +                if foldExp [] [] newE1 newE2+                  then do  -- identify the function+                                 -- that defines this expression+                                 -- the find the free and declared variables from it...+                                 -- error $ show newE2+                         rest <- findExpression e1 newE1 (mod1, tokList1, name1) exps+                         return ( (e2, name1) : rest)+                         +                  else do  rest <- findExpression e1 newE1 (mod1, tokList1, name1) exps+                           return rest ++isWhite' x@(t,_) = t==Whitespace || t==Commentstart || t==Comment || t==NestedComment || isOpenBracket x || isCloseBracket x ||+                   isComma x || isOpenSquareBracket x || isCloseSquareBracket x || isIrrefute x++                  +-- find the defining function for a given expression+definingFun e1+  = (fromJust) . (applyTU (once_tdTU (failTU `adhocTU` inFun)))+     where+       inFun d@(Dec (HsFunBind s ms)::HsDeclP)+        | findEntity e1 d = Just d+       inFun d@(Dec (HsPatBind s p e ds)::HsDeclP)+        | findEntity e1 d = Just d+       inFun _ = Nothing++-- foldExp compares two expressions for equality+-- via alpha-renaming+-- foldIdent :: (HsIdent PNT) -> (HsIdent PNT) -> Bool+foldIdent pats pats2 (HsVar x) (HsVar y)+ = x == y && ((not (checkPNTInPat pats x)) && (not (checkPNTInPat pats2 y)))+foldIdent _ _ (HsCon x) (HsCon y) -- constructors are treated like literals?+ = True -- x == y+foldIdent _ _ x y = False+foldWild (HsVar x)+ = isLocalPNT x  +foldWild (HsCon x) + = isLocalPNT x       + + +checkPNTInPat :: [HsPatP] -> PNT -> Bool+checkPNTInPat [] _ = False+checkPNTInPat (p:ps) i +        | defineLoc i == (SrcLoc "__unknown__" 0 0 0) = False+        | defineLoc i == defineLoc (patToPNT p) = True+        | otherwise = checkPNTInPat ps i++findPNTInPat :: Int -> [HsPatP] -> PNT -> Int+findPNTInPat n [] _ = -1+findPNTInPat n (p:ps) i +        | defineLoc i == (SrcLoc "__unknown__" 0 0 0) = -1+        | defineLoc i == defineLoc (patToPNT p) = n+        | otherwise = findPNTInPat (n+1) ps i       + +foldExp :: [HsPatP] -> [HsPatP] -> HsExpP -> HsExpP -> Bool+foldExp pats pats2 (Exp (HsId x)) (Exp (HsId y))+ | pred1 x y && pos1 x == pos2 y = True+ | pred1 x y && pos1 x /= pos2 y = False+ | (foldIdent pats pats2 x y || (foldWild x && foldWild y)) = True+ | otherwise = False+    where+      pred1 (HsVar x) (HsVar y) = checkPNTInPat pats x && checkPNTInPat pats2 y+      pred1 _ _ = False+      pos1 (HsVar x) = findPNTInPat 0 pats x+      pos2 (HsVar y) = findPNTInPat 0 pats2 y+foldExp pats pats2 (Exp (HsId (HsVar x))) e  -- comparing a variable against any expression should be OK CHECK THIS!+ | isLocalPNT x && (not (checkPNTInPat pats x)) = True -- | pNTtoName x == "$" = True+ | otherwise = False+foldExp pats pats2 e (Exp (HsId (HsVar x)))   -- comparing a variable against any expression should be OK CHECK THIS!+ | isLocalPNT x && (not (checkPNTInPat pats2 x)) = True -- | pNTtoName x == "$" = True + | otherwise = False+foldExp pats pats2 (Exp (HsParen e1)) e2 + | not (sameOccurrence e1 e2) = foldExp pats pats2 e1 e2+ | otherwise = False+foldExp pats pats2 e1 (Exp (HsParen e2)) + | not (sameOccurrence e1 e2) = foldExp pats pats2 e1 e2+ | otherwise = False+foldExp pats pats2 (Exp (HsLit s lit1)) x   -- (Exp (HsLit s2 (lit2))) -- comparing 2 literals is True!?+  = True -- lit1 == lit2+foldExp pats pats2 x (Exp (HsLit s lit1)) = True+foldExp pats pats2 (Exp (HsInfixApp e1 o1 e2)) (Exp (HsInfixApp e3 o2 e4))  -- check this (different ops!?)+ | foldWild o1 && (pred1 && pred2) = True+ | foldIdent pats pats2 o1 o2 && (pred1 && pred2) = True+     where+       pred1 = foldExp pats pats2 e1 e3+       pred2 = foldExp pats pats2 e2 e4+foldExp pats pats2 a@(Exp (HsApp e1 e2)) b@(Exp (HsApp e3 e4))+  = (foldExp pats pats2 e1 e3) && (foldExp pats pats2 e2 e4)+foldExp pats pats2 (Exp (HsNegApp s e1)) (Exp (HsNegApp s2 e2)) = foldExp pats pats2 e1 e2+foldExp pats pats2 e5@(Exp (HsLambda ps e11)) e4@(Exp (HsLambda ps2 e22)) + = False+foldExp pats pats2 (Exp (HsLet decs1 e1)) (Exp (HsLet decs2 e2)) = False -- check decs?+foldExp pats pats2 (Exp (HsIf e1 e2 e3)) (Exp (HsIf e4 e5 e6)) +  = foldExp pats pats2 e1 e4 && foldExp pats pats2 e2 e5 && foldExp pats pats2 e3 e6+foldExp pats pats2 a@(Exp (HsCase e1 alts1)) b@(Exp (HsCase e2 alts2)) + = False+foldExp pats pats2 (Exp (HsList es1)) (Exp (HsList es2))+  = foldExpList pats pats2 es1 es2+foldExp pats pats2 (Exp (HsTuple es1)) (Exp (HsTuple es2))+  = foldExpList pats pats2 es1 es2+foldExp pats pats2 (Exp (HsLeftSection e1 x)) (Exp (HsLeftSection e2 y))+ | foldWild x && foldExp pats pats2 e1 e2 = True+ | foldIdent pats pats2 x y  && foldExp pats pats2 e1 e2 = True+ | otherwise = False+foldExp pats pats2 (Exp (HsRightSection x e1)) (Exp (HsRightSection y e2))+ | foldWild x && foldExp pats pats2 e1 e2 = True+ | foldIdent pats pats2 x y  && foldExp pats pats2 e1 e2 = True+ | otherwise = False+foldExp pats pats2 (Exp (HsEnumFrom e1)) (Exp (HsEnumFrom e2))+ = foldExp pats pats2 e1 e2+foldExp pats pats2 (Exp (HsEnumFromTo e1 e2)) (Exp (HsEnumFromTo e3 e4)) + = foldExp pats pats2 e1 e3 && foldExp pats pats2 e2 e4+foldExp pats pats2 (Exp (HsEnumFromThen e1 e2)) (Exp (HsEnumFromThen e3 e4))+ = foldExp pats pats2 e1 e3 && foldExp pats pats2 e2 e4+foldExp pats pats2 (Exp (HsExpTypeSig _ e1 _ _)) (Exp (HsExpTypeSig _ e2 _ _))+ = foldExp pats pats2 e1 e2+foldExp pats pats2 (Exp (HsAsPat i1 e1)) (Exp (HsAsPat i2 e2))+ | isLocalPNT i1 && foldExp pats pats2 e1 e2     = True+ | i1 == i2 && foldExp pats pats2 e1 e2 = True+ | otherwise = False+foldExp pats pats2 (Exp (HsWildCard)) (Exp (HsWildCard)) = True+foldExp pats pats2 (Exp (HsIrrPat e1)) (Exp (HsIrrPat e2)) = foldExp pats pats2 e1 e2+ +foldExp _ _ _ _ = False+++{- foldAlt :: [HsAltP] -> [HsAltP] -> Bool+foldAlt [] [] = True+foldAlt [] _  = False+foldAlt _ []  = False+foldAlt ((HsAlt s p rhs ds):as) ((HsAlt s1 p1 rhs1 ds1):as1)+  = foldRHS rhs rhs1 && foldAlt as as1+  +foldRHS (HsBody e1) (HsBody e2) + = foldExp e1 e2+foldRHS (HsGuard gs1) (HsGuard gs2)+ = foldGuards gs1 gs2+    where+      foldGuards [] [] = True+      foldGuards _ []  = False+      foldGuards [] _  = False+      foldGuards ((s1, e1, e2):gs1) ((s2, e3, e4):gs2)+       = foldExp e1 e3 && foldExp e2 e4 && foldGuards gs1 gs2 -}++foldExpList :: [HsPatP] -> [HsPatP] -> [HsExpP] -> [HsExpP] -> Bool+foldExpList p _ [] [] = True+foldExpList p _ [] _ = False+foldExpList p _ _ [] = False+foldExpList p p2 (x:xs) (y:ys)+  = (foldExp p p2 x y && foldExpList p p2 xs ys)+++-- ==========================================================++foldDo :: [HsPatP] -> [HsPatP] -> (HsExpP, HsExpP) -> (HsExpP,HsExpP) -> (Bool, HsExpP, HsExpP)+foldDo pats pats2 (Exp (HsDo stmts1), Exp (HsDo stmts1')) ((Exp (HsDo stmts2)), Exp (HsDo stmts2'))+ | pred = (True, Exp (HsDo res), Exp (HsDo res2))+           where+             (pred, res, res2) = foldStmt pats pats2 (stmts1,stmts1') (stmts2, stmts2')+foldDo _ _ _ _ = (False, defaultExp, defaultExp)+  +foldStmt :: [HsPatP] -> [HsPatP] -> (HsStmtP, HsStmtP) -> (HsStmtP,HsStmtP) -> (Bool, HsStmtP, HsStmtP)+foldStmt pats pats2 (ss1@(HsGenerator s p1 e1 stmts1),ss2@(HsGenerator _ p1' e1' stmts1')) +                    (ss3@(HsGenerator _ p2 e2 stmts2),ss4@(HsGenerator _ p2' e2' stmts2'))+ {- | wildCardAllPNs p1 == wildCardAllPNs p2 && predExp && pred2+      = (True, ss1, res2')               +  | wildCardAllPNs p1 == wildCardAllPNs p2 && predExp && pred3+      = (True, res3', ss3) -}+ -- | pred2 = (True, HsGenerator loc0 p1' e1' res1', res2')+ -- | pred3 = (True, res3', HsGenerator loc0 p2' e2' res4')+  | wildCardAllPNs p1 == wildCardAllPNs p2 && predExp && predStmt+       = (True, (HsGenerator s p1' e1' res1), (HsGenerator s p2' e2' res2))+  | wildCardAllPNs p1 == wildCardAllPNs p2 && predExp && (not predStmt)+       = (True, (HsGenerator s p1' e1' (HsLast defaultExp)), +                (HsGenerator s p2' e2' (HsLast defaultExp)))+  -- | pred2 = (True, ss1, (HsGenerator s p2' e2' res2'))++  | otherwise = foldStmt (pats++[p1]) (pats2++[p2]) (stmts1, stmts1') (stmts2, stmts2')+           where+             predExp = foldExp (pats++[p1]) (pats2++[p2]) e1 e2+             (pred2, res1', res2') = foldStmt (pats++[p1]) (pats2++[p2]) (ss1, ss2) (stmts2, stmts2')+             (pred3, res3', res4') = foldStmt (pats++[p1]) (pats2++[p2]) (stmts1, stmts1') (ss3, ss4)+             (predStmt, res1, res2) = foldStmt (pats++[p1]) (pats2++[p2]) (stmts1, stmts1') (stmts2, stmts2') +foldStmt pats pats2 (HsQualifier e1 stmts1, HsQualifier e1' stmts1')+                    (HsQualifier e2 stmts2, HsQualifier e2' stmts2')+ | foldExp pats pats2 e1 e2 = (True, HsQualifier e1' res1, HsQualifier e2' res2)+                     where+                       (_, res1, res2) = foldStmt (pats) pats2 (stmts1, stmts1') (stmts2, stmts2')+foldStmt pats pats2 (HsQualifier e1 stmts1, HsQualifier e1' stmts1')+              (HsLast e2, HsLast e2')+ | foldExp pats pats2 e1 e2 = (True, HsLast e1', HsLast e2')+foldStmt pats pats2 (HsLast e1, HsLast e1') +              (HsQualifier e2 stmts2, HsQualifier e2' stmts2')+ | foldExp pats pats2 e1 e2 = (True, HsLast e1', HsLast e2')+foldStmt pats pats2 (HsLast e1, HsLast e1') +              ((HsLast e2),(HsLast e2'))+ | foldExp pats pats2 e1 e2 = (True, HsLast e1', HsLast e2')+foldStmt a b c d = (False, HsLast defaultExp, HsLast defaultExp)  ++-- ===========================================================++foldDoNormal :: [HsPatP] -> [HsPatP] -> HsExpP -> HsExpP -> Bool+foldDoNormal pats pats2 (Exp (HsDo stmts1)) (Exp (HsDo stmts2))+ | pred = True+           where+             pred= foldStmtNormal pats pats2 stmts1 stmts2+foldDoNormal _ _ _ _ = False+  +foldStmtNormal :: [HsPatP] -> [HsPatP] -> HsStmtP -> HsStmtP -> Bool+foldStmtNormal pats pats2 ss@(HsGenerator s p1 e1 stmts1) ss2@(HsGenerator _ p2 e2 stmts2)+  -- | pred2 = True+  -- | pred3 = True+  | wildCardAllPNs p1 == wildCardAllPNs p2 && predExp && predStmt+       = True+  | otherwise = foldStmtNormal (pats++[p1]) (pats2++[p2]) stmts1 stmts2+           where+             pred2 = foldStmtNormal (pats++[p1]) (pats2++[p2]) ss stmts2+             pred3 = foldStmtNormal (pats++[p1]) (pats2++[p2]) stmts1 ss2+             predExp = foldExp (pats++[p1]) (pats2++[p2]) e1 e2+             predStmt = foldStmtNormal (pats++[p1]) (pats2++[p2]) stmts1 stmts2+foldStmtNormal pats pats2 (HsQualifier e1 stmts1) (HsQualifier e2 stmts2)+ = foldExp pats pats2 e1 e2 && predStmt+     where+       predStmt = foldStmtNormal pats pats2 stmts1 stmts2+foldStmtNormal pats pats2 (HsLast e1) (HsLast e2)+ | e1 == defaultExp && e2 == defaultExp = True+ | otherwise  = foldExp pats pats2 e1 e2+foldStmtNormal _ _ _ _ = False+++  +-- renames all bound variables to "$" so we can+-- compare too expressions via alpha renaming...      +-- renameExp :: HsExpP -> HsDeclP -> m HsExpP+renameExp exp = applyTP (full_buTP (idTP `adhocTP` renameVar)) exp+  where+    renameVar e@(p::PName)+      | isTopLevelPN p = return p+     -- | (pNTtoPN p) `elem` free = return p+     -- | not (defines (pNTtoPN x) fun) = return e+      | otherwise = do s <- renameStringPN p+                       return e+                       --   (nameToPN "$")+    -- renameVar e = return e+    renameStringPN p = applyTP (full_buTP (idTP `adhocTP` inS)) p+    inS (p::String) = return "$"+    +    +-- ===================================================================================== +-- Pretty Printing +-- We pretty print our matches to a file. Displaying the expression, together with+-- its position and the number of occurrences.+--+--++prettyPrint :: [ [(HsExpP, HsExpP, String)] ] -> [ ([PosToken], String) ] ->  String+prettyPrint [] [] = []+prettyPrint [] _ = []+prettyPrint _ [] = []+prettyPrint (dups:xs) toks+  = prettyPrint' dups toks ++ prettyPrint xs toks+  +     where+       prettyPrint' :: [(HsExpP, HsExpP,String)] -> [ ([PosToken], String) ] -> String+       prettyPrint' [] _ = ""+       prettyPrint' dups toks+         | length dups == 1 = ""+         | otherwise = +          ( (concatMap renderIt dups) +               ++ "\n" ++ (show (length dups)) ++ " occurrences.\n\n" )++       renderIt :: (HsExpP, HsExpP, String) -> String+       renderIt (_, e, m)+         = "\n\t\t" ++ m ++ "  " ++ (pos e (toks' m)) ++ ": >" ++ +                       (stringise e (toks' m)) ++ "<"++       toks' :: String -> [PosToken]+       toks' m = findTokens toks m+    +       findTokens :: [ ([PosToken], String) ] -> String -> [PosToken]+       findTokens ((x,m):xs) name+         | m == name = x+         | otherwise = findTokens xs name++       pos :: HsExpP -> [PosToken] -> String+       pos e@(Exp (HsDo stmts)) toks+        = show pos'+           where pos'+                  = let       s=getStmtList stmts                           +                              locs = map (startEndLoc toks) (removeDefault s)+                              (startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))+                          in {- extendForwards toks (ghead "StartEndLoc::HsStmtP" startLocs) (glast "StartEndLoc::HsStmtP" endLocs) isLet -} ((ghead "StartEndLoc::HsStmtP" startLocs), (glast "StartEndLoc::HsStmtP" endLocs)) +                          +       pos e toks+        | e /= defaultExp+           = let (start, end) = getStartEndLoc toks e+                in ((show (start, end)))+        | otherwise = ""+            +       stringise :: HsExpP -> [ PosToken ] -> String+       stringise e@(Exp (HsDo stmts)) toks+        = stringIt (getToks pos' toks)+           where pos'+                  = let       s=getStmtList stmts                           +                              locs = map (startEndLoc toks) (removeDefault s)+                              (startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))+                          in {- extendForwards toks (ghead "StartEndLoc::HsStmtP" startLocs) (glast "StartEndLoc::HsStmtP" endLocs) isLet -} ((ghead "StartEndLoc::HsStmtP" startLocs), (glast "StartEndLoc::HsStmtP" endLocs)) ++       stringise e toks +        | e /= defaultExp+           = let (start,end) = getStartEndLoc toks e+              in stringIt (getToks (start,end) toks)+        | otherwise = ""++removeDefault [] = []+removeDefault (s@ (HsLastAtom e):es)         +  | e == defaultExp = removeDefault es+  | otherwise = s : removeDefault es+removeDefault (s:ss)+  = s : removeDefault ss+prettyPrint2 :: [ [(HsExpP, HsExpP, String)] ] -> [ ([PosToken], String) ] ->  [ [(HsExpP, String, String)] ]+prettyPrint2 [] [] = []+prettyPrint2 [] _ = []+prettyPrint2 _ [] = []+prettyPrint2 (dups:xs) toks+  = prettyPrint' dups toks : prettyPrint2 xs toks+  +     where+       prettyPrint' :: [(HsExpP,HsExpP,String)] -> [ ([PosToken], String) ] -> [(HsExpP, String, String)]+       prettyPrint' [] _ = []+       prettyPrint' ((_,e,m):ms) toks+         = (e,m,( (renderIt (e,m)) ++ "\n" )) : prettyPrint' ms toks++       renderIt :: (HsExpP, String) -> String+       renderIt (e, m)+         = "\n\t\t" ++ m ++ "  " ++ (pos e (toks' m)) ++ ": >" ++ +                       (stringise e (toks' m)) ++ "<"++       toks' :: String -> [PosToken]+       toks' m = findTokens toks m+    +       findTokens :: [ ([PosToken], String) ] -> String -> [PosToken]+       findTokens ((x,m):xs) name+         | m == name = x+         | otherwise = findTokens xs name++       pos :: HsExpP -> [PosToken] -> String+       pos e@(Exp (HsDo stmts)) toks+        = show pos'+           where pos'+                  = let       s=getStmtList stmts+                              locs = map (startEndLoc toks) (removeDefault s)+                              (startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))+                          in ((ghead "StartEndLoc::HsStmtP" startLocs), (glast "StartEndLoc::HsStmtP" endLocs)) ++       pos e toks+        = let (start, end) = getStartEndLoc toks e+             in ((show (start, end)))+            +       stringise :: HsExpP -> [ PosToken ] -> String+       stringise e@(Exp (HsDo stmts)) toks+        = stringIt (getToks pos' toks)+           where pos'+                  = let       s=getStmtList stmts                           +                              locs = map (startEndLoc toks) (removeDefault s)+                              (startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))+                          in  ((ghead "StartEndLoc::HsStmtP" startLocs), (glast "StartEndLoc::HsStmtP" endLocs))   ++       stringise e toks +        | e /= defaultExp+            = let (start,end) = getStartEndLoc toks e+                in stringIt (getToks (start,end) toks)+        | otherwise = ""++stringIt :: [PosToken] -> String+stringIt [] = ""+stringIt (r@(x,(y, s) ):xs) = s ++ (stringIt xs)+++
+ refactorer/EditorCommands.hs view
@@ -0,0 +1,231 @@+module EditorCommands where++import MT(MT(..))++import System(system,getArgs)+import IO(hPutStrLn+         ,hGetLine+         ,hClose+         ,hSetBuffering+         ,BufferMode(..)+         ,IOMode(..)+         ,Handle+         ,stdin+         ,stderr)+import Control.OldException as Exception+import Foreign+import Foreign.C+import Network hiding (listenOn,connectTo,accept)+import Network.BSD(getProtocolNumber+                  ,getHostByName+                  ,getHostByAddr+                  ,hostAddress+                  ,HostEntry(..))+import Network.Socket(Family(..)+                     ,SocketType(..)+                     ,SockAddr(..)+                     ,SocketOption(..)+                     ,socket+                     ,sClose+                     ,setSocketOption+                     ,bindSocket+                     ,listen+                     ,connect+                     ,socketToHandle+                     ,iNADDR_ANY+                     ,maxListenQueue+                     ,inet_ntoa+                     ,recv+                     ,send+                     )+import qualified Network.Socket as Socket(accept)++data EditorCmds = EditorCmds +  { getEditorCmd :: IO String                   +  , sendEditorMsg :: Bool -> String -> IO () -- False: just log, +                                             -- True: make visible+  , sendEditorModified :: String -> IO ()+  }++-- default, useful for testing+commandlineCmds =+  EditorCmds{getEditorCmd={- hSetBuffering stdin LineBuffering >> -} getLine+            ,sendEditorModified= \f->hPutStrLn stderr $ "modified: "++f+            ,sendEditorMsg= \d m-> if d then hPutStrLn stderr $ "message: "++m +                                        else hPutStrLn stderr m}++-- refactorer is asynchronous subprocess of emacs,+-- which controls refactorers stdin and stdout;+-- seems to be relatively portable; emacs side will+-- need to interpret backchannel as editor-commands +emacsCmds = +  EditorCmds{getEditorCmd=getLine+            ,sendEditorModified= \f->hPutStrLn stderr $ "modified: "++f+            ,sendEditorMsg= \d m-> if d then hPutStrLn stderr $ "message: "++m +                                        else hPutStrLn stderr m}++-- refactorer is independent process started from vim;+-- we listen on socket for commands from vim (via refactoring+-- client), and answer with direct editor-commands, using +-- vim's clientserver functionality+mkVimCmds vimPath vimServerName = lift $ withSocketsDo $ do+  s <- listenOn $ PortNumber 9000+  return EditorCmds{+    getEditorCmd=getInput s+   ,sendEditorModified= \f-> do +      let cmd = vim_remote $+                  "call Haskell_refac_modified("++squote f++")"+      hPutStrLn stderr cmd+      system cmd  +      return ()+   ,sendEditorMsg= \b s-> do +      let dialog = if b then "1" else "0"+          cmd = vim_remote $+                  "call Haskell_refac_msg("++dialog++","++dquote s++")"+      hPutStrLn stderr cmd+      system cmd  +      return ()+   }+  where+    -- which vim to call?? the caller will tell us,+    -- but in case it's a gvim, we need to avoid pop-up dialogs+    vim_remote cmd = vimPath++" --servername "++vimServerName+                            ++" --remote-send \":silent "++cmd++" | silent redraw <cr>\""+    squote s           = "'"++concatMap del_quotes s++"'" -- no quotes or special chars in single quotes..:-((+    dquote s           = "'"++concatMap del_quotes s++"'" -- vim remote in win98 reads any " as comment start:-(+    del_quotes c | c `elem` "'\"" = " "+		 | c == '\n'	  = "\\n"+		 | otherwise      = [c]+    getInput s = do+      (h,host,portnr) <- accept s+      hSetBuffering h LineBuffering+      l <- hGetLine h+      hPutStrLn h "<ack>"+      putStrLn $ "SERVER: '"++l++"'"+      -- hClose h+      return l++clientCmd :: IO ()+clientCmd = withSocketsDo $ do+  args <- getArgs+  h <- connectTo "localhost" $ PortNumber 9000+  hSetBuffering h LineBuffering+  hPutStrLn stderr $ "(stderr) CLIENT SEND: "++unwords args+  putStrLn $ "(stdout) CLIENT SEND: "++unwords args+  hPutStrLn h $ unwords args+  hGetLine h  -- wait for acknowledgement+  return ()+++-- | Creates the server side socket which has been bound to the+-- specified port.  +--+-- NOTE: To avoid the \"Address already in use\"+-- problems popped up several times on the GHC-Users mailing list we+-- set the 'ReuseAddr' socket option on the listening socket.  If you+-- don't want this behaviour, please use the lower level+-- 'Network.Socket.listen' instead.++{-+foreign import stdcall unsafe "WSAGetLastError"+  c_getLastError :: IO CInt++foreign import ccall unsafe "getWSErrorDescr"+  c_getWSError :: CInt -> IO (Ptr CChar)+-}++listenOn :: PortID 	-- ^ Port Identifier+	 -> IO Socket	-- ^ Connected Socket++listenOn (PortNumber port) = do+--    proto <- getProtocolNumber "tcp"+--    putStrLn $ "tcp: "++show proto+    let proto = 6 -- bug in ghc's getProtocolNumber..+    EditorCommands.bracketOnError+      (Exception.catch (socket AF_INET Stream proto)+          (\e-> do+--          errCode <- c_getLastError+            -- perr <- c_getWSError errCode+            -- err <- peekCString perr+--          putStrLn $ "WSAGetLastError: "++show errCode+            throw e))++	(sClose)+	(\sock -> do+	    setSocketOption sock ReuseAddr 1+	    bindSocket sock (SockAddrInet port iNADDR_ANY)+	    listen sock maxListenQueue+	    return sock+	)++bracketOnError+	:: IO a		-- ^ computation to run first (\"acquire resource\")+	-> (a -> IO b)  -- ^ computation to run last (\"release resource\")+	-> (a -> IO c)	-- ^ computation to run in-between+	-> IO c		-- returns the value from the in-between computation+bracketOnError before after thing =+  block (do+    a <- before +    r <- Exception.catch +	   (unblock (thing a))+	   (\e -> do { after a; throw e })+    return r+ )++-- | Calling 'connectTo' creates a client side socket which is+-- connected to the given host and port.  The Protocol and socket type is+-- derived from the given port identifier.  If a port number is given+-- then the result is always an internet family 'Stream' socket. ++connectTo :: HostName		-- Hostname+	  -> PortID 		-- Port Identifier+	  -> IO Handle		-- Connected Socket++connectTo hostname (PortNumber port) = do+--    proto <- getProtocolNumber "tcp"+--    putStrLn $ "tcp: "++show proto+    let proto = 6 -- bug in ghc's getProtocolNumber..+    EditorCommands.bracketOnError+	(Exception.catch (socket AF_INET Stream proto)+          (\e-> do+--          errCode <- c_getLastError+--          putStrLn $ "WSAGetLastError: "++show errCode+            throw e))+	(sClose)  -- only done if there's an error+        (\sock -> do+      	  he <- getHostByName hostname+      	  connect sock (SockAddrInet port (hostAddress he))+      	  socketToHandle sock ReadWriteMode+	)++-- -----------------------------------------------------------------------------+-- accept++-- | Accept a connection on a socket created by 'listenOn'.  Normal+-- I\/O opertaions (see "System.IO") can be used on the 'Handle'+-- returned to communicate with the client.+-- Notice that although you can pass any Socket to Network.accept, only+-- sockets of either AF_UNIX or AF_INET will work (this shouldn't be a problem,+-- though). When using AF_UNIX, HostName will be set to the path of the socket+-- and PortNumber to -1.+--+accept :: Socket 		-- ^ Listening Socket+       -> IO (Handle,  -- Socket, -- should be: Handle,+	      HostName,+	      PortNumber)	-- ^ Triple of: read\/write 'Handle' for +				-- communicating with the client,+			 	-- the 'HostName' of the peer socket, and+				-- the 'PortNumber' of the remote connection.+accept sock {- @(MkSocket _ AF_INET _ _ _) -} = do+ ~(sock', (SockAddrInet port haddr)) <- Socket.accept sock+ peer <- Exception.catchJust ioErrors+	  (do 	+	     (HostEntry peer _ _ _) <- getHostByAddr AF_INET haddr+	     return peer+	  )+	  (\e -> inet_ntoa haddr)+		-- if getHostByName fails, we fall back to the IP address+ -- return (sock', peer, port)+ handle <- socketToHandle sock' ReadWriteMode+ return (handle, peer, port)+
+ refactorer/Evaluate.hs view
@@ -0,0 +1,56 @@+module Main where++import System+import Control.Exception+import System.IO.Unsafe+import System.IO+import List+import Unsafe.Coerce+-- Package GHC stuff+import GHC+import DynFlags+import ErrUtils+import PackageConfig+import HsSyn+import Outputable+import SrcLoc+import RdrName+import Name +import Control.Monad+import Language.Haskell.Interpreter hiding (runGhc)+import LocalSettings++main + = -- defaultErrorHandler defaultDynFlags $+   do+   ar <- getArgs+   putStrLn "here"+   let args = ar !! 0+       -- newArgs = (ar !! 1) ++ "hs"+       closure_call = ar !! 1+       modName = ar !! 2+   -- error $ show (closure_call, modName, args)+   let newArgs =  args ++ ".hs"++   -- let packageConf = ghcPath +   -- (eval_res, x) <- runEval args modName closure_call packageConf+   x <- runInterpreter (runEvalHint args modName closure_call)+   case x of+     Left err -> printInterpreterError err+     Right x -> do putStrLn $ show (x)+                   writeFile evaluate_result x ++printInterpreterError :: InterpreterError -> IO ()+printInterpreterError e = error $ "Ups... " ++ (show e)++runEvalHint args modName closure_call + = do+      set [languageExtensions := [OverlappingInstances]]+      loadModules [args]+      setTopLevelModules [modName]+      setImportsQ [("Prelude", Nothing)]+      liftIO (putStrLn ("about to evaluate...>" ++ modName ++ "<"))+      let expr1 = (modName ++ "." ++ closure_call)+      a <- eval expr1+      return a+      
+ refactorer/InitGHC.hs view
@@ -0,0 +1,14 @@+module InitGHC(initGHC) where++import Prelude hiding (putStrLn)+import System.IO.Unsafe+import AbstractIO (putStrLn)+import Maybe+import List  +import TypeCheck+import RefacUtils ++initGHC filenames+ = do +      AbstractIO.putStrLn $ ghcInit filenames+      
+ refactorer/LocalSettings.hs view
@@ -0,0 +1,30 @@+module LocalSettings where+import System.FilePath.Posix+import System.IO.Unsafe+import Paths_hare++root=getDataFileName "haskell-refac.el"++hare_version="HaRe 28/06/2010"+release_root= showNoQuotes "/Users/chrisbrown/hare/cabal/HaRe_28062010/editors/.."+refactorer = showNoQuotes "/Users/chrisbrown/hare/cabal/HaRe_28062010/refactorer/pfe"+refactorer_client = showNoQuotes "/Users/chrisbrown/hare/cabal/HaRe_28062010/refactorer/pfe_client"+preludePath = unsafePerformIO $ getDataFileName "HaskellLibraries"++reportFilePath = unsafePerformIO $ getDataFileName "dupReport"+answerFilePath = unsafePerformIO $ getDataFileName "dupAnswers"+positionFilePath = unsafePerformIO $ getDataFileName "dupPositions"+transFilePath  = unsafePerformIO $ getDataFileName "dupTransforms"+classAnswerPath    = unsafePerformIO $ getDataFileName "dupClassAnswer"+classTransformPath = unsafePerformIO $ getDataFileName "dupClassTransform"+mergeFilePath  = unsafePerformIO $ getDataFileName "mergeCache"++evaluate = "hare_evaluate"+evaluate_result = unsafePerformIO $ getDataFileName "evaluateResult"++genFoldPath = unsafePerformIO $ getDataFileName "genFoldCache"++(refactor_prg:refactor_args) = words refactorer -- for emacs+showNoQuotes x = init $ tail $ show x++haskellLibraries = dropFileName (unsafePerformIO $ getDataFileName "Prelude.hs")
+ refactorer/PFE0.hs view
@@ -0,0 +1,599 @@+-- Programatica Front-End, level 0, see README.html+module PFE0(+    PFE0MT,runPFE0,clean0,PFE0State, PFE0_IO, HasInfixDecls,+    pput,epput,+    Upd,getSt0ext,updSt0ext,setSt0ext, -- for extending the state+    ModuleNode,ModuleGraph,+    getCurrentModuleGraph,sortCurrentModuleGraph,getSortedSubGraph,getSubGraph,+    allModules,allFiles,moduleList,+    findFile,findFile',findNode,findNode',+    getModuleInfixes,getModuleImports,+    updateModuleGraph,+    parserFlags,ppFlags,+    batchMode,setBatchMode,+    newProject,addPaths,removePaths,saveSrcList,checkProject,projectStatus,+    lex0SourceFile,preparseModule,preparseSourceFile,lexAndPreparseSourceFile,+    projectDir,projPath,maybeF,withProjectDir,withProjectDir',newProjectHelp,+    moduleInfoPath,+    -- Pure functions:+    optSubGraph,subGraph,+    -- Independent of PFE:+    moduleNode,newerThan,+    -- managing HaRe file history+    clearHistory, addToHistory, undoLatestInHistory,+    -- Hare editor interface+    getEditorCmds, State0, editorCmds, getSt0+  ) where+import Prelude hiding (readFile,writeFile,putStr,putStrLn,catch,ioError)+import List(sort,nub,(\\))+import Monad(when,unless)+import Maybe(fromMaybe,fromJust,isJust)++import HsModule+import HsAssocStruct+import HsIdent+import ReAssoc(HasInfixDecls,getInfixes)+import NamesEntities(getQualified)+import QualNames(QualNames) +import SourceNames(SN,fakeSN)+import HasBaseName(getBaseName)++import MUtils(( # ),(@@),done,collectByFst,mapFst,apFst,apSnd,ifM,seqMaybe)+import SimpleGraphs(reverseGraph,reachable)+--import EnvMT+import MT (MT(..))+import StateMT(WithState,withSt,withStS,getSt,setSt,updSt,updSt_)+import DirUtils+import FileUtils hiding (readFileNow)+import AbstractIO+import NewSCC(scc)+import PPU+import CmdLineParser3+import ParserOptions+import ParseMonad(PM)++import Unlit(readHaskellFile)+import ParseMonad(parseTokens)+import HsLexerPass1(Lexer)+import HsLexMerge(mergeLex)++import EditorCommands+import qualified Control.OldException as CE (catch)+--------------------------------------------------------------------------------+-- Types manipulated at PFE level 0:++type ModuleNode = (FilePath,(ModuleName,[ModuleName]))+type ModuleGraph = [ModuleNode]+type SortedModuleGraph = [ModuleGraph] -- strongly connected components++type Fixities n = [(HsIdentI n,HsFixity)]+type ModuleFixities n = [(ModuleName,Fixities n)]++--------------------------------------------------------------------------------++--type PFE i ds m a = WithEnv (Parser i ds m) m a+--type Parser i ds m = FilePath -> m (HsModuleI i ds)++--pfe :: (PFE_IO m, DefinedNames (SN HsName) ds, HasInfixDecls (SN HsName) ds)+--    => (Maybe String->Parser (SN HsName) ds m) -> [String] -> m ()++--type PFE0Env i ds = ((Flags,(Bool,PPHsMode)),(Lexer,PM (HsModuleI i ds)))++data State0 n i ds = PFE0 { myname :: String,+			    batch :: Bool,+			    cacheDir :: Maybe FilePath,+			    parserOpts :: ParserOptions.Flags,+			    ppOpts :: (Bool,PPHsMode),+			    lexer :: Lexer,+			    parser :: PM (HsModuleI (SN ModuleName) i ds),+			    fixities :: ModuleFixities n,+			    srclist :: [FilePath],+			    tgraph :: Maybe (Maybe ClockTime,ModuleGraph),+			    sortedgraph :: Maybe SortedModuleGraph ,+                            editorCmds :: EditorCmds ,+			    history :: [(Bool,[(String,String)])] }++initState0 name (lexer,parser)+  = PFE0 { myname = name, -- name of command, for usage message+	   batch = True, -- batch mode (always trust data in internal caches)+	   cacheDir = Nothing, -- location of current project cache+	   parserOpts = flags0,+	   ppOpts = ppOpts0,+	   lexer = lexer,+	   parser = parser,+	   fixities = [],+	   srclist = [],+	   tgraph = Nothing,+	   sortedgraph = Nothing,+           editorCmds = commandlineCmds ,+	   history = [] }++graph st = snd # tgraph st+-- Old:+--type PFE0Info n = (ModuleGraph,ModuleFixities n)+--pfe0info st = (graph st,fixities st)++getEditorCmds = editorCmds # getSt0++-- Leave room for extending the state (poor man's subtyping):+type PFE0State n i ds nextlevel = (State0 n i ds,nextlevel)++type PFE0MT n i ds ext m = WithState (PFE0State n i ds ext) m+withPFE0 :: Monad m => PFE0State n i ds ext -> PFE0MT n i ds ext m a -> m a+withPFE0 = withSt ++{-++All level 0 functions work in arbitrary monads that provide access to+the level 0 state (and some other things). The following type+signatures *restricts* level 0 functions to the PFE0MT monad transformer.+We don't need the extra generality at the moment and the restriction+should make the inferred types more readable (but since+GHC doesn't do any context reduction, they are still not very+readable...)+-}+type Upd s = s->s+getSt0 :: Monad m => PFE0MT n i ds ext m (State0 n i ds)+updSt0 :: Monad m => Upd (State0 n i ds)->PFE0MT n i ds ext m ()+getSt0ext :: Monad m => PFE0MT n i ds ext m ext+updSt0ext :: Monad m => Upd ext->PFE0MT n i ds ext m ()++getSt0 = fst # getSt+updSt0 = updSt_ . apFst+setSt0 = updSt0 . const++getSt0ext = snd # getSt+updSt0ext = updSt_ . apSnd+setSt0ext = updSt0ext . const++batchMode = batch # getSt0+setBatchMode b = updSt0 $ \st->st{batch=b}++{- the definition from Programatica.+runPFE0 ext pfeM lexerAndParser (opts,name,args0) =+  do let st0 = (initState0 name lexerAndParser){ppOpts=opts}+     withPFE0 (st0,ext) $ pfeM (name++" [options]") =<< initProject args0+-}++--------------------------------------------------------------------------+-- HaRe redefined runPFE0.  (was called runLoopPFE0).+runPFE0 ext pfeM lexerAndParser (opts,name,args0) = do +  let st0 = (initState0 name lexerAndParser){ppOpts=opts}+  withPFE0 (st0,ext) $ editorLoop (name++" [options]") =<< initProject args0+  where+    editorLoop prg ("emacs":args) = do+      updSt0 $ \st->st{editorCmds=emacsCmds}+      loop prg args+    editorLoop prg ("vim":(vimPath:(vimServerName:args))) = do+      editorCmds <- mkVimCmds vimPath vimServerName+      updSt0 $ \st->st{editorCmds=editorCmds}+      loop prg args+    editorLoop prg args = do+      loop prg args++    loop prg args = do+      editorCmds <- editorCmds # getSt0+      let getCmd = lift (getEditorCmd editorCmds)+          sendMsg dialog msg = lift (sendEditorMsg editorCmds dialog msg)+          sendModified f = lift (sendEditorModified editorCmds f)+      l <- catchEnv getCmd (const $ return "stop")+      let cmdArgs@(cmd: ~(mod:_)) = words l+      sendMsg False $ "CMD:"++show cmdArgs+      unless (cmd=="stop") $ do+        if (cmd=="undo") then (undoLatestInHistory >> loop prg args) +          else do when (cmd == "new") clearHistory                  +                  -- refactorings currently use exceptions freely:-(+                  -- AbstractIO defined catch as Prelude.catch, which doesn't+                  -- capture all exceptions; we need Control.Exception.catch..+                  -- we also need catch embedded in environment monad (catchEnv)+                  -- [now changed into state transformer..]+                  -- in the longer term, we need to avoid fatal exceptions within+                  -- refactorings, switching to Either or least to user exceptions!+                  -- NOTE: we need a placeholder for semantic information, to be+                  --       filled in and kept up-to-date by refactorings as they+                  --       find they need to parse&analyse files in the project;+                  --       that placeholder/semantic info will then have to be +                  --       passed from one iteration to the next here+                  -- in the new programatica sources, "new"/"chase" don't seem to +                  -- update the project state; as a workaround, we reinitialise+                  -- in each loop..+                  catchEnv (do initProject args0 +                               setBatchMode False+                               pfeM prg cmdArgs) +                    (\e ->sendMsg True $ "CAUGHT EXCEPTION: " ++ show e)++                  loop prg args+    catchEnv m f = do s <- getSt+                      (r,s) <- lift (withStS s m `CE.catch` (withStS s . f))+                      setSt s+                      return r++------------------------------------------------------------------------+-- managing the refactoring history, which is of type +-- [[(Filename,Filecontents)]], where both names and contents are Strings++clearHistory = updSt0 (\s->s{history=[]})++-- refactorer currently extends history whenever +-- called upon, even if the editor file has been +-- reset in the meantime!! need more communication+-- between editor and refactorer++addToHistory isSubRefactor files  = do sources <- mapM readFileNow files +                                       updSt0 (\s->s{history=((isSubRefactor,(zip files sources)):(history s))})++undoLatestInHistory = do+  history <- history # getSt0+  editorCmds <- editorCmds # getSt0+  let sendModified f = lift (sendEditorModified editorCmds f)+      sendMsg dialog msg = lift (sendEditorMsg editorCmds dialog msg)+  case skipHistory ([],history) of+    (f@(file:files),rest) -> +         do mapM_ (\(name,source)->writeFile name source >> sendModified name) f+            updSt0 (\s->s{history=rest})+    _ -> do sendMsg True "no refactorer undo history"++readFileNow name = do -- make sure file is read completely+                      contents <- readFile name +                      seq (length contents) $ return contents++skipHistory (r, []) =(r,[])+{- flag: True means the back-up id for sub-refactoring. This function aims to help+   undoing composite refactorings+-}+skipHistory (r,h@((flag,files):rest)) +       = if flag then skipHistory (((diffHistory r files)++ files),rest)  -- handle sub-refactoring+                 else (((diffHistory r files)++files), rest) +  where +    diffHistory::[(String,String)]->[(String,String)]->[(String,String)]+    diffHistory h1 h2 = filter (\(filename,content)->not (elem filename filenames)) h1+       where  filenames = map fst h2++ ++------------------------------------------------------------------------++initProject args0 =+  do res <- try loadSrcList+     case res of+       Left err ->+         if isDoesNotExistError err+	 then blankProject args0+	 else ioError err+       Right files -> openProject projdir args0+  where+    projdir = defaultProjectDir++    loadSrcList =+      do paths <- lines # readFileNow (srclistPath projdir)+	 setSrcList paths+	 clearGraph+	 return paths++blankProject args0 =+  do flags0 <- parserFlags+     let (flags,args) = parserOptions flags0 args0+     updSt0 $ \st->st{parserOpts=flags}+     return args++openProject dir args0 =+  do updSt0 $ \st->st{cacheDir=Just dir}+     flags0 <- parserFlags+     let opath = optionsPath dir+     flags1 <- fromMaybe flags0 # (readFileMaybe opath)+     let (flags,args) = parserOptions flags1 args0+     updSt0 $ \st->st{parserOpts=flags}+     --quietUpdateModuleGraph+     when (flags/=flags1) $ writeFile opath (show flags)+     return args++setpfe0info (tg,fs) =+     updSt0 $ \st->st{tgraph=Just tg,fixities=fs,sortedgraph=Nothing}++newProject =+  do let dir=defaultProjectDir+     optCreateDirectory dir+     updSt0 $ \st->st{cacheDir=Just dir}+     setSrcList []+     setpfe0info ((Nothing,[]),[])+     let opath = optionsPath dir+     writeFile opath . show =<< parserFlags+     updateModuleGraph++clearGraph = updSt0 $ \st->st{fixities=[],tgraph=Nothing,sortedgraph=Nothing}++saveSrcList paths =+  do setSrcList paths+     flip updateFile_ (unlines . set $ paths) `projPath` srclistPath++setSrcList paths = updSt0 $ \st->st{srclist=paths}++preparseModule = preparseSourceFile @@ findFile++preparseSourceFile path =+  do flags <- parserOpts # getSt0+     optAddPrelude fakeSN (prel flags) #+	(parseFile path =<< readHaskellFile (cpp flags) path)+  where+    parseFile path (litcmnts,code) = +      do PFE0 {lexer=lexerPass0,parser=parseModule} <- getSt0+	 parseTokens parseModule path (lexerPass0 code)++-- lexAndPreparseSourceFile :: (HasEnv m PFE0Env, FileIO m) =>+--  => FilePath -> m ([(Token,(Pos,String))],HsModuleI i)+lexAndPreparseSourceFile path =+  do PFE0{parserOpts=flags,lexer=lexerPass0,parser=parseModule} <- getSt0+     lts@(_,ts) <- apSnd lexerPass0 # readHaskellFile (cpp flags) path+     m <- optAddPrelude fakeSN (prel flags) # parseTokens parseModule path ts+     return (mergeLex lts,m)++lex0SourceFile path =+  do PFE0{parserOpts=flags,lexer=lexerPass0} <- getSt0+     apSnd lexerPass0 # readHaskellFile (cpp flags) path++parserFlags = parserOpts # getSt0+ppFlags = ppOpts # getSt0++-- Pretty print with options from PFE environment and put on stdout:+pput x =+  do o <- ppFlags+     putStrLn$ ppu o $ x++-- Pretty print with options from PFE environment and put on stderr:+epput x =+  do o <- ppFlags+     ePutStrLn$ ppu o $ x++findFile m = fst # findNode m+findNode m = findNode' m =<< getCurrentModuleGraph+++findFile' :: (Functor m, Monad m) => ModuleName -> ModuleGraph -> m FilePath+findFile' m g = fst # findNode' m g++findNode' :: Monad m => ModuleName -> ModuleGraph -> m ModuleNode+findNode' m g =+    case  [n|n@(_,(m',_))<-g,m'==m] of+      [n] -> return n+      []  -> fail $ pp $ "Unknown module:"<+>m+      _   -> fail $ pp $ "Module defined in several files:"<+>m++getModuleImports m = snd . snd # findNode m++getCurrentModuleGraph =+  do ifM (isJust . graph # getSt0) done quietUpdateModuleGraph+     fromJust . graph # getSt0++sortCurrentModuleGraph =+  do optsg <- sortedgraph # getSt0+     case optsg of+       Just sg -> return sg+       _ -> do g <- getCurrentModuleGraph+	       case checkGraph g of+	         Just errs -> fail $ pp $ moduleGraphReport errs+	         _ -> do let sg = sortGraph g+			 updSt0 $ \st->st{sortedgraph=Just sg}+			 return sg++getSubGraph optms = concat # getSortedSubGraph optms+getSortedSubGraph optms = flip optSubGraph optms # sortCurrentModuleGraph++projectDir = cacheDir # getSt0+withProjectDir' n m = maybe n m =<< projectDir+withProjectDir = withProjectDir' done++allModules = moduleList # sortCurrentModuleGraph+allFiles = srclist # getSt0+getModuleInfixes = fixities # getSt0++moduleList g = [m|scc<-g,(_,(m,_))<-scc]++projectStatus =+  do checkProject+     files <- allFiles+     if null files+       then do putStrLn "You have a new, empty project."+	       putStrLn "Add files to it by using: pfe add <files>"+       else do let n = length files+	       putStrLn $ "The project contains "+++			       if n==1+			       then "one source file."+			       else show (length files)++" source files."+	       putStrLn "(To list the files, use: pfe files)"+	       updateModuleGraph -- skip?++checkProject = withProjectDir' newProjectHelp return++newProjectHelp =+    do name <- myname # getSt0+       fail $ "Start by creating a new project using "+++	      name++" new or pfesetup"++addPaths = changePaths (++)+removePaths = changePaths (\\)++changePaths op quiet paths =+  do checkProject+     old <- allFiles+     new <- expand paths+     let files = old `op` paths+     saveSrcList files+     --optUpdateModuleGraph+     updateModuleGraph' quiet++sortGraph :: ModuleGraph -> [ModuleGraph]+sortGraph g = map (map post) . scc . map snd $ g+  where+    mfs = [(n,f)|(f,(n,_))<-g]+    post (n,is) = (fromMaybe (error "PFE0.sortGraph") $ lookup n mfs,(n,is))+++checkGraph g =+    if null dups && null missing+    then Nothing+    else Just (dups,missing)+  where+    dups = filter duplicated mfs+      where duplicated (m,fs) = length fs/=1+    mfs = collectByFst [(m,f)|(f,(m,_))<-g]+    known = set (map fst mfs)+    missing = collectByFst [(i,m)|(_,(m,is))<-g,i<-is,i `notElem` known]+++moduleGraphReport (mfs,missing) = reportDuplicates $$ reportMissing+  where+    reportDuplicates = sep (map reportDuplicate mfs)++    reportMissing = if null missing+		    then empty+		    else sep [ppi "Source files missing for (add files with 'pfe add' or 'pfe chase'): ",+			      nest 4 (vcat (map needed missing))]+        where needed (i,ms) = i<>","<+>"needed by"<+>fsep ms++    reportDuplicate (m,fs) = m<+>"defined in more than one file:"<+>fsep fs++optUpdateModuleGraph = ifM (isJust . graph # getSt0) updateModuleGraph done++quietUpdateModuleGraph = updateModuleGraph' True+updateModuleGraph      = updateModuleGraph' False ++-- Another type signature to improve the readablility of inferred types:+updateModuleGraph' ::+  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+  Bool -> PFE0MT n i ds ext m ()++updateModuleGraph' quiet =+    do files <- allFiles+       tg <- optLoadModuleGraph files+       ofix <- getModuleInfixes+       (g,fixities) <- unzip # mapM (updateModuleImports ofix tg) files+       -- The graph written to modgraphPath must be current, since source files+       -- are reread only if they are newer than modgraphPath!+       flip writeFile (show g) `projPath` modgraphPath+       t <- maybe getClockTime return =<<+              getModificationTime' `projPath` modgraphPath+       updateGraphTextFiles g+       let r = maybe [] (pp . moduleGraphReport) (checkGraph g)+       unless (quiet || null r) $ ePutStrLn r+       --saveSrcList files+       setpfe0info ((Just t,g),fixities)+  where++    optLoadModuleGraph files =+        maybe (loadModuleGraph files) return . tgraph =<< getSt0++    loadModuleGraph files =+      do optgpath <- fmap modgraphPath # projectDir+	 case optgpath of+	   Just gpath ->+	     do g <- (readM =<< readFile gpath) `catch` const (return [])+	        t <- if null g+		     then return Nothing+		     else Just # getModificationTime' gpath+	        return (t,g::ModuleGraph)+	   _ -> return (Nothing,[])++    updateModuleImports ofix (gt,g) modulePath =+        case lookup modulePath g of+	  Nothing -> getModuleImports modulePath+	  Just mi ->+	    ifM ((`newerThan` gt) # getModificationTime' modulePath)+	        (getModuleImports modulePath)+	        (useOldImports ofix modulePath mi)++    getModuleImports modulePath =+        do m <- preparseSourceFile modulePath+	   m_infixes <- updateInfixes m+	   let node = moduleNode m+	   return ((modulePath,node),m_infixes)++    useOldImports oldfixities modulePath mi@(mn,_) =+      do infixes <- case lookup mn oldfixities of+	              Just infixes -> return infixes+	              _ -> withProjectDir' no yes+		       where yes dir = readM=<<readFile (infixFile dir mn)+			     no = fail$"Missing fixity info for: "++show mn+	 return ((modulePath,mi),(mn,infixes))++    --updateInfixes :: (Printable i,HasInfixDecls i ds,HasIO m) => HsModuleI i ds -> m Bool+    updateInfixes m =+	do let infixes = mapFst getQualified (getInfixes (hsModDecls m))+	       mn = getBaseName (hsModName m)+	       upd dir = do optCreateDirectory (infixdir dir)+			    updateFile_ (infixFile dir mn) (show infixes)+           withProjectDir upd+	   return (mn,infixes)++    updateGraphTextFiles fg = withProjectDir upd+      where+        upd dir = do updateFile_ (dir++"ModuleSourceFiles.txt") (txt2 fg)+	             updateFile_ (dir++"ModuleGraphRev.txt") (txtn rg)+        g = map snd fg+	rg = reverseGraph g+        txtn = unlines . map (\(m,is)->pp m++" "++unwords (map pp is))+        txt2 = unlines . map (\(f,(m,_))->pp m++" "++f)++moduleNode m = (getBaseName (hsModName m),{-set$-} map getBaseName (hsModImportsFrom m))+--------------------------------------------------------------------------------++t `newerThan` Nothing = True+t `newerThan` Just t' = t>t'++set xs = sort (nub xs)++optSubGraph g = maybe g (subGraph g)++subGraph g ms = [scc|scc<-g,any (`elem` r) [m|(_,(m,_))<-scc]]+  where r = reachable (map snd (concat g)) ms++updateFile_ path str = updateFile path str >> done++maybeF m f = maybe (return Nothing) (m.f) =<< projectDir++m `projPath` f = do d <- fmap f # projectDir+		    seqMaybe (fmap m d)++--------------------------------------------------------------------------------++clean0 = withProjectDir clean+  where+    clean dir =+      rmR [modgraphPath dir,+	   dir++"ModuleSourceFiles.txt",+	   dir++"ModuleGraphRev.txt",+	   infixdir dir]+      >>done++--------------------------------------------------------------------------------++defaultProjectDir = "hi/"+infixdir dir=dir++"infix/"+srclistPath dir= dir++"srclist.txt"+modgraphPath dir= dir++"FileModules.hv"+optionsPath dir= dir++"options"++infixFile dir m = infixdir dir++moduleInfoPath m++".hv"++moduleInfoPath m = map conv (pp (m::ModuleName))+  where+    conv '/'  = '-'+    conv '\\' = '_'+    conv ':'  = '_'+    conv c = c++--------------------------------------------------------------------------------+{-+instance CatchIO err m => CatchIO err (WithEnv e m) where+  m `catch` f = do e <- getEnv+                   lift (withEnv e m `catch` (withEnv e . f))+  ioError = lift . ioError+-}+instance CatchIO err m => CatchIO err (WithState s m) where+  m `catch` f = do s0 <- getSt+                   (a,s1) <- lift $ withStS s0 m `catch` (withStS s0 . f)+		   setSt s1+		   return a+  ioError = lift . ioError++-- a class synonym:+class (FileIO m,DirectoryIO m,CatchIO e m,StdIO m,SystemIO m,TimeIO m) => PFE0_IO e m | m->e+instance (FileIO m,DirectoryIO m,CatchIO e m,StdIO m,SystemIO m, TimeIO m) => PFE0_IO e m
+ refactorer/ParseAnswers.hs view
@@ -0,0 +1,97 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  ParseAnswers+-- Copyright   :  (c) Christopher Brown 2007+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+-- This module parses a file containing a list of questions+-- asking the user to replace occurences of duplicated code with+-- a function call.+-- After reading the question the module removes the question from the+-- file until finally an empty file is passed in.+--+-- If an empty file is passed in the module does exactly nothing.+--+-----------------------------------------------------------------------------++module ParseAnswers where++import System.IO.Unsafe+import PosSyntax hiding (ModuleName, HsName, SN)+import SourceNames +import ScopeModule+import UniqueNames hiding (srcLoc)+import HsName+import HsLexerPass1+import PNT +import TiPNT+import SimpleGraphs(reverseGraph,reachable)+import HsTokens+import RefacTypeSyn+import RefacLocUtils+import GHC +import Data.Char+import GHC.Unicode+import AbstractIO+import Maybe+import List+import RefacUtils+import LocalSettings+import PrettyPrint+parseAnswers args+  = do +       if (length args) > 0 +         then do+          let answers = args!!0+          -- AbstractIO.putStrLn answers       +          AbstractIO.appendFile answerFilePath (answers ++ "\n")+          {- answer <- AbstractIO.readFile reportFilePath+          let (answer2, remainder) = parseAnswer (force answer)+          if remainder == "" && answer2 == ""+            then do+             AbstractIO.putStrLn $ "completed."+            else do            +             AbstractIO.putStrLn answer2+             AbstractIO.writeFile reportFilePath remainder -}+         else do+          answer <- AbstractIO.readFile classAnswerPath+          let (answer2, remainder) = parseAnswer (force (read answer::[(HsExpP, String, String)]))+          if remainder == [] && answer2 == ""+            then do+             AbstractIO.putStrLn $ "completed."+            else do            +             AbstractIO.putStrLn answer2+             AbstractIO.writeFile classAnswerPath $ show remainder++parseAnswer :: [ (HsExpP, String, String) ] -> (String, [ (HsExpP, String, String) ])+parseAnswer [] = ("", [])+parseAnswer ((x,y,z):xs)+ = ( z , xs)+   +             +force  :: Eq a => a -> a
force x = if x==x then x else x+{-        +parseAnswer :: String -> (String, String)+parseAnswer [] = ([], [])+parseAnswer ('<':'%':'>':xs)+ = (parseEnd xs, parseAfter xs)+parseAnswer ('\n' : xs)+ = parseAnswer xs+parseAnswer (x:xs) + = ((x: parseEnd xs), parseAfter xs)+ +parseEnd :: String -> String+parseEnd [] = []+parseEnd ('<':'&':'>': xs)+  = []+parseEnd (x:xs) +   = x : parseEnd xs+         +parseAfter :: String -> String+parseAfter [] = []+parseAfter ('<':'&':'>': xs)+ = xs+parseAfter (x:xs) + = parseAfter xs -}
+ refactorer/PfeRefactoringCmds.hs view
@@ -0,0 +1,108 @@+-- refactoring commands added to pfe command interpreter+-- this file is generated from GenEditorInterfaces.hs+-- by calling the executable as follows:+--   editors/GenEditorInterfaces pfeRefactoringCmds > refactorer/PfeRefactoringCmds.hs++module PfeRefactoringCmds where++import PfeParse+import RefacMoveDef+import RefacRenaming+import RefacDupDef+import RefacCacheMerge+import RefacNewDef+import RefacSlicTuple+import RefacMerge+import RefacRmDef+import RefacAddRmParam+import RefacGenDef+import RefacMvDefBtwMod+import DuplicateCode+import RefacCleanImps+import ParseAnswers+import RefacAddCon+import RefacTypeSig+import RefacADT+import RefacSwapArgs+import RefacRedunDec+import RefacSlicing+import RefacDeForest+import RefacUnGuard+import RefacFunDef+import RefacAsPatterns+import RefacUnfoldAsPatterns+import RefacInstantiate+import RefacDupTrans+import RefacRemoveField+import RefacAddField+import RefacLetWhere+import RefacRmCon+import RefacWhereLet+import RefacIntroPattern+import RefacSimplify+import RefacGenFold+import RefacGenCache+import RefacIdentify+++pfeRefactoringCmds =+  [+   -- menu Names/Scopes+   ("rename",(args " <fileName> <name (New name? )> <line> <column>" rename, " Rename a variable name"))+  ,("liftToTopLevel",(args " <fileName> <line> <column>" liftToTopLevel, " Lift a local declaration to top level"))+  ,("liftOneLevel",(args " <fileName> <line> <column>" liftOneLevel, " Lift a local declaration one level up"))+  ,("demote",(args " <fileName> <line> <column>" demote, " Demote a declaration to where it is used"))+  ,("refacTypeSig",(args " <fileName>" refacTypeSig, " Generates type signatures for top-level definitions using GHC."))+  ,("parseAnswers",(args " <fileName>" parseAnswers, " Read in an answer"))+  ,("letToWhere",(args " <fileName> <line> <column>" letToWhere, " Converts a let expression into a where equation."))+  ,("whereToLet",(args " <fileName> <line> <column>" whereToLet, " Converts a where equation into a let expression"))+  ,("introPattern",(args " <fileName> <line> <column>" introPattern, " Replace variable with exhaustive set of patterns"))+  ,("introCase",(args " <fileName> <line> <column>" introCase, " Introduction of cases analysis via a pattern variable"))+  ,("foldPattern",(args " <fileName> <name (Name of pattern variable: )> <line> <column> <line> <column>" foldPattern, " Folds a sub-expression against a pattern variable"))+   -- menu Slicing+  ,("refacRedunDec",(args " <fileName> <line> <column> <line> <column>" refacRedunDec, " Removes redundant declarations in a where clause or expression"))+  ,("refacSlicing",(args " <fileName> <line> <column> <line> <column>" refacSlicing, " Slices a subexpression"))+  ,("refacSlicTuple",(args " <fileName> <line> <column> <name (Elements to slice: (A for all; (x,_x,_) for some): )>" refacSlicTuple, " slices a definition which returns a tuple"))+  ,("refacMerge",(args " <fileName> <name (Name for new definition: )>" refacMerge, " Merges multiple definitions to form one single definition."))+  ,("refacCacheMerge",(args " <fileName> <line> <column>" refacCacheMerge, " Adds a definition to the cache for merging."))+  ,("refacInstantiate",(args " <fileName> <line> <column> <name (patterns: )>" refacInstantiate, " Instantiates patterns in a generalised function clause"))+   -- menu Fold/Unfold+  ,("unfoldDef",(args " <fileName> <line> <column>" unfoldDef, " Unfold a definition"))+  ,("subFunctionDef",(args " <fileName> <line> <column> <line> <column>" subFunctionDef, " Folds against a definition"))+  ,("genFold",(args " <fileName> <line> <column> <line> <column>" genFold, " Replace an instance of the right hand side of a definition by the corresponding left hand side, creating a new recursive definition."))+  ,("genFoldCache",(args " <fileName> <line> <column>" genFoldCache, " Places an selcted equation into a cache for use by generative fold."))+  ,("refacAsPatterns",(args " <fileName> <name (Name for Pattern: )> <line> <column> <line> <column>" refacAsPatterns, " Converts all appropriate patterns to use an as binding."))+  ,("refacUnfoldAsPatterns",(args " <fileName> <line> <column> <line> <column>" refacUnfoldAsPatterns, " Converts all references to an as pattern to the actuall pattern."))+  ,("simplifyExpr",(args " <fileName> <line> <column> <line> <column>" simplifyExpr, " Attempts to simplify a case expression."))+   -- menu Definitions+  ,("introNewDef",(args " <fileName> <name (Name for new definition? )> <line> <column> <line> <column>" introNewDef, " Introduce a new definition"))+  ,("generaliseDef",(args " <fileName> <name (name of new parameter? )> <line> <column> <line> <column>" generaliseDef, " Generalise a definition"))+  ,("removeDef",(args " <fileName> <line> <column>" removeDef, " Remove a definition if it is no used"))+  ,("duplicateDef",(args " <fileName> <name (Name for duplicate? )> <line> <column>" duplicateDef, " Duplicate a definition at the same level"))+  ,("addOneParameter",(args " <fileName> <name (name of new parameter? )> <line> <column>" addOneParameter, " Add parameter (default undefined)"))+  ,("rmOneParameter",(args " <fileName> <line> <column>" rmOneParameter, " Remove unused parameter"))+  ,("moveDefBtwMod",(args " <fileName> <name (name of the destination module? )> <line> <column>" moveDefBtwMod, " Move a definition from one module to another module"))+  ,("guardToIte",(args " <fileName> <line> <column>" guardToIte, " Converts guards to an if then else"))+  ,("deforest",(args " <fileName>" deforest, " A (partial) implementation of the warm fusion algorithm"))+   -- menu Import/Export+  ,("cleanImports",(args " <fileName>" cleanImports, " Tidy up the import list of the current module"))+  ,("mkImpExplicit",(args " <fileName> <line> <column>" mkImpExplicit, " Make the used entities explicit"))+  ,("addToExport",(args " <fileName> <line> <column>" addToExport, " Add an identifier to the export list"))+  ,("rmFromExport",(args " <fileName> <line> <column>" rmFromExport, " Remove an identifier from the export list"))+   -- menu Data types+  ,("addFieldLabels",(args " <fileName> <line> <column>" addFieldLabels, " Add field labels to a data type declaration"))+  ,("addDiscriminators",(args " <fileName> <line> <column>" addDiscriminators, " Add discriminator functions to a data type declaration"))+  ,("addConstructors",(args " <fileName> <line> <column>" addConstructors, " Add constructor functions to a data type declaration"))+  ,("elimNestedPatterns",(args " <fileName> <line> <column>" elimNestedPatterns, " Eliminate nested pattern matchings"))+  ,("elimPatterns",(args " <fileName> <line> <column>" elimPatterns, " Eliminate pattern matchings"))+  ,("createADTMod",(args " <fileName> <line> <column>" createADTMod, " Create an new ADT module"))+  ,("fromAlgebraicToADT",(args " <fileName> <line> <column>" fromAlgebraicToADT, " Transforms an algebraic data type to an ADT"))+  ,("refacAddCon",(args " <fileName> <name (Enter text for constructor and parameters: )> <line> <column>" refacAddCon, " Adds a new constructor to a data type"))+  ,("refacRmCon",(args " <fileName> <line> <column>" refacRmCon, " Removes constructor from a data type"))+  ,("refacRemoveField",(args " <fileName> <name (Enter position of field to be removed: )> <line> <column>" refacRemoveField, " Removes a field from a data type"))+  ,("refacAddField",(args " <fileName> <name (Type of Field : )> <line> <column>" refacAddField, " Adds a field to a data type"))+   -- menu Duplicate Code+  ,("duplicateCode",(args " <fileName> <name (Clone Token Size: )>" duplicateCode, " Analysis a project for code duplication."))+  ,("refacDupTrans",(args " <fileName> <line> <column> <line> <column>" refacDupTrans, " Transforms duplicate code"))+  ,("refacIdentify",(args " <fileName> <line> <column> <line> <column>" refacIdentify, " identifies a clone class"))+  ]
+ refactorer/PwPf/GlobalPW.hs view
@@ -0,0 +1,379 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  GlobalPW+-- Copyright   :  (c) Jose Proenca 2005+-- License     :  GPL+--+-- Maintainer  :  jproenca@di.uminho.pt+-- Stability   :  experimental+-- Portability :  portable+--+-- A global pointwise syntax and its relation with:+--+--   * An expression in programatica's abstract syntax tree;+--+--   * A pointwise core - "PWCore".+--+-----------------------------------------------------------------------------++module GlobalPW (+    -- * Data Type+    {-| Represents a pointwise language that:++            (1) is very similar to the way we are used to program in haskell;++            (2) not the most general one, since it only deals with booleans, natural numbers and lists.+    -}+    GLTerm (..),++    -- * Conversion of an haskell expression to a GlobalPW term+    exp2Global,+    +    -- * Conversion of a GlobalPW term to a "PWCore" term+    global2core++ ) where++import PWCore+import RefacUtils+import PrettyPrint++--------------------------------+----- Global definition --------+--------------------------------++data GLTerm +  = Star                  -- ^Unit+  | V String              -- ^Variable+  | GLTerm:-:GLTerm       -- ^Aplication+  | Lam String GLTerm     -- ^Abstraction+  | GLTerm:&:GLTerm       -- ^Pair+  | Pi1 GLTerm            -- ^Point-wise first+  | Pi2 GLTerm            -- ^Point-wise second+  | Inl' GLTerm           -- ^Point-wise left injection+  | Inr' GLTerm           -- ^Point-wise right injection+  | Case' GLTerm (String,GLTerm) (String,GLTerm)+                          -- ^Case of+  | In'  HsExpP GLTerm    -- ^Injection on a specified type+  | Out' HsExpP GLTerm    -- ^Extraction of the functor of a specified type+  | Fix' GLTerm           -- ^Fixed-point+---------------- from PCF ---------------------+  | T'                    -- ^Constant True+  | F'                    -- ^Constant False+  | Z'                    -- ^Constant Zero+  | Suc GLTerm            -- ^Successor+  | Pred GLTerm           -- ^Predecessor+  | IsZ GLTerm            -- ^is zero?+  | Ite GLTerm GLTerm GLTerm -- ^if then else+  | N'                    -- ^Empty list+  | GLTerm ::: GLTerm     -- ^Constructor for lists+  | Hd GLTerm             -- ^Head of a list+  | Tl GLTerm             -- ^Tail of a list+  | IsN  GLTerm           -- ^is the list empty?+  | Letrec String GLTerm GLTerm+                          -- ^recursive let+---------------- from BNL ---------------------+  | RecNat  GLTerm GLTerm GLTerm+                       -- ^Primitive recursion on Nat's+  | RecList GLTerm GLTerm GLTerm+                       -- ^Primitive recursion on List's+    deriving Show++++++{- | Applies a simple transformation from an expression of programatica's+     abstract syntax tree to 'GLTerm'.++     The recognized grammar is:+       +      [G, G1, G2, G3 @::=@]+           (G) | @undefined@ | @()@ | @_L@ | @inN (_L::@/type/@) @G |@ ouT (_L::@/type/@)@ +           |@ True @|@ False @|@ 0 @|@ [] @|@ /n, n>0/ @|@ [@G1@, @G2@, ... ] @| G1@ : @G2 |@ succ @G |@ pred @G+           |@ (==0) @G |@ @G@ == 0 @|@ head @G@ @|@ tail @G@ @|@ null @+           |@ recNat @G1@ @G2@ @G3@ @|@ recList @G1@ @G2@ @G3+           |@ fix @G@ @|@ if @G1@ then @G2@ else @G3@ @|@ /var/ @|@ (@G1@,@G2@) @|@ fst @|@ snd @|@ Left @|@ Right @+           |@ @G1@ /infixOp/ @G2@ @|@ \\/var1 var2 .../ -> @G+           |@ case @G1@ of Left /var1/ -> @G2@; Right /var2/ ->@G3 +           |@ let /var/ = @G1@ in @G2@ +           @ ++     where types are read as the pretty print string, and /var/, /var1/ and /var2/ are variables that are read as strings also.+-}++exp2Global :: Monad m => HsExpI PNT -> m GLTerm++-- parentisis+exp2Global (Exp (HsParen e)) = exp2Global e++-- unit -> "()" or "undefined" or "_L"+exp2Global (Exp (HsId (HsCon (PNT (PN (Qual (PlainModule "Prelude") "()") (G (PlainModule "Prelude") "()" (N (Just _)))) (ConstrOf (PN "()" (G (PlainModule "Prelude") "()" (N (Just _)))) (TypeInfo {defType = Just Data, constructors = [ConInfo {conName = PN "()" (G (PlainModule "Prelude") "()" (N (Just _))), conArity = 0, conFields = Nothing}], fields = []})) (N (Just loc))))))+    = return Star ++exp2Global (Exp (HsId (HsVar (PNT (PN (UnQual "undefined") (G (PlainModule "Prelude") "undefined" (N (Just _)))) _ (N (Just _))))))+    = return Star++exp2Global (Exp (HsId (HsVar (PNT (PN (UnQual "_L") _) _ _))))+    = return Star+++-- Constants (inN,ouT, True, False,[],int)+-- inN (_L::typ) exp+exp2Global (Exp (HsApp (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "inN") _) _ (N (Just _)))))) (Exp (HsParen typ@(Exp (HsExpTypeSig _ (Exp (HsId (HsVar (PNT (PN (UnQual "_L") _) _ (N (Just _)))))) [] +  typ'+  )))))) exp2))+   = exp2Global exp2 >>= return . In' typ--(pp typ)++-- ouT (_L::typ) exp+exp2Global (Exp (HsApp (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "ouT") _) _ (N (Just _)))))) (Exp (HsParen typ@(Exp (HsExpTypeSig _ (Exp (HsId (HsVar (PNT (PN (UnQual "_L") _) _ (N (Just _)))))) [] +  typ'+  )))))) exp2))+   = exp2Global exp2 >>= return . Out' typ --(pp typ)++-- True+exp2Global (Exp (HsId (HsCon (PNT (PN (UnQual "True") (G (PlainModule "Prelude") "True" (N (Just _)))) (ConstrOf (PN "Bool" (G (PlainModule "Prelude") "Bool" (N (Just _)))) (TypeInfo {defType = Just Data, constructors = [ConInfo {conName = PN "False" (G (PlainModule "Prelude") "False" (N (Just _))), conArity = 0, conFields = Nothing},ConInfo {conName = PN "True" (G (PlainModule "Prelude") "True" (N (Just _))), conArity = 0, conFields = Nothing}], fields = []})) (N (Just _))))))+    = return T'++-- False+exp2Global (Exp (HsId (HsCon (PNT (PN (UnQual "False") (G (PlainModule "Prelude") "False" (N (Just _)))) (ConstrOf (PN "Bool" (G (PlainModule "Prelude") "Bool" (N (Just _)))) (TypeInfo {defType = Just Data, constructors = [ConInfo {conName = PN "False" (G (PlainModule "Prelude") "False" (N (Just _))), conArity = 0, conFields = Nothing},ConInfo {conName = PN "True" (G (PlainModule "Prelude") "True" (N (Just _))), conArity = 0, conFields = Nothing}], fields = []})) (N (Just _))))))+    = return F'++-- Zero+exp2Global (Exp (HsLit _ (HsInt 0)))+    = return Z'++-- []+exp2Global ((Exp (HsList [])))+   = return N'++-- n>0+exp2Global (Exp (HsLit _ (HsInt n)))+   | n > 0 = exp2Global (Exp $ HsLit loc0 $ HsInt  (n-1)) >>= return . Suc+++------ recursion+-- recNat+exp2Global (Exp (HsApp (Exp (HsApp (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "recNat") _) _ _)))) exp1)) exp2)) exp3))+  = do term1 <- exp2Global exp1+       term2 <- exp2Global exp2+       term3 <- exp2Global exp3+       return $ RecNat term1 term2 term3++-- recList+exp2Global (Exp (HsApp (Exp (HsApp (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "recList") _) _ _)))) exp1)) exp2)) exp3))+  = do term1 <- exp2Global exp1+       term2 <- exp2Global exp2+       term3 <- exp2Global exp3+       return $ RecList term1 term2 term3++-- fix exp+exp2Global (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "fix") _) _ _)))) exp))+    = do term1 <- exp2Global exp+         return $ Fix' term1++-- let var = exp1 -> exp2+exp2Global (Exp (HsLet [Dec (HsPatBind _ (Pat (HsPId (HsVar (PNT (PN (UnQual str) _) _ _)))) (HsBody exp1) [])] exp2))+    =   do t1 <- exp2Global exp1+           t2 <- exp2Global exp2+           return $ Letrec str t1 t2++------ remaining operators+-- succ exp+exp2Global (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "succ") _) _ (N (Just _)))))) e))+    = do t <- exp2Global e+         return $ Suc t++-- pred exp+exp2Global (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "pred") _) _ (N (Just _)))))) e))+    = do t <- exp2Global e+         return $ Pred t++-- (== 0) exp+exp2Global (Exp (HsApp (Exp (HsRightSection (HsVar (PNT (PN (UnQual "==") (G (PlainModule "Prelude") "==" (N (Just _)))) (MethodOf (PN "Eq" (G (PlainModule "Prelude") "Eq" (N (Just _)))) _ [PN "==" (G (PlainModule "Prelude") "==" (N (Just _))),PN "/=" (G (PlainModule "Prelude") "/=" (N (Just _)))]) _)) (Exp (HsLit _ (HsInt 0))))) exp))+    = do t <- exp2Global exp+         return $ IsZ t++-- exp == 0+exp2Global (Exp (HsInfixApp exp (HsVar (PNT (PN (UnQual "==") (G (PlainModule "Prelude") "==" (N (Just _)))) (MethodOf (PN "Eq" (G (PlainModule "Prelude") "Eq" (N (Just _)))) _ [PN "==" (G (PlainModule "Prelude") "==" (N (Just _))),PN "/=" (G (PlainModule "Prelude") "/=" (N (Just _)))]) (N (Just _)))) (Exp (HsLit _ (HsInt 0)))))+    = do t <- exp2Global exp+         return $ IsZ t++-- [exp1, exp2, ... ]+exp2Global (Exp (HsList (e1:e2)))+  = do t1 <- exp2Global e1+       t2 <- exp2Global (Exp (HsList e2))+       return $ t1 ::: t2++-- x : xs+exp2Global (Exp (HsInfixApp e1 (HsCon (PNT (PN (UnQual ":") (G (PlainModule "Prelude") ":" (N (Just _)))) (ConstrOf (PN "[]" (G (PlainModule "Prelude") "[]" (N (Just _)))) (TypeInfo {defType = Just Data, constructors = [ConInfo {conName = PN "[]" (G (PlainModule "Prelude") "[]" (N (Just _))), conArity = 0, conFields = Nothing},ConInfo {conName = PN ":" (G (PlainModule "Prelude") ":" (N (Just _))), conArity = 2, conFields = Nothing}], fields = []})) (N (Just _)))) e2))+   = do t1 <- exp2Global e1+        t2 <- exp2Global e2+        return $ t1 ::: t2++-- head exp+exp2Global (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "head") _) _ (N (Just _)))))) e))+    = do t <- exp2Global e+         return $ Hd t++-- tail exp+exp2Global (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "tail") _) _ (N (Just _)))))) e))+    = do t <- exp2Global e+         return $ Tl t++-- null exp+exp2Global (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "null") _) _ (N (Just _)))))) e))+    = do t <- exp2Global e+         return $ IsN t++-- if exp1 then exp2 else exp3+exp2Global (Exp (HsIf e1 e2 e3)) =+   do t1 <- exp2Global e1+      t2 <- exp2Global e2+      t3 <- exp2Global e3+      return $ Ite t1 t2 t3++-- var+exp2Global (Exp (HsId (HsVar (PNT (PN (UnQual str) _) _ (N (Just _))))))+   = return $ V str++-- pairs+exp2Global (Exp (HsTuple [e1,e2]))+  = do t1 <- exp2Global e1+       t2 <- exp2Global e2+       return $ t1 :&: t2++-- fst exp+exp2Global (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "fst") _) _ (N (Just _)))))) e))+    = do t <- exp2Global e+         return $ Pi1 t++-- snd exp+exp2Global (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "snd") _) _ (N (Just _)))))) e))+    = do t <- exp2Global e+         return $ Pi2 t++-- Left exp+exp2Global (Exp (HsApp (Exp (HsId (HsCon (PNT (PN (UnQual "Left") (G (PlainModule "Prelude") "Left" (N (Just _)))) (ConstrOf (PN "Either" (G (PlainModule "Prelude") "Either" (N (Just _)))) (TypeInfo {defType = Just Data, constructors = [ConInfo {conName = PN "Left" (G (PlainModule "Prelude") "Left" (N (Just _))), conArity = 1, conFields = Nothing},ConInfo {conName = PN "Right" (G (PlainModule "Prelude") "Right" (N (Just _))), conArity = 1, conFields = Nothing}], fields = []})) _)))) e))+    = do t <- exp2Global e+         return $ Inl' t++-- Right exp+exp2Global (Exp (HsApp (Exp (HsId (HsCon (PNT (PN (UnQual "Right") (G (PlainModule "Prelude") "Right" (N (Just _)))) (ConstrOf (PN "Either" (G (PlainModule "Prelude") "Either" (N (Just _)))) (TypeInfo {defType = Just Data, constructors = [ConInfo {conName = PN "Left" (G (PlainModule "Prelude") "Left" (N (Just _))), conArity = 1, conFields = Nothing},ConInfo {conName = PN "Right" (G (PlainModule "Prelude") "Right" (N (Just _))), conArity = 1, conFields = Nothing}], fields = []})) _)))) e))+    = do t <- exp2Global e+         return $ Inr' t++-- application+exp2Global (Exp (HsApp e1 e2)) =+   do t1 <- exp2Global e1+      t2 <- exp2Global e2+      return $ t1 :-: t2++-- infix application+exp2Global (Exp (HsInfixApp e1 op e2)) =+   do t1 <- exp2Global e1+      t2 <- exp2Global e2+      return $ (getOpName op) :-: t1 :-: t2+  where getOpName ((HsVar (PNT (PN (UnQual op) _) _ _))) = V op++-- \ var -> exp+exp2Global (Exp (HsLambda [Pat (HsPId (HsVar (PNT (PN (UnQual str) _) _ _)))] e))+   = do t <- exp2Global e+        return $ Lam str t++-- \ var1 var2 ... -> exp+exp2Global (Exp (HsLambda (h@((Pat (HsPId (HsVar _)))):t) e))+    = exp2Global (Exp (HsLambda [h] (Exp (HsLambda t e))))++-- case exp1 of Left var2 -> exp2; Right var3 -> exp3+exp2Global (Exp (HsCase exp1 +             [HsAlt _ (Pat (HsPApp (PNT (PN (UnQual "Left") (G (PlainModule "Prelude") "Left" (N (Just _)))) (ConstrOf (PN "Either" (G (PlainModule "Prelude") "Either" (N (Just _)))) (TypeInfo {defType = Just Data, constructors = [ConInfo {conName = PN "Left" (G (PlainModule "Prelude") "Left" (N (Just _))), conArity = 1, conFields = Nothing},ConInfo {conName = PN "Right" (G (PlainModule "Prelude") "Right" (N (Just _))), conArity = 1, conFields = Nothing}], fields = []})) (N (Just _))) [Pat (HsPId (HsVar (PNT (PN (UnQual str2) _) _ _)))])) (HsBody exp2) []+             ,HsAlt _ (Pat (HsPApp (PNT (PN (UnQual "Right") (G (PlainModule "Prelude") "Right" (N (Just _)))) (ConstrOf (PN "Either" (G (PlainModule "Prelude") "Either" (N (Just _)))) (TypeInfo {defType = Just Data, constructors = [ConInfo {conName = PN "Left" (G (PlainModule "Prelude") "Left" (N (Just _))), conArity = 1, conFields = Nothing},ConInfo {conName = PN "Right" (G (PlainModule "Prelude") "Right" (N (Just _))), conArity = 1, conFields = Nothing}], fields = []})) (N (Just _))) [Pat (HsPId (HsVar (PNT (PN (UnQual str3) _) _ _)))])) (HsBody exp3) []]))+  = do t1 <- exp2Global exp1+       t2 <- exp2Global exp2+       t3 <- exp2Global exp3+       return $ Case' t1 (str2,t2) (str3,t3)++exp2Global x = --mzero+               --fail +               error $ "not a Global term: "++ pp x+++++--------------------------------+------- global to core ---------++{- | Converts a 'GLTerm' to a 'PWTerm', which is a more general representation for+       pointwise terms, but with less pratical constructors (in "PWCore").+-}++global2core :: GLTerm -> PWTerm+global2core Star = Unit+global2core (V str) = Var' str+global2core (Lam str t) = Abstr str (global2core t)+global2core (t1 :-: t2) = (global2core t1) :@: (global2core t2)+global2core (t1 :&: t2) = (global2core t1) :><: (global2core t2)+global2core (Pi1 t)     = Fst (global2core t)+global2core (Pi2 t)     = Snd (global2core t)+global2core T'          = In boolT (Inl Unit)+global2core F'          = In boolT (Inr Unit)+global2core Z'          = In intT (Inl Unit)+global2core (Suc t)     = In intT (Inr $ global2core t)+global2core (Pred t)    =+        Case (Out intT$ global2core t) ("_",In intT (Inl Unit))+                          ("x", (Var' "x"))+global2core (IsZ t) =+        Case (Out intT$ global2core t) ("_", In boolT (Inl Unit))+                          ("_", In boolT (Inr Unit))+global2core (Ite t1 t2 t3) =+        Case (Out boolT$ global2core t1) ("_", global2core t2)+                           ("_", global2core t3)+global2core (Fix' t) = Fix (global2core t)++global2core N'          = In listT (Inl Unit)+global2core (t1 ::: t2) = In listT (Inr ((global2core t1):><:(global2core t2)))+global2core (IsN t) =+        Case (Out listT$ global2core t) ("_", In boolT (Inl Unit))+                          ("_", In boolT (Inr Unit))+global2core (Hd t) =+        Case (Out listT$ global2core t) ("_", Var' "undefined")+                          ("x", Fst $ Var' "x")+global2core (Tl t) =+        Case (Out listT$ global2core t) ("_", In listT (Inl Unit))+                          ("x", Snd $ Var' "x")+global2core (Letrec str t1 t2) =+        let func = (Fix (Abstr str (global2core t1)))+        in  (Abstr str (global2core t2)) :@: func+global2core (Inl' t) = Inl (global2core t)+global2core (Inr' t) = Inr (global2core t)+global2core (Case' a (s1,b) (s2,c)) =+   Case (global2core a) (s1,global2core b) (s2,global2core c)+global2core (In' s t) = In s (global2core t)+global2core (Out' s t) = Out s (global2core t)+global2core (RecNat t1 t2 t3) =+        (Fix $ Abstr "r" $ Abstr "n" $ Abstr "f" $ Abstr "z" $+            Case (Out intT (Var' "n"))+                ("x", Var' "z")+                ("y", (Var' "f") :@: (Var' "y") :@:+                    ((Var' "r"):@:(Var' "y"):@:(Var' "f"):@:(Var' "z"))))+        :@: (global2core t1) :@: (global2core t2) :@: (global2core t3)+global2core (RecList t1 t2 t3) =+        (Fix $ Abstr "r" $ Abstr "l" $ Abstr "f" $ Abstr "z" $+            Case (Out listT (Var' "l"))+                ("x", Var' "z")+                ("y", (Var' "f") :@: (Fst$Var' "y") :@: (Snd$Var' "y") :@:+                   ((Var' "r"):@:(Snd$Var' "y"):@:(Var' "f"):@:(Var' "z"))))+        :@: (global2core t1) :@: (global2core t2) :@: (global2core t3)+ ++---- expressions for (_L::Int)+--                   (_L::Bool)+--                   (_L::[a])+intT = mkType (Typ (HsTyCon (PNT (PN (UnQual "Int") (G (PlainModule "Prelude") "Int" (N (Just loc0)))) (Type (TypeInfo {defType = Just Primitive, constructors = [], fields = []})) (N (Just loc0)))))+boolT = mkType (Typ (HsTyCon (PNT (PN (UnQual "Bool") (G (PlainModule "Prelude") "Bool" (N (Just loc0)))) (Type (TypeInfo {defType = Just Data, constructors = [ConInfo {conName = PN "False" (G (PlainModule "Prelude") "False" (N (Just loc0))), conArity = 0, conFields = Nothing},ConInfo {conName = PN "True" (G (PlainModule "Prelude") "True" (N (Just loc0))), conArity = 0, conFields = Nothing}], fields = []})) (N (Just loc0)))))+listT = mkType (Typ (HsTyApp (Typ $ HsTyCon (PNT (PN (Qual (PlainModule "Prelude") "[]") (G (PlainModule "Prelude") "[]" (N (Just loc0)))) (Type (TypeInfo {defType = Just Data, constructors = [ConInfo {conName = PN "[]" (G (PlainModule "Prelude") "[]" (N (Just loc0))), conArity = 0, conFields = Nothing},ConInfo {conName = PN ":" (G (PlainModule "Prelude") ":" (N (Just loc0))), conArity = 2, conFields = Nothing}], fields = []})) (N (Just loc0)))) (Typ $ HsTyVar (PNT (PN (UnQual "a") (S loc0)) (Type (TypeInfo {defType = Nothing, constructors = [], fields = []})) (N (Just loc0))))))++mkType typ = Exp $ HsParen $ typedExp "_L" typ+typedExp strVar typ = Exp (HsExpTypeSig loc0 (nameToExp strVar) [] typ)+
+ refactorer/PwPf/Makefile view
@@ -0,0 +1,19 @@+top			= .+lhsModules	= $(shell find $(top) -name "*.lhs")+hsModules	= GlobalPW.hs PWCore.hs Pointfree.hs PwPfConversion.hs ../RefacPwPf.hs+#$(shell find $(top) -name "*.hs")+#Core.hs Pointfree.hs Conversion.hs PCF.hs BNL.hs Common.hs++all: $(top)/docs/index.html ++$(top)/docs/index.html : docdir $(hsModules)+	haddock -h -o docs/ $(hsModules)++docdir: +	mkdir -p $(top)/docs++clean:+	rm -f *~ *.log *.aux *.toc *.bak *.out *.bbl *.blg++cleanall : clean+	rm -f $(top)/docs/*
+ refactorer/PwPf/PWCore.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  PWCore+-- Copyright   :  (c) Jose Proenca 2005+-- License     :  GPL+--+-- Maintainer  :  jproenca@di.uminho.pt+-- Stability   :  experimental+-- Portability :  portable+--+-- A syntax of a general pointwise language.+--+-----------------------------------------------------------------------------++module PWCore (+  {- | A simple definition of a pointwise language where:+        +        * products and sums are allowed;++        * constants are dealed by the use of /in/ and /out/ functions that+           allows to go from any type that has an associated base functor to and+           from a representation of that base functor using sums and products;++        * recursion is only possible by the use of the fixed point constructor.+  -}++  PWTerm (..)+) where++import RefacUtils++-- *Definition of the data type++data PWTerm = Unit               -- ^Unit+          | Var' String          -- ^Variable+          | PWTerm:@:PWTerm      -- ^Aplication+          | Abstr String PWTerm  -- ^Abstraction+          | PWTerm:><:PWTerm     -- ^Pair+          | Fst PWTerm           -- ^Point-wise first+          | Snd PWTerm           -- ^Point-wise second+          | Inl PWTerm           -- ^Point-wise left injection+          | Inr PWTerm           -- ^Point-wise right injection+          | Case PWTerm (String,PWTerm) (String,PWTerm)+                                 -- ^Case of+          | In  HsExpP PWTerm    -- ^Injection on a specified type+          | Out HsExpP PWTerm    -- ^Extraction of the functor of a specified type+          | Fix PWTerm+                                 -- ^Fixed point+            deriving Show+ 
+ refactorer/PwPf/Pointfree.hs view
@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Pointfree+-- Copyright   :  (c) Jose Proenca 2005+-- License     :  GPL+--+-- Maintainer  :  jproenca@di.uminho.pt+-- Stability   :  experimental+-- Portability :  portable+--+-- A syntax of a general pointfree language.+--+-----------------------------------------------------------------------------++module Pointfree (+  -- * Data Type+  {-| Represents a pointfree language where:+        +        (1) products and sums are treated++        (2) base types are obtained and decomposed by the use of the /IN/ and+            /OUT/ constructors++        (3) recursion can be expressed by the point-fix function or by a paramorphism++        (4) free variables are called macros and represent known pointfree expressions+  -} +  PFTerm (..),+  +  -- * Conversion of a "PFTerm" to an haskell expression+  pf2Exp++) where++import RefacUtils+++data PFTerm = BANG             -- ^Constant function that returns Unit+          | ID                 -- ^Identity+          | APP                -- ^Apply+          | Curry PFTerm       -- ^Curry+          | PFTerm :.: PFTerm  -- ^Composition+          | PFTerm :\/: PFTerm -- ^Either+          | PFTerm :/\: PFTerm -- ^Split+          | FST                -- ^Point-free first+          | SND                -- ^Point-free second+          | INL                -- ^Point-free left injection+          | INR                -- ^Point-free right injection+          | IN HsExpP          -- ^Injection on a specified type+          | OUT HsExpP         -- ^Gets the functor+          | PARA HsExpP PFTerm -- ^Paramorphism+          | FIX                -- ^Fixed point function+          | Macro String       -- ^Macros of frequently used pointfree terms+            deriving Show+ ++-- Implementation of a pointfree term on a HsExp+{- | Applies a tranformation from a 'PFTerm' to an expression of programatica's+     abstract tree. Note that the type information inside the /IN/, /OUT/ and /PARA/+     terms is represented as a programatica's expression @L::type@, where the @type@+     is the real type information.+-}+pf2Exp :: PFTerm -> HsExpI PNT++pf2Exp BANG = nameToExp "bang"+pf2Exp ID = prelVar "id"+pf2Exp APP = nameToExp "app"++pf2Exp (Curry t1)   = Exp $ HsApp (nameToExp "curry") (mbParen$ pf2Exp t1)+pf2Exp (t1 :.: t2)  = Exp (HsInfixApp  (mbParen$ pf2Exp t1)+                           (prelOp ".") (mbParen$ pf2Exp t2))+pf2Exp (t1 :\/: t2)  = Exp (HsInfixApp  (mbParen$ pf2Exp t1)+                           (nameToOp "\\/") (mbParen$ pf2Exp t2))+pf2Exp (t1 :/\: t2)  = Exp (HsInfixApp  (mbParen$ pf2Exp t1)+                           (nameToOp "/\\") (mbParen$ pf2Exp t2))++pf2Exp FST          = nameToExp "fst"+pf2Exp SND          = nameToExp "snd"+pf2Exp INL          = prelCon "Left"+pf2Exp INR          = prelCon "Right"+++pf2Exp (IN typ)     = -- inN (_L::str)+    Exp (HsApp (nameToExp "inN") typ)--(Exp $ HsParen $ typedExp "_L" str))+pf2Exp (OUT typ)    = -- ouT (_L::str)+    Exp (HsApp (nameToExp "ouT") typ)--(Exp $ HsParen $ typedExp "_L" str))++pf2Exp (PARA typ t) = -- para (_L::str) t+    Exp (HsApp (Exp $ HsApp (nameToExp "para") typ)--(Exp $ HsParen $ typedExp "_L" str))+      (mbParen$ pf2Exp t))+pf2Exp FIX       = nameToExp "fix"++pf2Exp (Macro str)  = nameToExp str+ +++---------------------------+--- auxiliary functions ---+---------------------------++-- nameToExp is imported from RefacUtils.hs+-- nameToExp str = Exp (HsId (HsVar (PNT (PN (UnQual str) (S loc0)) Value (N (Just loc0)))))++prelVar str = Exp (HsId (HsVar (PNT (PN (UnQual str) (G (PlainModule "Prelude") str (N (Just loc0)))) Value (N (Just loc0)))))++conToExp str = Exp (HsId (HsCon (PNT (PN (UnQual str) (S loc0)) Value (N (Just loc0)))))++prelCon str = Exp (HsId (HsCon (PNT (PN (UnQual str) (G (PlainModule "Prelude") str (N (Just loc0)))) Value (N (Just loc0)))))++-- | places parentisis in an expression only if it is necessary+--mbParen :: EI -> HsExp+mbParen e@(Exp (HsApp _ _)) = Exp $ HsParen e+mbParen e@(Exp (HsInfixApp _ _ _)) = Exp $ HsParen e+mbParen e@(Exp (HsCase _ _)) = Exp $ HsParen e+mbParen e@(Exp (HsLambda _ _)) = Exp $ HsParen e+mbParen x = x++prelOp str = (HsVar (PNT (PN (UnQual str) (G (PlainModule "Prelude") str (N (Just loc0)))) Value (N (Just loc0))))+nameToOp str = (HsVar (PNT (PN (UnQual str) (S loc0)) Value (N (Just loc0))))+++typedExp strVar strType = Exp (HsExpTypeSig loc0 (nameToExp strVar) [] (Typ $ HsTyVar (PNT (PN (UnQual strType) (S loc0)) (Type (TypeInfo {defType = Nothing, constructors = [], fields = []})) (N (Just loc0)))))+
+ refactorer/PwPf/PointlessP/Combinators.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS -fglasgow-exts #-}++module PointlessP.Combinators where++-- Point free programming combinators++_L :: a+_L = undefined++-- The final object++data One++instance Show One+    where show _ = "_L"++bang :: a -> One+bang _ = _L++-- Products++infix 6  /\+(/\) :: (a -> b) -> (a -> c) -> a -> (b,c)+(/\) f g x = (f x, g x)++infix 7  ><+(><) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)+f >< g = f . fst /\ g . snd++-- Sums++inl :: a -> Either a b+inl = Left++inr :: b -> Either a b+inr = Right++infix 4 \/+(\/) :: (b -> a) -> (c -> a) -> Either b c -> a+(\/) = either++infix 5 -|-+(-|-) :: (a -> b) -> (c -> d) -> Either a c -> Either b d+f -|- g = inl . f \/ inr . g++infix 5 <>+(<>) :: (a -> b) -> (c -> d) -> Either a c -> Either b d+(<>) = (-|-)++-- Exponentials++app :: (a -> b, a) -> b+app (f,x) = f x++infix 0 !+(!) :: a -> b -> a+(!) = const++-- Points++pnt :: a -> One -> a+pnt x = \_ -> x+ +-- Guards++grd :: (a -> Bool) -> a -> Either a a+grd p x = if p x then inl x else inr x++(?) :: (a -> Bool) -> a -> Either a a+(?) = grd
+ refactorer/PwPf/PointlessP/Functors.hs view
@@ -0,0 +1,138 @@+{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}++module PointlessP.Functors where++import PointlessP.Combinators++-- Data types as fixed points of functors - PolyP style++class (Functor f) => FunctorOf f d | d -> f+    where inn' :: f d -> d+	  out' :: d -> f d++-- Bridge to data types as explicit fixed points++newtype (Functor f) => Mu f = Mu {unMu :: f (Mu f)}++instance (Functor f) => FunctorOf f (Mu f)+    where inn' = Mu+	  out' = unMu++--infixr 5 :+:+--infixr 6 :*:+--infixr 9 :@:++-- Functors++newtype Id x        = Id {unId :: x}+newtype Const t x   = Const {unConst :: t}+data (PSum g h) x    = Inl (g x) | Inr (h x)+data (PProd g h) x    = PProd (g x) (h x)+newtype (PApp g h) x = Comp {unComp :: g (h x)}++-- Maps++instance Functor Id+    where fmap f (Id x) = Id (f x)++instance Functor (Const t)+    where fmap f (Const x) = Const x++instance (Functor g, Functor h) => Functor (PSum g h)+    where fmap f (Inl x) = Inl (fmap f x)+	  fmap f (Inr x) = Inr (fmap f x)++instance (Functor g, Functor h) => Functor (PProd g h)+    where fmap f (PProd x y) = PProd (fmap f x) (fmap f y)++instance (Functor g, Functor h) => Functor (PApp g h)+    where fmap f (Comp x) = Comp (fmap (fmap f) x)++-- From functors to sums of products++class Rep a b | a -> b+    where to :: a -> b+	  from :: b -> a++instance Rep (Id x) x+    where to (Id x) = x+	  from x = Id x++instance Rep (Const t x) t+    where to (Const t) = t+	  from t = Const t++instance (Rep (g x) y, Rep (h x) z) => Rep ((PSum g h) x) (Either y z)+    where to (Inl a) = Left (to a)+	  to (Inr a) = Right (to a)+	  from (Left a) = Inl (from a)+	  from (Right a) = Inr (from a)++instance (Rep (g x) y, Rep (h x) z) => Rep ((PProd g h) x) (y, z)+    where to (PProd a b) = (to a, to b)+	  from (a, b) = PProd (from a) (from b)++instance (Functor g, Rep (h x) y, Rep (g y) z) => Rep ((PApp g h) x) z+    where to (Comp x) = to (fmap to x) +	  from y = Comp (fmap from (from y))++-- We also need the (obvious) representation of type functors++instance Rep [a] [a]+    where to = id+	  from = id++-- The out and inn functions++out :: (FunctorOf f d, Rep (f d) fd) => d -> fd+out = to . out'++inn :: (FunctorOf f d, Rep (f d) fd) => fd -> d+inn = inn' . from++ouT :: (FunctorOf f d, Rep (f d) fd) => d -> d -> fd+ouT _ = to . out'++inN :: (FunctorOf f d, Rep (f d) fd) => d -> fd -> d+inN _ = inn' . from++-- Auxiliary definitions++instance FunctorOf (PSum (Const One) (PProd (Const a) Id)) [a] +    where inn' (Inl (Const _))          = []+	  inn' (Inr (PProd (Const x) (Id xs))) = x:xs+	  out' []     = Inl (Const _L)+	  out' (x:xs) = Inr (PProd (Const x) (Id xs))++nil :: One -> [a]+nil = inn . inl++cons :: (a,[a]) -> [a]+cons = inn . inr++instance FunctorOf (PSum (Const One) Id) Int+    where inn' (Inl (Const _)) = 0+	  inn' (Inr (Id n)) = n+1+	  out' 0     = Inl (Const _L)+	  out' (n+1) = Inr (Id n)++zero :: One -> Int+zero = inn . inl++suck :: Int -> Int+suck = inn . inr ++instance FunctorOf (PSum (Const One) (Const One)) Bool+    where inn' (Inl _) = True+	  inn' (Inr _) = False+	  out' True  = Inl _L+	  out' False = Inr _L++true :: One -> Bool+true = inn . inl++false :: One -> Bool+false = inn . inr++fix :: (a->a) -> a+fix f = f (fix f)
+ refactorer/PwPf/PointlessP/Isomorphisms.hs view
@@ -0,0 +1,38 @@+module PointlessP.Isomorphisms where++import PointlessP.Combinators++swap :: (a,b) -> (b,a)+swap = snd /\ fst++coswap :: Either a b -> Either b a+coswap = inr \/ inl++distl :: (Either a b, c) -> Either (a,c) (b,c)+distl = app . ((curry inl \/ curry inr) >< id)++undistl :: Either (a,c) (b,c) -> (Either a b, c)+undistl = inl >< id \/ inr >< id++distr :: (c, Either a b) -> Either (c,a) (c,b)+distr = (swap -|- swap) . distl . swap+--distr = app . ((curry (inl . swap) \/ curry (inr . swap)) >< id) . swap++undistr :: Either (c,a) (c,b) -> (c, Either a b)+undistr = (id >< inl) \/ (id >< inr)++assocl :: (a,(b,c)) -> ((a,b),c)+assocl = id >< fst /\ snd . snd++assocr :: ((a,b),c) -> (a,(b,c))+assocr = fst . fst  /\  snd >< id++coassocl :: Either a (Either b c) -> Either (Either a b) c+coassocl = (inl . inl) \/ (inr -|- id)++coassocr :: Either (Either a b) c -> Either a (Either b c)+coassocr = (id -|- inl) \/ (inr . inr)+++unpnt :: (One -> a -> b) -> a -> b+unpnt f = app . (f . bang /\ id)
+ refactorer/PwPf/PointlessP/RecursionPatterns.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS -fglasgow-exts #-}++module PointlessP.RecursionPatterns where++import PointlessP.Combinators+import PointlessP.Functors++pmap :: (FunctorOf f d, Rep (f a) fa, Rep (f b) fb) => +        d -> (a -> b) -> (fa -> fb)+pmap (_::d) f = +    to . (fmap:: (FunctorOf f d) => (a -> b) -> (f a -> f b)) f . from++hylo :: (FunctorOf f d, Rep (f b) fb, Rep (f a) fa) => +        d -> (fb -> b) -> (a -> fa) -> a -> b+hylo (_::d) g h = g . pmap (_L::d) (hylo (_L::d) g h) . h++cata :: (FunctorOf f d, Rep (f a) fa, Rep (f d) fd) =>+        d -> (fa -> a) -> d -> a+cata (_::d) f = hylo (_L::d) f out++ana :: (FunctorOf f d, Rep (f a) fa, Rep (f d) fd) =>+       d -> (a -> fa) -> a -> d+ana (_::d) f = hylo (_L::d) inn f++para (_::d) f = +    hylo (_L :: FunctorOf f d => Mu (PApp f (PProd Id (Const d)))) +	 f (pmap (_L::d) (id /\ id) . out)++apo (_::d) f = +    hylo (_L :: FunctorOf f d => Mu (PApp f (PSum Id (Const d))))+	 (inn . pmap (_L::d) (id \/ id)) f++zygo (_::d) g f =+    hylo (_L :: FunctorOf f d => Mu (PApp f (PProd Id (Const a))))+	 f (pmap (_L::d) (id /\ cata (_L::d) g) . out)++paraZygo (_::d) = zygo (_L::d) inn++accum (_::d) t f = +    hylo (_L :: FunctorOf f d => Mu (PProd f (Const a))) +	 f ((t /\ snd) . (out >< id))+
+ refactorer/PwPf/PwPfConversion.hs view
@@ -0,0 +1,177 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  PwPfConversion+-- Copyright   :  (c) Jose Proenca 2005+-- License     :  GPL+--+-- Maintainer  :  jproenca@di.uminho.pt+-- Stability   :  experimental+-- Portability :  portable+--+-- Translations between pointwise and point-free expressions, expressed in+--  the modules "PWCore" and "PointFree".+--+-----------------------------------------------------------------------------++module PwPfConversion (+  -- * Translation from "Pointfree" to "PWCore"+  pf2core,++  -- * Translation from "PWCore" to "Pointfree"+  core2Pf+) where++import PWCore+import Pointfree+++{- | Applies a simple transformation from a 'PFTerm' to a 'PWTerm', in an automated manner.+-}++pf2core :: PFTerm -> PWTerm+pf2core BANG          = Abstr "x" Unit+pf2core ID            = Abstr "x" (Var' "x")+pf2core APP           = Abstr "x" ((Fst $ Var'"x") :@:+                                 (Snd $ Var' "x"))+pf2core (Curry t1)    = Abstr "x" (Abstr "y" +                        ((pf2core t1):@:((Var' "y"):><:(Var' "x"))) )+pf2core (t1 :.: t2)   = Abstr "x" ((pf2core t1):@:((pf2core t2):@:(Var' "x")))+pf2core (t1 :\/: t2)  = Abstr "x" (Case (Var' "x") +                        ("y" , (pf2core t1):@:(Var' "y")) +                        ("z" , (pf2core t2):@:(Var' "z")))+pf2core (t1 :/\: t2)  = Abstr "x" ((pf2core t1):><:(pf2core t2))+pf2core FST           = Abstr "x" (Fst $ Var' "x")+pf2core SND           = Abstr "x" (Snd $ Var' "x")+pf2core INL           = Abstr "x" (Inl $ Var' "x")+pf2core INR           = Abstr "x" (Inr $ Var' "x")+pf2core (IN  str)     = Abstr "x" (In  str  $ Var' "x")+pf2core (OUT str)     = Abstr "x" (Out str $ Var' "x")+pf2core FIX           = Abstr "x" (Fix $ Var' "x")+pf2core (Macro x)     = Var' x+++-- | A context will be a left-nested pair, where the most to the+--   right value will be a never used constant+type Context = PWTerm+++-- | Calculates a "path" to a variable in a context by composing the+--   "fst" and "snd" functions+path :: Context -> PWTerm -> PFTerm+path (t:><:(Var' y)) (Var' x)+     | x == y    = SND+     | otherwise = (path t (Var' x)) :.: FST+path _ (Var' x) = Macro x++++-- | Given a Context, it calculates the translation from Core+--   to Point-free+core2pf :: Context -> PWTerm -> PFTerm+++{- | Applies the conversion of a pointwise expression of type @A@  and obtains+     a pointfree expression of type @1->A@, to which is applied a poinfree macro+     to get the correct type again.+-}+-- (unpnt f = app . (f . bang /\ id))+core2Pf :: PWTerm -> PFTerm+core2Pf t = APP :.: (((core2pf Unit t) :.: BANG) :/\: ID)+++-- paramorphisms for Int+core2pf cont ((((Fix (Abstr r1 (Abstr n1 (Abstr f1 (Abstr z1 +    (Case (Out typ (Var' n2))+         (_,Var' z2)+         (y1,(Var' f2 :@: Var' y2) :@: (((Var' r2 :@: Var' y3) :@: Var' f3)+          :@: Var' z3)))))))) :@: n) :@: f) :@: z)+  | r1==r2 && n1==n2 && f1==f2 && f2==f3 &&+    z1==z2 && z2==z3 && y1==y2 && y2==y3 &&+    isClosed f && isClosed z =+       (PARA typ (unpoint $ g(f,z))) :.: (core2pf cont n)+ where+    unpoint f = APP :.: ((f :.: BANG) :/\: ID) +    g (f,z) = let y = getFV f; x = getFV (z:><:Var' y)+            in core2pf Unit $+     Abstr x $+       Case (Var' x) ("_",z)+                      (y,f :@: (Snd$Var' y) :@: (Fst$Var' y))+----------------------------- pred ^ - recursive result ^++-- paramorphisms for [a]+core2pf cont ((((Fix (Abstr r1 (Abstr l1 (Abstr f1 (Abstr z1 +    (Case (Out typ (Var' l2))+         (_,Var' z2)+         (y1,Var' f2 :@: (Fst (Var' y2)) :@: (Snd (Var' y3)) :@:+            (Var' r2 :@: (Snd (Var' y4)) :@: Var' f3 :@: Var' z3))))))))+         :@: n) :@: f) :@: z)+  | r1==r2 && l1==l2 && f1==f2 && f2==f3 &&+    z1==z2 && z2==z3 && y1==y2 && y2==y3 && y3==y4 &&+    isClosed f && isClosed z =+       (PARA typ (unpoint $ g(f,z))) :.: (core2pf cont n)+ where+    unpoint f = APP :.: ((f :.: BANG) :/\: ID) +    g (f,z) = let y = getFV f; x = getFV (z:><:Var' y)+            in core2pf Unit $+     Abstr x $+       Case (Var' x) ("_",z)+              (y,f :@: (Fst$Var' y) :@: (Snd$Snd$Var' y) :@: (Fst$Snd$Var' y))+------------------------- head ^  --------- tail ^ --- recursive result ^+++core2pf _    Unit        = BANG+core2pf cont var@(Var' x) = path cont var+core2pf cont (t1:><:t2)  = (core2pf cont t1):/\:(core2pf cont t2)+core2pf cont (Fst t)     = FST :.: (core2pf cont t)+core2pf cont (Snd t)     = SND :.: (core2pf cont t)+core2pf cont (Abstr x t) = Curry (core2pf (cont:><:(Var' x)) t)+core2pf cont (t1:@:t2)   = APP :.: ((core2pf cont t1):/\:(core2pf cont t2))+core2pf cont (Inl t)     = INL :.: (core2pf cont t)+core2pf cont (Inr t)     = INR :.: (core2pf cont t)+core2pf cont (Case t (x,u) (y,v)) = +    APP :.: ((Curry (((core2pf (cont:><:(Var' x)) u) :\/: +            (core2pf (cont:><:(Var' y)) v)) :.: (Macro "distr")))+            :/\: (core2pf cont t))+core2pf cont (In  str t) = IN  str :.: (core2pf cont t)+core2pf cont (Out str t) = OUT str :.: (core2pf cont t)+core2pf cont (Fix t)    = FIX :.: (core2pf cont t)+++-- get the free variables+getFV :: PWTerm -> String+getFV = (\x->x++"_").maximum.getVars++getVars :: PWTerm -> [String]+getVars (Var' str)      = [str]+getVars Unit           = []+getVars (t1:><:t2)     = (getVars t1) ++ (getVars t2)+getVars (Abstr str t)  = str:(getVars t)+getVars (t1:@:t2)      = (getVars t1) ++ (getVars t2)+getVars (Case t1 (str1,t2) (str2,t3)) =+        str1:str2:(getVars t1++getVars t2++getVars t3)+getVars (Fst t)   = getVars t+getVars (Snd t)   = getVars t+getVars (Inl t)   = getVars t+getVars (Inr t)   = getVars t+getVars (In _ t)  = getVars t+getVars (Out _ t) = getVars t+getVars (Fix t)   = getVars t+++isClosed :: PWTerm -> Bool+isClosed t = closed t []+ where+  closed Unit _           = True+  closed (Var' str) ac     = str `elem` ac+  closed (t1:><:t2) ac    = (closed t1 ac) && (closed t2 ac)+  closed (Abstr str t) ac = closed t (str:ac)+  closed (t1:@:t2) ac     = (closed t1 ac) && (closed t2 ac)+  closed (Case t1 (str1,t2) (str2,t3)) ac =+     (closed t1 ac) && (closed t2 (str1:ac)) && (closed t3 (str2:ac))+  closed (Fst t) ac       = closed t ac+  closed (Snd t) ac       = closed t ac+  closed (Inl t) ac       = closed t ac+  closed (Inr t) ac       = closed t ac+  closed (In _ t) ac      = closed t ac+  closed (Out _ t) ac     = closed t ac+  closed (Fix t) ac       = closed t ac
+ refactorer/PwPf/docs/GlobalPW.html view
@@ -0,0 +1,1109 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    >GlobalPW</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "modulebar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><FONT SIZE = "6"+		>GlobalPW</FONT+		></TD+	      ><TD ALIGN = "right"+	      ><TABLE CLASS = "narrow" CELLSPACING = "0" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "infohead"+		    >Portability</TD+		    ><TD CLASS = "infoval"+		    >  portable</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "infohead"+		    >Stability</TD+		    ><TD CLASS = "infoval"+		    >  experimental</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "infohead"+		    >Maintainer</TD+		    ><TD CLASS = "infoval"+		    >  jproenca@di.uminho.pt</TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "section4"+	      ><B+		>Contents</B+		></TD+	      ></TR+	    ><TR+	    ><TD+	      ><DL+		><DT+		  ><A HREF = "#1"+		    >Data Type</A+		    ></DT+		  ><DT+		  ><A HREF = "#2"+		    >Conversion of an haskell expression to a GlobalPW term</A+		    ></DT+		  ><DT+		  ><A HREF = "#3"+		    >Conversion of a GlobalPW term to a <A HREF = "PWCore.html"+		      >PWCore</A+		      > term</A+		    ></DT+		  ></DL+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Description</TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	><P+	  >A global pointwise syntax and its relation with:+</P+	  ><UL+	  ><LI+	    > An expression in programatica's abstract syntax tree;+</LI+	    ><LI+	    > A pointwise core - <A HREF = "PWCore.html"+	      >PWCore</A+	      >.+</LI+	    ></UL+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Synopsis</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "body"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "decl"+	      ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "decl"+		    ><SPAN CLASS = "keyword"+		      >data</SPAN+		      > <A HREF = "#t%3AGLTerm"+		      >GLTerm</A+		      > </TD+		    ></TR+		  ><TR+		  ><TD CLASS = "body"+		    ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+		      ><TR+			><TD CLASS = "decl"+			  >= <A HREF = "#v%3AStar"+			    >Star</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AV"+			    >V</A+			    > String</TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3A%3A-%3A"+			    >(:-:)</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ALam"+			    >Lam</A+			    > String <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3A%3A%26%3A"+			    >(:&amp;:)</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3APi1"+			    >Pi1</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3APi2"+			    >Pi2</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AInl'"+			    >Inl'</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AInr'"+			    >Inr'</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ACase'"+			    >Case'</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > (String, <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    >) (String, <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    >)</TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AIn'"+			    >In'</A+			    > HsExpP <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AOut'"+			    >Out'</A+			    > HsExpP <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AFix'"+			    >Fix'</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AT'"+			    >T'</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AF'"+			    >F'</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AZ'"+			    >Z'</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ASuc"+			    >Suc</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3APred"+			    >Pred</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AIsZ"+			    >IsZ</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AIte"+			    >Ite</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AN'"+			    >N'</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3A%3A%3A%3A"+			    >(:::)</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AHd"+			    >Hd</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ATl"+			    >Tl</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AIsN"+			    >IsN</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ALetrec"+			    >Letrec</A+			    > String <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ARecNat"+			    >RecNat</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ARecList"+			    >RecList</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    > <A HREF = "GlobalPW.html#t%3AGLTerm"+			    >GLTerm</A+			    ></TD+			  ></TR+			></TABLE+		      ></TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "s8"+	      ></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "decl"+	      ><A HREF = "#v%3Aexp2Global"+		>exp2Global</A+		> :: Monad m =&gt; HsExpI PNT -&gt; m <A HREF = "GlobalPW.html#t%3AGLTerm"+		>GLTerm</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "s8"+	      ></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "decl"+	      ><A HREF = "#v%3Aglobal2core"+		>global2core</A+		> :: <A HREF = "GlobalPW.html#t%3AGLTerm"+		>GLTerm</A+		> -&gt; <A HREF = "PWCore.html#t%3APWTerm"+		>PWTerm</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	><A NAME = "1"+	  >Data Type</A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	><P+	  >Represents a pointwise language that:+</P+	  ><OL+	  ><LI+	    > is very similar to the way we are used to program in haskell;+</LI+	    ><LI+	    > not the most general one, since it only deals with booleans, natural numbers and lists.+</LI+	    ></OL+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "decl"+	><SPAN CLASS = "keyword"+	  >data</SPAN+	  > <A NAME = "t%3AGLTerm"+	  ></A+	  ><B+	  >GLTerm</B+	  > </TD+	></TR+      ><TR+      ><TD CLASS = "body"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "section4"+	      >Constructors</TD+	      ></TR+	    ><TR+	    ><TD CLASS = "body"+	      ><TABLE CLASS = "vanilla" CELLSPACING = "1" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AStar"+		      ></A+		      ><B+		      >Star</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Unit</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AV"+		      ></A+		      ><B+		      >V</B+		      > String</TD+		    ><TD CLASS = "rdoc"+		    >Variable</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3A%3A-%3A"+		      ></A+		      ><B+		      >(:-:)</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Aplication</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ALam"+		      ></A+		      ><B+		      >Lam</B+		      > String <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Abstraction</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3A%3A%26%3A"+		      ></A+		      ><B+		      >(:&amp;:)</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Pair</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3APi1"+		      ></A+		      ><B+		      >Pi1</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-wise first</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3APi2"+		      ></A+		      ><B+		      >Pi2</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-wise second</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AInl'"+		      ></A+		      ><B+		      >Inl'</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-wise left injection</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AInr'"+		      ></A+		      ><B+		      >Inr'</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-wise right injection</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ACase'"+		      ></A+		      ><B+		      >Case'</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > (String, <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      >) (String, <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      >)</TD+		    ><TD CLASS = "rdoc"+		    >Case of</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AIn'"+		      ></A+		      ><B+		      >In'</B+		      > HsExpP <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Injection on a specified type</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AOut'"+		      ></A+		      ><B+		      >Out'</B+		      > HsExpP <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Extraction of the functor of a specified type</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AFix'"+		      ></A+		      ><B+		      >Fix'</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Fixed-point</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AT'"+		      ></A+		      ><B+		      >T'</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Constant True</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AF'"+		      ></A+		      ><B+		      >F'</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Constant False</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AZ'"+		      ></A+		      ><B+		      >Z'</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Constant Zero</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ASuc"+		      ></A+		      ><B+		      >Suc</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Successor</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3APred"+		      ></A+		      ><B+		      >Pred</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Predecessor</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AIsZ"+		      ></A+		      ><B+		      >IsZ</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >is zero?</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AIte"+		      ></A+		      ><B+		      >Ite</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >if then else</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AN'"+		      ></A+		      ><B+		      >N'</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Empty list</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3A%3A%3A%3A"+		      ></A+		      ><B+		      >(:::)</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Constructor for lists</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AHd"+		      ></A+		      ><B+		      >Hd</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Head of a list</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ATl"+		      ></A+		      ><B+		      >Tl</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Tail of a list</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AIsN"+		      ></A+		      ><B+		      >IsN</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >is the list empty?</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ALetrec"+		      ></A+		      ><B+		      >Letrec</B+		      > String <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >recursive let</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ARecNat"+		      ></A+		      ><B+		      >RecNat</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Primitive recursion on Nat's</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ARecList"+		      ></A+		      ><B+		      >RecList</B+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      > <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Primitive recursion on List's</TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "section4"+	      >Instances</TD+	      ></TR+	    ><TR+	    ><TD CLASS = "body"+	      ><TABLE CLASS = "vanilla" CELLSPACING = "1" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "decl"+		    >Show <A HREF = "GlobalPW.html#t%3AGLTerm"+		      >GLTerm</A+		      ></TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	><A NAME = "2"+	  >Conversion of an haskell expression to a GlobalPW term</A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "decl"+	><A NAME = "v%3Aexp2Global"+	  ></A+	  ><B+	  >exp2Global</B+	  > :: Monad m =&gt; HsExpI PNT -&gt; m <A HREF = "GlobalPW.html#t%3AGLTerm"+	  >GLTerm</A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	><P+	  >Applies a simple transformation from an expression of programatica's+abstract syntax tree to <TT+	    ><A HREF = "GlobalPW.html#t%3AGLTerm"+	      >GLTerm</A+	      ></TT+	    >.+</P+	  ><P+	  >The recognized grammar is:+</P+	  ><DL+	  ><DT+	    >G, G1, G2, G3 <TT+	      >::=</TT+	      ></DT+	    ><DD+	    >+(G) | <TT+	      >undefined</TT+	      > | <TT+	      >()</TT+	      > | <TT+	      >_L</TT+	      > | <TT+	      >inN (_L::</TT+	      ><EM+	      >type</EM+	      ><TT+	      >) </TT+	      >G |<TT+	      > ouT (_L::</TT+	      ><EM+	      >type</EM+	      ><TT+	      >)</TT+	      > +|<TT+	      > True </TT+	      >|<TT+	      > False </TT+	      >|<TT+	      > 0 </TT+	      >|<TT+	      > [] </TT+	      >|<TT+	      > <EM+		>n, n&gt;0</EM+		> </TT+	      >|<TT+	      > [</TT+	      >G1<TT+	      >, </TT+	      >G2<TT+	      >, ... ] </TT+	      >| G1<TT+	      > : </TT+	      >G2 |<TT+	      > succ </TT+	      >G |<TT+	      > pred </TT+	      >G+|<TT+	      > (==0) </TT+	      >G |<TT+	      > </TT+	      >G<TT+	      > == 0 </TT+	      >|<TT+	      > head </TT+	      >G<TT+	      > </TT+	      >|<TT+	      > tail </TT+	      >G<TT+	      > </TT+	      >|<TT+	      > null </TT+	      >+|<TT+	      > recNat </TT+	      >G1<TT+	      > </TT+	      >G2<TT+	      > </TT+	      >G3<TT+	      > </TT+	      >|<TT+	      > recList </TT+	      >G1<TT+	      > </TT+	      >G2<TT+	      > </TT+	      >G3+|<TT+	      > fix </TT+	      >G<TT+	      > </TT+	      >|<TT+	      > if </TT+	      >G1<TT+	      > then </TT+	      >G2<TT+	      > else </TT+	      >G3<TT+	      > </TT+	      >|<TT+	      > <EM+		>var</EM+		> </TT+	      >|<TT+	      > (</TT+	      >G1<TT+	      >,</TT+	      >G2<TT+	      >) </TT+	      >|<TT+	      > fst </TT+	      >|<TT+	      > snd </TT+	      >|<TT+	      > Left </TT+	      >|<TT+	      > Right </TT+	      >+|<TT+	      > </TT+	      >G1<TT+	      > <EM+		>infixOp</EM+		> </TT+	      >G2<TT+	      > </TT+	      >|<TT+	      > \<EM+		>var1 var2 ...</EM+		> -&gt; </TT+	      >G+|<TT+	      > case </TT+	      >G1<TT+	      > of Left <EM+		>var1</EM+		> -&gt; </TT+	      >G2<TT+	      >; Right <EM+		>var2</EM+		> -&gt;</TT+	      >G3 +|<TT+	      > let <EM+		>var</EM+		> = </TT+	      >G1<TT+	      > in </TT+	      >G2<TT+	      > +</TT+	      > +</DD+	    ></DL+	  ><P+	  >where types are read as the pretty print string, and <EM+	    >var</EM+	    >, <EM+	    >var1</EM+	    > and <EM+	    >var2</EM+	    > are variables that are read as strings also.+</P+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	><A NAME = "3"+	  >Conversion of a GlobalPW term to a <A HREF = "PWCore.html"+	    >PWCore</A+	    > term</A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "decl"+	><A NAME = "v%3Aglobal2core"+	  ></A+	  ><B+	  >global2core</B+	  > :: <A HREF = "GlobalPW.html#t%3AGLTerm"+	  >GLTerm</A+	  > -&gt; <A HREF = "PWCore.html#t%3APWTerm"+	  >PWTerm</A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	>Converts a <TT+	  ><A HREF = "GlobalPW.html#t%3AGLTerm"+	    >GLTerm</A+	    ></TT+	  > to a <TT+	  ><A HREF = "PWCore.html#t%3APWTerm"+	    >PWTerm</A+	    ></TT+	  >, which is a more general representation for+pointwise terms, but with less pratical constructors (in <A HREF = "PWCore.html"+	  >PWCore</A+	  >).+</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "botbar"+	>Produced by <A HREF = "http://www.haskell.org/haddock/"+	  >Haddock</A+	  > version 0.6</TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/PWCore.html view
@@ -0,0 +1,490 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    >PWCore</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "modulebar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><FONT SIZE = "6"+		>PWCore</FONT+		></TD+	      ><TD ALIGN = "right"+	      ><TABLE CLASS = "narrow" CELLSPACING = "0" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "infohead"+		    >Portability</TD+		    ><TD CLASS = "infoval"+		    >  portable</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "infohead"+		    >Stability</TD+		    ><TD CLASS = "infoval"+		    >  experimental</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "infohead"+		    >Maintainer</TD+		    ><TD CLASS = "infoval"+		    >  jproenca@di.uminho.pt</TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Description</TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	>A syntax of a general pointwise language.+</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Synopsis</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "body"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "decl"+	      ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "decl"+		    ><SPAN CLASS = "keyword"+		      >data</SPAN+		      > <A HREF = "#t%3APWTerm"+		      >PWTerm</A+		      > </TD+		    ></TR+		  ><TR+		  ><TD CLASS = "body"+		    ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+		      ><TR+			><TD CLASS = "decl"+			  >= <A HREF = "#v%3AUnit"+			    >Unit</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AVar'"+			    >Var'</A+			    > String</TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3A%3A%40%3A"+			    >(:@:)</A+			    > <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    > <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AAbstr"+			    >Abstr</A+			    > String <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3A%3A%3E%3C%3A"+			    >(:&gt;&lt;:)</A+			    > <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    > <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AFst"+			    >Fst</A+			    > <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ASnd"+			    >Snd</A+			    > <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AInl"+			    >Inl</A+			    > <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AInr"+			    >Inr</A+			    > <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ACase"+			    >Case</A+			    > <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    > (String, <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    >) (String, <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    >)</TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AIn"+			    >In</A+			    > HsExpP <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AOut"+			    >Out</A+			    > HsExpP <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AFix"+			    >Fix</A+			    > <A HREF = "PWCore.html#t%3APWTerm"+			    >PWTerm</A+			    ></TD+			  ></TR+			></TABLE+		      ></TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Documentation</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	><P+	  >A simple definition of a pointwise language where:+</P+	  ><UL+	  ><LI+	    > products and sums are allowed;+</LI+	    ><LI+	    > constants are dealed by the use of <EM+	      >in</EM+	      > and <EM+	      >out</EM+	      > functions that+allows to go from any type that has an associated base functor to and+from a representation of that base functor using sums and products;+</LI+	    ><LI+	    > recursion is only possible by the use of the fixed point constructor.+</LI+	    ></UL+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "decl"+	><SPAN CLASS = "keyword"+	  >data</SPAN+	  > <A NAME = "t%3APWTerm"+	  ></A+	  ><B+	  >PWTerm</B+	  > </TD+	></TR+      ><TR+      ><TD CLASS = "body"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "section4"+	      >Constructors</TD+	      ></TR+	    ><TR+	    ><TD CLASS = "body"+	      ><TABLE CLASS = "vanilla" CELLSPACING = "1" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AUnit"+		      ></A+		      ><B+		      >Unit</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Unit</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AVar'"+		      ></A+		      ><B+		      >Var'</B+		      > String</TD+		    ><TD CLASS = "rdoc"+		    >Variable</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3A%3A%40%3A"+		      ></A+		      ><B+		      >(:@:)</B+		      > <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      > <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Aplication</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AAbstr"+		      ></A+		      ><B+		      >Abstr</B+		      > String <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Abstraction</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3A%3A%3E%3C%3A"+		      ></A+		      ><B+		      >(:&gt;&lt;:)</B+		      > <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      > <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Pair</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AFst"+		      ></A+		      ><B+		      >Fst</B+		      > <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-wise first</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ASnd"+		      ></A+		      ><B+		      >Snd</B+		      > <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-wise second</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AInl"+		      ></A+		      ><B+		      >Inl</B+		      > <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-wise left injection</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AInr"+		      ></A+		      ><B+		      >Inr</B+		      > <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-wise right injection</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ACase"+		      ></A+		      ><B+		      >Case</B+		      > <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      > (String, <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      >) (String, <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      >)</TD+		    ><TD CLASS = "rdoc"+		    >Case of</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AIn"+		      ></A+		      ><B+		      >In</B+		      > HsExpP <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Injection on a specified type</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AOut"+		      ></A+		      ><B+		      >Out</B+		      > HsExpP <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Extraction of the functor of a specified type</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AFix"+		      ></A+		      ><B+		      >Fix</B+		      > <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Fixed point</TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "section4"+	      >Instances</TD+	      ></TR+	    ><TR+	    ><TD CLASS = "body"+	      ><TABLE CLASS = "vanilla" CELLSPACING = "1" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "decl"+		    >Show <A HREF = "PWCore.html#t%3APWTerm"+		      >PWTerm</A+		      ></TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "botbar"+	>Produced by <A HREF = "http://www.haskell.org/haddock/"+	  >Haddock</A+	  > version 0.6</TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/Pointfree.html view
@@ -0,0 +1,600 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    >Pointfree</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "modulebar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><FONT SIZE = "6"+		>Pointfree</FONT+		></TD+	      ><TD ALIGN = "right"+	      ><TABLE CLASS = "narrow" CELLSPACING = "0" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "infohead"+		    >Portability</TD+		    ><TD CLASS = "infoval"+		    >  portable</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "infohead"+		    >Stability</TD+		    ><TD CLASS = "infoval"+		    >  experimental</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "infohead"+		    >Maintainer</TD+		    ><TD CLASS = "infoval"+		    >  jproenca@di.uminho.pt</TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "section4"+	      ><B+		>Contents</B+		></TD+	      ></TR+	    ><TR+	    ><TD+	      ><DL+		><DT+		  ><A HREF = "#1"+		    >Data Type</A+		    ></DT+		  ><DT+		  ><A HREF = "#2"+		    >Conversion of a <A HREF = "PFTerm.html"+		      >PFTerm</A+		      > to an haskell expression</A+		    ></DT+		  ></DL+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Description</TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	>A syntax of a general pointfree language.+</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Synopsis</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "body"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "decl"+	      ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "decl"+		    ><SPAN CLASS = "keyword"+		      >data</SPAN+		      > <A HREF = "#t%3APFTerm"+		      >PFTerm</A+		      > </TD+		    ></TR+		  ><TR+		  ><TD CLASS = "body"+		    ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+		      ><TR+			><TD CLASS = "decl"+			  >= <A HREF = "#v%3ABANG"+			    >BANG</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AID"+			    >ID</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AAPP"+			    >APP</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ACurry"+			    >Curry</A+			    > <A HREF = "Pointfree.html#t%3APFTerm"+			    >PFTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3A%3A.%3A"+			    >(:.:)</A+			    > <A HREF = "Pointfree.html#t%3APFTerm"+			    >PFTerm</A+			    > <A HREF = "Pointfree.html#t%3APFTerm"+			    >PFTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3A%3A%5C%2F%3A"+			    >(:\/:)</A+			    > <A HREF = "Pointfree.html#t%3APFTerm"+			    >PFTerm</A+			    > <A HREF = "Pointfree.html#t%3APFTerm"+			    >PFTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3A%3A%2F%5C%3A"+			    >(:/\:)</A+			    > <A HREF = "Pointfree.html#t%3APFTerm"+			    >PFTerm</A+			    > <A HREF = "Pointfree.html#t%3APFTerm"+			    >PFTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AFST"+			    >FST</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3ASND"+			    >SND</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AINL"+			    >INL</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AINR"+			    >INR</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AIN"+			    >IN</A+			    > HsExpP</TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AOUT"+			    >OUT</A+			    > HsExpP</TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3APARA"+			    >PARA</A+			    > HsExpP <A HREF = "Pointfree.html#t%3APFTerm"+			    >PFTerm</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AFIX"+			    >FIX</A+			    ></TD+			  ></TR+			><TR+			><TD CLASS = "decl"+			  >| <A HREF = "#v%3AMacro"+			    >Macro</A+			    > String</TD+			  ></TR+			></TABLE+		      ></TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "s8"+	      ></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "decl"+	      ><A HREF = "#v%3Apf2Exp"+		>pf2Exp</A+		> :: <A HREF = "Pointfree.html#t%3APFTerm"+		>PFTerm</A+		> -&gt; HsExpI PNT</TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	><A NAME = "1"+	  >Data Type</A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	><P+	  >Represents a pointfree language where:+</P+	  ><OL+	  ><LI+	    > products and sums are treated+</LI+	    ><LI+	    > base types are obtained and decomposed by the use of the <EM+	      >IN</EM+	      > and+<EM+	      >OUT</EM+	      > constructors+</LI+	    ><LI+	    > recursion can be expressed by the point-fix function or by a paramorphism+</LI+	    ><LI+	    > free variables are called macros and represent known pointfree expressions+</LI+	    ></OL+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "decl"+	><SPAN CLASS = "keyword"+	  >data</SPAN+	  > <A NAME = "t%3APFTerm"+	  ></A+	  ><B+	  >PFTerm</B+	  > </TD+	></TR+      ><TR+      ><TD CLASS = "body"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "section4"+	      >Constructors</TD+	      ></TR+	    ><TR+	    ><TD CLASS = "body"+	      ><TABLE CLASS = "vanilla" CELLSPACING = "1" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ABANG"+		      ></A+		      ><B+		      >BANG</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Constant function that returns Unit</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AID"+		      ></A+		      ><B+		      >ID</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Identity</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AAPP"+		      ></A+		      ><B+		      >APP</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Apply</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ACurry"+		      ></A+		      ><B+		      >Curry</B+		      > <A HREF = "Pointfree.html#t%3APFTerm"+		      >PFTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Curry</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3A%3A.%3A"+		      ></A+		      ><B+		      >(:.:)</B+		      > <A HREF = "Pointfree.html#t%3APFTerm"+		      >PFTerm</A+		      > <A HREF = "Pointfree.html#t%3APFTerm"+		      >PFTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Composition</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3A%3A%5C%2F%3A"+		      ></A+		      ><B+		      >(:\/:)</B+		      > <A HREF = "Pointfree.html#t%3APFTerm"+		      >PFTerm</A+		      > <A HREF = "Pointfree.html#t%3APFTerm"+		      >PFTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Either</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3A%3A%2F%5C%3A"+		      ></A+		      ><B+		      >(:/\:)</B+		      > <A HREF = "Pointfree.html#t%3APFTerm"+		      >PFTerm</A+		      > <A HREF = "Pointfree.html#t%3APFTerm"+		      >PFTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Split</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AFST"+		      ></A+		      ><B+		      >FST</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-free first</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3ASND"+		      ></A+		      ><B+		      >SND</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-free second</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AINL"+		      ></A+		      ><B+		      >INL</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-free left injection</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AINR"+		      ></A+		      ><B+		      >INR</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Point-free right injection</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AIN"+		      ></A+		      ><B+		      >IN</B+		      > HsExpP</TD+		    ><TD CLASS = "rdoc"+		    >Injection on a specified type</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AOUT"+		      ></A+		      ><B+		      >OUT</B+		      > HsExpP</TD+		    ><TD CLASS = "rdoc"+		    >Gets the functor</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3APARA"+		      ></A+		      ><B+		      >PARA</B+		      > HsExpP <A HREF = "Pointfree.html#t%3APFTerm"+		      >PFTerm</A+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Paramorphism</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AFIX"+		      ></A+		      ><B+		      >FIX</B+		      ></TD+		    ><TD CLASS = "rdoc"+		    >Fixed point function</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "decl"+		    ><A NAME = "v%3AMacro"+		      ></A+		      ><B+		      >Macro</B+		      > String</TD+		    ><TD CLASS = "rdoc"+		    >Macros of frequently used pointfree terms</TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "section4"+	      >Instances</TD+	      ></TR+	    ><TR+	    ><TD CLASS = "body"+	      ><TABLE CLASS = "vanilla" CELLSPACING = "1" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "decl"+		    >Show <A HREF = "Pointfree.html#t%3APFTerm"+		      >PFTerm</A+		      ></TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	><A NAME = "2"+	  >Conversion of a <A HREF = "PFTerm.html"+	    >PFTerm</A+	    > to an haskell expression</A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "decl"+	><A NAME = "v%3Apf2Exp"+	  ></A+	  ><B+	  >pf2Exp</B+	  > :: <A HREF = "Pointfree.html#t%3APFTerm"+	  >PFTerm</A+	  > -&gt; HsExpI PNT</TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	>Applies a tranformation from a <TT+	  ><A HREF = "Pointfree.html#t%3APFTerm"+	    >PFTerm</A+	    ></TT+	  > to an expression of programatica's+abstract tree. Note that the type information inside the <EM+	  >IN</EM+	  >, <EM+	  >OUT</EM+	  > and <EM+	  >PARA</EM+	  >+terms is represented as a programatica's expression <TT+	  >L::type</TT+	  >, where the <TT+	  >type</TT+	  >+is the real type information.+</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "botbar"+	>Produced by <A HREF = "http://www.haskell.org/haddock/"+	  >Haddock</A+	  > version 0.6</TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/PwPfConversion.html view
@@ -0,0 +1,265 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    >PwPfConversion</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "modulebar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><FONT SIZE = "6"+		>PwPfConversion</FONT+		></TD+	      ><TD ALIGN = "right"+	      ><TABLE CLASS = "narrow" CELLSPACING = "0" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "infohead"+		    >Portability</TD+		    ><TD CLASS = "infoval"+		    >  portable</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "infohead"+		    >Stability</TD+		    ><TD CLASS = "infoval"+		    >  experimental</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "infohead"+		    >Maintainer</TD+		    ><TD CLASS = "infoval"+		    >  jproenca@di.uminho.pt</TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "section4"+	      ><B+		>Contents</B+		></TD+	      ></TR+	    ><TR+	    ><TD+	      ><DL+		><DT+		  ><A HREF = "#1"+		    >Translation from <A HREF = "Pointfree.html"+		      >Pointfree</A+		      > to <A HREF = "PWCore.html"+		      >PWCore</A+		      ></A+		    ></DT+		  ><DT+		  ><A HREF = "#2"+		    >Translation from <A HREF = "PWCore.html"+		      >PWCore</A+		      > to <A HREF = "Pointfree.html"+		      >Pointfree</A+		      ></A+		    ></DT+		  ></DL+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Description</TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	>Translations between pointwise and point-free expressions, expressed in+the modules <A HREF = "PWCore.html"+	  >PWCore</A+	  > and <A HREF = "PointFree.html"+	  >PointFree</A+	  >.+</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Synopsis</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "body"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "decl"+	      ><A HREF = "#v%3Apf2core"+		>pf2core</A+		> :: <A HREF = "Pointfree.html#t%3APFTerm"+		>PFTerm</A+		> -&gt; <A HREF = "PWCore.html#t%3APWTerm"+		>PWTerm</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "s8"+	      ></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "decl"+	      ><A HREF = "#v%3Acore2Pf"+		>core2Pf</A+		> :: <A HREF = "PWCore.html#t%3APWTerm"+		>PWTerm</A+		> -&gt; <A HREF = "Pointfree.html#t%3APFTerm"+		>PFTerm</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	><A NAME = "1"+	  >Translation from <A HREF = "Pointfree.html"+	    >Pointfree</A+	    > to <A HREF = "PWCore.html"+	    >PWCore</A+	    ></A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "decl"+	><A NAME = "v%3Apf2core"+	  ></A+	  ><B+	  >pf2core</B+	  > :: <A HREF = "Pointfree.html#t%3APFTerm"+	  >PFTerm</A+	  > -&gt; <A HREF = "PWCore.html#t%3APWTerm"+	  >PWTerm</A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	>Applies a simple transformation from a <TT+	  ><A HREF = "Pointfree.html#t%3APFTerm"+	    >PFTerm</A+	    ></TT+	  > to a <TT+	  ><A HREF = "PWCore.html#t%3APWTerm"+	    >PWTerm</A+	    ></TT+	  >, in an automated manner.+</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	><A NAME = "2"+	  >Translation from <A HREF = "PWCore.html"+	    >PWCore</A+	    > to <A HREF = "Pointfree.html"+	    >Pointfree</A+	    ></A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "decl"+	><A NAME = "v%3Acore2Pf"+	  ></A+	  ><B+	  >core2Pf</B+	  > :: <A HREF = "PWCore.html#t%3APWTerm"+	  >PWTerm</A+	  > -&gt; <A HREF = "Pointfree.html#t%3APFTerm"+	  >PFTerm</A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	>Applies the conversion of a pointwise expression of type <TT+	  >A</TT+	  >  and obtains+a pointfree expression of type <TT+	  >1-&gt;A</TT+	  >, to which is applied a poinfree macro+to get the correct type again.+</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "botbar"+	>Produced by <A HREF = "http://www.haskell.org/haddock/"+	  >Haddock</A+	  > version 0.6</TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/RefacPwPf.html view
@@ -0,0 +1,297 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    >RefacPwPf</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "modulebar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><FONT SIZE = "6"+		>RefacPwPf</FONT+		></TD+	      ><TD ALIGN = "right"+	      ><TABLE CLASS = "narrow" CELLSPACING = "0" CELLPADDING = "0"+		><TR+		  ><TD CLASS = "infohead"+		    >Portability</TD+		    ><TD CLASS = "infoval"+		    >  portable</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "infohead"+		    >Stability</TD+		    ><TD CLASS = "infoval"+		    >  experimental</TD+		    ></TR+		  ><TR+		  ><TD CLASS = "infohead"+		    >Maintainer</TD+		    ><TD CLASS = "infoval"+		    >  jproenca@di.uminho.pt</TD+		    ></TR+		  ></TABLE+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "section4"+	      ><B+		>Contents</B+		></TD+	      ></TR+	    ><TR+	    ><TD+	      ><DL+		><DT+		  ><A HREF = "#1"+		    >Refactoring  </A+		    ></DT+		  ><DT+		  ><A HREF = "#2"+		    >Limitations</A+		    ></DT+		  ></DL+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Description</TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	><P+	  >Refactoring tool that converts a pointwise to a pointfree expression.+</P+	  ><P+	  >It uses the modules <A HREF = "GlobalPW.html"+	    >GlobalPW</A+	    >, <A HREF = "PWCore.html"+	    >PWCore</A+	    >, <A HREF = "PwPfConversion.html"+	    >PwPfConversion</A+	    > and <A HREF = "Pointfree.html"+	    >Pointfree</A+	    >+</P+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Synopsis</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "body"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD CLASS = "decl"+	      ><A HREF = "#v%3ApwToPf"+		>pwToPf</A+		> :: [String] -&gt; State' IO ()</TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	><A NAME = "1"+	  >Refactoring  </A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	><P+	  >Converts an expression in pointwise to pointfree by the following steps:+</P+	  ><OL+	  ><LI+	    > Reads the expression to be evaluated obtained by programatica's tools;+</LI+	    ><LI+	    > Tries to convert the expression to a GLTerm by the use of the+monadic function <TT+	      ><A HREF = "GlobalPW.html#v%3Aexp2Global"+		>exp2Global</A+		></TT+	      >, in <A HREF = "GlobalPW.html"+	      >GlobalPW</A+	      > module;+</LI+	    ><LI+	    > Converts the GLTerm to a PWTerm, which is more general pointwise+representation that can be found in module <A HREF = "PWCore.html"+	      >PWCore</A+	      >, by the use of+the function <TT+	      ><A HREF = "GlobalPW.html#v%3Aglobal2core"+		>global2core</A+		></TT+	      >;+</LI+	    ><LI+	    > Converts the PWTerm to a PFTerm, which is a pointfree expression,+by the use of the function <TT+	      ><A HREF = "PwPfConversion.html#v%3Acore2Pf"+		>core2Pf</A+		></TT+	      >;+</LI+	    ><LI+	    > Writes the resulting pointfree expression into an expression of+programatica's abstract syntax tree, by the use of the function <TT+	      ><A HREF = "Pointfree.html#v%3Apf2Exp"+		>pf2Exp</A+		></TT+	      >.+</LI+	    ></OL+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "decl"+	><A NAME = "v%3ApwToPf"+	  ></A+	  ><B+	  >pwToPf</B+	  > :: [String] -&gt; State' IO ()</TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	><A NAME = "2"+	  >Limitations</A+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "doc"+	><P+	  >This refactoring is not complete, since only the grammar specified for+the function <TT+	    ><A HREF = "GlobalPW.html#v%3Aexp2Global"+	      >exp2Global</A+	      ></TT+	    > can be recognized,+and later translated into a pointfree expression.+</P+	  ><P+	  >There are also some limitations. Some of them are presented bellow.+</P+	  ><UL+	  ><LI+	    > Types inside <EM+	      >IN</EM+	      >, <EM+	      >OUT</EM+	      > and <EM+	      >PARA</EM+	      > have the type information correct, but+the variable &quot;_L&quot; sometimes don't have the correct location information,+and lists are represented by <TT+	      >[a]</TT+	      >, where the letter <TT+	      >a</TT+	      > may already be bounded; +</LI+	    ><LI+	    > The source location information is ignored in most cases, since the+expression is completely changed;+</LI+	    ><LI+	    > Scope information is lost, except for prelude functions;+</LI+	    ><LI+	    > Aditional information to the expression, like type information, cannot+be added inside the selected expression, since only the specified grammar+is recognized.+</LI+	    ></UL+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "botbar"+	>Produced by <A HREF = "http://www.haskell.org/haddock/"+	  >Haddock</A+	  > version 0.6</TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-58.html view
@@ -0,0 +1,193 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (:)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >:&amp;:</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3A%3A%26%3A"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >:-:</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3A%3A-%3A"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >:.:</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3A%3A.%3A"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >:/\:</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3A%3A%2F%5C%3A"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >:::</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3A%3A%3A%3A"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >:&gt;&lt;:</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3A%3A%3E%3C%3A"+		>PWCore</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >:@:</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3A%3A%40%3A"+		>PWCore</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >:\/:</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3A%3A%5C%2F%3A"+		>Pointfree</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-A.html view
@@ -0,0 +1,145 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (A)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >APP</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3AAPP"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Abstr</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3AAbstr"+		>PWCore</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-B.html view
@@ -0,0 +1,137 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (B)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >BANG</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3ABANG"+		>Pointfree</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-C.html view
@@ -0,0 +1,161 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (C)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >Case</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3ACase"+		>PWCore</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Case'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3ACase'"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Curry</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3ACurry"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >core2Pf</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PwPfConversion.html#v%3Acore2Pf"+		>PwPfConversion</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-E.html view
@@ -0,0 +1,137 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (E)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >exp2Global</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3Aexp2Global"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-F.html view
@@ -0,0 +1,177 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (F)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >F'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AF'"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >FIX</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3AFIX"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >FST</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3AFST"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Fix</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3AFix"+		>PWCore</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Fix'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AFix'"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Fst</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3AFst"+		>PWCore</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-G.html view
@@ -0,0 +1,145 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (G)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >GLTerm</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#t%3AGLTerm"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >global2core</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3Aglobal2core"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-H.html view
@@ -0,0 +1,137 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (H)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >Hd</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AHd"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-I.html view
@@ -0,0 +1,233 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (I)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >ID</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3AID"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >IN</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3AIN"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >INL</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3AINL"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >INR</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3AINR"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >In</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3AIn"+		>PWCore</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >In'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AIn'"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Inl</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3AInl"+		>PWCore</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Inl'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AInl'"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Inr</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3AInr"+		>PWCore</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Inr'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AInr'"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >IsN</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AIsN"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >IsZ</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AIsZ"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Ite</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AIte"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-L.html view
@@ -0,0 +1,145 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (L)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >Lam</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3ALam"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Letrec</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3ALetrec"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-M.html view
@@ -0,0 +1,137 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (M)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >Macro</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3AMacro"+		>Pointfree</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-N.html view
@@ -0,0 +1,137 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (N)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >N'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AN'"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-O.html view
@@ -0,0 +1,153 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (O)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >OUT</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3AOUT"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Out</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3AOut"+		>PWCore</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Out'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AOut'"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-P.html view
@@ -0,0 +1,201 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (P)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >PARA</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3APARA"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >PFTerm</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#t%3APFTerm"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >PWTerm</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#t%3APWTerm"+		>PWCore</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Pi1</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3APi1"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Pi2</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3APi2"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Pred</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3APred"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >pf2Exp</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3Apf2Exp"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >pf2core</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PwPfConversion.html#v%3Apf2core"+		>PwPfConversion</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >pwToPf</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "RefacPwPf.html#v%3ApwToPf"+		>RefacPwPf</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-R.html view
@@ -0,0 +1,145 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (R)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >RecList</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3ARecList"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >RecNat</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3ARecNat"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-S.html view
@@ -0,0 +1,161 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (S)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >SND</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "Pointfree.html#v%3ASND"+		>Pointfree</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Snd</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3ASnd"+		>PWCore</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Star</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AStar"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Suc</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3ASuc"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-T.html view
@@ -0,0 +1,145 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (T)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >T'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AT'"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Tl</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3ATl"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-U.html view
@@ -0,0 +1,137 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (U)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >Unit</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3AUnit"+		>PWCore</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-V.html view
@@ -0,0 +1,145 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (V)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >V</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AV"+		>GlobalPW</A+		></TD+	      ></TR+	    ><TR+	    ><TD CLASS = "indexentry"+	      >Var'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "PWCore.html#v%3AVar'"+		>PWCore</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index-Z.html view
@@ -0,0 +1,137 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index (Z)</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD CLASS = "indexentry"+	      >Z'</TD+	      ><TD CLASS = "indexlinks"+	      ><A HREF = "GlobalPW.html#v%3AZ'"+		>GlobalPW</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/doc-index.html view
@@ -0,0 +1,123 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    > (Index)</TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Index</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "5"+	  ><TR+	    ><TD+	      ><A HREF = "doc-index-A.html"+		>A</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-B.html"+		>B</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-C.html"+		>C</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-F.html"+		>F</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-G.html"+		>G</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-H.html"+		>H</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-I.html"+		>I</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-L.html"+		>L</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-M.html"+		>M</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-N.html"+		>N</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-O.html"+		>O</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-P.html"+		>P</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-R.html"+		>R</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-S.html"+		>S</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-T.html"+		>T</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-U.html"+		>U</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-V.html"+		>V</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-Z.html"+		>Z</A+		></TD+	      ><TD+	      ><A HREF = "doc-index-58.html"+		>:</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/PwPf/docs/haddock.css view
@@ -0,0 +1,200 @@+/* -------- Global things --------- */++BODY { +  background-color: #ffffff;+  color: #000000;+  font-family: sans-serif;+  } ++A:link    { color: #0000e0; text-decoration: none }+A:visited { color: #0000a0; text-decoration: none }+A:hover   { background-color: #e0e0ff; text-decoration: none }++TABLE.vanilla {+  width: 100%;+  border-width: 0px;+  /* I can't seem to specify cellspacing or cellpadding properly using CSS... */+}++/* <TT> font is a little too small in MSIE */+TT  { font-size: 100%; }+PRE { font-size: 100%; }++LI P { margin: 0pt } ++TD {+  border-width: 0px;+}++TABLE.narrow {+  border-width: 0px;+}++TD.s8  {  height: 8px;  }+TD.s15 {  height: 15px; }++SPAN.keyword { text-decoration: underline; }++/* --------- Documentation elements ---------- */++TD.children {+  padding-left: 25px;+  }++TD.synopsis {+  padding: 2px;+  background-color: #f0f0f0;+  font-family: monospace+ }++TD.decl { +  padding: 2px;+  background-color: #f0f0f0; +  font-family: monospace;+  white-space: nowrap;+  vertical-align: top;+  }++TD.recfield { padding-left: 20px }++TD.doc  { +  padding-top: 2px;+  padding-left: 10px;+  }++TD.ndoc  { +  padding: 2px;+  }++TD.rdoc  { +  padding: 2px;+  padding-left: 10px;+  width: 100%;+  }++TD.body  { +  padding-left: 10px+  }++TD.pkg {+  width: 100%;+  padding-left: 10px+}++TD.indexentry {+  vertical-align: top;+  padding-right: 10px+  }++TD.indexannot {+  vertical-align: top;+  padding-left: 20px;+  white-space: nowrap+  }++TD.indexlinks {+  width: 100%+  }++/* ------- Section Headings ------- */++TD.section1 {+  padding-top: 15px;+  font-weight: bold;+  font-size: 150%+  }++TD.section2 {+  padding-top: 10px;+  font-weight: bold;+  font-size: 130%+  }++TD.section3 {+  padding-top: 5px;+  font-weight: bold;+  font-size: 110%+  }++TD.section4 {+  font-weight: bold;+  font-size: 100%+  }++/* -------------- The title bar at the top of the page */++TD.infohead {+  color: #ffffff;+  font-weight: bold;+  padding-right: 10px;+  text-align: left;+}++TD.infoval {+  color: #ffffff;+  padding-right: 10px;+  text-align: left;+}++TD.topbar {+  background-color: #000099;+  padding: 5px;+}++TD.title {+  color: #ffffff;+  padding-left: 10px;+  width: 100%+  }++TD.topbut {+  padding-left: 5px;+  padding-right: 5px;+  border-left-width: 1px;+  border-left-color: #ffffff;+  border-left-style: solid;+  white-space: nowrap;+  }++TD.topbut A:link {+  color: #ffffff+  }++TD.topbut A:visited {+  color: #ffff00+  }++TD.topbut A:hover {+  background-color: #6060ff;+  }++TD.topbut:hover {+  background-color: #6060ff+  }++TD.modulebar { +  background-color: #0077dd;+  padding: 5px;+  border-top-width: 1px;+  border-top-color: #ffffff;+  border-top-style: solid;+  }++/* --------- The page footer --------- */++TD.botbar {+  background-color: #000099;+  color: #ffffff;+  padding: 5px+  }+TD.botbar A:link {+  color: #ffffff;+  text-decoration: underline+  }+TD.botbar A:visited {+  color: #ffff00+  }+TD.botbar A:hover {+  background-color: #6060ff+  }+
+ refactorer/PwPf/docs/haskell_icon.gif view
binary file changed (absent → 911 bytes)
+ refactorer/PwPf/docs/index.html view
@@ -0,0 +1,95 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!--Rendered using the Haskell Html Library v0.2-->+<HTML+><HEAD+  ><TITLE+    ></TITLE+    ><LINK HREF = "haddock.css" REL = "stylesheet" TYPE = "text/css"+    ></HEAD+  ><BODY+  ><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+    ><TR+      ><TD CLASS = "topbar"+	><TABLE CLASS = "vanilla" CELLSPACING = "0" CELLPADDING = "0"+	  ><TR+	    ><TD+	      ><IMG SRC = "haskell_icon.gif" WIDTH = "16" HEIGHT = "16" ALT = " "+		></TD+	      ><TD CLASS = "title"+	      ></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "index.html"+		>Contents</A+		></TD+	      ><TD CLASS = "topbut"+	      ><A HREF = "doc-index.html"+		>Index</A+		></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "section1"+	>Modules</TD+	></TR+      ><TR+      ><TD+	><TABLE CELLPADDING = "0" CELLSPACING = "2"+	  ><TR+	    ><TD+	      ><A HREF = "GlobalPW.html"+		>GlobalPW</A+		></TD+	      ><TD CLASS = "pkg"+	      ></TD+	      ></TR+	    ><TR+	    ><TD+	      ><A HREF = "PWCore.html"+		>PWCore</A+		></TD+	      ><TD CLASS = "pkg"+	      ></TD+	      ></TR+	    ><TR+	    ><TD+	      ><A HREF = "Pointfree.html"+		>Pointfree</A+		></TD+	      ><TD CLASS = "pkg"+	      ></TD+	      ></TR+	    ><TR+	    ><TD+	      ><A HREF = "PwPfConversion.html"+		>PwPfConversion</A+		></TD+	      ><TD CLASS = "pkg"+	      ></TD+	      ></TR+	    ><TR+	    ><TD+	      ><A HREF = "RefacPwPf.html"+		>RefacPwPf</A+		></TD+	      ><TD CLASS = "pkg"+	      ></TD+	      ></TR+	    ></TABLE+	  ></TD+	></TR+      ><TR+      ><TD CLASS = "s15"+	></TD+	></TR+      ><TR+      ><TD CLASS = "botbar"+	>Produced by <A HREF = "http://www.haskell.org/haddock/"+	  >Haddock</A+	  > version 0.6</TD+	></TR+      ></TABLE+    ></BODY+  ></HTML+>
+ refactorer/RefacADT.hs view
@@ -0,0 +1,1222 @@+++module RefacADT(addFieldLabels,addDiscriminators,addConstructors,+                elimNestedPatterns,elimPatterns,createADTMod,fromAlgebraicToADT,+               fromAlgebraicToADT1) where+import Prelude hiding (putStrLn)+import Maybe+import List  +import Char+import PrettyPrint +import Prelude hiding (putStrLn)+import AbstractIO (putStrLn)+import PFE0 (allModules)++import RefacUtils hiding (mkNewName, conName)++-----------------------------------------------------------------------------------------------------+{-- This refactoring transforms an algebraic data type into an abstract datatype. This is done by+    composing the invloved primitive refactorings in a correct order.+-}+-----------------------------------------------------------------------------------------------------+-- two versions of 'fromAlgebraicToADT' with different user-interfaces.+fromAlgebraicToADT1 args +   = do let fileName = ghead "filename" args+            typeCon  = (args!!1)+        seqRefac [addFieldLabels1 typeCon  fileName+                  ,addDiscriminators1 typeCon fileName+                  ,addConstructors1  typeCon fileName+                  ,elimNestedPatterns1 typeCon fileName+                  ,elimPatterns1 typeCon fileName +                  ,createADT1 typeCon fileName                  +                  ]+        putStrLn "Refactoring completed." ++fromAlgebraicToADT args+  = do let fileName = ghead "filename" args+           row = read (args!!1)::Int +           col = read (args!!2)::Int+       info@(_, _, mod, _)<-parseSourceFile fileName    +       case checkCursor fileName row col mod of+         Left errMsg ->do putStrLn errMsg+         Right decl  ->+            do let typeCon = pNtoName $ getTypeCon decl  +               seqRefac [addFieldLabels1 typeCon  fileName+                         ,addDiscriminators1 typeCon fileName+                         ,addConstructors1  typeCon fileName+                         ,elimNestedPatterns1 typeCon fileName+                         ,elimPatterns1 typeCon fileName +                         ,createADT1 typeCon fileName                  +                         ]+               putStrLn "Refactoring completed."+--------------------------------------------------------+--This refactoring does not confined this refactoring.+seqRefac=seqRefac'.addFlagParam+ where  +    addFlagParam [] = []+    addFlagParam (r:rs) = (r False): (map (\r'->r' True) rs)+                      +    seqRefac' []= return ()                                 +    seqRefac' (r:rs) = do r +                          seqRefac' rs ++----------------------------------------------------------------- +addFieldLabels1 typeCon fileName isSubRefactor+ = do  info@(_, _, mod,_) <-parseSourceFile fileName +       case findDataTypeDecl typeCon mod of +        Left errMsg ->do putStrLn errMsg+        Right decl  ->addFieldLabels' info decl fileName isSubRefactor++addDiscriminators1 typeCon fileName isSubRefactor+  = do info@(_,_, mod,_) <- parseSourceFile fileName  +       case findDataTypeDecl typeCon mod of +         Left errMsg -> putStrLn errMsg+         Right decl ->addDiscriminators' info decl fileName isSubRefactor      ++addConstructors1 typeCon  fileName isSubRefactor+   = do info@(_, _,mod,_) <- parseSourceFile fileName+        case findDataTypeDecl typeCon mod of +          Left errMsg -> putStrLn errMsg+          Right decl ->  addConstructors' info decl fileName isSubRefactor ++elimNestedPatterns1 typeCon fileName isSubRefactor+  = do info@(_,_,mod,_) <- parseSourceFile fileName+       case findDataTypeDecl typeCon mod of +         Left errMsg -> putStrLn errMsg+         Right decl  -> elimNestedPatterns' decl info fileName isSubRefactor++elimPatterns1 typeCon fileName isSubRefactor+  = do info@(_,_,mod,_) <- parseSourceFile fileName+       case findDataTypeDecl typeCon mod of +         Left errMsg -> putStrLn errMsg+         Right decl  -> elimPatterns' decl info fileName isSubRefactor++createADT1 typeCon fileName isSubRefactor +  = do info@(_,_,mod,_) <- parseSourceFile fileName+       case findDataTypeDecl typeCon mod of +         Left errMsg -> putStrLn errMsg+         Right decl  -> createADT' decl info fileName isSubRefactor++findDataTypeDecl::String->HsModuleP->Either String HsDeclP +findDataTypeDecl typeCon mod+  = case find definesTypeCon (hsModDecls mod) of+        Nothing   -> Left "The refactorer could not find the datatype declaration."+        Just decl'-> Right decl'+  where+     definesTypeCon (Dec (HsDataDecl loc c tp _ _))+        = typeCon == pNTtoName (head (hsPNTs tp))+     definesTypeCon _ = False +++-------------------------------------------------------------------------------------------------------------+{- This refactoring creates the module interface for the ADT. The pre-condition for the+   refactoring is that there are no uses of the related data constructors in the importing modules.+  If this refactoring is only used as a basic step in the refactoring 'fromAlgebraicToADT', then there+  is no need to modify the client modules. However, if it is applied individully, there is a need to+  check the client modules to make sure the exporting does not cause name clash/conflict problems.+-}++createADTMod args+  =do let fileName= ghead "filename" args   +          row = read (args!!1)::Int+          col = read (args!!2)::Int   +      info@(_,_,mod,_) <- parseSourceFile fileName+      case checkCursor fileName row col mod of+        Left errMsg ->putStrLn errMsg+        Right decl  ->+           do isUsed<-useOfDataCons decl fileName  +              case isUsed of+                True ->putStrLn ("Some of the data constructors declared by this datatype are used by at"+                                  ++" least one of the client modules, please apply the 'eliminate patterns' refactoring first.")+                False->createADT' decl info fileName False ++-- check whether any of the declared constructors is used by client modules.+-- useOfDataCons::HsDeclP->ModuleName->HsModuleP->Maybe Bool++useOfDataCons decl fileName  +  = do  clients <-clientModsAndFiles =<<RefacUtils.fileNameToModName fileName  +        info <-mapM parseSourceFile (map snd clients)+        let pns =concatMap (findPNames  (conName decl)) (map (\ (_,_,mod,_)->hsModDecls mod) info)+        return (pns/=[])+  where +       -- CHECK THIS LATER, WHY USING  findPNames from the API does not work.+       findPNames pns=head.(applyTU (once_tdTU (failTU `adhocTU` worker)))+        where +          worker (pn1::PNT)+             |elem (pNTtoPN pn1) pns =return [pn1]+          worker _ =return []+  ++createADT' decl (_, exps, mod, toks) fileName isSubRefactor+  = do (mod', ((toks',m),_)) <-runStateT (doCreateADTMod decl exps mod) ((toks, unmodified), (-1000, 0))+       serverModName<- RefacUtils.fileNameToModName fileName  +       clients<-clientModsAndFiles serverModName+       let typeCon = getTypeCon decl +       refactoredClients <- mapM (createADTInClientMod typeCon)  clients+       writeRefactoredFiles isSubRefactor $ ((fileName,True),(toks', mod')):refactoredClients+       ++createADTInClientMod typeCon (m, fileName)+   = do (_,_,mod,toks)<-parseSourceFile fileName+        (mod',((toks',modified),_))+           <-runStateT (rmSubEntsFromExport typeCon mod) ((toks,unmodified), (-1000,0))+        return ((fileName, modified),(toks',mod'))  +++doCreateADTMod decl@(Dec (HsDataDecl _ _ _ cons _)) exps mod +  = mkADTInterface exps typeCon (typeCon:(selectors++discriminators++constructors)) mod    +  where +   typeCon = getTypeCon decl+   discriminators = map (fromJust.snd)  $ existingDiscriminators mod decl  +   constructors   = map (fromJust.snd) $ filter (\(x,y)->isJust y) $ existingConstructors mod decl+   selectors      = concatMap selectors' cons+     where  selectors' ((HsRecDecl _ _ _ i ts):: HsConDeclP) = map pNTtoPN (concatMap fst ts)+            selectors' ((HsConDecl _ _ _ i _) ::HsConDeclP)  = []+++mkADTInterface exps typeCon pns mod +  = case hsModExports mod of+          -- The whole module is implicitly exported.+         Nothing     -> addItemsToExport  mod  Nothing True (Right entsToBeExported) +         -- There are explicitly exported entities.+         Just exports ->+           case isJust (find (==(ModuleE (hsModName mod))) exports) of+                  -- The module name is explicitly exported.+            True   -> do mod'<-rmItemsFromExport mod (Left ([sNtoName (hsModName mod)], pns))+                         addItemsToExport mod' Nothing True (Right entsToBeExported)+                         --individual entities are explicitly exported                            +            False  ->do let entsToAdd =map pNtoVarEnt $ (pns \\(findEnts pns exports))+                        -- remove the type constructor+                        mod'<-rmItemsFromExport mod (Left ([], [typeCon]))+                        addItemsToExport mod' Nothing True (Right ((pNtoVarEnt typeCon):entsToAdd))+  where+     -- entities need to be exported.+     entsToBeExported = nub $ map fromJust $ filter isJust (map fromEntToEntE exps)++     fromEntToEntE  (_, Ent modName (HsCon con) (Type _))+          = if sNtoName con == pNtoName typeCon  +              then -- only export type constructor.+                   Just $ EntE (Abs (nameToPNT (sNtoName con)))+                   -- export both type constructor and data constructor.+              else Just $ EntE (AllSubs (nameToPNT (sNtoName con)))+     fromEntToEntE  (_, Ent modName (HsVar var) _) +          = Just $ EntE (Var (nameToPNT (sNtoName  var)))+     fromEntToEntE  _   = Nothing +     +     findEnts pns ents+       =filter (\pn->any (\e->case e of +                          ModuleE _ -> False+                          EntE e'   -> match pn e') ents) pns      +       where  match pn (Var pnt)        = pNTtoPN pnt == pn+              match pn (Abs pnt)        = pNTtoPN pnt == pn+              match pn (AllSubs pnt)    = pNTtoPN pnt == pn+              match pn (ListSubs pnt _) = pNTtoPN pnt == pn++------------------------------------End of createADTMod------------------------------------------------------++doCreateADTMod1 decl@(Dec (HsDataDecl _ _ _ cons _))  mod exps+  = addToExport mod exps typeCon (typeCon:(selectors++discriminators++constructors))     +  where +   typeCon = getTypeCon decl+ +   discriminators = map (fromJust.snd)  $ existingDiscriminators mod decl  ++   constructors   = map (fromJust.snd) $ filter (\(x,y)->isJust y) $ existingConstructors mod decl+   +   selectors      = concatMap selectors' cons+    +   selectors' ((HsRecDecl _ _ _ i ts):: HsConDeclP) = map pNTtoPN (concatMap fst ts)+   selectors' ((HsConDecl _ _ _ i _)::HsConDeclP)   = []++   addToExport mod exps typeCon pns +    =let filteredExps =map fromJust $ filter isJust (map fromEntToEntE exps)+         exports = hsModExports mod +         modName =ModuleE $ hsModName mod +     in  case isNothing exports of+         True   -> return mod+         -- There are explicitly exported entities.+         False  -> case isJust (find (==modName) (fromJust exports))+                        of  -- The whole module is exported.+                          True   -> return mod+                           --   individual entities are explicitly exported                            +                          False  ->do let entsToAdd =map pNtoVarEnt $ (pns \\(findEnts pns (fromJust exports)))+                                      addItemsToExport mod Nothing False (Right entsToAdd)+      where   +        fromEntToEntE  (_, Ent modName (HsCon con) (Type _))+             = if sNtoName con == pNtoName typeCon  +                 then Just $ EntE (Abs (nameToPNT (sNtoName con)))+                 else Just $ EntE (AllSubs (nameToPNT (sNtoName con)))+        fromEntToEntE  (_, Ent modName (HsVar var) _) +            = Just $ EntE (Var (nameToPNT (sNtoName  var)))+        fromEntToEntE  _   = Nothing +     +        findEnts pns ents+         =filter (\pn->any (\e->case e of +                           ModuleE _ -> False+                           EntE e'   -> match pn e') ents) pns      +          where  match pn (Var pnt)        = pNTtoPN pnt == pn+                 match pn (Abs pnt)        = pNTtoPN pnt == pn+                 match pn (AllSubs pnt)    = pNTtoPN pnt == pn+                 match pn (ListSubs pnt _) = pNTtoPN pnt == pn++exportEnts (HsModule _ _ (Just ents) _ _)+  = map fromJust $ filter isJust +      ( map (\e ->case e of +                  (EntE ent) ->Just ent +                  _          ->Nothing) ents)+exportEnts (HsModule _ _ Nothing _ _) = []++findEntsToAdd typeConPN selectors discriminators constructors  ents+  = nub $ concatMap (match typeConPN) ents      +    where ++      match typeConPN (AllSubs pnt)+         | pNTtoPN pnt == typeConPN+        = concatMap snd selectors ++ map snd (discriminators++constructors)+      match typeConPN (ListSubs pnt idents)    -- refactor this +        | pNTtoPN pnt == typeConPN+        = let r1 = concatMap (\(dataCon, funs)->if elem (pNtoName dataCon) identNames+                                                 then funs +                                                 else []) selectors +              r2 = concatMap (\(dataCon, fun)->if elem (pNtoName dataCon) identNames+                                                then [fun] +                                                else []) (discriminators++constructors)+          in r1++r2+       where+          identNames= map identToName  idents +          identToName (HsVar i) = pNTtoName i+          identToName (HsCon i) = pNTtoName i+      match _ _ = []+                                  +getTypeCon::HsDeclP->PName+getTypeCon decl@(Dec (HsDataDecl l c tp cons d))+  = pNTtoPN $ ghead "getTypeCon" $ filter (\(PNT _ (Type _) _)->True) (hsPNTs tp)++----------------------------------------------------------------------------------------------+{- This refactoring eliminate the affected patterns by using selectors/discriminators/constructors.+   The condition for this refactoring is that there shoudn't be any nested patterns using other data+   constructors in the pattern to be eliminated, and the selectors/discriminators/constructors should+   be available. So there is a need to modify the imports/exports interfaces to make sure these+   special functions are available. -}+  +----------------------------------------------------------------------------------------------  ++elimPatterns args+ =do let fileName= ghead "filename" args            +         row = read (args!!1)::Int+         col = read (args!!2)::Int   +     info@(_,_,mod,_) <- parseSourceFile fileName+     case checkCursor fileName row col mod of+       Left errMsg -> putStrLn errMsg+       Right decl  -> elimPatterns' decl info fileName False+ ++elimPatterns' decl (_, exps, mod, toks) fileName isSubRefactor+  = do (mod',((toks',modified),_))<-runStateT (do mod'<-doCreateADTMod1 decl mod exps+                                                  rmPatterns mod')+                                              ((toks,unmodified),(-1000,0)) +       if (any (flip isExported  exps) (conPNT decl)) -- check whether any of the data constructors are exported.+         then do +                 serverModName<- RefacUtils.fileNameToModName fileName  +                 clients<-clientModsAndFiles serverModName+                 refactoredClients <- mapM (elimPatternsInClientMod serverModName)  clients+                 writeRefactoredFiles isSubRefactor $ ((fileName,True),(toks', mod')):refactoredClients+         else writeRefactoredFiles isSubRefactor $ [((fileName,True),(toks', mod'))]+   where+     typeCon = getTypeCon decl++     conNames = conName decl++     selectors = gatherSelectors decl++     discriminators = gatherDiscriminators decl mod  ++     constructors  = gatherConstructors decl mod               ++     elimPatternsInClientMod serverModName (m, fileName)+       = do (_,_,mod,toks)<-parseSourceFile fileName+            (mod',((toks',modified),_))+                <-runStateT (do -- replace  exports of data constructors by exports of associated special functions.+                                 let entsToAdd= map (\x->(EntE (Var (nameToPNT x))))+                                             $ findEntsToAdd typeCon selectors discriminators constructors (exportEnts mod)+                                 mod'<- addItemsToExport mod Nothing False (Right entsToAdd)+                                 -- replace imports of data constructors by imports of associated special functions.+                                 mod''<-addToImport serverModName typeCon selectors  discriminators constructors mod'+                                 rmPatterns mod'')+                             ((toks,unmodified), (-1000,0))+            return ((fileName, modified),(toks',mod'))  ++     rmPatterns = applyTP (full_tdTP (idTP `adhocTP` inMatch           -- full_buTP and full_tdTP make difference in this function.+                                           `adhocTP` inPatBinding+                                           `adhocTP` inExp)) +  +       where  ++         inMatch (match@(HsMatch loc i ps rhs ds)::HsMatchP) +           |isNothing (find (==(pNTtoName i)) (map snd (discriminators++constructors))) +            --the condition ensures that those special funs are not affected.+           = do (ps', sels, guards) <-rmPatternsInParams conNames match ps+                rhs'<-replaceVarsBySels sels rhs+                rhs''<-replacePatsByConstructors conNames constructors rhs'+                rhs'''<-if guards/=[] then addGuardsToRhs rhs'' $ fromJust (mkGuard guards)+                                      else return rhs''                                    +                ds'<-replacePatsByConstructors conNames constructors =<<replaceVarsBySels sels ds +                return $ (HsMatch loc i ps' rhs''' ds')   +         inMatch m = return m+ +         inPatBinding (pat@(Dec (HsPatBind loc i rhs ds)::HsDeclP)) +           |isNothing (find (==(pNTtoName.patToPNT) i) (map snd (discriminators++constructors)))+            --the condition ensures that those special funs are not affected.+           = do rhs'<-replacePatsByConstructors conNames constructors rhs                           +                ds'<-replacePatsByConstructors conNames constructors  ds +                return $ (Dec (HsPatBind loc i rhs' ds'))+         inPatBinding m = return m+       +         inExp (exp@(Exp (HsLambda ps e))::HsExpP)+           =do (ps', sels, guards) <-rmPatternsInParams conNames exp ps        +               e'<-replaceVarsBySels sels e+               let e''= if guards/=[] then (Exp (HsCase (fromJust (mkGuard guards))+                                            [HsAlt loc0 fakeTruePat (HsBody e') []]))+                                      else e'+                   exp'= Exp (HsLambda ps' e'')+               if (exp/=exp') then update exp exp' exp+                              else return exp'        +++         inExp exp@(Exp (HsListComp stmts))+           = do exp'<-applyTP (full_buTP (idTP `adhocTP` inStmt)) exp  +                if (exp/=exp') then update exp exp' exp+                               else return exp'+           where +             inStmt (stmt@(HsGenerator loc p e stmts)::HsStmtP)+               = do (p', sels, guards) <-rmPatternsInParams conNames stmt p      +                    e'<-replaceVarsBySels sels e+                    stmts'<-replaceVarsBySels sels stmts+                    let stmts''=if guards/=[] then (HsQualifier (fromJust (mkGuard guards)) stmts')+                                              else stmts'    +                    return $ HsGenerator loc p' e' stmts''                                    +             inStmt m = return m  ++         inExp exp@(Exp (HsDo stmts))+            = do exp' <-applyTP (full_buTP (idTP `adhocTP` inStmt)) exp +                 if (exp/=exp') then update exp exp' exp                           +                                else return exp'+           where +             inStmt (stmt@(HsGenerator loc p e stmts)::HsStmtP)+               =do (p', sels, guards) <-rmPatternsInParams conNames stmt p     +                   e'<-replaceVarsBySels sels e+                   stmts'<-replaceVarsBySels sels stmts+                   let stmts''=if guards/=[] then (HsLast (Exp (HsCase (fromJust (mkGuard guards))+                                                   [HsAlt loc0 fakeTruePat (HsBody (Exp (HsDo stmts'))) []])))+                                             else stmts'+                   return (HsGenerator loc p' e' stmts'')           +             inStmt m = return m++         inExp exp@(Exp (HsCase e alts))+           = do exp'<-applyTP (full_buTP (idTP `adhocTP` inAlt)) exp +                if (exp/=exp') then update exp exp' exp                               +                               else return exp'            +           where +            inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+              = do  (p', sels, guards) <-rmPatternsInParams conNames alt p +                    rhs'<- replaceVarsBySels sels rhs    +                    rhs''<-if guards/=[] then addGuardsToRhs rhs' $ fromJust (mkGuard guards)+                                         else return rhs'                                      +                    ds'<-replaceVarsBySels sels ds+                    return (HsAlt loc p' rhs'' ds') +         inExp m = return m+++         rmPatternsInParams conNames ast ps+           = do fds <-existingVbls ast+                ps' <- rmPatternInParams1 fds conNames ps+                resetVal+                (sels, guards) <-rmPatternInParams2 fds conNames ps+                resetVal+                return (ps',sels, guards)+            where +          -- Two versions of `rmPatternInParams`, one for transformation, one for collecting information.+         rmPatternInParams1 d conNames  +            =applyTP (stop_tdTP (failTP `adhocTP` inPat)) +             where+             inPat pat@(Pat (HsPParen (Pat (HsPApp i is))))+              | isJust (find (==pNTtoPN i) conNames) +              = inPat' pat Nothing        +             inPat pat@(Pat (HsPAsPat i1 (Pat (HsPParen (Pat (HsPApp i2 is))))))+              | isJust (find (==pNTtoPN i2) conNames)+              = inPat' pat (Just (pNTtoName i1))+             inPat (pat@(Pat (HsPApp i is))::HsPatP)+              | isJust (find (==pNTtoPN i) conNames) +              = inPat' pat Nothing +             inPat pat@(Pat (HsPAsPat i1 (Pat (HsPApp i2 is))))+               | isJust (find (==pNTtoPN i2) conNames) +              = inPat' pat (Just (pNTtoName i1))+             inPat pat@(Pat (HsPId (HsCon i)))+               | isJust (find (==pNTtoPN i) conNames)+              =inPat' pat Nothing+             inPat pat@(Pat (HsPParen (Pat (HsPId (HsCon i)))))+               | isJust (find (==pNTtoPN i) conNames)+              = inPat' pat Nothing+             inPat pat@(Pat (HsPAsPat i1 (Pat (HsPId (HsCon i2)))))+               | isJust (find (==pNTtoPN i2) conNames)+              =inPat' pat (Just (pNTtoName i1))+             inPat pat@(Pat (HsPAsPat i1 (Pat (HsPParen (Pat (HsPId (HsCon i2)))))))+               | isJust (find (==pNTtoPN i2) conNames)+              =inPat' pat (Just (pNTtoName i2))+              +             inPat _ = mzero+         +             inPat' pat varName +                = do unless (not (isNestedPattern conNames pat))+                         $ error "Nested patterns exist, please apply the 'eliminate nested patterns' refactoring first!"+                     (_,d') <- hsFreeAndDeclaredPNs pat   +                     (tm,(v,val)) <- get+                     let newVarName =if isJust varName then fromJust varName+                                                       else mkNewName "p" (map pNtoName (d\\d')) "" val+                         nextVal' =(ord (glast "rmPatternInParams'" newVarName) - ord '0') +1 +                         nextVal = if nextVal' >10 then 1 else nextVal'                            +                     put (tm, (v,nextVal))                +                     update pat  (Pat (HsPId (HsVar (nameToPNT newVarName)))) pat+ +         rmPatternInParams2 d conNames ps+           =do r<-applyTU (stop_tdTU (failTU `adhocTU` inPat)) ps+               return (concatMap fst r, concatMap snd r)+           where+             inPat (pat@(Pat (HsPApp i is))::HsPatP)+               | isJust (find (==pNTtoPN i) conNames)+               = inPat' (pNTtoPN i) pat Nothing+ +             inPat (pat@(Pat (HsPId (HsCon i)))::HsPatP)+               | isJust (find (==pNTtoPN i) conNames)+               = inPat' (pNTtoPN i) pat Nothing++             inPat (pat@(Pat (HsPAsPat i1 i2)))+                 | case rmPParen i2 of   +                       (Pat (HsPApp i2' _)) ->isJust (find (==pNTtoPN i2') conNames)+                       (Pat (HsPId (HsCon i2'))) ->isJust (find (==pNTtoPN i2') conNames)+                       _ ->False +                 = (\pat -> case pat of +                            (Pat (HsPApp i2' ps)) ->inPat' (pNTtoPN i2') pat (Just (pNTtoName i1))+                            (Pat (HsPId (HsCon i2')))->inPat' (pNTtoPN i2') pat (Just (pNTtoName i1))) (rmPParen i2)+             inPat _ =mzero++             inPat' conPN pat varName +               = do (_,d') <- hsFreeAndDeclaredPNs pat  +                    (tm,(v,val)) <- get+                    let (newVarName,nextVal')+                           =if isJust varName+                              then (fromJust varName, val)+                              else (mkNewName "p" (map pNtoName (d\\d')) "" val, +                                    (ord (glast "rmPatternInParams'" newVarName) - ord '0') +1)+                        nextVal = if nextVal' >10 then 1 else nextVal'+                    put (tm,  (v,nextVal))                +                    let sels = findSelectors conPN selectors +                        selectorFuns =mkSelectorFuns conPN newVarName "" sels pat                         +                        guardExps = mkGuardExps newVarName discriminators pat                      +                    return [(selectorFuns, guardExps)]++         isNestedPattern conNames appPat+             = isJust $ find (==True) (ghead "isNestedPattern" (isNestedPattern' appPat))+           where+            isNestedPattern'= applyTU (full_tdTU (constTU []  `adhocTU` inAppPat))+              where+               inAppPat pat+                 | isVarPat pat =return []+               inAppPat pat@(Pat (HsPApp i ps))+                 |isJust (find (==pNTtoPN i) conNames)+                 = return []+               inAppPat pat@(Pat (HsPId (HsCon i)))+                 |isJust (find (==pNTtoPN i) conNames)+                 =return []       +               inAppPat pat@(Pat (HsPInfixApp _ i _))+                 |isJust (find (==pNTtoPN i) conNames)+                 = return []+               inAppPat pat@(Pat (HsPRec i _))+                 |isJust (find (==pNTtoPN i) conNames)+                 = return [] +               inAppPat pat@(Pat (HsPAsPat i1 i2)) +                 =isNestedPattern' i2+               inAppPat pat@(Pat (HsPParen p))+                 =isNestedPattern' p               +               inAppPat _ = return [True]++         repalceVarsBySels [] p = return p+         replaceVarsBySels sels p =applyTP (full_buTP (idTP `adhocTP` inExp)) p+           where +             inExp exp@(Exp (HsId (HsVar (PNT pn ty src@(N (Just (SrcLoc fileName  c row col))))))) +                |isJust (find (==pn) pnsToBeReplaced)+               = do let sel = (snd.fromJust) (find (\(x,y)-> x==pn) sels)+                        --pn' = replaceNameInPN Nothing pn sel  +                    update exp sel exp +                    --update pnt (PNT pn' ty src) pnt                   +             inExp e = return e      +             pnsToBeReplaced =map fst sels++         replacePatsByConstructors conNames constructors +            = applyTP (full_tdTP (idTP `adhocTP` inExp))+                                       -- `adhocTP` inPNT))+           where+            inExp exp@(Exp (HsRecConstr _ i fields)) +              | isJust (find (==pNTtoPN i) conNames)+               = do let entry = find (\(x,y)->x==(pNTtoPN i)) constructors+                        con   = if isJust entry +                                 then (snd.fromJust) entry+                                 else error $ "Constructor function does not exist for the data constructor:" ++ pNTtoName i+                        es = map (\(HsField _ e ) -> e) fields+                        exp'= (Exp (HsParen (foldl (\e1 e2->(Exp (HsApp e1 e2))) (nameToExp con) es)))+                    update exp exp' exp                    +            inExp e +              | isJust (find (==(pNTtoPN.expToPNT) e) conNames)+              = do let (PNT pn ty src)=expToPNT e +                       entry = find (\(x,y)->x==pn) constructors+                       constructor +                         =if isJust entry +                           then (snd.fromJust) entry+                           else error $ "Constructor function does not exist for the data constructor:"++ pNtoName pn+                   renamePN pn Nothing constructor True e++            inExp e = return e             +            +{-+            inPNT pnt@(PNT pn ty src@(N (Just (SrcLoc fileName  c row col))))+              | isJust (find (== pn) conNames) && not (isTypeCon pnt)+              = do let entry = find (\(x,y)->x==pn) constructors+                       constructor = if isJust entry +                                       then (snd.fromJust) entry+                                       else error $ "Constructor function does not exist for the data constructor:"++ pNtoName pn+                       pn' = replaceNameInPN Nothing pn constructor+                   updateExpToks pnt constructor+                   return (PNT pn' ty src)+            inPNT pnt = return pnt +-}+       +         mkGuardExps newVarName discriminators (Pat (HsPApp i ps))+           = let discr =findDiscriminator (pNTtoPN i)  discriminators +                 guardExp=Exp (HsApp (Exp (HsId (HsVar (nameToPNT discr))))+                           (Exp (HsId (HsVar (nameToPNT newVarName)))))+             in [guardExp]++         mkGuardExps newVarName discriminators (Pat (HsPId (HsCon i)))+           = let discr =findDiscriminator (pNTtoPN i)  discriminators +                 guardExp=Exp (HsApp (Exp (HsId (HsVar (nameToPNT discr))))+                           (Exp (HsId (HsVar (nameToPNT newVarName)))))+             in [guardExp]+         mkGuard [] = Nothing+         mkGuard (e:es)+           = Just (foldl (\e1 e2 -> (Exp (HsInfixApp e1 (HsVar (nameToPNT  "&&")) e2))) e es)++         -- What is poxfix for?+         mkSelectorFuns con  newVarName posfix selectors (Pat (HsPApp i ps)) +          = concatMap mkSelectorFuns' (zip selectors ps)+          where mkSelectorFuns' (sel, pat@(Pat (HsPId (HsVar i))))+                  =[(pNTtoPN i, if posfix ==[]+                                    then  (Exp (HsParen (Exp (HsApp (Exp (HsId (HsVar (nameToPNT sel))))+                                                (Exp (HsId (HsVar (nameToPNT newVarName))))))))+                                    else (Exp (HsParen (Exp (HsApp (Exp (HsId (HsVar (nameToPNT (sel++"."++posfix)))))+                                                           (Exp (HsId (HsVar (nameToPNT newVarName)))))))))]+                                   {-                  +                                      if posfix=="" then "("++sel++" "++ newVarName++")"+                                               else "(("++sel++"."++posfix++") "++newVarName++")")] -}+                mkSelectorFuns' (sel, (Pat (HsPParen p)))+                 = mkSelectorFuns' (sel, p)+                mkSelectorFuns' (sel, pat@(Pat (HsPApp i ps)))+                 = mkSelectorFuns con newVarName+                      (if posfix=="" then sel else sel++"."++posfix) selectors pat  +                mkSelectorFuns' (sel, _) = [] +         mkSelectorFuns _ _ _ _  _ = []+++---- This function is only used by the 'RefacADT.hs' module, I haven't work out a way to refactor it.+addToImport serverModName typeCon selectors discriminators constructors mod+  =applyTP (full_buTP (idTP `adhocTP` inImport)) mod+  where +    inImport (imp@(HsImportDecl loc m@(SN modName _) qual  as h):: HsImportDeclP)+      | serverModName == modName &&  findPN typeCon h+       = case h of+           Nothing        -> return imp                     +           Just (b, ents) -> do let funs=findEntsToAdd typeCon selectors discriminators constructors ents+                                if (funs==[]) then return imp+                                  else addItemsToImport serverModName Nothing (Left funs) imp+    inImport imp = return imp++   +    findEntsToAdd typeConPN selectors discriminators constructors ents+      = nub $ concatMap (match typeConPN) ents      +      where ++      match typeConPN (AllSubs pnt)+         | pNTtoPN pnt == typeConPN+        = concatMap snd selectors ++ map snd (discriminators++constructors)+      match typeConPN (ListSubs pnt idents)    -- refactor this +        | pNTtoPN pnt == typeConPN+        = let r1 = concatMap (\(dataCon, funs)->if elem (pNtoName dataCon) identNames+                                                 then funs +                                                 else []) selectors +              r2 = concatMap (\(dataCon, fun)->if elem (pNtoName dataCon) identNames+                                                then [fun] +                                                else []) (discriminators++constructors)+          in r1++r2+       where+          identNames= map identToName  idents +          identToName (HsVar i) = pNTtoName i+          identToName (HsCon i) = pNTtoName i+      match _ _ = []+    +------------------------------------------------------------------------------------------------------------------------  +{- This refactoring removes the explict uses of specific data constructors by using selectors/disriminators/constructors.+   To do this refactoring, put the cursor at beginning of the data type declaration, then select the `elimNestedPatterns`+   in Refactor menu. There is no pre-condition for this refactoring.  -}+------------------------------------------------------------------------------------------------------------------------+elimNestedPatterns args+ =do let fileName= ghead "filename" args            +         row = read (args!!1)::Int+         col = read (args!!2)::Int   +     info@(inscps, exps, mod, toks) <- parseSourceFile fileName+     case checkCursor fileName row col mod of+       Left errMsg -> putStrLn errMsg+       Right decl  -> elimNestedPatterns' decl info fileName False                                             ++elimNestedPatterns'  decl (_,_,mod,toks) fileName isSubRefactor+  = do (mod',((toks',modified),_))<-runStateT (elimNestedPatterns'' mod)+                                     ((toks,unmodified), (-1000,0))+       modName <- RefacUtils.fileNameToModName fileName  +       clients<-clientModsAndFiles modName   +       refactoredClients <- mapM elimNestedPatternsInClientMod  clients+       writeRefactoredFiles isSubRefactor $ ((fileName,True),(toks', mod')):refactoredClients+     +   where ++     conNames = conName decl ++     elimNestedPatternsInClientMod (m,fileName)+       = do (_,_,mod,toks)<-parseSourceFile fileName+            (mod',((toks',modified),_))<-runStateT (elimNestedPatterns''  mod)+                                          ((toks,unmodified), (-1000,0))+            return ((fileName, modified),(toks',mod'))   ++      {- This function removes those nested patterns in the formal parameters of a function declaration+         by introducing guards and case expression. -}+     elimNestedPatterns'' = applyTP (full_buTP (idTP `adhocTP` inMatch +                                                     `adhocTP` inExp))+      where  +       inMatch (match@(HsMatch loc i ps rhs ds)::HsMatchP) +        = do newMatch <-mkNewAST mkNewMatch conNames match ps                +             if (match/=newMatch) then update match newMatch match+                                  else return newMatch ++       inExp (exp@(Exp (HsLambda ps e))::HsExpP)+         =do newLambdaExp <-mkNewAST mkNewLambdaExp conNames exp ps +             if (exp/=newLambdaExp) then update exp newLambdaExp exp+                                    else  return newLambdaExp     ++       inExp exp@(Exp (HsListComp stmts))+          = do exp'<-applyTP (full_buTP (idTP `adhocTP` inStmt)) exp  +               if (exp/=exp') then update exp exp' exp                                +                              else return exp'+          where +           inStmt (stmt@(HsGenerator loc p e stmts)::HsStmtP)+             = mkNewAST mkNewListStmt conNames stmt p           +           inStmt m = return m  ++       inExp exp@(Exp (HsDo stmts))+          = do exp' <-applyTP (full_buTP (idTP `adhocTP` inStmt)) exp +               if (exp/=exp') then update exp exp' exp+                              else return exp'+         where +           inStmt (stmt@(HsGenerator loc p e stmts)::HsStmtP)+              = mkNewAST mkNewDoStmt conNames stmt p     +           inStmt m = return m++       inExp exp@(Exp (HsCase e alts))+          = do exp'<-applyTP (full_buTP (idTP `adhocTP` inAlt)) exp  +               if (exp/=exp') then update exp exp' exp+                              else  return exp'            +          where +            inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+              = mkNewAST mkNewAlt conNames alt p +       inExp m = return m+++     mkNewAST fun conNames ast p+       = do fds <-existingVbls ast+            p' <-rmNestedPatternInParams2 fds conNames p+            resetVal+            varsAndPats <- getExpPatPairs fds conNames p+            resetVal+            return (fun ast p' varsAndPats)++     mkNewDoStmt stmt@(HsGenerator loc p e stmts) p' varsAndPats+       =case varsAndPats of+            Nothing -> stmt+            Just (caseVars, casePats) -> (HsGenerator loc p' e (HsLast (Exp (HsCase caseVars+                                           [HsAlt loc0 casePats (HsBody (Exp (HsDo stmts))) []]))))+ +     mkNewListStmt stmt@(HsGenerator loc p e stmts) p' varsAndPats+       = case varsAndPats of+           Nothing -> stmt+           Just (caseVars,casePats) ->(HsGenerator loc p' e (HsGenerator loc casePats (Exp (HsList [caseVars])) stmts))++     mkNewLambdaExp exp@(Exp (HsLambda ps e)) ps' varsAndPats+      = case varsAndPats of+           Nothing -> exp+           Just (caseVars,casePats) -> (Exp (HsLambda ps' (Exp (HsCase caseVars [HsAlt loc0 casePats (HsBody e) []]))))+                                            +     mkNewAlt alt@(HsAlt loc p rhs@(HsBody e) ds) p' expsAndPats +       = case expsAndPats of+            Nothing -> alt+            Just (exps, pats)->(HsAlt loc p' (HsGuard [(loc0, (Exp (HsCase exps +                             [HsAlt loc0  pats (HsBody fakeTrueExp) [],+                             HsAlt loc0 (Pat HsPWildCard) (HsBody fakeFalseExp) []])), +                            (Exp (HsApp (Exp (HsParen (Exp (HsLambda [pats] e)))) exps)))]) ds)++     mkNewAlt alt@(HsAlt loc p rhs@(HsGuard es) ds) p' expsAndPats+       = case expsAndPats of+             Nothing -> alt+             Just (exps, pats) -> let rhs'= HsGuard $ map (addToGuards (exps, pats)) es +                                  in (HsAlt loc p' rhs' ds)++     mkNewMatch ((HsMatch loc i ps rhs@(HsBody e) ds)::HsMatchP) ps' expsAndPats+       = case expsAndPats of+            Nothing -> HsMatch loc i ps' rhs ds+            Just (exps, pats) -> (HsMatch loc i ps' (HsGuard [(loc0, (Exp (HsCase exps +                                 [HsAlt loc0  pats (HsBody fakeTrueExp) [],+                                 HsAlt loc0 (Pat HsPWildCard) (HsBody fakeFalseExp) []])), +                                 (Exp (HsApp (Exp (HsParen (Exp (HsLambda [pats] e)))) exps)))]) ds)+          +     mkNewMatch (HsMatch loc i ps rhs@(HsGuard es) ds) ps' expsAndPats+       = case expsAndPats of +          Nothing-> HsMatch loc i ps' rhs ds +          Just (exps, pats)-> let rhs'= HsGuard $ map (addToGuards (exps,pats)) es +                              in (HsMatch loc i ps' rhs' ds)++     addToGuards  (exp, pat) (loc, e1, e2)+       = let g1 = Exp (HsCase exp+                    [HsAlt loc0  pat (HsBody fakeTrueExp) [],+                     HsAlt loc0 (Pat HsPWildCard) (HsBody fakeFalseExp) []])+             e1'= Exp (HsInfixApp g1 (HsVar (nameToPNT "&&")) e1)+             e2'= Exp (HsApp (Exp (HsParen (Exp (HsLambda [pat] e2)))) exp)+         in (loc, e1', e2')++                     +     getExpPatPairs d conNames ps+       = do r <- applyTU (stop_tdTU (failTU `adhocTU` inPat)) ps+            let r' = filter (\(x,y) -> isJust x) r+                r''= map (\(x,y)->(patVarToExpVar (fromJust x),y)) r'+                (exps, pats) = (map fst r'', map snd r'')+            return (if length exps ==0 then Nothing+                    else if length exps==1 then Just (head exps, head pats)+                                           else Just (Exp (HsTuple exps), Pat (HsPTuple loc0 pats)))+        where+          inPat (pat@(Pat (HsPApp i is))::HsPatP)+            | isJust (find (==pNTtoPN i) conNames)+           = do  is'<-rmNestedPatternInParams1 d conNames is+                 let caseExps = filter (\(x,y) ->isJust x) is'+                 return caseExps+          inPat _ = mzero++          patVarToExpVar (Pat (HsPId (HsVar id))) = (Exp (HsId (HsVar id)))+     +     {-There are two versions of 'rmNestedPatternsInParams'. These two functions have different+       purspose: 'rmNestedPatternInParams1' aims to collect info, whereas 'rmNestedPatternInParams2'+       aims to modify the syntax tree and token stream. The reason for this is because of the +       limitation of Strafunski's combinators-}+  +     rmNestedPatternInParams1 d conNames +        = applyTU (stop_tdTU (failTU `adhocTU` inAppPat)) +      where+       inAppPat pat+         | isVarPat pat = return [(Nothing, pat)]+       inAppPat pat@(Pat (HsPApp i ps))+         |isNothing (find (==pNTtoPN i) conNames)+          = replacePatByVar pat Nothing       +       inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPApp i2 ps))))+         |isNothing (find (==pNTtoPN i2) conNames)+         = replacePatByVar pat (Just (pNTtoName i1))        +       inAppPat pat@(Pat (HsPInfixApp _  i _))+         |isNothing (find (==pNTtoPN i) conNames)+          = replacePatByVar pat Nothing+       inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPInfixApp _ i2 _))))+         |isNothing (find (==pNTtoPN i2) conNames)+         = replacePatByVar pat (Just (pNTtoName i1))+       inAppPat pat@(Pat (HsPRec i _))+         |isNothing (find (==pNTtoPN i) conNames)+         = replacePatByVar pat Nothing +       inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPRec i2 _))))+         |isNothing (find (==pNTtoPN i2) conNames)+         = replacePatByVar pat (Just (pNTtoName i1))+       inAppPat pat+        = replacePatByVar pat Nothing++       replacePatByVar pat varName+         = do (_,d') <- hsFreeAndDeclaredPNs pat+              (t,(v,val)) <- get +              let (newVarName,nextVal')+                   =if isJust varName+                      then (fromJust varName, val)+                      else (mkNewName "p" (map pNtoName (d\\d')) "" val, +                             (ord (glast "rmPatternInParams'" newVarName) - ord '0') +1)               +                  nextVal = if nextVal' >10 then 1 else nextVal'+              put (t, (v,nextVal))                +              return [(Just (Pat (HsPId (HsVar (nameToPNT newVarName)))), pat)]++     rmNestedPatternInParams2 d conNames +       = applyTP (stop_tdTP (failTP `adhocTP` inPat))+       where+        inPat (pat@(Pat (HsPApp i is))::HsPatP)+          | isJust (find (==pNTtoPN i) conNames)+          = do is'<-rmNestedPatternInParams' is           +               return (Pat (HsPApp i is'))+        inPat _ = mzero +        -- replace the nested patterns by variables.+        rmNestedPatternInParams' +          = applyTP (stop_tdTP (failTP `adhocTP` inAppPat)) +          where+           inAppPat pat+             | isVarPat pat = mzero+           inAppPat pat@(Pat (HsPApp i ps))+             |isNothing (find (==pNTtoPN i) conNames)+              = replacePatByVar pat Nothing       +           inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPApp i2 ps))))+             |isNothing (find (==pNTtoPN i2) conNames)+             = replacePatByVar pat (Just (pNTtoName i1))        +           inAppPat pat@(Pat (HsPInfixApp _ i  _))+             |isNothing (find (==pNTtoPN i) conNames)+             = replacePatByVar pat Nothing+           inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPInfixApp _  i2  _))))+             |isNothing (find (==pNTtoPN i2) conNames)+             = replacePatByVar pat (Just (pNTtoName i1))+           inAppPat pat@(Pat (HsPRec i _))+             |isNothing (find (==pNTtoPN i) conNames)+             = replacePatByVar pat Nothing +           inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPRec i2 _))))+             |isNothing (find (==pNTtoPN i2) conNames)+             = replacePatByVar pat (Just (pNTtoName i1))+           inAppPat pat+             = replacePatByVar pat Nothing++           replacePatByVar pat varName +             = do (_,d') <- hsFreeAndDeclaredPNs pat+                  (t,(v,val)) <- get+                  let (newVarName,nextVal')+                        =if isJust varName+                           then (fromJust varName, val)+                           else (mkNewName "p" (map pNtoName (d\\d')) "" val, +                                 (ord (glast "rmPatternInParams'" newVarName) - ord '0') +1)      +                      nextVal = if nextVal' >10 then 1 else nextVal'                    +                  put (t,(v,nextVal)) +                  update pat (Pat (HsPId (HsVar (nameToPNT newVarName)))) pat+---------------------------------------------------------------------------------+{- This refactoring adds field labels to a data type declaration, the label names will+   be created by the refactorer automatically, however the user can rename them afterwards.+   The refactoring does nothing if all the field labels already exisit.+   No pre-condition for this refactoring.+-}+addFieldLabels args+ =do let fileName= ghead "filename" args            +         row = read (args!!1)::Int+         col = read (args!!2)::Int   +     info@(inscps, exps, mod, toks) <- parseSourceFile fileName+     case checkCursor fileName row col mod of+       Left errMsg -> putStrLn errMsg+       Right decl  -> addFieldLabels' info decl fileName False++addFieldLabels' (inscps,_, mod, toks) decl fileName isSubRefactor+ = do clients <-clientModsAndFiles =<<RefacUtils.fileNameToModName fileName   +      -- make sure the new name does not cause any problems in the current and client modules.+      -- By doing this, the refactor does not need to check the clients.+      clientInfo <- mapM parseSourceFile (map snd clients) +      let inscpNames =map (\ (x,_,_,_)->x) (concatMap inScopeInfo (inscps:(map (\ (a,_,_,_)->a) clientInfo)))+      (mod',((toks',modified),_))<-runStateT (addFieldLabels'' inscpNames decl mod) ((toks, unmodified), (-1000,0))+      writeRefactoredFiles isSubRefactor $ [((fileName,True),(toks', mod'))]+    +addFieldLabels'' inscpNames decl mod +  = do let (decls1, decls2) = break (==decl) (hsModDecls mod)+       newDecl <-conDeclToRecDecl inscpNames decl+       decl'<-update decl newDecl decl+       return $ mod {hsModDecls=decls1++(decl':(tail decls2))}+ +-- Add field labels to each data constructor declaration.  +conDeclToRecDecl inscpeNames = applyTP (full_buTP (idTP `adhocTP` inConDecl)) +   where+   inConDecl (decl@(HsConDecl loc is c i ts):: HsConDeclP)+     |ts /= [] +      = do ts'<-createFieldLabel 1 i ts+           return (HsRecDecl loc is c i ts')+   inConDecl x = return x -- already has field labels.+   -- create a field label by attaching a number to the end of the data constructor name.+   createFieldLabel val dataCon [] = return []+   createFieldLabel val dataCon (t:ts)+    = do let name = mkNewName (map toLower (pNTtoName dataCon)) inscpeNames "" val+             fieldLabelPNT =(PNT (PN (UnQual name) (G (PlainModule "unknown") name+                                  (N (Just loc0)))) Value (N (Just loc0)))+             -- only allowing one digit is too restrictive. +             nextVal = (ord (glast "createFieldLabel" name) - ord '0') + 1+         ds' <- createFieldLabel nextVal dataCon ts           +         return $ ([fieldLabelPNT], t):ds'+++--------------------------------------------------------------------------------------+{- This refactoring adds discriminator functions to a data type declaration. The function names+   will be created by the refactorer automatically, however the user can rename them afterwards.+   No pre-condition for this refactoring.+-}++addDiscriminators args+ =do let fileName= ghead "filename" args            +         row = read (args!!1)::Int+         col = read (args!!2)::Int   +     info@(inscps, exps, mod, toks) <- parseSourceFile fileName+     case checkCursor fileName row col mod of +       Left errMsg -> putStrLn errMsg+       Right decl  -> addDiscriminators' info decl fileName False++addDiscriminators' (inscps,_,mod,toks) decl fileName isSubRefactor+  = do clients <-clientModsAndFiles =<< RefacUtils.fileNameToModName fileName   +       clientInfo <- mapM parseSourceFile (map snd clients) +       let inscpNames= map (\(x,_,_,_)->x) (concatMap inScopeInfo (inscps:(map (\(a,_,_,_)->a) clientInfo)))+       (mod',((toks',modified),_))<-runStateT (addDiscriminators'' inscpNames decl mod)((toks, unmodified), (-1000,0))+       -- no need to modify the client module.+       writeRefactoredFiles isSubRefactor $  [((fileName,True),(toks',mod'))]++addDiscriminators'' inscpNames decl@(Dec (HsDataDecl (SrcLoc  _ _ _ col) c tp conDecls _)) mod +   = do let consWithDiscrs = existingDiscriminators mod decl+        if (length conDecls == length consWithDiscrs)+          then return mod  -- all the discriminators already exist.           +          else do     -- those data constructor decls without discriminators.+                  let conDecls' = filter (\x->isNothing (find (conName' x==) (map fst consWithDiscrs))) conDecls+                      funs= concatMap (mkDiscriminator col tp inscpNames (length conDecls) mod) conDecls'+                  addDecl mod Nothing (funs,Nothing) True +   where             +     mkDiscriminator startCol tp existingNames cons mod (decl@(HsRecDecl _ _ _ i ts):: HsConDeclP)+       = mkDiscriminator' startCol tp existingNames cons mod i ts +     mkDiscriminator startCol tp existingNames cons mod (decl@(HsConDecl _ _ _ i ts):: HsConDeclP)+       = mkDiscriminator' startCol tp existingNames cons mod i ts +      +     mkDiscriminator' startCol tp existingNames cons mod i ts +       = let funNamePNT =nameToPNT $  mkNewName (pNTtoName i) existingNames "is" 0 +             typeSig = (Dec (HsTypeSig loc0 [funNamePNT] [] (Typ (HsTyFun tp (Typ (HsTyCon (PNT (PN+                         (UnQual "Bool") (G (PlainModule "Prelude") "Bool" (N (Just loc0)))) +                        (Type blankTypeInfo) (N (Just loc0 )))))))))+             -- if only one data constructor is declared, only one match is needed.+             match1 =let pats= if length ts ==0 then [Pat (HsPId (HsCon i))]+                                                else [Pat (HsPParen (Pat (HsPApp i (mkWildCards (length ts)))))]+                     in [HsMatch loc0  funNamePNT  pats (HsBody (Exp (HsId (HsCon (PNT (PN (UnQual "True")+                         (G (PlainModule "Prelude") "True" (N (Just loc0))))(Type blankTypeInfo) (N (Just loc0)))))))[]]+             match2 = if cons ==1 then []+                        else [HsMatch loc0 funNamePNT [Pat HsPWildCard] (HsBody (Exp (HsId (HsCon (PNT (PN +                              (UnQual "False") (G (PlainModule "Prelude") "False" (N (Just loc0)))) (Type blankTypeInfo)+                              (N (Just loc0))))))) []]+             fun  = (Dec (HsFunBind loc0 (match1 ++ match2)))+         in ([typeSig, fun])+             +     mkWildCards 0 = []+     mkWildCards n = (Pat HsPWildCard) : mkWildCards (n-1)++-- collect the exisiting discriminators+existingDiscriminators mod (Dec (HsDataDecl _ c tp conDecls _))+    =filter (\x -> isJust (snd x)) $ map (findDiscriminator (hsModDecls mod)) conDecls+   where             +     findDiscriminator decls (conDecl:: HsConDeclP)  +       = let (dataCon,numOfFields)= case conDecl of +                                       (HsRecDecl _ _ _ i ts) -> (pNTtoPN i, length ts)+                                       (HsConDecl _ _ _ i ts) -> (pNTtoPN i, length ts) +             decls' = filter (\x -> isDiscriminator x (dataCon, numOfFields)) decls+         in if decls'==[] then (dataCon, Nothing)+                          else (dataCon, Just (ghead "findDiscriminator" (definedPNs (head decls'))))      +     isDiscriminator (Dec (HsFunBind _ (match1@(HsMatch _ _ [p] _ _):matches))) (dataCon,numOfFields) +          = let conAndArity = getConAndArity p+            in if isJust conAndArity  +                  then let (con, arity) = fromJust conAndArity+                       in  (con, arity) == (dataCon, numOfFields)+                           && ((render.ppi) (rhsExp match1)) =="True" +                           && (if matches==[] then True+                                 else length matches==1 && ((render.ppi) (rhsExp (head matches))) == "False")+                  else False  +          where      +             getConAndArity  (Pat (HsPApp i ps)) = Just ((pNTtoPN i), length ps)+             getConAndArity  (Pat (HsPId (HsCon i))) = Just ((pNTtoPN i),0)+             getConAndArity  (Pat (HsPParen p)) = getConAndArity p+             getConAndArity  (Pat (HsPAsPat i p)) = getConAndArity p+             getConAndArity  _  = Nothing+        +             rhsExp (HsMatch _ _ _ (HsBody e) _) = Just e+             rhsExp _ = Nothing++     isDiscriminator _  _ = False++----------------------------------------------------------------------------------------------+{- This refactoring adds constructor functions to a data type declaration.  The function names+   will be created by the refactorer automatically, however the user can rename them afterwards. +   No pre-condition for this refactoring.+-}++addConstructors args+ =do let fileName= ghead "filename" args            +         row = read (args!!1)::Int+         col = read (args!!2)::Int   +     info@(_,_,mod,_) <- parseSourceFile fileName+     case checkCursor fileName row col mod of+       Left errMsg -> putStrLn errMsg+       Right decl  -> addConstructors' info decl fileName False ++addConstructors' (inscps,_, mod, toks)  decl fileName isSubRefactor+   = do clients <-clientModsAndFiles =<<RefacUtils.fileNameToModName fileName    +        clientInfo <- mapM parseSourceFile (map snd clients) +        let inscpNames= map (\(x,_,_,_)->x) (concatMap inScopeInfo (inscps:(map (\(a,_,_,_)->a) clientInfo)))+        (mod',((toks',modified),_))<-runStateT (addConstructors'' inscpNames decl mod) ((toks, unmodified), (-1000,0))+        -- no need to modify the client modules, as the new name won't cause problems.+        writeRefactoredFiles isSubRefactor $ [((fileName,modified),(toks', mod'))]++         +addConstructors'' inscpNames decl@(Dec (HsDataDecl (SrcLoc  _ _ _ col) c tp conDecls _)) mod +  = do let consWithConstrs = existingConstructors mod decl +       if (length conDecls == length consWithConstrs) +         then return mod -- all constructors already exist, so do nothing.+         else do let conDecls' = filter (\x->isNothing (find (conName' x==) (map fst consWithConstrs))) conDecls+                     funs =concatMap (mkConstructor col tp inscpNames mod) conDecls'+                 addDecl mod Nothing (funs,Nothing) True +  where             +     mkConstructor startCol tp existingNames mod (decl@(HsRecDecl _ _ _ i ts):: HsConDeclP)+       = mkConstructor' startCol tp existingNames mod i (map (typeFromBangType.snd) ts)+     mkConstructor startCol tp existingNames mod (decl@(HsConDecl _ _ _ i ts):: HsConDeclP)+       = mkConstructor' startCol tp existingNames mod i (map typeFromBangType ts)+          +     mkConstructor' startCol tp existingNames mod i ts +       = let funNamePNT =nameToPNT $ mkNewName (pNTtoName i) existingNames "mk" 0 +             numOfParams = length ts +             typeSig = (Dec (HsTypeSig loc0 [funNamePNT] [] (mkTypeFun tp ts)))+             fun  = (Dec (HsFunBind loc0 [HsMatch loc0 funNamePNT [] (HsBody (Exp (HsId (HsCon i)))) []]))+          in ([typeSig, fun])+             +     mkTypeFun t ts = foldr (\ t1 t2 ->(Typ (HsTyFun t1 t2))) t ts++     typeFromBangType (HsBangedType t)   = t+     typeFromBangType (HsUnBangedType t) = t+++--existingConstructors:: HsModuleP -> HsDeclP ->(PName, Maybe PName)+existingConstructors mod (Dec (HsDataDecl _ c tp conDecls _))+  =filter (\x -> isJust (snd x)) $ map (findConstructors (hsModDecls mod)) conDecls+  where             +    findConstructors decls (conDecl:: HsConDeclP)  +     = let (dataCon,numOfFields)= case conDecl of +                                  (HsRecDecl _ _ _ i ts) -> (pNTtoPN i, length ts)+                                  (HsConDecl _ _ _ i ts) -> (pNTtoPN i, length ts) +           decls' = filter (\x -> isConstructor x (dataCon, numOfFields)) decls+       in if decls'==[] then (dataCon, Nothing)+                        else (dataCon,  Just (ghead "findConstructors" (definedPNs (head decls'))))    +   +    isConstructor (Dec (HsFunBind _ [match1@(HsMatch _ _ ps (HsBody e) _ )])) (dataCon,numOfFields) +      | length ps== numOfFields && all isVarPat ps +       =hsPNs e ==dataCon : (hsPNs ps)       +    isConstructor (Dec (HsPatBind _  f (HsBody e) _)) (dataCon, numOfFileds)+       = (render.ppi) e == pNtoName dataCon+    isConstructor _ _ = False+++--------------------Some utility functions --------------------------------------++-- check whether the cursor points to the beginning of the datatype declaration.+checkCursor::String->Int->Int->HsModuleP->Either String HsDeclP +checkCursor fileName row col mod+  = case locToTypeDecl of+       Nothing   ->Left ("Invalid cursor position. Please place cursor at the beginning of the type constructor name!")+       Just decl ->Right decl                                +   where+    locToTypeDecl =find (definesTypeCon (locToPNT fileName (row,col) mod)) (hsModDecls mod)+   +    definesTypeCon pnt (Dec (HsDataDecl loc c tp _ _))= isTypeCon pnt && (findPNT pnt tp)+    definesTypeCon pnt _ = False ++-- Create a new name from the oldName, and the new name should not conflict with the exisiting names.+mkNewName oldName exisitingNames prefix init+  = let newName = if init==0 then prefix++oldName+                             else prefix++oldName++ show init+    in if elem newName exisitingNames+           then mkNewName oldName exisitingNames prefix (init+1)+           else newName+++--get the list of free and declared variables.+existingVbls t = do (f,d)<-hsFDsFromInside t+                    return (f++d)++-- returns True if a pat is a variable.+isVarPat pat = case pat of+                  (Pat (HsPId (HsVar i))) -> True+                  (Pat (HsPAsPat i p))    -> isVarPat p+                  (Pat (HsPIrrPat p))     -> True+                  (Pat (HsPParen p))      -> isVarPat p +                  (Pat (HsPWildCard))     -> True       +                  _                       -> False       ++-- get the data constructor name.+conName (Dec (HsDataDecl _ _ _ cons _))+  = map conName' cons+conName _ = []++getCons (Dec (HsDataDecl _ _ _ cons _))+  = cons+getCons _ =[]++conName' (HsRecDecl _ _ _ i _) = pNTtoPN i+conName' (HsConDecl _ _ _ i _) = pNTtoPN i++conPNT (Dec (HsDataDecl _ _ _ cons _))+  = map conPNT' cons +  where+    conPNT' (HsRecDecl _ _ _ i _) = i+    conPNT' (HsConDecl _ _ _ i _) = i+-- remove the enclosing parenthesis.+rmPParen p = case p of (Pat (HsPParen p')) -> rmPParen p'+                       _                   -> p+sNtoName (SN i _) = i     ++pNtoVarEnt pn = EntE (Var (PNT pn Value (N (Just loc0))))++-- find the selector associated with the constructor name specified by 'conName' +findSelectors conName allSelectors+  = let r = find (\(x,y)->x==conName) allSelectors +    in if isNothing r  then error $ "Selectors do not exist for data constructor " ++ pNtoName conName+                       else (snd.fromJust) r+-- find the discriminator associated with the constructor name specified by `conName`+findDiscriminator conName allDiscrs+   = let r = find (\(x,y) -> x == conName) allDiscrs+     in if isNothing r then error $ "Discriminator does not exist for data constructor: " ++ pNtoName conName+                       else (snd.fromJust) r++--Collect all the field labels associated with the data declaration.+gatherSelectors::HsDeclP->[(PName,[String])]+gatherSelectors (Dec (HsDataDecl _ _ _ cons _))+  =map selectors cons+  where    -- data constructor decl with field labels+    selectors ((HsRecDecl _ _ _ i ts):: HsConDeclP)+      = (pNTtoPN i, map pNTtoName (concatMap fst ts))+    -- data constructors decl without field labels+    selectors ((HsConDecl _ _ _ i _)::HsConDeclP)+      = (pNTtoPN i, [])++--Collect all the discriminators associated with the data declaration in the current module.+gatherDiscriminators::HsDeclP->HsModuleP->[(PName,String)]+gatherDiscriminators decl mod +  = map (\(x,y)->(x, pNtoName (fromJust y))) $ existingDiscriminators mod decl  ++--Collect all the constructors associated with the data declatation in the current  module.+gatherConstructors::HsDeclP->HsModuleP->[(PName,String)]+gatherConstructors decl mod +  = map (\(x,y) -> (x, pNtoName (fromJust y))) +        $ filter (\(x,y)->isJust y) $ existingConstructors mod decl++resetVal = do  (t,(v,_)) <- get+               put (t, (v,0))++fakeTrueExp  =(Exp (HsId (HsCon (PNT (PN (UnQual "True") (G (PlainModule "Prelude") "True" (N (Just loc0))))+                   (Type blankTypeInfo) (N (Just loc0))))))++fakeTruePat=(Pat (HsPId (HsCon (PNT (PN (UnQual "True") (G (PlainModule "Prelude") "True" (N (Just loc0))))+                   (Type blankTypeInfo) (N (Just loc0))))))++fakeFalseExp =(Exp (HsId (HsCon (PNT (PN (UnQual "False") (G (PlainModule "Prelude") "False" (N (Just loc0))))+                   (Type blankTypeInfo) (N (Just loc0))))))+ +
+ refactorer/RefacAddCon.hs view
@@ -0,0 +1,675 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacAddCon+-- Copyright   :  (c) Christopher Brown 2006+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Add a new constructor to a data type++-----------------------------------------------------------------------------++module RefacAddCon where+ +import PrettyPrint+import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils hiding (getParams)+import PFE0 (findFile)+import MUtils (( # ))+import RefacLocUtils+import System+import IO+import Char++-- | An argument list for a function which of course is a list of paterns.+type FunctionPats = [HsPatP]++-- | A list of declarations used to represent a where or let clause.+type WhereDecls = [HsDeclP]+++alphabet :: String+alphabet = "abcdefghijklmnopqrstuvwxyz"++refacAddCon args+  = do +       let len = length args+       if len > 2 +         then do +            let (first,sec) = splitAt ((length args)-2) args+            let fileName    = first!!0+                ans         = concat ( map ( ++ " ") (tail first))+                row         = read (sec!!0)::Int+                col         = read (sec!!1)::Int+            AbstractIO.putStrLn "refacAddCon"   +            +            -- let modName = convertModName modName1            -- Parse the input file.+            modInfo@(inscps, exps, mod, tokList) <- parseSourceFile (fileName)   +            let res1 = locToPNT fileName (row, col) mod+                res2 = locToPN fileName (row, col) mod+                decs = hsDecls mod+                datDec = definingDecls [res2] decs False True+                datName = (declToName (ghead "datName" datDec))+                datPNT = (declToPNT (ghead "datPNT" datDec))+                 +                 -- add any new type params...++            ((_,m), (newToks, newMod)) <- applyRefac (addField (ghead "applyRefac" datDec) datPNT datName res1 (drop 1 (tail first)) tokList) +                                                     (Just (inscps, exps, mod, tokList)) fileName+       +            writeRefactoredFiles False [((fileName, m), (newToks, newMod))]+                +            (s, col', row', inf) <- doFileStuff fileName row col ans    +            modName1 <- fileNameToModName fileName ++            let modName = convertModName modName1            -- Parse the input file.+            modInfo@(inscps, exps, mod, tokList) <- parseSourceFile (fileName)              +            -- Find the datatype that's been highlighted as the refactree+            +            {- case checkCursor fileName row col mod of+              Left errMsg -> do AbstractIO.removeFile (fileName ++ ".temp.hs")+                                error errMsg+              Right dat ->+                do+                 +                -}+                +            let res' = locToPNT fileName (row, col) mod+                res = pNTtoPN res'   +                 -- Parse the input file.+            AbstractIO.putStrLn ("parsing ..." ++ fileName ++ ".temp.hs")+            modInfo2@(inscps', exps', mod', tokList') <- parseSourceFileOld (fileName ++ ".temp.hs") +            AbstractIO.putStrLn "parsed."                                               +            let decs = hsDecls mod'+                -- datDec = definingDecls [res] decs False True                +                 -- get the list of constructors from the data type+                decs' = hsDecls mod+                datDec'' = definingDecls [res2] decs False True+                datDec' = ghead "datDec'" datDec'' +                -- datName = getDataName [datDec']+                pnames = definedPNs datDec' +                newPN = locToPN (fileName ++ ".temp.hs") (row', col') mod'+                newPNT = locToPNT (fileName ++ ".temp.hs") (row', col') mod'+            numParam <- getParams datDec' newPNT+            let oldPnames = filter (/= newPN) pnames+                position = findPos 0 newPN pnames+                +            ((_,m), (newToks, newMod)) <- applyRefac (addCon (fileName) datName pnames newPN newPNT numParam oldPnames position inf (tail first) modName) +                                                                 (Just (inscps', exps', mod', tokList')) (fileName++"temp.hs")+            writeRefactoredFiles True [((fileName, m), (newToks, newMod))]           +            AbstractIO.removeFile (fileName ++ ".temp.hs")                         +            AbstractIO.putStrLn "Completed.\n"      +         else do+            error "refacAddCon must take a new constructor and a list of arguments."++addField datDec datPNT pnt fName fType tok (_, _, t)+ = do+      newMod <- addTypeVar datDec datPNT pnt fType tok t+      return newMod+      +addingField pnt fName fType t+ = applyTP (stop_tdTP (failTP `adhocTP` inDat)) t+    where+     inDat (dat@(HsConDecl s i c p types)::HsConDeclP)+       | p == pnt = do+                       r <- update dat (HsConDecl s i c p (newTypes types fType)) dat+                       return r+     inDat (dat@(HsRecDecl s i c p types)::HsConDeclP)+       | p == pnt = do+                      r <- update dat (HsRecDecl s i c p (newRecTypes types fName fType)) dat+                      return r    +     inDat _ = fail ""+     +     +     -- newRecTypes must check that the name is not already declared as a field name+     -- within that constructor.+     newRecTypes xs n []  = xs+     newRecTypes xs n (a:as) +       | n `elem` (map pNTtoName (unFlattern xs)) = error "There is already a field declared with that name!"+       | otherwise =  ([nameToPNT n], (HsUnBangedType (Typ (HsTyCon (nameToPNT a))))) : (newRecTypes xs n as)++     unFlattern :: [([a],b)] -> [a]+     unFlattern [] = []+     unFlattern ((xs, y):xss) = xs ++ (unFlattern xss)+                                 ++     newTypes xs [] = xs+     newTypes xs (a:as) = HsUnBangedType (Typ (HsTyCon (nameToPNT a))) : (newTypes xs as)   ++addTypeVar datDec datName pnt fType toks t+ = applyTP (full_buTP (idTP `adhocTP` (inDatDeclaration datDec))) t+    where+      inDatDeclaration _ (dat@(Dec (HsDataDecl a b tp c d))::HsDeclP) +        | (defineLoc datName == (defineLoc.typToPNT.(ghead "inDatDeclaration").flatternTApp) tp) &&+          checkIn fType tp +          = update dat (Dec (HsDataDecl a b (createTypFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) tp) +                                              ( ((map nameToTyp fType') ++ (tail (flatternTApp tp))) )) c d)) dat+            +             where+              fType' = checkInOne2 tp [" "] fType+                                              +      inDatDeclaration (Dec (HsDataDecl _ _ tp _ _)) (dat@(Dec (HsTypeSig s is c t))::HsDeclP) +        | (pNTtoName datName) `elem` (map (pNTtoName.typToPNT) (flatternTApp t) )+          = do+               +               let res = changeType t tp+               if res == t+                 then return dat+                 else update dat (Dec (HsTypeSig s is c res)) dat++      inDatDeclaration _ t = return t+      +      checkIn [] tp = True+      checkIn (fType:fTypes) tp = +       (fType `elem` (map (pNTtoName.typToPNT) (flatternTApp tp))) == False &&+            isLower (ghead "checkIn" fType) || (checkIn fTypes tp)+      +      checkInOne t tp n [] = []+      checkInOne t tp n (f:fs) +        | (f `elem` (map (pNTtoName.typToPNT) (flatternTApp tp))) &&+              isLower (ghead "checkInOne" f) = checkInOne t tp n fs+        | (f `elem` (map (pNTtoName.typToPNT) (flatternTApp t))) &&+              isLower (ghead "checkInOne" f)  = newName : checkInOne t tp (n ++ [newName]) fs+        | (f `elem` (map (pNTtoName.typToPNT) (flatternTApp t))) == False &&+             isLower (ghead "checkInOne" f) = f : (checkInOne t tp n fs)+        | otherwise = checkInOne t tp n fs++            where+              newName = (mkNewName f (n ++ (map (pNTtoName.typToPNT) (flatternTApp tp))) 1)+       +      checkInOne2 tp n [] = []+      checkInOne2 tp n (f:fs) +        | (f `elem` (map (pNTtoName.typToPNT) (flatternTApp tp))) == False &&+             isLower (ghead "checkInOne" f) = f : (checkInOne2 tp n fs)+        | otherwise = checkInOne2 tp n fs +       +        +      changeType :: HsTypeP -> HsTypeP -> HsTypeP+      changeType t@(Typ (HsTyFun t1 t2)) tp+            = (Typ (HsTyFun (changeType t1 tp) (changeType t2 tp)))   +      changeType t@(Typ (HsTyApp (Typ (HsTyCon p)) t2)) tp+        | (defineLoc datName) == (defineLoc p) && +          checkIn fType t +            = createTypFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) t) +                                              ( ((map nameToTyp fType') ++ (tail (flatternTApp t)))) +             where+              fType' = checkInOne t tp [" "] fType+      changeType t@(Typ (HsTyApp t1 t2)) tp+            = (Typ (HsTyApp (changeType t1 tp) (changeType t2 tp)))+      +              -- fType'' = checkNames ftype' t+      changeType t@(Typ (HsTyCon p)) tp+        | (defineLoc datName) == (defineLoc p) && +             checkIn fType t+               = createTypFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) t) +                                              ( ((map nameToTyp fType') ++ (tail (flatternTApp t))))+            where+              fType' = checkInOne t tp [" "] fType+      changeType t tp = t+      +      flatternTApp :: HsTypeP -> [HsTypeP]+      flatternTApp (Typ (HsTyFun t1 t2)) = flatternTApp t1 ++ flatternTApp t2+      flatternTApp (Typ (HsTyApp t1 t2)) = flatternTApp t1 ++ flatternTApp t2+      flatternTApp x = [x]   ++++checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToTypeDecl of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the constructor name!")+     Just decl@(Dec (HsDataDecl loc c tp xs _)) -> Right decl          +   where+    locToTypeDecl = find (definesTypeCon (locToPNT fileName (row, col) mod)) (hsModDecls mod)+    +    -- definesTypeCon pnt (Dec (HsDataDecl loc c tp xs _)) +    --  = isDataCon pnt && (findPNT pnt tp)+    +    definesTypeCon pnt (Dec (HsDataDecl _ _ _ i _))+      = isDataCon pnt && (findPNT pnt i)+    definesTypeCon pnt _ = False++++isDefinedData [] _    = error "Please select the beginning of a constructor!"+isDefinedData ((Dec (HsDataDecl _ _ _ cs i)):ds) c2+ | c2 `myIn` cs = True+ | otherwise  = isDefinedData ds c2+     where+       myIn _ [] = False+       myIn pnt ((HsConDecl _ _ _ i _):cs)+         | pnt == i   = True+         | otherwise  = myIn pnt cs+       myIn pnt ((HsRecDecl _ _ _ i _):cs)+         | pnt == i   = True+         | otherwise  = myIn pnt cs++convertModName (PlainModule s) = s+convertModName m@(MainModule f) = modNameToStr m+++findPos _ _ [] = 0+findPos count newPn (x:xs)+ | newPn == x = count + | otherwise  = findPos (count + 1) newPn xs++getBeforePN _ _ [] = 0            +getBeforePN c newPN (x:xs)+  | newPN /= x = (c + 1) + (getBeforePN (c + 1)newPN xs)+  | otherwise = c      +            +createFun (x:xs) newPN datName+ = Dec ( HsPatBind loc0 (pNtoPat funPName) (HsBody (nameToExp ("error \"added " ++ (concat (map ( ++ " ") (x:xs))) ++ "to " ++ datName ++ "\"") )) [] )+    where funPName= PN (UnQual ("added" ++ x)) (S loc0)++            +getParams (Dec (HsDataDecl _ _ _ cons _)) newPNT+ = numParam cons+     where+       numParam [] = return 0+       numParam (x@(HsConDecl _ _ _ pnt list):cs)+        | newPNT == pnt = do +                             list' <- countCon x+                             return $ length list'+        | otherwise = do x <- numParam cs+                         return x+       numParam (x@(HsRecDecl _ _ _ pnt list):cs)+        | newPNT == pnt = do list' <- countCon' x+                             return $ length list'+        | otherwise = do x <- numParam cs+                         return x++       -- numParam _ = return 0+       +countCon :: (MonadPlus m, Term t) => t -> m [Int]  +countCon co+ = applyTU (full_tdTU (constTU [] `adhocTU` inCon)) co+    where+      inCon a@(HsTyCon _::TI PNT HsTypeP) = return [0]+      inCon a@(HsTyVar _::TI PNT HsTypeP) = return [0]+      inCon _ = return []++countCon' :: (MonadPlus m, Term t) => t -> m [Int]+countCon' co+ = applyTU (full_tdTU (constTU [] `adhocTU` inCon)) co+    where+      inCon a@((x, _)::([PNT], HsBangType HsTypeP)) = return $ replicate (length x) 0+      -- inCon _ = return []+      +       +addCon fileName datName pnames newPn newPNT numParam oldPnames  position inf xs modName (inscps, exps, mod)+ = do+      newMod <- addDecl mod Nothing ([createFun xs newPn datName], Nothing) True+      -- unsafePerformIO.putStrLn $ show newMod+      res <- findFuncs fileName datName newMod pnames newPn newPNT numParam oldPnames position inf xs modName+      +   --   res2 <- findPatterns ses datName res pnames newPn newPNT numParam oldPnames position inf xs+      +      return res+      +getPNs (Dec (HsFunBind _ (m:ms) ))+ = checkMatch (m:ms)+    where checkMatch [] = []+          checkMatch ((HsMatch _ _ (p:ps) _ _):ms)+            | (getPN p) /= defaultPN = (getPN p) : checkMatch ms+            | otherwise = checkMatch ms+            +getPNPats (Exp (HsCase e pats))+ = checkAlt pats+    where checkAlt [] = []+          checkAlt ((HsAlt loc p e2 ds):ps)+            | p /= (Pat HsPWildCard) = (getPN p) : checkAlt ps+            | otherwise = checkAlt ps +            +getPN p + = fromMaybe (defaultPN)+             (applyTU (once_tdTU (failTU `adhocTU` inPat)) p)+             +    where+      inPat (pat::PName)+       = Just pat+      -- inPat _ = Nothing+ +findPosBefore newPN [] = []+findPosBefore newPN (x:[]) = [x]+findPosBefore newPN (x:y:ys)+ | newPN == y = [x]+ | otherwise  = findPosBefore newPN (y:ys)+++findFuncs fileName datName t pnames newPn newPNT numParam oldPnames position inf (x:xs) modName+  =  applyTP (stop_tdTP (failTP `adhocTP` inFun)) t+    where+    inFun dec1 +        = do+            (pat, exp1) <- findCase dec1 modName+            if pat /= False+             then do +                    let altPNs = getPNPats exp1+                    if oldPnames /= altPNs+                     then do+                      let posBefore = findPosBefore newPn pnames+                      update exp1 (newPat3 exp1 (head posBefore)) dec1+                     else do+                      update exp1 (newPat2 exp1) dec1    +        +             else +              do ((match,arity), patar) <- findFun dec1 modName+                 if match == False +                   then do  --error "not found"+                       fail ""+                   else +                     do  let funPNs = getPNs dec1+                         if oldPnames /= funPNs +                           then do+                            let posBefore = findPosBefore newPn pnames+                            if length posBefore > 1+                             then do+                              update dec1 (newMatch3 dec1 (head posBefore) arity patar) dec1+                             else do+                              update dec1 (newMatch dec1 arity patar) dec1+                           else do+                           update dec1 (newMatch2 dec1 arity patar) dec1+                       where+                        newMatch (Dec (HsFunBind loc1 matches@((HsMatch _ pnt p e ds):ms)))  arity patar+                          =  Dec (HsFunBind loc1 (newMatches matches pnt arity patar (length p)))  +                          +                        newMatch2 (Dec (HsFunBind loc1 matches@((HsMatch _ pnt p e ds):ms) )) arity patar+                          = Dec (HsFunBind loc1 (fst ++ (newMatch' pnt arity patar(length p)) ++ snd) )+                            where +                              (fst, snd) = splitAt position matches+                              +                        newMatch3 (Dec (HsFunBind loc1 matches@((HsMatch _ pnt p e ds):ms))) posBefore arity patar+                          = Dec (HsFunBind loc1 (newMatches' matches pnt posBefore arity patar (length p)))+                                       +                                                                         +                        newMatches [] pnt position arity patar = newMatch' pnt position arity patar+                        newMatches (m@(HsMatch _ _ pats _ _):ms) pnt position arity patar+                         | or (map wildOrID pats) = (newMatch' pnt position arity patar) ++ (m : ms)+                         | otherwise                     = m : (newMatches ms pnt position arity patar)++                        newMatches' [] pnt posBefore position arity patar = newMatch' pnt position arity patar+                        newMatches' (m@(HsMatch _ _ pats _ _):ms) pnt posBefore position arity patar+                         | (getPN pats) == posBefore = m : ((newMatch' pnt position arity patar) ++ ms)+                         | or (map wildOrID pats) = (newMatch' pnt position arity patar) ++ (m : ms)+      --                   | (TiDecorate.Pat HsPWildCard) `elem` pats = (newMatch' pnt) ++ (m : ms)+                         | otherwise      = m : (newMatches' ms pnt posBefore position arity patar)                                       +                                       +                        newMatch' pnt arity  patar position+                  --       | numParam == 0  =  [HsMatch loc0 pnt [pNtoPat newPn] (HsBody (nameToExp ("added" ++ x))) []  ]+                          = createMatch arity ['a'..'z'] patar+                            where+                              createMatch arity alpha patar +                               | elem 1 arity+                                   = (HsMatch loc0 pnt (createPat arity patar alpha) (HsBody (nameToExp ("added" ++ x))) []) : (createMatch (mutatearity arity) alpha patar)+                               | otherwise = []++                              mutatearity [] = []+                              mutatearity (x:xs) +                               | x == 1 = 0 : xs+                               | otherwise = x : (mutatearity xs)++                              createPat [] _ alpha= []+                              createPat (x:xs) ((y,n):ys) alpha+                               | x == 1    =  newPatt' : (createPat (replicate (length xs) 0) ys ((res4')))+                               | elem 1 y  = (conApps n) : (createPat xs ys (res3))+                               | otherwise = (createNames 1 alpha) ++ (createPat xs ys (tail alpha))+                                  where+                                    (_, res2) = splitAt numParam alpha+                                    conApps n = conApp y alpha n+                                    (_, res3) = splitAt ((myLength (conApps n)) * numParam -1) alpha+                                    +                                    (_, res4') = splitAt ((myLength newPatt') ) alpha+                                    newPatt' = patt alpha+                                    +                                    patt alpha +                                     | inf == False = (Pat (HsPParen (Pat (HsPApp newPNT (createNames numParam alpha))))::HsPatP)+                                     | otherwise    = (Pat (HsPInfixApp (nameToPat [alpha!!0]) newPNT (nameToPat [alpha!!1]))::HsPatP)+                                     +                                    conApp xs alpha name+                                      = (Pat (HsPParen (Pat (HsPApp (nameToPNT name) (createPats xs alpha)))))+                                      +                                    myLength (Pat (HsPParen (Pat (HsPApp _ xs)))) = length xs+                                    myLength _ = 0  +                                                                        +                                    +                                    createPats [] alpha = []  +                                    createPats (x:xs) alpha+                                     | x == 1 = newPatt : (createPats xs (res4))+                                     | otherwise = (createNames 1 alpha) ++ (createPats xs (tail alpha))+                                        where+                                         (_, res4) = splitAt ((myLength newPatt)) alpha+                                         newPatt = patt alpha+                                    +                                    createNames 0 _ = []+                                    createNames count (x:xs)+                                     = (nameToPat [x]) : (createNames (count-1) xs)+                                          +                        newPat (Exp (HsCase e pats@((HsAlt loc p e2 ds):ps)))+                          = Exp (HsCase e (newPats pats))+                     +                        newPat2 (Exp (HsCase e pats))+                          = Exp (HsCase e (fst ++ newPat' ++ snd))+                             where+                              (fst, snd) = splitAt position pats+                                       + +                        newPat3 (Exp (HsCase e pats)) posBefore+                          = Exp (HsCase e (newPats' pats posBefore))+                     +                        newPats [] = newPat'+                        newPats(pa@(HsAlt _ p _ _):ps)+                         | wildOrID p = newPat' ++ (pa:ps)+                         | otherwise              = pa : (newPats ps)+                     +                        newPats' [] posBefore = newPat'+                        newPats' (pa@(HsAlt _ p _ _):ps) posBefore+                         | (getPN p) == posBefore = pa : (newPat' ++ ps)+                         | wildOrID p = newPat' ++ (pa:ps)+                         | otherwise = pa : (newPats' ps posBefore)++                     +                        newPat' +                         | numParam == 0 = [HsAlt loc0 (pNtoPat newPn) (HsBody (nameToExp ("added" ++ x))) [] ]+                         | otherwise = [HsAlt loc0 patt (HsBody (nameToExp ("added" ++ x))) []]+                            where+                             patt +                              | inf == False = (Pat (HsPParen (Pat (HsPApp newPNT  (createNames numParam ['a'..'z']))))::HsPatP)+                              | otherwise    = (Pat (HsPInfixApp (nameToPat "a") newPNT (nameToPat "b"))::HsPatP)++                             createNames 0 _ = []+                             createNames count (x:xs)+                               = (nameToPat [x]) : (createNames (count-1) xs)++      --The selected sub-expression is in the argument list of a match+      --and the function only takes 1 parameter+    findFun dec@(Dec (HsFunBind loc matches)::HsDeclP) modName+        =  return $ findMatch matches+           where findMatch match +                   = fromMaybe ((False, []), [([], "")])+                      (applyTU (once_tdTU (failTU `adhocTU` inMatch)) match)+                 inMatch (mat@(HsMatch loc1  pnt pats (HsBody e) ds)::HsMatchP)+                  = do+                       let (_, y) = checkTypesInPat datName pats modName fileName+                      -- error $ show y+                       Just ((checkTypes2 datName (pNTtoName pnt) modName fileName), y)+                 inMatch x@(_) = Nothing++    findFun a@(_) _ = return ((False, []), [([], "")])+      +    findCase dec@(Dec (HsFunBind loc matches)::HsDeclP) modName+        = return (findExp matches)+           where findExp alt+                  = fromMaybe ((False, defaultExp))+                     (applyTU (once_tdTU (failTU `adhocTU` inExp)) alt)+                 inExp (exp@(Exp e)::HsExpP)+                  = Just ((findPat e), exp)  +                  +                  where                      +                   findPat alt+                    = fromMaybe (False)+                      (applyTU (once_tdTU (failTU `adhocTU` inPat)) alt)+                   inPat (pat@(HsAlt loc (Pat (HsPId (HsCon p))) e ds)::HsAltP)+                     = (Just (checkTypes datName (pNTtoName p) modName fileName))+                   inPat e -- (pat@(HsAlt loc (Pat (HsPId (HsVar _))) e ds)::HsAltP)+                     = do+                         case exp of+                          Exp (HsCase (Exp (HsId (HsVar x))) alts)+                                                            -> do+                                                                 -- find where p is defined, and get the type+                                                                 let decs = hsDecls t+                                                                 -- error ( show (pNTtoPN x))+                                                                 let y = definingDecls [(pNTtoPN x)] decs False True+                                                                 -- error $ show y+                                                                 if length y /= 0+                                                                  then do +                                                                   let b = definedPNs (head y)+                                                                   Just (checkTypes datName (pNtoName (head b)) modName fileName)+                                                                  else  Nothing+                          _ -> Nothing+                   -- inPat e = error (show e) -- Nothing   +                 -- inExp _ = Nothing           +    findCase pat@(_) _ =  return (False, defaultExp)+flatternPat :: HsPatP -> [HsPatP] +flatternPat (Pat (HsPAsPat i p)) = flatternPat p+flatternPat (Pat (HsPApp i p)) = (Pat (HsPId (HsCon i))) : (concatMap flatternPat p)+flatternPat (Pat (HsPTuple _ p)) = p+flatternPat (Pat (HsPList _ p)) = p+flatternPat (Pat (HsPInfixApp p1 i p2)) = (flatternPat p1) ++ (flatternPat p2)+flatternPat (Pat (HsPParen p)) = flatternPat p+flatternPat p@(Pat (HsPId i)) = [p]+flatternPat p = [p] ++wildOrID (Pat HsPWildCard) = True+wildOrID (Pat (HsPId (HsVar x))) = True+wildOrID _ = False++doFileStuff fileName r c a = do+    s <- AbstractIO.readFile fileName+    +    -- get the first half of the file (up to point user has selected)+    let rev = reverse (returnHalf r c (1,1) s)+    let rest = returnSndHalf r c (1,1) s+    let str = parseIt rest a+    let str' = parseIt' rest a       +    let len = length (myDiff s str')    +    let (st, fin) = splitAt len s+    let new = st ++ str ++ fin   +    let extraCol = parseTick 0 str+    let (col, row) = getRowCol r c (1,1) st+          +    -- Check that the file does not already exist first         +    -- or else it will lead into strange errors...+    AbstractIO.catch (AbstractIO.writeFile (fileName ++ ".temp.hs") new)+                      (\_ -> do AbstractIO.removeFile (fileName ++ ".temp.hs")+                                AbstractIO.writeFile (fileName ++ ".temp.hs") new)+    +    if '`' `elem` a +      then do return (new, col + extraCol, row, True)+      else do return (new, col + extraCol, row, False)+ +-- function to parse to see if user is placing contructor at the beginning or end of statement...   +-- if the user has selected a ' ' or a character+-- parse forwards (which is really backwards) until a '|' or a '=' character is found+parseTick _ [] = 3+parseTick count (x:xs)+ | x == '`' = count + 1+ | otherwise = parseTick (count+1) xs+++myDiff :: String -> String -> String+myDiff [] _ = []+myDiff (y:ys) (x:xs) + | (y:ys) == (x:xs) = ""+ | otherwise = y : (myDiff ys (x:xs))+ +parseIt :: String -> String -> String+parseIt "" str = error "Please select a position on the right hand side of the data type."+parseIt (x:xs) str + | x == '\n' || x == '|' = " | " ++ str ++ " "+ | x /= '\n' || x /= '|' = parseIt xs str+ | otherwise            = " | " ++ str ++ " "+ +parseIt' :: String -> String -> String+parseIt' "" str = ""+parseIt' (x:xs) str+ | x == '\n' || x == '|' = (x:xs)+ | x /= '\n' || x /= '|' = parseIt' xs str+ | otherwise             = (x:xs)++                                 +-- perform some primitve parsing. We need to check where abouts the user wants+-- to add the data structure: +-- a) if the it is at the beginning - we need to check that the+--    use has selected at the end of a "=" sign -- if this is the case append "|" to the end+--    of the user string;+-- b) if a "=" does not proceed the position - append a "|" to the end+--+-- we do not need to check for any other cases as Programatica will pick up the errors+-- (if the position of adding the constructor is invalid, for example.)++-- function to return the half of the file that comes before the user position+returnHalf r c (col, row) "" = ""+returnHalf r c (col, row) (x:xs) +  | x == '\n' = if (r == row) && (c == col)   then [x]+                                              else x : (returnHalf r c (1, row+1) xs)+  | otherwise = if c == col && (r == row)     then [x]+                                              else x : (returnHalf r c (col+1, row) xs)+                                              +returnSndHalf r c (col, row) "" = ""+returnSndHalf r c (col, row) (x:xs) +  | x == '\n' = if (r == row) && (c == col)   then xs+                                              else (returnSndHalf r c (1, row+1) xs)+  | otherwise = if c == col && (r == row)     then xs+                                              else (returnSndHalf r c (col+1, row) xs)                                       +                                           +getRowCol r c (col, row) "" = (col, row)+getRowCol r c (col, row) (x:xs) + | x == '\n' = getRowCol r c (1, row+1) xs+ | otherwise = getRowCol r c (col+1, row) xs+++{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> [HsConDeclP]  -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+                     +findDefNameAndExp toks beginPos endPos t+  = fromMaybe ([])+              (applyTU (once_tdTU (failTU `adhocTU` inData)) t)+    where+      --The selected sub-expression is the rhs of a data type+      inData (dat@(HsConDecl loc1 is con i xs)::HsConDeclP)+       = error (show res) +            where +               res = pNtoExp (pNTtoPN i)+      inData _ = Nothing++++                    +
+ refactorer/RefacAddField.hs view
@@ -0,0 +1,257 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacAddField+-- Copyright   :  (c) Christopher Brown 2007+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Add a field to a constructor and resolve+-- pattern matching by placing references to said+-- field by calls to error; also resolves type signatures (by making them+-- more general if necessary).++-----------------------------------------------------------------------------++module RefacAddField where+ +import PrettyPrint+import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils hiding (getParams)+import PFE0 (findFile)+import MUtils (( # ))+import RefacLocUtils+import System+import IO+import Char++refacAddField args+  = do+       when (length args /= 5) (error "Please enter a field name ( _ to omit) and a field type!")+       let +           fileName    = args!!0+           fName       = args!!1+           fType       = args!!2+           row         = read (args!!3)::Int+           col         = read (args!!4)::Int++       AbstractIO.putStrLn "refacAddField"+        +       modInfo@(inscps, exps, mod, tokList) <- parseSourceFile (fileName)+       case checkCursor fileName row col mod of+         Left errMsg -> do error errMsg+         Right dat ->+            do+             let res = locToPNT fileName (row, col) mod+             let res2 = locToPN fileName (row, col) mod+             let decs = hsDecls mod+       +             let datDec = definingDecls [res2] decs False True+              +             let datName = (declToName (head datDec))+       +             let datPNT = (declToPNT (head datDec))+       +             -- if the field in question is a record we must get+             -- the name of the record...++             ((_,m), (newToks, newMod)) <- applyRefac (addField datPNT datName res fName fType tokList) +                                                     (Just (inscps, exps, mod, tokList)) fileName+       +             writeRefactoredFiles False [((fileName, m), (newToks, newMod))]++             AbstractIO.putStrLn "Completed.\n"++checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToTypeDecl of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the constructor name!")+     Just decl@(Dec (HsDataDecl loc c tp xs _)) -> Right decl          +   where+    locToTypeDecl = find (definesTypeCon (locToPNT fileName (row, col) mod)) (hsModDecls mod)+    +    -- definesTypeCon pnt (Dec (HsDataDecl loc c tp xs _)) +    --  = isDataCon pnt && (findPNT pnt tp)+    +    definesTypeCon pnt (Dec (HsDataDecl _ _ _ i _))+      = isDataCon pnt && (findPNT pnt i)+    definesTypeCon pnt _ = False+++++getRecordName (Dec (HsDataDecl s c tp recs i)) pos+  = getRecordName' recs pos 1+      where+        getRecordName' :: [HsConDeclP] -> Int -> Int -> PNT+        getRecordName' ((HsRecDecl _ _ _ _ recs):cons) pos n+         = getRecordName'' recs pos n+      +      +        getRecordName'' :: [ ([PNT], HsBangType t)] -> Int -> Int -> PNT+        getRecordName'' [] _ _ = error "Not a valid field position!"+        getRecordName'' (([], _): types) pos n+          = getRecordName'' types pos n+        getRecordName'' ( ((l:ls), t) :types) pos n+         | pos == n   = error $ show l +         | otherwise  = getRecordName'' ((ls, t):types) pos (n+1)+   +addField datPNT datName pnt fName fType tok (_, _, t)+ = do+      newMod <- addingField pnt fName fType t+      newMod' <- addingFieldInPat datName pnt fType tok newMod+      newMod'' <- addTypeVar datPNT pnt fType tok newMod+      return newMod''++addTypeVar datName pnt fType toks t+ = applyTP (full_buTP (idTP `adhocTP` inDatDeclaration)) t+    where+      inDatDeclaration (dat@(Dec (HsDataDecl a b tp c d))::HsDeclP)+        | (defineLoc datName == (defineLoc.typToPNT.(ghead "inDatDeclaration").flatternTApp) tp) &&+            (fType `elem` (map (pNTtoName.typToPNT) (flatternTApp tp))) == False &&+            isLower (head fType)   +          = update dat (Dec (HsDataDecl a b (createTypFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) tp) +                                              ( ((nameToTyp fType) : (tail (flatternTApp tp))) )) c d)) dat+                                              +      inDatDeclaration (dat@(Dec (HsTypeSig s is c t))::HsDeclP) +       | (pNTtoName datName) `elem` (map (pNTtoName.typToPNT) (flatternTApp t) )+          = do+               let res = changeType t+               if res == t+                 then return dat+                 else update dat (Dec (HsTypeSig s is c res)) dat++      inDatDeclaration  t = return t+        +      changeType :: HsTypeP -> HsTypeP+      changeType t@(Typ (HsTyFun t1 t2)) +            = (Typ (HsTyFun (changeType t1) (changeType t2)))   ++      changeType t@(Typ (HsTyApp (Typ (HsTyCon p)) t2))+        | (defineLoc datName) == (defineLoc p) && +          (fType `elem` (map (pNTtoName.typToPNT) (flatternTApp t))) == False &&+            isLower (head fType) +            = (createTypFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) t) +                                              ( ((nameToTyp fType) : (tail (flatternTApp t)))))+      changeType t = t+      +      flatternTApp :: HsTypeP -> [HsTypeP]+      flatternTApp (Typ (HsTyFun t1 t2)) = flatternTApp t1 ++ flatternTApp t2+      flatternTApp (Typ (HsTyApp t1 t2)) = flatternTApp t1 ++ flatternTApp t2+      flatternTApp x = [x]   ++addingField pnt fName fType t+ = applyTP (stop_tdTP (failTP `adhocTP` inDat)) t+    where+     inDat (dat@(HsConDecl s i c p types)::HsConDeclP)+       | p == pnt = do+                       r <- update dat (HsConDecl s i c p (newTypes types fType)) dat+                       return r+     inDat (dat@(HsRecDecl s i c p types)::HsConDeclP)+       | p == pnt = do+                      r <- update dat (HsRecDecl s i c p (newRecTypes types fName fType)) dat+                      return r    +     inDat _ = fail ""+     +     +     -- newRecTypes must check that the name is not already declared as a field name+     -- within that constructor.+     newRecTypes xs n a +       | n `elem` (map pNTtoName (unFlattern xs)) = error "There is already a field declared with that name!"+       | otherwise =  ([nameToPNT n], (HsUnBangedType (Typ (HsTyCon (nameToPNT a))))) : xs++     unFlattern :: [([a],b)] -> [a]+     unFlattern [] = []+     unFlattern ((xs, y):xss) = xs ++ (unFlattern xss)+                                 ++     newTypes xs a = HsUnBangedType (Typ (HsTyCon (nameToPNT a))) : xs   ++addingFieldInPat datName pnt fType tok t+ = applyTP (stop_tdTP (failTP `adhocTP` inPat)) t+      where+        inPat d@(Dec _::HsDeclP)+          = do+               d'  <- checkPat1 pnt pos d+               d'' <- checkCall pnt pos d'+               return d'+                 where+                    -- checkPat :: (Term t) => PNT -> String -> t -> HsPatP+                    checkPat1 pnt pos t+                      = applyTP (full_buTP (idTP `adhocTP` inP)) t+                    inP pat@(Pat (HsPApp i p)) +                      | (defineLoc i) == (defineLoc pnt) =  update pat (Pat (HsPApp i ([nameToPat newName] ++ p))) pat+                      -- RefacUtils.delete (p !! ((read pos::Int)-1)) pat+                    inP x =  return x+                         +                    newName = mkNewName (nameLowered (pNTtoName pnt)) (map pNtoName (definedPNs d)) 1     +                                                +                    nameLowered (x:xs) = toLower x : xs                           +                                                +                    checkCall pnt pos t+                      = applyTP (stop_tdTP (failTP `adhocTP` conApp)) t+                    -- a constructor application...+                    conApp exp@(Exp (HsApp e1 e2))+                      | defineLoc pnt == (defineLoc.expToPNT.(ghead "inE").flatternApp) exp+                        = update exp (createFuncFromPat ((expToPNT.(ghead "inE").flatternApp) exp) +                                     ([nameToExp "undefined"] ++ ( (tail.flatternApp) exp) )) exp+                      +                    conApp _ = mzero                    +                     +                    flatternApp :: HsExpP -> [HsExpP]+                    flatternApp (Exp (HsApp e1 e2)) = flatternApp e1 ++ flatternApp e2+                    flatternApp x = [x] +                    +                    (!-) :: Int -> Int -> [a] -> [a]+                    (!-) _ _ [] = []+                    (!-) n pos (x:xs)+                     | n == pos  = xs+                     | otherwise = x : (!-) n (pos + 1) xs+                                         +                    newPats :: [HsPatP] -> Int -> Int -> [HsPatP]+                    newPats (p:ps) pos n+                     | n == pos  = ps+                     | otherwise = p : (newPats ps pos (n+1)) +        -- inPat x = fail ""++checkPat2 datName pnt pos t+ = applyTP (stop_tdTP (failTP `adhocTP` inPat)) t+      where+        inPat d@(Dec _::HsDeclP)+          = do+               d'' <- addCall (declToName d) pnt pos d+               return d''+        addCall funcName pnt pos t+          = applyTP (stop_tdTP (failTP `adhocTP` (inE funcName))) t +      +        -- a name associated to a pattern binding somewhere...  +        inE funcName exp@(Exp (HsId (HsVar x)))+          | (findPatBind pnt x (read pos::Int) t) +              = update exp  (Exp (HsApp (Exp  (HsApp  (Exp (HsApp (nameToExp ("error" ++ datName)) +                                                                  (nameToExp ("\"" ++ (pNTtoName x) ++ "\""))))+                                                      (nameToExp ("\"" ++ (pNTtoName pnt) ++ "\""))))+                                        (nameToExp ("\"" ++ funcName ++ "\"")))) exp+        inE _ x = mzero++findPatBind :: (Term t) => PNT -> PNT -> Int -> t -> Bool+findPatBind pnt x pos+   = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inBind)))+        where             +           inBind (dat@(Pat (HsPApp i types))::HsPatP)+              | pnt == i && checkInTypes x (types!!(pos-1)) = Just True+           inBind _ = Nothing  +           checkInTypes x (Pat (HsPId (HsVar typePnt)))+            |  defineLoc x == defineLoc typePnt = True+           checkInTypes _ x = False++-- thePNT id = (PNT (PN (UnQual id) (G (PlainModule "unknown") id (N (Just loc0)))) (Type (TypeInfo (Just Primitive) [] []))  (N (Just loc0)))
+ refactorer/RefacAddRmParam.hs view
@@ -0,0 +1,420 @@+++module RefacAddRmParam(addOneParameter,rmOneParameter) where++import PosSyntax+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT +import TiPNT ++import Maybe+import List hiding (delete)+import RefacUtils+import Char++-----------------------------------------------------------------------------------------------------+{- An argument can be added to the definition of a function or constant. Adding an argument to a constant +   definition will change the constant definition to a function definition.  The new parameter is always+   added as the first parameter of the function. A default parameter will be added as the first argument+   to each of the function's call site. Suppose a new  parameter named 'p' is added to function 'f',+   then default parameter will be defined automatically as p_f_i=undefined, where 'i' is an integer.+   To ensure that the default parameter name does not cause name clash in the client modules, we take the+   visble names both in the current module and in the client modules into account when creating the+   name. ++-}+----------------------------------------------------------------------------------------------------- +addOneParameter args+ = let fileName = args!!0+       paramName= args!!1          +       row      = read (args!!2)::Int+       col      = read (args!!3)::Int+   in if isVarId paramName+      then do modName <-fileNameToModName fileName  +              (inscps, exps, mod, tokList)<-parseSourceFile fileName  +              let pnt@(PNT pn _ _)=locToPNT fileName  (row, col) mod+              --make sure this name is defined in this module+              if pn /= defaultPN && isFunOrPatName pn mod+               then if isExported pnt exps+                    then do clients <- clientModsAndFiles modName+                            info    <- mapM parseSourceFile $ map snd  clients         +                            defaultArg <-mkTopLevelDefaultArgName pn paramName fileName modName +                                            ( map (\(x, _,_,_)->x) (concatMap inScopeInfo (map myfst info))) (hsDecls mod)+                            (mod',((ts',m), _))<-doAddingParam fileName  modName pn paramName +                                                    (Just defaultArg) True  mod tokList   +                            refactoredClients<-mapM (addArgInClientMod pnt defaultArg modName) $ zip info (map snd clients)+                            writeRefactoredFiles False $ ((fileName,m),(ts',mod')):refactoredClients+                    else do (mod',((ts',m),_))<-doAddingParam fileName  modName pn paramName Nothing  False mod tokList +                            writeRefactoredFiles False [((fileName,m),(ts',mod'))]                               +               else error "Invalid cursor position or identifier is not a function/pattern name defined in this module!\n"+      else error "Invalid parameter name!\n"++doAddingParam fileName modName pn newParam defaultArg isExported mod tokList  +    =  runStateT (applyTP (once_tdTP (failTP `adhocTP` inMod+                                             `adhocTP` inMatch+                                             `adhocTP` inPat+                                             `adhocTP` inLet+                                             `adhocTP` inAlt+                                             `adhocTP` inLetStmt)+                           `choiceTP` failure) mod) ((tokList,unmodified),(-1000,0))+      where+             --1.pn is declared in top level+             inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)  +               | definingDecls [pn] ds False  False/=[]  +               = do mod'<-doAdding mod  ds   +                    if isExported && isExplicitlyExported pn mod+                      then addItemsToExport mod' (Just pn) False (Left [pNtoName (fromJust defaultArg)])+                      else return mod' +                            +             inMod _ = mzero +           +             --2. pn is declared locally in the where clause of a match.+             inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+               | definingDecls [pn] ds False  False/=[]  = doAdding match  ds                                                +             inMatch _ = mzero++             --3. pn is declared locally in the where clause of a pattern binding.+             inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+               | definingDecls [pn] ds False  False/=[]  = doAdding pat  ds                  +             inPat _ = mzero+  +             --4: pn is declared locally in a  Let expression+             inLet (letExp@(Exp (HsLet ds e))::HsExpP)+               | definingDecls [pn] ds False False /=[] = doAdding letExp  ds +             inLet _ = mzero+                +             --5. pn is declared locally in a  case alternative.+             inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+               | definingDecls [pn] ds False  False/=[] = doAdding  alt  ds +             inAlt _ = mzero+      +             --6.pn is declared locally in a let statement.+             inLetStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP)+               | definingDecls [pn] ds False  False/=[]  = doAdding letStmt ds +             inLetStmt _ = mzero+            +             failure = idTP `adhocTP` mod+               where mod (m::HsModuleP) = error "Refactoring failed"+ +             doAdding parent ds  +               = if paramNameOk pn newParam ds+                   then +                    do ds' <- addParamsToDecls ds pn [nameToPN newParam] True  --addFormalParam pn newParam ds+                       defaultParamPName <-if isNothing defaultArg+                                           then mkLocalDefaultArgName pn newParam modName parent                +                                           else return (fromJust defaultArg)+                       parent' <- addDefaultActualArg False pn defaultParamPName (replaceDecls parent ds')+                       parent''<- addDefaultActualArgDecl defaultParamPName  parent' pn isExported +                       ds'' <- addArgToSig pn (hsDecls parent'')+                       return (replaceDecls parent'' ds'')+                   else error " Refactoring failed." +                    +         +-- check whether the new parameter is a legal.+                        +paramNameOk pn newParam t = (fromMaybe True) (applyTU (once_tdTU (failTU `adhocTU` decl)) t) +  where+   decl ((Dec (HsFunBind _ matches@((HsMatch _ fun pats rhs ds):ms)))::HsDeclP)+    | pNTtoPN fun == pn+    = do results'<-mapM checkInMatch matches+         Just (all (==True) results')+   decl pat@(Dec (HsPatBind loc p rhs ds))+    | patToPN p == pn    +    = do (f,d) <- hsFDNamesFromInside pat+         if elem newParam (f `union` d)+            then  error "The new parameter name will cause name clash or semantics change, please select another name!"+            else Just True+   decl (Dec (HsPatBind _ p _ _))+     | patToPN p /= pn && elem pn (hsPNs p)+      = error "Parameter can not be added to complex pattern binding" +   decl _=mzero ++   checkInMatch match+     = do (f,d) <- hsFDNamesFromInside match+          if elem newParam (f `union` d)+           then error "The new parameter name will cause name clash or semantics change, please choose another name!"+           else return True++--add the default argument declaration right after the declaration defining pn+addDefaultActualArgDecl defaultParamPName parent pn isExported+   =if not (findEntity pn parent) && not isExported+      then return parent               +      else addDecl parent (Just pn) (defaultArgDecl,Nothing) True+   where+      defaultArgDecl= [Dec (HsPatBind loc0 (nameToPat (pNtoName defaultParamPName))(HsBody (nameToExp "undefined"))[])]+ +--suppose function name is f, parameter name is p, then the default argument name is like f_p.    +mkLocalDefaultArgName fun paramName modName t+ =do (f,d)<-hsFDNamesFromInside t  +     vs<-hsVisibleNames fun t+     let name=mkNewName ((pNtoName fun)++"_"++paramName) (nub (f `union` d `union` vs)) 0 +     return (PN (UnQual name) (S loc0))+       +mkTopLevelDefaultArgName fun paramName fileName modName inscopeNames t+ =do (f,d)<-hsFDNamesFromInside t  +     let name=mkNewName ((pNtoName fun)++"_"++paramName) (nub (f `union` d `union` inscopeNames)) 0 +     let loc =  SrcLoc fileName 0 (-1000) (-1000)+     return (PN (UnQual name) (G modName name (N (Just loc))))+   +   +addDefaultActualArg recursion pn argPName+        = if recursion then applyTP (stop_tdTP (failTP `adhocTP` funApp))+                       else applyTP (stop_tdTP (failTP `adhocTP` inDecl+                                                       `adhocTP` funApp))+       where +         inDecl (fun@(Dec (HsFunBind _  ((HsMatch _ (PNT pname _ _) _ _ _):ms)))::HsDeclP)+           | pn == pname +           = return fun++         inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+           | pn == patToPN  ps+           = return pat             +         inDecl _ = mzero+     +         funApp (exp@(Exp (HsId (HsVar (PNT pname _ _))))::HsExpP)+          |pname==pn+           = update exp (Exp (HsParen (Exp (HsApp exp (pNtoExp argPName))))) exp+                               +         funApp _ = mzero++--Add type arg to type siginature +addArgToSig pn decls+   = let (before,after)=break (\d ->definesTypeSig pn d) decls+     in if  after==[] +       then  return decls+       else  do newSig<-addArgToSig' [(head after)]  --no problem with head.   +                return (before++newSig++(tail after))++    where+       addArgToSig' sig@[(Dec (HsTypeSig loc is c tp))]+          =do let tVar=mkNewTypeVarName sig+                  typeVar=newTypeVar tVar tp+              let newSig=if length is==1+                           then  --the type sig only defines the type for pn+                                [Dec (HsTypeSig loc is c typeVar)]  +                           else  --otherwise, seperate it into two type signatures.+                               [Dec (HsTypeSig loc (filter (\x->pNTtoPN x/=pn) is) c tp),  +                                Dec (HsTypeSig loc (filter (\x->pNTtoPN x==pn) is) c typeVar)]+              update sig newSig sig                +     +       --compose a type application using type expressions tv and tp +       newTypeVar tVar tp+         =(Typ (HsTyFun (Typ (HsTyVar (PNT (PN (UnQual tVar) (S loc0))+           (Type (TypeInfo {defType=Nothing, constructors=[], fields=[]})) (N (Just loc0))))) tp))++       {- make a fresh type variable name. the new name is the first letter in the alphabet which is not+          used in the type signature. -}+       mkNewTypeVarName sig +          =mkNewName "a" $ map pNtoName $ (snd.hsTypeVbls) sig+             where mkNewName initName v+                     =if elem initName v+                         then mkNewName ((intToDigit (digitToInt(head initName)+1)):tail initName) v+                         else initName               ++addArgInClientMod pnt defaultArg  serverModName ((inscps, exps, mod,ts), fileName)+ = let qual = hsQualifier pnt inscps+       pn = pNTtoPN pnt+   in if qual == []+          then return ((fileName,unmodified), (ts,mod))+          else do (mod',((ts',m), _))<-+                      runStateT (do mod'<-addItemsToImport serverModName  (Just pn) (Left [pNtoName defaultArg]) mod+                                    mod''<-addItemsToExport mod (Just pn) False (Left [pNtoName defaultArg])+                                    if isInScopeAndUnqualified (pNtoName pn) inscps+                                       then addDefaultActualArgInClientMod  pn  (head qual) defaultArg False mod''+                                       else addDefaultActualArgInClientMod  pn  (head qual) defaultArg True  mod'')+                          ((ts,unmodified), (-1000,0))+                  return ((fileName,m),(ts',mod'))  ++            +--add default actual argument to pn in all the calling places.            +addDefaultActualArgInClientMod pn qual argPName toBeQualified t+   = applyTP (stop_tdTP (failTP `adhocTP` funApp)) t+  where +    funApp (exp@(Exp (HsId (HsVar pnt@(PNT pname _ _))))::HsExpP)+      | pname == pn +       = do vs <- hsVisibleNames pnt t +            let argExp=if toBeQualified || elem (pNtoName argPName) vs+                         then pNtoExp (qualifyPName qual argPName)+                         else pNtoExp argPName+                newExp =(Exp (HsParen (Exp (HsApp exp argExp))))+            update exp newExp exp +    funApp _=mzero              ++myfst (a,_,_,_) = a       +-------------------------------End of adding a parameter-----------------------------------           ++-----------------------------------------------------------------------------------------------------+{-Refactoring: Remove a parameter                                                                   +  Description: The refactoring removes a user specified formal parameter in a function binding,and    +               the corresponding actual parameters in all calling places of this function. The+               condition acompanying this refactoring is that the parameter to be removed is not being used.++  --To select a parameter, just stop the cursor at any position between the start and end position of this parameter.+-}+----------------------------------------------------------------------------------------------------- ++rmOneParameter args+ =do let fileName=args!!0+         row=read (args!!1)::Int    +         col=read (args!!2)::Int+     (inscps, exps, mod, tokList)<-parseSourceFile fileName  +     --pn is the function names. +     --nth is the nth paramter of pn is to be removed,index starts form 0.+     let (pnt,nth)=getParam tokList (row,col) mod  +         pn=pNTtoPN pnt +     if pn/=defaultPN +       then do (mod',((ts',m), _))<-doRmParam pn nth mod fileName tokList+               if isExported pnt exps+                then do modName <- RefacUtils.fileNameToModName fileName  +                        clients<-clientModsAndFiles modName+                        refactoredClients<-mapM (rmParamInClientMod pnt nth) clients+                        writeRefactoredFiles False $ ((fileName,m),(ts',mod')):refactoredClients +                else  writeRefactoredFiles  False [((fileName,m), (ts',mod'))]+       else error "Invalid cursor position!"++--pn: function name; nth: the index of the parameter to be removed. +doRmParam pn nth mod fileName tokList+       =runStateT (applyTP ((once_tdTP (failTP `adhocTP` inMod+                                              `adhocTP` inMatch+                                              `adhocTP` inPat+                                              `adhocTP` inLet+                                              `adhocTP` inAlt+                                              `adhocTP` inLetStmt)) `choiceTP` failure) mod) +                                           ((tokList,unmodified),(-1000,0))+      where+             --1. pn is declared in top level. +             inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)  +                |definingDecls [pn] ds False  False/=[] = doRemoving mod  ds+             inMod _ =mzero ++             --2. pn is declared locally in the where clause of a match.+             inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+                 |definingDecls [pn] ds False False /=[] = doRemoving match  ds                                                 +             inMatch _ =mzero++             --3. pn is declared locally in the where clause of a pattern binding.+             inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+                | definingDecls [pn] ds False  False/=[]  = doRemoving pat  ds                    +             inPat _=mzero+  +             --4: pn is declared locally in a  Let expression+             inLet (letExp@(Exp (HsLet ds e))::HsExpP)+               | definingDecls [pn] ds False  False/=[] = doRemoving letExp  ds+             inLet _=mzero+                +             --5. pn is declared locally in a  case alternative.+             inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+                | definingDecls [pn] ds False  False/=[]  = doRemoving  alt  ds+             inAlt _=mzero+      +             --6.pn is declared locally in a let statement.+             inLetStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP)+                | definingDecls [pn] ds False  False/=[]  = doRemoving letStmt ds+             inLetStmt _=mzero++             failure=idTP `adhocTP` mod+                     where mod (m::HsModuleP)=error "Refactoring failed"++             doRemoving parent  ds  --PROBLEM: How about doRemoving fails?+                =do rmFormalArg pn nth False True =<<rmNthArgInFunCall pn nth False ds +                    ds'<-rmNthArgInSig pn nth =<<rmFormalArg pn nth True False  ds  +                    rmNthArgInFunCall pn nth True (replaceDecls parent ds') ++             -- just remove the nth formal parameter.+             rmFormalArg pn nth updateToks checking         +                =applyTP (stop_tdTP (failTP `adhocTP` rmInMatch))+                                                   +               where +                 rmInMatch (match@(HsMatch loc  fun  pats rhs decls)::HsMatchP) --a formal parameter only exists in a match+                   |pNTtoPN fun==pn  +                   =let  pat=pats!!nth   --get the nth formal parameter+                         pNames=hsPNs pat  --get all the names in this pat. (the pat may be just be a variable)+                    in if checking && not ( all (==False) ((map (flip findPN rhs) pNames)) && --not used in rhs+                                            all (==False) ((map (flip findPN decls) pNames))) --not used in the where clause+                         then error  "This parameter can not be removed, as it is used!" +                         else if updateToks+                                then  do  pats'<-delete pat pats+                                          return (HsMatch loc fun pats' rhs decls)                                 +                                else return (HsMatch loc fun (pats\\[pat]) rhs decls)                         +                 rmInMatch _=mzero+++--remove the nth argument of function pn in all the calling places. the index for the first argument is zero.+rmNthArgInFunCall pn nth updateToks=applyTP (stop_tdTP (failTP `adhocTP` funApp))+   where             +         funApp (exp@(Exp (HsParen (Exp (HsApp e1 e2))))::HsExpP)+              |nth==0 && pn==expToPN e1+             =do if updateToks +                   then do update exp e1 exp    --handle the case like '(fun x) => fun "                         +                   else return e1+         funApp (exp@(Exp (HsApp e1 e2))::HsExpP)+              |pn==(expToPN.(ghead "rmNthArgInFunCall").unfoldHsApp) exp  --test if this application is a calling of fun pn.+               =do let (before,after)=splitAt (nth+1) (unfoldHsApp exp)   --remove the nth argument+                   if updateToks +                    then delete (ghead "rmNthArgInFunCall" after) exp +                    else return (foldHsApp (before++tail after))  --reconstruct the function application.        +                 +         funApp _=mzero                  +        +         --deconstruct a function application into a list of expressions.+         unfoldHsApp exp=+              case exp of+                  (Exp (HsApp e1 e2))->(unfoldHsApp e1)++[e2] +                  _ ->[exp]+         --reconstruct  a function application by a list of expressions.                           +         foldHsApp exps=foldl1 (\e1 e2->(Exp (HsApp e1 e2))) exps +++rmNthArgInSig pn nth decls+ = let (before,after)=break (\d ->definesTypeSig pn d) decls+   in if  after==[] +       then  return decls+       else  do newSig<-rmNthArgInSig' nth  [(head after)]  --no problem with 'head'+                return (before++newSig++(tail after))++   where rmNthArgInSig' nth sig@[(Dec (HsTypeSig loc is c tp))]+          =do let newSig=if length is ==1  +                            then --this type signature only defines the type of pn +                                 [Dec (HsTypeSig loc is c (rmNth tp))]+                            else --this type signature also defines the type of other ids.+                                 [Dec (HsTypeSig loc (filter (\x->pNTtoPN x/=pn) is) c tp),  +                                  Dec (HsTypeSig loc (filter (\x->pNTtoPN x==pn) is) c (rmNth tp))]+              update sig newSig sig   ++         rmNth tp=let (before,after)=splitAt nth (unfoldHsTypApp tp)+                    in  (foldHsTypApp (before ++ tail after))+            +         --deconstruct a type application into a list of types+         unfoldHsTypApp typ =+               case typ of (Typ (HsTyFun t1 t2)) ->t1:unfoldHsTypApp t2+                           _ ->[typ]++         --reconstruct a type application by a list of type expression.+         foldHsTypApp ts=foldr1 (\t1 t2->(Typ (HsTyFun t1 t2))) ts+ +--get the function name and the index of the parameter to be removed from the cursor position.+getParam toks pos  +     =(fromMaybe (defaultPNT, 0)).(applyTU (once_tdTU (failTU `adhocTU` inMatch)))+    where+       inMatch (match@(HsMatch loc  fun  pats rhs  decls)::HsMatchP)+          |inRange pos (getStartEndLoc toks pats) +          =let paramPosRanges=map (getStartEndLoc toks) pats +               elem=find (inRange pos) paramPosRanges+               in if isNothing elem +                    then error "Invalid cursor position!"  -- cursor doesn't stop at a parameter position.+                     else Just (fun, fromJust (elemIndex (fromJust elem) paramPosRanges))+       inMatch _=Nothing+      +       inRange pos (startPos,endPos)=pos>=startPos && pos<=endPos+        +rmParamInClientMod pnt nth (m, fileName)       + = do (inscps, exps, mod, ts) <-parseSourceFile fileName+      let qualifier = hsQualifier pnt inscps+          pn = pNTtoPN pnt+      if  qualifier == [] +          then return ((fileName,unmodified), (ts,mod))+          else do (mod',((ts',m), _)) <- runStateT (rmNthArgInFunCall pn nth True mod)+                                         ((ts,unmodified),(-1000,0))+                  return ((fileName,m), (ts',mod')) +
+ refactorer/RefacAsPatterns.hs view
@@ -0,0 +1,501 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacAsPatterns+-- Copyright   :  (c) Christopher Brown 2007+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Convert all patterns into AS patterns and +-- change all reference to the pattern on the RHS to references+-- to the AS name.+--+-----------------------------------------------------------------------------++module RefacAsPatterns where+++import System.IO.Unsafe+import PrettyPrint+import RefacTypeSyn+import RefacLocUtils+import Data.Char+import GHC.Unicode+import AbstractIO+import Maybe+import List+import RefacUtils++data Patt = Match HsMatchP | MyAlt HsAltP | MyDo HsStmtP | MyListComp HsExpP+             deriving (Show)+refacAsPatterns args+  = do let +           fileName    = args!!0+           name        = args!!1+           beginRow    = read (args!!2)::Int+           beginCol    = read (args!!3)::Int+           endRow      = read (args!!4)::Int+           endCol      = read (args!!5)::Int++       AbstractIO.putStrLn "refacAsPatterns"++       unless (isVarId name) +                  $ error "The new name is invalid!\n"+++       -- Parse the input file.+       modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName+       +       -- there are two modes to this refactoring:+       -- either one selects a pattern, or, one selects an expression (referring to a pattern).+       +       let exp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod+       +       case exp of+         Exp (HsId (HsVar (PNT (PN (UnQual "unknown") (G (PlainModule "unknown") "--" (N Nothing))) Value  (N Nothing)) ))+           -> do+       +                let (pnt, pat, match) = findPattern tokList (beginRow, beginCol) (endRow, endCol) mod+                                +                ((_,m), (newToks, newMod)) <- applyRefac (changePattern name pat match) (Just (inscps, exps, mod, tokList)) fileName+       +                unless (newMod /= mod) $ AbstractIO.putStrLn "Pattern does not occur on the rhs!"+  +                writeRefactoredFiles False [((fileName, m), (newToks, newMod))]   +                AbstractIO.putStrLn "Completed.\n"+         _+           -> do+                 -- all we need is the expression and the pattern to which it is imitating...+                 +                 let pat = getPat exp mod+                 +                 ((_,m), (newToks, newMod)) <- applyRefac (changePatternSimple name pat exp) (Just (inscps, exps, mod, tokList)) fileName+                 +                 writeRefactoredFiles False [((fileName, m), (newToks, newMod))]+                 AbstractIO.putStrLn "Completed.\n"+          ++getPat exp t+ = fromMaybe (error "No Pattern is associated with the highlighted expression!")+     (applyTU (once_tdTU (failTU `adhocTU` worker)) t)+       where+        worker (p :: HsPatP) +          | rewritePats p == exp = Just p+          | otherwise = Nothing+++convertPat :: String -> HsPatP -> HsPatP+convertPat _ (Pat (HsPAsPat n p)) = error "The selected pattern is already an as-pattern!"+convertPat _ (Pat (HsPId _)) = error "Cannot perform to-as-patterns on a simple variable!"+convertPat _ (Pat (HsPLit _ _)) = error "Cannot perform to-as-patterns on a constant value!"+convertPat name (Pat (HsPParen p)) = convertPat name p+convertPat name p = (Pat (HsPAsPat (nameToPNT name) p))++changePatternSimple name pat exp (_, _, t)+ = do++       inscopeNames <- hsVisibleNames exp t+       unless (not (name `elem` inscopeNames))+        $ error ("the use of the name: " ++ name ++ " is already in scope!")+       +       -- let newPats = checkPats name pat [p]+       let convertedPat = convertPat name pat+       newExp <- checkExpr convertedPat exp++       newT <- update exp newExp t+       newT2 <- update pat convertedPat newT+       +       return newT2++++changePattern name pat (Match match) (_, _,t)+  = do +       newDecl <- lookInMatches t name pat [match]+       newT <- update match (newDecl !! 0) t+       return newT++changePattern name pat (MyAlt alt) (_, _, t)+  = do+       newAlt <- lookInAlt t name pat alt+       newT <- update alt newAlt t+       return newT+       +changePattern name pat (MyDo inDo) (_,_, t)+  = do+       newDo <- lookInDo t name pat inDo+       newT <- update inDo newDo t+       return newT+       +changePattern name pat (MyListComp inList) (_,_,t)+ = do+       newList <- lookInList t name pat inList+       newT <- update inList newList t+       return newT++-- sconvertPatterns :: (Term t, MonadPlus m,Monad m) => t -> String -> HsPatP -> HsDeclP -> m HsDeclP+convertPatterns t name pat dec@(Dec (HsPatBind a b (HsBody e) ds)) +  = do+        newExp <- checkExpr (Pat (HsPAsPat (nameToPNT name) pat)) e+        return (Dec (HsPatBind a b (HsBody newExp) ds))+convertPatterns t name pat (Dec (HsFunBind loc matches)) +  = +    do+       rest <- lookInMatches t name pat matches+       return (Dec (HsFunBind loc  rest ))++lookInMatches _ _ _ []  = return []+lookInMatches t name pat (match@(HsMatch s pnt (p:ps) (HsGuard g@((_,_,e):gs)) ds):ms)+    = do       +       inscopeNames <- hsVisibleNames e t+       unless (not (name `elem` inscopeNames))+        $ error ("the use of the name: " ++ name ++ " is already in scope!")+    +       let newPats = checkPats name pat (p:ps)+       let convertedPat = convertPat name pat+       newGuard <- checkGuards convertedPat g+       newDS <- mapM (convertPatterns t name pat) ds+       rest <- lookInMatches t name pat ms+       if newGuard == g && newDS == ds+         then do+           return (HsMatch s pnt (p:ps) (HsGuard g) ds : rest)+         else do+           return (HsMatch s pnt newPats (HsGuard newGuard) newDS : rest)++         +lookInMatches t name pat (match@(HsMatch s pnt (p:ps) (HsBody e) ds):ms)+   = do+       inscopeNames <- hsVisibleNames e t+       unless (not (name `elem` inscopeNames))+        $ error ("the use of the name: " ++ name ++ " is already in scope!")+       +       let newPats = checkPats name pat (p:ps)+       let convertedPat = convertPat name pat+       newExp <- checkExpr convertedPat e+       newDS <- mapM (convertPatterns t name pat) ds+       rest <- lookInMatches t name pat ms+       if newExp == e && newDS == ds+         then do+           return (HsMatch s pnt (p:ps) (HsBody e) ds : rest)     +         else do+           return (HsMatch s pnt newPats (HsBody newExp) newDS : rest)+++lookInAlt t name pat (alt@(HsAlt s p (HsGuard g@((_,_,e):gs))  ds)::HsAltP)+    = do       +       inscopeNames <- hsVisibleNames e t+       unless (not (name `elem` inscopeNames))+        $ error ("the use of the name: " ++ name ++ " is already in scope!")+    +       let newPats = checkPats name pat [p]+       let convertedPat = convertPat name pat+       newGuard <- checkGuards convertedPat g+       newDS <- mapM (convertPatterns t name pat) ds+       -- rest <- lookInMatches t name pat ms+       if newGuard == g && newDS == ds+         then do+           return (HsAlt s p (HsGuard g) ds)+         else do+           return (HsAlt s (ghead "lookInAlt" newPats) (HsGuard newGuard) newDS)+         +lookInAlt t name pat (alt@(HsAlt s p (HsBody e)  ds)::HsAltP)+   = do+       inscopeNames <- hsVisibleNames e t+       unless (not (name `elem` inscopeNames))+        $ error ("the use of the name: " ++ name ++ " is already in scope!")+       +       let newPats = checkPats name pat [p]+       let convertedPat = convertPat name pat+       newExp <- checkExpr convertedPat e+       newDS <- mapM (convertPatterns t name pat) ds+       -- rest <- lookInMatches t name pat ms+       if newExp == e && newDS == ds+         then do+           return (HsAlt s p (HsBody e) ds)+         else do+           return (HsAlt s (ghead "lookInAlt" newPats) (HsBody newExp) newDS)+ +lookInDo t name pat (inDo@(HsGenerator s p e rest))+   = do+       inscopeNames <- hsVisibleNames e t+       unless (not (name `elem` inscopeNames))+        $ error ("the use of the name: " ++ name ++ " is already in scope!")+       +       let newPats = checkPats name pat [p]+       let convertedPat = convertPat name pat+       newExp <- checkExpr convertedPat e+       newDS <- lookInExps t name pat rest+       -- rest <- lookInMatches t name pat ms+       if newExp == e && newDS == rest+         then do+           return (HsGenerator s p e rest)+         else do+           return (HsGenerator s (ghead "lookInDo" newPats) newExp newDS)+           +lookInList t name pat (inList@(Exp (HsListComp d)))+ = do+      res <- lookInDo t name pat d+      return (Exp (HsListComp res))++lookInExps t name pat (HsLast e) +   = do+       inscopeNames <- hsVisibleNames e t+       unless (not (name `elem` inscopeNames))+        $ error ("the use of the name: " ++ name ++ " is already in scope!")+       let convertedPat = convertPat name pat+       newExp <- checkExpr convertedPat e+       return (HsLast newExp)++lookInExps t name pat (HsGenerator s p e rest)+   = do+       inscopeNames <- hsVisibleNames e t+       unless (not (name `elem` inscopeNames))+        $ error ("the use of the name: " ++ name ++ " is already in scope!")+       +       let newPats = checkPats name pat [p]+       let convertedPat = convertPat name pat+       newExp <- checkExpr convertedPat e+       newDS <- lookInExps t name pat rest+       -- rest <- lookInMatches t name pat ms+       if newExp == e && newDS == rest+         then do+           return (HsGenerator s p e rest)+         else do+           return (HsGenerator s (ghead "lookInDo" newPats) newExp newDS)++lookInExps t name pat (HsQualifier e rest)+   = do+       inscopeNames <- hsVisibleNames e t+       unless (not (name `elem` inscopeNames))+        $ error ("the use of the name: " ++ name ++ " is already in scope!")+       let convertedPat = convertPat name pat+       newExp <- checkExpr convertedPat e+       newDS <- lookInExps t name pat rest+       return (HsQualifier newExp newDS)+       +lookInExps t name pat (HsLetStmt ds rest)+   = do+       +       let convertedPat = convertPat name pat+       newRest <- lookInExps t name pat rest+       newDS <- mapM (convertPatterns t name pat) ds++       -- rest <- lookInMatches t name pat ms+       if newDS == ds && rest == newRest+         then do+           return (HsLetStmt ds rest)+         else do+           return (HsLetStmt newDS newRest) +            +checkPats :: String -> HsPatP -> [ HsPatP ] -> [ HsPatP ]+checkPats _ _ [] = []+checkPats name pat (pat2@(Pat (HsPParen p)): ps)+ | pat == pat2  = (Pat (HsPParen (Pat (HsPAsPat (nameToPNT name) p)))) : checkPats name pat ps+ | otherwise =  (Pat (HsPParen res)) : (checkPats name pat ps)+     where+       res = ghead "checkPats HsPParen res" $ checkPats name pat [p]+checkPats name pat (pat2@(Pat (HsPApp i ps)):pss)+ | pat == pat2 = (Pat (HsPAsPat (nameToPNT name) pat2)) : checkPats name pat pss+ | otherwise = (Pat (HsPApp i (checkPats name pat ps))) : checkPats name pat pss+ +checkPats name pat (pat2@(Pat (HsPTuple s ps)):pss)+ | pat == pat2 = (Pat (HsPAsPat (nameToPNT name) pat2)) : checkPats name pat pss+ | otherwise = (Pat (HsPTuple s (checkPats name pat ps))) : checkPats name pat pss+ +checkPats name pat (pat2@(Pat (HsPList s ps)) : pss)+ | pat == pat2 = (Pat (HsPAsPat (nameToPNT name) pat2)) : checkPats name pat pss+ | otherwise   = (Pat (HsPList s (checkPats name pat ps))) : checkPats name pat pss+ +checkPats name pat ((Pat (HsPInfixApp p1 i p2)) : pss)+ = (Pat (HsPInfixApp res1 i res2)) : checkPats name pat pss+     where+       res1 = ghead "checkPats HsPInFixApp res1" $ checkPats name pat [p1]+       res2 = ghead "checkPats HsPInfixApp res2" $ checkPats name pat [p2]+checkPats name pat (p:ps)+ | pat == p  = (Pat (HsPAsPat (nameToPNT name) p)) : checkPats name pat ps+ | otherwise = p : (checkPats name pat ps) ++-- checkGuards [] g = return g+checkGuards _ [] = return []+checkGuards pat@(Pat (HsPAsPat s p)) ((s1, e1, e2):gs)+  = do+       -- rewrite the guard+       newGuard  <- rewriteExp s (rewritePats p) e1 pat+       -- newGuard' <- checkExpr ps newGuard+       +       -- rewrite the RHS of the guard+       rhs       <- rewriteExp s (rewritePats p) e2 pat+       -- rhs'      <- checkExpr ps rhs+       rest <- checkGuards pat gs++       return ((s1, newGuard, rhs):rest)++-- checkExpr :: [ HsPatP ] -> HsExpP -> m HsExpP+-- checkExpr [] e = return e+checkExpr pat@(Pat (HsPAsPat s p)) e+    = do  +        newExp <- rewriteExp s (rewritePats p) e pat  --   error $ show (rewritePats p)+        -- newExp' <- checkExpr ps newExp  +        return newExp+checkExpr _ e = return e++-- rewrite exp checks to see whether the given expression occurs within+-- the second exp. If it does, the expression is replaced with the name of the 'as'+-- pattern.+-- rewriteExp :: String -> HsExpP -> HsExpP -> HsExpP+rewriteExp name e1 e2 t+  = applyTP (full_tdTP (idTP `adhocTP` (inExp e1))) e2+     where+       -- inExp :: HsExpP -> HsExpP -> HsExpP+       inExp (Exp (HsParen e1)::HsExpP) (e2::HsExpP)+        = do+             -- error $ show e2+             allDef <- allDefined e2 t+             if (rmLocs e1) == (rmLocs e2) && (and allDef)+               then do+                  return (nameToExp (pNTtoName name))+               else do+                  return e2             +       inExp (e1::HsExpP) (e2::HsExpP)+         | (rmLocs e1) == (rmLocs e2)  = return (nameToExp (pNTtoName name))+         | otherwise = return e2 +  +allDefined e t+  = applyTU (full_tdTU (constTU [] `adhocTU` inPNT)) e+      where+        inPNT (p@(PNT pname ty _)::PNT)   +         = return [findPN pname t]++rewritePats :: HsPatP -> HsExpP+rewritePats (pat1@(Pat (HsPRec x y)))+  = Exp (HsRecConstr loc0 x (map sortField y))+    where+      sortField :: HsFieldI a HsPatP -> HsFieldI a HsExpP+      sortField (HsField i e) = (HsField i (rewritePats e))++rewritePats (pat1@(Pat (HsPLit x y)))+  = Exp (HsLit x y)++rewritePats (pat1@(Pat (HsPAsPat i p1)))+  = Exp (HsAsPat i (rewritePats p1))++rewritePats (pat1@(Pat (HsPIrrPat p1)))+  = Exp (HsIrrPat (rewritePats p1))++rewritePats (pat1@(Pat (HsPWildCard)))+  = nameToExp "undefined"++rewritePats (pat1@(Pat (HsPApp i p1)))+  = createFuncFromPat i (map rewritePats p1)++rewritePats (pat1@(Pat (HsPList _ p1)))+  = Exp (HsList (map rewritePats p1))++rewritePats (pat1@(Pat (HsPTuple _ p1)))+  = Exp (HsTuple (map rewritePats p1))++rewritePats (pat1@(Pat (HsPInfixApp p1 x p2)))+  =  Exp (HsInfixApp (rewritePats p1)+                     (HsCon x)+                     (rewritePats p2))++rewritePats (pat@(Pat (HsPParen p1)))+  = Exp (HsParen (rewritePats p1))++rewritePats (pat1@(Pat (HsPId (HsVar (PNT (PN (UnQual (i:is)) a) b c)))))+ | isUpper i = (Exp (HsId (HsCon (PNT (PN (UnQual (i:is)) a) b c))))+ | otherwise = (Exp (HsId (HsVar (PNT (PN (UnQual (i:is)) a) b c))))+rewritePats (pat1@(Pat (HsPId (HsCon (PNT (PN (UnQual (i:is)) a) b c)))))+  = (Exp (HsId (HsCon (PNT (PN (UnQual (i:is)) a) b c))))+-- rewritePats p = error $ show p+++-- strip removes whitespace and '\n' from a given string+strip :: String -> String+strip [] = []+strip (' ':xs) = strip xs+strip ('\n':xs) = strip xs+strip (x:xs) = x : strip xs++isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)++--check whether the cursor points to the beginning of the datatype declaration+--taken from RefacADT.hs+checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToTypeDecl of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the definition!")+     Just decl -> Right decl+   where+    locToTypeDecl = find (definesPNT (locToPNT fileName (row, col) mod)) (hsModDecls mod)+    +    definesPNT pnt d@(Dec (HsPatBind loc p e ds))+      = findPNT pnt d+    definesPNT pnt d@(Dec (HsFunBind loc ms)) = findPNT pnt d+    definesPNT pnt _ = False++{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++{-findPattern :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (SrcLoc, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+ -}                    +findPattern toks beginPos endPos t+  = fromMaybe (defaultPNT, defaultPat, error "Invalid pattern selected!")+              (applyTU (once_tdTU (failTU `adhocTU` inMatch +                                          `adhocTU` inCase+                                          `adhocTU` inDo +                                          `adhocTU` inList )) t)++    where+       --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats rhs ds)::HsMatchP)+        -- is the highlighted region selecting a pattern?+        | inPat pats == Nothing = Nothing+        | otherwise = do +                         let pat = fromJust (inPat pats) +                         Just (pnt, pat, Match match)+      +      inCase (alt@(HsAlt s p rhs ds)::HsAltP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let pat = fromJust (inPat [p])+                          Just (defaultPNT, pat, MyAlt alt)+                          +      inDo (inDo@(HsGenerator s p e rest)::HsStmtP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let pat = fromJust (inPat [p])+                          Just (defaultPNT, pat, MyDo inDo)+      inDo x = Nothing+      +      inList (inlist@(Exp (HsListComp (HsGenerator s p e rest)))::HsExpP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let pat = fromJust (inPat [p])+                          Just (defaultPNT, pat, MyListComp inlist)+      inList x = Nothing+      +      inPat :: [HsPatP] -> Maybe HsPatP+      inPat [] = Nothing+      inPat (p:ps)+       = if p1 /= defaultPat+           then Just p1+           else inPat ps+              where +                p1 = locToLocalPat beginPos endPos toks p+   --   inPat _ = Nothing
+ refactorer/RefacCacheMerge.hs view
@@ -0,0 +1,97 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacCacheMerge+-- Copyright   :  (c) Christopher Brown 2006+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module caches definitions into a file to be used+-- with RefacMerge+++module RefacCacheMerge where+++import System.IO.Unsafe++import RefacTypeSyn+import RefacLocUtils+import Data.Char+import GHC.Unicode+import AbstractIO+import Maybe+import List+import RefacUtils+import RefacRedunDec+import SlicingUtils++import LocalSettings++refacCacheMerge args+  = do ++           +       let fileName     = args!!0+           begin        = read (args!!1)::Int+           end          = read (args!!2)::Int+       AbstractIO.putStrLn "refacCacheMerge"+       +       +       (inscps, exps, mod, tokList) <- parseSourceFile fileName+       +       case checkCursor fileName begin end mod of+         Left errMsg -> do error errMsg+         Right decl ->+           do+             AbstractIO.putStrLn ((declToName decl) ++ " added to cache.")+       +             -- let x = unsafePerformIO (do+             AbstractIO.appendFile mergeFilePath (">" ++ fileName ++ "<" ++ "%" ++ (show begin) ++ "%" ++ "&" ++ (show end) ++ "&") +             AbstractIO.putStrLn "Completed" -- )+              +             AbstractIO.putStrLn "RefacCacheMerge Completed."++-- check whether the cursor points to the beginning of the datatype declaration+-- taken from RefacADT.hs+{- checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToTypeDecl of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the definition!")+     Just decl -> Right decl+   where+    locToTypeDecl = find (definesPNT (locToPNT fileName (row, col) mod)) (hsModDecls mod)+    +    definesPNT pnt d@(Dec (HsPatBind loc p e ds))+      | declToPName2 d == pNTtoPN pnt = True+      | otherwise = definesPNT pnt (hsDecls ds) -- findPNT pnt d+    definesPNT pnt d@(Dec (HsFunBind loc ms)) +      | declToPName2 d == pNTtoPN pnt = True+      | otherwise = definesPNT pnt (hsDecls ms)+    +    -- = -- findPNT pnt d+    definesPNT pnt _ = False -}+    +checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToPName of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the definition!")+     Just decl -> Right decl+    where+        locToPName +         = case res of +             Nothing -> find (definesPNT (locToPNT fileName (row, col) mod)) (hsDecls mod)+             _ -> res+        res =  find (defines (locToPN fileName (row, col) mod)) (concat (map hsDecls (hsModDecls mod)))+        +        definesPNT pnt d@(Dec (HsPatBind loc p e ds))+         = findPNT pnt d+        definesPNT pnt d@(Dec (HsFunBind loc ms)) +         = findPNT pnt d+        definesPNT _ _ = False+     {-  locToPName = locToPN fileName (row, col) mod+        +        definesPNT pnt d@(Dec (HsFunBind loc ms))+         | isDeclaredIn -}+         
+ refactorer/RefacCase.hs view
@@ -0,0 +1,32 @@+++module RefacCase(ifToCase) where++import RefacUtils ++ifToCase args  +  = do let fileName = args!!0              +           beginPos = (read (args!!1), read (args!!2))::(Int,Int)+           endPos   = (read (args!!3), read (args!!4))::(Int,Int)+       modInfo@(_, _, mod, toks) <- parseSourceFile fileName +       let exp = locToExp beginPos endPos toks mod+       case exp of +           (Exp (HsIf _ _ _))   +                -> do refactoredMod <- applyRefac (ifToCase exp) (Just modInfo) fileName          +                      writeRefactoredFiles False [refactoredMod]+           _   -> error "You haven't selected an if-then-else  expression!"+    where ++     ifToCase exp (_, _, mod)= applyTP (once_buTP (failTP `adhocTP` inExp)) mod+       where +         inExp exp1@((Exp (HsIf  e e1 e2))::HsExpP)+           | sameOccurrence exp exp1       +           = let newExp =Exp (HsCase e [HsAlt loc0 (nameToPat "True") (HsBody e1) [],+                                        HsAlt loc0 (nameToPat "False")(HsBody e2) []])+             in update exp1 newExp exp1+         inExp _ = mzero++                           +++
+ refactorer/RefacCleanImps.hs view
@@ -0,0 +1,357 @@+++module RefacCleanImps(cleanImports,mkImpExplicit,addToExport,rmFromExport) where++import PosSyntax+import Maybe+import TypedIds+import List hiding (delete)+import RefacUtils +import UniqueNames hiding (srcLoc)+import HsName hiding (ModuleName)+import SourceNames+import PNT +import RefacMoveDef(liftingInClientMod)+import PFE0 (findFile)+import PrettyPrint hiding (group)+import NamesEntities+import Ents +import Relations+import Modules(mImp',mExpListEntry)+import AST4ModSys (toImport',toExpListEntry') +import HsIdent(HsIdentI(..))+++{- This refactoring trys to remove the unnecessary import declarations from the module-}++cleanImports args+ = do let fileName= ghead "filename" args  +      (inscps, _, mod'', toks) <- parseSourceFile fileName      +      let mod = rmPrelude mod''+          inscps' =relToList inscps    +      imp_Ents_List <- getImportedEnts inscps' (hsModImports mod)+      (mod',((toks',m),_))<-runStateT (doCleanImports imp_Ents_List (inscps', mod))+                                        ((toks,unmodified),(-1000,0)) +      writeRefactoredFiles False [((fileName,m),(toks', mod'))]+++doCleanImports imp_Ents_List (inscps, mod@(HsModule _ modName exps imps decls))+ = do  -- imp_usedEnts_List ::[(ImportDeclP, [PNames])]+      let imp_usedEnts_List =map (getUsedEnts mod) imp_Ents_List+      mod' <- checkEachImport mod (imp_usedEnts_List, imp_usedEnts_List)+      combineImports mod' (hsModImports mod')   ++-- remove an import declaration from the module.+rmOneImport mod@(HsModule loc modName exps imps decls) imp+  = do imps' <- delete imp imps+       return (HsModule loc modName exps (imps\\[imp]) decls)+++checkEachImport mod@(HsModule loc modName exps imps decls) ([],_)+  =return mod++checkEachImport mod@(HsModule loc modName exps imps decls) ((i@(imp,inscpEnts,usedEnts):is), origList)+  = if usedEnts == []   -- this import decl is not used at all.+      then do mod'<- (do m'<-rmOneImport mod imp+                         if inscpEnts==[] && modIsExported1 (qualifier imp) mod+                           then rmItemsFromExport m' (Left ([qualifier imp], []))+                           else return m')           +              checkEachImport mod' (is, (origList \\ [i]))+      else if any (\(x,y,z)->(usedEnts == z  && length inscpEnts >= length y)+                    || (usedEnts \\ z ==[] && length usedEnts <length z)) (origList \\ [i])    +             then do mod'<-rmOneImport mod imp+                     checkEachImport mod' (is,(origList \\[i]))+             else checkEachImport mod (is, origList)+++--getImportedEnts::[(QName,Entity)]->[HsImportDeclP]->[(HsImportDeclP,[(QName,Entity)])]+getImportedEnts inscps imps+ = do importedEnts<-mapM getImportedEnts' imps+      return $ zip imps importedEnts+  where  +    getImportedEnts' (imp@(HsImportDecl loc (SN modName _) qual as h)::HsImportDeclP)+       = do fileName <- PFE0.findFile modName  +            (_, exps, mod, toks) <- parseSourceFile fileName       +            return $ relToList (mImp' (listToRel exps) +                     (toImport' (HsImportDecl loc modName qual (as' as) h)))+      where as' Nothing = Nothing+            as' (Just (SN modName _)) = Just modName+        +getUsedEnts mod@(HsModule _ _ exps imps decls) (imp@(HsImportDecl _ (SN modName _) _ as h),inscpEnts)+  = if modIsExported1 (qualifier imp) mod+      then (imp, inscpEnts, inscpEnts)+      else case h of+              (Just (False, ents)) ->if ents == [] +                                       then (imp, inscpEnts,[])+                                       else (imp, inscpEnts, usedEnts' (exps, decls))+              _ -> (imp, inscpEnts, usedEnts' (exps, decls))          +   where +     usedEnts'= (nub.ghead "getUsedEnts'"). applyTU (full_tdTU (constTU [] `adhocTU` inPnt)) +        where+          inPnt pnt@(PNT pname ty loc)+           | isTopLevelPNT pnt+            =let ent'=pntToEnt pnt+             in if isJust (find (==ent') inscpEnts)+                  then return [ent']+                  else return []+          inPnt _ = return []++--- THIS FUNCTION SHOULD GO TO THE API.+modIsExported1 modName mod+ = if isNothing exps+     then False+     else isJust $ find (\x->getModName x == Just modName) (fromJust exps)+   where+     exps =  hsModExports mod+     getModName (ModuleE  (SN modName _)) = Just modName+     getModName _ = Nothing+ ++unqualify ((SN (Qual _ id) l), ent) = ((SN (UnQual id) l), ent)+unqualify x  = x  ++qualifier (HsImportDecl _ (SN modName _) qual Nothing h) = modName+qualifier (HsImportDecl _ _ qual (Just (SN modName _)) h) = modName++combineImports mod [] = return mod  +combineImports mod@(HsModule _ _ _ imps _) (i:is)+   = case i of +     (HsImportDecl _ modName@(SN modName' _)  qual as (Just(False, ents)))+        ->let sub_is= filter (\x-> case x of+                                  (HsImportDecl _ modName1 qual1 as1 (Just(False,ents1)))+                                    ->modName1 == modName && qual==qual1 && as == as1+                                  _ ->False ) is+          in if sub_is==[] then combineImports mod is+                           else do let ents=concatMap importedEnts sub_is+                                   mod'<-foldM rmOneImport mod sub_is+                                   let (imps1, imps2) = break (==i) imps   +                                   i' <-addItemsToImport modName' Nothing (Right ents) i+                                   combineImports (mod' {hsModImports =((imps1++[i']++(tail imps2)) \\ sub_is)}) (is \\ sub_is) +     _  ->combineImports mod is+  where+     importedEnts (HsImportDecl _ _ False Nothing (Just(False,ents))) =ents+     importedEnts  _ =[] +  +pntToEnt pnt@(PNT pn@(PN (UnQual s) (G modName s1 loc)) ty _)+  = let t= if hasNameSpace pnt == ValueName then HsVar else HsCon+    in ((SN (UnQual s) (getSrcLoc loc)), (Ent modName (t (SN s (getSrcLoc loc))) (fmap pIdtoId ty)))++pntToEnt pnt@(PNT pn@(PN (Qual modName s) (G modName1 s1 loc)) ty _)+  = let t= if hasNameSpace pnt == ValueName then HsVar else HsCon+    in ((SN (Qual modName s) (getSrcLoc loc)) , (Ent modName1 (HsVar (SN s (getSrcLoc loc))) (fmap pIdtoId ty)))+          +pIdtoId pn@(PN i orig) = (SN i (srcLoc pn))++getSrcLoc (N (Just loc)) = loc+getSrcLoc (N Nothing)    = loc0++-- this refactoring makes the all the used enitities from a import decl explicit in the import declaration.+mkImpExplicit args+ =do let fileName= ghead "filename" args            +         row = read (args!!1)::Int+         col = read (args!!2)::Int+     modName <- fileNameToModName fileName+     (inscps, _, mod, toks) <- parseSourceFile fileName      +     let imp'=locToImport fileName row col mod   +     unless (isJust imp')+        $ error ("Invalid cursor position! "+++                "Please point the cursor to the beginning position of the module name." )+     let inscps' = relToList inscps  +         imp = fromJust imp'    +     [(imp, importedEnts)] <- getImportedEnts inscps' [imp]  +     (mod',((toks',_),_))<-runStateT (doExplicitImport mod (imp,importedEnts))+                                         ((toks,unmodified),(-1000,0))+     writeRefactoredFiles False [((fileName,True),(toks', mod'))]+++locToImport fileName row col mod+  = applyTU (once_buTU (failTU `adhocTU` worker)) mod+      where+       worker (imp@(HsImportDecl l (SN modName (SrcLoc _ _ row1 col1)) _ _ _)::HsImportDeclP)+         | row1 == row && col1 == col +         =Just imp+       worker _ = Nothing +                     +doExplicitImport mod (imp@(HsImportDecl l m qual as _),importedEnts)+ = do let used =usedEnts importedEnts  mod          +          (imps1, imps2) = break (==imp) (hsModImports mod)+      imp' <-update imp ( if (used==[])  then (HsImportDecl l m qual as (Just(False, [])))+                                         else (HsImportDecl l m qual as (Just (False, used)))) imp+      return (mod {hsModImports=(imps1++[imp']++imps2)})++  where+   usedEnts importedEnts = combineEntSpecs. (nub.ghead "usdEnts'"). +                            applyTU (full_tdTU (constTU [] `adhocTU` inPnt)) +        where+          inPnt pnt@(PNT pname ty loc)+           | isTopLevelPNT pnt+            =let ent'=pntToEnt pnt+             in if isJust (find (==ent') importedEnts)+                  then return [pNTtoEntSpec pnt]+                  else return []+          inPnt _ = return []+     +   combineEntSpecs [] = []+   combineEntSpecs (e:es) +       = case e of+          Abs pnt -> if findDup pnt es then combineEntSpecs es else (e:combineEntSpecs es)+               where findDup pnt es = any (\x->case x of +                                            ListSubs i is -> pNTtoName i== pNTtoName pnt+                                            Abs  i        -> pNTtoName i== pNTtoName pnt+                                            _             -> False) es+          ListSubs p _ -> if findDup p es then combineEntSpecs (doCombine e es)  else (e:combineEntSpecs es)+              where findDup pnt es = any (\x->case x of +                                              ListSubs p' _ ->pNTtoName p == pNTtoName p' +                                              _  -> False) es        +                    doCombine (ListSubs p cs) es+                          = let (es1, es2) = break (\x-> case x of+                                                    ListSubs p' _ ->pNTtoName p == pNTtoName p'  +                                                    _ ->False) es +                                (ListSubs _ cs') = ghead "doCombine" es2+                            in (es1++[ListSubs p (cs++cs')]++tail es2) +                                +          _  -> (e: combineEntSpecs es)+       +pNTtoEntSpec pnt@(PNT pn@(PN _ (G modName s1 loc)) ty _)+  = case  ty of      +       ConstrOf i _ -> ListSubs (pIdToPNT i) [HsCon pnt']+       Type _       -> Abs pnt' +       _            -> Var pnt'+  where   +   pIdToPNT (PN id orig) =PNT (PN (UnQual id) orig) Value  (N Nothing) + +   pnt'= rmQualifier pnt +     where rmQualifier (PNT (PN (Qual modName  s) l) ty loc)= (PNT (PN (UnQual s) l) ty loc)+           rmQualifier  x  = x +++-- this refactoring adds an user-selected top-level identifier to the export list.++addToExport args+ =do let fileName= ghead "filename" args            +         row = read (args!!1)::Int+         col = read (args!!2)::Int   +     modName <- fileNameToModName fileName+     (inscps, exps, mod, toks) <- parseSourceFile fileName+     let pnt = locToPNT fileName (row, col) mod                                            +     unless (pnt/=defaultPNT) $ error "Invalid cursor position!\n"  -- this refactoring does not handle module names.+     unless (isTopLevelPNT pnt) $ error "The selected identifier is not a top level identifier!\n"+     (mod',((toks',_),_))<-runStateT (doAddingToExport pnt mod)+                                         ((toks,unmodified),(-1000,0))+     clients <-clientModsAndFiles modName+     refactoredClients <-mapM (refactorInClientMod modName (pNTtoPN pnt)) clients+     writeRefactoredFiles False $ ((fileName,True),(toks', mod')):refactoredClients+  where +     doAddingToExport pnt mod+      = do let pn = pNTtoPN pnt +           unless (not (isExplicitlyExported pn mod  || modIsExported mod))+                   $ error "The indentifier is already exported!\n"+           let exps=fromJust $ hsModExports mod+               newEnt = EntE (pNTtoEntSpec pnt)+           insertEEnt mod newEnt++     insertEEnt mod e@(EntE ent)+      = let exps = fromJust $ hsModExports mod+        in case  ent  of +            ListSubs i is  ->+               let (exps1,exps2)=break (\i'->case i' of+                                             (EntE (ListSubs i'' _)) ->(i''==i)+                                             (EntE (Abs i''))        ->(i''== i)+                                             _                       -> False) exps+               in if exps2 == []+                   then do addItemsToExport mod Nothing False (Right [e])+                           return $ (mod {hsModExports=Just ([e]++exps)}) +                   else do let e'=ghead "insertEnt" exps2+                           exps'<- case e' of +                                    (EntE (ListSubs i'' is')) ->+                                        do e''<-update e' (EntE (ListSubs i (is'++is))) e'+                                            -- there is a problem with pretty-printing (EntE ...)+                                           return $ Just (exps1++(e'':tail exps2))+                                    (EntE (Abs i'')) ->+                                        do e''<-update  e'(EntE (ListSubs i'' is)) e' +                                           return $ Just (exps1 ++(e'':tail exps2))+                           return $ (mod {hsModExports=exps'})+            _  -> do addItemsToExport mod Nothing False (Right [e]) +                     return $ (mod {hsModExports=Just ([e]++exps)})++     refactorInClientMod serverModName pn (modName, fileName)+       = liftingInClientMod serverModName [pn] (modName, fileName)++--This refactoring removes an user-selected entry from the export list if none of the idenitifiers exported+--by this entry is used by other modules.++-- NOTE: This refactoring DOES NOT HANDLE SUB-ENTRIES in the export list. (Can this be improved?)++rmFromExport args+ =do let fileName= ghead "filename" args            +         row = read (args!!1)::Int+         col = read (args!!2)::Int   +     modName <- fileNameToModName fileName+     (inscps, exps, mod, toks) <- parseSourceFile fileName+     let eEntry' = locToEEntry row col mod toks             +     unless (eEntry'/=Nothing) $ error "Invalid cursor position!\n"   +     let eEntry = fromJust eEntry'+         ents = exportedEnts inscps eEntry+     if isDuplicatedEntry inscps (eEntry, ents) (fromJust (hsModExports mod))+       then do (mod',((toks',m),_))<-runStateT (doRmFromExport mod eEntry)+                                   ((toks,unmodified),(-1000,0)) +               writeRefactoredFiles False [((fileName, m),(toks',mod'))]+       else do clients<-clientModsAndFiles modName+               refactoredClients <- mapM (refactorInClientMod ents) clients+               (mod',((toks',m),_))<-runStateT (doRmFromExport mod eEntry)+                                        ((toks,unmodified),(-1000,0))+               writeRefactoredFiles False $ ((fileName,m),(toks',mod')):refactoredClients+          +     +   where++    -- Calculates all the entities exported by this entry.+    exportedEnts inscps eEntry = relToList (mExpListEntry inscps  (toExpListEntry' eEntry))++    -- Returns True if this entry is duplicated or covered by another entry in the export list.+    isDuplicatedEntry inscps (eEntry, ents) exps +       =let ents'= map (mExpListEntry' inscps) (map toExpListEntry' (exps \\[eEntry]))        +        in  any (\e->intersect e ents==ents) ents'+        where mExpListEntry' inscps entry= relToList (mExpListEntry inscps entry)+  +    -- Removes an entry from the export list.+    doRmFromExport mod eEntry = rmItemsFromExport mod (Right [eEntry])++    -- get the user selected entry from the export list.+    locToEEntry row col mod toks+      =if isJust exps +          then let (_, e2) =break (\e->let (startLoc, endLoc) =getStartEndLoc toks e+                                       in startLoc<=(row,col) && (row,col)<=endLoc) (fromJust exps)+               in if e2==[] then Nothing else Just (head e2)+           else Nothing+ +       where exps = hsModExports mod     + +    refactorInClientMod ents (modName, fileName)+      = do (inscps, exps, mod ,ts) <-parseSourceFile fileName          +           -- The following condition is too strong.         +           if findEnt ents (hsModDecls mod) || (intersect (map impEntToExpEnt ents) exps) /= []+            then  error $ "This entity can not be removed as it is used by the client module '"++(render.ppi) modName++"'!"+            else do let pnsToBeHided =findPns ents (hsModImports mod) +                    if pnsToBeHided/=[]  +                     then do (mod', ((ts',m),_))<-runStateT (rmItemsFromImport mod pnsToBeHided)+                                                   ((ts,unmodified),(-1000,0))+                             return ((fileName,m), (ts',mod'))+                     else return ((fileName,unmodified), (ts,mod)) +    findEnt ents+        = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))+          where +            worker (pnt::PNT)+             |isTopLevelPNT pnt && isJust (find (==(pntToEnt pnt)) ents) = Just True+            worker _ = Nothing++    impEntToExpEnt ((SN (UnQual s) loc1), e) = ((SN s loc1), e)+    impEntToExpEnt ((SN (Qual modName s) loc1),e) = ((SN s loc1), e)++    findPns ents +        = (nub.ghead "findPns").(applyTU (full_tdTU (constTU [] `adhocTU` worker)))+          where +            worker (pnt::PNT)+             |isTopLevelPNT pnt && isJust (find (==(pntToEnt pnt)) ents) = return [pNTtoPN pnt]+            worker _ = return []+
+ refactorer/RefacConDef.hs view
@@ -0,0 +1,72 @@+module RefacConDef (subConstantDef) where++import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils+import PFE0 (findFile)+import MUtils (( # ))++-- folding against a constant definition++subConstantDef args+  = do let fileName   = args!!0+           beginRow   = read (args!!1)::Int+           beginCol   = read (args!!2)::Int+           endRow     = read (args!!3)::Int+           endCol     = read (args!!4)::Int+       AbstractIO.putStrLn "subConstantDef"++       (inscps, exps, mod, tokList) <- parseSourceFile fileName+++       let (pnt,subExp) = findDefNameAndExp tokList (beginRow, beginCol) (endRow, endCol) mod+       +       if isPatBind pnt +         then do+           -- constant folding...+           +         else do+           -- function folding+       +           let exp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod+           (mod', ((tokList', m) , _)) <- runStateT (doSubstitution pnt exp mod) ((tokList,False),( 0, 0))+           writeRefactoredFiles False [((fileName, m), (tokList', mod'))]++findDefNameAndExp toks beginPos endPos t+   = fromMaybe (defaultPNT, defaultExp) (applyTU (once_tdTU (failTU `adhocTU` inMatch+                                                                    `adhocTU` inPat)) t)  --CAN NOT USE 'once_tdTU' here.++    where  --The selected sub-expression is in the rhs of a match+          inMatch (match@(HsMatch loc1  pnt pats rhs ds)::HsMatchP)+            | locToExp beginPos endPos toks rhs /= defaultExp+            = Just (pnt, locToExp beginPos endPos toks rhs)+          inMatch _ = Nothing++          --The selected sub-expression is in the rhs of a pattern-binding+          inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+            | locToExp beginPos endPos toks rhs /= defaultExp+            = if isSimplePatBind pat+               then Just (patToPNT ps, locToExp beginPos endPos toks rhs)+               else error "A complex pattern binding can not be generalised!"+          inPat _ = Nothing+++doSubstitution p e = applyTP (stop_tdTP (failTP `adhocTP` subExp))+                       where+                             subExp exp@((Exp _)::HsExpP)+                               | sameOccurrence exp e == False = if toRelativeLocs e == toRelativeLocs exp then +                                                                                   update exp (createFunc p) exp+                                                                             else+                                                                                   mzero+                               | otherwise                     = mzero++                             createFunc pat =+                                              (Exp (HsId (HsVar pat))) +
+ refactorer/RefacDataNewType.hs view
@@ -0,0 +1,138 @@+module RefacDataNewType (refacDataNewType) where+ ++import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils+import PFE0 (findFile)+import MUtils (( # ))+import RefacLocUtils++refacDataNewType args+  = do let fileName   = args!!0+           row   = read (args!!1)::Int+           col   = read (args!!2)::Int+       -- Parse the input file.+       modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName++       -- Find the function that's been highlighted as the refactree++       --let pat = locToPNT fileName (row,col) mod++     {-  let dat+             = findDefNameAndExp tokList+                                 (beginRow, beginCol)+                                 (endRow, endCol)+                                 mod -}++       AbstractIO.putStrLn "Warning: This refactoring may change the strictness properties of the program."+       case checkCursor fileName row col mod of+         Left errMsg -> do error errMsg+         Right dat ->+           do++     --  error (show pat)++             refactoredMod <- applyRefac (addNewType dat) (Just modInfo) fileName+   --    refactoredMod <- forEach exp (beginRow, beginCol) (endRow, endCol) tokList wh p loc pnt pats 1 modInfo fileName ((fileName, False), (tokList, mod))+             writeRefactoredFiles False [refactoredMod]++             AbstractIO.putStrLn "Completed.\n"++addNewType dataDec (_,_, mod) = do+                     let newType = createNewType dataDec+               -- res <- addDecl mod Nothing ([newType], Nothing) True+                     res <- update dataDec newType mod+                     return res++createNewType (dec@(Dec (HsDataDecl loc n tp (c:cs) is)))+  = if checkLength c == False then error "constructor must have exactly one argument."+                    else Dec (HsNewTypeDecl loc n tp c is)++createNewType _ = error "not a valid data expression"++checkLength (HsConDecl src is c i ds)+ = if length ds > 1 then False+                    else True+checkLength _ = True++{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int)+                  -> (Int, Int)+                  -> t          -- ^ The abstract syntax tree.+                  -> [HsDeclP] -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+                    +findDefNameAndExp toks beginPos endPos t+  = fromMaybe []+              (applyTU (once_tdTU (failTU `adhocTU` inDat)) t)++    where+      {---The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats (rhs@(HsBody e)) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just ([loc1], pnt, pats, e, ds)+      inMatch _ = Nothing++      --The selected sub-expression is in the rhs of a pattern-binding+      inPat (pat@(Dec (HsPatBind loc1 ps (rhs@(HsBody e)) ds))::HsDeclP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = if isSimplePatBind pat+              then Just ([loc1], patToPNT ps, [], e, ds)+              else error "A complex pattern binding can not be generalised!"+      inPat _ = Nothing-}++      inDat (dat@(Dec(HsDataDecl loc n tp cs is))::HsDeclP)+        | locToExp beginPos endPos toks dat /= defaultExp+        = if length cs > 1 +            then error "You can only create a newtype from a data type with one constuctor"+            else Just [dat]+      inDat _ = Nothing++--check whether the cursor points to the beginning of the datatype declaration+--taken from RefacADT.hs+-- checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+-- checkCursor fileName row col mod+--  = case locToTypeDecl of+--      Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the type constructor name!")+--      Just decl -> Right decl+--    where+--     locToTypeDecl = find (definesTypeCon (locToPNT fileName (row, col) mod)) (hsModDecls mod)+    +--     definesTypeCon pnt (Dec (HsDataDecl loc c tp xs _)) +--       = if length xs > 1 then error "You must select a data type with only one constructor"+--                          else isTypeCon pnt && (findPNT pnt tp)+--     definesTypeCon pnt _ = False+++checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToTypeDecl of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the type constructor name!")+     Just decl@(Dec (HsDataDecl loc c tp xs _)) ->+         if length xs >1 then Left (error " You must select a data type with only one constructor!")+            else Right decl          +   where+    locToTypeDecl = find (definesTypeCon (locToPNT fileName (row, col) mod)) (hsModDecls mod)+    +    definesTypeCon pnt (Dec (HsDataDecl loc c tp xs _)) +      = isTypeCon pnt && (findPNT pnt tp)+    definesTypeCon pnt _ = False
+ refactorer/RefacDeForest.hs view
@@ -0,0 +1,225 @@+++module RefacDeForest(deforest) where++import PrettyPrint+import PosSyntax hiding(moduleName)+import Maybe+import TypedIds+import ScopeModule+import UniqueNames hiding (srcLoc)+import PNT +import TiPNT +import PFE0+import List  +import RefacUtils+import AbstractIO+import Prelude hiding(putStrLn,putStr)++-- this refactoring trys to eliminate intermeidate list.+deforest args+ = do let fileName= ghead "filename" args     +      modName <- fileNameToModName fileName +      (inscps, exps, mod, tokList) <- parseSourceFile fileName+      let (newDecs,oldPNs,newPNs) = unzip3( head(getHsMatch mod) )   	+      (mod',((tokList',m),_)) <- doFuseCurrent mod tokList newDecs oldPNs newPNs fileName        +      clients<-clientModsAndFiles modName  +      let (clientsMod,clientFiles)= unzip clients         +      refactoredClients <- mapM (doFuseInClient tokList newDecs oldPNs newPNs ) clients+      writeRefactoredFiles False $ ((fileName,m),(tokList',mod')):refactoredClients++  where+	+    simpDec mod = fromJust ( applyTP ( full_tdTP ( idTP `adhocTP` simplifyDecl) ) mod)++    fil x mod = filter notInUsed x where+		notInUsed:: HsDeclP -> Bool+		notInUsed t = not (isDeclaredIn (getPN t) mod )+++    getHsMatch  m = applyTU (full_tdTU (constTU [] `adhocTU`  special ) ) m where+		    special x = do  p <- simplifyDecl x+				    convertDec p +		    simpDec m = applyTP (full_tdTP (idTP `adhocTP` simplifyDecl) ) m+	++    doFuseInClient tokList newDecs oldPNs newPNs (modName,fileName)+      = do (inscps, exps, mod, tokList) <- parseSourceFile fileName+  	   (mod',((tokList',m),_)) <- doFuseClient mod tokList newDecs oldPNs newPNs fileName +	   return ( (fileName,True),(tokList',mod'))++    doFuseCurrent  mod tokList  newDecs oldPNs newPNs fileName +      =runStateT (fus mod) (( tokList,unmodified), (-1000, 0)) where+	fus mod =do mod' <- addDecl mod Nothing (fil newDecs mod , Nothing )True +		    replaceFold mod' oldPNs newPNs  +			+			--replace all :  foldr f n (fb) -> fb_workder f n +++    doFuseClient  mod tokList  newDecs oldPNs newPNs  fileName+	= runStateT ( replaceFold mod  oldPNs newPNs  )  (( tokList,unmodified), (-1000, 0))+++    replaceFold mod  oldPNs newPNs +       = applyTP ( full_tdTP (idTP `adhocTP` convertFold) ) mod +      where+	convertFold  a@(Exp(HsApp(Exp(HsApp (Exp(HsApp fol f )) n ) ) exp  ) ) +	  | (isFunc fol "foldr") && (findPNs  oldPNs (strip exp) ) -- can be fused+	   = do newExp <-  melt exp p newP f n+		update a newExp a +	  | otherwise = return a+           where+	     p = getPNFromExp (strip(exp))+	     newP = newPNs !!  ( fromJust ( elemIndex p oldPNs))++	     convertFold a = return a++	     melt exp pn newPn f n = ( applyTP (full_tdTP (idTP `adhocTP` changeF)) exp)+               where+		changeF exp@(Exp(HsId(HsVar(PNT pName a b ) ) )) +		   | (pName== pn)= return (Exp(HsApp (Exp(HsApp (Exp(HsId(HsVar(PNT newPn a b)))) f )) n ))+	   	   | otherwise = return exp+		changeF exp = return exp+	     ++    getCataFun = applyTU (full_tdTU ( constTU[] `adhocTU` recToCata) ) 	+++strip (Exp(HsApp exp1 exp2 ) ) = strip exp1+strip a@(Exp(_)) = a+                        ++build [] = nameToExp "n"+build (x:xs) = Exp(HsApp (Exp(HsApp (nameToExp "c") x))  (build xs) )++--get PN from a Decl +getPN ( Dec(HsFunBind t ( (HsMatch src (PNT pn _ _) pat body loc):xs))) = pn +++colListCons :: HsIdentI PNT -> [ [HsIdentI PNT]]+colListCons x = if (isListCons x) then  return [x] else return []++-- takes an Exp and return itself if it is an (:) list constructor +isListCons  (HsCon (PNT (PN (UnQual ":") (G (PlainModule "Prelude") ":"_ )) _ _))    = True+isListCons _ = False+++--check if this Exp has a fun call `name` +isFunc f@(Exp (HsId (HsVar (PNT (PN (UnQual fName) _) _  _)))) name = (fName == name)+isFunc _ _= False++++bodyHasCons (HsBody(e)) =  expHasCons e+++expHasCons (Exp (HsInfixApp _ cons _ )) =  isListCons cons+expHasCons (Exp ( HsApp (Exp(HsApp (Exp(HsId(cons)))  exp1 )) exp2   ) ) = isListCons cons+expHasCons (Exp(HsList _)) = True+expHasCons _ = False++++modBody (HsBody e) = (HsBody (modExp e))++modExp  (Exp (HsInfixApp exp1 cons exp2)) = (addWrapper exp1 exp2)+modExp  (Exp ( HsApp (Exp(HsApp cons  exp1)) exp2 ) ) = (addWrapper exp1 exp2)+modExp  (Exp(HsList x )) = build x+modExp a = a+++addWrapper exp1 exp2 = Exp (HsApp (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "c") (S loc0)) Value (N (Just loc0)))))) (  exp1  ))) (exp2  ))+++getPnFromPNT (PNT pn _ _ ) = pn++getPNFromExp exp =  ( fromJust $ applyTU ( once_tdTU ( failTU `adhocTU` idPN) ) exp) where+    idPN :: PName -> Maybe PName+    idPN a = Just a+++--convertDec takes a Dec check if we can convert it into cata form if not simply return itself+--convertDec :: HsDeclP ->  [ [ (HsDeclP,HsName,HsName) ] ] ++convertDec d@( Dec(HsFunBind t [m@(HsMatch src pnt pat body loc)]))= +	if isFormed body then return [ ( (Dec (HsFunBind t [convertMatch m] ) ), getPnFromPNT pnt, getPnFromPNT $ change pnt)]+	else return []  where+		isFormed ((HsBody (Exp (HsCase exp1 alt) ))) = checkAltL alt where+			checkAltL [] = True+			checkAltL (x:xs) = (checkAlt x) && (checkAltL xs) where+				checkAlt (HsAlt src p bo d) = bodyHasCons bo+			+		 +		isFormed ((HsBody(e@(Exp( HsIf e1 e2 e3) ) ))) = checkIfExp e where+			checkIfExp (Exp(HsIf e1 e2 e3 )) = expHasCons e2  && checkIfExp e3+			checkIfExp e = expHasCons e+			--checkIfExp _ = True++			+		isFormed _ = False+	+		-- add "_worker" to the function name in PNT+		change p@(PNT ( PN (UnQual f) (G v1 f1 v2 ) )v3  pat )    = PNT (PN(UnQual (f++"_worker")) (G v1  (f++"_worker") v2 )) v3 pat   +		change p = p++		convertMatch (HsMatch src pnt pat body loc) = HsMatch src (change pnt) ([nameToPat "c",nameToPat "n"] ++ pat) (convertBody body) loc	where+			+			convertBody (HsBody(Exp (HsCase exp alt))) = (HsBody(Exp(HsCase exp (convertAlt alt))))+			convertBody (HsBody(Exp (HsIf e1 e2 e3))) = (HsBody(Exp( HsIf e1 e2' e3'))) where+				e2' = modIfExp e2 +				e3' = modIfExp e3 +				modIfExp (Exp(HsIf a1 a2 a3 )) = (Exp(HsIf a1 (changeFToF (modExp a2) pnt) (modIfExp a3) ))+				modIfExp e = changeFToF (modExp e) pnt+++++			convertAlt [] = []+			convertAlt (x :xs) = (con x) : (convertAlt xs)+			con (HsAlt src p bo d ) = changeFToF (HsAlt src p (modBody bo)d) pnt+++			changeFToF m  p = fromJust $ (applyTP( full_tdTP ( idTP `adhocTP` changeFToF# ) )) m where+			    changeFToF# :: HsExpP -> Maybe  HsExpP+			    changeFToF# e@(Exp(HsId(HsVar pnt))) = if (p==pnt) then  +								return ( Exp(HsApp (Exp(HsApp (Exp(HsId(HsVar (change pnt)))) (nameToExp "c"))) (nameToExp "n") ))+								 else return e+			    changeFToF# a = Just a++			+		+convertDec d = return [] +++-- from recursion to cataformlism++recToCata :: HsDeclP -> [[HsDeclP]]+recToCata d@( Dec(HsFunBind t [m@(HsMatch src pnt pat body loc)])) = if (check body) then return [d] else return [] where+	check b@(HsBody (Exp (HsCase exp1 alt) )) = checkAlt alt+	check _ = False+	checkAlt [ (HsAlt src1 (Pat (HsPTuple _ p1)) bo1 d1), (HsAlt src2 (Pat (HsPTuple _ p2)) bo2 d2) ] = doCheck p1 p2+	checkAlt _ = False  +	doCheck p1 p2 = (match ==1 )where+		match = count p1 p2+		count (x:xs) (y:ys)= if (eq x y) then 0 + count xs ys+                                     else if (isEmptyPList x && isConsPat y) || +                                                (isConsPat x && isEmptyPList y) then count xs ys + 1+				     else 2 + count xs ys+		count _  _ = 0+		isConsPat (Pat (HsPParen (Pat (HsPInfixApp a cons b)))) = isListPNT cons+		isConsPat _ = False++                +                -- takes an Exp and return itself if it is an (:) list constructor +                isListPNT  (PNT (PN (UnQual ":") (G (PlainModule "Prelude") ":"_ )) _ _) = True+                isListPNT  _ = False++                isEmptyPList (Pat (HsPList _ [])) = True+                isEmptyPList _ = False +		+		eq (Pat (HsPId (HsVar (PNT (PN pn1 _)  _ _))))   (Pat (HsPId (HsVar (PNT (PN pn2 _)  _ _)))) = pn2==pn1+		eq _ _ = False+					 +								   +recToCata _ = return []+
+ refactorer/RefacDupDef.hs view
@@ -0,0 +1,161 @@+++module RefacDupDef(duplicateDef {-,duplicateDef1-}) where++import PrettyPrint+import PosSyntax+import Maybe+import TypedIds+import List +import TiPNT +import RefacUtils +import SourceNames+import HsName+import Prelude hiding (putStrLn)+import AbstractIO (putStrLn)++{-This refactoring duplicates a defintion(function binding or simple pattern binding) at same level with a new name+  provided by the user. The new name should not cause name clash/capture. +-}+{-+----Begin: for experimenting interfaces------------------------+duplicateDef1 args+ = do let fileName     = ghead "filename" args +          funNamePath  = args!!1+          newName      = args!!2+      if isVarId newName+       then do modName <-fileNameToModName fileName+               (inscps, _, mod, tokList) <-parseSourceFile fileName    +               case findPNameByPath funNamePath mod of +                  Left errMsg -> putStrLn errMsg+                  Right pn  ->+                     do (mod',((tokList',m),_))<- doDuplicating pn newName (inscps, mod, tokList)+                        if modIsExported mod+                          then do clients <- clientModsAndFiles modName+                                  refactoredClients <-mapM (refactorInClientMod modName (findNewPName newName mod')) clients+                                  writeRefactoredFiles False $ ((fileName,m),(tokList',mod')):refactoredClients +                          else  writeRefactoredFiles False [((fileName,m), (tokList',mod'))]+       else putStrLn "Invalid new function name!"    -}+-----End: for experimenting interfaces---------------------------------  ++duplicateDef args+ = do let fileName = ghead "filename" args +          newName  = args!!1 +          row      = read (args!!2)::Int+          col      = read (args!!3)::Int+      if isVarId newName +        then do modName <-fileNameToModName fileName+                (inscps, _, mod, tokList) <-parseSourceFile fileName    +                let pn = pNTtoPN $ locToPNT fileName (row, col) mod                                            +                if (pn /= defaultPN) +                  then do (mod',((tokList',m),_))<- doDuplicating pn newName (inscps, mod, tokList)+                          if modIsExported mod+                           then do clients <- clientModsAndFiles modName+                                   refactoredClients <- mapM (refactorInClientMod modName +                                                              (findNewPName newName mod')) clients+                                   writeRefactoredFiles False $ ((fileName,m),(tokList',mod')):refactoredClients +                           else  writeRefactoredFiles False [((fileName,m), (tokList',mod'))]+                  else error "Invalid cursor position!" +        else error "Invalid new function name!"   +   +doDuplicating pn newName (inscps, mod, tokList)+   = runStateT (applyTP ((once_tdTP (failTP `adhocTP` dupInMod+                                            `adhocTP` dupInMatch+                                            `adhocTP` dupInPat+                                            `adhocTP` dupInLet+                                            `adhocTP` dupInAlt+                                            `adhocTP` dupInLetStmt)) `choiceTP` failure) mod)+                                     ((tokList,unmodified), (-1000))  -- the (-1000) should be deleted.+        where          +        --1. The definition to be duplicated is at top level.+        dupInMod (mod@(HsModule loc name exps imps ds):: HsModuleP)   +          |findFunOrPatBind  pn ds/=[]=doDuplicating' inscps mod pn  +        dupInMod _ =mzero++        --2. The definition to be duplicated is a local declaration in a match+        dupInMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+          |findFunOrPatBind pn ds/=[]=doDuplicating' inscps match pn                                                    +        dupInMatch _ =mzero++        --3. The definition to be duplicated is a local declaration in a pattern binding+        dupInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+          |findFunOrPatBind pn ds/=[]=doDuplicating' inscps pat pn                    +        dupInPat _=mzero+  +        --4: The defintion to be duplicated is a local decl in a Let expression+        dupInLet (letExp@(Exp (HsLet ds e))::HsExpP)+          |findFunOrPatBind pn  ds/=[]=doDuplicating' inscps letExp pn +        dupInLet _=mzero+                +        --5. The defintion to be duplicated is a local decl in a case alternative.+        dupInAlt (alt@(HsAlt loc p rhs ds)::(HsAlt (HsExpP) (HsPatP) [HsDeclP]))+          |findFunOrPatBind pn ds/=[]=doDuplicating'  inscps alt pn +        dupInAlt _=mzero+      +        --6.The definition to be duplicated is a local decl in a Let statement.+        dupInLetStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP]))+           |findFunOrPatBind pn  ds /=[]=doDuplicating' inscps letStmt pn +        dupInLetStmt _=mzero++        +        failure=idTP `adhocTP` mod+          where+            mod (m::HsModuleP)+              = error "The selected identifier is not a function/simple pattern name, or is not defined in this module "+ +        findFunOrPatBind pn ds = filter (\d->isFunBind d || isSimplePatBind d) $ definingDecls [pn] ds True False++        doDuplicating' inscps parent pn +           = do let decls           = hsDecls parent  +                    duplicatedDecls = definingDecls [pn] decls True False+                    (after,before)  = break (defines pn) (reverse decls)+                (f,d) <- hsFDNamesFromInside parent  +                 --f: names that might be shadowd by the new name, d: names that might clash with the new name+                dv <- hsVisibleNames pn decls --dv: names may shadow new name+                let inscpsNames = map ( \(x,_,_,_)-> x) $ inScopeInfo inscps+                    vars        = nub (f `union` d `union` dv)+                if elem newName vars || (isInScopeAndUnqualified newName inscps && findEntity pn duplicatedDecls) +                   then error ("The new name'"++newName++"' will cause name clash/capture or ambiguity problem after "+                               ++ "duplicating, please select another name!")+                   else do newBinding<-duplicateDecl decls pn newName                            +                           return (replaceDecls parent (reverse before++ newBinding++ reverse after)) +   +++--Find the the new definition name in PName format. +findNewPName name +  =(fromMaybe defaultPN). applyTU (once_buTU (failTU `adhocTU` worker))+     where +        worker  pname +           |pNtoName pname == name = Just pname+        worker _ =mzero++                   +--Do refactoring in the client module.+-- that is to hide the identifer in the import declaration if it will cause any problem in the client module.+refactorInClientMod serverModName newPName (modName, fileName)+  = do (inscps, exps,mod ,ts) <- parseSourceFile fileName+       let modNames = willBeUnQualImportedBy serverModName mod   +       if isJust modNames && needToBeHided (pNtoName newPName) exps mod+        then do (mod', ((ts',m),_))<-runStateT (addHiding serverModName mod [newPName]) ((ts,unmodified),fileName)+                return ((fileName,m), (ts',mod')) +        else return ((fileName,unmodified),(ts,mod))+   where+     needToBeHided name exps mod+         =usedWithoutQual name (hsModDecls mod)+          || causeNameClashInExports newPName name mod exps++--Check here:+--get the module name or alias name by which the duplicated definition will be imported automatically.+willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName]+willBeUnQualImportedBy modName mod+   = let imps = hsModImports mod+         ms   = filter (\(HsImportDecl _ (SN modName1 _) qualify  as h)->modName==modName1 && (not qualify) && +                          (isNothing h || (isJust h && ((fst (fromJust h))==True)))) imps+         in if ms==[] then Nothing+                      else Just $ nub $ map getModName ms++         where getModName (HsImportDecl _ (SN modName _) qualify  as h)+                 = if isJust as then simpModName (fromJust as)+                                else modName+               simpModName (SN m loc) = m
+ refactorer/RefacDupTrans.hs view
@@ -0,0 +1,716 @@+module RefacDupTrans where+import System.IO.Unsafe+import PosSyntax hiding (ModuleName, HsName, SN)+import SourceNames +import ScopeModule+import UniqueNames hiding (srcLoc)+import HsName+import HsLexerPass1+import PNT +import TiPNT+import SimpleGraphs(reverseGraph,reachable)+import HsTokens+import PrettyPrint+import RefacTypeSyn+import RefacLocUtils+import Data.Char+import GHC.Unicode+import AbstractIO+import Maybe+import List+import Data.Function+import RefacUtils+import LocalSettings+import DuplicateCode (foldDo)++type NameToCall    = String+type NameToReplace = String+type Module        = String+type FileName      = String++refacDupTrans args+  = do         +       AbstractIO.putStrLn "refacDupTrans"+       {- let fileName = ghead "fileName'" args +           beginRow         = read (args!!1)::Int+           beginCol         = read (args!!2)::Int+           endRow           = read (args!!3)::Int+           endCol           = read (args!!4)::Int+       -- collect the answers...+       (inscps, exps, mod, tokList)<-parseSourceFileOld fileName+       let subExp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod+       expression <- AbstractIO.readFile transFilePath+       let expressions = (read expression)::([ [(HsExpP, String)] ])+ +       let clonedExps = concat (filter (subExp `myElem`) expressions) +           groupedClones = groupClones clonedExps  -}+           +       cloneCall <- AbstractIO.readFile classTransformPath+       answers   <- AbstractIO.readFile answerFilePath  +        +       let clonedExps = pruneCloneClass (read cloneCall::[(HsExpP, String, String)]) (filter (isAlpha) answers) +           groupedClones = groupClones clonedExps   +               +       if clonedExps == []+         then error "Please use introduce a new definition instead; selected expression is not a member of a clone class!"+         else do +            -- make sure all the files we need to modify+            -- are added to the project. Otherwise we run into "module not found"+            -- issues...+            let names = nub $ concatMap (map snd) groupedClones+            mods <- (mapM parseSourceFile names)+            destMods <- mapM fileNameToModName names +            -- addFile names+            res <- createParameters (makeFullASTList mods) 1 (createAbs (map fst clonedExps)) +            let pns  = nub $ concatMap definedPNs [(fromJust res)]+            results <- callFindSafeModules destMods (myZip mods names groupedClones) pns res+            writeRefactoredFiles False results+            AbstractIO.putStrLn "Clone Transformation Completed.\n" +makeFullASTList gf= [mod | (inscps, exps, mod, tokList) <- gf]+++pruneCloneClass :: [ (HsExpP, String, String) ] -> String -> [ (HsExpP, String) ]+pruneCloneClass ((x,y,z):xs) ('y':ys) = (x,y) : pruneCloneClass xs ys+pruneCloneClass (x:xs) ('n':ys) = pruneCloneClass xs ys+pruneCloneClass _ _ = []+++retainLocs [] _ = []+retainLocs _ [] = []+retainLocs ((i,e,_,_):ms) (((_,_),(t,m)):ts)+ = (i,e,m,t) : retainLocs ms ts++myZip :: [(a,b,c,d)] -> [e] -> [f] -> [(a,b,c,d,e,f)]+myZip ((a,b,c,d):as) (e:bs) (f:fs) = (a,b,c,d,e,f) : myZip as bs fs+myZip _      _   _    = []+++-- find safe Module+-- this function checks to see where there is a safe place+-- to put the abstraction.+-- +-- given the list of the files that we are transforming,+-- we introduce a cyclic inclusion if the module+-- we want to introduce the abstraction already imports+-- another module.... Therefore the module cannot import+-- any of the modules from our transformation set.+-- findSafeModule :: Term t => [ ModuleName ] -> t -> [Bool]+findSafeModule destMods mod+  = not $ or $ map (flip elem mod) (map fst destMods)+++findSafeModules destmods [] _ = -- basically we can't do imports, everywhere needs to define abstraction!+                                  return Nothing+findSafeModules destmods ((inscps, exps, mod, tokList, fileName, clonedExps@(c:cs)):mods) res+  = do+          modName <- fileNameToModName fileName+          modules <- serverModsAndFiles modName+          if findSafeModule modules destmods +           then +            do AbstractIO.putStrLn $ show fileName+               -- add the abstraction in this module...+               -- we also need to make sure all other modules import this module...+               ((f,m), (newToks, newMod)) <- applyRefac (addAbstraction res (map fst clonedExps))+                                                        (Just (inscps, exps, mod, tokList)) fileName  +                                            +                                                   +               return (Just (((f,m), (newToks, newMod)), mod, fileName))  +           else do rest <- findSafeModules destmods mods res+                   return rest                                 +                   ++callFindSafeModules destMods mods pns res+ = do+       -- mod is the module that everything has to import...+       result <- findSafeModules destMods mods res+       if result == Nothing+            then error "All will introduce cyclic inclusion!"+            else do let (transformation, m, fName) = fromJust result+                    fFile <- fileNameToModName fName+                    transformation' <- addImports mods res m pns fName fFile +                    -- we also need to transform the module we are left with+                    -- i.e. the module where we have added the abstraction...                    +                    return (transformation:transformation')+       +addImports [] _ _ _ _ _ = return []+addImports (t@(inscps, exps, mod, tokList, fileName, clonedExps@(c:cs)):ms) res m pns fFile f+ | mod == m  = do+                  rest <- addImports ms res m pns fFile f+                  return rest+ | otherwise = do modified <- addImports' t res pns fFile f+                  rest <- addImports ms res m pns fFile f+                  return (modified: rest)+                  +addImports' (inscps, exps2, mod, tokList, fileName, clonedExps@(c:cs)) res pns fFile f+ = do+      ((f,m), (newToks, newMod)) <- applyRefac (addImport'' res pns fFile f (map fst clonedExps)) (Just (inscps, exps2, mod, tokList)) fileName+      return ((f,m), (newToks, newMod))+++addImport'' res pns fFile f exps (_,_,t)+ = do +      replacedT <- replaceOccurrences t res exps+      t' <- addImport fFile f pns replacedT+      return t'+      ++-- transformClones takes a list of [(HsExpP, String)]+-- parses the module of String, and performs a +-- "addAbstraction" over that module and writes the +-- refactoredFiles. +--+-- transformClones should be called from a mapM_ to allow+-- the monadic effect to be preserved.+transformClones destMods res f clonedExps@(c:cs)+ = do+     let fileName = snd c+          +     currentMod <- fileNameToModName fileName+     origFile <- fileNameToModName f++     let pns  = nub $ concatMap definedPNs [(fromJust res)]++     (inscps, exps, mod, tokList)<-parseSourceFileOld fileName+     ((f2,m), (newToks, newMod)) <- applyRefac (extractExpression res pns fileName origFile currentMod (map fst clonedExps))+                                               (Just (inscps, exps, mod, tokList)) fileName+     return ((f2,m), (newToks, newMod))                                          +                                               +                                               +-- group the expressions by their defining module.+-- groupBy :: (a -> a -> Bool) -> [a] -> [[a]]+groupClones :: [ (HsExpP, String) ] -> [ [(HsExpP, String)] ]++groupClones clones+  = groupBy checkFile clones+     where+      checkFile :: Eq b => (a,b) -> (a,b) -> Bool+      checkFile (a,b) (c,d) = b == d+++myElem :: HsExpP -> [(HsExpP, String)] -> Bool+myElem _ [] = False+myElem e ((x,y):xs) + | toRelativeLocs e == toRelativeLocs x    = True+ | otherwise = myElem e xs+ +extractExpression decs pns fFile f fileName exps (_,_,t)+ | f /= fileName+     = do+      -- find the expressions in t that are associated+      -- with exps. Replace these expressions with a call+      -- to the abstactions.+      replacedT <- replaceOccurrences t decs exps+      return replacedT+ | otherwise = do replacedT <- replaceOccurrences t decs exps+                  return replacedT+++--add a definition name to the import. If the module is not imported yet, then create a new import decl.+-- addImport::String->HsName.ModuleName->[PName]->HsModuleP->HsModuleP+addImport destFileName destModName pns mod@(HsModule _ _  _ imp _)+  =if itemIsImportedByDefault destModName mod     -- Is the definition name explicitly imported?+    then return mod                               -- Yes. Do nothing.+    else if itemsAreExplicitlyImported destModName mod  --Is the module imported and some of its items are explicitly imported?+          then addVarItemInImport1 destModName pns mod -- Yes. Then add the definition name to the list.+          else addImportDecl mod (modNameToStr destModName) False  Nothing False (map pNtoName pns)+               --addImportDecl mod (mkImportDecl destFileName destModName  False (map pNtoName pns)) --Create a new import decl.++  where  +   {- Compose a import declaration which imports the module specified by 'modName',+      and only imports the definition spcified by 'e'.+    -}+   +   itemsAreExplicitlyImported serverModName (HsModule _ _ _ imps _)+     = any (isExplicitlyImported serverModName) imps+    where+       isExplicitlyImported serverModName ((HsImportDecl _ (SN modName _) _ _ h)::HsImportDeclP)+         = serverModName == modName && isJust h && not (fst (fromJust h))++++-- are items defined in the serverModName imported by the current module by default?+itemIsImportedByDefault serverModName (HsModule _ _ _ imps _) +  = any (isImportedByDefault'  serverModName) imps+  where+    isImportedByDefault' serverModName ((HsImportDecl _ (SN modName _) _ _ h)::HsImportDeclP)+       = serverModName == modName && ( isNothing h  || (isJust h && fst(fromJust h)))+++addVarItemInImport1 serverModName pns mod+   = applyTP ((once_tdTP (failTP `adhocTP` inImport))  `choiceTP` idTP) mod+  where +    inImport (imp@(HsImportDecl loc@(SrcLoc fileName _ row col) (SN modName l) qual as (Just (b,ents))):: HsImportDeclP)+      | serverModName == modName && not b  +     =  +          addItemsToImport serverModName  Nothing (Left (map pNtoName pns)) imp+    inImport x = mzero +                  +addAbstraction decs exps (_,_,t)+  = do+       +       replacedT <- replaceOccurrences t decs exps+       t' <- addDecl replacedT Nothing (maybeToList decs, Nothing) True+       t'' <- addItemsToExport t' Nothing False (Left (map declToName (maybeToList decs))) +       return t''+++-- replaceOccurrences :: (Term t, MonadPlus m, Monad m) => t -> [ HsDeclP ] -> [ [HsExpP] ] -> m t+-- replaceOccurrences t [] _ = return t+replaceOccurrences t _ [] = return t+replaceOccurrences t dec exps+  = do+       res <- repOcc dec exps t+       -- rest <- replaceOccurrences res dec expss+       return res++repOcc Nothing _ t = return t+repOcc (Just dec) es t+  = do+      -- get the expression on the RHS of Abstraction,+      -- and abstraction name for the call.+      let (name, rhs) = getNameAndRHS dec+      newT <- repOcc' name rhs es t+      return newT     +       where+         getNameAndRHS (Dec (HsFunBind _ [HsMatch _ name _ (HsBody e) _]))+           = (name, e)++repOcc' _ _ [] t = return t+repOcc' name rhs (x:xs) t+  = do+      res <- applyTP (once_tdTP (failTP `adhocTP` inExp)) t+      -- error $ show x+      rest <- repOcc' name rhs xs res+      return rest+    where+      inExp e@(Exp (HsDo e1))+       = do+             let new = foldAgainstAbs [] x rhs+             -- we need to actually find the bit to update...+             las <- (getStmtList2 rhs)+             -- error $ show las+             if las == [] +               then mzero+               else do+                      let (p, newStmts) = foldStmt' (head las) [] (createFunc name (rmAllLocs new)) e1 x+                      if p +                       then +                        do+                           -- error $ show (e1, rhs)+                           --    new' = (render.ppi) new+                           -- n' <- update e (Exp (HsDo (HsLast (createFunc name new)))) e+                           -- n' <- RefacUtils.delete e e+                           lift $ AbstractIO.putStrLn $ show new+                           n'' <- update e (Exp (HsDo newStmts))  e+                           return n''+                       else mzero++      inExp e@(Exp (HsParen e1))+        | sameOccurrence e x+            = do +                 let new = foldAgainstAbs [] e rhs+                     new' = (render.ppi) new+                 +                 e' <- update e (Exp (HsParen (createFunc name new))) e+                 return e'++       -- | otherwise = mzero+      inExp (e::HsExpP)+        | sameOccurrence e x+            = do +                 let new = foldAgainstAbs [] e rhs+                     new' = (render.ppi) new+                 e' <- update e (createFunc name new) e+                 return e'+      inExp e = +                   mzero++getStmtList2 (Exp (HsDo s))+  = return [last $ getStmtList s]+getStmtList2 _ = return []+++foldStmt' :: HsStmtAtomP -> [HsPatP] -> HsExpP -> HsStmtP -> HsExpP -> (Bool, HsStmtP)+foldStmt' ss p e s (Exp (HsDo s1)) = foldStmt ss p e  s s1+foldStmt' ss p e s1 _ = (False, s1)+  +foldStmt :: HsStmtAtomP -> [HsPatP] -> HsExpP -> HsStmtP -> HsStmtP -> (Bool, HsStmtP)+foldStmt ss p e s1@(HsGenerator _ p1 e1 s0) s2@(HsGenerator _ p2 e2 s3)+ | p1 == p2 && sameOccurrence e1 e2 = foldStmt ss (p++[p1]) e s0 s3+ | otherwise = (False, s1)+foldStmt (HsLastAtom ee) p e s1@(HsQualifier e1 s3) (HsLast e2)+ | isReturn ee && e2 == defaultExp = (True, newStmt)+ | sameOccurrence e1 e2 = (True, s1)+      where+          newStmt = (HsGenerator loc0 (Pat (HsPTuple loc0 p)) e s3)+foldStmt ee p e s1@(HsQualifier e1 s0) s2@(HsQualifier e2 s3)+ | sameOccurrence e1 e2 = foldStmt ee p e s0 s3+ | otherwise = (False, s1)+foldStmt (HsLastAtom ee) p e s1@(HsLast e1) s2@(HsLast e2)+ | isReturn ee && e2 == defaultExp = (True, newStmt)+ | e2 == defaultExp = (True, s1)+ | sameOccurrence e1 e2 && isReturn ee = (True, newStmt)+ | sameOccurrence e1 e2 = (True, s1)+         where +            newStmt = (HsGenerator loc0 (Pat (HsPTuple loc0 p)) e s1) +foldStmt ee p e s1 s2 = (False, s1)+ +isReturn e = (render.ppi) (head (flatternApp e)) == "return"+flatternApp :: HsExpP -> [HsExpP]+flatternApp (Exp (HsApp e1 e2)) = flatternApp e1 ++ flatternApp e2+flatternApp (Exp (HsParen e)) = flatternApp e+flatternApp x = [x] +  +grabPNT :: PNT -> [PNT] -> PNT+grabPNT x [] = x+grabPNT x (y:ys)+  | defineLoc x == defineLoc y = y+  | otherwise = grabPNT x ys  +  +checkPNTInPat :: [HsPatP] -> PNT -> Bool+checkPNTInPat [] _ = False+checkPNTInPat (p:ps) i +        | defineLoc i == (SrcLoc "__unknown__" 0 0 0) = False+        | defineLoc i == defineLoc (patToPNT p) = True+        | otherwise = checkPNTInPat ps i+      +foldAgainstAbs :: [HsPatP] -> HsExpP -> HsExpP -> [ HsExpP ]+foldAgainstAbs _ e1 e2 + | e1 == defaultExp || e2 == defaultExp = []+foldAgainstAbs pats e@(Exp (HsId (HsVar x))) (Exp (HsId (HsVar y)))+ | x == y && isTopLevelPNT x = []+ | x == y && isTopLevelPNT x = []+ | checkPNTInPat pats x  = []+ | otherwise = [e]+foldAgainstAbs pats e@(Exp (HsId (HsCon x))) (Exp (HsId (HsCon y)))+  | x == y    = []+  | otherwise = [e]+foldAgainstAbs pats e@(Exp (HsLit s l1)) (Exp (HsLit s2 l2))+  | l1 == l2  = []+  | otherwise = [(Exp (HsLit loc0 l1))]+foldAgainstAbs pats e@(Exp (HsInfixApp e1 o1 e2)) (Exp (HsInfixApp e3 o2 e4))+  = (e1' ++ o1' ++ e2')+     where+       e1' = foldAgainstAbs pats e1 e3+       o1' +        | o1 == o2  = []+        | otherwise = [Exp (HsId o1)]+       e2' = foldAgainstAbs pats e2 e4+foldAgainstAbs pats e@(Exp (HsApp e1 e2)) (Exp (HsApp e3 e4))+ = (foldAgainstAbs pats e1 e3) ++ (foldAgainstAbs pats e2 e4)+foldAgainstAbs pats e@(Exp (HsNegApp s1 e1)) (Exp (HsNegApp s2 e2))+ = (foldAgainstAbs pats e1 e2)+foldAgainstAbs pats1 e@(Exp (HsLambda pats e1)) (Exp (HsLambda pats2 e2))+ = []+foldAgainstAbs pats e@(Exp (HsLet decs e1)) (Exp (HsLet decs2 e2))+ = (foldAgainstAbs pats e1 e2)+foldAgainstAbs pats e@(Exp (HsIf e1 e2 e3)) (Exp (HsIf e4 e5 e6))+ = (e1' ++ e2' ++ e3')+    where+     e1' = foldAgainstAbs pats e1 e4+     e2' = foldAgainstAbs pats e2 e5+     e3' = foldAgainstAbs pats e3 e6+foldAgainstAbs pats e@(Exp (HsCase e1 alts1)) (Exp (HsCase e2 alts2))+  = []+foldAgainstAbs pats e@(Exp (HsParen e1)) (Exp (HsParen e2))+ = (foldAgainstAbs pats e1 e2)+foldAgainstAbs pats (Exp (HsParen e1)) e2+ = foldAgainstAbs pats e1 e2+foldAgainstAbs pats e1 (Exp (HsParen e2))+ = foldAgainstAbs pats e1 e2 +foldAgainstAbs pats (Exp (HsTuple es1)) (Exp (HsTuple es2))+ = concat (foldAgainstAbs' pats es1 es2)+foldAgainstAbs pats (Exp (HsList es1)) (Exp (HsList es2))+ = concat (foldAgainstAbs' pats es1 es2)+foldAgainstAbs pats (Exp (HsLeftSection e1 o1)) (Exp (HsLeftSection e2 o2))+ = e1' ++ o1'+   where+      e1' = foldAgainstAbs pats e1 e2+      o1'+       | o1 == o2 = []+       | otherwise = [Exp (HsId o1)]+foldAgainstAbs pats (Exp (HsRightSection o1 e1)) (Exp (HsRightSection o2 e2))+ = o1' ++ e1'+  where+    e1' = foldAgainstAbs pats e1 e2+    o1'+     | o1 == o2 = []+     | otherwise = [Exp (HsId o1)]+foldAgainstAbs pats (Exp (HsEnumFrom e1)) (Exp (HsEnumFrom e2))+ = foldAgainstAbs pats e1 e2+foldAgainstAbs pats (Exp (HsEnumFromTo e1 e2)) (Exp (HsEnumFromTo e3 e4))+ = foldAgainstAbs pats e1 e2 ++ foldAgainstAbs pats e3 e4+foldAgainstAbs pats (Exp (HsEnumFromThen e1 e2)) (Exp (HsEnumFromThen e3 e4))+ = foldAgainstAbs pats e1 e2 ++ foldAgainstAbs pats e3 e4+foldAgainstAbs pats (Exp (HsEnumFromThenTo e1 e2 e3)) (Exp (HsEnumFromThenTo e4 e5 e6))+ = foldAgainstAbs pats e1 e4 ++ foldAgainstAbs pats e2 e5 ++ foldAgainstAbs pats e3 e6 +foldAgainstAbs pats (Exp (HsAsPat i1 e1)) (Exp (HsAsPat i2 e2))+ = i1' ++ e1'+   where+     e1' = foldAgainstAbs pats e1 e2+     i1'+      | i1 == i2 = []+      | otherwise = [Exp (HsId (HsVar i1))]+foldAgainstAbs pats (Exp (HsIrrPat e1)) (Exp (HsIrrPat e2))+ = foldAgainstAbs pats e1 e2 +foldAgainstAbs pats (Exp (HsDo e1)) (Exp (HsDo e2))+ = foldAgainstAbsStmts pats e1 e2    +foldAgainstAbs pats e1 e2 = [e1] +foldAgainstAbsAlt pats as _ = as++foldAgainstAbs' pats [] [] = []+foldAgainstAbs' p x  [] = []+foldAgainstAbs' p [] x  = [] +foldAgainstAbs' p (e:es) (x:xs) = foldAgainstAbs p e x : foldAgainstAbs' p es xs++foldAgainstAbsStmts pats a@(HsGenerator _ p1 e1 s1) b@(HsGenerator _ p2 e2 s2)+ = foldAgainstAbs (pats++[p1]++[p2]) e1 e2 ++ foldAgainstAbsStmts (pats++[p1]++[p2]) s1 s2+foldAgainstAbsStmts pats (HsQualifier e1 s1) (HsQualifier e2 s2)+ = foldAgainstAbs pats e1 e2 ++ foldAgainstAbsStmts pats s1 s2+foldAgainstAbsStmts pats (HsLast e1) (HsLast e2)+ = foldAgainstAbs pats e1 e2+foldAgainstAbsStmts pats (HsLast e1) (HsQualifier e2 s1)+ = foldAgainstAbs pats e1 e2++-- createParameters :: HsExpP -> HsDeclP+-- createParameters mod n [] = return []+createParameters mods n Nothing = return Nothing+createParameters mods n (Just e)+   = do+        numParams <- countParams e+        let nameParams = mkNewNames (length numParams) e []+        +        e' <- renameNormals e nameParams+        let newDec = createDec (transformBindings e') nameParams+        return (Just newDec)+        where+          transformBindings (Exp (HsDo stmts))+           = (Exp (HsDo (transformBind [] stmts)))+          transformBindings e = e+          +          transformBind pats (HsGenerator s p1 e1 stmts)+            = (HsGenerator s p1 e1 (transformBind (pats++[p1]) stmts))+          transformBind pats (HsQualifier e stmts)+            = (HsQualifier e (transformBind pats stmts))+          transformBind pats (HsLast e)+           | e == defaultExp+              = (HsLast (Exp (HsApp (nameToExp "return") (Exp (HsTuple (getPats pats))))))+           | pats /= [] = (HsQualifier e (HsLast (Exp (HsApp (nameToExp "return") (Exp (HsTuple (getPats pats)))))))+           | otherwise = (HsLast e)+        +          +          getPats [] = []+          getPats (p:ps) = nameToExp (pNTtoName (patToPNT p)) : getPats ps+        +          createDec e' nameParams+            = Dec (HsFunBind loc0 [HsMatch loc0 (nameToPNT newName) +                                                (map nameToPat nameParams)+                                                (HsBody e') +                                                [] ])+           +           +          newName = mkNewName "abs" (map pNTtoName (hsPNTs mods)) n+           +          renameNormals e [] = return e+          renameNormals e (x:xs)+             = do+                  e' <- renameANorm e x+                  res <- renameNormals e' xs+                  return res+           where+             renameANorm e x+               = applyTP (once_tdTP (failTP `adhocTP` (inPNT x))) e+             inPNT x (p::PNT) +              | pNTtoName p == "$I" = return (nameToPNT x)+             inPNT _ _ = mzero  +        +          countParams t+            = applyTU (full_tdTU (constTU [] `adhocTU` inPNT)) t+          inPNT (p::PNT)+            | pNTtoName p == "$I" = return [p]+          inPNT x = return []+        +          mkNewNames :: Int -> HsExpP -> [String] -> [String]+          mkNewNames 0 e names = names +          mkNewNames n e names+            = mkNewNames (n-1) e (result : names) +              where+                result = mkNewName "p" (oldNames ++ names) n+                oldNames = map pNTtoName (hsPNTs e)+       +posToExp :: (Term t) => [PosToken] -> t -> [(SimpPos, SimpPos)] -> [HsExpP]+posToExp _ _ [] = []+posToExp toks mod ((x,y):xs) +  = locToExp x y toks mod    : posToExp toks mod xs   ++-- compareExp takes a clone class and tries to+-- figure out which parts can be extracted away or not.++-- we take all the variables out of each expression and compare them+-- the ones that match stay in the abstraction, +createAbs' :: [ HsExpP ] -> [ HsExpP ]+createAbs' [] = []+createAbs' [x] = [compareExp [] x x]+createAbs' (x:y:es)+ = int : createAbs' (y:es)+  where +    int = compareExp [] x y++createAbs'' :: [ HsExpP ] -> Maybe HsExpP+createAbs'' [] = Nothing+createAbs'' [x] = Just x+createAbs'' (x:y:xs)+ = createAbs'' ((compareExp [] x y):xs)++createAbs :: [ HsExpP ] -> Maybe HsExpP +createAbs list+  = let f = createAbs' list in (createAbs'' f)+++compareExp :: [HsPatP] -> HsExpP -> HsExpP -> HsExpP+compareExp pats e@(Exp (HsId (HsVar x))) (Exp (HsId (HsVar y)))+  | x == y && isTopLevelPNT x = e+  | checkPNTInPat pats x = e+  | otherwise = (Exp (HsId (HsVar (nameToPNT "$I"))))+compareExp pats e@(Exp (HsId (HsCon x))) (Exp (HsId (HsCon y)))+  | x == y    = e+  | otherwise = (Exp (HsId (HsVar (nameToPNT "$I"))))+compareExp pats e@(Exp (HsLit s l1)) (Exp (HsLit s2 l2))+  | l1 == l2  = e+  | otherwise = (Exp (HsId (HsVar (nameToPNT "$I"))))+compareExp pats e@(Exp (HsInfixApp e1 o1 e2)) (Exp (HsInfixApp e3 o2 e4))+  = Exp (HsInfixApp e1' o1' e2')+     where+       e1' = compareExp pats e1 e3+       o1' +        | o1 == o2  = o1+        | otherwise = HsVar (nameToPNT "$I")+       e2' = compareExp pats e2 e4+compareExp pats e@(Exp (HsApp e1 e2)) (Exp (HsApp e3 e4))+ = Exp (HsApp (compareExp pats e1 e3) (compareExp pats e2 e4))+compareExp pats e@(Exp (HsNegApp s1 e1)) (Exp (HsNegApp s2 e2))+ = Exp (HsNegApp s1 (compareExp pats e1 e2))+compareExp pats1 e@(Exp (HsLambda pats e1)) (Exp (HsLambda pats2 e2))+ = Exp (HsLambda pats (compareExp pats1 e1 e2))+compareExp pats e@(Exp (HsLet decs e1)) (Exp (HsLet decs2 e2))+ = Exp (HsLet decs (compareExp pats e1 e2))+compareExp pats e@(Exp (HsIf e1 e2 e3)) (Exp (HsIf e4 e5 e6))+ = Exp (HsIf e1' e2' e3')+    where+     e1' = compareExp pats e1 e4+     e2' = compareExp pats e2 e5+     e3' = compareExp pats e3 e6+compareExp pats e@(Exp (HsCase e1 alts1)) (Exp (HsCase e2 alts2))+ = Exp (HsCase (compareExp pats e1 e2) (compareAlt pats alts1 alts2))+compareExp pats e@(Exp (HsParen e1)) (Exp (HsParen e2))+ = Exp (HsParen (compareExp pats e1 e2))+compareExp pats (Exp (HsParen e1)) e2+ = compareExp pats e1 e2+compareExp pats e1 (Exp (HsParen e2))+ = compareExp pats e1 e2 +compareExp pats (Exp (HsList es1)) (Exp (HsList es2))+ = Exp (HsList (compareExp' pats es1 es2))+compareExp pats (Exp (HsTuple es1)) (Exp (HsTuple es2))+ = Exp (HsTuple (compareExp' pats es1 es2))+compareExp pats (Exp (HsLeftSection e1 i1)) (Exp (HsLeftSection e2 i2))+ = Exp (HsLeftSection (compareExp pats e1 e2) i2')+   where+     i2' +       | i1 == i2 = i1 +       | otherwise = HsVar (nameToPNT "$I")+compareExp pats (Exp (HsRightSection i1 e1)) (Exp (HsRightSection i2 e2))+ = Exp (HsRightSection i1' (compareExp pats e1 e2))+   where+     i1' +      | i1 == i2 = i1+      | otherwise = HsVar (nameToPNT "$I" )+compareExp pats (Exp (HsEnumFrom e1)) (Exp (HsEnumFrom e2))+ = Exp (HsEnumFrom (compareExp pats e1 e2))+compareExp pats (Exp (HsEnumFromTo e1 e2)) (Exp (HsEnumFromTo e3 e4))+ = Exp (HsEnumFromTo (compareExp pats e1 e3) (compareExp pats e2 e4))+compareExp pats (Exp (HsEnumFromThen e1 e2)) (Exp (HsEnumFromThen e3 e4))+ = Exp (HsEnumFromThen (compareExp pats e1 e3) (compareExp pats e2 e4))+compareExp pats (Exp (HsEnumFromThenTo e1 e2 e3)) (Exp (HsEnumFromThenTo e4 e5 e6))+ = Exp (HsEnumFromThenTo (compareExp pats e1 e4) (compareExp pats e2 e5) (compareExp pats e3 e6))+compareExp pats (Exp (HsAsPat i1 e1)) (Exp (HsAsPat i2 e2))+ = Exp (HsAsPat i1' (compareExp pats e1 e2))+   where+    i1' +     | i1 == i2 = i1+     | otherwise = (nameToPNT "$I")+compareExp pats (Exp (HsIrrPat e1)) (Exp (HsIrrPat e2))+ = Exp (HsIrrPat (compareExp pats e1 e2))+compareExp pats e1@(Exp (HsDo stmts1)) e2@(Exp (HsDo stmts2))+ = Exp (HsDo (compareStmts pats stmts1 stmts2))+compareExp pats e1 e2 = (Exp (HsId (HsVar (nameToPNT "$I"))))+compareAlt pats as _ = as++compareStmts pats (HsGenerator s p1 e1 s1) (HsGenerator _ p2 e2 s2)+ = HsGenerator s p1 (compareExp (pats++[p1]++[p2]) e1 e2) (compareStmts (pats++[p1]++[p2]) s1 s2)+compareStmts pats (HsQualifier e1 stmts1) (HsQualifier e2 stmts2)+ = HsQualifier (compareExp pats e1 e2) (compareStmts pats stmts1 stmts2)+compareStmts pats (HsLast e1) (HsLast e2)+ = HsLast (compareExp pats e1 e2)+compareStmts pats s1 s2 = s1+++compareExp' p [] [] = []+compareExp' p _ [] = []+compareExp' p [] _ = []+compareExp' p (e:es) (x:xs) = compareExp p e x : compareExp' p es xs+       +catPositions :: String -> [ String ]+catPositions [] = []+catPositions ('[':ps)+   = grabbed : catPositions ps'+      where +        (grabbed, ps') = (grabPositions ps, dropPositions ps)+        grabPositions [] = []+        grabPositions (']':xs) = []+        grabPositions ('<':'&':'>':ps)+          = ":" ++ grabPositions ps+        grabPositions (x:xs) = x : grabPositions xs+        +        dropPositions [] = []+        dropPositions (']':xs) = xs+        dropPositions (x:xs) = dropPositions xs++        +prunePositions :: String -> [String] -> [ [(SimpPos, SimpPos)] ]+prunePositions [] [] = []+prunePositions [] _  = []+prunePositions _ []  = []+prunePositions as (p:ps) +   = createSet as p : prunePositions remAnswers ps+    where+      remAnswers = drop ((length (filter (==':') p)) + 1) as+    +      createSet :: String -> String -> [ (SimpPos, SimpPos) ]+      createSet [] [] = []+      createSet [] _  = []+      createSet _  [] = []+      createSet ('y':xs) ps    +         = ((read p2)::(SimpPos, SimpPos)) : createSet xs ps'+           where+             p2  = getPos ps +             ps' = dropPos ps+             getPos [] = []+             getPos (':':xs) = []+             getPos (x:xs)   = x : getPos xs+             +             dropPos [] = []+             dropPos (':':xs) = xs+             dropPos (x:xs)   = dropPos xs+         +      createSet ('n':xs) ps+         = createSet xs ps'+            where+             ps' = dropPos ps+             +             dropPos [] = []+             dropPos (':':xs) = xs+             dropPos (x:xs)   = dropPos xs++      createSet _ _ = []++
+ refactorer/RefacDuplicates.hs view
@@ -0,0 +1,314 @@+module RefacDuplicates(detectDuplicates,detectSpecDuplicates) where++import PrettyPrint+import PosSyntax+import Maybe+import TypedIds++import UniqueNames hiding (srcLoc)+import PNT +import TiPNT ++import List  +import RefacUtils+import PFE0 (findFile, getCurrentModuleGraph)+import AbstractIO+import Prelude hiding (putStrLn, putStr)+import Char+import Time++type Drip = (String, LocInfo)+type ExpDrip = (HsExpP, LocInfo)+type Bucket = [Drip]+type ExpBucket = [ExpDrip]+type BucketGroup = [Bucket]+type ExpBucketGroup = [ExpBucket]+type LocInfo = (String, Int, Int)+++-- **************************************************+-- *****                                        *****+-- ***** File:        RefacDuplicates.hs        *****+-- ***** Module Name: RefacDuplicates           *****+-- ***** Author:      Jonathan Cowie            *****+-- ***** Email:       jrc3@kent.ac.uk           *****+-- *****                                        *****+-- ***** Created as a summer internship project *****+-- ***** between July and August 2004           *****+-- *****                                        *****+-- **************************************************++detectDuplicates args+ = do let fileName  = args!!0+      timeone <- AbstractIO.getClockTime+      modName <- fileNameToModName fileName ++      (inscps, exps, mod, tokList) <- parseSourceFile fileName+      putStrLn "\nComputing list of duplicates from the following files..."+      servers<-serverModsAndFiles modName+      let directory = getDirectory fileName+          servers' = stripServers servers directory+      -- mods <- getModules+      putStrLn $ show servers'+      expmods <- makeFullASTList (map snd servers')+      let dups = getDuplicates expmods+      displayDuplicates dups+      putStrLn "Duplicate code refactoring complete!\n"+      timetwo <- AbstractIO.getClockTime  +      putStrLn $ show $ diffClockTimes timetwo timeone++getDirectory :: String -> String+getDirectory f+  = reverse $ dropWhile (=='/') (dropWhile (/='/') (reverse f))++-- stripServers :: [(ModuleName, String)] -> String -> [(ModuleName, String)]+stripServers [] d = []+stripServers (a@(x,y):xs)  d+ | d == getDirectory y = a : stripServers xs d+ | otherwise           = stripServers xs d+ +detectSpecDuplicates args+ = do let fileName   = args!!0            +          beginRow   = read (args!!1)::Int+          beginCol   = read (args!!2)::Int+          endRow     = read (args!!3)::Int+          endCol     = read (args!!4)::Int+      timeone <- AbstractIO.getClockTime+      modName <- fileNameToModName fileName +      (inscps, exps, mod, tokList) <- parseSourceFile fileName+      let exp=findExp tokList (beginRow, beginCol) (endRow, endCol) mod +      if exp/=defaultExp +        then  -- (mod',((tokList',_),_))<- detectDuplicates' fileName (beginRow,beginCol)(endRow,endCol) mod tokList+              -- writeRefactoredFiles [((fileName,True), (tokList',mod'))]+              do putStrLn "\nComputing list of duplicates from the following files..."+		 mods <- getModules+	 	 putStrLn $ show mods+		 expmods <- makeFullASTList mods+                 let dups = getSpecificDupls exp expmods+                 displayDuplicates dups+                 putStrLn "Duplicate code refactoring complete!\n"+        else  putStrLn "You have not selected a valid expression!\n"+      timetwo <- AbstractIO.getClockTime+      putStrLn $ show $ diffClockTimes timetwo timeone+  where+++  findExp toks beginPos endPos t+     =fromMaybe defaultExp (applyTU (once_tdTU (failTU `adhocTU` exp)) t)+       where exp (e::HsExpP)+               |inScope (getStartEndLoc toks e)=Just e+             exp _ =Nothing                     +             +             inScope (startLoc,endLoc)+                =startLoc>=beginPos &&  endLoc<=endPos  ++++-- ***********************************************************+-- ***** HashTable construction & manipulation functions *****+-- ***********************************************************++--Takes an AST and returns a bucket containing (for each drip) the string of the Expression+--name, and the start & finish locations of the Expression+makeBucket :: Term t => t -> Bucket+makeBucket ast = ghead "makeBucket"  $ applyTU (stop_tdTU (failTU `adhocTU` addHash)) ast+    where addHash (a::HsExpP)= return [(showExp a,getSrcLoc a)]+			      +--Simple hash function, Takes a String and returns an Int+--Currently not used, but left in just in case+hashString :: String -> Int+hashString = fromIntegral . foldr f 0 +    where f c m = ord c + (m * 128) `rem` 1500007+ +--Takes an AST of Type Exp and returns its start location+getSrcLoc :: (Term t) => t -> LocInfo +getSrcLoc exp  = if length lexp == 0 then ("",0,0) else ghead "getSrcLoc" lexp+    where lexp = allSortedLocsRev exp++--Takes an AST and returns the AST with all SrcLocs replaced with loc0+removeSrcLocs :: Term t => t -> t+removeSrcLocs ast =  ghead "removeSrcLocs" $ applyTP (full_tdTP (idTP `adhocTP` noSrc)) ast+    where noSrc (a::SrcLoc) = return loc0++--Takes a single Drip parameter, a Bucket and returns the Bucket with+--all occurences of the Drip parameter removed+removeHashElement :: Drip -> Bucket ->  Bucket+removeHashElement (x,y) xs = [(a,b) | (a,b) <- xs, a /= x]++--Takes an expression and returns a string containing the data constructor name+showExp :: HsExpP -> String+showExp exp = case exp of+              (Exp (HsId (HsVar _))) -> "HsVar"+	      (Exp (HsId (HsCon _))) -> "HsCon"		+              (Exp (HsLit _ _)) -> "HsLit"+              (Exp (HsInfixApp _ _ _)) -> "HsInfixApp"+              (Exp (HsApp _ _)) -> "HsApp"+              (Exp (HsNegApp _ _)) -> "HsNegApp"+              (Exp (HsLambda _ _)) -> "HsLambda"+              (Exp (HsLet _ _)) -> "HsLet"+              (Exp (HsIf _ _ _)) -> "HsIf"+              (Exp (HsCase _ _)) -> "HsCase"+              (Exp (HsDo _)) -> "HsDo"+              (Exp (HsTuple _)) -> "HsTuple"+              (Exp (HsList _)) -> "HsList"+              (Exp (HsParen _)) -> "HsParen"+              (Exp (HsLeftSection _ _)) -> "HsLeftSection"+              (Exp (HsRightSection _ _)) -> "HsRightSection"+              (Exp (HsRecConstr _ _ _)) -> "HsRecConstr"+              (Exp (HsRecUpdate _ _ _)) -> "HsRecUpdate"+              (Exp (HsEnumFrom _)) -> "HsEnumFrom"+              (Exp (HsEnumFromTo _ _)) -> "HsEnumFromTo"+              (Exp (HsEnumFromThen _ _)) -> "HsEnumFromThen"+              (Exp (HsEnumFromThenTo _ _ _)) -> "HsEnumFromThenTo"+              (Exp (HsListComp _)) -> "HsListComp"+              (Exp (HsExpTypeSig _ _ _ _)) -> "HsExpTypeSig"+              (Exp (HsAsPat _ _)) -> "HsAsPat"+              (Exp (HsWildCard)) -> "HsWildCard"+              (Exp (HsIrrPat _)) -> "HsIrrPat"+++--Takes an AST and returns a list of tuples containing the string equivalent of the+-- Expression name, and the start & finish locations of the Expression+genExpList :: (Term t) => t -> [HsExpP]+genExpList ast = ghead "genExpList" $ applyTU (stop_tdTU ( failTU `adhocTU` isExp)) ast+    where isExp (a::HsExpP)= return [a]++--Modified version of allSortedLocs to include Filename+allSortedLocsRev t =(sort.nub.getSrcLocsRev) t++--Modified version of getSrcLocs to include Filename+getSrcLocsRev=runIdentity.(applyTU (full_tdTU (constTU [] `adhocTU` pnt  +                                                       `adhocTU` literalInExp+                                                       `adhocTU` literalInPat)))+        where +            pnt (PNT pname _ (N (Just (SrcLoc f c row col))))=return [(f,row,col)]                +            pnt _=return []+                     +            literalInExp ((Exp (HsLit (SrcLoc f  c row col) _))::HsExpP) = return [(f,row,col)]+            literalInExp (Exp _) =return []++            literalInPat ((Pat (HsPLit (SrcLoc f c row col) _))::HsPatP) = return [(f,row,col)]+            literalInPat (Pat (HsPNeg (SrcLoc f c row col) _)) = return [(f,row,col)]+            literalInPat _ =return []+++++-- **********************************************************+-- ***** Initial duplicate list  construction functions *****+-- **********************************************************++--Takes a Bucket, a DuplicateData List and populates the list with all duplicates+--found in the Bucket+constructBucketGroup :: Bucket -> BucketGroup -> BucketGroup+constructBucketGroup hshtbl dupl+		= case hshtbl of+                      []  -> dupl+                      (x:xs) -> if (dripOccurences x xs) > 1 +			        then (addAllOcc x xs dupl) ++ (constructBucketGroup (removeHashElement x xs) [])+			        else dupl ++ (constructBucketGroup xs [])++--Takes a single Drip parameter, a Bucket and returns the number of times+--the Drip parameter occurs in the Bucket+dripOccurences :: Drip -> Bucket -> Int+dripOccurences (x,y) xs = 1 + length [a | (a,b) <- xs, a == x]++--Takes a single Drip parameter, a Bucket and a BucketGroup and populates it+--with all occurences of Drip in Bucket+addAllOcc :: Drip -> Bucket -> BucketGroup -> BucketGroup+addAllOcc (x,y) xs dupl = ((x,y) : [(a,b) | (a,b) <- xs, a == x])  : dupl++++-- *********************************************************+-- ***** Initial duplicate list verification functions *****+-- *********************************************************++--Takes a BucketGroup parameter and populates it with full expressions from the+--HsExpP list taken as the first parameter+--Returns ExpBucketGroup+populateBucketGroup :: [HsExpP] -> BucketGroup -> ExpBucketGroup+populateBucketGroup expl [] = []+populateBucketGroup expl (x:xs) = map (getExp expl) x : populateBucketGroup expl xs+    where getExp ast dupl = ghead "populateBucketGroup" (catMaybes $ map (getMatch dupl) ast)+          getMatch (strexp, locinfo) exp+            | (getSrcLoc exp) == locinfo && strexp == showExp exp  = Just ((removeSrcLocs exp), locinfo)+            | otherwise                  = Nothing++--Takes an ExpBucket (second param is list to store intermediate results)+--and groups the elements according to duplicate matches+--Returns ExpBucket+groupDupls ::  ExpBucket -> ExpBucket -> ExpBucket+groupDupls  y []= y+groupDupls  ys (x:xs) = let r = xmatches x xs +		        in groupDupls (ys++r) (xs\\r)+    where xmatches x xs = x:filter (\y->(show (fst x)) == (show (fst y))) xs++--Given an ExpBucketGroup paramater, returns a grouped list of+--duplicate Expressions in ExpBucketGroup form.+elemCheck :: ExpBucketGroup -> ExpBucketGroup+elemCheck xs = List.groupBy (\x y ->(show(fst x)) == (show(fst y))) (groupDupls [] (concat xs))++--Takes a list of HsExpP and a BucketGroup list and verifies the duplicates in the BucketGroup list+--against the HsExpP list+verifyBucketGroup :: [HsExpP] -> BucketGroup -> ExpBucketGroup+verifyBucketGroup ast dupl = do let expast = populateBucketGroup ast dupl+			        [ x | x <- elemCheck expast, length x > 1]++++-- *******************************************************+-- ***** Module list related functions called by the ***** +-- ***** refactor interface                          *****+-- *******************************************************++--Takes a single parameter containing a list of all the modules to be+--expanded into ASTs+makeFullASTList gf= do gh <- (mapM parseSourceFile gf)+		       return [mod | (inscps, exps, mod, tokList) <- gh]++--Returns a list of all modules used in the program which are in the+--same directory as the initial file to be refactored+getModules = do gf <- getCurrentModuleGraph+                return  (filterNames [ f | (f, (m,_)) <- gf])++--Takes a single parameter containing a list of strings and returns+--the list with all strings containing the '/' character removed+filterNames :: [String] -> [String]+filterNames xs = [ x | x <- xs, containsSlash x == False]++--Takes a single string paramater and returns a boolean value+--depending on whether or not the string contains the '/' character+containsSlash :: String -> Bool+containsSlash x = if gx x == 0 then False else True+    where gx xs = length [ x | x <- xs, x == '/']++++-- **************************************************************+-- ***** Top level functions called by refactorer interface *****+-- **************************************************************++--Takes an AST and returns a list of duplicate information (Type ExpBucketGroup)+getDuplicates :: Term t => t -> ExpBucketGroup+getDuplicates ast = verifyBucketGroup (genExpList ast) (constructBucketGroup (makeBucket ast) [])++--Takes an AST and returns a bucket containing (for each drip) the string of the Expression+--name, and the start & finish locations of the Expression+getSpecificDupls :: Term t => HsExpP -> t -> ExpBucketGroup+getSpecificDupls exp ast =  [catMaybes $ ghead "getSpecificDupls" $ (applyTU (full_tdTU (constTU [] `adhocTU` findMatches)) ast)]+    where findMatches (a::HsExpP)= if show(removeSrcLocs exp) == show(removeSrcLocs a) +				   then return [Just (a,getSrcLoc a)]+				   else return [Nothing]+++--Function to display duplicates returned by getDuplicates in a readable format+displayDuplicates dupls = do putStrLn $ "The following duplicates have been identified (File,Line,Char):" ++ "\n"+		             mapM putStrLn (map displayElement dupls)		       +    where displayElement xs = if length xs == 1 +			      then "No duplicates found.\n"+			      else (render.ppi) (fst(ghead "displayElement" xs)) ++ " at location(s) " ++ show (nub [snd x | x <- xs]) ++ "\n"++--Simple function to display the raw data output by getDuplicates+displayDuplicates1 dupls =  putStrLn $ show dupls+
+ refactorer/RefacFunDef.hs view
@@ -0,0 +1,1024 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacFunDef+-- Copyright   :  (c) Christopher Brown 2005+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Function Definition folding.+-- Looks for duplicate code and replaces it with a call to the function.+--   e.g.+--+-- @ square x = x * x @+--+-- @ g x y = x * x + y * y @+--+--   will be refactored to:+--+-- @ square x = x * x @+--+-- @ g x y = square x + square y @+--+-----------------------------------------------------------------------------++module RefacFunDef (+ +   -- ** Data types+   Binding, Environment, NonSetEnv,+   FunctionPats, WhereDecls,+ +   -- * Function types+   subFunctionDef, checkInWhere, checkInPat,+   createFunc, createFunc', getEnvironment,+   canAddBind, checkVal, rewritePatsInEnv,+   doZip, zipHighlightedMatch, callZipHighlightedMatch,+   zipHighlightedField, zipHighlightedStmt,+   -- * Type signatures with argument docs+   findDefNameAndExp + +  ) where++import PrettyPrint+import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils+import PFE0 (findFile)+import MUtils (( # ))+import RefacLocUtils+import RefacGenFold hiding (FunctionPats, WhereDecls, Er, Patt, Mat, findDefNameAndExp, PatFun)++-- | Binds an exp to another e.g. (HsID x, HsLit 5) says x is bound to 5.+-- and it continues until the next non-comment line+type Binding = (HsExpP, HsExpP)++-- | An environment is a *set* of bindings.+type Environment = [Binding]++{- | An environment that is not yet a set - should be processed into an+    'Environment'. -}+type NonSetEnv = [Maybe Binding]++-- | An argument list for a function which of course is a list of paterns.+type FunctionPats = [HsPatP]++-- | A list of declarations used to represent a where or let clause.+type WhereDecls = [HsDeclP]+++data PatFun = Mat | Patt | Er deriving (Eq, Show)++{- | Function Definition folding.+     This folding takes a function definition, looks for duplicate code and+     replaces it with a call to the function.+     e.g.+     @+         square x = x * x+         g x y = x * x + y * y+     @+     will be refactored to:+     @+         square x = x * x+         g x y = square x + square y+     @+-}+subFunctionDef args+  = do let fileName   = args!!0+           beginRow   = read (args!!1)::Int+           beginCol   = read (args!!2)::Int+           endRow     = read (args!!3)::Int+           endCol     = read (args!!4)::Int+       AbstractIO.putStrLn "subFunctionDef"+       +       (inscps, exps, mod, tokList) <- parseSourceFile fileName+              +       -- Parse the input file.+       -- (inscps, exps, mod, tokList) <- parseSourceFile fileName+                      +       -- Find the function that's been highlighted as the refactree+       let (ty, pnt, pats, subExp, wh)+             = findDefNameAndExp tokList+                                 (beginRow, beginCol)+                                 (endRow, endCol)+                                 mod+       let exp = locToExp (beginRow, beginCol)+                          (endRow, endCol)+                          tokList+                          mod+       {-+        - Do the refactoring!  Returns modifications as below:+        - mod'     - the modified Abstract Syntax Tree+        - tokList' - the modified Token Stream+        - m        - ???+        -}+       if ty == Mat+         then do +            (mod', ((tokList', m), _)) <- runStateT (doZip pnt wh pats subExp mod)+                                                    ((tokList, False), (0,0))+       +            -- Write out the refactoring+            writeRefactoredFiles False [((fileName, m), (tokList', mod'))]+            AbstractIO.putStrLn "Completed.\n"+         else do+           (mod', ((tokList', m) , _)) <- runStateT (doSubstitution pnt subExp mod) ((tokList,False),( 0, 0))+           writeRefactoredFiles False [((fileName, m), (tokList', mod'))]+           AbstractIO.putStrLn "Completed.\n"++++doSubstitution p e+   = applyTP (full_tdTP (idTP `adhocTP` inMod+                              `adhocTP` inMatch+                              `adhocTP` inPat  ))+       where+        inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)+         | p `elem` (map declToPNT ds) +             = do+                  ds' <- doZipModule ds+                  return (HsModule loc name exps imps ds')+            where+             doZipModule t+              = applyTP (full_tdTP (idTP `adhocTP` inMatch2+                                        `adhocTP` inPat2)) t+               where+               inMatch2 (match@(HsMatch loc name pats rhs ds)::HsMatchP)+                  = do+                    (_, declared) <- hsFreeAndDeclaredNames pats+                    (_, declared') <- hsFreeAndDeclaredNames match+                    (_, declared'') <- hsFreeAndDeclaredNames ds+                    if (pNTtoName p) `elem` (declared++(declared'++declared''))+                      then return match+                      else do  e' <- doSubstitution' p e declared rhs+                               return (HsMatch loc name pats e' ds)+                        ++               inPat2 (pat@(Dec (HsPatBind loc pa rhs ds))::HsDeclP)+                 = do+                   (_, declared)  <- hsFreeAndDeclaredNames pat+                   (_, declared') <- hsFreeAndDeclaredNames ds+                   if (pNTtoName p) `elem` (declared++declared')+                    then return pat+                    else do e' <- doSubstitution' p e declared rhs+                            return (Dec (HsPatBind loc pa e' ds))+                +               inPat2 x = return x+               +        inMod x = return x    +        +        inMatch (match@(HsMatch loc name pats rhs ds)::HsMatchP)+         | p `elem` (map declToPNT ds)+            = do+                    (_, declared) <- hsFreeAndDeclaredNames pats+                    (_, declared') <- hsFreeAndDeclaredNames match+                    if (pNTtoName p) `elem` (declared++declared')+                      then return match+                      else do +                              e' <- doSubstitution' p e declared rhs+                              return (HsMatch loc name pats e' ds)+      +        inMatch x = return x++        inPat (pat@(Dec (HsPatBind loc pa rhs ds))::HsDeclP)+         | p `elem` (map declToPNT ds)+               = do+                   (_, declared)  <- hsFreeAndDeclaredNames pat+                   if (pNTtoName p) `elem` declared+                    then return pat+                    else do e' <- doSubstitution' p e declared rhs+                            return (Dec (HsPatBind loc pa e' ds))+        +        inPat x = return x++           +doSubstitution' p e declared t+    = applyTP (stop_tdTP (failTP `adhocTP` subExp)) t+       where +         subExp exp@((Exp _)::HsExpP)+          | sameOccurrence exp e == False+               = if toRelativeLocs e == toRelativeLocs exp then update exp (createFunc p) exp+                                                           else mzero+          | otherwise                     +                  = mzero++         createFunc pat = (Exp (HsId (HsVar pat)))            +           ++           +           +{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (PatFun, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+                     +findDefNameAndExp toks beginPos endPos t+  = fromMaybe (Er, defaultPNT, [], defaultExp, [])+              (applyTU (once_tdTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t)++    where+      --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats rhs@(HsBody e) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (Mat, pnt, pats, locToExp beginPos endPos toks rhs, ds)+      inMatch (match@(HsMatch loc1  pnt pats rhs@(HsGuard e) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (Mat, pnt, pats, rmGuard rhs, ds)          +      inMatch _ = Nothing++      --The selected sub-expression is in the rhs of a pattern-binding+      inPat (pat@(Dec (HsPatBind loc1 ps rhs@(HsBody e) ds))::HsDeclP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (Patt, patToPNT ps, [], locToExp beginPos endPos toks rhs, ds)+      --The selected sub-expression is in the rhs of a pattern-binding+      inPat (pat@(Dec (HsPatBind loc1 ps rhs@(HsGuard es) ds))::HsDeclP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (Patt, patToPNT ps, [], rmGuard rhs, ds)+      inPat _ = Nothing++      rmGuard ((HsGuard gs)::RhsP)+             = let (_,e1,e2)=glast "guardToIfThenElse" gs+               in  if ((pNtoName.expToPN) e1)=="otherwise" +                   then (foldl mkIfThenElse e2 (tail(reverse gs)))+                   else (foldl mkIfThenElse defaultElse (reverse gs)) +           +      mkIfThenElse e (_,e1, e2)=(Exp (HsIf e1 e2 e)) ++      defaultElse=(Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "error") (G (PlainModule "Prelude") "error" +                    (N (Just loc0)))) Value (N (Just loc0)))))) (Exp (HsLit loc0 (HsString "UnMatched Pattern")))))+++doZip :: (MonadPlus m, Term t, MonadState (([PosToken],Bool),(Int, Int)) m) => +         PNT -> WhereDecls -> FunctionPats -> HsExpP -> t+             -> m t+doZip p w patsGlob e t+  = applyTP (full_tdTP (idTP  `adhocTP` inMod+                              `adhocTP` inMatch+                              `adhocTP` inPat  )) t+       where+        inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)+         | p `elem` (map declToPNT ds) +             = do+                  ds' <- doZipModule ds+                  return (HsModule loc name exps imps ds')+            where+             doZipModule t+              = applyTP (full_tdTP (idTP `adhocTP` inMatch2+                                        `adhocTP` inPat2)) t+               where+               inMatch2 (match@(HsMatch loc name pats rhs ds)::HsMatchP)+                  = do+                    (_, declared) <- hsFreeAndDeclaredNames pats+                    (_, declared') <- hsFreeAndDeclaredNames match+                    (_, declared'') <- hsFreeAndDeclaredNames ds+                    if (pNTtoName p) `elem` (declared++(declared'++declared''))+                      then return match+                      else do e' <- doZip' p w patsGlob e rhs+                              return (HsMatch loc name pats e' ds)+                        ++               inPat2 (pat@(Dec (HsPatBind loc pa rhs ds))::HsDeclP)+                 = do+                   (_, declared)  <- hsFreeAndDeclaredNames pat+                   (_, declared') <- hsFreeAndDeclaredNames ds+                   if (pNTtoName p) `elem` (declared++declared')+                    then return pat+                    else do e' <- doZip' p w patsGlob e rhs+                            return (Dec (HsPatBind loc pa e' ds))+                +               inPat2 x = return x+        inMod x = return x+          +         +            +       +       +        inMatch (match@(HsMatch loc name pats rhs ds)::HsMatchP)+         | p `elem` (map declToPNT ds)+            = do+                    (_, declared) <- hsFreeAndDeclaredNames pats+                    (_, declared') <- hsFreeAndDeclaredNames match+                    if (pNTtoName p) `elem` (declared++declared')+                      then return match+                      else do e' <- doZip' p w patsGlob e rhs+                              return (HsMatch loc name pats e' ds)++        inMatch x = return x++        inPat (pat@(Dec (HsPatBind loc pa rhs ds))::HsDeclP)+         | p `elem` (map declToPNT ds)+               = do+                   (_, declared)  <- hsFreeAndDeclaredNames pat+                   if (pNTtoName p) `elem` declared+                    then return pat+                    else do e' <- doZip' p w patsGlob e rhs+                            return (Dec (HsPatBind loc pa e' ds))+        +        inPat x = return x+++{-| +doZip uses Strafunski to traverse each node of the AST and +then performs the folding on each node.+-}+doZip' :: (MonadPlus m, Term t, MonadState (([PosToken],Bool),(Int, Int)) m) => +         PNT -> WhereDecls -> FunctionPats -> HsExpP -> t+             -> m t+doZip' p w pats e t+  = applyTP (stop_tdTP (failTP `adhocTP` (zipExpCheck p w pats e))) t+    where+      zipExpCheck p w pats (exp1::HsExpP) (exp2::HsExpP)+        | sameOccurrence exp1 exp2 == False+            = do +                 result <- (callZipHighlightedMatch pats w exp1 exp2)+                 let environment = getEnvironment result+                 if result == [Nothing] || environment == Nothing+                   then do fail ""+                   else do let Just env = environment+                           let result' = map (rewritePatsInEnv env) pats+                           update exp2 (createFunc p result') exp2+                           +        | otherwise+           = return exp1++{-|+checkVal calls checkAddBind in succession to check that all the bindings+can be added to the environment or not.+ -}+ +checkVal :: NonSetEnv -> Bool+checkVal xs+  = checkValAux xs []+    where+      checkValAux :: NonSetEnv -> Environment -> Bool+      checkValAux [] _ = True+      checkValAux ((Just (x,y)) : xs) env+        = canAddBind (x,y) env &&+          checkValAux xs ((x,y):env)+      checkValAux (Nothing:xs) env = checkValAux xs env++{-|+canAddBind takes a binding and some environments, and checks to see+whether the binding can be added to the environment or not.+The binding will not be added to the environment if that binding+already exists within the environment. canAddBind returns True+if the binding can be added, and False if it cannot.+-}++canAddBind :: Binding -> Environment -> Bool+canAddBind _ [] = True+canAddBind (x,y) ((x',y'):xs)+  = (x1 == x1' && y1 == y1') ||+    (x1 /= x1' && canAddBind (x,y) xs)+    where+      [x1,x1',y1,y1'] = map toRelativeLocs [x,x',y,y']++{-|+getEnvironment takes a list of bindings and removes+the duplicates within the bindings+-}++getEnvironment :: NonSetEnv -> Maybe Environment+getEnvironment [] = Just []+getEnvironment (Nothing: xs) = getEnvironment xs+getEnvironment (Just (x,y):xs)+  = case subEnv of+      Nothing  -> Nothing+      Just env -> if canAddBind (x,y) env+                    then Just ((x,y):env)+                    else Nothing+    where+      subEnv = getEnvironment xs+++{-|+rewritePatsInEnv takes the Environment and a pattern belonging to the+argument list of the function the user is folding against.+rewritePatsInEnv then forms an expression based on this pattern+taking into consideration the environment. This is used when forming+the function call+e.g.+@+  Environment = [("x", [1,2,3]), ("y", 1)]+  pat = (x,y) +@++would return...++@+  HsTuple ([1,2,3], 1)+@+  +-}++rewritePatsInEnv :: Environment -> HsPatP -> HsExpP+rewritePatsInEnv [] p = error "Empty Environment!"+rewritePatsInEnv env (pat1@(Pat (HsPRec x y)))+  = Exp (HsRecConstr loc0 x (map (sortField env) y))+    where+      sortField :: Environment -> HsFieldI a HsPatP -> HsFieldI a HsExpP+      sortField env (HsField i e) = (HsField i (rewritePatsInEnv env e))++rewritePatsInEnv env (pat1@(Pat (HsPLit x y)))+  = Exp (HsLit x y)++rewritePatsInEnv env (pat1@(Pat (HsPAsPat i p1)))+  = Exp (HsAsPat i (rewritePatsInEnv env p1))++rewritePatsInEnv env (pat1@(Pat (HsPIrrPat p1)))+  = Exp (HsIrrPat (rewritePatsInEnv env p1))++rewritePatsInEnv env (pat1@(Pat (HsPWildCard)))+  = nameToExp "undefined"++rewritePatsInEnv env (pat1@(Pat (HsPApp i p1)))+  = createFunc i (map (rewritePatsInEnv env) p1)++rewritePatsInEnv env (pat1@(Pat (HsPList _ p1)))+  = Exp (HsList (map (rewritePatsInEnv env) p1))++rewritePatsInEnv env (pat1@(Pat (HsPTuple _ p1)))+  = Exp (HsTuple (map (rewritePatsInEnv env) p1))++rewritePatsInEnv env (pat1@(Pat (HsPInfixApp p1 x p2)))+  =  Exp (HsInfixApp (rewritePatsInEnv env p1)+                     (HsCon x)+                     (rewritePatsInEnv env p2))++rewritePatsInEnv env (pat@(Pat (HsPParen p1)))+  = Exp (HsParen (rewritePatsInEnv env p1))++rewritePatsInEnv env (pat1@(Pat (HsPId (HsVar (PNT (PN (UnQual i) _) _ _)))))+  = if findRewrites i == []+      then nameToExp "undefined"+      else snd (head (findRewrites i))+    where+      findRewrites i = filter (checkPat i) env+      checkPat i (Exp (HsId (HsVar (PNT (PN (UnQual i2) _) _ _))), (Exp z))+        = i == i2+      checkPat i _ = False++{-|+callZipHighlightedMatch simply calls the function zipHighlightedMatch+and then returns the value wrapped in a monad+-}+callZipHighlightedMatch :: Monad m =>  FunctionPats -> WhereDecls +                         -> HsExpP -> HsExpP -> m NonSetEnv+callZipHighlightedMatch pats w (exp1::HsExpP) (exp2::HsExpP)+  = do zippedE1 <- zipHighlightedMatch False pats w exp1 exp2+       return zippedE1++{- |+zipHighlightedMatch takes a list of patterns (the list of arguments for the +function highlighted, the where clause associated with the function, +the expression that has been highlighted and the expression that we are trying+to fold against.+   +zipHighlightedMatch then checks to see if the the expressions can be paired.+The expressions will only be paired if:+both expressions have the ssame type+e.g.+      refactoron -> [1,2,3,4]+      refactorod -> [1,2,3,4] becomes ([1,2,3,4], [1,2,3,4])+        +or, the highlighted expression is an idenitfier, in which case a pair is+always created, unless the idenitifier does not appear in the argument list+(pats)+  +-}++zipHighlightedMatch :: Monad m => Bool ->  FunctionPats -> WhereDecls +                    -> HsExpP -> HsExpP -> m NonSetEnv+zipHighlightedMatch b pats w (exp1@(Exp (HsId (HsCon i1)))::HsExpP)+                             (exp2@(Exp (HsId (HsCon i2)))::HsExpP)+  | i1 == i2  = return [ Just (exp1, exp2) ]+  | otherwise = return [ Nothing ]+zipHighlightedMatch b pats w (exp1@(Exp (HsId (HsCon i1)))::HsExpP)+                             (exp2::HsExpP)+  = return [ Nothing ]+zipHighlightedMatch True pats w (exp1@(Exp (HsId i1))::HsExpP) +                           (exp2@(Exp (HsId i2))::HsExpP)+  | not (checkDefs i1 i2) = fail "untouched"      +  | checkInPat pats exp2 = return  [ Just (exp1, exp2) ]+--  | checkInPat pats exp1  = return [ Just (exp1, exp2) ]+  | checkGlobal i1 i2     = return [ Just (exp1, exp2) ]+  | not (checkInWhere w exp1) = return [Nothing]+  | otherwise                 = fail "untouched"+    where+     checkGlobal (HsVar i1) (HsVar i2) = (pNTtoPN i1) == (pNTtoPN i2)+     checkGlobal _ _ = False+zipHighlightedMatch False pats w (exp1@(Exp (HsId i1))::HsExpP) +                                 (exp2@(Exp (HsId i2))::HsExpP)++  | checkInPat pats exp1  = return [ Just (exp1, exp2) ]+  | checkGlobal i1 i2     = return [ Just (exp1, exp2) ]+  | not (checkInWhere w exp1) = return [Nothing]+  | otherwise                 = fail "untouched"+    where+     checkGlobal (HsVar i1) (HsVar i2) = (pNTtoPN i1) == (pNTtoPN i2)+     checkGlobal _ _ = False+zipHighlightedMatch b pats w (exp1@(Exp (HsId i))::HsExpP) (exp2::HsExpP)+  | checkInPat pats exp1 == True &&+    checkInWhere w exp1 /= True+      = return [ Just (exp1, exp2) ]+  | otherwise+      = fail "untouched" ++zipHighlightedMatch b pats w (exp1@(Exp (HsLit _ i1))::HsExpP)+                             (exp2@(Exp (HsLit _ i2))::HsExpP)+  | i1 == i2  = return [ Just (exp1, exp2) ]+  | otherwise = return [ Nothing ]++zipHighlightedMatch b pats w (exp1@(Exp (HsLit _ _))::HsExpP) (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsInfixApp e1 i e2))::HsExpP)+              (exp2@(Exp (HsInfixApp e11 i2 e22))::HsExpP)+  | i == i2   = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+                   zippedE2 <- zipHighlightedMatch b pats w e2 e22+                   if zippedE1 == [ Nothing ] || zippedE2 == [ Nothing ]+                     then return [ Nothing ]+                     else return (zippedE1 ++ zippedE2)+  | otherwise = return [ Nothing ]+++zipHighlightedMatch b pats w (exp1@(Exp (HsInfixApp e1 i e2))::HsExpP) +                           (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsApp e1 e2))::HsExpP)+                             (exp2@(Exp (HsApp e11 e22))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       zippedE2 <- zipHighlightedMatch b pats w e2 e22+       if zippedE1 == [Nothing] || zippedE2 == [ Nothing ]+         then return [Nothing]+         else return (zippedE1 ++ zippedE2)++zipHighlightedMatch b pats w (exp1@(Exp (HsApp e1 e2))::HsExpP) (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsNegApp _ e1))::HsExpP)+              (exp2@(Exp (HsNegApp _ e2))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e2+       return zippedE1++zipHighlightedMatch b pats w (exp1@(Exp (HsNegApp _ e1))::HsExpP) (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsLambda ps e1))::HsExpP)+                           (exp2@(Exp (HsLambda ps2 e11))::HsExpP) + | wildCardAllPNs ps == wildCardAllPNs ps2+     = do zippedE1 <- zipHighlightedMatch b pats w e1 (localRewriteExp e11 (localRewritePats ps ps2))+          return zippedE1+        where+         localRewritePats [] ps = []+         localRewritePats ps [] = []+         localRewritePats (p1:p1s) (p2:p2s) +           = (rewritePat p2 p1) : (localRewritePats p1s p2s)+        +         localRewriteExp e [] = e   +         localRewriteExp e (p1:p1s)+           = let e1' = rewritePatsInExp p1 e  in localRewriteExp e1' p1s+zipHighlightedMatch b pats w (exp1@(Exp (HsLet _ e1))::HsExpP)+              (exp2@(Exp (HsLet _ e11))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       return zippedE1++zipHighlightedMatch b pats w (exp@(Exp (HsLet _ e1))::HsExpP) (exp2::HsExpP)+  = fail ""++zipHighlightedMatch b pats w (exp1@(Exp (HsLambda _ e1))::HsExpP) (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsIf e1 e2 e3))::HsExpP)+              (exp2@(Exp (HsIf e11 e22 e33))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       zippedE2 <- zipHighlightedMatch b pats w e2 e22+       zippedE3 <- zipHighlightedMatch b pats w e3 e33+       return (zippedE1 ++ zippedE2 ++ zippedE3)++zipHighlightedMatch b pats w (exp1@(Exp (HsIf e1 e2 e3))::HsExpP) (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats +                    w +                    (exp1@(Exp (HsCase e1 (alt@(HsAlt _ p1 e2 ds1):alts1)))::HsExpP)+                    (exp2@(Exp +                              (HsCase e11 +                                         (alt2@(HsAlt _ p11 e22 ds11):alts2)+                              ))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       res <- zippedAlts (alt:alts1) (alt2:alts2)+       if res == [Nothing] +          then return [Nothing]+          else return (zippedE1 ++ res)+         where+           zippedAlts [] alts = return []+           zippedAlts alts [] = return []+           zippedAlts ((HsAlt _ p1 (HsBody exp1) ds1):alts1) ((HsAlt _ p11 (HsBody exp2) ds11):alts2)+             | wildCardAllPNs p1 == wildCardAllPNs p11+             = do+                  zippedE1 <- zipHighlightedMatch b pats w exp1 (rewritePatsInExp (rewritePat p11 p1) exp2)+                  if zippedE1 == [Nothing]+                    then return [Nothing]+                    else do res <- zippedAlts alts1 alts2+                            if res == [Nothing] then return [Nothing]+                                                else return (zippedE1 ++ res)+             | otherwise = return [Nothing]+           zippedAlts ((HsAlt _ p1 (HsGuard g1) ds1):alts1) ((HsAlt _ p22 (HsGuard g2) ds11):alts2)+             | wildCardAllPNs p1 == wildCardAllPNs p22+               = do+                    zippedE1 <- zippedGuards g1 (rewritePatsInGuard (rewritePat p22 p1) g2)+                    -- error $ show zippedE1+                    if zippedE1 == [Nothing]+                      then return [Nothing]+                      else do+                              res <- zippedAlts alts1 alts2+                              if res == [Nothing] then return [Nothing]+                                                  else return (zippedE1 ++ res)+                where+                  zippedGuards _ [] = return []+                  zippedGuards [] _ = return []+                  zippedGuards ((_, e1, e2):gs1) ((_, e3, e4):gs2)+                    = do+                         e1' <- zipHighlightedMatch True pats w e1 e3+                         e2' <- zipHighlightedMatch True pats w e2 e4+                         res <- zippedGuards gs1 gs2+                         return ((e1' ++ e2') ++ res)+           zippedAlts _ _ = return [Nothing]+zipHighlightedMatch b pats w (exp1@(Exp +                                     (HsCase e1 +                                               ((HsAlt _ e2 p1 ds1):alts1)+                                     ))::HsExpP)+                           (exp2::HsExpP)+                +  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsDo (stat1)))::HsExpP)+                             (exp2@(Exp (HsDo (stat2)))::HsExpP) +  = do zippedE1 <- zipHighlightedStmt pats w stat1 stat2+       return zippedE1++zipHighlightedMatch b pats w (exp1@(Exp (HsDo (stat1)))::HsExpP) (exp2::HsExpP)+  = return [Nothing]+  +zipHighlightedMatch b pats w (exp1@(Exp (HsTuple ([e1])))::HsExpP)+                           (exp2@(Exp (HsTuple ([e11])))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       return zippedE1++zipHighlightedMatch b pats w (exp1@(Exp (HsTuple (e1:e1s)))::HsExpP)+                             (exp2@(Exp (HsTuple (e11:e11s)))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       result <- zippedE2 e1s e11s+       if result == [Nothing] || zippedE1 ==  [Nothing]+         then return [Nothing]+         else return (zippedE1 ++ result)+       where+         zippedE2 [] [] = return []+         zippedE2 _ [] = return [Nothing]+         zippedE2 [] _ = return [Nothing]+         zippedE2 (x:xs) (y:ys)+          = do result1 <- zipHighlightedMatch b pats w x y+               result2  <- zippedE2 xs ys+               if result1 == [Nothing] || result2 == [Nothing]+                 then return [Nothing]+                 else return (result1 ++ result2)++zipHighlightedMatch b pats w (exp1@(Exp (HsTuple (e1:e1s)))::HsExpP) +                           (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsList ([e1])))::HsExpP)+                           (exp2@(Exp (HsList ([e11])))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       return zippedE1++zipHighlightedMatch b pats w (exp1@(Exp (HsList (e1:e1s)))::HsExpP)+                           (exp2@(Exp (HsList (e11:e11s)))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       result   <- zippedE2 e1s e11s+       -- error (show zippedE1 ++ " " ++ show result)+       if result == [Nothing] || zippedE1 == [Nothing]+         then return [Nothing]+         else return (zippedE1 ++ result)+       where+         zippedE2 [] [] = return []+         zippedE2 _ [] = return [Nothing]+         zippedE2 [] _ = return [Nothing]+         zippedE2 (x:xs) (y:ys) = do+         result1 <- zipHighlightedMatch b pats w x y+         result2  <- zippedE2 xs ys+         if result1 == [Nothing] || result2 == [Nothing] +           then return [Nothing]+           else return (result1 ++ result2)++zipHighlightedMatch b pats w (exp1@(Exp (HsList (e1:e1s)))::HsExpP) (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsParen e1))::HsExpP)+                             (exp2@(Exp (HsParen e11))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       return zippedE1++zipHighlightedMatch b pats w (exp1@(Exp (HsParen e1))::HsExpP) (exp2::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 exp2+       return zippedE1+zipHighlightedMatch b pats w (exp1::HsExpP) (exp2@(Exp (HsParen e2))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w exp1 e2+       return zippedE1+zipHighlightedMatch b pats w (exp1@(Exp (HsLeftSection e1 i1))::HsExpP)+              (exp2@(Exp (HsLeftSection e11 i2))::HsExpP)+  | i1 == i2  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+                   return zippedE1+  | otherwise = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsLeftSection e1 i1))::HsExpP)+              (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsRightSection i1 e1))::HsExpP)+              (exp2@(Exp (HsRightSection i2 e11))::HsExpP)+  | i1 == i2  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+                   return zippedE1+  | otherwise = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsRightSection i1 e1))::HsExpP)+              (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsRecConstr _ i1 i2 ))::HsExpP)+              (exp2@(Exp (HsRecConstr _ i11 i22 ))::HsExpP)+  | i1 == i11 = do zippedE1 <- zipHighlightedField pats w i2 i22+                   return zippedE1+  | otherwise = do return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsRecConstr _ i1 i2))::HsExpP) +                           (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsRecUpdate _ e1 i1))::HsExpP)+              (exp2@(Exp (HsRecUpdate _ e11 i11))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       zippedE2 <- zipHighlightedField pats w i1 i11+       return (zippedE1 ++ zippedE2)++zipHighlightedMatch b pats w (exp1@(Exp (HsRecUpdate _ e1 i1))::HsExpP)+                           (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFrom e1))::HsExpP)+              (exp2@(Exp (HsEnumFrom e11))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       return zippedE1++zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFrom e1))::HsExpP) (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromTo e1 e2))::HsExpP)+              (exp2@(Exp (HsEnumFromTo e11 e22))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       zippedE2 <- zipHighlightedMatch b pats w e2 e22+       return (zippedE1 ++ zippedE2)++zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromTo e1 e2))::HsExpP) +                           (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromThen e1 e2))::HsExpP)+              (exp2@(Exp (HsEnumFromThen e11 e22))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       zippedE2 <- zipHighlightedMatch b pats w e2 e22+       return (zippedE1 ++ zippedE2)++zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromThen e1 e2))::HsExpP) +                           (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromThenTo e1 e2 e3))::HsExpP)+              (exp2@(Exp (HsEnumFromThenTo e11 e22 e33))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       zippedE2 <- zipHighlightedMatch b pats w e2 e22+       zippedE3 <- zipHighlightedMatch b pats w e3 e33+       return (zippedE1 ++ zippedE2 ++ zippedE3)++zipHighlightedMatch b pats w (exp1@(Exp (HsEnumFromThenTo e1 e2 e3))::HsExpP) +                           (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsListComp (stat1)))::HsExpP)+              (exp2@(Exp (HsListComp (stat2)))::HsExpP)+  = do zippedE1 <- zipHighlightedStmt  pats w stat1 stat2+       return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsListComp (stat1)))::HsExpP)+                           (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsExpTypeSig _ e1 c1 t1))::HsExpP)+              (exp2@(Exp (HsExpTypeSig _ e2 c2 t2))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e2+       return zippedE1++zipHighlightedMatch b pats w (exp1@(Exp (HsExpTypeSig _ e1 c1 t1))::HsExpP)+              (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsAsPat i1 e1))::HsExpP)+              (exp2@(Exp (HsAsPat i11 e11))::HsExpP)+  | i1 == i11 = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+                   return zippedE1+  | otherwise = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsAsPat i1 e1))::HsExpP) (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1@(Exp (HsIrrPat e1))::HsExpP)+              (exp2@(Exp (HsIrrPat e11))::HsExpP)+  = do zippedE1 <- zipHighlightedMatch b pats w e1 e11+       return zippedE1++zipHighlightedMatch b pats w (exp1@(Exp (HsIrrPat e1))::HsExpP) (exp2::HsExpP)+  = return [Nothing]++zipHighlightedMatch b pats w (exp1::HsExpP) (exp2::HsExpP)+  = return [Nothing]++{-|+zipHighlightedField takes the highlighted expression+, and takes the expression that we are folding against.+If they are both fields, it then calls zipHiglightedMatch to+pair up the expressions within the fields.+-}+zipHighlightedField :: Monad m =>  FunctionPats -> WhereDecls +                    -> HsFieldsI PNT (HsExpI PNT) -> HsFieldsI PNT (HsExpI PNT)+                    -> m NonSetEnv+zipHighlightedField pats w [] _+  = return [Nothing]++zipHighlightedField pats w _ []+  = return [Nothing]++zipHighlightedField pats w ((fiel1@(HsField i1 e1)):xs)+                  ((fiel2@(HsField i11 e11)):ys)+  = if i1 == i11+      then do zippedE1 <- zipHighlightedMatch False pats w e1 e11+              return zippedE1+      else do+              return [Nothing]++checkDefs (HsVar p1@(PNT (PN (UnQual i) (_) ) _ _ )) (HsVar p2@(PNT (PN (UnQual i2) (_) ) _ _ ))+ = i == i2+checkDefs _ _ = False+++{-|+checkInPat checks that the Expression (supplied as 2nd argument) +occurs within the Function Arugment List.+checkInPat needs to check for every case that expression could be+e.g. literals, lists, tuples and records.+if the expression occurs then the function returns True+otherwise returns False.  +-}+   +checkInPat :: FunctionPats -> HsExpP -> Bool+checkInPat (pat1@(Pat (HsPRec x y)):pats) exp+  | (checkField y) == False = (checkInPat pats exp)+  | otherwise               = True+  where+    checkField ((HsField i e):xs)+      | (checkInPat [e] exp) == False = (checkField xs)+      | otherwise                     = True++checkInPat (pat1@(Pat (HsPIrrPat p)):pats) exp+  | (checkInPat [p] exp) == False = checkInPat pats exp+  | otherwise                     = True++checkInPat (pat1@(Pat (HsPAsPat i p)):pats) exp+  | (checkInPat [p] exp) == False = checkInPat pats exp+  | otherwise                     = True++checkInPat (pat1@(Pat (HsPWildCard)):pats) exp+  = checkInPat pats exp++checkInPat (pat1@(Pat (HsPId (HsVar (PNT p@(PN (UnQual i) (_) ) _ _ )))):pats)+           (exp1@(Exp (HsId (HsVar (PNT p2@(PN (UnQual i2) (_) ) _ _ ))))::HsExpP)+ = if p == p2 then True else checkInPat pats exp1+ {- = if i == i2+      then True+      else checkInPat pats exp1 -}++checkInPat (pat1@(Pat (HsPParen pat)):pats) exp+  | (checkInPat [pat] exp) == False = checkInPat pats exp+  | otherwise                       = True++checkInPat (pat@(Pat (HsPInfixApp pat1 x pat2)):pats) exp+  | (checkInPat [pat1] exp) == False &&+    (checkInPat [pat2] exp) == False+              = checkInPat pats exp+  | otherwise = True++checkInPat (pat@(Pat (HsPTuple _ pat1)):pats) exp+  | (checkInPat pat1 exp) == False = checkInPat pats exp+  | otherwise                      = True++checkInPat (pat@(Pat (HsPList _ pat1)):pats) exp+  | (checkInPat pat1 exp) == False = checkInPat pats exp+  | otherwise                      = True++checkInPat (pat@(Pat (HsPApp i pat1)):pats) exp+  | (checkInPat pat1 exp) == False = checkInPat pats exp+  | otherwise                      = True++checkInPat ((Pat (HsPLit _ (HsInt x))):pats) exp1+  = checkInPat pats exp1+checkInPat _ _ = False+++{-|+checkInWhere checks that where clause of the function does not contain+the expressions (as second argument). If it does the function returns+True, otherwise returns False. +-}++checkInWhere :: [HsDeclP] -> HsExpP -> Bool+checkInWhere [] _ = False+checkInWhere (wh@(Dec+                   (HsPatBind _+                              (Pat+                                (HsPId+                                  (HsVar+                                    (PNT+                                      (PN+                                        (UnQual i)+                                        _+                                      )+                                      _+                                      _+                                    )+                                  )+                                )+                              )+                              _+                              rest)):ws)+             (exp1@(Exp (HsId (HsVar (PNT (PN (UnQual i2) _ ) _ _ ))))::HsExpP)+  = i == i2 +  +-- extractHsBody simply extracts the expression within an HsBody+-- and returns that Expression.+extractHsBody (HsBody exp) = return exp+extractHsBody _ = error "Case must contain HsBody"++{-|+zipHighLightedStmt checks that two statements are identical,+if they are, zipHighLightedStmt returns the two statements paired together+-}++zipHighlightedStmt :: Monad m =>  FunctionPats -> WhereDecls +                    -> HsStmtP -> HsStmtP -> m NonSetEnv+zipHighlightedStmt pats w (exp1@(HsGenerator _ p1 e1 e1')::HsStmtP)+                          (exp2@(HsGenerator _ p2 e2 e2')::HsStmtP)+ | wildCardAllPNs p1 == wildCardAllPNs p2 +  = do zippedE1 <- zipHighlightedMatch False pats w e1 e2+       zippedE2 <- zipHighlightedStmt pats w e1' e2'+       return (zippedE1 ++ zippedE2)++zipHighlightedStmt pats w (exp1@(HsQualifier e1 e1')::HsStmtP)+                          (exp2@(HsQualifier e2 e2')::HsStmtP)+  = do zippedE1 <- zipHighlightedMatch False pats w e1 e2+       zippedE2 <- zipHighlightedStmt pats w e1' e2'+       return [Nothing]++zipHighlightedStmt pats w (exp1@(HsLetStmt ds1 e1)::HsStmtP)+                          (exp2@(HsLetStmt ds2 e2)::HsStmtP)+  = do zippedE1 <- zipHighlightedStmt pats w e1 e2+       return zippedE1++zipHighlightedStmt pats w (exp1@(HsLast e1)::HsStmtP)+                          (exp2@(HsLast e2)::HsStmtP)+  = do zippedE1 <- zipHighlightedMatch False pats w e1 e2+       return zippedE1++zipHighlightedStmt pats w (exp1::HsStmtP) (exp2::HsStmtP)+  = return [Nothing]+
+ refactorer/RefacGenCache.hs view
@@ -0,0 +1,62 @@+module RefacGenCache where++import TypeCheck+import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils hiding (getParams)+import PFE0 (findFile, allFiles, allModules)+import MUtils (( # ))+import RefacLocUtils+import System+import IO+import Relations+import Ents+import Data.Set (toList)+import Data.List+import System.IO.Unsafe+import System.Cmd+import LocalSettings++-- allows the selection of a function equation to +-- be outputted as AST representation to a file.++genFoldCache args+ = do+     let fileName     = args!!0+         begin        = read (args!!1)::Int+         end          = read (args!!2)::Int+           +     (inscps, exps, mod, tokList) <- parseSourceFile fileName+     +     case checkCursor fileName begin end mod of+         Left errMsg -> do error errMsg+         Right decl ->+           do+              AbstractIO.writeFile genFoldPath (show decl)      +              AbstractIO.putStrLn "refacGenFoldCache"+              +checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToPName of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the definition!")+     Just decl -> Right decl+    where+        locToPName +         = case res of +             Nothing -> find (definesPNT (locToPNT fileName (row, col) mod)) (hsDecls mod)+             _ -> res+        res =  find (defines (locToPN fileName (row, col) mod)) (concat (map hsDecls (hsModDecls mod)))+        +        definesPNT pnt d@(Dec (HsPatBind loc p e ds))+         = findPNT pnt d+        definesPNT pnt d@(Dec (HsFunBind loc ms)) +         = findPNT pnt d+        definesPNT _ _ = False+
+ refactorer/RefacGenDef.hs view
@@ -0,0 +1,323 @@+++module RefacGenDef(generaliseDef) where++import PrettyPrint+import PosSyntax+import Maybe+import TypedIds+import UniqueNames +import PNT +import TiPNT   +import List +import RefacUtils++{-A definition can be generialised by selecting a sub-expression of the RHS of the definition,+  and introducing that sub-expression as a new argument to the function/constant at each of its +  call sites. At the same time, a new formal parameter will be added to the generalised definition.++  When generalising a definition in a mutli-module context, there maybe several cases:+  1. The definition is not exported by the current module: refactoring only afftects this module.+  2. The definition is exported by the current module, but not used by any client modules.+  3. The definition is exported by the current module, and used any some client modules:+    2.1 The selected sub-expression does not contain any free variables.+    2.2 The selected sub-expression contains free variables. In this case, this is a possiblity that+        some of the free variables may not be visible in the client modules. These free variables might+        be from the current module, or from other modules that are imported by the current modules.One+        implementation option is to make these variables also visible to the client modules by modifying/+        adding import declarations. This involves chasing the origins of these free variables, and detecting+        possible name clashes/captures. Another implementation option is to define an auxiliary function+        to denote the sub-expression, and make this function visible to the client modules. We take the +        second option in our implementation. To ensure that the new function name does not cause name clash+        in the client modules, we take the visble names both in the current module and in the client modules +        into account when creating the new function name.+-}++generaliseDef args+ = let fileName     = args!!0+       newParamName = args!!1            +       beginPos     = (read (args!!2), read (args!!3))::(Int,Int)+       endPos       = (read (args!!4), read (args!!5)) :: (Int,Int)+   in if isVarId newParamName -- the parameter name is a valid name.+      then do modName <- RefacUtils.fileNameToModName fileName+              (inscps,exps,mod, tokList) <- parseSourceFile fileName +              let (pnt,subExp) = findDefNameAndExp tokList beginPos endPos  mod+                  pn           = pNTtoPN pnt+              if pn == defaultPN || subExp == defaultExp+                then error ("The highlighted source does not contain a rhs sub-expression, " +++                       "or the selected sub-expression does not contain any identifiers so that the refactor could not locate it.")+                            +                else if isExported pnt exps +                       then do clients <- clientModsAndFiles modName  -- returns [(module name ,filename)]+                               info    <- mapM parseSourceFile (map snd clients)   -- parse all the client modules+                               let funPName+                                    =if clients /= [] && hasFreeVars subExp  --THIS CONDITION MIGHT A LITTLE BIT LOOSE. +                                                                              --HOW ABOUT NONE OF THE CLIENTS USE IT?+                                        then let inscpNames =map (\ (x,_,_,_)->x) $ concatMap inScopeInfo (map myfst info) -- calculate all visibe names+                                             in  Just =<< mkNewFunPName pn (hsDecls mod) modName inscpNames+                                        else Nothing+                                   subExp' = if isJust funPName then pNtoExp (fromJust funPName) else subExp +                               (mod',((tokList',m),_)) <- doGeneralise pnt fileName subExp newParamName funPName mod tokList+                                                                           +                               refactoredClients   <- mapM (generaliseInClientMod pnt subExp' modName funPName)+                                                       $ zip info (map snd clients)+                               writeRefactoredFiles False $ ((fileName,m), (tokList',mod')):refactoredClients                        +                       else do (mod',((tokList',m),_))<-doGeneralise pnt fileName subExp newParamName Nothing mod tokList+                               writeRefactoredFiles False [((fileName,m), (tokList',mod'))]+      else error "Invalid parameter name!" +  where+   +   --find the definition name whose sub-expression has been selected, and the selected sub-expression.+   findDefNameAndExp toks beginPos endPos t +    = fromMaybe (defaultPNT, defaultExp) (applyTU (once_tdTU (failTU `adhocTU` inMatch+                                                                     `adhocTU` inPat)) t)  --CAN NOT USE 'once_tdTU' here. ++     where  --The selected sub-expression is in the rhs of a match+           inMatch (match@(HsMatch loc1  pnt pats rhs ds)::HsMatchP)+             | locToExp beginPos endPos toks rhs /= defaultExp+             = Just (pnt, locToExp beginPos endPos toks rhs)+           inMatch _ = Nothing+        +           --The selected sub-expression is in the rhs of a pattern-binding+           inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+             | locToExp beginPos endPos toks rhs /= defaultExp+             = if isSimplePatBind' pat+                then Just (patToPNT ps, locToExp beginPos endPos toks rhs)    +                else error "A complex pattern binding can not be generalised!"+           inPat _ = Nothing+++           isSimplePatBind' (Dec (HsPatBind _ p _ _)) = isPatID p++           isPatID (Pat (HsPId (HsVar pnt))) = True+           isPatID p = False+ +   -- Do generalisation in current module.+   doGeneralise pnt@(PNT pn _ _) fileName subExp newParamName newFunPName mod tokList+     = runStateT (if isJust newFunPName+                    then do -- add the new function name to the export list+                            mod'<-addItemsToExport mod (Just pn) False (Left [pNtoName (fromJust newFunPName)]) +                            doGeneralise' mod'+                    else doGeneralise' mod) ((tokList,unmodified),(-1000,0))+      where +    +      doGeneralise' mod +         = applyTP (once_tdTP (failTP `adhocTP` inMod+                                      `adhocTP` inMatch+                                      `adhocTP` inPat+                                      `adhocTP` inLet+                                      `adhocTP` inAlt+                                      `adhocTP` inStmt) `choiceTP` failure) mod               +        where++           --1.pn is declared in top level+           inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)  +               | definingDecls [pn] ds False False/=[] +              = do worker pnt subExp newParamName mod ds newFunPName +           inMod _ =mzero  +           +           --2. pn is declared locally in the where clause of a match.+           inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+               | definingDecls [pn] ds False  False/=[] +              = worker pnt subExp newParamName match ds newFunPName+           inMatch _ =mzero++           --3. pn is declared locally in the where clause of a pattern binding.+           inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+               | definingDecls [pn] ds False  False /=[] +              =  worker pnt subExp newParamName pat ds newFunPName                  +           inPat _=mzero+  +           --4: pn is declared locally in a  Let expression+           inLet (letExp@(Exp (HsLet ds e))::HsExpP)+               | definingDecls [pn] ds False  False /=[] +               = worker pnt subExp newParamName letExp ds newFunPName +           inLet _=mzero+                +           --5. pn is declared locally in a  case alternative.+           inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+               | definingDecls [pn] ds False  False/=[] +               = worker pnt subExp newParamName alt ds newFunPName+           inAlt _=mzero+      +            --6.pn is declared locally in a let statement.+           inStmt (letStmt@(HsLetStmt ds stmts):: HsStmtP)+               | definingDecls [pn] ds False  False/=[] +             = worker pnt subExp newParamName letStmt ds newFunPName +           inStmt _=mzero+            +           failure=idTP `adhocTP` mod+               where mod (m::HsModuleP)=error "Refactoring failed"+          ++      worker pnt@(PNT pn _ _) subExp newParamName parent ds newFunPName+       = do --add formal parameter to the generalised function+           let newParamPName = nameToPN newParamName +               declToBeGeneralised = definingDecls [pn] ds False False+           doChecking declToBeGeneralised+           parent' <- if isJust newFunPName +                       then do let declToAdd=Dec (HsPatBind loc0 (pNtoPat (fromJust newFunPName)) (HsBody subExp) [])+                               addDecl parent (Just pn) ([declToAdd],Nothing) True +                       else return parent                               +           ds''<-replaceExpByParam pn subExp newParamPName =<<commentOutTypeSig pn (hsDecls parent')+           ds'''<-addParamsToDecls ds'' pn [newParamPName] True++           --ds''<- addFormalParam pn subExp newParamName =<<commentOutTypeSig pn ds'  +           --Check clashed names because of the adding of subExp as a actual parameter.+           parent''<- renamingCheck pn subExp $ replaceDecls parent' ds'''+           --Adding the actual parameter to each call site of the generalised function name.+           addActualArg False pn subExp parent''+        where+         doChecking decl   +          = do (expFreeVars,_) <- hsFreeAndDeclaredPNs subExp+               (defFreeVars,_) <- hsFreeAndDeclaredPNs decl+               if expFreeVars \\ defFreeVars /= [] +                 then do error "The selected expression should not contain locally declared variables!" +                 else do (f,d) <- hsFDsFromInside =<<  replaceExpByDefault subExp decl       +                         d'   <- hsVisiblePNs  subExp decl                +                         if elem newParamName $ map pNtoName (f `union` d `union` d')+                          then error "The parameter name will cause name clash or semantics change, please choose another name!"+                          else return ()+                  +           +         {- substitute the occurrence of an expression by the default expression,+            in order to get rid of the free variables in the generalised sub-expression -}+         replaceExpByDefault e = applyTP (once_tdTP (failTP `adhocTP` inExp)) +          where+             --only replace the higelighted expression +            inExp (e1::HsExpP)+             |sameOccurrence e1 e +              = return defaultExp+            inExp x = mzero++         --Replace occurrence of the highlighted expression by the formal parameter.+         replaceExpByParam pn e paramPName = applyTP (once_tdTP (failTP `adhocTP` inDecl))                  +          where+            --The sub-expression is in the rhs of a function definition.+           inDecl (fun@(Dec (HsFunBind _  ((HsMatch _ (PNT pname _ _) _ _ _):ms)))::HsDeclP)+             | pn == pname +              = replaceExpByParam' fun+            --The sub-expression is in the rhs of a pattern binding+           inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+             | pn == patToPN  ps+              = replaceExpByParam' pat+           inDecl _ =mzero  +  +           replaceExpByParam'= applyTP (stop_tdTP (failTP `adhocTP` inExp))  -- use once_td to only replace the +                                                                                       -- highlighted occurrence.+             where+              inExp (e1 ::HsExpP)+                | e1 == e  -- && srcLocs e == srcLocs e1   --ONLY REPLACE THE HIGHLIGHTED EXP.                                 +                = do let newExp=pNtoExp paramPName+                     update e1 newExp e1                             ++              inExp e = mzero+                                 +         renamingCheck pn subExp parent+          = do --free variables declared in the highlighted expression+               (f,_) <- hsFreeAndDeclaredPNs subExp+                --visible variables to the generalised function name in its use places.+               vVars <- hsVisiblePNs pn parent+               --clasedNames names come  from the vVars+               let clashedNames = filter (\x->elem (pNtoName x) (map pNtoName f)) $  (nub vVars \\ nub f)+               if clashedNames == [] +                 then return parent+                 else error ("The identifier(s):" ++ showEntities showPNwithLoc clashedNames +++                          " will cause name capture/clash after generalisation, please do renaming first!")   ++      {- if the generalised declaration is a direct recursion function, then add the parameter +         as the actual argument; otherwise add the highlighted expression as a actual paramter +         to the generalised function at each of its call sites -}+    +   addActualArg recursion pn subExp+        = if recursion then applyTP (stop_tdTP (failTP `adhocTP` funApp))+                       else applyTP (stop_tdTP (failTP `adhocTP` inDecl+                                                       `adhocTP` funApp))+       where +         inDecl (fun@(Dec (HsFunBind _  ((HsMatch _ (PNT pname _ _) _ _ _):ms)))::HsDeclP)+           | pn == pname +           = return fun++         inDecl (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+           | pn == patToPN  ps+           = return pat             +         inDecl _ = mzero+        +         funApp (Exp (HsApp e  exp@(Exp (HsId (HsVar pnt@(PNT pname _ _ )))))::HsExpP)+           | pname == pn --ganrantee this is a use place of pn +          = do exp'<-doAddingActulaArg pnt exp subExp True+               return (Exp (HsApp e  exp'))++         funApp (exp@(Exp (HsId (HsVar pnt@(PNT pname _ _))))::HsExpP)   +           | pname == pn  --ganrantee this is a use place of pn+          = doAddingActulaArg pnt exp subExp False++         funApp _ = mzero++   doAddingActulaArg pnt pntExp subExp addParen+     = do let newExp = if isSimpleExp subExp || isParenExp subExp +                         then if addParen then (Exp (HsParen (Exp (HsApp pntExp subExp)))) +                                          else (Exp (HsApp pntExp subExp))+                         else if addParen then (Exp (HsParen (Exp (HsApp pntExp (Exp (HsParen subExp))))))+                                          else (Exp (HsApp pntExp (Exp (HsParen subExp))))+          update pntExp newExp pntExp          ++     where ++       +       isSimpleExp (Exp (HsId _))=True+       isSimpleExp (Exp (HsLit _ _))=True+       isSimpleExp _ =False++       isParenExp (Exp (HsParen _))=True+       isParenExp _=False+     +   addActualArgInClientMod pn qual funName toBeQualified t+      = applyTP (stop_tdTP (failTP `adhocTP`funApp)) t+       where +         funApp (Exp (HsApp e  exp@(Exp (HsId (HsVar pnt@(PNT pname _ _ )))))::HsExpP)+           | pname == pn --ganrantee this is a use place of pn +          = do vs <- hsVisibleNames pnt t +               let e'=if toBeQualified || elem (pNtoName funName) vs  +                        then pNtoExp (qualifyPName qual funName)+                        else pNtoExp funName+               exp'<- doAddingActulaArg pnt exp  e' True             +               return (Exp (HsApp e  exp'))++         funApp (exp@(Exp (HsId (HsVar pnt@(PNT pname _ _))))::HsExpP)   +           | pname == pn  --ganrantee this is a use place of pn+          = do vs <- hsVisibleNames pnt t +               let e'=if toBeQualified || elem (pNtoName funName) vs  +                        then pNtoExp (qualifyPName qual funName)+                        else pNtoExp funName+               doAddingActulaArg pnt exp e' False       +      +         funApp _ = mzero+        +   generaliseInClientMod pnt subExp serverModName newFunPName ((inscps, exps, mod,ts) ,fileName)+      = let qual  = hsQualifier  pnt inscps+            pn    = pNTtoPN pnt+        in if qual==[]+            then --This name is not imported+                 return ((fileName,unmodified), (ts,mod))+            else do (mod',((ts',m), _))+                       <- runStateT (if isNothing newFunPName +                                       then addActualArg False pn subExp mod+                                       else do let funName=fromJust newFunPName+                                               mod' <- addItemsToImport serverModName (Just pn) (Left [pNtoName funName]) mod+                                               mod''<- addItemsToExport mod' (Just pn) False (Left [pNtoName funName]) +                                               if isInScopeAndUnqualified (pNtoName pn) inscps+                                                 then addActualArgInClientMod pn  (head qual) funName False mod''+                                                 else addActualArgInClientMod pn  (head qual) funName True mod'')+                                     ((ts,unmodified), (-1000,0))+                    return ((fileName,m),(ts',mod'))    ++myfst (a,_,_,_) = a  ++{- Create the auxiliary function name. Suppose the original function name is 'f', +   then the auxiliary function name is like 'f_gen_i', where i is an integer. -}+mkNewFunPName pn e modName inscopeNames +   =do  (f1,d1) <- hsFDsFromInside e+        let name=mkNewName ((pNtoName pn)++"_gen") (nub ((map pNtoName (f1 `union` d1)) `union` inscopeNames)) 0  +        return (PN (UnQual name) (G modName name (N (Just loc0))))+
+ refactorer/RefacGenFold.hs view
@@ -0,0 +1,731 @@+module RefacGenFold where++import PFE0+import HsTokens+import TypeCheck+import PrettyPrint+import PosSyntax+import HsName+import HsLexerPass1+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils hiding (getParams)+import PFE0 (findFile, allFiles, allModules)+import MUtils (( # ))+import RefacLocUtils+import System+import IO+import Relations+import Ents+import Data.Set (toList)+import Data.List+import System.IO.Unsafe+import System.Cmd+import LocalSettings+import RefacSimplify+import StateMT(WithState,withSt,withStS,getSt,setSt,updSt,updSt_)+import qualified Control.Exception as CE (catch)+import EditorCommands+-- | An argument list for a function which of course is a list of paterns.+type FunctionPats = [HsPatP]++-- | A list of declarations used to represent a where or let clause.+type WhereDecls = [HsDeclP]++data PatFun = Mat | Patt | Er deriving (Eq, Show)++genFold args + = do+     let fileName = ghead "fileName'" args +         beginRow         = read (args!!1)::Int+         beginCol         = read (args!!2)::Int+         endRow           = read (args!!3)::Int+         endCol           = read (args!!4)::Int+     AbstractIO.putStrLn "genFold" +     +     modName <-fileNameToModName fileName+     let modName1 = convertModName modName+     (inscps, exps, mod, tokList)<-parseSourceFile fileName+     let subExp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod+     let (ty, pnt, pats, wh)+             = findDefNameAndExp tokList+                                 (beginRow, beginCol)+                                 (endRow, endCol)+                                 mod+          +     ((_,m), (newToks, (newMod, e))) <- applyRefac (addCommentDec pnt) (Just (inscps, exps, mod, tokList)) fileName+          +          +          +     writeRefactoredFiles False [((fileName, m), (newToks, newMod))]+          +     (inscps', exps', mod', tokList') <- parseSourceFile fileName+     +     +     ((_,m'), (newToks', (newMod',parsed))) <- applyRefac (retrieveDecAndRemove pnt e) +                                                           (Just (inscps', exps', mod', tokList')) fileName+               +     let pnt' = declToPNT parsed          +     -- undo the added entry!                                         +     undoLatestInHistory+     (inscps2, exps2, mod2, tokList2)<-parseSourceFile fileName+     ((_,m'''), (newToks''', newMod''')) <- applyRefac (changeExpression pnt pnt' parsed subExp) +                                                        (Just (inscps2, exps2, mod2, tokList2)) fileName+     writeRefactoredFiles False  [((fileName, m'''), (newToks''', newMod'''))]+     +     +     +     AbstractIO.putStrLn "Completed.\n"++addCommentDec pnt (_,_,t)+ = do+      tks <- extractComment (pNTtoPN pnt) t+      let tksString = concatMap getName tks+      let commentDef = dropWhile (==' ') (parseComment (reverse tksString))+      if '=' `elem` commentDef+       then do  +         mod <- insertTerm (dropWhile (==' ') (reverse commentDef)) (pNTtoPN pnt) t+         return (mod, (dropWhile (==' ') (reverse commentDef)))+       else do+         error "Please define an equation within a comment above the definition under scrutiny."++retrieveDecAndRemove pnt e (_,_,t)+ = do+      let parsedDec = retrieveDec pnt e t+      -- mod <- removeDec e t+      return (t, parsedDec)++retrieveDec pnt exp t+  = fromMaybe (error ("Previous record of definition not found! " ++ exp))+              (applyTU (once_tdTU (failTU `adhocTU` inDec)) t)+      where++      +        inDec d@(Dec (HsPatBind _ _ _ _))+          | (render.ppi) d == exp +              = Just d+        inDec d@(Dec (HsFunBind l matches))+          | rendered matches exp+               = do+                  let x = rendered2 matches exp+                  Just (Dec (HsFunBind l [x]))+        inDec d = Nothing ++        rendered [] _ = False+        rendered (m:ms) e+          | rmLine ( rmToks ((render.ppi) m)) == rmLine ( rmToks e ) = True+          | otherwise           = rendered ms e+          +        rendered2 [] _ = error "Error in rendered2"+        rendered2 (m:ms) e +          | rmLine ( rmToks ((render.ppi) m)) == rmLine ( rmToks e ) = m+          | otherwise           = rendered2 ms e++        rmToks x = (rmRBracket.rmLBracket.rmLine.rmSpace) x++        rmSpace x = filter (/=' ') x+        rmLine x = filter (/='\n') x+        rmLBracket x = filter (/='(') x+        rmRBracket x = filter (/=')') x+removeDec exp t+  = applyTP (stop_tdTP (idTP `adhocTP` inDec)) t+      where+        inDec (d::HsDeclP)+          | (render.ppi) d == exp +              = do+                   rmDecl (declToPName2 d) True [d] +                   return d +        inDec d = return d+++     ++parseComment :: String -> String+parseComment [] = []+parseComment ('}':('-':xs)) = parseComment' xs+parseComment (x:xs) = parseComment xs++parseComment' :: String -> String+parseComment' [] = []+parseComment' ('-':('{':xs)) = ""+parseComment' (x:xs) = x : (parseComment' xs)++getName :: PosToken -> String+getName (_, ((Pos _ _ _), s)) = s ++changeExpression pnt pntComment d exp (_,_,t)+ = do +      mod <- changeExpression' pnt pntComment d exp t+      return mod     +      +changeExpression' pnt pntComment d exp t+  = applyTP (stop_tdTP (failTP `adhocTP` (inExp d exp))) t+      where+        inExp (Dec (HsPatBind _ p (HsBody e2) ds)) exp (e::HsExpP)+          | sameOccurrence exp e +              = do+                  if rmAllLocs e2 == rmAllLocs e+                    then do   +                      res <- update e (nameToExp (pNTtoName (patToPNT p))) e+                      return res+                    else do+                      mzero+        inExp (dec@(Dec (HsFunBind s matches))::HsDeclP) exp (e::HsExpP)+          | sameOccurrence exp e+                = do+                      let match@(HsMatch loc name pats (HsBody e2) ds) = getMatch pntComment matches+                      let newExp = searchForRHS pnt exp t+                      let (pred, newParams) = rewriteExp pats newExp e2+                      if pred+                         then do  +                          -- let patsConverd = map (render.ppi) newPats+                          res <- update e (createFunc pntComment (map patToExp newParams)) e+                          return res+                         else do+                          mzero+        inExp d exp e = mzero++rewriteExp :: [HsPatP] -> HsExpP -> HsExpP -> (Bool, [HsPatP])+rewriteExp pats (Exp (HsParen e)) e2 = rewriteExp pats e e2+rewriteExp pats e (Exp (HsParen e2)) = rewriteExp pats e e2+rewriteExp pats (Exp (HsLit s x)) (Exp (HsLit s1 x2))+ | x == x2 = (True, pats)+rewriteExp pats (Exp (HsId (HsCon x))) (Exp (HsId (HsCon y)))+ | x == y = (True, pats) +rewriteExp pats n m@(Exp (HsId (HsVar i2)))+ | checkPNTInPat pats i2 = (True, getPatFromPats pats n i2)+rewriteExp pats n@(Exp (HsId (HsVar i1))) (Exp (HsId (HsVar i2)))+ | (pNTtoName i1) /= (pNTtoName i2) && checkPNTInPat pats i2 = (True, getPatFromPats pats n i2)+ | (pNTtoName i1) == (pNTtoName i2)  = (True, pats)+ | isLocalPNT i1 && isLocalPNT i2 = (True, pats)+ | otherwise = (False, pats)+rewriteExp pats a@(Exp (HsApp e1 e2)) b@(Exp (HsApp e3 e4))+ | pred1 == True && pred2 == True = (True, pats2)+   where+    (pred1, pats1) = rewriteExp pats  e1 e3+    (pred2, pats2) = rewriteExp pats1 e2 e4+rewriteExp pats a@(Exp (HsInfixApp e1 o1 e2)) b@(Exp (HsInfixApp e3 o2 e4))+ | o1 == o2 && (pred1 && pred2) = (True, pats2)+     where+       (pred1, pats1) = rewriteExp pats e1 e3+       (pred2, pats2) = rewriteExp pats1 e2 e4 +rewriteExp pats a@(Exp (HsTuple e1)) b@(Exp (HsTuple e2))+ | length e1 == length e2 && pred = (True, pats2)+ | otherwise = (False, pats)+    where+      (pred, pats2) = checkList pats e1 e2+rewriteExp pats a@(Exp (HsList e1)) b@(Exp (HsList e2))+ | length e1 == length e2 = (True, pats2)+ | otherwise = (False, pats)+    where+      (pred, pats2) = checkList pats e1 e2      +rewriteExp pats a@(Exp (HsLeftSection e1 i1)) b@(Exp (HsLeftSection e2 i2))+ | i1 == i2 && pred1 = (True, pats1)+     where+       (pred1, pats1) = rewriteExp pats e1 e2  +rewriteExp pats a@(Exp (HsRightSection i1 e1)) b@(Exp (HsRightSection i2 e2))+ | i1 == i2 && pred1 = (True, pats1)+     where+       (pred1, pats1) = rewriteExp pats e1 e2  +rewriteExp pats a@(Exp (HsEnumFrom e1)) b@(Exp (HsEnumFrom e2))+ | pred1 = (True, pats1)+   where+     (pred1, pats1) = rewriteExp pats e1 e2+rewriteExp pats a@(Exp (HsEnumFromTo e1 e2)) b@(Exp (HsEnumFromTo e3 e4))+ | pred1 && pred2 = (True, pats2)+    where+       (pred1, pats1) = rewriteExp pats e1 e3+       (pred2, pats2) = rewriteExp pats1 e2 e4 +rewriteExp pats a@(Exp (HsEnumFromThen e1 e2)) b2@(Exp (HsEnumFromThen e3 e4))+ | pred1 && pred2 = (True, pats2)+    where+       (pred1, pats1) = rewriteExp pats e1 e3+       (pred2, pats2) = rewriteExp pats1 e2 e4 +rewriteExp pats a@(Exp (HsEnumFromThenTo e1 e2 e3)) b@(Exp (HsEnumFromThenTo e4 e5 e6))+ | pred1 && pred2 && pred3 = (True, pats3)+    where+      (pred1, pats1) = rewriteExp pats e1 e4+      (pred2, pats2) = rewriteExp pats1 e2 e5+      (pred3, pats3) = rewriteExp pats2 e3 e6+rewriteExp pats a@(Exp (HsIf e1 e2 e3)) b@(Exp (HsIf e4 e5 e6))+ | pred1 && pred2 && pred3 = (True, pats3)+    where+      (pred1, pats1) = rewriteExp pats e1 e4+      (pred2, pats2) = rewriteExp pats1 e2 e5+      (pred3, pats3) = rewriteExp pats2 e3 e6+rewriteExp pats a@(Exp (HsNegApp s e)) b@(Exp (HsNegApp s2 e2))+ | pred = (True, pats1)+   where+     (pred, pats1) = rewriteExp pats e e2+rewriteExp pats a@(Exp (HsListComp stmts1)) b@(Exp (HsListComp stmts2))+ | pred = (True, pats1)+   where+     (pred, pats1) = rewriteExpStmts pats stmts1 stmts2+rewriteExp pats (Exp (HsDo stmts1)) (Exp (HsDo stmts2))+ | pred = (True, pats1)+    where+      (pred, pats1) = rewriteExpStmts pats stmts1 stmts2+rewriteExp pats a@(Exp (HsLambda ps e1)) b@(Exp (HsLambda ps2 e2))+ | wildCardAllPNs ps == wildCardAllPNs ps2 && pred = (True, pats1)+   where+     (pred, pats1) = rewriteExp pats e1 (localRewriteExp e2 (localRewritePats ps ps2))+     localRewritePats [] ps = []+     localRewritePats ps [] = []+     localRewritePats (p1:p1s) (p2:p2s) +        = (rewritePat p2 p1) : (localRewritePats p1s p2s)+        +     localRewriteExp e [] = e   +     localRewriteExp e (p1:p1s)+       = let e1' = rewritePatsInExp p1 e  in localRewriteExp e1' p1s+       +rewriteExp pats a@(Exp (HsRecConstr s i fields1)) b@(Exp (HsRecConstr s2 i2 fields2))+ | i == i2 && pred = (True, pats1)+    where+      (pred, pats1) = rewriteExpFields pats fields1 fields2+rewriteExp pats a@(Exp (HsRecUpdate s1 e1 fields1)) b@(Exp (HsRecUpdate s2 e2 fields2))+ | pred1 && pred2 = (True, pats2)+   where+     (pred1, pats1) = rewriteExp pats e1 e2+     (pred2, pats2) = rewriteExpFields pats1 fields1 fields2+rewriteExp pats a@(Exp (HsCase e1 alts1)) b@(Exp (HsCase e2 alts2))+  | pred1 && pred2 = (True, pats2)+    where+      (pred1, pats1) = rewriteExp pats e1 e2+      (pred2, pats2) = rewriteExpAlts pats1 alts1 alts2++-- rewriteExp pats e1 e2 = error $ ">" ++ (show (pats, e1, e2))+rewriteExp pats e1 e2 = (False, pats) --  error $ ">" ++ (show (pats, e1, e2))++rewriteExpFields pats [] _ = (True, pats)+rewriteExpFields pats _ [] = (True, pats)+rewriteExpFields pats ((HsField i1 e1):f1) ((HsField i2 e2):f2)+  | pred && (i1 == i2 && pred2) = (True, pats2)+  | otherwise = (False, pats)+     where+       (pred, pats1) = rewriteExp pats e1 e2 +       (pred2, pats2) = rewriteExpFields pats1 f1 f2+  +rewriteExpAlts pats [] _ = (True, pats)+rewriteExpAlts pats _ [] = (True, pats)+rewriteExpAlts pats ((HsAlt _ p1 (HsBody e1) ds1):alts1) ((HsAlt _ p2 (HsBody e2) ds2):alts2)+  | pred && (wildCardAllPNs p1 == wildCardAllPNs p2 && pred2) = (True, pats2)+  | otherwise = (False, pats)+     where+       (pred, pats1) = rewriteExp pats e1 (rewritePatsInExp (rewritePat p2 p1) e2)+       (pred2, pats2) = rewriteExpAlts pats1 alts1 alts2+rewriteExpAlts pats ((HsAlt _ p1 (HsGuard gs1) ds1):alts1) ((HsAlt _ p2 (HsGuard gs2) ds2):alts2)+  | (wildCardAllPNs p1 == wildCardAllPNs p2 && pred2) = (True, pats2)+  | otherwise = (False, pats)+     where+       -- (pred, pats1) = rewriteExp pats e1 e2 +       (pred2, pats2) = rewriteExpGuards pats gs1 res+       res =  (rewritePatsInGuard (rewritePat p2 p1) gs2)+rewriteExpAlts pats _ _ = (False, pats)++rewriteExpGuards pats [] _ = (True, pats)+rewriteExpGuards pats _ [] = (True, pats)+rewriteExpGuards pats ((_ ,e1,e2):gs1) ((_, e3, e4):gs2)    +  | pred1 && pred2 && pred3 = (True, pats3)+    where+     (pred1, pats1) = rewriteExp pats e1 e3+     (pred2, pats2) = rewriteExp pats1 e2 e4+     (pred3, pats3) = rewriteExpGuards pats2 gs1 gs2     +       +       +rewriteExpStmts pats s1@(HsGenerator _ p1 e1 m1) s2@(HsGenerator _ p2 e2 m2)+ | wildCardAllPNs p1 == wildCardAllPNs p2 && pred1 && pred2 = (True, pats2)+  where+   (pred1, pats1) =  rewriteExp pats e1 e2 +   (pred2, pats2) = rewriteExpStmts pats1 m1 m2+rewriteExpStmts pats (HsLast e1) (HsLast e2)+ | wildCardAllPNs e1 == wildCardAllPNs e2 = (True, pats)+ -- = error $ show $ rewriteExp pats e1 e2+rewriteExpStmts pats (HsQualifier e1 stmts) (HsQualifier e2 stmts2)+ | pred1 && pred2 = (True, pats2)+  where+   (pred1, pats1) =  rewriteExp pats e1 e2 +   (pred2, pats2) = rewriteExpStmts pats1 stmts stmts2+rewriteExpStmts pats (HsLetStmt ds1 stmts) (HsLetStmt ds2 stmts2)+ = rewriteExpStmts pats stmts stmts2+rewriteExpStmts pats s1 s2 = (False, pats)++changeAllNames :: PNT -> PNT -> PNT +changeAllNames pnt  t =runIdentity (applyTP (full_buTP (idTP `adhocTP` l)) t) +   where +         l ((PN (UnQual n) s)) +           | n /= (pNTtoName pnt) =  return ((PN (UnQual (pNTtoName pnt)) s))+           | otherwise = return ((PN (UnQual n) s))++rewritePat :: HsPatP -> HsPatP -> HsPatP+rewritePat a@(Pat (HsPId (HsVar x))) b@(Pat (HsPId (HsVar y)))+  = (Pat (HsPId (HsVar (changeAllNames y x))))+rewritePat a@(Pat (HsPId (HsCon x))) b@(Pat (HsPId (HsCon y)))+  = a+rewritePat a@(Pat (HsPLit _ _)) b@(Pat (HsPLit _ _))+  = a+rewritePat a@(Pat (HsPNeg _ _)) b@(Pat (HsPNeg _ _)) +  = a+rewritePat a@(Pat (HsPSucc _ _ _)) b@(Pat (HsPSucc _ _ _))+  = a+rewritePat a@(Pat (HsPInfixApp p1 i p2)) b@(Pat (HsPInfixApp p3 i2 p4))+  = (Pat (HsPInfixApp (rewritePat p1 p3) i (rewritePat p2 p4)))+rewritePat a@(Pat (HsPApp i ps)) b@(Pat (HsPApp i2 ps2))+  = (Pat (HsPApp i (rewritePat' ps ps2)))+rewritePat a@(Pat (HsPTuple s ps)) b@(Pat (HsPTuple s2 ps2))+  = (Pat (HsPTuple s (rewritePat' ps ps2)))+rewritePat a@(Pat (HsPList s ps)) b@(Pat (HsPList s2 ps2))+  = (Pat (HsPList s (rewritePat' ps ps2)))+rewritePat a@(Pat (HsPParen p1)) b@(Pat (HsPParen p2))+  = (Pat (HsPParen (rewritePat p1 p2)))+rewritePat a@(Pat (HsPAsPat i p1)) b@(Pat (HsPAsPat i2 p2))+  = (Pat (HsPAsPat i (rewritePat p1 p2)))+rewritePat a@(Pat (HsPWildCard)) b@(Pat (HsPWildCard))+ = a+rewritePat a@(Pat (HsPIrrPat p1)) b@(Pat (HsPIrrPat p2))+ = Pat (HsPIrrPat (rewritePat p1 p2))+rewritePat a b = a++rewritePat' :: [HsPatP] -> [HsPatP] -> [HsPatP]+rewritePat' [] _ = []+rewritePat' x [] = x+rewritePat' (x:xs) (y:ys)+  = rewritePat x y : rewritePat' xs ys+ + +rewritePatsInExp :: HsPatP -> HsExpP -> HsExpP+rewritePatsInExp p a@(Exp (HsId (HsVar x))) + | isTopLevelPNT x = a+ | otherwise+   = (Exp (HsId (HsVar newPNT)))+     where+       newPNT = grabPNT x (hsPNTs p)+rewritePatsInExp p (Exp (HsInfixApp e1 o e2))+  = (Exp (HsInfixApp e1' o e2'))+      where+        e1' = rewritePatsInExp p e1+        e2' = rewritePatsInExp p e2+rewritePatsInExp p (Exp (HsApp e1 e2)) +  = (Exp (HsApp e1' e2'))+      where+        e1' = rewritePatsInExp p e1+        e2' = rewritePatsInExp p e2+rewritePatsInExp p (Exp (HsNegApp s e))+  = (Exp (HsNegApp s e'))+     where+       e' = rewritePatsInExp p e+rewritePatsInExp p (Exp (HsLambda ps e))+  = (Exp (HsLambda ps e'))+     where+       e' = rewritePatsInExp p e+rewritePatsInExp p (Exp (HsLet ds e))+  = (Exp (HsLet ds e'))+     where+       e' = rewritePatsInExp p e+rewritePatsInExp p (Exp (HsIf e1 e2 e3))+  = (Exp (HsIf e1' e2' e3'))+     where+       e1'  = rewritePatsInExp p e1+       e2'  = rewritePatsInExp p e2+       e3'  = rewritePatsInExp p e3+rewritePatsInExp p (Exp (HsCase e alts))+  = (Exp (HsCase e' alts'))+      where+        e' = rewritePatsInExp p e+        alts' = rewritePatsInAlts p alts+rewritePatsInExp p (Exp (HsDo stmts))+  = (Exp (HsDo stmts'))+     where+       stmts' = rewritePatsInStmts p stmts+rewritePatsInExp p (Exp (HsTuple es))+  = (Exp (HsTuple es'))+     where+      es' = map (rewritePatsInExp p) es        +rewritePatsInExp p (Exp (HsList es))+  = (Exp (HsList es'))+     where+       es' = map (rewritePatsInExp p) es+rewritePatsInExp p (Exp (HsParen e))+  = (Exp (HsParen (rewritePatsInExp p e)))+rewritePatsInExp p (Exp (HsLeftSection e (HsVar x)))+  = (Exp (HsLeftSection e' (HsVar newPNT)))+     where+       e' = rewritePatsInExp p e'+       newPNT = grabPNT x (hsPNTs p)+rewritePatsInExp p (Exp (HsRightSection (HsVar x) e))+  = (Exp (HsRightSection (HsVar newPNT) e'))+     where+       e' = rewritePatsInExp p e'+       newPNT = grabPNT x (hsPNTs p)+rewritePatsInExp p (Exp (HsRecConstr s i fields))+  = (Exp (HsRecConstr s newPNT fields'))+      where+        newPNT = grabPNT i (hsPNTs p)+        fields' = rewritePatsInFields p fields+rewritePatsInExp p (Exp (HsRecUpdate s e fields))+  = (Exp (HsRecUpdate s e' fields'))+      where+       e' = rewritePatsInExp p e+       fields' = rewritePatsInFields p fields+rewritePatsInExp p (Exp (HsEnumFrom e))+ = (Exp (HsEnumFrom e'))+    where+     e' = rewritePatsInExp p e+rewritePatsInExp p (Exp (HsEnumFromTo e1 e2))+ = (Exp (HsEnumFromTo e1' e2'))+    where+      e1' = rewritePatsInExp p e1+      e2' = rewritePatsInExp p e2+rewritePatsInExp p (Exp (HsEnumFromThen e1 e2))+ = (Exp (HsEnumFromThen e1' e2'))+     where+       e1' = rewritePatsInExp p e1+       e2' = rewritePatsInExp p e2+rewritePatsInExp p (Exp (HsEnumFromThenTo e1 e2 e3))+ = (Exp (HsEnumFromThenTo e1' e2' e3'))+     where+       e1' = rewritePatsInExp p e1+       e2' = rewritePatsInExp p e2+       e3' = rewritePatsInExp p e3+rewritePatsInExp p (Exp (HsListComp stmts))+ = (Exp (HsListComp stmts'))+     where+       stmts' = rewritePatsInStmts p stmts+rewritePatsInExp p e = e++rewritePatsInStmts :: HsPatP -> HsStmtP -> HsStmtP+rewritePatsInStmts p (HsGenerator s p2 e stmts)+ = (HsGenerator s p2 e' stmts')+   where+     e' = rewritePatsInExp p e+     stmts' = rewritePatsInStmts p stmts+rewritePatsInStmts p (HsQualifier e stmts)+ = (HsQualifier e' stmts')+    where+     e' = rewritePatsInExp p e+     stmts' = rewritePatsInStmts p stmts+rewritePatsInStmts p (HsLetStmt ds stmts)+ = (HsLetStmt ds stmts')+    where+     stmts' = rewritePatsInStmts p stmts+rewritePatsInStmts p (HsLast e)+ = (HsLast e')+    where+      e' = rewritePatsInExp p e++rewritePatsInFields :: HsPatP -> [HsFieldP] -> [HsFieldP]+rewritePatsInFields p [] = []+rewritePatsInFields p ((HsField i e):fs)+ = (HsField newPNT e') : (rewritePatsInFields p fs)+    where+      newPNT = grabPNT i (hsPNTs e)+      e' = rewritePatsInExp p e++rewritePatsInAlts :: HsPatP -> [HsAltP] -> [HsAltP]+rewritePatsInAlts p [] = []+rewritePatsInAlts p ((HsAlt s p2 (HsBody e) ds):alts)+ = (HsAlt s p2 (HsBody e') ds) : (rewritePatsInAlts p alts)+     where+       e' = rewritePatsInExp p e+rewritePatsInAlts p ((HsAlt s p2 (HsGuard gs) ds):alts)+ = (HsAlt s p2 (HsGuard gs') ds) : (rewritePatsInAlts p alts)+     where+       gs' = rewritePatsInGuard p gs++rewritePatsInGuard :: HsPatP -> [(SrcLoc, HsExpP, HsExpP)] -> [(SrcLoc, HsExpP, HsExpP)]+rewritePatsInGuard p [] = []+rewritePatsInGuard p ((s, e1, e2):gs)+ = (s, e1', e2') : (rewritePatsInGuard p gs)+    where+      e1' = rewritePatsInExp p e1+      e2' = rewritePatsInExp p e2+++grabPNT :: PNT -> [PNT] -> PNT+grabPNT x [] = x+grabPNT x (y:ys)+  | defineLoc x == defineLoc y = y+  | otherwise = grabPNT x ys+++checkList :: [HsPatP] -> [HsExpP] -> [HsExpP] -> (Bool, [HsPatP])+checkList pats [] [] = (True, pats)+checkList pats [e] [l] = rewriteExp pats e l+checkList pats (e:es) (l:ls) +        | pred = checkList pats' es ls+        | otherwise = (False, pats')+           where+             (pred, pats') = rewriteExp pats e l+checkPNTInPat :: [HsPatP] -> PNT -> Bool+checkPNTInPat [] _ = False+checkPNTInPat (p:ps) i +        | defineLoc i == (SrcLoc "__unknown__" 0 0 0) = False+        | defineLoc i == defineLoc (patToPNT p) = True+        | otherwise = checkPNTInPat ps i+++getPatFromPats :: [HsPatP] -> HsExpP -> PNT -> [HsPatP]+getPatFromPats [] _ _ = []+getPatFromPats (p:pats) e i2+     | defineLoc i2 == (SrcLoc "__unknown__" 0 0 0) = p : (getPatFromPats pats e i2)+     | defineLoc i2 == defineLoc (patToPNT p) = (expToPat e) ++ (getPatFromPats pats e i2)+     | otherwise = p : (getPatFromPats pats e i2)++patToExp :: HsPatP -> HsExpP+patToExp (Pat (HsPId x)) = (Exp (HsId x))+patToExp (Pat (HsPLit s l)) = (Exp (HsLit s l))+patToExp (Pat (HsPInfixApp p1 i p2)) = (Exp (HsInfixApp (patToExp p1) (HsCon i) (patToExp p2)))+patToExp (Pat (HsPApp pnt p2)) = (Exp (HsApp (nameToExp (pNTtoName pnt)) (cApp p2)))+                                    where+                                      cApp :: [HsPatP] -> HsExpP+                                      cApp [p] = patToExp p+                                      cApp (p:ps) = Exp (HsApp (cApp (init (p:ps))) (patToExp (last ps)))+patToExp (Pat (HsPTuple s ps)) = (Exp (HsTuple (map patToExp ps)))+patToExp (Pat (HsPList s ps)) = (Exp (HsList (map patToExp ps)))+patToExp (Pat (HsPParen p1)) = (Exp (HsParen (patToExp p1)))+patToExp (Pat (HsPAsPat pnt pat)) = (Exp (HsId (HsVar pnt)))+patToExp (Pat (HsPIrrPat p)) = patToExp p+patToExp (Pat (HsPWildCard)) = nameToExp "undefined"++expToPat :: HsExpP -> [HsPatP]+expToPat (Exp (HsId x)) = [Pat (HsPId x)]+expToPat (Exp (HsLit s l)) = [Pat (HsPLit s l)]+expToPat (Exp (HsInfixApp e1 (HsVar i) e2)) = [Pat (HsPInfixApp (ghead "expToPat" $ expToPat e1) +                                                             i (ghead "expToPat" $ expToPat e2))]+expToPat (Exp (HsInfixApp e1 (HsCon i) e2)) = [Pat (HsPInfixApp (ghead "expToPat" $ expToPat e1) +                                                             i (ghead "expToPat" $ expToPat e2))]+expToPat e@(Exp (HsApp e1 e2)) =    [Pat (HsPApp (nameToPNT " ")+                                                   (concatMap expToPat exps))]+                               where+                                 exps = flatternApp e         +expToPat (Exp (HsLambda ps e)) = ps+expToPat (Exp (HsTuple es)) = concatMap expToPat es   --[Pat (HsPTuple loc0 (concatMap expToPat es))]+expToPat (Exp (HsList es)) = concatMap expToPat es+expToPat (Exp (HsParen e1)) = [Pat (HsPParen (ghead "expToPat" $ expToPat e1))]+expToPat e = [] ++flatternApp :: HsExpP -> [HsExpP]+flatternApp (Exp (HsApp e1 e2)) = flatternApp e1 ++ flatternApp e2+flatternApp (Exp (HsParen e)) = flatternApp e+flatternApp x = [x]++searchForRHS pnt exp t+  = (fromMaybe (error "Could not find the right hand side for the commented definition!"))+    (applyTU (once_tdTU (failTU `adhocTU` (inDec exp))) t)+      where+        inDec e (pat@(Dec (HsPatBind loc1 ps rhs@(HsBody e2) ds))::HsDeclP)+         | findEntity e e2+            = do+               let newExp = symbolicallyTie exp e2 []+               Just newExp               +        +        inDec e (dec@(Dec (HsFunBind s matches))::HsDeclP)+         | findPNT pnt matches+          = do+               let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches+                   +               if findEntity e (extractRHS e rhs)+                  then do+                         let newExp = symbolicallyTie exp (extractRHS e rhs) pats+                         Just newExp+                  else do+                         mzero+        inDec _ d = mzero++findGuard e [] = error "Cannot find highlight expression!"+findGuard e ((_,_,x):xs) +  | findEntity e x = x+  | otherwise = findGuard e xs+extractRHS e (HsBody x) = x+extractRHS e (HsGuard gs) = findGuard e gs++symbolicallyTie exp (Exp (HsParen e)) pats = symbolicallyTie exp e pats +symbolicallyTie exp n@(Exp (HsCase e alts)) pats+     = symbolicallyTie' alts  -- (Exp (HsCase e [symbolicallyTie' alts]))+        where+          symbolicallyTie' [] = error "Error in symbolic evaluation: expression does not occur on the RHS!" +          symbolicallyTie' (a@(HsAlt l p (HsGuard gs) ds):as)+           | findEntity exp gs+            = zipPatExp e n a' pats+           | findEntity exp ds           -- selected definition is in where clause of a case alt.+            = zipPatExp e n a' pats+            where+              a' = (HsAlt l p (HsBody exp) ds)+          symbolicallyTie' (a@(HsAlt l p (HsBody e2) ds):as) +           | findEntity exp e2+               = zipPatExp e n a' pats+           | findEntity exp ds           -- selected definition is in where clause of a case alt.+               = zipPatExp e n a' pats+           | otherwise = symbolicallyTie' as+            where+              a' = (HsAlt l p (HsBody exp) ds)+symbolicallyTie exp e pats = exp          +-- utility functions +getMatch :: PNT -> [HsMatchP] -> HsMatchP   +getMatch _ [] = error "Please select a case in top-level expression scope!"+getMatch pnt (match@(HsMatch loc name pats rhs ds):ms)+  | useLoc pnt == useLoc name      = match+  | otherwise        = getMatch pnt ms +     +convertModName (PlainModule s) = s+convertModName m@(MainModule f) = modNameToStr m ++{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (PatFun, PNT, FunctionPats, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+                     +findDefNameAndExp toks beginPos endPos t+  = fromMaybe (Er, defaultPNT, [], [])+              (applyTU (once_buTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t)++    where+      --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats rhs@(HsBody e) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (Mat, pnt, pats, ds)+      inMatch (match@(HsMatch loc1  pnt pats rhs@(HsGuard e) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (Mat, pnt, pats, ds)          +      inMatch _ = Nothing+++      --The selected sub-expression is in the rhs of a pattern-binding+      inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+        | locToExp beginPos endPos toks rhs /= defaultExp+            = if isSimplePatBind pat+                 then Just (Patt, patToPNT ps, [], ds)    +                 else Just (Patt, pnt, pats, ds)+                    where +                      (_, pnt, pats, ds') = findDefining pat t+                      findDefining pats t +                        = fromMaybe (error "Error: the selected entity is a top level complex pattern binding!")+                                    (applyTU (once_buTU (failTU `adhocTU` inMatch')) t)+                                    +                      inMatch' (match@(HsMatch loc1  pnt pats rhs@(HsBody e) ds)::HsMatchP)+                         | pat `elem` ds = Just (Mat, pnt, pats, ds)+                         | findEntity pat e = Just (Mat, pnt, pats, ds)+                      inMatch' (match@(HsMatch loc1  pnt pats rhs@(HsGuard e) ds)::HsMatchP)+                         | pat `elem` ds = Just (Mat, pnt, pats, ds)+                         | findEntity pat e = Just (Mat, pnt, pats, ds)+                      inMatch' _ = Nothing+                    +      inPat _ = Nothing+
+ refactorer/RefacIdentify.hs view
@@ -0,0 +1,61 @@+module RefacIdentify where++import System.IO.Unsafe+import PosSyntax hiding (ModuleName, HsName, SN)+import SourceNames +import ScopeModule+import UniqueNames hiding (srcLoc)+import HsName+import HsLexerPass1+import PNT +import TiPNT+import SimpleGraphs(reverseGraph,reachable)+import HsTokens+import PrettyPrint+import RefacTypeSyn+import RefacLocUtils+import Data.Char+import GHC.Unicode+import AbstractIO+import Maybe+import List+import Data.Function+import RefacUtils+import LocalSettings++-- this module is used to identify the clone class we are interested in.+-- we use the highlighted expression passed in, and write the clone class+-- to a separate file for use with parseAnswers.++refacIdentify args+  = do+       AbstractIO.putStrLn "refacIdentify"+       let fileName = ghead "fileName'" args +           beginRow         = read (args!!1)::Int+           beginCol         = read (args!!2)::Int+           endRow           = read (args!!3)::Int+           endCol           = read (args!!4)::Int+        +       AbstractIO.writeFile answerFilePath ""     +       -- collect the answers...+       (inscps, exps, mod, tokList)<-parseSourceFileOld fileName+       let subExp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod+       expression <- AbstractIO.readFile transFilePath+       let expressions = (read expression)::([ [(HsExpP, String, String)] ])+           clonedExps = concat (filter (subExp `myElem`) expressions)    +       +       -- write the clone class to two files for analysis.+       AbstractIO.writeFile classAnswerPath $ show clonedExps+       AbstractIO.writeFile classTransformPath $ show clonedExps+       +       +       AbstractIO.putStrLn "Clone class identified."       ++myElem :: HsExpP -> [(HsExpP, String, String)] -> Bool+myElem _ [] = False+myElem e ((x,y,z):xs) + -- | toRelativeLocs e == toRelativeLocs x    = True+ | findEntityWithLocation e x = True+ | otherwise = myElem e xs++    
+ refactorer/RefacInstantiate.hs view
@@ -0,0 +1,126 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacInstantiate+-- Copyright   :  (c) Christopher Brown 2007+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Instantiating Patterns+++module RefacInstantiate where+++import System.IO.Unsafe+import PrettyPrint+import RefacTypeSyn+import RefacLocUtils+-- import GHC (Session)+import Data.Char+import GHC.Unicode+import AbstractIO+import Maybe+import List+import RefacUtils+import RefacRedunDec+import SlicingUtils+import Directory+import LocalSettings++refacInstantiate args+  = do +       let fileName     = args!!0+           begin        = read (args!!1)::Int+           end          = read (args!!2)::Int+           instantPatt  = drop 3 args+       AbstractIO.putStrLn "refacInstantiate"+       (inscps, exps, mod, tokList) <- parseSourceFile fileName+       case findMatch fileName begin end mod of+         Nothing -> do error "You can only instantiate patterns on the LHS of a match!"+         Just (decl, pats) ->+           do              +              let pairedPats = pairPatWithInstance pats instantPatt              +              res <- findAndReplaceAllPat decl pairedPats+              case checkCursor fileName begin end mod of+               Left errMsg -> do error errMsg+               Right fun ->+                 do+                  let newFun = addMatch fun res+                  ((_,m), (newToks, newMod)) <- applyRefac (addNewPat fun newFun) (Just (inscps, exps, mod, tokList)) fileName+                  writeRefactoredFiles False [((fileName, m), (newToks, newMod))]           +                  AbstractIO.putStrLn "Completed.\n"+                  +addMatch :: HsDeclP -> HsMatchP -> HsDeclP+addMatch (Dec (HsFunBind x ms) ) m = (Dec (HsFunBind x (m : ms)))+addMatch x _ = error "You can only instantiate patterns on the LHS of a match!"++addNewPat fun newFun (_, _, mod) + = do+     newMod <- update fun newFun mod+     return newMod             ++pairPatWithInstance :: [HsPatP] -> [ String ] -> [ (HsPatP, String) ]+pairPatWithInstance [] _ = []+pairPatWithInstance _ [] = []+pairPatWithInstance ((Pat (HsPLit _ x)):_) (s:ss)+  | convert x /= s && s /= "_" = error "Can only instantiate an identifier!"+pairPatWithInstance (p:ps) (s:ss) = (p, s) : pairPatWithInstance ps ss++convert ::HsLiteral -> String+convert (HsInt x) = show x+convert (HsChar x) = show x+convert (HsString x) = x+convert (HsFrac x) = show x+convert (HsCharPrim x) = show x+convert (HsStringPrim x) = show x+convert (HsIntPrim x) = show x+convert (HsFloatPrim x) = show x+convert (HsDoublePrim x) = show x+convertt (HsLitLit x ) = x++findAndReplaceAllPat :: (Term t, Monad m) => t -> [ (HsPatP, String) ] -> m t+findAndReplaceAllPat t [] = return t+findAndReplaceAllPat t (x:xs)+ = do+      res <- findAndReplacePat t x+      rest <- findAndReplaceAllPat res xs+      return rest++findAndReplacePat :: (Term t, Monad m) => t -> (HsPatP, String) -> m t+findAndReplacePat t (p,s) +  = applyTP (full_tdTP (idTP `adhocTP` inRhs)) t+  where+   inRhs (pnt::PNT) +    | (patToPNT p) == pnt +       = do return (nameToPNT s)+   inRhs x = return x+findMatch :: Term t => String -> Int -> Int -> t -> Maybe (HsMatchP, [HsPatP])+findMatch fileName row col mod+  = applyTU (once_tdTU (failTU `adhocTU` inMatch)) mod+    where+      --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats (rhs@(HsBody e)) ds)::HsMatchP)+        | useLoc (locToPNT fileName (row, col) mod) == useLoc pnt+          = Just (match, pats)+      inMatch _ = Nothing++checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToPName of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the definition!")+     Just decl -> Right decl+    where+        locToPName +         = case res of +             Nothing -> find (definesPNT (locToPNT fileName (row, col) mod)) (hsDecls mod)+             _ -> res+        res =  find (defines (locToPN fileName (row, col) mod)) (concat (map hsDecls (hsModDecls mod)))+        +        definesPNT pnt d@(Dec (HsPatBind loc p e ds))+         = findPNT pnt d+        definesPNT pnt d@(Dec (HsFunBind loc ms)) +         = findPNT pnt d+        definesPNT _ _ = False
+ refactorer/RefacIntroPattern.hs view
@@ -0,0 +1,984 @@+module RefacIntroPattern(introPattern, introCase, foldPattern) where++import TypeCheck+import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils hiding (getParams)+import PFE0 (findFile, allFiles, allModules)+import MUtils (( # ))+import RefacLocUtils+import System+import IO+import Relations+import Ents+import Data.Set (toList)+import Data.List+++-- | An argument list for a function which of course is a list of paterns.+type FunctionPats = [HsPatP]++-- | A list of declarations used to represent a where or let clause.+type WhereDecls = [HsDeclP]+++data PatFun = Mat | Patt | Er deriving (Eq, Show)++{- This module contains 3 refactorings for HaRe:+      introPattern : introduce a exhaustive pattern match for a +                     selected pattern variable.+                     +      introCase    : introduce a case analysis over a selected+                     pattern variable. Introduces an exhaustive +                     set of patterns for the type.+                     +      foldPattern  : allows one to fold a sub expression against a +                     particular pattern variable+-}++++{- Introduces pattern matching over a pattern variable. +   Introduces an exhaustive set of patterns for a type +   in a case analysis on the lhs of an equation.+   +   Copyright   :  (c) Christopher Brown 2008++   Maintainer  :  cmb21@kent.ac.uk+   Stability   :  provisional+   Portability :  portable   +   +-}++introPattern args+ = do let fileName = ghead "filename" args +          --fileName'= moduleName fileName+          --modName  = Module fileName'  +          row      = read (args!!1)::Int+          col      = read (args!!2)::Int+      modName <-fileNameToModName fileName+      let modName1 = convertModName modName+      (inscps, exps, mod, tokList)<-parseSourceFile fileName+      -- (inscps3, exps3, mod3, tokList3)<-parsePrelude +      let pnt = locToPNT fileName (row, col) mod+      if not (checkInPat pnt mod)+        then do +                -- it's quite possible we are dealing with a sub-pattern+                -- let's check that case.+                if not (checkInSubPat pnt mod) +                   then error "Please select a pattern variable on the LHS of an equation!"+                   else do+                           AbstractIO.putStrLn "introSubPattern"+                           ((_,m), (newToks, newMod))<-applyRefac (doIntroPatterns' fileName inscps pnt (modNameToStr modName)) +                                                       (Just (inscps, exps, mod, tokList)) fileName+                           writeRefactoredFiles False [((fileName,m), (newToks,newMod))]+                           AbstractIO.putStrLn "Completed.\n"+        else do +                AbstractIO.putStrLn "introPattern"+                ((_,m), (newToks, newMod))<-applyRefac (doIntroPatterns pnt) +                                                       (Just (inscps, exps, mod, tokList)) fileName+                writeRefactoredFiles False [((fileName,m), (newToks,newMod))]+                AbstractIO.putStrLn "Completed.\n"++convertModName (PlainModule s) = s+convertModName m@(MainModule f) = modNameToStr m +++doIntroPatterns pnt (_,_,t)+ = do mod <- introPats pnt t+      return mod+      +doIntroPatterns' fileName inscps pnt modName (_,_,t)+ = do mod <- introPats' fileName inscps pnt modName t+      return mod+   +introPats pnt t+  = applyTP (full_tdTP (idTP `adhocTP` inDec)) t+     where+       inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)+         | findPNT pnt matches && inMatch pnt matches+             = do+                  -- we need to find the type of the variable in question,+                  -- and also the implementation of the type. If the type+                  -- is defined outside of the project, we must error!+                  let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches+                      typeSig = getTypeSig (pNTtoPN name) t+                      (typeOfPat, position) = findPatAndType 0 pnt (flatternType typeSig) pats+                      constrsOfData = findTypeAndConstrs 0 pnt (flatternType typeSig) pats     +                  -- check that argument position is a variable in all defining+                  -- equations...     +                  if checkVariableEquation matches position+                     then do+                           let newMatches = concatMap (createMatches dec (declToName dec) name pats  (position+1) constrsOfData) matches+                           update dec (Dec (HsFunBind s (newMatches++matches))) dec+                     else do+                           return dec +       inDec x = return x                +       +       typToPNT (Typ (HsTyCon x)) = x      +       typToPNT x = error "Please select a variable with a type constructor!"+       +       checkVariableEquation [] _ = True+       checkVariableEquation ((HsMatch _ _ pats _ _):ms) position+        | checkPats (pats !! position) = checkVariableEquation ms position+        | otherwise = error "Pattern argument must be a variable in all defining equations!"+       +       checkPats (Pat (HsPIrrPat p)) = checkPats p+       checkPats (Pat (HsPParen p))  = checkPats p+       checkPats (Pat (HsPId (HsVar x))) = True+       checkPats _ = False+       +       createMatches (Dec (HsFunBind loc environment)) funName name pats position constrs match +         = let (before, after)  = break (==match) environment+               newMatches = createMatches2 position (length pats) match constrs+           in newMatches+            where  +             createMatches2 _ _ _ [] = [] +             createMatches2 position arity m@(HsMatch _ _ pats rhs ds)  ((ConInfo (PN n _) a _):cs)+              = let newPats = replace position pats (createPat pnt n a (pats !! (position-1)) (map pNtoName (hsPNs pats ++ hsPNs ds)))+                   in (HsMatch loc0 name newPats rhs ds) : createMatches2 position arity m cs+                 where+                   myReplicate 0 _ _  = []+                   myReplicate arity names index +                      = let newName = mkNewName "a" names index+                        in (nameToPat newName) : (myReplicate (arity-1) (names ++ [newName]) (index+1))      ++-- ==========================================================================+-- end of introPattern +-- ==========================================================================++-- ==========================================================================+-- introduce sub pattern+-- ==========================================================================+introPats' fileName inscps pnt modName t+  = applyTP (full_tdTP (idTP `adhocTP` inDec)) t+     where+       inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)+         | findPNT pnt matches && inMatch pnt matches+             = do+                  -- we need to find the type of the variable in question,+                  -- and also the implementation of the type. If the type+                  -- is defined outside of the project, we must error!+                  let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches+                      typeSig = getTypeSig (pNTtoPN name) t+                      (typeOfPat, position) = findPatAndType 0 pnt (flatternType typeSig) pats+                      +                  -- we need to check to make sure there are no polymorphic. If they are we+                  -- can simply replace them with the () type. This seems to be the Haskell+                  -- equivalent of Null.+                  newTypeSig <- replacePolymorphicType typeSig+                      +                  let closureEquation = createClosure ((render.ppi) newTypeSig) (pNTtoName pnt) (pats !! position) position++                  -- res <- liftIO $ ghcTypeCheckPattern closureEquation "closure___" ses+                  typeOfPat2 <- getSigAsString fileName closureEquation (force $ ghcTypeCheckPattern closureEquation "closure___" modName fileName)+                  +                  -- this is necessary to force the evaluation of the GHC compiler,+                  -- since it's wrapped up in a naughty unsafePerformIO...+                  lift $ AbstractIO.putStrLn $ (typeOfPat2 \\ typeOfPat2)+                  +                  let typeOfPat2' = last $ typeAnnot' typeOfPat2+                  +                  let typeOfPat2Cleaned = cleanPatType typeOfPat2'+                      constrsOfData = extractConstructors typeOfPat2Cleaned (toList inscps)+                                    +                  let newMatches = createMatches dec (declToName dec) name pats position constrsOfData match+                      (beforeM, afterM) = break (==match) matches+                  update dec (Dec (HsFunBind s (beforeM ++ newMatches ++ afterM))) dec+++       inDec x = return x                +       +       replacePolymorphicType typeSig+         = applyTP (full_tdTP (idTP `adhocTP` rename)) typeSig+            where+             rename (Typ (HsTyVar n)) = return (Typ (HsTyVar (nameToPNT "Int"))) +             rename x = return x +       +       +       force a = if a==a then a else a+       +       extractConstructors typeName [] = []+       extractConstructors typeName ((_,Ent _ (HsCon (SN n _)) (Type (TypeInfo _ cs _))):xs)+           | n == typeName && cs == [] = error $ "Cannot instantiate new patterns for the selected pattern. It may be of a polymorphic type, or a Haskell defined type such as Int."+           | n == typeName = cs+           | otherwise     = extractConstructors typeName xs+       extractConstructors typeName (x:xs) = extractConstructors typeName xs+       +       cleanPatType [] = []+       cleanPatType (' ':xs) = cleanPatType xs+       cleanPatType ('[':xs) = "[]"+       cleanPatType ('(':xs) +         = "(" ++ ( filter (==',') xs) ++ ")"+       cleanPatType xs = let (x, s') = break (== ' ') xs+                          in x+       +       getSigAsString ses closureEquation res+         = do+            let types = lines2 res            +            let types1 = cleanTypes (tail types)+            let (context, l) = getContext (head types)+            let types2 = l : types1+            let types3 = map (filter (/= '\n')) types2+            let types4 = fold (tail types3)+      +            return (context ++ " => " ++ (head types3) ++ " -> " ++ types4) +             where +              fold [] = []+              fold [x] = x+              fold  (x:xs) = x ++ (" -> " ++ fold xs) +       +       createClosure :: String -> String -> HsPatP -> Int -> String+       createClosure typeSig p pat pos+         =   "(\\(" ++ ((render.ppi) pat) ++ "::" ++ ((typeAnnot typeSig)!!pos) ++ ") -> " ++ p ++")"+        -- =  "closure___ " ++ "(" ++ ((render.ppi) pat) ++ "::" ++ ((typeAnnot typeSig)!!pos) ++ ") = " ++ p+              where+       typeAnnot :: String -> [String]+       typeAnnot "" = []+       typeAnnot s = let (_, s') = break (== ':') s+                       in case s' of+                             { [] -> [];+                               (_:s'') -> typeAnnot' (tail s'') }+       typeAnnot' :: String -> [String]+       typeAnnot' "" =  []+       typeAnnot' s =  let (l, s') = break (== '-') s+                         in  l : case s' of+                                    {[] -> [];+                                     (_:s'') -> typeAnnot' (tail s'')}+         +       ++       +       +       getModuleName [] modName = ""+       getModuleName (t:ts) modName+         | stripFilePath t == modName = t+         | otherwise                  = getModuleName ts modName+           where+             stripFilePath t +               = let (f,_) = break (=='/') (reverse t);+                     (f',_) = break ( =='.') (reverse f) in f'+       +       createMatches (Dec (HsFunBind loc environment)) funName name pats position constrs match +         = let (before, after)  = break (==match) environment+               newMatches = createMatches2 position (length pats) match constrs+           in newMatches+            where  +             createMatches2 _ _ _ [] = [] +             createMatches2 position arity m@(HsMatch _ _ pats rhs ds)  ((ConInfo (SN n _) a _):cs)+              = -- only update the pattern we are interested in...+                let newPats = replace (position+1) pats (createSubPat pnt n a (pats !! position) (map pNtoName (hsPNs pats ++ hsPNs ds)))+                     in (HsMatch loc0 name newPats rhs ds) : createMatches2 position arity m cs+              +              +               -- let newPats = replace position pats (createPat pnt n a (pats !! position) (map pNtoName (hsPNs pats ++ hsPNs ds)))+               --    in (HsMatch loc0 name newPats rhs ds) : createMatches2 position arity m cs+                 where+                   myReplicate 0 _ _  = []+                   myReplicate arity names index +                      = let newName = mkNewName "a" names index+                        in (nameToPat newName) : (myReplicate (arity-1) (names ++ [newName]) (index+1))+       +       createSubPat :: PNT -> String -> Int -> HsPatP -> [String] -> HsPatP+       createSubPat pnt x i (Pat (HsPParen p)) environ = (Pat (HsPParen (createSubPat pnt x i p environ)))+       createSubPat pnt x i (Pat (HsPApp n p)) environ+            = let myTail [] = []+                  myTail [x] = []+                  myTail (x:xs) = xs+                  (before, a) = break (findPNT pnt) p+              in case a of+                  [] -> createSubPat'' pnt x i environ +                  after -> (Pat (HsPApp n (before ++ [createSubPat pnt x i (ghead "createSubPat" after) environ] ++ (myTail after))))+       createSubPat pnt x i (Pat (HsPTuple s p)) environ+         = let myTail [] = []+               myTail [x] = []+               myTail (x:xs) = xs+               (before, a) = break (findPNT pnt) p+           in case a of+                [] -> createSubPat'' pnt x i environ -- create the sub pattern and get out of here!+                after -> (Pat (HsPTuple s (before ++ [createSubPat pnt x i (ghead "createSubPat" after) environ] ++ (myTail after))))+             +       createSubPat pnt x i (Pat (HsPIrrPat p)) environ+           = (Pat (HsPIrrPat (createSubPat pnt x i p environ)))+        +       createSubPat pnt x i (Pat (HsPInfixApp p1 i2 p2)) environ+         | findPNT pnt p1 = (Pat (HsPInfixApp (createSubPat pnt x i p1 environ) i2 p2))+         | findPNT pnt p2 = (Pat (HsPInfixApp p1 i2 (createSubPat pnt x i p2 environ)))+       +       createSubPat pnt x i (Pat (HsPAsPat n p)) environ+         = (Pat (HsPAsPat n (createSubPat pnt x i p environ)))  +           +       createSubPat pnt x i _ environ = createSubPat' pnt x i environ++       createSubPat' pnt i 0 environ = Pat (HsPAsPat pnt (Pat (HsPId (HsCon (nameToPNT i)))))+       createSubPat' pnt x@(':':xs) ts environ+          = Pat (HsPAsPat pnt (Pat (HsPInfixApp (ghead "createPat" pat1) (nameToPNT x) +                                                                 (last pat1))))+          where +           pat1 = reverse $ createId environ ts +       createSubPat' pnt x@('(':xs) ts environ+         = Pat (HsPAsPat pnt (Pat ( HsPTuple loc0 (reverse (createId environ ts)))))                    +       createSubPat' pnt i ts environ = Pat (HsPAsPat pnt (Pat (HsPApp (nameToPNT i) (reverse (createId environ ts)))))+       +       createSubPat'' pnt i 0 environ = (Pat (HsPId (HsCon (nameToPNT i))))+       createSubPat'' pnt x@(':':xs) ts environ+          = (Pat (HsPInfixApp (ghead "createPat" pat1) (nameToPNT x) +                                                                 (last pat1)))+          where +           pat1 = reverse $ createId environ ts +       createSubPat'' pnt x@('(':xs) ts environ+         = (Pat ( HsPTuple loc0 (reverse (createId environ ts))))                      +       createSubPat'' pnt i ts environ = (Pat (HsPApp (nameToPNT i) (reverse (createId environ ts))))+       +       +       findType index _ _ [] = error "No type associated with pattern variable!"+       findType index pnt types (p:ps) +         | findPNT pnt p = extractTypeName (types !! index)+         | otherwise     = findType (index+1) pnt types ps ++       extractTypeName (Typ (HsTyCon (PNT pn (Type (TypeInfo _ cs _)) _ ))) = pn+       extractTypeName (Typ (HsTyVar (PNT pn _ _))) = pn+       extractTypeName x = error "Please select a variable with a type constructor!"  +       +       extractTypeImplem [] typeName = error (typeName ++ " cannot be found in this project!")+       extractTypeImplem (d:ds) typeName+         | declToName d == typeName = d+         | otherwise                = extractTypeImplem ds typeName+       +       +       constrsToModule (PNT (PN _ (G (PlainModule m) _ _)) _ _) = m+       constrsToModule (PNT p@(PN _ (G (MainModule m) _ _)) _ _) = "Main"+       constrsToModule x = error "Error in constrsToModule!"+              +       +       findPatAndType index _ _ [] = error "No type associated with pattern variable!"+       findPatAndType index pnt types (p:ps)+          | findPNT' pnt [p] = (typToPNT (types !! index), index)+          | otherwise     = findPatAndType (index+1) pnt types ps+       +       findConstrAndType pnt pat typeOfPat+          = (positionOfPat, typ) +             where+               positionOfPat = flatternPat pnt pat+               typ     = extractType positionOfPat constr typeOfPat+               constr = findConstr pnt pat+       +       extractType pos constr d@(Dec (HsDataDecl _ _ _ cs _))+          = extractCons cs+             where+                extractCons [] = error "This is not a valid parameter of the binding constructor!"+                extractCons ((HsConDecl _ _ _ n types) : more)+                  | ghead "extractCons" (pNTtoName constr) == '(' &&+                    pNTtoName n == pNTtoName constr = removeBang (types !! pos)+                  | n == constr = removeBang (types !! pos)+                  | otherwise = extractCons more+                    where+                      removeBang (HsBangedType t) = t+                      removeBang (HsUnBangedType t) = t+       +       findPosition index pnt [] = 0+       findPosition index pnt (p:ps)+        | findPNT pnt p = index+        | otherwise     = findPosition (index+1) pnt ps+        +          +       flatternPat pnt (Pat (HsPAsPat i p)) = flatternPat pnt p+       flatternPat pnt (Pat (HsPApp i p)) +        | findPNT pnt p = findPosition 0 pnt p+       flatternPat pnt (Pat (HsPTuple _ p))+        | findPNT pnt p = findPosition 0 pnt p+       flatternPat pnt (Pat (HsPInfixApp p1 i p2)) = findPosition 0 pnt [p1] + findPosition 1 pnt [p2]+       flatternPat pnt (Pat (HsPParen p)) = flatternPat pnt p+       -- flatternPat pnt (Pat (HsPId i)) = 1+       flatternPat pnt p = error "Selected pattern is not a sub-pattern in flatternPat"   +          +       findConstr pnt (Pat (HsPAsPat i p))+         = findConstr pnt p+       findConstr pnt (Pat (HsPApp i p))+         | findPNT' pnt p = i+       findConstr pnt (Pat (HsPTuple _ p))+         | findPNT' pnt p = nameToPNT "(,)"  -- this needs checking for arbitrary sized tuples+       findConstr pnt (Pat (HsPInfixApp p1 i p2))+         | findPNT pnt p1 || findPNT pnt p2 = i+       findConstr pnt (p@(Pat (HsPParen p1)))+          = findConstr pnt p1+       findConstr pnt (p@(Pat (HsPId (HsCon i)))) +         | findPNT pnt p = i+       findConstr pnt p = error "pattern is not bound to a constructor entity!" +       +       findPNT' pnt []     = False+       findPNT' pnt ((Pat (HsPAsPat i p)):ps)+         | findPNT pnt i    = True+         | findPNT' pnt [p] = True+         | otherwise        = findPNT' pnt ps+       findPNT' pnt ((Pat (HsPApp i ps)):pss)+         | findPNT' pnt ps = True+         | otherwise     = findPNT' pnt ps+       findPNT' pnt ((Pat (HsPTuple i ps)):pss)+         | findPNT' pnt ps = True+         | otherwise     = findPNT' pnt ps        +       findPNT' pnt (Pat (HsPInfixApp p1 i p2):ps)+         | findPNT pnt p1 || findPNT pnt p2 = True+         | otherwise  = findPNT' pnt ps+       findPNT' pnt (p@(Pat (HsPParen p1)):ps)+         | findPNT' pnt [p1] = True+         | otherwise     = findPNT' pnt ps+       findPNT' pnt (p@(Pat (HsPId x)):ps) +         | findPNT pnt p = True+         | otherwise     = findPNT' pnt ps+       findPNT' pnt (p:ps) = findPNT' pnt ps+       +       +       typToPNT (Typ (HsTyCon x)) = x      +       typToPNT x = error "Please select a variable with a type constructor!"+       +       checkVariableEquation [] _ = True+       checkVariableEquation ((HsMatch _ _ pats _ _):ms) position+        | checkPats (pats !! position) = checkVariableEquation ms position+        | otherwise = error "Pattern argument must be a variable in all defining equations!"+       +       checkPats (Pat (HsPIrrPat p)) = checkPats p+       checkPats (Pat (HsPParen p))  = checkPats p+       checkPats (Pat (HsPId (HsVar x))) = True+       checkPats _ = False++-- ==========================================================================+-- end of introSubPattern +-- ==========================================================================++introCase args+ = do let fileName = ghead "filename" args +          --fileName'= moduleName fileName+          --modName  = Module fileName'  +          row      = read (args!!1)::Int+          col      = read (args!!2)::Int+      modName <-fileNameToModName fileName+      let modName1 = convertModName modName+      (inscps, exps, mod, tokList)<-parseSourceFile fileName+      let pnt = locToPNT fileName (row, col) mod+      if not (checkInPat pnt mod)+        then do+                if not (checkInSubPat pnt mod) +                   then error "Please select a pattern variable on the LHS of an equation!"+                   else do+                           AbstractIO.putStrLn "introCaseSubPattern"+                           ((_,m), (newToks, newMod))<-applyRefac (doIntroCasePatterns' fileName inscps pnt (modNameToStr modName)) +                                                       (Just (inscps, exps, mod, tokList)) fileName+                           writeRefactoredFiles False [((fileName,m), (newToks,newMod))]+                           AbstractIO.putStrLn "Completed.\n"+        else do +                AbstractIO.putStrLn "introCasePattern"+                ((_,m), (newToks, newMod))<-applyRefac (doIntroCasePatterns pnt) +                                                       (Just (inscps, exps, mod, tokList)) fileName+                writeRefactoredFiles False [((fileName,m), (newToks,newMod))]+                AbstractIO.putStrLn "Completed.\n"++ +doIntroCasePatterns pnt (_,_,t)+ = do mod <- introPatsCase pnt t+      return mod+      +doIntroCasePatterns' fileName inscps pnt modName (_,_,t)+ = do mod <- introPatsCase' fileName inscps pnt modName t+      return mod++introPatsCase' fileName inscps pnt modName t+  = applyTP (full_tdTP (idTP `adhocTP` inDec)) t+     where+       inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)+         | findPNT pnt matches && inMatch pnt matches+             = do+                  -- we need to find the type of the variable in question,+                  -- and also the implementation of the type. If the type+                  -- is defined outside of the project, we must error!+                  let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches+                      typeSig = getTypeSig (pNTtoPN name) t+                      (typeOfPat, position) = findPatAndType 0 pnt (flatternType typeSig) pats+                      +                  -- we need to check to make sure there are no polymorphic. If they are we+                  -- can simply replace them with the () type. This seems to be the Haskell+                  -- equivalent of Null.+                  newTypeSig <- replacePolymorphicType typeSig    +                      +                  let closureEquation = createClosure ((render.ppi) newTypeSig) (pNTtoName pnt) (pats !! position) position++                  -- res <- liftIO $ ghcTypeCheckPattern closureEquation "closure___" ses+                  typeOfPat2 <- getSigAsString fileName closureEquation (force $ ghcTypeCheckPattern closureEquation "closure___" modName fileName)+                  +                  -- this is necessary to force the evaluation of the GHC compiler,+                  -- since it's wrapped up in a naughty unsafePerformIO...+                  lift $ AbstractIO.putStrLn $ (typeOfPat2 \\ typeOfPat2)+                  +                  let typeOfPat2' = last $ typeAnnot' typeOfPat2+                  +                  let typeOfPat2Cleaned = cleanPatType typeOfPat2'+                      constrsOfData = extractConstructors typeOfPat2Cleaned (toList inscps)+                  +                  let newMatches = createMatches dec (declToName dec) pnt name pats position constrsOfData match+                      (beforeM, afterM) = break (==match) matches+                  update dec (Dec (HsFunBind s (beforeM ++ newMatches ++ afterM))) dec+       inDec x = return x           +        +        +       createMatches (Dec (HsFunBind loc environment)) funName pnt name pats position constrs match +         = let (before, after)  = break (==match) environment+               newMatches = createMatches2 position (length pats) match constrs+           in newMatches+            where  +             createMatches2 _ _ _ [] = []+             createMatches2 position arity m@(HsMatch _ _ pats rhs ds) constrs@(c:cs)+              = [HsMatch loc0 name pats newCase ds]+                 where+                   newPats [] = []+                   newPats ((ConInfo (SN n _) a _):cs) = createPat pnt n a (pats !! position)+                                                                           (map pNtoName (hsPNs pats ++ hsPNs ds))+                                                            : newPats cs+                   newCase = HsBody (Exp (HsCase (nameToExp (pNTtoName pnt)) (newAlts (newPats constrs))))+                   newAlts [] = []+                   newAlts (p:ps) = (HsAlt loc0 p rhs []) : newAlts ps+                 +                   myReplicate 0 _ _  = []+                   myReplicate arity names index +                      = let newName = mkNewName "a" names index+                        in (nameToPat newName) : (myReplicate (arity-1) (names ++ [newName]) (index+1)) +           +       replacePolymorphicType typeSig+         = applyTP (full_tdTP (idTP `adhocTP` rename)) typeSig+            where+             rename (Typ (HsTyVar n)) = return (Typ (HsTyVar (nameToPNT "Int"))) +             rename x = return x +       +       +       force a = if a==a then a else a+       +       extractConstructors typeName [] = []+       extractConstructors typeName ((_,Ent _ (HsCon (SN n _)) (Type (TypeInfo _ cs _))):xs)+           | n == typeName && cs == [] = error $ "Cannot instantiate new patterns for the selected pattern. It may be of a polymorphic type, or a Haskell defined type such as Int."+           | n == typeName = cs+           | otherwise     = extractConstructors typeName xs+       extractConstructors typeName (x:xs) = extractConstructors typeName xs+       +       cleanPatType [] = []+       cleanPatType (' ':xs) = cleanPatType xs+       cleanPatType ('[':xs) = "[]"+       cleanPatType ('(':xs) +         = "(" ++ ( filter (==',') xs) ++ ")"+       cleanPatType xs = let (x, s') = break (== ' ') xs+                          in x+       +       getSigAsString ses closureEquation res+         = do+            let types = lines2 res            +            let types1 = cleanTypes (tail types)+            let (context, l) = getContext (head types)+            let types2 = l : types1+            let types3 = map (filter (/= '\n')) types2+            let types4 = fold (tail types3)+      +            return (context ++ " => " ++ (head types3) ++ " -> " ++ types4) +             where +              fold [] = []+              fold [x] = x+              fold  (x:xs) = x ++ (" -> " ++ fold xs)    +       +       createClosure :: String -> String -> HsPatP -> Int -> String+       createClosure typeSig p pat pos+         =   "(\\(" ++ ((render.ppi) pat) ++ "::" ++ ((typeAnnot typeSig)!!pos) ++ ") -> " ++ p ++")"+        -- =  "closure___ " ++ "(" ++ ((render.ppi) pat) ++ "::" ++ ((typeAnnot typeSig)!!pos) ++ ") = " ++ p+              where        +       typeAnnot :: String -> [String]+       typeAnnot "" = []+       typeAnnot s = let (_, s') = break (== ':') s+                       in case s' of+                             { [] -> [];+                               (_:s'') -> typeAnnot' (tail s'') }+       typeAnnot' :: String -> [String]+       typeAnnot' "" =  []+       typeAnnot' s =  let (l, s') = break (== '-') s+                         in  l : case s' of+                                    {[] -> [];+                                     (_:s'') -> typeAnnot' (tail s'')} +                  +introPatsCase pnt t+  = applyTP (full_tdTP (idTP `adhocTP` inDec)) t+     where+       inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)+         | findPNT pnt matches && inMatch pnt matches+             = do+                  -- we need to find the type of the variable in question,+                  -- and also the implementation of the type. If the type+                  -- is defined outside of the project, we must error!+                  let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches+                      typeSig = getTypeSig (pNTtoPN name) t+                      (typeOfPat, position) = findPatAndType 0 pnt (flatternType typeSig) pats+                      constrsOfData = findTypeAndConstrs 0 pnt (flatternType typeSig) pats     +                  -- check that argument position is a variable in all defining+                  -- equations...     +                  if checkVariableEquation matches position+                     then do+                           let newMatches = concatMap (createMatches dec (declToName dec) name pats  (position+1) constrsOfData) matches+                           update dec (Dec (HsFunBind s (newMatches++matches))) dec+                     else do+                           return dec +       inDec x = return x        +      +       typToPNT (Typ (HsTyCon x)) = x      +       typToPNT x = error "Please select a variable with a type constructor1!"+      +       checkVariableEquation [] _ = True+       checkVariableEquation ((HsMatch _ _ pats _ _):ms) position+        | checkPats (pats !! position) = checkVariableEquation ms position+        | otherwise = error "Pattern argument must be a variable in all defining equations!"+       +       checkPats (Pat (HsPIrrPat p)) = checkPats p+       checkPats (Pat (HsPParen p))  = checkPats p+       checkPats (Pat (HsPId (HsVar x))) = True+       checkPats _ = False+       +       createMatches (Dec (HsFunBind loc environment)) funName name pats position constrs match +         = let (before, after)  = break (==match) environment+               newMatches = createMatches2 position (length pats) match constrs+           in newMatches+            where  +             createMatches2 _ _ _ [] = []+             createMatches2 position arity m@(HsMatch _ _ pats rhs ds) constrs@(c:cs)+              = [HsMatch loc0 name pats newCase ds]+                 where+                   newPats [] = []+                   newPats ((ConInfo (PN n _) a _):cs) = createPat pnt n a (pats !! (position-1)) +                                                                           (map pNtoName (hsPNs pats ++ hsPNs ds))+                                                            : newPats cs+                   newCase = HsBody (Exp (HsCase (nameToExp (pNtoName (patToPN (pats !! (position-1))))) (newAlts (newPats constrs) )))+                   newAlts [] = []+                   newAlts (p:ps) = (HsAlt loc0 p rhs []) : newAlts ps+                 +                   myReplicate 0 _ _  = []+                   myReplicate arity names index +                      = let newName = mkNewName "a" names index+                        in (nameToPat newName) : (myReplicate (arity-1) (names ++ [newName]) (index+1))+-- ==========================================================================+-- end of introCase+-- ==========================================================================            +            +foldPattern args+ = do let fileName = ghead "filename" args +          --fileName'= moduleName fileName+          --modName  = Module fileName' +          patName  = (args!!1)+          beginRow = read (args!!2)::Int+          beginCol = read (args!!3)::Int +          endRow   = read (args!!4)::Int+          endCol   = read (args!!5)::Int+      modName <-fileNameToModName fileName+      (inscps, exps, mod, tokList)<-parseSourceFile fileName +      +      let (ty, pnt, pats, subExp, wh)+             = findDefNameAndExp tokList+                                 (beginRow, beginCol)+                                 (endRow, endCol)+                                 mod+      let exp = locToExp (beginRow, beginCol)+                         (endRow, endCol)+                         tokList+                         mod+                         +      ((_,m), (newToks, newMod))<-applyRefac (doFoldPattern patName pnt exp) +                                             (Just (inscps, exps, mod, tokList)) fileName+      writeRefactoredFiles False [((fileName,m), (newToks,newMod))]+      AbstractIO.putStrLn "Completed.\n"                   ++doFoldPattern patName pnt exp (_,_,t)+ = do+      mod <- foldPatterns patName pnt exp t+      return mod++foldPatterns patName pnt exp t+   = applyTP (stop_tdTP (failTP `adhocTP` inMod+                              `adhocTP` inMatch)) t+       where+        inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)+         | pnt `elem` (map declToPNT ds) +             = do+                  ds' <- doFoldModule ds+                  return (HsModule loc name exps imps ds')+            where+             doFoldModule t+              = applyTP (stop_tdTP (failTP `adhocTP` inMatch2)) t+               where+               inMatch2 (match@(HsMatch loc name pats rhs ds)::HsMatchP)+                | useLoc pnt == useLoc name+                    = do+                         -- let's check that the pattern name+                         -- occurs as a variable pattern in pats+                         if checkPattern patName pats == False+                           then error "The pattern entered does not occur with the pattern list or is not a pattern variable!"+                           else do +                                  -- let's replace the highlighted expression with the pattern name+                                  newExp <- replaceExp rhs patName exp+                                  return (HsMatch loc name pats newExp ds)+               inMatch2 x = mzero  ++        inMod x = mzero    +        +        inMatch (match@(HsMatch loc name pats rhs ds)::HsMatchP)+         | useLoc pnt == useLoc name+            =do+               -- let's check that the pattern name+               -- occurs as a variable pattern in pats+               if checkPattern patName pats == False+                 then error "The pattern entered does not occur with the pattern list or is not a pattern variable!"+                 else do +                        -- let's replace the highlighted expression with the pattern name+                        newExp <- replaceExp rhs patName exp+                        return (HsMatch loc name pats newExp ds)+      +        inMatch x = mzero++replaceExp t patName e+    = applyTP (stop_tdTP (failTP `adhocTP` subExp)) t+       where +         subExp exp@((Exp _)::HsExpP)+          | sameOccurrence exp e == True+               = update exp (nameToExp patName) exp+          | otherwise = mzero+++checkPattern :: String -> [HsPatP] -> Bool+checkPattern patName+ = (fromMaybe False).applyTU (once_tdTU (failTU `adhocTU` inVar))+     where+       inVar (Pat (HsPId (HsVar n)))+         | pNTtoName n  == patName = Just True+       inVar (Pat (HsPAsPat n p))+         | pNTtoName n == patName = Just True+       inVar x = Nothing++                +-- ==========================================================================+-- end of foldPattern+-- ==========================================================================+             +-- utility functions    ++{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (PatFun, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+                     +findDefNameAndExp toks beginPos endPos t+  = fromMaybe (Er, defaultPNT, [], defaultExp, [])+              (applyTU (once_buTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t)++    where+      --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats rhs@(HsBody e) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (Mat, pnt, pats, locToExp beginPos endPos toks rhs, ds)+      inMatch (match@(HsMatch loc1  pnt pats rhs@(HsGuard e) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (Mat, pnt, pats, rmGuard rhs, ds)          +      inMatch _ = Nothing++      --The selected sub-expression is in the rhs of a pattern-binding+      inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = error "Cannot fold against a variable within a pattern binding!"+      inPat _ = Nothing++      rmGuard ((HsGuard gs)::RhsP)+             = let (_,e1,e2)=glast "guardToIfThenElse" gs+               in  if ((pNtoName.expToPN) e1)=="otherwise" +                   then (foldl mkIfThenElse e2 (tail(reverse gs)))+                   else (foldl mkIfThenElse defaultElse (reverse gs)) +           +      mkIfThenElse e (_,e1, e2)=(Exp (HsIf e1 e2 e)) ++      defaultElse=(Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "error") (G (PlainModule "Prelude") "error" +                    (N (Just loc0)))) Value (N (Just loc0)))))) (Exp (HsLit loc0 (HsString "UnMatched Pattern")))))+++         +checkInPat :: Term t =>  PNT -> t -> Bool+checkInPat pnt t+  = checkInMatch pnt t+  where+   checkInMatch pnt t+     = fromMaybe (False)+                 (applyTU (once_tdTU (failTU `adhocTU` inMatch)) t)+   --The selected sub-expression is in the rhs of a match+   inMatch (match@(HsMatch loc1  _ pats rhs ds)::HsMatchP)+    | findPNT' pnt pats+          = Just True+       where findPNT' pnt []     = False+             findPNT' pnt (p@(Pat (HsPIrrPat p1)):ps)+              | findPNT pnt p1 = True+              | otherwise     = findPNT' pnt ps+             findPNT' pnt (p@(Pat (HsPParen p1)):ps)+              | findPNT' pnt [p1] = True+              | otherwise     = findPNT' pnt ps+             findPNT' pnt (p@(Pat (HsPId x)):ps) +              | findPNT pnt p = True+              | otherwise     = findPNT' pnt ps+             findPNT' pnt (p:ps) = findPNT' pnt ps+   inMatch _ = Nothing++checkInSubPat :: Term t =>  PNT -> t -> Bool+checkInSubPat pnt t+  = checkInPat pnt t+  where+   checkInPat pnt t+     = fromMaybe (False)+                 (applyTU (once_tdTU (failTU `adhocTU` inMatch)) t)+   --The selected sub-expression is in the rhs of a match+   inMatch (match@(HsMatch loc1  _ pats rhs ds)::HsMatchP)+    | findPNT' pnt pats+          = Just True+       where findPNT' pnt []     = False+             findPNT' pnt ((Pat (HsPAsPat i p)):ps)+              | findPNT pnt i    = True+              | findPNT' pnt [p] = True+              | otherwise        = findPNT' pnt ps+             findPNT' pnt ((Pat (HsPApp i ps)):pss)+              | findPNT' pnt ps = True+              | otherwise     = findPNT' pnt ps+             findPNT' pnt ((Pat (HsPTuple _ ps)):pss)+              | findPNT' pnt ps = True+              | otherwise       = findPNT' pnt ps+             findPNT' pnt (Pat (HsPInfixApp p1 i p2):ps)+              | findPNT pnt p1 || findPNT pnt p2 = True+              | otherwise  = findPNT' pnt ps+             findPNT' pnt (p@(Pat (HsPParen p1)):ps)+              | findPNT' pnt [p1] = True+              | otherwise     = findPNT' pnt ps+             findPNT' pnt (p@(Pat (HsPId x)):ps) +              | findPNT pnt p = True+              | otherwise     = findPNT' pnt ps+             findPNT' pnt (p:ps) = findPNT' pnt ps+   inMatch _ = Nothing++createPat :: PNT -> String -> Int -> HsPatP -> [String] -> HsPatP+createPat pnt x i (Pat (HsPIrrPat p)) environ+    = (Pat (HsPIrrPat (createPat' pnt x i environ)))+createPat pnt x i _ environ = createPat' pnt x i environ++createPat' pnt i 0 environ = Pat (HsPAsPat pnt (Pat (HsPId (HsCon (nameToPNT i)))))+createPat' pnt x@(':':xs) ts environ+  = Pat (HsPAsPat pnt (Pat (HsPInfixApp (ghead "createPat" pat1) (nameToPNT x) +                                                                 (last pat1))))+       where +         pat1 = reverse $ createId environ ts+createPat' pnt x@('(':xs) ts environ+   = Pat (HsPAsPat pnt (Pat ( HsPTuple loc0 (reverse (createId environ ts)))))                      +createPat' pnt i ts environ = Pat (HsPAsPat pnt (Pat (HsPApp (nameToPNT i) (reverse (createId environ ts)))))++createId _ 0 = []+createId names a+   = let newName = mkNewName "b" names a+     in (nameToPat newName) : (createId (names ++ [newName]) (a-1))+                 +                 +replace :: Int -> [a] -> a -> [a]+replace pos [] e = []+replace pos list e+   = (init (take pos list)) ++ [e] ++ (drop pos list) ++inMatch _ [] = False+inMatch pnt (match@(HsMatch loc name pats rhs ds):ms)+  | findPNT pnt pats = True+  | otherwise        = inMatch pnt ms+ +getMatch _ [] = error "Please select a pattern variable on the LHS of an equation!"+getMatch pnt (match@(HsMatch loc name pats rhs ds):ms)+  | findPNT pnt pats = match+  | otherwise        = getMatch pnt ms+                       ++ +getTypeSig name t+  = fromMaybe (error "Please define a type signature for the definition!")+              (applyTU (once_tdTU (failTU `adhocTU` inDec)) t)+   where+     inDec (d@(Dec (HsTypeSig _ _ _ _))::HsDeclP)+        | definesTypeSig name d = Just d+     inDec _ = Nothing+ +findTypeAndConstrs index _ _ [] = error "No type associated with pattern variable!"+findTypeAndConstrs index pnt types (p:ps) +  | findPNT pnt p = extractConstrs (types !! index)+  | otherwise     = findTypeAndConstrs (index+1) pnt types ps              +         +findPatAndType index _ _ [] = error "No type associated with pattern variable!"+findPatAndType index pnt types (p:ps) +  | findPNT pnt p = (typToPNT (types !! index), index)+  | otherwise     = findPatAndType (index+1) pnt types ps+        +-- flatternType :: HsDeclP -> [HsTypeP]+flatternType (Dec (HsTypeSig _ _ _ t))+  = flatternT t+flatternT (Typ (HsTyApp t1 t2)) = flatternT t1 +flatternT (Typ (HsTyFun t1 t2)) = flatternT t1 ++ flatternT t2 +flatternT (Typ (HsTyForall _ _ t)) = flatternT t+flatternT t = [t]++flatternAllType (Dec (HsTypeSig _ _ _ t))+  = flatternAllT t+flatternAllT (Typ (HsTyApp t1 t2))+  = flatternAllT t1 ++ flatternAllT t2+ --  | pNTtoName (typToPNT t1) == "[]" = flatternAllT t1+ -- | otherwise = flatternAllT t1 ++ flatternAllT t2+flatternAllT (Typ (HsTyFun t1 t2)) = flatternAllT t1 ++ flatternAllT t2 +flatternAllT (Typ (HsTyForall _ _ t)) = flatternAllT t+flatternAllT t = [t]++extractConstrs t@(Typ (HsTyCon (PNT pn (Type (TypeInfo _ [] _)) _ ))) +  = error "There are no constructors defined for the type of this pattern!"   +extractConstrs (Typ (HsTyCon (PNT pn (Type (TypeInfo _ cs _)) _ ))) = cs+extractConstrs x = error "Please select a variable with a type constructor!" +++extractConstrs' t@(Typ (HsTyCon (PNT pn (Type (TypeInfo _ [] _)) _ ))) _ _ _ _+  = error "There are no constructors defined for the type of this pattern!" +extractConstrs' (Typ (HsTyCon (PNT pn (Type (TypeInfo _ cs _)) _ ))) _ _ _ _ = cs+extractConstrs' (Typ (HsTyVar (PNT pn (Type (TypeInfo _ cs _)) _ ))) types ty pos constrName +   =  -- if it's a variable, then it must be exposed on the+      -- LHS of the type+      -- what about existential types?+      let posOfVar = findPosOfVar constrName ty+          instanceOfVarType = findPosOfInstance posOfVar (declToPNT ty) types+        in extractConstrs instanceOfVarType      ++findPosOfInstance _ _ [] = error "pattern is a variable which is not instantiated within the type signature!"+findPosOfInstance offset pn (t@(Typ (HsTyCon pnt)):ts)+ | rmLocs pn == rmLocs pnt = ts !! (offset-1)+ | otherwise               = findPosOfInstance offset pn ts++findPosOfVar (Typ (HsTyVar pnt)) (Dec (HsDataDecl _ _ t _ _))+   = extractPos 0 (flatternAllT t) +       where+         extractPos i [] = i+         extractPos i ((Typ (HsTyCon pnt2)):ts) +           = extractPos (i+1) ts+         extractPos i ((Typ (HsTyVar pnt2)):ts)+           | rmLocs pnt2 == rmLocs pnt = i+           | otherwise                 = extractPos (i+1) ts+
+ refactorer/RefacLetWhere.hs view
@@ -0,0 +1,489 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacLetWhere+-- Copyright   :  (c) Christopher Brown 2008+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Let to Where and its converse. Apart from the pure syntactic change,+-- A where is an equation where a let is an expression. Therefore, one must+-- take into account guards and patterns as well as scoped entities.+--+-- Let also binds closer than Where.+--+-----------------------------------------------------------------------------++module RefacLetWhere where++import PrettyPrint+import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils+import PFE0 (findFile)+import MUtils (( # ))+import RefacLocUtils++-- | Binds an exp to another e.g. (HsID x, HsLit 5) says x is bound to 5.+-- and it continues until the next non-comment line+type Binding = (HsExpP, HsExpP)++-- | An environment is a *set* of bindings.+type Environment = [Binding]++{- | An environment that is not yet a set - should be processed into an+    'Environment'. -}+type NonSetEnv = [Maybe Binding]++-- | An argument list for a function which of course is a list of paterns.+type FunctionPats = [HsPatP]++-- | A list of declarations used to represent a where or let clause.+type WhereDecls = [HsDeclP]++data LetType = LetExp HsExpP | MonExp HsStmtP | Gen [HsDeclP]++letToWhere args+ = do let  fileName = ghead "filename"  args +           row = read (args!!1)::Int+           col = read (args!!2)::Int+      -- f <-  MT.lift $ getCurrentDirectory +      modName <- fileNameToModName fileName +      (inscps, _, mod, toks) <- parseSourceFile fileName  +      +      let pnt = locToPNT fileName (row, col) mod                                         +          pn = pNTtoPN pnt+      if pn /= defaultPN+         then liftToWhere modName fileName (inscps, mod, toks) pnt+         else error "\nInvalid cursor position!\n"+                     ++{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+                     +findDefNameAndExp toks beginPos endPos t+  = fromMaybe (defaultPNT, [], defaultExp, [])+              (applyTU (once_tdTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t)++    where+      --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats rhs ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (pnt, pats, locToExp beginPos endPos toks rhs, ds)+      inMatch _ = Nothing++      --The selected sub-expression is in the rhs of a pattern-binding+      inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (patToPNT ps, [], locToExp beginPos endPos toks rhs, ds)+      inPat _ = Nothing +      +++convertLets d e (_,_,mod)+ = do+      t' <- addLetInWhere d e mod+      t''  <- doLetToWhere d e t'+      return t'' ++liftToWhere modName fileName (inscps, mod, toks) pnt@(PNT pn _ _)   +  = if isLocalFunOrPatName pn mod+        then do (mod', ((toks',m),_))<-liftWhereLevel            +                writeRefactoredFiles False [((fileName,m),(toks',mod'))]     +        else error "\nThe identifer is not a function/pattern name!"+   where+    liftWhereLevel =+       runStateT (applyTP ((once_tdTP (failTP `adhocTP` liftToWhere'+                                                            `adhocTP` liftToWhere2+                                                            ))+                                          `choiceTP` failure) mod) ((toks,unmodified),(-1000,0))            +         where+           liftToWhere' (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP) +             | definingDecls [pn] (hsDecls rhs) False  False /=[] +                  =doLifting2 pat  pn +           liftToWhere' _=mzero+           +           liftToWhere2 (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+            | definingDecls [pn] (hsDecls rhs) False  False /=[] +                  =doLifting3 match  pn +           liftToWhere2 _=mzero+                        +           doLifting2 dest@(Dec (HsPatBind loc p parent ds)) pn +               = do  let  liftedDecls=definingDecls [pn] (hsDecls parent) True  False+                          declaredPns=nub $ concatMap definedPNs liftedDecls+                     pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns+                     (_, dd)<-hsFreeAndDeclaredPNs dest +                     if pns==[]+                       then do (parent',liftedDecls',paramAdded)<-addParamsToDef pn dd parent liftedDecls+                               let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls'+                                                                else liftedDecls'+                               moveDecl1 (Dec (HsPatBind loc p parent' ds)) Nothing [pn] False +                         else askRenamingMsg pns "lifting"  +           doLifting3 (match@(HsMatch loc1 name pats parent ds)::HsMatchP) pn +               = do  let  liftedDecls=definingDecls [pn] (hsDecls parent) True  False+                          declaredPns=nub $ concatMap definedPNs liftedDecls+                     pns<-pnsNeedRenaming inscps match parent liftedDecls declaredPns+                     (_, dd)<-hsFreeAndDeclaredPNs match +                     if pns==[]+                       then do (parent',liftedDecls',paramAdded)<-addParamsToDef pn dd parent liftedDecls+                               let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls'+                                                                else liftedDecls'+                               moveDecl1 (HsMatch loc1 name pats parent' ds) Nothing [pn] False +                         else askRenamingMsg pns "lifting"        +                        +           worker dest ds pn+                  =do let (before, parent,after)=divideDecls ds pnt                                    +                          liftedDecls=definingDecls [pn] (hsDecls parent) True  False+                          declaredPns=nub $ concatMap definedPNs liftedDecls+                      (_, dd)<-hsFreeAndDeclaredPNs dest +                      pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns+                      if pns==[]+                        then do +                                (parent',liftedDecls',paramAdded)<-addParamsToDef pn dd+                                                                     parent liftedDecls +                                let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls'+                                                                else liftedDecls'+                                --True means the new decl will be at the same level with its parant. +                                dest'<-moveDecl1 (replaceDecls dest (before++parent'++after))+                                           (Just (ghead "liftToWhere" (definedPNs (ghead "worker" parent')))) [pn] False+                                return (hsDecls dest')+                                --parent'<-doMoving declaredPns (ghead "worker" parent) True  paramAdded parent'+                                --return (before++parent'++liftedDecls''++after)+                        else askRenamingMsg pns "lifting"++           failure=idTP `adhocTP` mod+                where+                  mod (m::HsModuleP)+                   = error ( "Lifting this definition failed. "+++                           " This might be because that the definition to be lifted is defined in a class/instance declaration.")++--return True if pn is a local function/pattern name+isLocalFunOrPatName pn scope+ =isLocalPN pn && isFunOrPatName pn scope++-- |Divide a declaration list into three parts (before, parent, after) according to the PNT,+-- where 'parent' is the first decl containing the PNT, 'before' are those decls before 'parent'+-- and 'after' are those decls after 'parent'.++divideDecls::[HsDeclP]->PNT->([HsDeclP],[HsDeclP],[HsDeclP])+divideDecls ds pnt+  = let (before,after)=break (\x->findPNT pnt x) ds+    in if (after/=[])+         then (before, [ghead "divideDecls" after], tail after)+         else (ds,[],[]) +++--Get the subset of 'pns' that need to be renamed before lifting.+pnsNeedRenaming inscps dest parent liftedDecls pns+   =do r<-mapM pnsNeedRenaming' pns   +       return (concat r)+  where                 +     pnsNeedRenaming' pn+       = do (f,d)<-hsFDsFromInside dest  --f: free variable names that may be shadowed by pn+                                             --d: declaread variables names that may clash with pn+            vs<-hsVisiblePNs pn parent      --vs: declarad varaibles that may shadow pn          +            let inscpNames = map (\(x,_,_,_)->x) $ inScopeInfo inscps+                vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames            +            if elem (pNtoName pn) vars  || isInScopeAndUnqualified (pNtoName pn) inscps && findEntity pn dest +               then return [pn]+               else return []+     --This pNtoName takes into account the qualifier.+     pNtoName (PN (UnQual i) orig)=i    +     pNtoName (PN (Qual (PlainModule modName) i ) orig)=modName ++ "." ++ i  +++askRenamingMsg pns str +  = error ("The identifier(s):" ++ showEntities showPNwithLoc pns +++           " will cause name clash/capture or ambiguity occurrence problem after "+           ++ str ++", please do renaming first!") ++moveDecl1 t defName pns topLevel+   = do ((toks, _),_)<-get+        let (declToMove, toksToMove) = getDeclAndToks (ghead "moveDecl1" pns) True toks t+	--error$ show (declToMove, toksToMove)+        t' <- rmDecl (ghead "moveDecl3"  pns) False =<<foldM (flip rmTypeSig) t pns+        addDecl t' defName (declToMove, Just toksToMove) topLevel + +       +{-       +LiftToWhere' d (LetExp le@(Exp (HsLet xs e1))) t+  = applyTP (stop_tdTP (failTP `adhocTP` funcCheck)) t+     where+       funcCheck (dec@(Dec (HsPatBind l ps rhs ds))::HsDeclP)+         | findEntity le rhs = do +                                  (gg, decsRHS) <- freeDecs' rhs+                                  +                                  when (length (filter (==(declToPName2 d)) decsRHS) > 1) +                                       (error ("Please rename " ++ (declToName d) ++ "before this refactoring to resolve scoping issues."))+         +                                  (free, decs) <- freeDecs ds+                                  if (declToName d) `elem` decs+                                     then do+                                       error ("Lifting " ++ (declToName d) ++ +                                              " conflicts with a declared entity in the where clause. Please rename the entity first.")+                                     else do+                                       +                                           -- then we pass in the dependencies as parameters! :)+                                           let liftedDecls=definingDecls [(declToPName2 d)] [dec] True True+                                           (_,dd)<-hsFreeAndDeclaredPNs t+                                           op@(declToLift, ds', md) <- addParamsToDef (declToPName2 d) dd dec liftedDecls+                                           error $ show op                                   +                                           {- let freeDec' = filterDecs freeDec (freeLet ++ decLet)+                                           error ( (concat (map pNtoName freeDec')) ++ +                                                   " is/are not in scope within in the where clause.") -}+         | otherwise         = return dec+           where         +       funcCheck (dec@(Dec (HsFunBind loc matches))::HsDeclP)+        = do+             result <- checkMatches matches+             return (Dec (HsFunBind loc result))+          where+            checkMatches [] = return matches+            checkMatches (m@(HsMatch _ _ _ rhs ds):ms)+              |  findEntity le rhs = do +                                      decsRHS <- (decsInRHS rhs)+                                      when (length (filter (==(declToName d)) decsRHS) > 1) +                                            (error ("Please rename " ++ (declToName d) ++ "before this refactoring to resolve scoping issues."))+         ++                                      (free, decs) <- freeDecs ds+                                      if (declToName d) `elem` decs+                                       then do+                                        error ("Lifting " ++ (declToName d) ++ +                                               " conflicts with a declared entity in the where clause. Please rename the entity first.")+                                       else do+                                        (freeDec, _) <- freeDecs' d+                                        (freeLet, decLet) <- freeDecs' (xs \\ [d])+                                        (free', decs') <- freeDecs' ds+                                     +                                        if and (freeDec `myElem` decLet) && and (freeDec `myElem` (freeLet ++ decLet))+                                         then do+                                          ds' <- addDecl m Nothing ([d], Nothing) False+                                          return (ds':ms)+                                         else do+                                           let freeDec' = filterDecs freeDec (freeLet ++ decLet)+                                           error ( (concat (map pNtoName freeDec')) ++ +                                                   " is/are not in scope within in the where clause.")+              | otherwise = do+                               rest <- checkMatches ms+                               return (m:rest)+                  where+                   freeDecs m = hsFreeAndDeclaredNames m+       funcCheck x = return x+       +       decsInRHS rhs +         = do (_, res) <- hsFreeAndDeclaredNames rhs+              return res+       +       freeDecs m = hsFreeAndDeclaredNames m+       freeDecs' m = hsFreeAndDeclaredPNs m+       filterDecs [] [] = []+       filterDecs [] _  = []+       filterDecs _ []  = []+       filterDecs (x:xs) list+               | x `elem` list = x : filterDecs xs list+               | otherwise     = filterDecs xs list+         +       myElem [] [] = [True]+       myElem [] _  = [True]+       myElem _ []  = [True]+       myElem (x:xs) list = (x `elem` xs) : myElem xs list        -}           +    +addLetInWhere d (MonExp le@(HsLetStmt xs r)) t+  = applyTP (stop_tdTP (failTP `adhocTP` funcCheck)) t+     where+       funcCheck (dec@(Dec (HsPatBind l ps rhs ds))::HsDeclP)+         | findEntity le rhs = do +                                  (free, decs) <- freeDecs ds+                                  if (declToName d) `elem` decs+                                     then do+                                       error ("Lifting " ++ (declToName d) ++ +                                              " conflicts with a declared entity in the where clause. Please rename the entity first.")+                                     else do+                                       (freeDec, _) <- freeDecs' d+                                       (freeLet, decLet) <- freeDecs' (xs \\ [d])+                                       (free', decs') <- freeDecs' ds+                                     +                                       if and (freeDec `myElem` decLet) && and (freeDec `myElem` (freeLet ++ decLet))+                                         then do+                                           ds' <- addDecl dec Nothing ([d], Nothing) False+                                           return ds'+                                         else do+                                           let freeDec' = filterDecs freeDec (freeLet ++ decLet)+                                           error ( (concat (map pNtoName freeDec')) ++ +                                                   " is/are not in scope within in the where clause.")+         | otherwise         = return dec+           where         +       funcCheck (dec@(Dec (HsFunBind loc matches))::HsDeclP)+        = do+             result <- checkMatches matches+             return (Dec (HsFunBind loc result))+          where+            checkMatches [] = return matches+            checkMatches (m@(HsMatch _ _ _ rhs ds):ms)+              |  findEntity le rhs = do +                                      (free, decs) <- freeDecs ds+                                      if (declToName d) `elem` decs+                                       then do+                                        error ("Lifting " ++ (declToName d) ++ +                                               " conflicts with a declared entity in the where clause. Please rename the entity first.")+                                       else do+                                        (freeDec, _) <- freeDecs' d+                                        (freeLet, decLet) <- freeDecs' (xs \\ [d])+                                        (free', decs') <- freeDecs' ds+                                     +                                        if and (freeDec `myElem` decLet) && and (freeDec `myElem` (freeLet ++ decLet))+                                         then do+                                          ds' <- addDecl m Nothing ([d], Nothing) False+                                          return (ds':ms)+                                         else do+                                           let freeDec' = filterDecs freeDec (freeLet ++ decLet)+                                           error ( (concat (map pNtoName freeDec')) ++ +                                                   " is/are not in scope within in the where clause.")+              | otherwise = do+                               rest <- checkMatches ms+                               return (m:rest)+                  where+                   freeDecs m = hsFreeAndDeclaredNames m++         +       funcCheck x = return x+       +       +       freeDecs m = hsFreeAndDeclaredNames m+       freeDecs' m = hsFreeAndDeclaredPNs m+       filterDecs [] [] = []+       filterDecs [] _  = []+       filterDecs _ []  = []+       filterDecs (x:xs) list+               | x `elem` list = x : filterDecs xs list+               | otherwise     = filterDecs xs list+         +       myElem [] [] = [True]+       myElem [] _  = [True]+       myElem _ []  = [True]+       myElem (x:xs) list = (x `elem` xs) : myElem xs list+addLetInWhere _ _ _ = error "Please highlight a let expression!"+           +addParamsToDef pn dd parent liftedDecls+  =do  (ef,_)<-hsFreeAndDeclaredPNs parent+       (lf,_)<-hsFreeAndDeclaredPNs liftedDecls   +       let newParams=((nub lf)\\ (nub ef)) \\ dd  --parameters (in PName format) to be added to pn because of lifting+       if newParams/=[]  +         then if  (any isComplexPatBind liftedDecls)+                then error "This pattern binding cannot be lifted, as it uses some other local bindings!"+                else do parent'<-{-addParamsToDecls parent pn newParams True-} addParamsToParent pn newParams parent+                        liftedDecls'<-addParamsToDecls liftedDecls pn newParams True +                        return (parent', liftedDecls',True)+         else return (parent,liftedDecls,False)++addParamsToParent pn [] t = return t+addParamsToParent pn params t+   =applyTP(full_buTP (idTP  `adhocTP` inExp)) t +   where              +          inExp (exp@(Exp (HsId (HsVar (PNT pname ty loc))))::HsExpP)+            | pname==pn+             = do  let newExp=Exp (HsParen (foldl addParamToExp exp (map pNtoExp params)))+                   update exp newExp exp++          inExp x =return x                   +   +          addParamToExp  exp param+              =(Exp (HsApp exp param)) +    ++doLetToWhere :: (MonadPlus m, Term t, MonadState (([PosToken], Bool), (Int, Int)) m) =>+                 HsDeclP -> LetType -> t -> m t+doLetToWhere d (LetExp e@(Exp (HsLet xs e1))) t+  =  applyTP (stop_tdTP (failTP `adhocTP` (expCheck e))) t+    where+      expCheck (exp1::HsExpP) (exp2::HsExpP)+        | sameOccurrence exp1 exp2 == True+           = do+                if (length xs) > 1 +                  then do+                          ds <- rmDecl (pNTtoPN (declToPNT d)) False xs+                          return (Exp (HsLet ds e1))+                  else do+                          update exp2 e1 exp2+        | otherwise = mzero+doLetToWhere d (MonExp m@(HsLetStmt xs r)) t+  =  applyTP (stop_tdTP (failTP `adhocTP` (expCheck m))) t+    where+      expCheck (stmt1::HsStmtP) (stmt2::HsStmtP)+        | sameOccurrence stmt1 stmt2 == True+           = do+                if (length xs) > 1 +                  then do+                          ds <- rmDecl (pNTtoPN (declToPNT d)) False xs+                          return (HsLetStmt ds r)+                  else do+                          update stmt1 r stmt1+        | otherwise = mzero+doLetToWhere _ _ _ = error "Please highlight a let expression!"+++checkLet :: (Term t) => t -> PName -> LetType+checkLet t name+ = (fromMaybe (error "Please select a definition within a let clause")) +              (applyTU (once_buTU (failTU `adhocTU` inExp `adhocTU` inMon)) t)+    where+      inExp exp@(Exp (HsLet ds e)::HsExpP)+        | or (map (defines name) ds) = Just (LetExp exp)+      inExp _ = Nothing+      +      inMon mon@((HsLetStmt ds rest)::HsStmtP)+        | or (map (defines name) ds) = Just (MonExp mon)+      inMon _ = Nothing+      -- inMonad mon@(+    +checkCursor :: String -> Int -> Int -> HsModuleP -> HsDeclP+checkCursor fileName row col mod+ = (fromMaybe (error "Please select a definition!")) $ (locToDec fileName (row, col) mod)+         +-- |Find the declaration(in PNT format) whose start position is (row,col) in the+-- file specified by the fileName, and returns Nothing if such an identifier does not exist.++locToDec::(Term t)=>String      -- ^ The file name +                    ->(Int,Int) -- ^ The row and column number               +                    ->t         -- ^ The syntax phrase+                    ->Maybe HsDeclP       -- ^ The result+locToDec  fileName (row, col) t+  =applyTU (once_buTU (failTU `adhocTU` worker)) t+     where +        worker dec@(Dec (HsFunBind loc ((HsMatch loc0 name p rhs ds):ms))::HsDeclP)+          | locToPNT' name fileName (row, col) = Just dec+        worker dec@(Dec (HsPatBind loc0 name rhs ds))+          | locToPNT' (patToPNT name) fileName (row, col) = Just dec+        worker _ = Nothing+     +        locToPNT' name fileName (row, col)+          = (fromMaybe False) $ (applyTU (once_buTU (failTU `adhocTU` worker)) name)+           where+            worker pnt@(PNT pname ty (N (Just (SrcLoc fileName1 _ row1 col1))))+              |fileName1==fileName && (row1,col1) == (row,col) = Just True+            worker _ =Nothing
+ refactorer/RefacLocUtils view
@@ -0,0 +1,1329 @@+++module RefacLocUtils(module HsTokens,PosToken, simpPos, +                     SimpPos,unmodified,modified,simpPos0,ghead,glast,gfromJust,gtail,++                     tokenCol, tokenRow, tokenPos,tokenCon,tokenLen,lengthOfToks,+                     mkToken,defaultToken,newLnToken,whiteSpacesToken,whiteSpaceTokens,isWhite,+                     notWhite,isWhiteSpace,isNewLn,isCommentStart,isComment,+                     isNestedComment,isMultiLineComment,isOpenBracket,isCloseBracket,+                     isOpenSquareBracket,isCloseSquareBracket,isOpenBrace,isConid,+                     isLit,isWhereOrLet,isWhere,isLet,isIn,isCase,isDo,isIf,isForall,+                     isHiding,isModule,isComma,isEqual,isLambda,isIrrefute,isBar,isMinus,+                     endsWithNewLn,startsWithNewLn,hasNewLn,startsWithEmptyLn, +                     lastNonSpaceToken,firstNonSpaceToken,compressPreNewLns,compressEndNewLns,+                     lengthOfLastLine,+                     updateToks,+                     getToks,replaceToks,deleteToks, doRmWhites,doAddWhites,+                     srcLocs, getStartEndLoc, getStartEndLoc2,+                     startEndLoc,extendBothSides,extendForwards,extendBackwards,+                     startEndLocIncFowComment,startEndLocIncFowNewLn,startEndLocIncComments,+                     prettyprint ,deleteFromToks, prettyprintGuardsAlt,+                     addFormalParams,  adjustOffset, -- try to remove it +                     StartEndLoc, isArrow,-- swapInToks,+                     commentToks,tokenise, prettyprintPatList,groupTokensByLine, addLocInfo, getOffset, splitToks, insertComments,+                     extractComments, insertTerms+  ) where++import RefacTypeSyn(SimpPos)+import PosSyntax+import UniqueNames +import HsLexerPass1 hiding (notWhite)+import HsTokens+import PrettySymbols(rarrow)+import HsLayoutPre (PosToken)+import PrettyPrint+import HsExpUtil+import PNT ++import RefacTypeSyn+import Maybe+import List+import SourceNames+-------------------------+--import DriftStructUtils  +import StrategyLib+------------------------+import Control.Monad.State++--In the token stream, locations are unique except the default locs.++{- Some related data types defined by Programatica's Lexer:+type Lexer = String -> LexerOutPut++type LexerOutput = [PosToken]++type PosToken = (Token,(Pos,String))++data Pos = Pos { char, line, column :: !Int } deriving (Show)+-- it seems that the field char is used to handle special characters including the '\t'++data Token+  = Varid | Conid | Varsym | Consym+  | Reservedid | Reservedop  | Specialid+  | IntLit | FloatLit | CharLit | StringLit+  | Qvarid | Qconid | Qvarsym | Qconsym+  | Special | Whitespace+  | NestedCommentStart -- will cause a call to an external function+  | NestedComment  -- from the external function+  | Commentstart  -- dashes+  | Comment -- what follows the dashes+  | ErrorToken | GotEOF | TheRest+  | ModuleName | ModuleAlias -- recognized in a later pass+  -- Inserted during layout processing (see Haskell 98, 9.3):+  | Layout     -- for implicit braces+  | Indent Int -- <n>, to preceed first token on each line+  | Open Int   -- {n}, after let, where, do or of, if not followed by a "{"+  deriving (Show,Eq,Ord)+-}++--A flag used to indicate whether the token stream has been modified or not.+unmodified = False+modified   = True++--- some default values----+pos0=Pos 0 0 0+simpPos0 = (0,0)++extractComments :: (SimpPos, SimpPos) -> [PosToken] -> [PosToken]+extractComments ((startPosl, startPosr), endPos) toks+   = let (toks1, toks21, toks22) = splitToks ((startPosl, startPosr), endPos) toks+      in toks1++------------------------------------------------+ghead info []    = error $ "ghead "++info++" []"+ghead ingp (h:_) = h++glast info []    = error $ "glast " ++ info ++ " []"+glast info h     = last h++gtail info []   = error $ "gtail " ++ info ++ " []"+gtail info h    = tail h++gfromJust info (Just h) = h+gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing"++--Some functions for fetching a specific field of a token+tokenCol (_,(Pos _ _ c,_)) = c  ++tokenRow (_,(Pos _ r _,_)) = r++tokenPos (_,(p,_))     = simpPos p++tokenCon (_,(_,s))     = s++tokenLen (_,(_,s))     = length s   --check this again! need to handle the tab key.++lengthOfToks::[PosToken]->Int+lengthOfToks=length.(concatMap tokenCon)++--Some functions for checking whether a token is of a specific type of token.+isWhite (t,_)                = t==Whitespace || t==Commentstart || t==Comment || t==NestedComment+notWhite  = not.isWhite++isWhiteSpace (t,(_,s))       = t==Whitespace && s==" "+isNewLn (t,(_,s))            = t==Whitespace && s=="\n"++isCommentStart (t,(_,s))     = t==Commentstart && s=="--" +isComment (t,(_,s))          = t==Comment || t ==NestedComment+isNestedComment (t,(_,s))    = t==NestedComment+isMultiLineComment (t,(_,s)) = t==NestedComment && (isJust (find (=='\n') s))++isOpenBracket  (t,(_,s))       = t==Special && s=="("+isCloseBracket (t,(_,s))       = t==Special && s==")"++isOpenSquareBracket  (t,(_,s)) = t==Special && s=="[" +isCloseSquareBracket (t,(_,s)) = t==Special && s=="]"++isOpenBrace  (t,(_,s))         = t==Special && s=="{" +isCloseBrace (t,(_,s))         = t==Special && s=="}" ++isConid (t,(_,_))              = t==Conid+isLit (t,(_,s)) = t==IntLit || t==FloatLit || t==CharLit || t==StringLit++isWhereOrLet  t   = isWhere t || isLet t+isWhere (t,(_,s)) = t==Reservedid && s=="where"+isLet   (t,(_,s)) = t==Reservedid && s=="let"+isImport (t, (_,s))= t == Reservedid && s=="import"+isType (t, (_,s))= t  == Reservedid && s=="type"+isData (t, (_,s))= t == Reservedid && s=="data"+isFixty (t, (_,s)) = t==Reservedid && (s=="infix" || s=="infixl" || s=="infixr")+isDefault (t, (_,s)) = t == Reservedid && s=="default"+isClass (t, (_,s)) = t == Reservedid && s=="class"+isInstance (t, (_,s)) = t == Reservedid && s=="instance"+isNewtype (t, (_,s)) = t == Reservedid && s=="newtype"++isIn    (t,(_,s))  = t==Reservedid && s=="in" +isCase  (t,(_,s))  = t==Reservedid && s=="case"  +isDo    (t,(_,s))  = t==Reservedid && s=="do"  +isIf    (t,(_,s))  = t==Reservedid && s=="if"+isForall (t,(_,s)) = t==Reservedid && s=="forall"+isHiding (t,(_,s)) = s=="hiding" +isModule (t,(_,s)) = t==Reservedid && s=="module"+  +isComma (t,(_,s))    = t==Special && s=="," +isEqual  (t,(_,s))   = t==Reservedop && s=="="+isLambda (t,(_,s))   = t==Reservedop && s=="\\"+isIrrefute (t,(_,s)) = t==Reservedop && s=="~"+isBar   (t,(_,s))    = t==Reservedop && s=="|"+isArrow (t,(_,s))    = t==Reservedop && s=="->"+isMinus (t,(_,s))    = t==Varsym && s=="-"++-----------------------------------------------------------------++--Returns True if the token ends with '\n'+endsWithNewLn::PosToken->Bool+endsWithNewLn   (_,(_,s)) =if s==[] then False +                                    else (glast "endsWithNewLn"  s=='\n')+ +--Returns True if the token starts with `\n`.+startsWithNewLn::PosToken->Bool+startsWithNewLn (_,(_,s)) =if s==[] then False +                                    else ((ghead "starsWithNewLn" s)=='\n')++--Returns True if there is a '\n' in the token.+hasNewLn::PosToken->Bool+hasNewLn (_,(_,s))=isJust (find (=='\n') s) {-different from isNewLn -}+++--Returns True if a token stream starts with a newline token (apart from the white spaces tokens)+startsWithEmptyLn::[PosToken]->Bool+startsWithEmptyLn toks=isJust (find isNewLn $ takeWhile (\t->isWhiteSpace t || isNewLn t) toks)++-- get the last non-space token in a token stream.+lastNonSpaceToken::[PosToken]->PosToken+lastNonSpaceToken toks=case dropWhile isWhiteSpace (reverse toks) of+                         [] ->defaultToken+                         l -> ghead "lastNonSpaceToken" l++--get the first non-space token in a token stream.+firstNonSpaceToken::[PosToken]->PosToken+firstNonSpaceToken toks=case dropWhile isWhiteSpace toks of+                         [] ->defaultToken+                         l -> ghead "firstNonSpaceToken" l  ++-- remove the extra preceding  empty lines.+compressPreNewLns::[PosToken]->[PosToken]+compressPreNewLns toks= let (toks1, toks2) = break (not.(\t->isNewLn t || isWhiteSpace t)) toks+                            groupedToks    = groupTokensByLine toks1+                        in if length groupedToks>1 then (last groupedToks)++toks2  +                                                   else toks++--remove the following extra empty lines.+compressEndNewLns::[PosToken]->[PosToken]+compressEndNewLns toks=let (toks1, toks2) = break (not.(\t->isNewLn t || isWhiteSpace t)) (reverse toks)+                           groupedToks    = groupTokensByLine toks1+                       in if length groupedToks>1 then reverse ((ghead "compressEndNewLns" groupedToks)++toks2) +                                                  else toks++prettyprintPatList beginWithSpace t +     = replaceTabBySpaces $ if beginWithSpace then format1 t else format2 t+ where +   format1 t = foldl (\x y -> x++ " "++(render.ppi) y) "" t++   format2 [] = "" +   format2 [p] = (render.ppi) p+   format2 (p:ps) = (render.ppi) p ++" " ++ format2 ps+               +prettyprint = replaceTabBySpaces.render.ppi++prettyprintGuardsAlt = replaceTabBySpaces.render.(ppRhs rarrow)+++--Replace Tab by white spaces. (1 Tab=8 white spaces)+replaceTabBySpaces::String->String+replaceTabBySpaces []=[]+replaceTabBySpaces (s:ss)+  =if s=='\t' then replicate 8 ' ' ++replaceTabBySpaces ss+              else s:replaceTabBySpaces ss+++--Compose a new token using the given arguments.+mkToken::Token->SimpPos->String->PosToken+mkToken t (row,col) c=(t,(Pos 0 row col,c))++---Restriction: the refactorer should not modify refactorer-modified/created tokens.+defaultToken = (Whitespace, (pos0," "))      +newLnToken   = (Whitespace, (pos0,"\n"))  +++tokenise  startPos _ _ [] = []+tokenise  startPos colOffset withFirstLineIndent str +  = let str' = case lines str of +                    (ln:[]) -> addIndent ln ++ if glast "tokenise" str=='\n' then "\n" else ""+                    (ln:lns)-> addIndent ln ++ "\n" ++ concatMap (\n->replicate colOffset ' '++n++"\n") lns+        str'' = if glast "tokenise" str' == '\n' && glast "tokenise" str /='\n'+                  then genericTake (length str' -1) str'+                  else str' +    in expandNewLnTokens $ lexerPass0' startPos str''+   where +     addIndent ln = if withFirstLineIndent +                      then replicate colOffset ' '++ ln+                      else ln         +     --preprocssing the token stream to expand the white spaces to individual tokens.+     expandNewLnTokens::[PosToken]->[PosToken]+     expandNewLnTokens ts = concatMap expand ts+       where+        expand tok@(Whitespace,(pos,s)) = doExpanding pos s                +        expand x = [x]++        doExpanding pos [] =[]+        doExpanding pos@(Pos c row col) (t:ts)+          = case t of +             '\n'  -> (Whitespace, (pos,[t])):(doExpanding (Pos c (row+1) 1) ts)+             _     -> (Whitespace, (pos,[t])):(doExpanding (Pos c row (col+1)) ts)+++--Should add cases for literals.+addLocInfo (decl, toks)+    = runStateT (applyTP (full_tdTP (idTP `adhocTP` inPnt +                                          `adhocTP` inSN)) decl) toks+       where+         inPnt (PNT pname ty (N (Just loc)))+            = do loc' <- findLoc (pNtoName pname)+                 return (PNT pname ty (N (Just loc')))+         inPnt x = return x++         inSN (SN (PlainModule modName) (SrcLoc _ _ row col)) +             = do loc' <- findLoc modName+                  return (SN (PlainModule modName) loc')+         inSN x = return x  + ++         pNtoName (PN (UnQual i) _)=i+         pNtoName (PN (Qual (PlainModule modName) i) _) = modName++"."++i+         pNtoName (PN (Qual (MainModule _) i) _)        = "Main."++i      +         findLoc name  +          = do  let name' = if name =="Prelude.[]" || name == "[]"  then "["+                               else if name=="Prelude.(,)" || name == "(,)" || name == "()"  then "(" +                                                                                             else name   ----Check this again. +                    toks' = dropWhile (\t->tokenCon t /= name') toks+                    (row, col) =if toks'==[] then error "HaRe: Error in addLocInfo!"  +                                              else tokenPos $ ghead "findLoc" toks' +                return (SrcLoc "unknown" 0 row col)+++groupTokensByLine [] = []+groupTokensByLine xs =let (xs', xs'') = break hasNewLn xs+                      in if xs''==[] then [xs']+                          else (xs'++ [ghead "groupTokensByLine" xs''])+                                : groupTokensByLine (gtail "groupTokensByLine" xs'')+                             +--Give a token stream covering multi-lines, calculate the length of the last line  +lengthOfLastLine::[PosToken]->Int+lengthOfLastLine toks+   = let (toks1,toks2)=break hasNewLn $ reverse toks+     in  if toks2==[] +          then sum (map tokenLen toks1)+          else sum (map tokenLen toks1)+lastLineLenOfToken (ghead "lengthOfLastLine"  toks2)+  where +   --Compute the length of a token, if the token covers multi-line, only count the last line.+   --What about tab keys?+   lastLineLenOfToken (_,(_,s))=(length.(takeWhile (\x->x/='\n')).reverse) s++++--get a token stream specified by the start and end position.+getToks::(SimpPos,SimpPos)->[PosToken]->[PosToken]+getToks (startPos,endPos) toks+    =let (_,toks2)=break (\t->tokenPos t==startPos) toks+         (toks21, toks22)=break (\t->tokenPos t==endPos) toks2+     in (toks21++ [ghead "getToks" toks22])   -- Should add error message for empty list?++-- Split the token stream into three parts: the tokens before the startPos,+-- the tokens between startPos and endPos, and the tokens after endPos.+splitToks::(SimpPos, SimpPos)->[PosToken]->([PosToken],[PosToken],[PosToken])+splitToks (startPos, endPos) toks+   = if (startPos, endPos) == (simpPos0, simpPos0)+       then error "Invalid token stream position!"+       else let startPos'= if startPos==simpPos0 then endPos else startPos+                endPos'  = if endPos == simpPos0 then startPos else endPos+                (toks1, toks2) = break (\t -> tokenPos t == startPos') toks+                (toks21, toks22) = break (\t -> tokenPos t== endPos') toks2+                -- Should add error message for empty list?+            in  if toks22==[] then error "Sorry, HaRe failed to finish this refactoring." -- (">" ++ (show (startPos, endPos) ++ show toks))+                  else (toks1, toks21++[ghead "splitToks" toks22], gtail "splitToks" toks22) +++getOffset toks pos+  = let (ts1, ts2) = break (\t->tokenPos t == pos) toks+    in if ts2==[] +         then error "HaRe error: position does not exist in the token stream!"+         else lengthOfLastLine ts1   ++--comment a token stream specified by the start and end position.+commentToks::(SimpPos,SimpPos)->[PosToken]->[PosToken]+commentToks (startPos,endPos) toks+    = let (toks1, toks21, toks22) = splitToks (startPos, endPos) toks+          toks21' = case toks21 of+                     []              -> toks21+                     (t,(l,s)):[]    -> (t, (l, ("{-" ++ s ++ "-}"))):[]+                     (t1,(l1,s1)):ts -> let lastTok@(t2, (l2, s2)) = glast "commentToks" ts+                                            lastTok' = (t2, (l2, (s2++" -}"))) +                                        in (t1,(l1, ("{- "++s1))): (reverse (lastTok': gtail "commentToks" (reverse ts)))+      in (toks1 ++ toks21' ++ toks22)+++insertTerms :: (SimpPos, SimpPos) -> [PosToken] -> String -> [PosToken]+insertTerms ((startPosl, startPosr), endPos) toks com+    = let (toks1, toks21, toks22) = splitToks ((startPosl, startPosr), endPos) toks+          toks21' = (Commentstart, ((Pos 0 startPosl startPosr) , "")) : [(Comment, ((Pos 0 startPosl startPosr), ("\n" ++ com ++ "\n")))]+      in (toks1 ++ toks21' ++ (toks21 ++ toks22))+++insertComments :: (SimpPos, SimpPos) -> [PosToken] -> String -> [PosToken]+insertComments ((startPosl, startPosr), endPos) toks com+    = let (toks1, toks21, toks22) = splitToks ((startPosl, startPosr), endPos) toks+          toks21' = (Commentstart, ((Pos 0 startPosl startPosr) , "")) : [(Comment, ((Pos 0 startPosl startPosr), ("\n{- " ++ com ++ " -}\n")))]+      in (toks1 ++ toks21' ++ (toks21 ++ toks22))+       +---  -} -}++updateToks oldAST newAST printFun+   = do ((toks,_), (v1, v2)) <-get+        let (startPos, endPos) = getStartEndLoc toks oldAST+            (toks1, _, _)      = splitToks (startPos, endPos) toks +            offset             = lengthOfLastLine toks1+            newToks = tokenise (Pos 0 v1 1) offset False $ printFun newAST  --check the startPos+            toks' = replaceToks toks startPos endPos newToks+        if newToks ==[] then put ((toks', modified), (v1,v2)) +                        else put ((toks',modified), (tokenRow (glast "updateToks1" newToks) -10, v2))                +                        +        -- error $ show (newToks, startPos, endPos)+        -- put ((toks', modified), (v1,v2))+        addLocInfo (newAST, newToks)++---REFACTORING: GENERALISE THIS FUNCTION.+addFormalParams t newParams +  = do ((toks,_),(v1, v2))<-get   +       let (startPos,endPos) = getStartEndLoc toks t+           tToks     = getToks (startPos, endPos) toks +           (toks1, _) = let (toks1', toks2') = break (\t-> tokenPos t == endPos) toks+                        in (toks1' ++ [ghead "addFormalParams" toks2'], gtail "addFormalParams"  toks2')+           offset  = lengthOfLastLine toks1+           newToks = tokenise (Pos 0 v1 1) offset False (prettyprintPatList True newParams )+           toks'   = replaceToks toks startPos endPos (tToks++newToks)+       put ((toks',modified), ((tokenRow (glast "addFormalParams" newToks) -10), v2))+       addLocInfo (newParams, newToks)    +++--Replace a list of tokens in the token stream by a new list of tokens, adjust the layout as well.+--To use this function make sure the start and end positions really exist in the token stream.+--QN: what happens if the start or end position does not exist?++replaceToks::[PosToken]->SimpPos->SimpPos->[PosToken]->[PosToken]+replaceToks toks startPos endPos newToks+   = if toks22 == [] +        then toks1 ++ newToks+        else let pos = tokenPos (ghead "replaceToks" toks22)+                 oldOffset = getOffset toks pos       +                 newOffset = getOffset (toks1++newToks++ toks22) pos +             in  toks1++ newToks++ adjustLayout toks22 oldOffset newOffset+   where +      (toks1, toks21, toks22) = splitToks (startPos, endPos) toks+++{- Delete an syntax phrase from the token stream, this function (instead of the following one)+   should be the interface function for deleting tokens.+-}          +-- deleteFromToks::( (MonadState (([PosToken], Bool), t1) m), StartEndLoc t,Printable t,Term t)=>t->m ()+deleteFromToks t getLocFun+   =do ((toks,_),others)<-get+       let (startPos,endPos)=getLocFun toks t+           toks'=deleteToks toks startPos endPos+       put ((toks',modified),others)++{-Delete a sequence of tokens specified by the start position and end position from the token stream,+  then adjust the remaining token stream to preserve layout-}+deleteToks::[PosToken]->SimpPos->SimpPos->[PosToken]+deleteToks toks startPos@(startRow, startCol) endPos@(endRow, endCol)+  = case after of +      (_:_) ->    let nextPos =tokenPos $ ghead "deleteToks1" after +                      oldOffset = getOffset toks nextPos+                      newOffset = getOffset (toks1++before++after) nextPos +                  in  toks1++before++adjustLayout (after++toks22) oldOffset newOffset +      _     -> if toks22 == [] +                 then toks1++before+                 else let toks22'=let nextOffset = getOffset toks (tokenPos (ghead "deleteToks2" toks22)) +                                  in if isMultiLineComment (lastNonSpaceToken toks21)   +                                       then whiteSpaceTokens (-1111, 0) (nextOffset-1) ++ toks22+                                       else toks22+                      in if endsWithNewLn (last (toks1++before)) || startsWithNewLn (ghead "deleteToks3" toks22')+                           then  toks1++before++toks22'+                           --avoiding layout adjustment by adding a `\n', sometimes may produce extra lines.+                             else  toks1++before++[newLnToken]++toks22'+                            --  else toks1 ++ before ++ toks22'+     where +      +      (toks1, toks2) = let (ts1, ts2)   = break (\t->tokenPos t == startPos) toks+                           (ts11, ts12) = break hasNewLn (reverse ts1)+                       in (reverse ts12, reverse ts11 ++ ts2)+      (toks21, toks22)=let (ts1, ts2) = break (\t -> tokenPos t == endPos) toks2+                           (ts11, ts12) = break hasNewLn ts2+                       in (ts1++ts11++if ts12==[] then [] else [ghead "deleteToks4" ts12], if ts12==[] then [] else gtail "deleteToks5"  ts12)  ++      -- tokens before the tokens to be deleted at the same line+      before = takeWhile (\t->tokenPos t/=startPos) toks21 ++      -- tokens after the tokens to be deleted at the same line.+      after = let t= dropWhile (\t->tokenPos t /=endPos) toks21+              in  if t == [] then error "Sorry, HaRe failed to finish this refactoring."+                             else  gtail "deleteToks6" t+                  +  +-- Adjust the layout to compensate the change in the token stream.+adjustLayout::[PosToken]->Int->Int->[PosToken]+adjustLayout [] _ _ = []+adjustLayout toks oldOffset newOffset + | oldOffset == newOffset  = toks++adjustLayout toks oldOffset newOffset+  = case layoutRuleApplies of+    True -> let (ts:ts') = groupTokensByLine  toks+            in ts ++ addRmSpaces (newOffset-oldOffset) oldOffset  ts'  -- THIS IS PROBLEMETIC. +    _    -> toks  +  where + +  layoutRuleApplies  +    = let ts = dropWhile (\t-> (not.elem (tokenCon t)) keyWords) +               $ filter notWhite+               $ takeWhile (not.hasNewLn) toks +      in case ts of+         (_: t: _) -> tokenCon t /= "{" +         _         -> False          ++  keyWords = ["where","let","do","of"] ++  addRmSpaces n col [] = []+  addRmSpaces n col toks@(ts:ts')+    =case find notWhite ts of+      Just t  -> if length (concatMap tokenCon ts1) >= col +                 then (addRmSpaces' n ts) ++ addRmSpaces n col ts' +                 else concat toks +      _       -> ts ++ addRmSpaces n col ts'+     where +      (ts1, ts2) = break notWhite ts++  addRmSpaces' 0 ts = ts+  addRmSpaces' _ [] = []+  addRmSpaces' n ts@(t:ts') +    = case n >0 of  +       True -> whiteSpaceTokens (tokenRow t,0) n ++ ts   -- CHECK THIS.+       _    -> if isWhiteSpace t +               then addRmSpaces' (n+1) ts'+               else error $ "Layout adjusting failed at line:"+                           ++ show (tokenRow t)++ "." ++-- remove at most n white space tokens from the beginning of ts+doRmWhites::Int->[PosToken]->[PosToken]+doRmWhites 0 ts=ts  +doRmWhites n []=[]+doRmWhites n toks@(t:ts)=if isWhiteSpace t then doRmWhites (n-1) ts+                                           else toks ++--add n white space tokens to the beginning of ts+doAddWhites::Int->[PosToken]->[PosToken]+doAddWhites n []=[]+doAddWhites n ts@(t:_)= whiteSpacesToken (tokenRow t,0) n ++ts++whiteSpaceTokens (row, col) n + = if n<=0 +    then [] +    else (mkToken Whitespace (row,col) " "):whiteSpaceTokens (row,col+1) (n-1)++-------------------------------------------------------------------------------------------------+--get all the source locations (use locations) in an AST phrase t in according the the occurrence order of identifiers.+srcLocs::(Term t)=> t->[SimpPos]+srcLocs t =(nub.srcLocs') t \\ [simpPos0]+   where srcLocs'=runIdentity.(applyTU (full_tdTU (constTU []+                                                  `adhocTU` pnt  +                                                  `adhocTU` sn+                                                  `adhocTU` literalInExp+                                                  `adhocTU` literalInPat)))+        +         pnt (PNT pname _ (N (Just (SrcLoc _  _ row col))))=return [(row,col)]                +         pnt _=return []+          +         sn (SN (PlainModule modName) (SrcLoc _ _ row col)) +             = return [(row, col)]+         sn _ = return []  +                     +         literalInExp ((Exp (HsLit (SrcLoc _  _ row col) _))::HsExpP) = return [(row,col)]+         literalInExp (Exp _) =return []++         literalInPat ((Pat (HsPLit (SrcLoc _ _ row col) _))::HsPatP) = return [(row,col)]+         literalInPat (Pat (HsPNeg (SrcLoc _  _ row col) _)) = return [(row,col)]+         literalInPat _ =return []  ++  +class StartEndLocPat t where++   startEndLoc2 :: [PosToken]->t->[(SimpPos,SimpPos)]+   -- startEndLoc3 :: [PosToken]->t->[(SimpPos,SimpPos)] +   +   +instance StartEndLocPat [HsDeclP] where+   startEndLoc2 toks ds=if  ds==[] then [(simpPos0,simpPos0)]+                                   else if length ds==1 +                                         then [startEndLoc toks (ghead "StartEndLoc:[HsDeclP]" ds)]+                                         else concat (map (startEndLoc2 toks) ds)+++instance StartEndLocPat HsMatchP where+   startEndLoc2 toks (HsMatch loc i ps rhs ds)+         =let (startLoc,_)=startEndLoc toks i+              (_,endLoc)  =if ds==[] then startEndLoc toks rhs+                                     else startEndLoc toks (glast "StartEndLoc:HsMatchP" ds)+          in [(startLoc,endLoc)]+          +instance StartEndLocPat HsDeclP where++   startEndLoc2 toks (Dec (HsTypeDecl (SrcLoc _ _ r c) tp t))+      = let (startLoc, _) = startEndLoc toks tp+            (_ , endLoc)  = startEndLoc toks t+        in [extendForwards toks startLoc endLoc isType]++   startEndLoc2 toks (Dec (HsDataDecl loc c tp decls is))+        = let (startLoc, _) = startEndLoc toks tp+              (_, endLoc)  = if is == [] then startEndLoc toks (glast "StartEndLoc:HsDeclP1" decls)+                                        else startEndLoc toks is+          in [extendForwards toks startLoc endLoc isData]++   startEndLoc2 toks (Dec (HsNewTypeDecl loc c tp decls is))+        = let (startLoc, _) = startEndLoc toks tp+              (_, endLoc) = if is == [] then startEndLoc toks decls+                                        else startEndLoc toks is+          in [extendForwards toks startLoc endLoc isNewtype]++   startEndLoc2 toks (Dec (HsDefaultDecl _ ts))+      = let (startLoc, _) = startEndLoc toks (head ts)+            (_ , endLoc) = startEndLoc toks (last ts)+        in [extendForwards toks startLoc endLoc isDefault]  ++   startEndLoc2 toks (Dec (HsInfixDecl _ _ is))+      = let (startLoc, _) = startEndLoc toks (head is)+            (_, endLoc)   = startEndLoc toks (last is)+        in [extendForwards toks startLoc endLoc isFixty]++   startEndLoc2 toks d@(Dec (HsFunBind _ ms))+      = map (startEndLoc toks) ms++   startEndLoc2 toks (Dec (HsPatBind _  p rhs ds))+       = let (startLoc, _) = startEndLoc toks p+             (_, endLoc)   = if ds ==[] then startEndLoc toks rhs+                                        else startEndLoc toks (glast "startEndLoc:HsDeclP5" ds)+             toks1 = dropWhile (\t->tokenPos t /= endLoc) toks+	     endLoc1 = if toks1==[] +			  then endLoc +			  else let toks2 = takeWhile (\t -> isSpecialTok t) toks1+                               in (tokenPos.glast "startEndLoc::HsMatchP") toks2+          in [(startLoc, endLoc1)]+       where +         isSpecialTok t = isWhiteSpace t  || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t +                        || isCloseSquareBracket t ++   startEndLoc2 toks (Dec (HsTypeSig _ is c t))+      = let (startLoc, _) = startEndLoc toks (ghead "startEndLoc:HsDeclP6" is)+            (_, endLoc)   = startEndLoc toks t+        in [(startLoc, endLoc)]++              +   startEndLoc2 toks decl@(Dec (HsClassDecl loc c tp funDeps  ds))+      = let locs = srcLocs decl+            (startLoc, endLoc)+              = if locs == [] then (simpPos0, simpPos0)+                 else (head locs, last locs)                           +        in [extendForwards toks startLoc endLoc isClass]++   startEndLoc2 toks decl@(Dec (HsInstDecl loc i c t ds))+     = let locs = srcLocs decl+           (startLoc, endLoc)+              = if locs == [] then (simpPos0, simpPos0)+                 else (head locs, last locs)                           +        in [extendForwards toks startLoc endLoc isInstance]          +          ++getStartEndLoc2::(Term t, StartEndLocPat t,Printable t)=>[PosToken]->t->[(SimpPos,SimpPos)]+getStartEndLoc2 toks t +  = startEndLoc2 toks t+     {-   locs = srcLocs t +        (startPos,endPos) = (if startPos' == simpPos0 && locs /=[] then ghead "getStartEndLoc2" locs+                                                                   else startPos',+                             if endPos' == simpPos0 && locs /= [] then glast "gerStartEndLoc2" locs+                                                                  else endPos')+    in (startPos, endPos)  -}+  +  +         +--given an AST phrase, 'startEndLoc' gets its start and end position in the program source.+class StartEndLoc t where++   startEndLoc :: [PosToken]->t->(SimpPos,SimpPos)++instance StartEndLoc HsModuleP where+  startEndLoc toks _  = (tokenPos (ghead "startEndLoc:HsModuleP" toks), +                         tokenPos (glast "startEndLoc:HsModuleP" toks))++instance StartEndLoc HsExpP where+    +  startEndLoc  toks (Exp e)=+      case e of+  +        HsId ident@(HsVar (PNT pn _ _)) ->let (startLoc, endLoc) = startEndLoc toks ident+                                              {- To handle infix operator. for infix operators like (++), there+                                                  is no parenthesis in the syntax tree -}+                                              (toks1,toks2) = break (\t->tokenPos t==startLoc) toks+                                              toks1' = dropWhile isWhite (reverse toks1)+                                              toks2' = dropWhile isWhite (gtail "startEndLoc:HsExpP"+                                                          (dropWhile (\t->tokenPos t /=endLoc) toks2))+                                           in if toks1'/=[] && toks2'/=[] && isOpenBracket (head toks1')+                                                 && isCloseBracket (head toks2')+                                              then (tokenPos (head toks1'), tokenPos (head toks2'))+                                              else (startLoc, endLoc) +        HsId  x                       ->startEndLoc toks x+   +        HsLit (SrcLoc _ _ r c) _      -> ((r,c),(r,c))++        HsInfixApp e1 op e2           ->let (startLoc,_)=startEndLoc toks e1+                                            (_, endLoc) =startEndLoc toks e2+                                        in (startLoc,endLoc)++        e@(HsApp e1 e2)               ->let (startLoc,endLoc)=startEndLoc toks e1+                                            (startLoc1, endLoc1 )=startEndLoc toks e2+	                     +                                        in (startLoc, endLoc1)++        HsNegApp (SrcLoc _ _ r c) e     ->let (_,endLoc)=startEndLoc toks e+                                          in ((r,c), endLoc)++        HsLambda ps e                 ->let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsLambda" ps)  --ps can not be empty+                                            (_,endLoc)  =startEndLoc toks e+                                        in extendForwards toks startLoc endLoc isLambda++        HsIf e1 e2 e3                 ->let (startLoc, _)=startEndLoc toks e1+                                            (_, endLoc)=startEndLoc toks e3+                                        in extendForwards toks  startLoc endLoc isIf++        HsLet ds e                    ->if ds==[]+                                          then+                                            let  (startLoc,endLoc)=startEndLoc toks e+                                            in extendForwards toks startLoc endLoc isLet+                                          else+                                            let  (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsLet" ds) +                                                 (_,endLoc)  =startEndLoc toks e +                                            in extendForwards toks startLoc endLoc isLet++        HsCase e alts                 ->let (startLoc,_)=startEndLoc toks e+                                            (_,endLoc)  =startEndLoc toks (glast "HsCase" alts) --alts can not be empty.+                                        in extendForwards toks startLoc endLoc isCase+                        +        HsDo stmts                    ->let (startLoc, endLoc)=startEndLoc toks  stmts+                                        in extendForwards toks startLoc endLoc isDo++        HsTuple es                    ->if es==[] +                                         then  (simpPos0,simpPos0)  --Empty tuple can cause problem.+                                         else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsTuple" es)+                                                  (_,endLoc)  =startEndLoc toks (glast "startEndLoc:HsTuple" es)+                                              in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket  ++        HsList es                     ->if es==[] +                                         then (simpPos0,simpPos0)  --Empty list can cause problem.+                                         else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsList" es) +                                                  (_,endLoc)  =startEndLoc toks (glast "startEndLoc:HsList" es)+                                              in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket++        HsParen e                     ->let (startLoc,(endLocR, endLocC))=startEndLoc toks  e+                                        in extendBothSides toks startLoc (endLocR, endLocC) isOpenBracket isCloseBracket+									   +                                       --  in if expIsPNT e+--                                              then (startLoc, (endLocR, endLocC+1))+--                                              else extendBothSides toks startLoc (endLocR, endLocC) isOpenBracket isCloseBracket +--                                           where+--                                             expIsPNT (Exp (HsId (HsVar pnt)))=True+--                                             expIsPNT (Exp (HsParen e))=expIsPNT e  +--                                             expIsPNT _ =False++        HsLeftSection e op            ->let (startLoc,_)=startEndLoc toks e+                                            (_, endLoc )=startEndLoc toks op+                                        in (startLoc,endLoc)++        HsRightSection op e           ->let (startLoc,_)=startEndLoc toks op+                                            (_, endLoc )=startEndLoc toks op+                                        in (startLoc,endLoc)++        HsRecConstr loc i upds            ->let (startLoc,_)=startEndLoc toks i+                                                (_,endLoc)  =startEndLoc toks (glast "startEndLoc:HsRecConstr" upds) --can 'upds' be empty?+                                        in extendBackwards toks startLoc endLoc isCloseBrace +                                        +        HsRecUpdate loc e upds            ->let (startLoc,_)=startEndLoc toks e+                                                (_,endLoc)  =startEndLoc toks (glast "startEndLoc:HsRecUpdate" upds) --ditto+                                        in extendBackwards toks startLoc endLoc isCloseBrace ++        HsEnumFrom e                  ->let (startLoc,endLoc)=startEndLoc toks e+                                        in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket   ++        HsEnumFromTo e1 e2            ->let (startLoc,_)=startEndLoc toks e1+                                            (_,  endLoc)=startEndLoc toks e2+                                        in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket   ++        HsEnumFromThen e1 e2          ->let (startLoc,_)=startEndLoc toks e1+                                            (_,  endLoc)=startEndLoc toks e2+                                        in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket  +                                  +        HsEnumFromThenTo e1 e2 e3     ->let (startLoc,_)=startEndLoc toks e1+                                            (_,  endLoc)=startEndLoc toks e3+                                        in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket  +                                 +        HsListComp stmts              ->let (startLoc,endLoc)=startEndLoc toks stmts+                                        in  extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket     ++        HsAsPat i e                   ->let (startLoc,_)=startEndLoc toks i+                                            (_,endLoc)=  startEndLoc toks e+                                        in (startLoc,endLoc) ++        HsIrrPat e                    ->let (startLoc,endLoc)=startEndLoc toks e+                                        in extendForwards toks startLoc endLoc isIrrefute++        HsWildCard                    ->(simpPos0,simpPos0)  -- wildcard can cause problem.+  +        +        HsExpTypeSig loc e c t        ->let (startLoc,_)=startEndLoc toks e+                                            (_, endLoc )=startEndLoc toks t+                                        in (startLoc,endLoc)    ++instance StartEndLoc HsTypeP where++   startEndLoc toks (Typ p)=+      case p of +        HsTyFun  t1  t2       ->   let (startLoc,e)=startEndLoc toks t1+                                       (_ , endLoc)=startEndLoc toks t2+                                   in (startLoc,endLoc) +        --HsTyTuple [t]         ->++        HsTyApp  t1 t2        ->   let (startLoc,endLoc1)=startEndLoc toks  t1 +                                       (_ , endLoc)=startEndLoc toks  t2+                                   in (endLoc1, endLoc) -- (startLoc,if endLoc1>endLoc then endLoc1 else endLoc) -- (startLoc,endLoc)+        HsTyVar  i            ->   let (startLoc, endLoc) = startEndLoc toks i+                                   in  extendBothSides' toks startLoc endLoc isOpenBracket isCloseBracket+        HsTyCon  i            ->   let (startLoc, endLoc) = startEndLoc toks i +                                   in if (render.ppi) i =="[]" +                                        then extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket               +                                        else extendBothSides' toks startLoc endLoc isOpenBracket isCloseBracket ++        HsTyForall   is ts t   ->   case is of+                                     []  ->let (startLoc,endLoc)=startEndLoc toks t+                                           in  extendForwards toks startLoc endLoc isForall+   +                                     l  -> let (startLoc, _) =startEndLoc toks  $ ghead "StartEndLoc:HsTypeP" is+                                               ( _ , endLoc) =startEndLoc toks t+                                           in extendForwards toks startLoc endLoc isForall++extendBothSides'  toks startLoc endLoc  forwardCondFun backwardCondFun+       =let (toks1,toks2)=break (\t->tokenPos t==startLoc) toks+            toks21=dropWhile (\t->tokenPos t<=endLoc) toks2+            firstLoc=case (dropWhile isWhite (reverse toks1)) of +                             [] -> startLoc    -- is this the correct default?+                             ls  -> if (forwardCondFun.ghead "extendBothSides:lastTok") ls  then tokenPos (head ls)+                                      else startLoc+            lastLoc =case (dropWhile isWhite toks21) of+                            [] ->endLoc   --is this a correct default?+                            ls -> if (backwardCondFun.ghead "extendBothSides:lastTok") ls then tokenPos (head ls)+                                   else endLoc                   +        in (firstLoc, lastLoc)  ++instance StartEndLoc HsPatP where++  startEndLoc toks (Pat p)=+     case p of+       HsPId i                          ->startEndLoc toks i++       HsPLit (SrcLoc _ _ r c) _        ->((r,c),(r,c))++       HsPNeg (SrcLoc _ _  r c) p       ->((r,c),(r,c))+   +       HsPInfixApp p1 op p2             ->let (startLoc,_)=startEndLoc toks  p1+                                              (_ , endLoc)=startEndLoc toks p2+                                          in (startLoc,endLoc)++       HsPApp i ps                      ->let (startLoc,_)=startEndLoc toks  i+                                              (_,endLoc)=startEndLoc toks (glast "StartEndLoc:HsPatP" ps)+                                          in (startLoc,endLoc)++       HsPTuple loc ps                  -> if ps==[]+                                             then  (simpPos0,simpPos0)  -- ****Update this using locations****.+                                             else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsPTuple"  ps)+                                                      (_,endLoc)=startEndLoc toks (glast "startEndLoc:HsPTuple" ps)+                                                  in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket  ++       HsPList loc ps                     ->if ps==[] +                                            then (simpPos0,simpPos0)  -- ***Update this using locations*****+                                            else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsPList" ps)+                                                     (_, endLoc) =startEndLoc toks (glast "startEndLoc:HsPList" ps)+                                            in  extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket     +                                        +       HsPParen p                       ->let (startLoc,endLoc)=startEndLoc toks p+                                          in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket  + +       HsPRec i upds                    ->let (startLoc,_)=startEndLoc toks i+                                              (_,endLoc)=startEndLoc toks (glast "startEndLoc:HsPRec" upds) --can upds be empty?+                                          in extendBackwards toks startLoc endLoc isCloseBrace +                                         +       HsPAsPat i p                     ->let (startLoc,_)=startEndLoc toks i+                                              (_,endLoc)=startEndLoc toks p+                                          in (startLoc,endLoc)+ +       HsPIrrPat p                      ->let (startLoc,endLoc)=startEndLoc toks p+                                          in extendForwards toks startLoc endLoc isIrrefute+                                       +       HsPWildCard                       ->(simpPos0,simpPos0)  -- wildcard can  cause problem.++instance StartEndLoc [HsPatP] where++   startEndLoc toks ps = let locs=(nub.(map (startEndLoc toks))) ps \\ [(simpPos0,simpPos0)]+                         in if locs==[] then (simpPos0,simpPos0)+                                        else let (startLoc,_)=ghead "StartEndLoc:HsPatP" locs+                                                 (_,endLoc) =glast "StartEndLoc:HsPatP"  locs+                                             in (startLoc,endLoc)+instance StartEndLoc [HsExpP] where++   startEndLoc toks es=let locs=(nub.(map (startEndLoc toks))) es \\ [(simpPos0,simpPos0)]+                       in if locs==[] then (simpPos0,simpPos0)+                                      else let (startLoc,_)=ghead "StartEndLoc:HsExp" locs+                                               (_,endLoc) =glast "startEndLoc:HsExp" locs+                                           in (startLoc,endLoc)+instance StartEndLoc [HsDeclP] where+  startEndLoc toks ds=if  ds==[] then (simpPos0,simpPos0)+                                 else if length ds==1 +                                        then startEndLoc toks (ghead "StartEndLoc:[HsDeclP]" ds)+                                        else  let (startLoc,_)=startEndLoc toks (ghead "StartEndLoc:[HsDeclP]" ds)+                                                  (_,endLoc) =startEndLoc toks (glast  "StartEndLoc:[HsDeclP]" ds)+                                              in (startLoc,endLoc)++instance StartEndLoc HsMatchP where+   startEndLoc toks t@(HsMatch loc i ps rhs ds)+         =let (startLoc,_)=startEndLoc toks i+              (_,endLoc)  =if ds==[] then startEndLoc toks rhs+                                     else startEndLoc toks (glast "StartEndLoc:HsMatchP" ds)			  +              locs = srcLocs t +              (startLoc1,endLoc1) = (if startLoc == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs+                                                                   else startLoc,+				     if endLoc == simpPos0 && locs /= [] then glast "getStartEndLoc" locs+                                                                         else endLoc)			    +              toks1 = gtail "startEndLoc:HsMatchP" (dropWhile (\t->tokenPos t /= endLoc1) toks)+              toks0 = getToks (startLoc1, endLoc1) toks+	      endLoc2 = if toks1==[] +		 	  then endLoc1 +			  else let toks2 = takeWhile (\t -> isSpecialTok t && needmore toks t ) toks1+                               in if toks2 == [] || all (\t-> isWhiteSpace t ) toks2+				       then endLoc1 +                                       else (tokenPos.glast "startEndLoc::HsMatchP") toks2+              +          in (startLoc1, endLoc2) +        where +          isSpecialTok t = isWhiteSpace t  || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t +                          || isCloseSquareBracket t +          needmore toks t = case  isCloseBracket t of +                              True -> let openBrackets = length $ filter isOpenBracket toks+                                          closeBrackets = length $ filter isCloseBracket toks+                                      in closeBrackets < openBrackets+                              False -> case isCloseSquareBracket t of+                                       True -> let openSqBrackets = length $ filter isOpenSquareBracket toks+                                                   closeSqBrackets = length $ filter isCloseSquareBracket toks+                                               in closeSqBrackets < openSqBrackets+                                       false -> True+++instance StartEndLoc HsStmtP where      -- Bug fixed. 20/05/2004+   startEndLoc toks stmts=let s=getStmtList  stmts                           +                              locs = map (startEndLoc toks) s +                              (startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))+                          in (ghead "StartEndLoc::HsStmtP" startLocs, glast "StartEndLoc::HsStmtP" endLocs)+                              +instance StartEndLoc (HsStmtAtom HsExpP HsPatP [HsDeclP])  where++    startEndLoc toks stmt=+      case stmt of +           HsGeneratorAtom (SrcLoc _ _ r c) p e -> +                                  let (startLoc,_)=startEndLoc toks p+                                      (_,endLoc)  =startEndLoc toks e+                                  in (startLoc,endLoc)+           HsQualifierAtom e   -> startEndLoc toks e+           HsLetStmtAtom ds    -> if ds==[]+                                   then (simpPos0,simpPos0)+                                   else let (startLoc,_)= startEndLoc toks (ghead "StartEndLoc:HsStmtAtom" ds)+                                            (_,endLoc)  = startEndLoc toks (glast "StartEndLoc:HsStmtAtom" ds)+                                        in (startLoc,endLoc)+           HsLastAtom e        ->startEndLoc toks e++instance (StartEndLoc i,StartEndLoc e)=>StartEndLoc (HsFieldI i e) where+    startEndLoc toks (HsField i e)=let (startLoc,_)=startEndLoc toks i+                                       (_,endLoc)=startEndLoc toks e+                                   in (startLoc,endLoc) ++instance StartEndLoc HsAltP where   +    startEndLoc toks (HsAlt l p rhs ds)=let (startLoc,_)=startEndLoc toks p+                                            (_,endLoc)=if ds==[] then startEndLoc toks rhs+                                                                 else startEndLoc toks (glast "StartEndLoc:HsAltP" ds)+                                        in (startLoc,endLoc)++instance StartEndLoc RhsP where    +   startEndLoc toks (HsBody e)=startEndLoc toks e++   startEndLoc toks (HsGuard es)=if es==[] then (simpPos0,simpPos0)+                                           else let (_,e1,_)=ghead "StartEndLoc:RhsP" es+                                                    (_,_,e2)=glast "StartEndLoc:RhsP" es+                                                    (startLoc,_)=startEndLoc toks e1+                                                    (_,endLoc)=startEndLoc toks e2+                                                in extendForwards toks startLoc endLoc isBar ++instance StartEndLoc (HsIdentI PNT) where+    startEndLoc toks ident =+       case ident of+           HsVar i  ->startEndLoc toks i+           HsCon i  ->startEndLoc toks i++instance StartEndLoc [PNT] where+    startEndLoc toks pnts +       = if pnts==[] then (simpPos0, simpPos0)+           else let (startPos, _) = startEndLoc toks (head pnts)+                    (_,      endPos) = startEndLoc toks (last pnts)+                in (startPos, endPos)                           ++instance StartEndLoc (HsImportDeclI ModuleName PNT)  where+     startEndLoc toks (HsImportDecl (SrcLoc _ _ row col) modName qual  as Nothing)+        = let startPos=fst (startEndLoc toks modName)+              endPos = if isJust as then snd (startEndLoc toks (fromJust as))+                                    else snd (startEndLoc toks modName)+          in extendForwards toks startPos endPos isImport +                                        +     startEndLoc toks (HsImportDecl (SrcLoc _ _ row col) modName qual as (Just (_, ents)))+         = let startPos = fst (startEndLoc toks modName)+               endPos = if ents == [] then if isJust as then  snd (startEndLoc toks (fromJust as))+                                                        else  snd (startEndLoc toks modName)+                                      else snd (startEndLoc toks (glast "startEndLocImport" ents))+           in extendBothSides toks startPos endPos isImport isCloseBracket +++instance StartEndLoc  [HsExportSpecI ModuleName PNT] where+   startEndLoc toks es +     = if es == [] then (simpPos0, simpPos0)+                   else let (startLoc, _) = startEndLoc toks $ head es +                            (_, endLoc)   = startEndLoc toks $ last es+                        in (startLoc, endLoc)+                        -- in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket +++instance StartEndLoc (HsExportSpecI ModuleName PNT) where+     startEndLoc toks (EntE ent) =startEndLoc toks ent+    +     startEndLoc toks (ModuleE moduleName) = let (startPos, endPos) = startEndLoc toks moduleName+                                             in extendForwards toks startPos endPos isModule++    +              +instance StartEndLoc(EntSpec PNT) where+      startEndLoc toks (Var i)=startEndLoc toks i   --- x (a variable identifier)+ +      startEndLoc toks (Abs i) =startEndLoc toks i   -- T, C++      startEndLoc toks (AllSubs i) =let (startPos, endPos) =startEndLoc toks i -- T(..), C(..)+                                    in extendBackwards toks startPos endPos isCloseBracket+      startEndLoc toks (ListSubs i ents)= let (startPos, _) = startEndLoc toks i --T (C_1, ...,C_n, f1,...f_n)+                                              (_, endPos)   = startEndLoc toks (glast "startEnPosListSubs" ents)+                                          in extendBackwards toks startPos endPos isCloseBracket+                                        +instance StartEndLoc ModuleName where+   startEndLoc toks (SN modName (SrcLoc _ _ row col)) = ((row,col), (row,col))++instance StartEndLoc [EntSpec PNT] where+      startEndLoc toks ents +        = if ents==[] then (simpPos0,simpPos0)+                      else let (startPos, _)=startEndLoc toks $ head ents+                               (_,  endPos) =startEndLoc toks $ last ents +                           in (startPos,endPos)+                --         in extendBothSides toks startPos endPos isHiding isCloseBracket++instance StartEndLoc PNT where    +     startEndLoc toks pnt =+        case pnt of +          PNT pn  _ (N (Just (SrcLoc _ _ row col)))->((row,col),(row,col))+          _                                        ->(simpPos0,simpPos0)  {-Shouldn't cause any problems here, as in a normal+                                                                            AST, every PNT has a source location. -}+++instance (Eq i, Eq t, StartEndLoc i, StartEndLoc t,StartEndLoc [i]) =>StartEndLoc (HsConDeclI i t c) where+   startEndLoc toks (HsConDecl _ is c i ds) +      = let (startLoc, _) = startEndLoc toks is+            (_, endLoc)   = if ds==[] then startEndLoc toks i +                                      else startEndLoc toks (last ds)+        in (startLoc, endLoc)+   +   startEndLoc toks (HsRecDecl _ is c i ds) +      = let (startLoc, _) = startEndLoc toks is+            (_, endLoc)   = if ds==[] then startEndLoc toks i +                                      else startEndLoc toks (last ds)+        in (startLoc, endLoc)+ +instance (StartEndLoc t)=>StartEndLoc (HsBangType t) where+   startEndLoc toks (HsBangedType t) = startEndLoc toks t++   startEndLoc toks (HsUnBangedType t) = startEndLoc toks t++instance (StartEndLoc t, StartEndLoc [i]) => StartEndLoc ([i], HsBangType t) where+   +   startEndLoc toks (x,y)+     = let (startLoc, endLoc) = startEndLoc toks y+         in  extendBackwards toks startLoc endLoc isCloseBrace+   +++instance StartEndLoc HsDeclP where++   startEndLoc toks (Dec (HsTypeDecl (SrcLoc _ _ r c) tp t))+      = let (startLoc, _) = startEndLoc toks tp+            (_ , endLoc)  = startEndLoc toks t+        in extendForwards toks startLoc endLoc isType++   startEndLoc toks (Dec (HsDataDecl loc c tp decls is))+        = let (startLoc, _) = startEndLoc toks tp+              (_, endLoc)  = if is == [] then startEndLoc toks (glast "StartEndLoc:HsDeclP1" decls)+                                        else startEndLoc toks is+          in extendForwards toks startLoc endLoc isData++   startEndLoc toks (Dec (HsNewTypeDecl loc c tp decls is))+        = let (startLoc, _) = startEndLoc toks tp+              (_, endLoc) = if is == [] then startEndLoc toks decls+                                        else startEndLoc toks is+          in extendForwards toks startLoc endLoc isNewtype++   startEndLoc toks (Dec (HsDefaultDecl _ ts))+      = let (startLoc, _) = startEndLoc toks (head ts)+            (_ , endLoc) = startEndLoc toks (last ts)+        in extendForwards toks startLoc endLoc isDefault  ++   startEndLoc toks (Dec (HsInfixDecl _ _ is))+      = let (startLoc, _) = startEndLoc toks (head is)+            (_, endLoc)   = startEndLoc toks (last is)+        in extendForwards toks startLoc endLoc isFixty++   startEndLoc toks d@(Dec (HsFunBind _ ms))+      = let (startLoc, _) = startEndLoc toks (ghead "startEndLoc:HsDeclP3" ms)+            (_,   endLoc) = if ms == [] then (simpPos0, simpPos0) +                                        else startEndLoc toks (glast "startEndLoc:HsDeclP4" ms)+        in (startLoc, endLoc)+   startEndLoc toks t@(Dec (HsPatBind _  p rhs ds))+       = let (startLoc, _) = startEndLoc toks p+             (_, endLoc)   = if ds ==[] then startEndLoc toks rhs+                                        else startEndLoc toks (glast "startEndLoc:HsDeclP5" ds)+	     locs = srcLocs t +             (startLoc1,endLoc1) = (if startLoc == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs+                                                                   else startLoc,+				    if endLoc == simpPos0 && locs /= [] then glast "getStartEndLoc" locs+                                                                         else endLoc)			    +             toks1 = gtail "startEndLoc:HsPatBind" (dropWhile (\t->tokenPos t /= endLoc1) toks)+	     endLoc2 = if toks1==[] +		       then endLoc1 +                       else let toks2 = takeWhile (\t -> isSpecialTok t && needmore toks t) toks1+                            in if toks2 == [] || all (\t-> isWhiteSpace t) toks2+			       then endLoc1 +                               else (tokenPos.glast "startEndLoc::HsMatchP") toks2+	 in (startLoc1, endLoc2)+    where +        isSpecialTok t = isWhiteSpace t  || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t +                      || isCloseSquareBracket t +        needmore toks t = case  isCloseBracket t of +                            True -> let openBrackets = length $ filter isOpenBracket toks+                                        closeBrackets = length $ filter isCloseBracket toks+                                    in  closeBrackets < openBrackets+                            False -> case isCloseSquareBracket t of+                                      True -> let openSqBrackets = length $ filter isOpenSquareBracket toks+                                                  closeSqBrackets = length $ filter isCloseSquareBracket toks+                                              in  closeSqBrackets < openSqBrackets+                                      False -> True++  +++   startEndLoc toks (Dec (HsTypeSig _ is c t))+      = let (startLoc, _) = startEndLoc toks (ghead "startEndLoc:HsDeclP6" is)+            (_, endLoc)   = startEndLoc toks t+        in (startLoc, endLoc)+              +   startEndLoc toks decl@(Dec (HsClassDecl loc c tp funDeps  ds))+      = let locs = srcLocs decl+            (startLoc, endLoc)+              = if locs == [] then (simpPos0, simpPos0)+                 else (head locs, last locs)                           +        in extendForwards toks startLoc endLoc isClass++   startEndLoc toks decl@(Dec (HsInstDecl loc i c t ds))+     = let locs = srcLocs decl+           (startLoc, endLoc)+              = if locs == [] then (simpPos0, simpPos0)+                 else (head locs, last locs)                           +        in extendForwards toks startLoc endLoc isInstance++  +{-+   startEndLoc toks (Dec (HsPrimitiveTypeDecl _ c tp))+     = let (startLoc, endLoc) = startEndLoc toks tp+       in extendForward toks startLoc endLoc isData   +          ++   startEndLoc toks (Dec (HsPrimitiveBind _ i t)) +     = let (startLoc, _) = startEndLoc toks i+           (_, endLoc)   = stratEndLoc toks t+       in  extendForward toks startLoc endLoc isPrimitive+-}++---------------End of the class StartEndLoc----------------------------------------+--------------------------------------------------------------------------------------------------------+-- This function should be the interface function for fetching start and end locations of a AST phrase in the source.+getStartEndLoc::(Term t, StartEndLoc t,Printable t)=>[PosToken]->t->(SimpPos,SimpPos)+getStartEndLoc toks t +  = let (startPos',endPos') = startEndLoc toks t+        locs = srcLocs t +        (startPos,endPos) = (if startPos' == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs+                                                                   else startPos',+                             if endPos' == simpPos0 && locs /= [] then glast "getStartEndLoc" locs+                                                                  else endPos')+    in (startPos, endPos)++ {- THECK : myppi.+      adjustLoc toks (startPos,endPos) t  -- to handle syntax phrase starts/ends with [], () ...+    where  +      adjustLoc toks (startPos,endPos) t+         = let astToks = filter (not.unwantedTok) $ tokenise  (Pos 0 0 1) 1 True $ (render.myppi) t +               (toks1,toks2, toks3) = splitToks (startPos, endPos) toks+               toks2' = filter (not.unwantedTok) toks2               +               (t1, t2) =(ghead "getStartEndLoc1" astToks, glast "getStartEndLoc2" astToks)+               startPos'= if sameToks t1 (ghead "getStartEndLoc3" toks2')+                           then startPos+                           else tokenPos $ ghead "getStartEndLoc4" $ dropWhile (\t-> not (sameToks t t1)) (reverse toks1)+               endPos'  = if sameToks t2 (glast "getStartEndLoc2" toks2')+                           then endPos+                           else tokenPos $ ghead "getStartEndLoc5" $ dropWhile (\t-> not (sameToks t t2)) toks3 +           in (startPos', endPos')++      unwantedTok t = isWhite t  || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t +                      || isCloseSquareBracket t || isComma t ++      sameToks (t1, (l1, c1)) (t2, (l2, c2)) = t1 == t2 && c1 == c2+ -}++-- this function has problems whegtn they encounter sth. like [.....[p]]/+extendBothSides  toks startLoc endLoc  forwardCondFun backwardCondFun+       =let (toks1,toks2)=break (\t->tokenPos t==startLoc) toks+            toks21=gtail ("extendBothSides" ++ (show (startLoc, endLoc, toks2))  ) $ dropWhile (\t->tokenPos t /=endLoc) toks2+            firstLoc=case (dropWhile (not.forwardCondFun) (reverse toks1)) of +                             [] -> startLoc    -- is this the correct default?+                             l  -> (tokenPos.ghead "extendBothSides:lastTok") l  +            lastLoc =case (dropWhile (not.backwardCondFun) toks21) of+                            [] ->endLoc   --is this a correct default?+                            l -> (tokenPos.ghead "extendBothSides:lastTok") l                    +        in (firstLoc, lastLoc)   ++extendForwards toks startLoc endLoc forwardCondFun+       =let toks1=takeWhile (\t->tokenPos t /= startLoc) toks          +            firstLoc=case (dropWhile (not.forwardCondFun) (reverse toks1)) of+                       [] ->startLoc  -- is this the correct default?+                       l -> (tokenPos.ghead "extendForwards") l+        in (firstLoc, endLoc)++extendBackwards toks startLoc endLoc backwardCondFun+       = let toks1= gtail "extendBackwards"  $ dropWhile (\t->tokenPos t /=endLoc) toks+             lastLoc=case (dropWhile (not.backwardCondFun) toks1) of+                          [] ->endLoc -- is this the correct default?+                          l ->(tokenPos. ghead "extendBackwards") l+         in (startLoc, lastLoc)     +                                   +------------------Some functions for associating comments with syntax phrases.---------------------------+{- Note: We assume that a comment before t belongs to t only if there is at most one blank line between them, +         and a cooment after t belongs to t only it the comment starts at the last line of t.+-}++{-Get the start&end location of syntax phrase t, then extend the end location to cover the comment/white spaces+  or new line which starts in the same line as the end location-}+startEndLocIncFowComment::(Term t, Printable t,StartEndLoc t)=>[PosToken]->t->(SimpPos,SimpPos)+startEndLocIncFowComment toks t+       =let (startLoc,endLoc)=getStartEndLoc toks t+            toks1= gtail "startEndLocIncFowComment"  $ dropWhile (\t->tokenPos t/=endLoc) toks+            toks11 = let (ts1, ts2) = break hasNewLn toks1+                     in (ts1 ++ if ts2==[] then [] else [ghead "startEndLocInFowComment" ts2])+         in  if toks11/=[] && all (\t->isWhite t || endsWithNewLn t) toks11 +             then (startLoc, tokenPos (glast "startEndLocIncFowComment" toks11))+             else (startLoc, endLoc) +++{-get the start&end location of t in the token stream, then extend the end location to cover+  the following '\n' if there is no other characters (except white space) between t and the '\n'+-}+startEndLocIncFowNewLn::(Term t, Printable t,StartEndLoc t)=>[PosToken]->t->(SimpPos,SimpPos)+startEndLocIncFowNewLn toks t+  =let (startLoc,endLoc)=getStartEndLoc toks t+       toks1 = dropWhile isWhiteSpace $ gtail "startEndLocIncFowNewLn"  $ dropWhile (\t->tokenPos t /=endLoc) toks+       nextTok= if toks1==[] then defaultToken else head toks1+   in if isNewLn nextTok  +        then (startLoc, tokenPos nextTok)+        else (startLoc, endLoc)+ +{-get the start&end loation of t in the token stream, then extend the start and end location to+  cover the preceding and folllowing comments. +-}+startEndLocIncComments::(Term t, StartEndLoc t,Printable t)=>[PosToken]->t->(SimpPos,SimpPos)+startEndLocIncComments toks t+  =let (startLoc,endLoc)=getStartEndLoc toks t +       (toks11,toks12)= let (ts1,ts2) = break (\t->tokenPos t == startLoc) toks+                            (ts11, ts12) = break hasNewLn (reverse ts1)+                        in (reverse ts12, reverse ts11++ts2)+       toks12'=takeWhile (\t->tokenPos t /=startLoc) toks12+       startLoc'=+         if all isWhite  toks12'  +           then  -- group the toks1 according to lines in a reverse order.+                 let  groupedToks=reverse $ groupTokensByLine toks11+                      -- empty lines right before t+                      emptyLns=takeWhile (all (\t->isWhiteSpace t || isNewLn t )) groupedToks             +                      lastComment=if length emptyLns <=1  -- get the comment if there is any+                                    then takeWhile (all isWhite) $ takeWhile (any isComment) $ dropWhile +                                               (all (\t->isWhiteSpace t || isNewLn t)) groupedToks    +                                    else [] -- no comment +                      toks1'=if lastComment /=[] then concat $ reverse (emptyLns ++ lastComment)+                                                 else []+                 in if toks1'==[]+                       then if toks12'/=[] +                              then (tokenPos (ghead "startEndLocIncComments"  toks12'))  --there is no comment before t+                              else startLoc +                       --there is a comment before t+                       else tokenPos (ghead "startEndLocIncComments"  toks1') +           else startLoc          +       -- tokens after t+       toks2=gtail "startEndLocIncComments1"  $ dropWhile (\t->tokenPos t/=endLoc) toks+       -- toks21 are those tokens that are in the same line with the last line of t +       (toks21,tok22)= let (ts11, ts12) = break hasNewLn toks2+                       in (ts11 ++ if ts12==[] then [] else [ghead "startEndLocIncComments" ts12],+                                                             gtail "startEndLocIncComments2" ts12)+    in if toks21==[] then (startLoc',endLoc)  -- no following comments.+        else if all (\t->isWhite t || endsWithNewLn t) toks21 --get the following white tokens in the same+                                                              --line of the last token of t+               then (startLoc', tokenPos (last toks21))+               else (startLoc', endLoc)  ++--Create a list of white space tokens.+whiteSpacesToken::SimpPos->Int->[PosToken]+whiteSpacesToken (row,col) n+  |n>0        = [(Whitespace,(Pos 0 row col,replicate n ' '))]+  |otherwise  = []++-------------------------------------------------------------------------------------------------++adjustOffset::Int->[PosToken]->Bool->[PosToken]           +adjustOffset offset [] _ = []  +adjustOffset offset toks firstLineIncluded  +     = let groupedToks = groupBy (\x y->tokenRow x==tokenRow y) toks  --groupedToks/=[], no problem with 'head'+           --if firstLineIncluded is False, the offset of the first line won't be ajusted.+       in if offset>=0 then if firstLineIncluded +                               then concatMap (doAddWhites offset) groupedToks+                               else ghead "adjustOffset" groupedToks ++ concatMap (doAddWhites offset) (tail groupedToks)+                       else if firstLineIncluded +                               then concatMap (doRmWhites  (-offset)) groupedToks+                               else ghead "adjustOffset" groupedToks ++ concatMap (doRmWhites  (-offset)) (tail groupedToks) 
+ refactorer/RefacLocUtils.hs view
@@ -0,0 +1,1334 @@+++module RefacLocUtils(module HsTokens,PosToken, simpPos, +                     SimpPos,unmodified,modified,simpPos0,ghead,glast,gfromJust,gtail,++                     tokenCol, tokenRow, tokenPos,tokenCon,tokenLen,lengthOfToks,+                     mkToken,defaultToken,newLnToken,whiteSpacesToken,whiteSpaceTokens,isWhite,+                     notWhite,isWhiteSpace,isNewLn,isCommentStart,isComment,+                     isNestedComment,isMultiLineComment,isOpenBracket,isCloseBracket,+                     isOpenSquareBracket,isCloseSquareBracket,isOpenBrace,isConid,+                     isLit,isWhereOrLet,isWhere,isLet,isIn,isCase,isDo,isIf,isForall,+                     isHiding,isModule,isComma,isEqual,isLambda,isIrrefute,isBar,isMinus,+                     endsWithNewLn,startsWithNewLn,hasNewLn,startsWithEmptyLn, +                     lastNonSpaceToken,firstNonSpaceToken,compressPreNewLns,compressEndNewLns,+                     lengthOfLastLine,+                     updateToks,+                     getToks,replaceToks,deleteToks, doRmWhites,doAddWhites,+                     srcLocs, getStartEndLoc, getStartEndLoc2,+                     startEndLoc,extendBothSides,extendForwards,extendBackwards,+                     startEndLocIncFowComment,startEndLocIncFowNewLn,startEndLocIncComments,+                     prettyprint ,deleteFromToks, prettyprintGuardsAlt,+                     addFormalParams,  adjustOffset, -- try to remove it +                     StartEndLoc, isArrow,-- swapInToks,+                     commentToks,tokenise, prettyprintPatList,groupTokensByLine, addLocInfo, getOffset, splitToks, insertComments,+                     extractComments, insertTerms+  ) where++import RefacTypeSyn(SimpPos)+import PosSyntax+import UniqueNames +import HsLexerPass1 hiding (notWhite)+import HsTokens+import PrettySymbols(rarrow)+import HsLayoutPre (PosToken)+import PrettyPrint+import HsExpUtil+import PNT ++import RefacTypeSyn+import Maybe+import List+import SourceNames+-------------------------+--import DriftStructUtils  +import StrategyLib+------------------------+import Control.Monad.State++--In the token stream, locations are unique except the default locs.++{- Some related data types defined by Programatica's Lexer:+type Lexer = String -> LexerOutPut++type LexerOutput = [PosToken]++type PosToken = (Token,(Pos,String))++data Pos = Pos { char, line, column :: !Int } deriving (Show)+-- it seems that the field char is used to handle special characters including the '\t'++data Token+  = Varid | Conid | Varsym | Consym+  | Reservedid | Reservedop  | Specialid+  | IntLit | FloatLit | CharLit | StringLit+  | Qvarid | Qconid | Qvarsym | Qconsym+  | Special | Whitespace+  | NestedCommentStart -- will cause a call to an external function+  | NestedComment  -- from the external function+  | Commentstart  -- dashes+  | Comment -- what follows the dashes+  | ErrorToken | GotEOF | TheRest+  | ModuleName | ModuleAlias -- recognized in a later pass+  -- Inserted during layout processing (see Haskell 98, 9.3):+  | Layout     -- for implicit braces+  | Indent Int -- <n>, to preceed first token on each line+  | Open Int   -- {n}, after let, where, do or of, if not followed by a "{"+  deriving (Show,Eq,Ord)+-}++--A flag used to indicate whether the token stream has been modified or not.+unmodified = False+modified   = True++--- some default values----+pos0=Pos 0 0 0+simpPos0 = (0,0)++extractComments :: (SimpPos, SimpPos) -> [PosToken] -> [PosToken]+extractComments ((startPosl, startPosr), endPos) toks+   = let (toks1, toks21, toks22) = splitToks ((startPosl, startPosr), endPos) toks+      in toks1++------------------------------------------------+ghead info []    = error $ "ghead "++info++" []"+ghead ingp (h:_) = h++glast info []    = error $ "glast " ++ info ++ " []"+glast info h     = last h++gtail info []   = error $ "gtail " ++ info ++ " []"+gtail info h    = tail h++gfromJust info (Just h) = h+gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing"++--Some functions for fetching a specific field of a token+tokenCol (_,(Pos _ _ c,_)) = c  ++tokenRow (_,(Pos _ r _,_)) = r++tokenPos (_,(p,_))     = simpPos p++tokenCon (_,(_,s))     = s++tokenLen (_,(_,s))     = length s   --check this again! need to handle the tab key.++lengthOfToks::[PosToken]->Int+lengthOfToks=length.(concatMap tokenCon)++--Some functions for checking whether a token is of a specific type of token.+isWhite (t,_)                = t==Whitespace || t==Commentstart || t==Comment || t==NestedComment+notWhite  = not.isWhite++isWhiteSpace (t,(_,s))       = t==Whitespace && s==" "+isNewLn (t,(_,s))            = t==Whitespace && s=="\n"++isCommentStart (t,(_,s))     = t==Commentstart && s=="--" +isComment (t,(_,s))          = t==Comment || t ==NestedComment+isNestedComment (t,(_,s))    = t==NestedComment+isMultiLineComment (t,(_,s)) = t==NestedComment && (isJust (find (=='\n') s))++isOpenBracket  (t,(_,s))       = t==Special && s=="("+isCloseBracket (t,(_,s))       = t==Special && s==")"++isOpenSquareBracket  (t,(_,s)) = t==Special && s=="[" +isCloseSquareBracket (t,(_,s)) = t==Special && s=="]"++isOpenBrace  (t,(_,s))         = t==Special && s=="{" +isCloseBrace (t,(_,s))         = t==Special && s=="}" ++isConid (t,(_,_))              = t==Conid+isLit (t,(_,s)) = t==IntLit || t==FloatLit || t==CharLit || t==StringLit++isWhereOrLet  t   = isWhere t || isLet t+isWhere (t,(_,s)) = t==Reservedid && s=="where"+isLet   (t,(_,s)) = t==Reservedid && s=="let"+isImport (t, (_,s))= t == Reservedid && s=="import"+isType (t, (_,s))= t  == Reservedid && s=="type"+isData (t, (_,s))= t == Reservedid && s=="data"+isFixty (t, (_,s)) = t==Reservedid && (s=="infix" || s=="infixl" || s=="infixr")+isDefault (t, (_,s)) = t == Reservedid && s=="default"+isClass (t, (_,s)) = t == Reservedid && s=="class"+isInstance (t, (_,s)) = t == Reservedid && s=="instance"+isNewtype (t, (_,s)) = t == Reservedid && s=="newtype"++isIn    (t,(_,s))  = t==Reservedid && s=="in" +isCase  (t,(_,s))  = t==Reservedid && s=="case"  +isDo    (t,(_,s))  = t==Reservedid && s=="do"  +isIf    (t,(_,s))  = t==Reservedid && s=="if"+isForall (t,(_,s)) = t==Reservedid && s=="forall"+isHiding (t,(_,s)) = s=="hiding" +isModule (t,(_,s)) = t==Reservedid && s=="module"+  +isComma (t,(_,s))    = t==Special && s=="," +isEqual  (t,(_,s))   = t==Reservedop && s=="="+isLambda (t,(_,s))   = t==Reservedop && s=="\\"+isIrrefute (t,(_,s)) = t==Reservedop && s=="~"+isBar   (t,(_,s))    = t==Reservedop && s=="|"+isArrow (t,(_,s))    = t==Reservedop && s=="->"+isMinus (t,(_,s))    = t==Varsym && s=="-"++-----------------------------------------------------------------++--Returns True if the token ends with '\n'+endsWithNewLn::PosToken->Bool+endsWithNewLn   (_,(_,s)) =if s==[] then False +                                    else (glast "endsWithNewLn"  s=='\n')+ +--Returns True if the token starts with `\n`.+startsWithNewLn::PosToken->Bool+startsWithNewLn (_,(_,s)) =if s==[] then False +                                    else ((ghead "starsWithNewLn" s)=='\n')++--Returns True if there is a '\n' in the token.+hasNewLn::PosToken->Bool+hasNewLn (_,(_,s))=isJust (find (=='\n') s) {-different from isNewLn -}+++--Returns True if a token stream starts with a newline token (apart from the white spaces tokens)+startsWithEmptyLn::[PosToken]->Bool+startsWithEmptyLn toks=isJust (find isNewLn $ takeWhile (\t->isWhiteSpace t || isNewLn t) toks)++-- get the last non-space token in a token stream.+lastNonSpaceToken::[PosToken]->PosToken+lastNonSpaceToken toks=case dropWhile isWhiteSpace (reverse toks) of+                         [] ->defaultToken+                         l -> ghead "lastNonSpaceToken" l++--get the first non-space token in a token stream.+firstNonSpaceToken::[PosToken]->PosToken+firstNonSpaceToken toks=case dropWhile isWhiteSpace toks of+                         [] ->defaultToken+                         l -> ghead "firstNonSpaceToken" l  ++-- remove the extra preceding  empty lines.+compressPreNewLns::[PosToken]->[PosToken]+compressPreNewLns toks= let (toks1, toks2) = break (not.(\t->isNewLn t || isWhiteSpace t)) toks+                            groupedToks    = groupTokensByLine toks1+                        in if length groupedToks>1 then (last groupedToks)++toks2  +                                                   else toks++--remove the following extra empty lines.+compressEndNewLns::[PosToken]->[PosToken]+compressEndNewLns toks=let (toks1, toks2) = break (not.(\t->isNewLn t || isWhiteSpace t)) (reverse toks)+                           groupedToks    = groupTokensByLine toks1+                       in if length groupedToks>1 then reverse ((ghead "compressEndNewLns" groupedToks)++toks2) +                                                  else toks++prettyprintPatList beginWithSpace t +     = replaceTabBySpaces $ if beginWithSpace then format1 t else format2 t+ where +   format1 t = foldl (\x y -> x++ " "++(render.ppi) y) "" t++   format2 [] = "" +   format2 [p] = (render.ppi) p+   format2 (p:ps) = (render.ppi) p ++" " ++ format2 ps+               +prettyprint = replaceTabBySpaces.render.ppi++prettyprintGuardsAlt = replaceTabBySpaces.render.(ppRhs rarrow)+++--Replace Tab by white spaces. (1 Tab=8 white spaces)+replaceTabBySpaces::String->String+replaceTabBySpaces []=[]+replaceTabBySpaces (s:ss)+  =if s=='\t' then replicate 8 ' ' ++replaceTabBySpaces ss+              else s:replaceTabBySpaces ss+++--Compose a new token using the given arguments.+mkToken::Token->SimpPos->String->PosToken+mkToken t (row,col) c=(t,(Pos 0 row col,c))++---Restriction: the refactorer should not modify refactorer-modified/created tokens.+defaultToken = (Whitespace, (pos0," "))      +newLnToken   = (Whitespace, (pos0,"\n"))  +++tokenise  startPos _ _ [] = []+tokenise  startPos colOffset withFirstLineIndent str +  = let str' = case lines str of +                    (ln:[]) -> addIndent ln ++ if glast "tokenise" str=='\n' then "\n" else ""+                    (ln:lns)-> addIndent ln ++ "\n" ++ concatMap (\n->replicate colOffset ' '++n++"\n") lns+        str'' = if glast "tokenise" str' == '\n' && glast "tokenise" str /='\n'+                  then genericTake (length str' -1) str'+                  else str' +    in expandNewLnTokens $ lexerPass0' startPos str''+   where +     addIndent ln = if withFirstLineIndent +                      then replicate colOffset ' '++ ln+                      else ln         +     --preprocssing the token stream to expand the white spaces to individual tokens.+     expandNewLnTokens::[PosToken]->[PosToken]+     expandNewLnTokens ts = concatMap expand ts+       where+        expand tok@(Whitespace,(pos,s)) = doExpanding pos s                +        expand x = [x]++        doExpanding pos [] =[]+        doExpanding pos@(Pos c row col) (t:ts)+          = case t of +             '\n'  -> (Whitespace, (pos,[t])):(doExpanding (Pos c (row+1) 1) ts)+             _     -> (Whitespace, (pos,[t])):(doExpanding (Pos c row (col+1)) ts)+++--Should add cases for literals.+addLocInfo (decl, toks)+    = runStateT (applyTP (full_tdTP (idTP `adhocTP` inPnt +                                          `adhocTP` inSN)) decl) toks+       where+         inPnt (PNT pname ty (N (Just loc)))+            = do loc' <- findLoc (pNtoName pname)+                 return (PNT pname ty (N (Just loc')))+         inPnt x = return x++         inSN (SN (PlainModule modName) (SrcLoc _ _ row col)) +             = do loc' <- findLoc modName+                  return (SN (PlainModule modName) loc')+         inSN x = return x  + ++         pNtoName (PN (UnQual i) _)=i+         pNtoName (PN (Qual (PlainModule modName) i) _) = modName++"."++i+         pNtoName (PN (Qual (MainModule _) i) _)        = "Main."++i      +         findLoc name  +          = do  let name' = if name =="Prelude.[]" || name == "[]"  then "["+                               else if name=="Prelude.(,)" || name == "(,)" || name == "()"  then "(" +                                                                                             else name   ----Check this again. +                    toks' = dropWhile (\t->tokenCon t /= name') toks+                    (row, col) =if toks'==[] then error "HaRe: Error in addLocInfo!"  +                                              else tokenPos $ ghead "findLoc" toks' +                return (SrcLoc "unknown" 0 row col)+++groupTokensByLine [] = []+groupTokensByLine xs =let (xs', xs'') = break hasNewLn xs+                      in if xs''==[] then [xs']+                          else (xs'++ [ghead "groupTokensByLine" xs''])+                                : groupTokensByLine (gtail "groupTokensByLine" xs'')+                             +--Give a token stream covering multi-lines, calculate the length of the last line  +lengthOfLastLine::[PosToken]->Int+lengthOfLastLine toks+   = let (toks1,toks2)=break hasNewLn $ reverse toks+     in  if toks2==[] +          then sum (map tokenLen toks1)+          else sum (map tokenLen toks1)+lastLineLenOfToken (ghead "lengthOfLastLine"  toks2)+  where +   --Compute the length of a token, if the token covers multi-line, only count the last line.+   --What about tab keys?+   lastLineLenOfToken (_,(_,s))=(length.(takeWhile (\x->x/='\n')).reverse) s++++--get a token stream specified by the start and end position.+getToks::(SimpPos,SimpPos)->[PosToken]->[PosToken]+getToks (startPos,endPos) toks+    =let (_,toks2)=break (\t->tokenPos t==startPos) toks+         (toks21, toks22)=break (\t->tokenPos t==endPos) toks2+     in (toks21++ [ghead "getToks" toks22])   -- Should add error message for empty list?++-- Split the token stream into three parts: the tokens before the startPos,+-- the tokens between startPos and endPos, and the tokens after endPos.+splitToks::(SimpPos, SimpPos)->[PosToken]->([PosToken],[PosToken],[PosToken])+splitToks (startPos, endPos) toks+   = if (startPos, endPos) == (simpPos0, simpPos0)+       then error "Invalid token stream position!"+       else let startPos'= if startPos==simpPos0 then endPos else startPos+                endPos'  = if endPos == simpPos0 then startPos else endPos+                (toks1, toks2) = break (\t -> tokenPos t == startPos') toks+                (toks21, toks22) = break (\t -> tokenPos t== endPos') toks2+                -- Should add error message for empty list?+            in  if toks22==[] then error "Sorry, HaRe failed to finish this refactoring." -- (">" ++ (show (startPos, endPos) ++ show toks))+                  else (toks1, toks21++[ghead "splitToks" toks22], gtail "splitToks" toks22) +++getOffset toks pos+  = let (ts1, ts2) = break (\t->tokenPos t == pos) toks+    in if ts2==[] +         then error "HaRe error: position does not exist in the token stream!"+         else lengthOfLastLine ts1   ++--comment a token stream specified by the start and end position.+commentToks::(SimpPos,SimpPos)->[PosToken]->[PosToken]+commentToks (startPos,endPos) toks+    = let (toks1, toks21, toks22) = splitToks (startPos, endPos) toks+          toks21' = case toks21 of+                     []              -> toks21+                     (t,(l,s)):[]    -> (t, (l, ("{-" ++ s ++ "-}"))):[]+                     (t1,(l1,s1)):ts -> let lastTok@(t2, (l2, s2)) = glast "commentToks" ts+                                            lastTok' = (t2, (l2, (s2++" -}"))) +                                        in (t1,(l1, ("{- "++s1))): (reverse (lastTok': gtail "commentToks" (reverse ts)))+      in (toks1 ++ toks21' ++ toks22)+++insertTerms :: (SimpPos, SimpPos) -> [PosToken] -> String -> [PosToken]+insertTerms ((startPosl, startPosr), endPos) toks com+    = let (toks1, toks21, toks22) = splitToks ((startPosl, startPosr), endPos) toks+          toks21' = (Commentstart, ((Pos 0 startPosl startPosr) , "")) : [(Comment, ((Pos 0 startPosl startPosr), ("\n" ++ com ++ "\n")))]+      in (toks1 ++ toks21' ++ (toks21 ++ toks22))+++insertComments :: (SimpPos, SimpPos) -> [PosToken] -> String -> [PosToken]+insertComments ((startPosl, startPosr), endPos) toks com+    = let (toks1, toks21, toks22) = splitToks ((startPosl, startPosr), endPos) toks+          toks21' = (Commentstart, ((Pos 0 startPosl startPosr) , "")) : [(Comment, ((Pos 0 startPosl startPosr), ("\n{- " ++ com ++ " -}\n")))]+      in (toks1 ++ toks21' ++ (toks21 ++ toks22))+       +---  -} -}++updateToks oldAST newAST printFun+   = do ((toks,_), (v1, v2)) <-get+        let (startPos, endPos) = getStartEndLoc toks oldAST+            (toks1, _, _)      = splitToks (startPos, endPos) toks +            offset             = lengthOfLastLine toks1+            newToks = tokenise (Pos 0 v1 1) offset False $ printFun newAST  --check the startPos+            toks' = replaceToks toks startPos endPos newToks+        if newToks ==[] then put ((toks', modified), (v1,v2)) +                        else put ((toks',modified), (tokenRow (glast "updateToks1" newToks) -10, v2))                +                        +        -- error $ show (newToks, startPos, endPos)+        -- put ((toks', modified), (v1,v2))+        addLocInfo (newAST, newToks)++---REFACTORING: GENERALISE THIS FUNCTION.+addFormalParams t newParams +  = do ((toks,_),(v1, v2))<-get   +       let (startPos,endPos) = getStartEndLoc toks t+           tToks     = getToks (startPos, endPos) toks +           (toks1, _) = let (toks1', toks2') = break (\t-> tokenPos t == endPos) toks+                        in (toks1' ++ [ghead "addFormalParams" toks2'], gtail "addFormalParams"  toks2')+           offset  = lengthOfLastLine toks1+           newToks = tokenise (Pos 0 v1 1) offset False (prettyprintPatList True newParams )+           toks'   = replaceToks toks startPos endPos (tToks++newToks)+       put ((toks',modified), ((tokenRow (glast "addFormalParams" newToks) -10), v2))+       addLocInfo (newParams, newToks)    +++--Replace a list of tokens in the token stream by a new list of tokens, adjust the layout as well.+--To use this function make sure the start and end positions really exist in the token stream.+--QN: what happens if the start or end position does not exist?++replaceToks::[PosToken]->SimpPos->SimpPos->[PosToken]->[PosToken]+replaceToks toks startPos endPos newToks+   = if toks22 == [] +        then toks1 ++ newToks+        else let pos = tokenPos (ghead "replaceToks" toks22)+                 oldOffset = getOffset toks pos       +                 newOffset = getOffset (toks1++newToks++ toks22) pos +             in  toks1++ newToks++ adjustLayout toks22 oldOffset newOffset+   where +      (toks1, toks21, toks22) = splitToks (startPos, endPos) toks+++{- Delete an syntax phrase from the token stream, this function (instead of the following one)+   should be the interface function for deleting tokens.+-}          +-- deleteFromToks::( (MonadState (([PosToken], Bool), t1) m), StartEndLoc t,Printable t,Term t)=>t->m ()+deleteFromToks t getLocFun+   =do ((toks,_),others)<-get+       let (startPos,endPos)=getLocFun toks t+           toks'=deleteToks toks startPos endPos+       put ((toks',modified),others)++{-Delete a sequence of tokens specified by the start position and end position from the token stream,+  then adjust the remaining token stream to preserve layout-}+deleteToks::[PosToken]->SimpPos->SimpPos->[PosToken]+deleteToks toks startPos@(startRow, startCol) endPos@(endRow, endCol)+  = case after of +      (_:_) ->    let nextPos =tokenPos $ ghead "deleteToks1" after +                      oldOffset = getOffset toks nextPos+                      newOffset = getOffset (toks1++before++after) nextPos +                  in  toks1++before++adjustLayout (after++toks22) oldOffset newOffset +      _     -> if toks22 == [] +                 then toks1++before+                 else let toks22'=let nextOffset = getOffset toks (tokenPos (ghead "deleteToks2" toks22)) +                                  in if isMultiLineComment (lastNonSpaceToken toks21)   +                                       then whiteSpaceTokens (-1111, 0) (nextOffset-1) ++ toks22+                                       else toks22+                      in if endsWithNewLn (last (toks1++before)) || startsWithNewLn (ghead "deleteToks3" toks22')+                           then  toks1++before++toks22'+                           --avoiding layout adjustment by adding a `\n', sometimes may produce extra lines.+                             else  toks1++before++[newLnToken]++toks22'+                            --  else toks1 ++ before ++ toks22'+     where +      +      (toks1, toks2) = let (ts1, ts2)   = break (\t->tokenPos t == startPos) toks+                           (ts11, ts12) = break hasNewLn (reverse ts1)+                       in (reverse ts12, reverse ts11 ++ ts2)+      (toks21, toks22)=let (ts1, ts2) = break (\t -> tokenPos t == endPos) toks2+                           (ts11, ts12) = break hasNewLn ts2+                       in (ts1++ts11++if ts12==[] then [] else [ghead "deleteToks4" ts12], if ts12==[] then [] else gtail "deleteToks5"  ts12)  ++      -- tokens before the tokens to be deleted at the same line+      before = takeWhile (\t->tokenPos t/=startPos) toks21 ++      -- tokens after the tokens to be deleted at the same line.+      after = let t= dropWhile (\t->tokenPos t /=endPos) toks21+              in  if t == [] then error "Sorry, HaRe failed to finish this refactoring."+                             else  gtail "deleteToks6" t+                  +  +-- Adjust the layout to compensate the change in the token stream.+adjustLayout::[PosToken]->Int->Int->[PosToken]+adjustLayout [] _ _ = []+adjustLayout toks oldOffset newOffset + | oldOffset == newOffset  = toks++adjustLayout toks oldOffset newOffset+  = case layoutRuleApplies of+    True -> let (ts:ts') = groupTokensByLine  toks+            in ts ++ addRmSpaces (newOffset-oldOffset) oldOffset  ts'  -- THIS IS PROBLEMETIC. +    _    -> toks  +  where + +  layoutRuleApplies  +    = let ts = dropWhile (\t-> (not.elem (tokenCon t)) keyWords) +               $ filter notWhite+               $ takeWhile (not.hasNewLn) toks +      in case ts of+         (_: t: _) -> tokenCon t /= "{" +         _         -> False          ++  keyWords = ["where","let","do","of"] ++  addRmSpaces n col [] = []+  addRmSpaces n col toks@(ts:ts')+    =case find notWhite ts of+      Just t  -> if length (concatMap tokenCon ts1) >= col +                 then (addRmSpaces' n ts) ++ addRmSpaces n col ts' +                 else concat toks +      _       -> ts ++ addRmSpaces n col ts'+     where +      (ts1, ts2) = break notWhite ts++  addRmSpaces' 0 ts = ts+  addRmSpaces' _ [] = []+  addRmSpaces' n ts@(t:ts') +    = case n >0 of  +       True -> whiteSpaceTokens (tokenRow t,0) n ++ ts   -- CHECK THIS.+       _    -> if isWhiteSpace t +               then addRmSpaces' (n+1) ts'+               else error $ "Layout adjusting failed at line:"+                           ++ show (tokenRow t)++ "." ++-- remove at most n white space tokens from the beginning of ts+doRmWhites::Int->[PosToken]->[PosToken]+doRmWhites 0 ts=ts  +doRmWhites n []=[]+doRmWhites n toks@(t:ts)=if isWhiteSpace t then doRmWhites (n-1) ts+                                           else toks ++--add n white space tokens to the beginning of ts+doAddWhites::Int->[PosToken]->[PosToken]+doAddWhites n []=[]+doAddWhites n ts@(t:_)= whiteSpacesToken (tokenRow t,0) n ++ts++whiteSpaceTokens (row, col) n + = if n<=0 +    then [] +    else (mkToken Whitespace (row,col) " "):whiteSpaceTokens (row,col+1) (n-1)++-------------------------------------------------------------------------------------------------+--get all the source locations (use locations) in an AST phrase t in according the the occurrence order of identifiers.+srcLocs::(Term t)=> t->[SimpPos]+srcLocs t =(nub.srcLocs') t \\ [simpPos0]+   where srcLocs'=runIdentity.(applyTU (full_tdTU (constTU []+                                                  `adhocTU` pnt  +                                                  `adhocTU` sn+                                                  `adhocTU` literalInExp+                                                  `adhocTU` literalInPat)))+        +         pnt (PNT pname _ (N (Just (SrcLoc _  _ row col))))=return [(row,col)]                +         pnt _=return []+          +         sn (SN (PlainModule modName) (SrcLoc _ _ row col)) +             = return [(row, col)]+         sn _ = return []  +                     +         literalInExp ((Exp (HsLit (SrcLoc _  _ row col) _))::HsExpP) = return [(row,col)]+         literalInExp (Exp _) =return []++         literalInPat ((Pat (HsPLit (SrcLoc _ _ row col) _))::HsPatP) = return [(row,col)]+         literalInPat (Pat (HsPNeg (SrcLoc _  _ row col) _)) = return [(row,col)]+         literalInPat _ =return []  ++  +class StartEndLocPat t where++   startEndLoc2 :: [PosToken]->t->[(SimpPos,SimpPos)]+   -- startEndLoc3 :: [PosToken]->t->[(SimpPos,SimpPos)] +   +   +instance StartEndLocPat [HsDeclP] where+   startEndLoc2 toks ds=if  ds==[] then [(simpPos0,simpPos0)]+                                   else if length ds==1 +                                         then [startEndLoc toks (ghead "StartEndLoc:[HsDeclP]" ds)]+                                         else concat (map (startEndLoc2 toks) ds)+++instance StartEndLocPat HsMatchP where+   startEndLoc2 toks (HsMatch loc i ps rhs ds)+         =let (startLoc,_)=startEndLoc toks i+              (_,endLoc)  =if ds==[] then startEndLoc toks rhs+                                     else startEndLoc toks (glast "StartEndLoc:HsMatchP" ds)+          in [(startLoc,endLoc)]+          +instance StartEndLocPat HsDeclP where++   startEndLoc2 toks (Dec (HsTypeDecl (SrcLoc _ _ r c) tp t))+      = let (startLoc, _) = startEndLoc toks tp+            (_ , endLoc)  = startEndLoc toks t+        in [extendForwards toks startLoc endLoc isType]++   startEndLoc2 toks (Dec (HsDataDecl loc c tp decls is))+        = let (startLoc, _) = startEndLoc toks tp+              (_, endLoc)  = if is == [] then startEndLoc toks (glast "StartEndLoc:HsDeclP1" decls)+                                        else startEndLoc toks is+          in [extendForwards toks startLoc endLoc isData]++   startEndLoc2 toks (Dec (HsNewTypeDecl loc c tp decls is))+        = let (startLoc, _) = startEndLoc toks tp+              (_, endLoc) = if is == [] then startEndLoc toks decls+                                        else startEndLoc toks is+          in [extendForwards toks startLoc endLoc isNewtype]++   startEndLoc2 toks (Dec (HsDefaultDecl _ ts))+      = let (startLoc, _) = startEndLoc toks (head ts)+            (_ , endLoc) = startEndLoc toks (last ts)+        in [extendForwards toks startLoc endLoc isDefault]  ++   startEndLoc2 toks (Dec (HsInfixDecl _ _ is))+      = let (startLoc, _) = startEndLoc toks (head is)+            (_, endLoc)   = startEndLoc toks (last is)+        in [extendForwards toks startLoc endLoc isFixty]++   startEndLoc2 toks d@(Dec (HsFunBind _ ms))+      = map (startEndLoc toks) ms++   startEndLoc2 toks (Dec (HsPatBind _  p rhs ds))+       = let (startLoc, _) = startEndLoc toks p+             (_, endLoc)   = if ds ==[] then startEndLoc toks rhs+                                        else startEndLoc toks (glast "startEndLoc:HsDeclP5" ds)+             toks1 = dropWhile (\t->tokenPos t /= endLoc) toks+	     endLoc1 = if toks1==[] +			  then endLoc +			  else let toks2 = takeWhile (\t -> isSpecialTok t) toks1+                               in (tokenPos.glast "startEndLoc::HsMatchP") toks2+          in [(startLoc, endLoc1)]+       where +         isSpecialTok t = isWhiteSpace t  || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t +                        || isCloseSquareBracket t ++   startEndLoc2 toks (Dec (HsTypeSig _ is c t))+      = let (startLoc, _) = startEndLoc toks (ghead "startEndLoc:HsDeclP6" is)+            (_, endLoc)   = startEndLoc toks t+        in [(startLoc, endLoc)]++              +   startEndLoc2 toks decl@(Dec (HsClassDecl loc c tp funDeps  ds))+      = let locs = srcLocs decl+            (startLoc, endLoc)+              = if locs == [] then (simpPos0, simpPos0)+                 else (head locs, last locs)                           +        in [extendForwards toks startLoc endLoc isClass]++   startEndLoc2 toks decl@(Dec (HsInstDecl loc i c t ds))+     = let locs = srcLocs decl+           (startLoc, endLoc)+              = if locs == [] then (simpPos0, simpPos0)+                 else (head locs, last locs)                           +        in [extendForwards toks startLoc endLoc isInstance]          +          ++getStartEndLoc2::(Term t, StartEndLocPat t,Printable t)=>[PosToken]->t->[(SimpPos,SimpPos)]+getStartEndLoc2 toks t +  = startEndLoc2 toks t+     {-   locs = srcLocs t +        (startPos,endPos) = (if startPos' == simpPos0 && locs /=[] then ghead "getStartEndLoc2" locs+                                                                   else startPos',+                             if endPos' == simpPos0 && locs /= [] then glast "gerStartEndLoc2" locs+                                                                  else endPos')+    in (startPos, endPos)  -}+  +  +         +--given an AST phrase, 'startEndLoc' gets its start and end position in the program source.+class StartEndLoc t where++   startEndLoc :: [PosToken]->t->(SimpPos,SimpPos)++instance StartEndLoc HsModuleP where+  startEndLoc toks _  = (tokenPos (ghead "startEndLoc:HsModuleP" toks), +                         tokenPos (glast "startEndLoc:HsModuleP" toks))++instance StartEndLoc HsExpP where+    +  startEndLoc  toks (Exp e)=+      case e of+  +        HsId ident@(HsVar (PNT pn _ _)) ->let (startLoc, endLoc) = startEndLoc toks ident+                                              {- To handle infix operator. for infix operators like (++), there+                                                  is no parenthesis in the syntax tree -}+                                              (toks1,toks2) = break (\t->tokenPos t==startLoc) toks+                                              toks1' = dropWhile isWhite (reverse toks1)+                                              toks2' = dropWhile isWhite (gtail "startEndLoc:HsExpP"+                                                          (dropWhile (\t->tokenPos t /=endLoc) toks2))+                                           in if toks1'/=[] && toks2'/=[] && isOpenBracket (head toks1')+                                                 && isCloseBracket (head toks2')+                                              then (tokenPos (head toks1'), tokenPos (head toks2'))+                                              else (startLoc, endLoc) +        HsId  x                       ->startEndLoc toks x+   +        HsLit (SrcLoc _ _ r c) _      -> ((r,c),(r,c))++        HsInfixApp e1 op e2           ->let (startLoc,_)=startEndLoc toks e1+                                            (_, endLoc) =startEndLoc toks e2+                                        in (startLoc,endLoc)++        e@(HsApp e1 e2)               ->let (startLoc,endLoc)=startEndLoc toks e1+                                            (startLoc1, endLoc1 )=startEndLoc toks e2+	                     +                                        in (startLoc, endLoc1)++        HsNegApp (SrcLoc _ _ r c) e     ->let (_,endLoc)=startEndLoc toks e+                                          in ((r,c), endLoc)++        HsLambda ps e                 ->let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsLambda" ps)  --ps can not be empty+                                            (_,endLoc)  =startEndLoc toks e+                                        in extendForwards toks startLoc endLoc isLambda++        HsIf e1 e2 e3                 ->let (startLoc, _)=startEndLoc toks e1+                                            (_, endLoc)=startEndLoc toks e3+                                        in extendForwards toks  startLoc endLoc isIf++        HsLet ds e                    ->if ds==[]+                                          then+                                            let  (startLoc,endLoc)=startEndLoc toks e+                                            in extendForwards toks startLoc endLoc isLet+                                          else+                                            let  (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsLet" ds) +                                                 (_,endLoc)  =startEndLoc toks e +                                            in extendForwards toks startLoc endLoc isLet++        HsCase e alts                 ->let (startLoc,_)=startEndLoc toks e+                                            (_,endLoc)  =startEndLoc toks (glast "HsCase" alts) --alts can not be empty.+                                        in extendForwards toks startLoc endLoc isCase+                        +        HsDo stmts                    ->let (startLoc, endLoc)=startEndLoc toks  stmts+                                        in extendForwards toks startLoc endLoc isDo++        HsTuple es                    ->if es==[] +                                         then  (simpPos0,simpPos0)  --Empty tuple can cause problem.+                                         else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsTuple" es)+                                                  (_,endLoc)  =startEndLoc toks (glast "startEndLoc:HsTuple" es)+                                              in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket  ++        HsList es                     ->if es==[] +                                         then (simpPos0,simpPos0)  --Empty list can cause problem.+                                         else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsList" es) +                                                  (_,endLoc)  =startEndLoc toks (glast "startEndLoc:HsList" es)+                                              in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket++        HsParen e                     ->let (startLoc,(endLocR, endLocC))=startEndLoc toks  e+                                        in extendBothSides toks startLoc (endLocR, endLocC) isOpenBracket isCloseBracket+									   +                                       --  in if expIsPNT e+--                                              then (startLoc, (endLocR, endLocC+1))+--                                              else extendBothSides toks startLoc (endLocR, endLocC) isOpenBracket isCloseBracket +--                                           where+--                                             expIsPNT (Exp (HsId (HsVar pnt)))=True+--                                             expIsPNT (Exp (HsParen e))=expIsPNT e  +--                                             expIsPNT _ =False++        HsLeftSection e op            ->let (startLoc,_)=startEndLoc toks e+                                            (_, endLoc )=startEndLoc toks op+                                        in (startLoc,endLoc)++        HsRightSection op e           ->let (startLoc,_)=startEndLoc toks op+                                            (_, endLoc )=startEndLoc toks op+                                        in (startLoc,endLoc)++        HsRecConstr loc i upds            ->let (startLoc,_)=startEndLoc toks i+                                                (_,endLoc)  =startEndLoc toks (glast "startEndLoc:HsRecConstr" upds) --can 'upds' be empty?+                                        in extendBackwards toks startLoc endLoc isCloseBrace +                                        +        HsRecUpdate loc e upds            ->let (startLoc,_)=startEndLoc toks e+                                                (_,endLoc)  =startEndLoc toks (glast "startEndLoc:HsRecUpdate" upds) --ditto+                                        in extendBackwards toks startLoc endLoc isCloseBrace ++        HsEnumFrom e                  ->let (startLoc,endLoc)=startEndLoc toks e+                                        in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket   ++        HsEnumFromTo e1 e2            ->let (startLoc,_)=startEndLoc toks e1+                                            (_,  endLoc)=startEndLoc toks e2+                                        in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket   ++        HsEnumFromThen e1 e2          ->let (startLoc,_)=startEndLoc toks e1+                                            (_,  endLoc)=startEndLoc toks e2+                                        in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket  +                                  +        HsEnumFromThenTo e1 e2 e3     ->let (startLoc,_)=startEndLoc toks e1+                                            (_,  endLoc)=startEndLoc toks e3+                                        in extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket  +                                 +        HsListComp stmts              ->let (startLoc,endLoc)=startEndLoc toks stmts+                                        in  extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket     ++        HsAsPat i e                   ->let (startLoc,_)=startEndLoc toks i+                                            (_,endLoc)=  startEndLoc toks e+                                        in (startLoc,endLoc) ++        HsIrrPat e                    ->let (startLoc,endLoc)=startEndLoc toks e+                                        in extendForwards toks startLoc endLoc isIrrefute++        HsWildCard                    ->(simpPos0,simpPos0)  -- wildcard can cause problem.+  +        +        HsExpTypeSig loc e c t        ->let (startLoc,_)=startEndLoc toks e+                                            (_, endLoc )=startEndLoc toks t+                                        in (startLoc,endLoc)    ++instance StartEndLoc HsTypeP where++   startEndLoc toks (Typ p)=+      case p of +        HsTyFun  t1  t2       ->   let (startLoc,e)=startEndLoc toks t1+                                       (_ , endLoc)=startEndLoc toks t2+                                   in (startLoc,endLoc) +        --HsTyTuple [t]         ->++        HsTyApp  t1 t2        ->   let (startLoc,endLoc)=startEndLoc toks  t1 +                                       (startLoc1 , endLoc1)=startEndLoc toks  t2+                                   in case t1 of +                                        (Typ (HsTyCon t)) -> if (render.ppi) t == "[]"+                                                   then extendBothSides toks startLoc1 endLoc1 isOpenSquareBracket isCloseSquareBracket+                                                   else (startLoc, endLoc1)+                                        _  -> (startLoc, endLoc1)                                                       +                                  +        HsTyVar  i            ->   let (startLoc, endLoc) = startEndLoc toks i+                                   in  extendBothSides' toks startLoc endLoc isOpenBracket isCloseBracket+        HsTyCon  i            ->   let (startLoc, endLoc) = startEndLoc toks i +                                   in if (render.ppi) i =="[]" +                                        then extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket               +                                        else extendBothSides' toks startLoc endLoc isOpenBracket isCloseBracket ++        HsTyForall   is ts t   ->   case is of+                                     []  ->let (startLoc,endLoc)=startEndLoc toks t+                                           in  extendForwards toks startLoc endLoc isForall+   +                                     l  -> let (startLoc, _) =startEndLoc toks  $ ghead "StartEndLoc:HsTypeP" is+                                               ( _ , endLoc) =startEndLoc toks t+                                           in extendForwards toks startLoc endLoc isForall++extendBothSides'  toks startLoc endLoc  forwardCondFun backwardCondFun+       =let (toks1,toks2)=break (\t->tokenPos t==startLoc) toks+            toks21=dropWhile (\t->tokenPos t<=endLoc) toks2+            firstLoc=case (dropWhile isWhite (reverse toks1)) of +                             [] -> startLoc    -- is this the correct default?+                             ls  -> if (forwardCondFun.ghead "extendBothSides:lastTok") ls  then tokenPos (head ls)+                                      else startLoc+            lastLoc =case (dropWhile isWhite toks21) of+                            [] ->endLoc   --is this a correct default?+                            ls -> if (backwardCondFun.ghead "extendBothSides:lastTok") ls then tokenPos (head ls)+                                   else endLoc                   +        in (firstLoc, lastLoc)  ++instance StartEndLoc HsPatP where++  startEndLoc toks (Pat p)=+     case p of+       HsPId i                          ->startEndLoc toks i++       HsPLit (SrcLoc _ _ r c) _        ->((r,c),(r,c))++       HsPNeg (SrcLoc _ _  r c) p       ->((r,c),(r,c))+   +       HsPInfixApp p1 op p2             ->let (startLoc,_)=startEndLoc toks  p1+                                              (_ , endLoc)=startEndLoc toks p2+                                          in (startLoc,endLoc)++       HsPApp i ps                      ->let (startLoc,_)=startEndLoc toks  i+                                              (_,endLoc)=startEndLoc toks (glast "StartEndLoc:HsPatP" ps)+                                          in (startLoc,endLoc)++       HsPTuple loc ps                  -> if ps==[]+                                             then  (simpPos0,simpPos0)  -- ****Update this using locations****.+                                             else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsPTuple"  ps)+                                                      (_,endLoc)=startEndLoc toks (glast "startEndLoc:HsPTuple" ps)+                                                  in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket  ++       HsPList loc ps                     ->if ps==[] +                                            then (simpPos0,simpPos0)  -- ***Update this using locations*****+                                            else let (startLoc,_)=startEndLoc toks (ghead "startEndLoc:HsPList" ps)+                                                     (_, endLoc) =startEndLoc toks (glast "startEndLoc:HsPList" ps)+                                            in  extendBothSides toks startLoc endLoc isOpenSquareBracket isCloseSquareBracket     +                                        +       HsPParen p                       ->let (startLoc,endLoc)=startEndLoc toks p+                                          in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket  + +       HsPRec i upds                    ->let (startLoc,_)=startEndLoc toks i+                                              (_,endLoc)=startEndLoc toks (glast "startEndLoc:HsPRec" upds) --can upds be empty?+                                          in extendBackwards toks startLoc endLoc isCloseBrace +                                         +       HsPAsPat i p                     ->let (startLoc,_)=startEndLoc toks i+                                              (_,endLoc)=startEndLoc toks p+                                          in (startLoc,endLoc)+ +       HsPIrrPat p                      ->let (startLoc,endLoc)=startEndLoc toks p+                                          in extendForwards toks startLoc endLoc isIrrefute+                                       +       HsPWildCard                       ->(simpPos0,simpPos0)  -- wildcard can  cause problem.++instance StartEndLoc [HsPatP] where++   startEndLoc toks ps = let locs=(nub.(map (startEndLoc toks))) ps \\ [(simpPos0,simpPos0)]+                         in if locs==[] then (simpPos0,simpPos0)+                                        else let (startLoc,_)=ghead "StartEndLoc:HsPatP" locs+                                                 (_,endLoc) =glast "StartEndLoc:HsPatP"  locs+                                             in (startLoc,endLoc)+instance StartEndLoc [HsExpP] where++   startEndLoc toks es=let locs=(nub.(map (startEndLoc toks))) es \\ [(simpPos0,simpPos0)]+                       in if locs==[] then (simpPos0,simpPos0)+                                      else let (startLoc,_)=ghead "StartEndLoc:HsExp" locs+                                               (_,endLoc) =glast "startEndLoc:HsExp" locs+                                           in (startLoc,endLoc)+instance StartEndLoc [HsDeclP] where+  startEndLoc toks ds=if  ds==[] then (simpPos0,simpPos0)+                                 else if length ds==1 +                                        then startEndLoc toks (ghead "StartEndLoc:[HsDeclP]" ds)+                                        else  let (startLoc,_)=startEndLoc toks (ghead "StartEndLoc:[HsDeclP]" ds)+                                                  (_,endLoc) =startEndLoc toks (glast  "StartEndLoc:[HsDeclP]" ds)+                                              in (startLoc,endLoc)++instance StartEndLoc HsMatchP where+   startEndLoc toks t@(HsMatch loc i ps rhs ds)+         =let (startLoc,_)=startEndLoc toks i+              (_,endLoc)  =if ds==[] then startEndLoc toks rhs+                                     else startEndLoc toks (glast "StartEndLoc:HsMatchP" ds)			  +              locs = srcLocs t +              (startLoc1,endLoc1) = (if startLoc == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs+                                                                   else startLoc,+				     if endLoc == simpPos0 && locs /= [] then glast "getStartEndLoc" locs+                                                                         else endLoc)			    +              toks1 = gtail "startEndLoc:HsMatchP" (dropWhile (\t->tokenPos t /= endLoc1) toks)+              toks0 = getToks (startLoc1, endLoc1) toks+	      endLoc2 = if toks1==[] +		 	  then endLoc1 +			  else let toks2 = takeWhile (\t -> isSpecialTok t && needmore toks t ) toks1+                               in if toks2 == [] || all (\t-> isWhiteSpace t ) toks2+				       then endLoc1 +                                       else (tokenPos.glast "startEndLoc::HsMatchP") toks2+              +          in (startLoc1, endLoc2) +        where +          isSpecialTok t = isWhiteSpace t  || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t +                          || isCloseSquareBracket t +          needmore toks t = case  isCloseBracket t of +                              True -> let openBrackets = length $ filter isOpenBracket toks+                                          closeBrackets = length $ filter isCloseBracket toks+                                      in closeBrackets < openBrackets+                              False -> case isCloseSquareBracket t of+                                       True -> let openSqBrackets = length $ filter isOpenSquareBracket toks+                                                   closeSqBrackets = length $ filter isCloseSquareBracket toks+                                               in closeSqBrackets < openSqBrackets+                                       false -> True+++instance StartEndLoc HsStmtP where      -- Bug fixed. 20/05/2004+   startEndLoc toks stmts=let s=getStmtList  stmts                           +                              locs = map (startEndLoc toks) s +                              (startLocs, endLocs) =(sort (map fst locs), sort (map snd locs))+                          in (ghead "StartEndLoc::HsStmtP" startLocs, glast "StartEndLoc::HsStmtP" endLocs)+                              +instance StartEndLoc (HsStmtAtom HsExpP HsPatP [HsDeclP])  where++    startEndLoc toks stmt=+      case stmt of +           HsGeneratorAtom (SrcLoc _ _ r c) p e -> +                                  let (startLoc,_)=startEndLoc toks p+                                      (_,endLoc)  =startEndLoc toks e+                                  in (startLoc,endLoc)+           HsQualifierAtom e   -> startEndLoc toks e+           HsLetStmtAtom ds    -> if ds==[]+                                   then (simpPos0,simpPos0)+                                   else let (startLoc,_)= startEndLoc toks (ghead "StartEndLoc:HsStmtAtom" ds)+                                            (_,endLoc)  = startEndLoc toks (glast "StartEndLoc:HsStmtAtom" ds)+                                        in (startLoc,endLoc)+           HsLastAtom e        ->startEndLoc toks e++instance (StartEndLoc i,StartEndLoc e)=>StartEndLoc (HsFieldI i e) where+    startEndLoc toks (HsField i e)=let (startLoc,_)=startEndLoc toks i+                                       (_,endLoc)=startEndLoc toks e+                                   in (startLoc,endLoc) ++instance StartEndLoc HsAltP where   +    startEndLoc toks (HsAlt l p rhs ds)=let (startLoc,_)=startEndLoc toks p+                                            (_,endLoc)=if ds==[] then startEndLoc toks rhs+                                                                 else startEndLoc toks (glast "StartEndLoc:HsAltP" ds)+                                        in (startLoc,endLoc)++instance StartEndLoc RhsP where    +   startEndLoc toks (HsBody e)=startEndLoc toks e++   startEndLoc toks (HsGuard es)=if es==[] then (simpPos0,simpPos0)+                                           else let (_,e1,_)=ghead "StartEndLoc:RhsP" es+                                                    (_,_,e2)=glast "StartEndLoc:RhsP" es+                                                    (startLoc,_)=startEndLoc toks e1+                                                    (_,endLoc)=startEndLoc toks e2+                                                in extendForwards toks startLoc endLoc isBar ++instance StartEndLoc (HsIdentI PNT) where+    startEndLoc toks ident =+       case ident of+           HsVar i  ->startEndLoc toks i+           HsCon i  ->startEndLoc toks i++instance StartEndLoc [PNT] where+    startEndLoc toks pnts +       = if pnts==[] then (simpPos0, simpPos0)+           else let (startPos, _) = startEndLoc toks (head pnts)+                    (_,      endPos) = startEndLoc toks (last pnts)+                in (startPos, endPos)                           ++instance StartEndLoc (HsImportDeclI ModuleName PNT)  where+     startEndLoc toks (HsImportDecl (SrcLoc _ _ row col) modName qual  as Nothing)+        = let startPos=fst (startEndLoc toks modName)+              endPos = if isJust as then snd (startEndLoc toks (fromJust as))+                                    else snd (startEndLoc toks modName)+          in extendForwards toks startPos endPos isImport +                                        +     startEndLoc toks (HsImportDecl (SrcLoc _ _ row col) modName qual as (Just (_, ents)))+         = let startPos = fst (startEndLoc toks modName)+               endPos = if ents == [] then if isJust as then  snd (startEndLoc toks (fromJust as))+                                                        else  snd (startEndLoc toks modName)+                                      else snd (startEndLoc toks (glast "startEndLocImport" ents))+           in extendBothSides toks startPos endPos isImport isCloseBracket +++instance StartEndLoc  [HsExportSpecI ModuleName PNT] where+   startEndLoc toks es +     = if es == [] then (simpPos0, simpPos0)+                   else let (startLoc, _) = startEndLoc toks $ head es +                            (_, endLoc)   = startEndLoc toks $ last es+                        in (startLoc, endLoc)+                        -- in extendBothSides toks startLoc endLoc isOpenBracket isCloseBracket +++instance StartEndLoc (HsExportSpecI ModuleName PNT) where+     startEndLoc toks (EntE ent) =startEndLoc toks ent+    +     startEndLoc toks (ModuleE moduleName) = let (startPos, endPos) = startEndLoc toks moduleName+                                             in extendForwards toks startPos endPos isModule++    +              +instance StartEndLoc(EntSpec PNT) where+      startEndLoc toks (Var i)=startEndLoc toks i   --- x (a variable identifier)+ +      startEndLoc toks (Abs i) =startEndLoc toks i   -- T, C++      startEndLoc toks (AllSubs i) =let (startPos, endPos) =startEndLoc toks i -- T(..), C(..)+                                    in extendBackwards toks startPos endPos isCloseBracket+      startEndLoc toks (ListSubs i ents)= let (startPos, _) = startEndLoc toks i --T (C_1, ...,C_n, f1,...f_n)+                                              (_, endPos)   = startEndLoc toks (glast "startEnPosListSubs" ents)+                                          in extendBackwards toks startPos endPos isCloseBracket+                                        +instance StartEndLoc ModuleName where+   startEndLoc toks (SN modName (SrcLoc _ _ row col)) = ((row,col), (row,col))++instance StartEndLoc [EntSpec PNT] where+      startEndLoc toks ents +        = if ents==[] then (simpPos0,simpPos0)+                      else let (startPos, _)=startEndLoc toks $ head ents+                               (_,  endPos) =startEndLoc toks $ last ents +                           in (startPos,endPos)+                --         in extendBothSides toks startPos endPos isHiding isCloseBracket++instance StartEndLoc PNT where    +     startEndLoc toks pnt =+        case pnt of +          PNT pn  _ (N (Just (SrcLoc _ _ row col)))->((row,col),(row,col))+          _                                        ->(simpPos0,simpPos0)  {-Shouldn't cause any problems here, as in a normal+                                                                            AST, every PNT has a source location. -}+++instance (Eq i, Eq t, StartEndLoc i, StartEndLoc t,StartEndLoc [i]) =>StartEndLoc (HsConDeclI i t c) where+   startEndLoc toks (HsConDecl _ is c i ds) +      = let (startLoc, _) = startEndLoc toks is+            (_, endLoc)   = if ds==[] then startEndLoc toks i +                                      else startEndLoc toks (last ds)+        in (startLoc, endLoc)+   +   startEndLoc toks (HsRecDecl _ is c i ds) +      = let (startLoc, _) = startEndLoc toks is+            (_, endLoc)   = if ds==[] then startEndLoc toks i +                                      else startEndLoc toks (last ds)+        in (startLoc, endLoc)+ +instance (StartEndLoc t)=>StartEndLoc (HsBangType t) where+   startEndLoc toks (HsBangedType t) = startEndLoc toks t++   startEndLoc toks (HsUnBangedType t) = startEndLoc toks t++instance (StartEndLoc t, StartEndLoc [i]) => StartEndLoc ([i], HsBangType t) where+   +   startEndLoc toks (x,y)+     = let (startLoc, endLoc) = startEndLoc toks y+         in  extendBackwards toks startLoc endLoc isCloseBrace+   +++instance StartEndLoc HsDeclP where++   startEndLoc toks (Dec (HsTypeDecl (SrcLoc _ _ r c) tp t))+      = let (startLoc, _) = startEndLoc toks tp+            (_ , endLoc)  = startEndLoc toks t+        in extendForwards toks startLoc endLoc isType++   startEndLoc toks (Dec (HsDataDecl loc c tp decls is))+        = let (startLoc, _) = startEndLoc toks tp+              (_, endLoc)  = if is == [] then startEndLoc toks (glast "StartEndLoc:HsDeclP1" decls)+                                        else startEndLoc toks is+          in extendForwards toks startLoc endLoc isData++   startEndLoc toks (Dec (HsNewTypeDecl loc c tp decls is))+        = let (startLoc, _) = startEndLoc toks tp+              (_, endLoc) = if is == [] then startEndLoc toks decls+                                        else startEndLoc toks is+          in extendForwards toks startLoc endLoc isNewtype++   startEndLoc toks (Dec (HsDefaultDecl _ ts))+      = let (startLoc, _) = startEndLoc toks (head ts)+            (_ , endLoc) = startEndLoc toks (last ts)+        in extendForwards toks startLoc endLoc isDefault  ++   startEndLoc toks (Dec (HsInfixDecl _ _ is))+      = let (startLoc, _) = startEndLoc toks (head is)+            (_, endLoc)   = startEndLoc toks (last is)+        in extendForwards toks startLoc endLoc isFixty++   startEndLoc toks d@(Dec (HsFunBind _ ms))+      = let (startLoc, _) = startEndLoc toks (ghead "startEndLoc:HsDeclP3" ms)+            (_,   endLoc) = if ms == [] then (simpPos0, simpPos0) +                                        else startEndLoc toks (glast "startEndLoc:HsDeclP4" ms)+        in (startLoc, endLoc)+   startEndLoc toks t@(Dec (HsPatBind _  p rhs ds))+       = let (startLoc, _) = startEndLoc toks p+             (_, endLoc)   = if ds ==[] then startEndLoc toks rhs+                                        else startEndLoc toks (glast "startEndLoc:HsDeclP5" ds)+	     locs = srcLocs t +             (startLoc1,endLoc1) = (if startLoc == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs+                                                                   else startLoc,+				    if endLoc == simpPos0 && locs /= [] then glast "getStartEndLoc" locs+                                                                         else endLoc)			    +             toks1 = gtail "startEndLoc:HsPatBind" (dropWhile (\t->tokenPos t /= endLoc1) toks)+	     endLoc2 = if toks1==[] +		       then endLoc1 +                       else let toks2 = takeWhile (\t -> isSpecialTok t && needmore toks t) toks1+                            in if toks2 == [] || all (\t-> isWhiteSpace t) toks2+			       then endLoc1 +                               else (tokenPos.glast "startEndLoc::HsMatchP") toks2+	 in (startLoc1, endLoc2)+    where +        isSpecialTok t = isWhiteSpace t  || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t +                      || isCloseSquareBracket t +        needmore toks t = case  isCloseBracket t of +                            True -> let openBrackets = length $ filter isOpenBracket toks+                                        closeBrackets = length $ filter isCloseBracket toks+                                    in  closeBrackets < openBrackets+                            False -> case isCloseSquareBracket t of+                                      True -> let openSqBrackets = length $ filter isOpenSquareBracket toks+                                                  closeSqBrackets = length $ filter isCloseSquareBracket toks+                                              in  closeSqBrackets < openSqBrackets+                                      False -> True++  +++   startEndLoc toks (Dec (HsTypeSig _ is c t))+      = let (startLoc, _) = startEndLoc toks (ghead "startEndLoc:HsDeclP6" is)+            (_, endLoc)   = startEndLoc toks t+        in (startLoc, endLoc)+              +   startEndLoc toks decl@(Dec (HsClassDecl loc c tp funDeps  ds))+      = let locs = srcLocs decl+            (startLoc, endLoc)+              = if locs == [] then (simpPos0, simpPos0)+                 else (head locs, last locs)                           +        in extendForwards toks startLoc endLoc isClass++   startEndLoc toks decl@(Dec (HsInstDecl loc i c t ds))+     = let locs = srcLocs decl+           (startLoc, endLoc)+              = if locs == [] then (simpPos0, simpPos0)+                 else (head locs, last locs)                           +        in extendForwards toks startLoc endLoc isInstance++  +{-+   startEndLoc toks (Dec (HsPrimitiveTypeDecl _ c tp))+     = let (startLoc, endLoc) = startEndLoc toks tp+       in extendForward toks startLoc endLoc isData   +          ++   startEndLoc toks (Dec (HsPrimitiveBind _ i t)) +     = let (startLoc, _) = startEndLoc toks i+           (_, endLoc)   = stratEndLoc toks t+       in  extendForward toks startLoc endLoc isPrimitive+-}++---------------End of the class StartEndLoc----------------------------------------+--------------------------------------------------------------------------------------------------------+-- This function should be the interface function for fetching start and end locations of a AST phrase in the source.+getStartEndLoc::(Term t, StartEndLoc t,Printable t)=>[PosToken]->t->(SimpPos,SimpPos)+getStartEndLoc toks t +  = let (startPos',endPos') = startEndLoc toks t+        locs = srcLocs t +        (startPos,endPos) = (if startPos' == simpPos0 && locs /=[] then ghead "getStartEndLoc" locs+                                                                   else startPos',+                             if endPos' == simpPos0 && locs /= [] then glast "getStartEndLoc" locs+                                                                  else endPos')+    in (startPos, endPos)++ {- THECK : myppi.+      adjustLoc toks (startPos,endPos) t  -- to handle syntax phrase starts/ends with [], () ...+    where  +      adjustLoc toks (startPos,endPos) t+         = let astToks = filter (not.unwantedTok) $ tokenise  (Pos 0 0 1) 1 True $ (render.myppi) t +               (toks1,toks2, toks3) = splitToks (startPos, endPos) toks+               toks2' = filter (not.unwantedTok) toks2               +               (t1, t2) =(ghead "getStartEndLoc1" astToks, glast "getStartEndLoc2" astToks)+               startPos'= if sameToks t1 (ghead "getStartEndLoc3" toks2')+                           then startPos+                           else tokenPos $ ghead "getStartEndLoc4" $ dropWhile (\t-> not (sameToks t t1)) (reverse toks1)+               endPos'  = if sameToks t2 (glast "getStartEndLoc2" toks2')+                           then endPos+                           else tokenPos $ ghead "getStartEndLoc5" $ dropWhile (\t-> not (sameToks t t2)) toks3 +           in (startPos', endPos')++      unwantedTok t = isWhite t  || isCloseBracket t || isOpenBracket t || isOpenSquareBracket t +                      || isCloseSquareBracket t || isComma t ++      sameToks (t1, (l1, c1)) (t2, (l2, c2)) = t1 == t2 && c1 == c2+ -}++-- this function has problems whegtn they encounter sth. like [.....[p]]/+extendBothSides  toks startLoc endLoc  forwardCondFun backwardCondFun+       =let (toks1,toks2)=break (\t->tokenPos t==startLoc) toks+            toks21=gtail ("extendBothSides" ++ (show (startLoc, endLoc, toks2))  ) $ dropWhile (\t->tokenPos t /=endLoc) toks2+            firstLoc=case (dropWhile (not.forwardCondFun) (reverse toks1)) of +                             [] -> startLoc    -- is this the correct default?+                             l  -> (tokenPos.ghead "extendBothSides:lastTok") l  +            lastLoc =case (dropWhile (not.backwardCondFun) toks21) of+                            [] ->endLoc   --is this a correct default?+                            l -> (tokenPos.ghead "extendBothSides:lastTok") l                    +        in (firstLoc, lastLoc)   ++extendForwards toks startLoc endLoc forwardCondFun+       =let toks1=takeWhile (\t->tokenPos t /= startLoc) toks          +            firstLoc=case (dropWhile (not.forwardCondFun) (reverse toks1)) of+                       [] ->startLoc  -- is this the correct default?+                       l -> (tokenPos.ghead "extendForwards") l+        in (firstLoc, endLoc)++extendBackwards toks startLoc endLoc backwardCondFun+       = let toks1= gtail "extendBackwards"  $ dropWhile (\t->tokenPos t /=endLoc) toks+             lastLoc=case (dropWhile (not.backwardCondFun) toks1) of+                          [] ->endLoc -- is this the correct default?+                          l ->(tokenPos. ghead "extendBackwards") l+         in (startLoc, lastLoc)     +                                   +------------------Some functions for associating comments with syntax phrases.---------------------------+{- Note: We assume that a comment before t belongs to t only if there is at most one blank line between them, +         and a cooment after t belongs to t only it the comment starts at the last line of t.+-}++{-Get the start&end location of syntax phrase t, then extend the end location to cover the comment/white spaces+  or new line which starts in the same line as the end location-}+startEndLocIncFowComment::(Term t, Printable t,StartEndLoc t)=>[PosToken]->t->(SimpPos,SimpPos)+startEndLocIncFowComment toks t+       =let (startLoc,endLoc)=getStartEndLoc toks t+            toks1= gtail "startEndLocIncFowComment"  $ dropWhile (\t->tokenPos t/=endLoc) toks+            toks11 = let (ts1, ts2) = break hasNewLn toks1+                     in (ts1 ++ if ts2==[] then [] else [ghead "startEndLocInFowComment" ts2])+         in  if toks11/=[] && all (\t->isWhite t || endsWithNewLn t) toks11 +             then (startLoc, tokenPos (glast "startEndLocIncFowComment" toks11))+             else (startLoc, endLoc) +++{-get the start&end location of t in the token stream, then extend the end location to cover+  the following '\n' if there is no other characters (except white space) between t and the '\n'+-}+startEndLocIncFowNewLn::(Term t, Printable t,StartEndLoc t)=>[PosToken]->t->(SimpPos,SimpPos)+startEndLocIncFowNewLn toks t+  =let (startLoc,endLoc)=getStartEndLoc toks t+       toks1 = dropWhile isWhiteSpace $ gtail "startEndLocIncFowNewLn"  $ dropWhile (\t->tokenPos t /=endLoc) toks+       nextTok= if toks1==[] then defaultToken else head toks1+   in if isNewLn nextTok  +        then (startLoc, tokenPos nextTok)+        else (startLoc, endLoc)+ +{-get the start&end loation of t in the token stream, then extend the start and end location to+  cover the preceding and folllowing comments. +-}+startEndLocIncComments::(Term t, StartEndLoc t,Printable t)=>[PosToken]->t->(SimpPos,SimpPos)+startEndLocIncComments toks t+  =let (startLoc,endLoc)=getStartEndLoc toks t +       (toks11,toks12)= let (ts1,ts2) = break (\t->tokenPos t == startLoc) toks+                            (ts11, ts12) = break hasNewLn (reverse ts1)+                        in (reverse ts12, reverse ts11++ts2)+       toks12'=takeWhile (\t->tokenPos t /=startLoc) toks12+       startLoc'=+         if all isWhite  toks12'  +           then  -- group the toks1 according to lines in a reverse order.+                 let  groupedToks=reverse $ groupTokensByLine toks11+                      -- empty lines right before t+                      emptyLns=takeWhile (all (\t->isWhiteSpace t || isNewLn t )) groupedToks             +                      lastComment=if length emptyLns <=1  -- get the comment if there is any+                                    then takeWhile (all isWhite) $ takeWhile (any isComment) $ dropWhile +                                               (all (\t->isWhiteSpace t || isNewLn t)) groupedToks    +                                    else [] -- no comment +                      toks1'=if lastComment /=[] then concat $ reverse (emptyLns ++ lastComment)+                                                 else []+                 in if toks1'==[]+                       then if toks12'/=[] +                              then (tokenPos (ghead "startEndLocIncComments"  toks12'))  --there is no comment before t+                              else startLoc +                       --there is a comment before t+                       else tokenPos (ghead "startEndLocIncComments"  toks1') +           else startLoc          +       -- tokens after t+       toks2=gtail "startEndLocIncComments1"  $ dropWhile (\t->tokenPos t/=endLoc) toks+       -- toks21 are those tokens that are in the same line with the last line of t +       (toks21,tok22)= let (ts11, ts12) = break hasNewLn toks2+                       in (ts11 ++ if ts12==[] then [] else [ghead "startEndLocIncComments" ts12],+                                                             gtail "startEndLocIncComments2" ts12)+    in if toks21==[] then (startLoc',endLoc)  -- no following comments.+        else if all (\t->isWhite t || endsWithNewLn t) toks21 --get the following white tokens in the same+                                                              --line of the last token of t+               then (startLoc', tokenPos (last toks21))+               else (startLoc', endLoc)  ++--Create a list of white space tokens.+whiteSpacesToken::SimpPos->Int->[PosToken]+whiteSpacesToken (row,col) n+  |n>0        = [(Whitespace,(Pos 0 row col,replicate n ' '))]+  |otherwise  = []++-------------------------------------------------------------------------------------------------++adjustOffset::Int->[PosToken]->Bool->[PosToken]           +adjustOffset offset [] _ = []  +adjustOffset offset toks firstLineIncluded  +     = let groupedToks = groupBy (\x y->tokenRow x==tokenRow y) toks  --groupedToks/=[], no problem with 'head'+           --if firstLineIncluded is False, the offset of the first line won't be ajusted.+       in if offset>=0 then if firstLineIncluded +                               then concatMap (doAddWhites offset) groupedToks+                               else ghead "adjustOffset" groupedToks ++ concatMap (doAddWhites offset) (tail groupedToks)+                       else if firstLineIncluded +                               then concatMap (doRmWhites  (-offset)) groupedToks+                               else ghead "adjustOffset" groupedToks ++ concatMap (doRmWhites  (-offset)) (tail groupedToks) 
+ refactorer/RefacMerge.hs view
@@ -0,0 +1,849 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacMerge+-- Copyright   :  (c) Christopher Brown 2006+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Merging definitions together.+++module RefacMerge where+++import System.IO.Unsafe+import PrettyPrint+import RefacTypeSyn+import RefacLocUtils+-- import GHC (Session)+import Data.Char+import GHC.Unicode+import AbstractIO+import Maybe+import List+import RefacUtils+import RefacRedunDec+import SlicingUtils+import Directory+import LocalSettings++data FunEntity = Guard [HsPatP] [(SrcLoc, HsExpP, HsExpP)] [HsDeclP] PNT | Match [HsPatP] HsExpP [HsDeclP] PNT | Null+                   deriving (Eq, Show)+                   +type Fun = [ FunEntity ]++-- we can "pair" an arbitrary number of matches together so +-- we can't use a tuple. We don't know the number of +-- function to fuse!+type PairFun = [ Fun ]++refacMerge args+  = do +       let fileName     = args!!0+           name         = args!!1+       AbstractIO.putStrLn "refacMerge"+              +       fileContent <- AbstractIO.readFile mergeFilePath+       +       AbstractIO.removeFile mergeFilePath+       +       AbstractIO.putStrLn "Cache flushed."+              +       unless (isVarId name) +           $ error "The new name is invalid!\n"+       +       modName1 <- fileNameToModName fileName+       let modName = modNameToStr modName1+       +       modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName+       +       inscopeNames <- hsFDNamesFromInside mod+       unless (not (name `elem` ((\(x,y) -> x ++ y) inscopeNames)))+        $ error ("the use of the name: " ++ name ++ " is already in scope!")+       +       let parse = force (parseFile fileContent mod)+       let n = (parseName fileContent mod)+       let extractedDecs = map fst (map extractDecs parse)+       +       -- b is the boolean value for whether we+       -- are fusing together functions within a where clause or not.+       -- b == True  = not in where clause+       -- b == False = in where clause +       let b = or (map snd (map extractDecs parse))+       +       -- let extractedDecs' = pad extractedDecs+       +       newDecl <- doFusing fileName extractedDecs b parse modName mod name+              +       if b +         then do       +          res3 <- applyRefac (addDecls1 newDecl) (Just (inscps, exps, mod, tokList)) fileName+       +          writeRefactoredFiles True [res3]+          (inscps2, exps2, mod2, tokList2) <- parseSourceFile fileName              +          let fusedDecl = declToName newDecl+          let newRefactoredDecls1 = hsDecls mod2+          let newRefactoredDecls2 = definingDecls (map (declToPName [fusedDecl]) newRefactoredDecls1) newRefactoredDecls1 False False+          -- AbstractIO.putStrLn "parsed again"              +          sigs <- getSig fileName modName fusedDecl+                    +          res <- applyRefac (addTypes (map (declToPName [fusedDecl]) newRefactoredDecls1) [sigs]) (Just (inscps2, exps2, mod2, tokList2)) fileName+          -- AbstractIO.putStrLn $ show res+          writeRefactoredFiles True [res]+          (inscps5, exps5, mod5, tokList5) <- parseSourceFile fileName              +          --(mod',((tokList'',modified),_))<-(doCommenting ( (map (declToPName [fusedDecl]) newRefactoredDecls1))) fileName mod5 tokList5+          --writeRefactoredFiles True [((fileName, True), (tokList'', mod'))]+       +          AbstractIO.putStrLn "Completed."+          +         else do+          -- where clause+          +          -- recurse through each declaration selected.+          -- replace the RHS with a call to the newly+          -- created function+          let selectedDecs = map extractDecs' parse+                             +          res3 <- applyRefac (addDecls2 n newDecl) (Just (inscps, exps, mod, tokList)) fileName   +          +          writeRefactoredFiles True [res3]+          +          +          (inscps3, exps3, mod3, tokList3) <- parseSourceFile fileName+          -- +          -- AbstractIO.putStrLn $ show newMod+              +          res4 <- applyRefac (renameCallInSelected selectedDecs name) (Just (inscps3,exps3, mod3, tokList3)) fileName       +          +          writeRefactoredFiles True [res4]+          +          -- writeRefactoredFiles False [((fileName, m), (newToks, newMod))]        ++          AbstractIO.putStrLn "Completed."++doFusing fileName extractedDecs b parse  modName mod name+ = do+      (decl, newDecl) <- doFusing' fileName b extractedDecs parse modName mod name+           +      -- we need to recurse into the where clauses and perform+      -- a fusion if necessary.+      +      -- x <- fuseWheres decl modName mod ses1+      return decl++fuseExprs :: HsExpP -> HsExpP+fuseExprs exp@(Exp (HsTuple [e1,e2]))+ | (isFst e1 && isSnd e2) && (extractCall e1 == extractCall e2) = extractCall e1+ | otherwise = exp+                 where+                   isFst :: HsExpP -> Bool+                   isFst (Exp (HsInfixApp e1 o e2))+                     = (render.ppi) e1 == "fst"+                   isFst x = False+                   isSnd :: HsExpP -> Bool+                   isSnd (Exp (HsInfixApp e1 o e2))+                     = (render.ppi) e1 == "snd"+                   isSnd x = False+                   +                   extractCall :: HsExpP -> HsExpP+                   extractCall (Exp (HsInfixApp e1 s e2)) = e2+                   extractCall x = x+fuseExprs e = e+      +fuseWheres d@(Dec (HsFunBind loc0 ms)) modName mod ses1+ = do matches <- lookInMatches ms+      + +      return (Dec (HsFunBind loc0 matches))+   +       where+        lookInMatches [] = return ([]::[HsMatchP])+        lookInMatches (m@(HsMatch l n p exp@(HsBody exp'@(Exp (HsTuple [e,e1]))) ds):ms)+          = do+             let declNames = filter (/="") (map declToName ds)+             +             (inscopeNames, inscopeNames2) <- hsFDNamesFromInside d+             let name = ((expAppName e) ++ (expAppName e1))+             let newName = mkNewName name (inscopeNames ++ inscopeNames2) 1 +             AbstractIO.putStrLn $ show (expAppName e)             +             if (expAppName e) `elem` declNames && (expAppName e1) `elem` declNames+                then do+                +                   -- find the decl associated with e and e1+                   let decl1 = findDecl (expAppName e) ds+                   let decl2 = findDecl (expAppName e1) ds+                   +                   let extractedDecs = map extractDecs [Right (decl1, False), Right (decl2, False)]+                   +                   -- decl' <- doFusing extractedDecs False [Right decl1, Right decl2] modName ses1 mod newName+                   +                   newExp <- renameFusionInstances exp' newName (map declToPName2 (map extractDecs' [Right (decl1, False), Right (decl2,False)])) ++                   +                   rest <- lookInMatches ms+                   +                   -- createTypeSig (retieveTypeSig +                   +                   +                   -- return ((HsMatch l n p (HsBody newExp)+                   return ((HsMatch l n p (HsBody newExp) ds) : rest)+                   +                else do+                   AbstractIO.putStrLn (">" ++ (show e))+                   rest <- lookInMatches ms+                   +                   AbstractIO.putStrLn $ show rest+                   +                   return (m : rest)+                +        lookInMatches (m:ms)+         =  do +             rest <- lookInMatches ms+             return (m : rest)+         +        rmDecls :: [HsDeclP] -> (HsDeclP, HsDeclP) -> [HsDeclP] +        rmDecls [] _ = [] +        rmDecls (d@(Dec (HsTypeSig _ i _ _)):ds) (d1,d2)+         | declToPName2 d1 `elem` (map pNTtoPN i) = rmDecls ds (d1, d2)+         | declToPName2 d2 `elem` (map pNTtoPN i) = rmDecls ds (d1, d2)+         | otherwise = d : (rmDecls ds (d1, d2))+        rmDecls (d:ds) (d1, d2)+          | d == d1 = rmDecls ds (d1,d2)+          | d == d2 = rmDecls ds (d1,d2)+          | otherwise = d : (rmDecls ds (d1,d2))        +                +        findDecl :: String -> [HsDeclP] -> HsDeclP+        findDecl _ [] = error "error in findDecl!"+        findDecl name (d:ds) +          | (declToName d) == name      = d+          | otherwise                   = findDecl name ds    +                +        expAppName :: HsExpP -> String+        expAppName (Exp (HsApp e1 e2)) = expAppName e1 +        expAppName e@(Exp (HsId e1)) = pNtoName (expToPN e)+        expAppName x = ""+ ++doFusing' fileName b extractedDecs parse modName mod name+  = do+       let pairedDecs = pairMatches extractedDecs +       if b +        then do     +          converged <- isConvergeArguments fileName modName pairedDecs+          newRhs' <- mapM ( tidyLetClauses mod converged) pairedDecs+          let newDecl = createDecl newRhs' name+          decl' <- renameFusionInstances newDecl name (map declToPName2 (map extractDecs' parse)) +          return (decl', newDecl)+        else do+          newRhs' <- mapM ( tidyLetClauses mod True) pairedDecs+          let newDecl = createDecl newRhs' name+          decl' <- renameFusionInstances newDecl name (map declToPName2 (map extractDecs' parse)) +          return (decl', newDecl) +-- renameFusionInstances :: (MonadState (([PosToken], Bool), t1) m) => HsDeclP -> String -> PName -> m HsDeclP+renameFusionInstances d _ [] = error "No functions have been selected for fusion!"+renameFusionInstances d n [a,b]+  = do +       dec <- renamePNNoState' a ("fst $ " ++ n)  d+       dec2 <- renamePNNoState' b ("snd $ " ++n)  dec+       return dec2+renameFusionInstances _ _ (x:xs) = error "Only two functions may be fused together!"+       +force :: Eq a => a -> a+force x = if x == x then x else x++{- tidy up arrangments of let clauses.+   viz:+     f x y = (let ls = x + 1 in ls, let rs = y - 1 in rs)+     +     should be:+     +     f x y = let ls = x + 1 ; rs = y - 1 in (ls, rs) +     +     The idea is that it takes a list of expressions which are+     fused together to form a tuple -- or a list of let declarations+     and a tuple as a body.+     +     -}++isDupDec :: [String] -> Bool+isDupDec [] = False+isDupDec (x:xs) = (x `elem` xs) || (isDupDec xs)++getDupDec :: [String] -> String+getDupDec [] = ""+getDupDec (x:xs) + | x `elem` xs = x+ | otherwise   = getDupDec xs     +     +     +-- tidyLetClauses :: (Monad m, Term t) => t -> Bool -> Fun -> m FunEntity+tidyLetClauses _ _ [] = return Null+tidyLetClauses mod True (m@(Guard p (g@(s,e1,_):gs) ds pnt) : es)+ = do+      let allPats = extractPats' (m:es)+      if all (==(head allPats)) allPats+        then do+           let guards = filterGuards (m:es) +           let guards2 = map (map (\(x,y,z) -> y)) guards            +           let decs = map filterLet' guards+           let exps = pairExps (map filterExp' guards)     +           let guardExp = filterGuardExp (g:gs)        +           -- let (decs, exps) = (filterLet (m:es), (filterExp (m:es)))+           let ds' = filterDec (m:es)+           let dsNames = filter (/="") (map declToName2 ds')+           +           when (isDupDec dsNames) $ error ( "Please rename " ++ (getDupDec dsNames) ++ " as it conflicts during the merge." )+           +           when (all (/=(head guards2)) (tail guards2))+            $ error "The guards between the two functions do not match!"+           +           +           -- AbstractIO.putStrLn $ show (decs, length decs)+           +           if length (filter (/=[]) decs) > 0 +             then do+                 let returnGuard = createGuardLet guardExp decs exps+                 return (Guard p returnGuard ds' pnt)+             else do+                 let returnGuard = createGuard guardExp exps+                 return (Guard p returnGuard ds' pnt)+                 -- return (Match p gs' ds' pnt)+           +        else do+           error "The patterns between the functions are not the same set! The patterns must be the same and have the same type."+             where+              pairExps :: [ [HsExpP] ] -> [ (HsExpP, HsExpP) ]+              pairExps [] = []+              pairExps [x::[HsExpP],y::[HsExpP]] = zip x y+              pairExps x = error "Only two functions may be fused together!"+             +              createGuardLet :: [HsExpP] -> [ [HsDeclP] ] -> [ (HsExpP, HsExpP) ] -> [ (SrcLoc, HsExpP, HsExpP) ]+              createGuardLet [] [] [] = []+              createGuardLet (e:ess) (d:ds) ((x,y):es)+               = (s, e, (Exp (HsLet d (Exp (HsTuple (x:[y])))))) : (createGuardLet ess ds es)+              +              +              createGuard :: [HsExpP] -> [ (HsExpP, HsExpP) ] -> [ (SrcLoc, HsExpP, HsExpP) ]+              createGuard [] [] = []+              createGuard (e:ess) ((x,y):es) = (s,e, (Exp (HsTuple (x:[y])))) : (createGuard ess es)+                      +           +tidyLetClauses mod True (m@(Match p e ds pnt) : es)+  = do+       -- find Let Clauses+       let allPats = extractPats' (m:es)+       if all (==(head allPats)) allPats+         then do+       +           let (decs, exps) = (filterLet (m:es), filterExp (m:es))+           let ds' = filterDec (m:es)+           let dsNames = (filter (/="") (map declToName2 ds'))+           when (isDupDec dsNames) $ error ( "Please rename " ++ (getDupDec dsNames) ++ " as it conflicts during the merge." )+              +           if length decs > 0 +             then do+                 return (Match p (Exp (HsLet decs (Exp (HsTuple exps)))) ds' pnt)+             else do+                 return (Match p (Exp (HsTuple exps)) ds' pnt)+         else do+           error "The patterns between the functions are not the same set! The patterns must be the same and have the same type."+tidyLetClauses _ False _ = error "The types between the functions to be fused to do match. Please change the types first so that the arguments can converge."                   +{- tidyLetClauses mod False (m@(Match p e ds pnt) : es)+ = do+      let (decs, exps) = (filterLet (m:es), filterExp (m:es))+      if length decs > 0+        then do +                 let letExp = (Exp (HsLet decs (Exp (HsTuple exps))))+                 (params, exps', ds') <- renameArgs 1 (extractPats (m:es)) letExp ds mod+                 return (Match params exps' ds' pnt)+        else do+                 let letExp = (Exp (HsTuple exps))+                 (params, exps', ds') <- renameArgs 1 (extractPats (m:es)) letExp ds mod+                 return (Match params exps' ds' pnt) -}++                 +extractPats :: Fun -> [ [HsPatP] ]+extractPats [] = []+extractPats ((Match p _ _ _):ms) = p : (extractPats ms)+extractPats ((Guard p _ _ _):ms) = p : (extractPats ms)++extractPats' :: Fun -> [ [String] ]+extractPats' [] = []+extractPats' ((Match p _ _ _):ms) = (map pNtoName (hsPNs p)) : (extractPats' ms)+extractPats' ((Guard p _ _ _):gs) = (map pNtoName (hsPNs p)) : (extractPats' gs)++filterGuardExp :: [(SrcLoc, HsExpP, HsExpP)] -> [HsExpP]+filterGuardExp [] = []+filterGuardExp ((_,e,_):gs) = e : (filterGuardExp gs)++filterGuards :: Fun -> [ [(SrcLoc, HsExpP, HsExpP)] ]+filterGuards [] = []+filterGuards ((Guard _ g _ _):gs) = (rmAllLocs g) : (filterGuards gs)+filterGuards (m:ms) = filterGuards ms++filterDec :: Fun -> [HsDeclP]+filterDec [] = []+filterDec ((Match p e ds pnt):es)= ds ++ (filterDec es)+filterDec ((Guard p g ds pnt):es) = ds ++ (filterDec es)++filterLet' :: [ (SrcLoc, HsExpP, HsExpP) ] -> [HsDeclP]+filterLet' [] = []+filterLet' ((_, _, e@(Exp(HsLet ds _))):gs) = ds ++ (filterLet' gs)+filterLet' (g:gs) = filterLet' gs+++filterLet :: Fun  -> [HsDeclP]+filterLet [] = []+filterLet ((Match p e@(Exp (HsLet ds _)) _ pnt) : es) =  ds ++ (filterLet es)+filterLet ((Match p e ds pnt):es)= filterLet es+filterLet ((Guard p gs ds pnt):es) = (findLetInGuard gs) ++ (filterLet es)+                                    where+                                     findLetInGuard [] = []+                                     findLetInGuard ((_, _, (Exp (HsLet ds _))):gs)+                                       = ds ++ (findLetInGuard gs)+                                     findLetInGuard ((_,_, e):gs) = findLetInGuard gs++filterExp' :: [ (SrcLoc, HsExpP, HsExpP) ] -> [HsExpP]+filterExp' [] = []+filterExp' ((_,_, (Exp (HsLet _ e))):es) = e : (filterExp' es)+filterExp' ((_,_, e):es) = e : (filterExp' es)+++filterExp :: Fun -> [HsExpP]+filterExp [] = []+filterExp ((Match p (Exp (HsLet _ e)) ds pnt ): es) = e : (filterExp es)+filterExp ((Match p e ds pnt):es) = e : (filterExp es)+filterExp ((Guard p gs ds pnt):es) = (filterExpGuard gs) ++ (filterExp es)+                                      where+                                        filterExpGuard [] = []+                                        filterExpGuard ((_, _, (Exp (HsLet _ e))):gs) = e : (filterExpGuard gs) +                                        filterExpGuard ((_,_, e):gs) =  e : (filterExpGuard gs)++renameArgs index params rhs wheres t+ = do+      -- AbstractIO.putStrLn $ show (map toRelativeLocs (concat params))+      let dups = findDups (concat params)+      +      (newPats, newExps, newDS) <- doRenaming index dups (concat params) rhs wheres t      +      +      return (newPats, newExps, newDS)+      +doRenaming :: (Monad m, MonadPlus m, Term t) => Int -> [PName] -> [HsPatP] -> HsExpP -> [HsDeclP] -> t -> m ([HsPatP],HsExpP, [HsDeclP])+doRenaming _ [] a b c _ = return (a,b, c)+doRenaming index (p:ps) pats exps ds t+  = do+       -- names <- mapM (addName t) (concat exps)+      +       names <- addName t exps+      +       newPat <- mapM (renamePNNoState p names index) pats+       +       -- newExp <- mapM (mapListListM (renamePNNoState p (concat names) index)) exps+       +       newExp <- renamePNNoState p names index exps+       +       -- newDS <- mapM (mapListListM (renamePNNoState p names index)) ds+       +       newDS <- renamePNNoState p names index ds+       +       -- newExp <- mapM (renamePNNoState p name) exps+       +       rest <- doRenaming (index+1) ps newPat newExp newDS t+       +       return rest+       +addName mod e   = do+                   names <- hsVisibleNames e mod +                   return names++-- mapListListM :: [HsExpP] -> m [ [HsExpP] ]+mapListListM f e+  = mapM f e+   +renamePNNoState oldPN names index t+ = applyTP (full_tdTP (adhocTP idTP rename)) t+     where+       rename (pnt@(PNT pn ty (N (Just (SrcLoc fileName c row col)))))+        | (pn == oldPN) && (srcLoc oldPN == srcLoc pn)+           = return (PNT (replaceNameInPN Nothing pn (mkNewName (pNtoName oldPN) names index )) ty (N (Just (SrcLoc fileName c row col))))+       rename x = return x        ++renamePNNoState' oldPN name t+ = applyTP (full_tdTP (adhocTP idTP rename)) t+     where+       rename (pnt@(PNT pn ty (N (Just (SrcLoc fileName c row col)))))+        | (pn == oldPN) && (srcLoc oldPN == srcLoc pn)+           = return (PNT (replaceNameInPN Nothing pn name) ty (N (Just (SrcLoc fileName c row col))))+       rename x = return x +       +renameNameNoState' oldPN name t+ = applyTP (once_tdTP (adhocTP failTP rename)) t+     where+       rename (n::String)+        | n == oldPN+           = return name+       rename x = mzero+      +findDups :: [HsPatP] -> [PName]+findDups [] = []+findDups (x:xs)  -- do any elements of x occur through out xs?+  | pNtoName (patToPN x) `elem` (map (pNtoName.patToPN) xs) = (patToPN x) : findDups xs+  | otherwise   = findDups xs+++doCommenting (x:xs) fileName mod tokList +    =  runStateT (applyTP ((once_tdTP (failTP `adhocTP` (rmInMod (x:xs) )+                                              ))) mod)+                                                         ((tokList,unmodified),fileName)+                       +           where          +             --1. The definition to be removed is one of the module's top level declarations.+             rmInMod [] mod = return mod+             rmInMod (p:ps) (mod@(HsModule loc name exps imps ds):: HsModuleP)  +                = do ds'<-commentOutTypeSig p ds+                     res2 <- rmInMod ps (HsModule loc name exps imps ds')+                     return res2+  +addTypes _ [] (_,_,mod) = return mod+addTypes (x:xs) (y:ys) (a,b,mod) = do++                                      mod' <- addTypeSigDecl mod (Just x) ([y], Nothing) True +                                      +                                      -- commentOutTypeSig x (y:ys)                                   +                                      res <- addTypes xs ys (a,b,mod')+                                      return mod'     +++replaceInE :: (Monad m, MonadPlus m) => PNT -> String -> HsExpP -> m HsExpP+replaceInE origName newName e+  = applyTP (once_tdTP (adhocTP idTP rename')) e+     where+        rename' (e'@(Exp (HsId (HsVar x)))::HsExpP)+         | pNTtoName x == pNTtoName origName = return (Exp (HsId (HsVar (nameToPNT newName) )))+         | otherwise = return e'+        rename' e@(Exp (HsApp e1 e2))+         = do res1 <- rename' e1+              res2 <- rename' e2+              return (Exp (HsApp res1 res2))+        rename' e = return e+++cleanWhere :: (Monad m, MonadPlus m) => HsDeclP -> [PNT] -> String -> m HsDeclP+cleanWhere (Dec (HsPatBind loc p (HsBody e) ds)) names theName+    = do res2 <- (cleanWhere2 ds names theName)+         return (Dec (HsPatBind loc p (HsBody e) res2))+cleanWhere (Dec (HsFunBind loc (d:dss))) names theName+    = do res2 <- (cleanMatches (d:dss) names theName)+         return (Dec (HsFunBind loc res2)) +          where+             cleanMatches :: (Monad m, MonadPlus m) => [HsMatchP] -> [PNT] -> String  -> m [HsMatchP]+             cleanMatches [] _ _ = return []+             cleanMatches ((HsMatch l i1 ps (HsBody e) ds):ms) names theName+                = do res1 <- (cleanWhere2 ds names theName)+                     res2 <- (cleanMatches ms names theName)+                     return ((HsMatch l i1 ps (HsBody e) res1 ): res2) ++cleanWhere2 :: (Monad m, MonadPlus m) => [HsDeclP] -> [PNT] -> String -> m [HsDeclP]+cleanWhere2 [] _ _ = return []+cleanWhere2 x [] _ = return x+cleanWhere2 (de@(Dec (HsPatBind loc p (HsBody e) ds)):dss) (name:names) theName+ | pNTtoName (getNameFromExp e) == (pNTtoName name) = do newPats' <- newPats+                                                         newBody <- replaceInE (getNameFromExp e) theName e+                                                         let filteredDecs = filterDecs dss names+                                                         return ((Dec (HsPatBind loc newPats' (HsBody newBody) ds)):filteredDecs)+ | otherwise = do res <- (cleanWhere2 dss names theName)+                  return (de : res )+                                         where+                                          newPats = do res <- findRest dss names+                                                       return (Pat (HsPTuple loc0 (p: res)))+                                          findRest _ [] = return []+                                          findRest [] _ = return []+                                          findRest (de@(Dec (HsPatBind loc p (HsBody e) ds)):dss) (name:names)+                                           | pNTtoName (getNameFromExp e) == (pNTtoName name) = do res <- (findRest dss names)+                                                                                                   return (p : res)+                                           | otherwise = do res <- findRest dss names+                                                            return res+                                          filterDecs [] _ = []+                                          filterDecs (de@(Dec (HsPatBind loc p (HsBody e) ds)):dss) (name:names)+                                            | (getNameFromExp e) `elem` (name:names) = filterDecs dss (name:names)+                                            | otherwise = de : (filterDecs dss (name:names))+getNameFromExp (Exp (HsApp e1 e2))+ = getNameFromExp e1+getNameFromExp e1+ = expToPNT e1++addDecls1 x (_,_,mod) = do+                          mod' <- addDecl mod Nothing ([x], Nothing) True+                          return mod'+addDecls2 n x (_,_,mod) = do+                                 let newDec = convertExpr x+                                 mod' <- doAdding newDec n mod+                                 return mod' +                                  where+                                    doAdding x n mod = applyTP (once_tdTP (failTP `adhocTP` worker)) mod+                                      where+                                        worker (y::HsDeclP)+                                         | y == n = addDecl n Nothing ([x], Nothing) False+                                        worker _ = mzero ++convertExpr :: HsDeclP -> HsDeclP+convertExpr (Dec (HsPatBind loc0 pat (HsBody e) ds))+ = (Dec (HsPatBind loc0 pat (HsBody (fuseExprs e)) ds))+convertExpr (Dec (HsFunBind loc0 ms))+ = (Dec (HsFunBind loc0 (newMatches ms))) +     where+       newMatches [] = []+       newMatches (m@(HsMatch loc0 x pats (HsBody e) ds):ms)+             = (HsMatch loc0 x pats (HsBody (fuseExprs e)) ds) : (newMatches ms)+       newMatches (m:ms) = m : (newMatches ms)+convertExpr d = d             +renameCallInSelected [d1, d2] name (_,_,mod) +  = applyTP (stop_tdTP (failTP `adhocTP` worker)) mod+          where+              worker d@(Dec (HsPatBind loc0 pat (HsBody e) ds))+                  | d == d1 = do+                                 newDec <- update e (Exp (HsInfixApp (nameToExp "fst") (nameToIdent "$") (nameToExp name))) d+                                 return newDec++                  | d == d2 = do+                                 newDec <- update e (Exp (HsInfixApp (nameToExp "snd") (nameToIdent "$") (nameToExp name))) d+                                 return newDec+              worker d@(Dec (HsFunBind loc0 ms))+                  | d == d1 = do matches <- editMatches ms "fst"+                                 return (Dec (HsFunBind loc0 matches))+                  | d == d2 = do matches <- editMatches ms "snd"+                                 return (Dec (HsFunBind loc0 matches))+                                where+                                  editMatches [] _ = return []+                                  editMatches (m@(HsMatch loc0 _ pats (HsBody e) ds):ms') par+                                     = do+                                          let newPats = map (pNtoExp . patToPN) pats+                                          newMatch <- update e ((Exp (HsInfixApp (nameToExp par) (nameToIdent "$") (createFunc' (nameToExp name ) newPats  )   ))) m+                                          rest <- editMatches ms' par+                                          return (newMatch : rest)+              worker _ = mzero+                                        -- | y == n = addDecl n Nothing ([x], Nothing) False++                                 +createDecl :: Fun -> String -> HsDeclP+{-createDecl ((Match [] exps ds _):ms) name+    = (Dec (HsPatBind loc0 (nameToPat name) (HsBody exps) (concat ds))) -}   +createDecl (m:ms) name+    = (Dec (HsFunBind loc0 (createMatches (m:ms) )))+       where+        createMatches [] = []+        createMatches ((Guard p guards d _):gs)+          = +             (HsMatch loc0 (nameToPNT name) p (HsGuard guards) d) : (createMatches gs)+        createMatches ((Match p e d _):ms) +          =+             (HsMatch loc0 (nameToPNT name) p (HsBody e) d) : (createMatches ms)    ++extractDecs :: Either String (HsDeclP, Bool) -> (Fun, Bool)+extractDecs dec+  = do+       case dec of+         Left errMsg -> error errMsg+         Right (decl, b) -> extractDecl (decl, b)+         +extractDecs' :: Either String (HsDeclP, Bool) -> HsDeclP+extractDecs' dec+  = do+       case dec of+         Left errMsg -> error errMsg+         Right (decl,_) -> decl+ +        +-- pad :: [ [a] ] -> [ [a] ]+count list = maximum ( map length list )++pad list = map (pad' (count list)) list+             where +               pad' count entry = entry ++ (replicate count (head entry))   + +{- converge arguments attemps to converge the arguments of the pairs where ever possible.+   The selected functions must have the same set of patterns, if not then +   convergeArguments returns an error. Otherwise, the types of each function are taken, +   if the types match then only use the first set of arguments. Otherwise, do nothing.+   It is sensible to let the user instantiate patterns so that a more general instance converges+   with a more specific type. -}+   +{-+data FunEntity = Match [HsPatP] HsExpP [HsDeclP] PNT | Null+                   deriving (Eq, Show)+                   +type Fun = [ FunEntity ]++-- we can "pair" an arbitrary number of matches together so +-- we can't use a tuple. We don't know the number of +-- function to fuse!+type PairFun = [ Fun ] -}++-- convergeArguments :: (Monad m) => String -> GHC.Session -> PairFun -> m Bool+isConvergeArguments _ _ [] = return False+isConvergeArguments fileName modName (ent:ents)+ = do -- entType <- typeOf modName ses ent+      entsType <-typeOf fileName modName ent+      +      AbstractIO.putStrLn $ show entsType+      -- AbstractIO.putStrLn $ show (map hsPNs (settleTypes entsType))+      --let res = myAll (map pNtoName (map hsPNs (settleTypes entsType)))+      let res = myAll entsType      +      return res+        where+          -- myAll :: Eq a => [a] -> Bool+          myAll :: [ [String] ] -> Bool+          myAll [] = False +          myAll (l:ls) = all (==l) ls+          +settleType :: HsDeclP -> HsDeclP+settleType (Dec (HsTypeSig x _ y types))+    = (Dec (HsTypeSig x [] y types))++  +typeOf :: (Monad m) => String -> String -> [FunEntity] -> m [ [String] ]+typeOf fileName modName [] = return []+typeOf fileName modName (m:ms)+  = do+       sig <- getSigOmitLast modName (nameFromMatch m) fileName+       let sig' = hsPNs (settleType sig)+       let sig'' = map pNtoName sig'+       +       sigs <- typeOf fileName modName ms+       return (sig'' : sigs)++nameFromMatch :: FunEntity -> String+nameFromMatch  (Match _ _ _ pnt) = pNTtoName pnt+nameFromMatch Null = ""+++pairMatches :: [ Fun ] -> PairFun+pairMatches [] = []+pairMatches [ e] = [ e ]+pairMatches (e:es)+  = ((take 1 e) ++ (concat (map (take 1) es))) : (pairMatches (filter (/=[]) (((gtail "e" e):(map (drop 1) es)))))+  +++extractDecl :: (HsDeclP, Bool) -> (Fun, Bool)+-- extractDecl :: HsDeclP -> ( [[HsPatP]], [HsExpP], [HsDeclP] , PNT)+extractDecl (d@(Dec (HsPatBind loc p (HsBody e) ds)),b) = ([Match [] e ds (patToPNT p)],b)+extractDecl ((Dec (HsFunBind loc (d:dss ))),b) = (extractMatches (d:dss),b)+                                                  where +                                                   extractMatches [] = []+                                                   extractMatches ((HsMatch l i1 ps (HsBody e) ds):ms)+                                                                = (Match ps e ds i1) : extractMatches ms+                                                   extractMatches ((HsMatch l i1 ps (HsGuard g) ds):ms)+                                                                = (Guard ps g ds i1) : extractMatches ms+                                                   {-+                                                                          =  ((ps : ps2) , (e : e2) , (ds ++ ds2), i1)+                                                                              where+                                                                                (ps2, e2, ds2, _) = extractMatches ms    -}                            +                                 ++-- parseFile :: String -> HsModuleP -> [Either String (HsDeclP, Bool)]+parseName [] _ = error "error in parseName!"+parseName ('>':xs) mod =  checkCursor' fileName (read row) (read col) mod                  +                            where+                             (fileName, rest) = parseFileName xs+                             (row, rest2) = parseRow rest+                             (col, rest3) = parseCol rest2 +                                 +parseFile :: String -> HsModuleP -> [Either String (HsDeclP, Bool)]+parseFile [] _ = []+parseFile ('>':xs) mod =  (checkCursor fileName (read row) (read col) mod) : (parseFile (tail rest3) mod)                     +                            where+                             (fileName, rest) = parseFileName xs+                             (row, rest2) = parseRow rest+                             (col, rest3) = parseCol rest2 +                         +parseFileName :: String -> (String, String)+parseFileName [] = ([], [])+parseFileName xs = ((takeWhile (/= '<') xs), (dropWhile (/= '<') xs))     ++parseRow :: String -> (String, String)+parseRow [] = ([], [])+parseRow xs = ((takeWhile (/= '%') (tail xs')), dropWhile (/= '%') (tail xs'))   +                where+                 xs' = dropWhile (/= '%') xs                      ++parseCol :: String -> (String, String)+parseCol [] = ([], [])+parseCol xs = ((takeWhile (/= '&') (tail xs') ), dropWhile (/= '&') (tail xs') )   +                where+                 xs' = dropWhile (/= '&') xs +--check whether the cursor points to the beginning of the datatype declaration+--taken from RefacADT.hs+checkCursor :: String -> Int -> Int -> HsModuleP -> Either String (HsDeclP, Bool)+checkCursor fileName row col mod+ = case locToPName of+     (Nothing, _) -> Left ("Invalid cursor position. Please place cursor at the beginning of the definition!")+     (Just decl, b) -> Right (decl, b)+    where+        locToPName +         = case res of +             Nothing -> (find (definesPNT (locToPNT fileName (row, col) mod)) (hsDecls mod), True)+             _ -> (res, False)+        res =  find (defines (locToPN fileName (row, col) mod)) (concat (map hsDecls (hsModDecls mod)))+        +        definesPNT pnt d@(Dec (HsPatBind loc p e ds))+         = findPNT pnt d+        definesPNT pnt d@(Dec (HsFunBind loc ms)) +         = findPNT pnt d+        definesPNT _ _ = False++checkCursor' :: String -> Int -> Int -> HsModuleP -> HsDeclP+checkCursor' fileName row col mod+ = case locToPName of+     Nothing -> error "Invalid cursor position. Please place cursor at the beginning of the definition!"+     Just decl -> decl+    where+        locToPName = find (definesPNT (locToPNT fileName (row, col) mod)) (hsDecls mod)+        +        definesPNT pnt d@(Dec (HsPatBind loc p e ds))+         = findPNT pnt d+        definesPNT pnt d@(Dec (HsFunBind loc ms)) +         = findPNT pnt d+        definesPNT _ _ = False+    +{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++{-findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (SrcLoc, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+ -}                    +--find the definition name whose sub-expression has been selected, and the selected sub-expression.+findDefNameAndExp toks beginPos endPos t +  = fromMaybe (defaultPNT, defaultExp) (applyTU (once_tdTU (failTU `adhocTU` inMatch+                                                                   `adhocTU` inPat)) t)  --CAN NOT USE 'once_tdTU' here. ++     where  --The selected sub-expression is in the rhs of a match+           inMatch (match@(HsMatch loc1  pnt pats rhs ds)::HsMatchP)+             | locToExp2 beginPos endPos toks rhs /= defaultExp+             = Just (pnt, locToExp2 beginPos endPos toks rhs)+           inMatch _ = Nothing+        +           --The selected sub-expression is in the rhs of a pattern-binding+           inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+             | locToExp2 beginPos endPos toks rhs /= defaultExp+             = if isSimplePatBind pat+                then Just (patToPNT ps, locToExp2 beginPos endPos toks rhs)    +                else error "A complex pattern binding can not be generalised!"+           inPat _ = Nothing+    +    
+ refactorer/RefacMoveDef.hs view
@@ -0,0 +1,867 @@+++module RefacMoveDef(liftToTopLevel, liftOneLevel, demote,liftingInClientMod) where+import Prelude hiding (putStrLn)+import PrettyPrint+import Maybe+import List +import RefacUtils+import HsName+import AbstractIO++data Direction = UptoTopLevel | UpOneLevel | Down++{--------This function handles refactorings involving moving a defintion--------+ According to the Haskell's  syntax, a declaration may occur in one of the following six contexts:+  1. A top level declaration in the module:+            HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds+  2. A local declaration in a Match:+            HsMatch SrcLoc i [p] (HsRhs e) ds+  3. A local declaration in a pattern binding:+            HsPatBind SrcLoc p (HsRhs e) ds+  4. A local declaration in a Let expression:+            HsLet ds e+  5. A local declaration in a Case alternative:+            HsAlt SrcLoc p (HsRhs e) ds+  6. A local declaration in a Do statement:+            HsLetStmt ds (HsStmt e p ds)           +-}++liftToTopLevel args+ = do let  fileName = ghead "filename"  args +           row = read (args!!1)::Int+           col = read (args!!2)::Int+      -- f <-  MT.lift $ getCurrentDirectory +      modName <- fileNameToModName fileName +      (inscps, _, mod, toks) <- parseSourceFile fileName  +      let pnt = locToPNT fileName (row, col) mod                                         +          pn = pNTtoPN pnt+      if pn /= defaultPN+         then liftToTopLevel' modName fileName (inscps, mod, toks) pnt+         else error "\nInvalid cursor position!\n"++liftOneLevel args+ = do let  fileName = ghead "filename"  args +           row = read (args!!1)::Int+           col = read (args!!2)::Int+      modName <- fileNameToModName fileName +      (inscps, _, mod, toks) <- parseSourceFile fileName  +      let pnt = locToPNT fileName (row, col) mod                                         +          pn = pNTtoPN pnt+      if pn /= defaultPN+         then liftOneLevel' modName fileName (inscps, mod, toks) pnt+         else error "\nInvalid cursor position!\n"+++demote args+ = do let  fileName = ghead "filename"  args +           row = read (args!!1)::Int+           col = read (args!!2)::Int+      modName <- fileNameToModName fileName +      (inscps, _, mod, toks) <- parseSourceFile fileName  +      let pnt = locToPNT fileName (row, col) mod                                        +          pn = pNTtoPN pnt+      if pn /= defaultPN+         then demote' modName fileName (mod, toks) pn+         else error "\nInvalid cursor position!\n"++move direction args+  = do let fileName = ghead "filename"  args +           row = read (args!!1)::Int+           col = read (args!!2)::Int+       modName <- fileNameToModName fileName +       (inscps, _, mod, toks) <- parseSourceFile fileName  +       let pnt = locToPNT fileName (row, col) mod                                         +           pn = pNTtoPN pnt+       if pn /= defaultPN+         then +          case direction  of+               UptoTopLevel ->liftToTopLevel' modName fileName (inscps, mod, toks) pnt+               UpOneLevel   ->liftOneLevel'   modName fileName (inscps, mod, toks) pnt+               Down         ->demote'         modName fileName (mod, toks)  pn+          else error "\nInvalid cursor position!\n"+ ++{- Refactoring Names: 'liftToTopLevel'+   This refactoring lifts a local function/pattern binding to the top level of the module, so as to +    make it accessible to  other functions in the current module, and those modules that import +    current module.  +    +   In the current implementation, a definition will be lifted only if none of the identifiers defined in this+   definition will cause name clash/capture problems in the current module after lifting. ++   In the case that the whole current module is exported implicitly, the lifted identifier will be  exported+   automatically after lifting. If the identifier will cause name clash/ambiguous occurrence problem in a +   client module, it will be hided in the import declaration of the client module (Note: this might not be +   the best solution, we prefer hiding it in the server module instead of in the client module in the final version).++   In the case of indirect importing, it might be time-consuming to trace whether the lifted identifier+   will cause any problem in a client module that indirectly imports the current  module. The current solution is:+   suppose a defintion is lifted to top level in module A, and module A is imported and exported by module B, then+   the lifted identifier will be hided in the import declaration of B no matter whether it causes problems in +   module B or not.  + +   Function name: liftToTopLevel +   parameters: fileName--current file name. +               mod -- the scoped abstract syntax tree of the module.+               pn  -- the function/pattern name to be lifted.        +-}++liftToTopLevel' modName fileName (inscps, mod, toks) pnt@(PNT pn _ _)   +  = if isLocalFunOrPatName pn mod     +      then do ((mod',declPns),((toks',m),_))<-runStateT liftToMod ((toks,unmodified),(-1000,0))            +              if modIsExported mod  +               then do clients<-clientModsAndFiles modName  +                       refactoredClients <- mapM (liftingInClientMod modName declPns) clients+                       writeRefactoredFiles False $ ((fileName,m),(toks',mod')):refactoredClients                          +               else do writeRefactoredFiles False [((fileName,m), (toks',mod'))]+      else error "\nThe identifier is not a local function/pattern name!" +   +     where +          {-step1: divide the module's top level declaration list into three parts:+            'parant' is the top level declaration containing the lifted declaration,+            'before' and `after` are those declarations before and after 'parent'.+            step2: get the declarations to be lifted from parent, bind it to liftedDecls +            step3: remove the lifted declarations from parent and extra arguments may be introduce.+            step4. test whether there are any names need to be renamed. +          -}       +       liftToMod = do let (before, parent,after)=divideDecls (hsDecls mod) pnt                               +                      when (isClassDecl $ ghead "liftToMod" parent) +                            $ error "Sorry, the refactorer cannot lift a definition from a class declaration!"+                      when (isInstDecl $ ghead "liftToMod" parent)+                            $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!"+                      let liftedDecls=definingDecls [pn] parent True True+                          declaredPns=nub $ concatMap definedPNs liftedDecls                                         +                      pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns+                      (_,dd)<-hsFreeAndDeclaredPNs mod+                      if pns==[] +                        then do (parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl pn dd parent liftedDecls+                                let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls'+                                                                else liftedDecls'+                                mod'<-moveDecl1 (replaceDecls mod (before++parent'++after))+                                       (Just (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent')))) [pn] True+                                return (mod', declaredPns) +                        else askRenamingMsg pns "lifting"+++moveDecl1 t defName pns topLevel+   = do ((toks, _),_)<-get+        let (declToMove, toksToMove) = getDeclAndToks (ghead "moveDecl1" pns) True toks t+	--error$ show (declToMove, toksToMove)+        t' <- rmDecl (ghead "moveDecl3"  pns) False =<<foldM (flip rmTypeSig) t pns+        addDecl t' defName (declToMove, Just toksToMove) topLevel+         ++--get all the declarations define in the scope of t+allDeclsIn t = fromMaybe [] (applyTU (full_tdTU (constTU [] `adhocTU` decl)) t)               +               where decl (d::HsDeclP)+                       |isFunBind d || isPatBind d || isTypeSig d = Just [d]+                     decl _ = Just [] ++askRenamingMsg pns str +  = error ("The identifier(s):" ++ showEntities showPNwithLoc pns +++           " will cause name clash/capture or ambiguity occurrence problem after "+           ++ str ++", please do renaming first!")             ++--Get the subset of 'pns' that need to be renamed before lifting.+pnsNeedRenaming inscps dest parent liftedDecls pns+   =do r<-mapM pnsNeedRenaming' pns   +       return (concat r)+  where                 +     pnsNeedRenaming' pn+       = do (f,d)<-hsFDsFromInside dest  --f: free variable names that may be shadowed by pn+                                             --d: declaread variables names that may clash with pn+            vs<-hsVisiblePNs pn parent      --vs: declarad varaibles that may shadow pn          +            let inscpNames = map (\(x,_,_,_)->x) $ inScopeInfo inscps+                vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames            +            if elem (pNtoName pn) vars  || isInScopeAndUnqualified (pNtoName pn) inscps && findEntity pn dest +               then return [pn]+               else return []+     --This pNtoName takes into account the qualifier.+     pNtoName (PN (UnQual i) orig)=i    +     pNtoName (PN (Qual (PlainModule modName) i ) orig)=modName ++ "." ++ i        + +--can not simply use PNameToExp, PNameToPat here because of the location information. +addParamsToParent pn [] t = return t+addParamsToParent pn params t+   =applyTP(full_buTP (idTP  `adhocTP` inExp)) t +   where              +          inExp (exp@(Exp (HsId (HsVar (PNT pname ty loc))))::HsExpP)+            | pname==pn+             = do  let newExp=Exp (HsParen (foldl addParamToExp exp (map pNtoExp params)))+                   update exp newExp exp++          inExp x =return x                   +   +          addParamToExp  exp param+              =(Exp (HsApp exp param))  ++--Do refactoring in the client module.+-- that is to hide the identifer in the import declaration if it will cause any problem in the client module.++liftingInClientMod serverModName pns (modName, fileName)+  = do (inscps, exps ,mod ,ts) <- parseSourceFile fileName+       let modNames = willBeUnQualImportedBy serverModName mod   +       if isJust modNames+        then let pns' = namesNeedToBeHided mod exps (fromJust modNames) pns+             in if pns' /= [] +                 then do (mod', ((ts',m),_))<-runStateT (addHiding serverModName mod pns') ((ts,unmodified),(-1000,0))+                         return ((fileName,m), (ts',mod')) +                 else return ((fileName,unmodified), (ts,mod))+        else return ((fileName,unmodified),(ts,mod))+++--Test whether an identifier defined in the modules specified by 'names' will be exported by current module.+willBeExportedByClientMod names mod+  = let exps = hsModExports mod+    in if isNothing exps +          then False+          else any isJust $ map (\y-> (find (\x-> (simpModule x==Just y)) (fromJust exps))) names+      where simpModule (ModuleE (SN m _)) = Just m+            simpModule _  = Nothing ++--get the module name or alias name by which the lifted identifier will be imported automatically.+willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName]+willBeUnQualImportedBy modName mod+   = let imps  = hsModImports mod+         ms =filter (\(HsImportDecl _ (SN modName1 _) qualify  as h)->modName==modName1 && (not qualify) && +                          (isNothing h || (isJust h && ((fst (fromJust h))==True)))) imps+         in if ms==[] then Nothing+                      else Just $ nub $ map getModName ms++         where getModName (HsImportDecl _ (SN modName _) qualify  as h)+                 = if isJust as then simpModName (fromJust as)+                                else modName+               simpModName (SN m loc) = m++--get the subset of 'pns', which need to be hided in the import declaration in module 'mod'+namesNeedToBeHided mod exps modNames  pns+  = if willBeExportedByClientMod modNames mod+      then pns +      else concatMap needToBeHided pns+    where+      needToBeHided  pn +        = let name = pNtoName pn +          in if (usedWithoutQual name (hsModDecls mod) --the same name is used in the module unqualifiedly+                || usedWithoutQual name (hsModExports mod)  --the same name is exported unqualifiedly by an Ent decl+                || causeNameClashInExports pn name mod exps)+              then [pn] +              else []+++-- **************************************************************************************************************--++{- Refactoring Names: 'liftOneLevel'+   Descritption:+    this refactoring lifts a local function/pattern binding only one level up. +    By 'lifting one-level up' ,I mean: +    case1: In a module (HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds):+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the +           where clause of one of ds's element declaration.++    case2: In a match ( HsMatch SrcLoc i [p] (HsRhs e) ds) :+          A local declaration D  will be lifted to the same level as the 'ds', if D is in the +           where clause of one of ds's element declaration.+           A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to+           other declaration list in 'e'++    case3: In a pattern  binding (HsPatBind SrcLoc p (HsRhs e) ds):+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the +           where clause of one of ds's element declaration.+           A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to+           other declaration list in 'e'++    case4: In the Lex expression (Exp (HsLet ds e):+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the +           where clause of one of ds's element declaration.+           A declaration D, say, in the expression 'e' will be lifted to 'ds' if D is not local to+           other declaration list in 'e'+    case5: In the case Alternative expression:(HsAlt loc p rhs ds)+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the +           where clause of one of ds's element declaration.+           A declaration D in 'rhs' will be lifted to 'ds' if D is not local to other declaration +           list in 'rhs'.++    case6: In the do statement expression:(HsLetStmt ds stmts)+           A local declaration D  will be lifted to the same level as the 'ds', if D is in the +           where clause of one of ds's element declaration.+           A declaration D in 'stmts' will be lifted to 'ds' if D is not local to other declaration +           list in 'stmts'.           +    +Function name: liftOneLevel +parameters: fileName--current file name.+            mod -- the scoped abstract syntax tree of the module.+            pn  -- the function/pattern name to be lifted.+       +-}++liftOneLevel' modName fileName (inscps, mod, toks) pnt@(PNT pn _ _ )   +   = if isLocalFunOrPatName pn mod+        then do (mod', ((toks',m),_))<-liftOneLevel''            +                let (b, pns) = liftedToTopLevel pnt mod+                if b &&  modIsExported mod  +                  then do clients<-clientModsAndFiles modName +                          refactoredClients <- mapM (liftingInClientMod modName pns) clients+                          -- ePutStrLn (show clients)+                          writeRefactoredFiles False $ ((fileName,m),(toks',mod')):refactoredClients     +                  else writeRefactoredFiles False [((fileName,m), (toks',mod'))]+        else error "\nThe identifer is not a function/pattern name!"++   where+      liftOneLevel''=runStateT (applyTP ((once_tdTP (failTP `adhocTP` liftToMod+                                                            `adhocTP` liftToMatch+                                                            `adhocTP` liftToPattern +                                                            `adhocTP` liftToLet+                                                             `adhocTP` liftToAlt+                                                            `adhocTP` liftToLetStmt))+                                          `choiceTP` failure) mod) ((toks,unmodified),(-1000,0))+           where          +             --1. The defintion will be lifted to top level+             liftToMod (mod@(HsModule loc name exps imps ds):: HsModuleP)   +                | definingDecls [pn] (hsDecls ds) False False /=[]  --False means not taking type signature into account +                  =do ds'<-worker mod ds pn +                      return (HsModule loc name exps imps ds')+             liftToMod  _ =mzero+         +             --2. The definition will be lifted to the declaration list of a match+             liftToMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+                 | definingDecls [pn] (hsDecls ds) False False/=[] +                  =do ds'<-worker match ds pn            +                      return (HsMatch loc1 name pats rhs ds')++             liftToMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+                 | definingDecls [pn] (hsDecls rhs) False False /=[] +                  = doLifting1 match pn    +             liftToMatch _ =mzero++             --3. The definition will be lifted to the declaration list of a pattern binding +             liftToPattern (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+                | definingDecls [pn] (hsDecls ds) False  False /=[] +                  =do ds'<-worker pat ds pn +                      return (Dec (HsPatBind loc p rhs ds'))++             liftToPattern (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+                | definingDecls [pn] (hsDecls rhs) False  False /=[] +                  =doLifting2 pat  pn +             liftToPattern _=mzero++             --4. The definition will be lifted to the declaration list in a let expresiion.+             liftToLet (letExp@(Exp (HsLet ds e))::HsExpP)+               | definingDecls [pn] (hsDecls ds) False  False/=[] +                =do ds' <-worker letExp ds pn  +                    return (Exp (HsLet ds' e))++             liftToLet (letExp@(Exp (HsLet ds e))::HsExpP)  --Attention: ds can be empty!+               | definingDecls [pn] (hsDecls e) False  False /=[] +                = doLifting3 letExp pn  +             liftToLet _ =mzero + +           +             --5. The definition will be lifted to the declaration list in a alt+             liftToAlt (alt@(HsAlt loc p rhs ds)::(HsAlt (HsExpP) (HsPatP) [HsDeclP]))+                |definingDecls [pn] (hsDecls ds) False  False /=[] +                =do ds'<-worker alt ds pn +                    return (HsAlt loc p rhs ds')++             liftToAlt (alt@(HsAlt loc p rhs ds)::(HsAlt (HsExpP) (HsPatP) [HsDeclP]))+                |definingDecls [pn] (hsDecls rhs) False  False/=[] +                =doLifting4  alt  pn+             liftToAlt _=mzero++             --6. The defintion will be lifted to the declaration list in a let statement.+             liftToLetStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP]))+                |definingDecls [pn] (hsDecls ds) False  False/=[] +               =do ds'<-worker letStmt ds pn  +                   return (HsLetStmt ds' stmts)+              +             liftToLetStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP])) +                |definingDecls [pn] (hsDecls stmts) False False /=[] +               = doLifting5 letStmt pn +             liftToLetStmt _=mzero++             failure=idTP `adhocTP` mod+                where+                  mod (m::HsModuleP)+                   = error ( "Lifting this definition failed. "+++                           " This might be because that the definition to be lifted is defined in a class/instance declaration.")++             worker dest ds pn+                  =do let (before, parent,after)=divideDecls ds pnt                                    +                          liftedDecls=definingDecls [pn] (hsDecls parent) True  False+                          declaredPns=nub $ concatMap definedPNs liftedDecls+                      (_, dd)<-hsFreeAndDeclaredPNs dest +                      pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns+                      if pns==[]+                        then do +                                (parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl pn dd+                                                                     parent liftedDecls +                                let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls'+                                                                else liftedDecls'+                                --True means the new decl will be at the same level with its parant. +                                dest'<-moveDecl1 (replaceDecls dest (before++parent'++after))+                                           (Just (ghead "liftToMod" (definedPNs (ghead "worker" parent')))) [pn] False+                                return (hsDecls dest')+                                --parent'<-doMoving declaredPns (ghead "worker" parent) True  paramAdded parent'+                                --return (before++parent'++liftedDecls''++after)+                        else askRenamingMsg pns "lifting"++             doLifting1 dest@(HsMatch loc1 name pats parent ds)  pn +               = do  let  liftedDecls=definingDecls [pn] (hsDecls parent) True  False+                          declaredPns=nub $ concatMap definedPNs liftedDecls+                     pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns+                     (_, dd)<-hsFreeAndDeclaredPNs dest +                     if pns==[]+                       then do (parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl pn dd parent liftedDecls+                               let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls'+                                                                else liftedDecls'+                               moveDecl1 (HsMatch loc1 name pats parent' ds) Nothing [pn] False +                        else askRenamingMsg pns "lifting"+             doLifting2 dest@(Dec (HsPatBind loc p parent ds)) pn +               = do  let  liftedDecls=definingDecls [pn] (hsDecls parent) True  False+                          declaredPns=nub $ concatMap definedPNs liftedDecls+                     pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns+                     (_, dd)<-hsFreeAndDeclaredPNs dest +                     if pns==[]+                       then do (parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl pn dd parent liftedDecls+                               let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls'+                                                                else liftedDecls'+                               moveDecl1 (Dec (HsPatBind loc p parent' ds)) Nothing [pn] False +                         else askRenamingMsg pns "lifting"+                                +             doLifting3 dest@(Exp (HsLet ds parent)) pn +               = do  let  liftedDecls=definingDecls [pn] (hsDecls parent) True  False+                          declaredPns=nub $ concatMap definedPNs liftedDecls+                     pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns+                     (_, dd)<-hsFreeAndDeclaredPNs dest +                     if pns==[]+                       then do (parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl pn dd parent liftedDecls+                               let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls'+                                                                else liftedDecls'+                               moveDecl1 (Exp (HsLet ds parent')) Nothing [pn] False +                         else askRenamingMsg pns "lifting"++             doLifting4 dest@(HsAlt loc p parent ds) pn +               = do  let  liftedDecls=definingDecls [pn] (hsDecls parent) True  False+                          declaredPns=nub $ concatMap definedPNs liftedDecls+                     pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns+                     (_, dd)<-hsFreeAndDeclaredPNs dest +                     if pns==[]+                       then do (parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl pn dd parent liftedDecls+                               let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls'+                                                                else liftedDecls'+                               moveDecl1 (HsAlt loc p parent' ds) Nothing [pn] False +                         else askRenamingMsg pns "lifting"+             doLifting5 dest@(HsLetStmt ds parent) pn +               = do  let  liftedDecls=definingDecls [pn] (hsDecls parent) True  False+                          declaredPns=nub $ concatMap definedPNs liftedDecls+                     pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns+                     (_, dd)<-hsFreeAndDeclaredPNs dest +                     if pns==[]+                       then do (parent',liftedDecls',paramAdded)<-addParamsToParentAndLiftedDecl pn dd parent liftedDecls+                               let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls'+                                                                else liftedDecls'+                               moveDecl1 (HsLetStmt ds parent') Nothing [pn] False +                         else askRenamingMsg pns "lifting"+                                 +++liftedToTopLevel pnt@(PNT pn _ _) (mod@(HsModule loc name exps imps ds):: HsModuleP)  +  = if definingDecls [pn] (hsDecls ds) False True /=[] +     then let (_, parent,_) = divideDecls ds pnt+              liftedDecls=definingDecls [pn] (hsDecls parent) True True                                 +              declaredPns  = nub $ concatMap definedPNs liftedDecls+          in (True, declaredPns)+     else (False, [])++addParamsToParentAndLiftedDecl pn dd parent liftedDecls+  =do  (ef,_)<-hsFreeAndDeclaredPNs parent+       (lf,_)<-hsFreeAndDeclaredPNs liftedDecls   +       let newParams=((nub lf)\\ (nub ef)) \\ dd  --parameters (in PName format) to be added to pn because of lifting+       if newParams/=[]  +         then if  (any isComplexPatBind' liftedDecls)+                then error "This pattern binding cannot be lifted, as it uses some other local bindings!"+                else do parent'<-{-addParamsToDecls parent pn newParams True-} addParamsToParent pn newParams parent+                        liftedDecls'<-addParamsToDecls liftedDecls pn newParams True +                        return (parent', liftedDecls',True)+         else return (parent,liftedDecls,False)++isComplexPatBind' (Dec (HsPatBind _ p _ _)) = isPatID p+isComplexPatBind' d = False++isPatID (Pat (HsPId (HsVar pnt))) = False+isPatID p = True+--------------------------------End of Lifting-----------------------------------------++{-Refactoring : demote a function/pattern binding(simpe or complex) to the declaration where it is used.+  Descritption: if a declaration D, say, is only used by another declaration F,say, then D can be +                demoted into the local declaration list (where clause) in F.+                So currently, D can not be demoted if more than one declaration use it. +                +                In a multi-module context, a top-level definition can not be demoted if it is used+                by other modules. In the case that the demoted identifer is in the hiding list of+                import declaration in a client module, it should be removed from the hiding list.++ Function name:demote+ parameters: fileName--current file name.+             mod -- the scoped abstract syntax tree of the module.+             pn  -- the function/pattern name to be demoted.+       +-}++demote' modName fileName (mod,toks) pn+  =if isFunOrPatName pn mod +    then if isTopLevelPN pn && isExplicitlyExported pn mod +          then error "This definition can not be demoted, as it is explicitly exported by the current module!"+          else do (mod',((toks',m),_))<-doDemoting pn fileName mod toks+                  if isTopLevelPN pn && modIsExported mod  +                    then do let demotedDecls'= definingDecls [pn] (hsDecls mod) True False+                                declaredPns  = nub $ concatMap definedPNs demotedDecls'+                            clients<-clientModsAndFiles modName+                            refactoredClients <-mapM (demotingInClientMod declaredPns) clients+                            writeRefactoredFiles False $ ((fileName,m),(toks',mod')):refactoredClients     +                    else writeRefactoredFiles False [((fileName,m), (toks',mod'))]+    else error "\nInvalid cursor position!"+++--Do refactoring in the client module, that is:+--a) Check whether the identifier is used in the module body+--b) If the identifier is not used but is hided by the import declaration, then remove it from the hiding.++demotingInClientMod pns (modName, fileName)+  = do (inscps, exps, mod ,ts) <- parseSourceFile fileName+       if any (\pn->findPN pn (hsModDecls mod) || findPN pn (hsModExports mod)) pns+          then error $ "This definition can not be demoted, as it is used in the client module '"++show modName++"'!"+          else if any (\pn->findPN pn (hsModImports mod)) pns +                  then do (mod',((ts',m),_))<-runStateT (rmItemsFromImport mod pns) ((ts,unmodified),(-1000,0))+                          return ((fileName,m), (ts',mod'))+                  else return ((fileName,unmodified), (ts,mod)) +++doDemoting  pn fileName mod toks+ =runStateT (applyTP ((once_tdTP (failTP `adhocTP` demoteInMod+                                         `adhocTP` demoteInMatch +                                         `adhocTP` demoteInPat+                                         `adhocTP` demoteInLet+                                         `adhocTP` demoteInAlt+                                         `adhocTP` demoteInStmt)) `choiceTP` failure) mod)+                     ((toks,unmodified),(-1000,0))+    where+       --1. demote from top level+       demoteInMod (mod@(HsModule loc name exps imps ds):: HsModuleP)  +         |definingDecls [pn] ds False False /=[] +         = do mod'<-rmQualifier [pn] mod +              doDemoting' mod' pn+       demoteInMod _ =mzero+       +        --2. The demoted definition is a local decl in a match  +       demoteInMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+         | definingDecls [pn] ds False False/=[] +         = doDemoting' match pn+       demoteInMatch  _ =mzero++       --3. The demoted definition is a local decl in a pattern binding+       demoteInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+         | definingDecls [pn] ds False False /=[] +          = doDemoting' pat pn           +       demoteInPat _ =mzero++       --4: The demoted definition is a local decl in a Let expression+       demoteInLet (letExp@(Exp (HsLet ds e))::HsExpP)+         | definingDecls [pn] ds False False/=[] +          = doDemoting' letExp pn+       demoteInLet _=mzero+                +       --5. The demoted definition is a local decl in a case alternative.+       demoteInAlt (alt@(HsAlt loc p rhs ds)::(HsAlt (HsExpP) (HsPatP) [HsDeclP]))+         | definingDecls [pn] ds False False /=[] +          = doDemoting'  alt pn+       demoteInAlt _=mzero+      +       --6.The demoted definition is a local decl in a Let statement.+       demoteInStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP]))+         | definingDecls [pn] ds False False /=[] +          = doDemoting' letStmt pn+       demoteInStmt _=mzero++       failure=idTP `adhocTP` mod+             where+               mod (m::HsModuleP)+                = error "Refactoring failed!"   --SHOULD GIVE MORE DETAILED ERROR MESSAGE+     +{- doDemoting' :(MonadPlus m)=>PName->[HsDeclP]->m [HsDeclP] +   parameters:  t -declaration or expression  where pn is define.+                pn -- the function/pattern name to be demoted in PName format    +            +-}+doDemoting' t pn + = let origDecls=hsDecls t+       demotedDecls'=definingDecls [pn] origDecls True False+       declaredPns=nub $ concatMap definedPNs demotedDecls'+       demotedDecls=definingDecls declaredPns origDecls True False+   in if not (usedByRhs t declaredPns)+       then do -- find how many matches/pattern bindings (except the binding defining pn) use 'pn' +              uselist<-uses declaredPns (hsDecls t\\demotedDecls)+                      {- From 'hsDecls t' to 'hsDecls t \\ demotedDecls'. +                         Bug fixed 06/09/2004 to handle direct recursive function.+                       -}+              case  length uselist  of+                  0 ->do error "\n Nowhere to demote this function!\n"+                  1 -> --This function is only used by one friend function +                      do (f,d)<-hsFreeAndDeclaredPNs demotedDecls +                          -- remove demoted declarations+                         --Without updating the token stream.+                         let ds=foldl (flip removeTypeSig) (hsDecls t\\demotedDecls) declaredPns  +                         --get those varaibles declared at where the demotedDecls will be demoted to+                         dl  <-mapM (flip declaredNamesInTargetPlace ds) declaredPns+                         --make sure free variable in 'f' do not clash with variables in 'dl', +                         --otherwise do renaming. +                         let clashedNames=filter (\x-> elem (pNtoName x) (map pNtoName f)) $ (nub.concat) dl+                         --rename clashed names to new names created automatically,update TOKEN STREAM as well.+                         if clashedNames/=[] +                            then error ("The identifier(s):" ++ showEntities showPNwithLoc clashedNames +++                                       ", declared in where the definition will be demoted to, will cause name clash/capture"+                                       ++" after demoting, please do renaming first!")  +                                 --ds'<-foldM (flip (autoRenameLocalVar True)) ds clashedNames+                            else  --duplicate demoted declarations to the right place.+                                 do ds''<-duplicateDecls declaredPns origDecls +                                    return (replaceDecls t ds'')+                  _ ->error "\nThis function/pattern binding is used by more than one friend bindings\n"+                       +      else error "This function can not be demoted as it is used in current level!\n"            +    where+          ---find how many matches/pattern bindings use  'pn'------- +          uses pns +               = applyTU (stop_tdTU (failTU `adhocTU` usedInMatch+                                            `adhocTU` usedInPat))                           +                where+                  usedInMatch (match@(HsMatch _ (PNT pname _ _) _ _ _)::HsMatchP)+                     | isNothing (find (==pname) pns) && any  (flip findPN match) pns+                     =return ["Once"]+                  usedInMatch _ =mzero++                  usedInPat (pat@(Dec (HsPatBind _ p _ _)):: HsDeclP)+                    | hsPNs p `intersect` pns ==[]  && any  (flip findPN pat) pns+                    =return ["Once"]+                  usedInPat  _=mzero ++          -- duplicate demotedDecls to the right place (the outer most level where it is used).+          duplicateDecls  pns decls+             = do applyTP (once_tdTP (failTP `adhocTP` dupInMatch +                                             `adhocTP` dupInPat)) decls+                  --error (show decls' ++ "\n" ++ prettyprint decls')+                  -- rmDecl (ghead "moveDecl3"  pns) False =<<foldM (flip rmTypeSig) decls' pns +               where +                 dupInMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+                   | any (flip findPN match) pns && not (any (flip findPN name) pns)+                   =  --If not fold parameters. +                      moveDecl pns match False decls False+                      -- If fold parameters.+                      --foldParams pns match decls +                 dupInMatch _ =mzero+     +                 dupInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+                    |any (flip findPN pat) pns && not (any (flip findPN pat) pns)+                   =  moveDecl pns pat False decls False+                 dupInPat _ =mzero  +              +                 demotedDecls=definingDecls pns decls True False+          ---------------------------------------------------------------------+          declaredNamesInTargetPlace :: (Term t, MonadPlus m)=>PName->t->m [PName]+          declaredNamesInTargetPlace pn=applyTU (stop_tdTU (failTU +                                                    `adhocTU` inMatch  +                                                    `adhocTU` inPat))                            +               where+                 inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+                    | findPN pn rhs+                     =(return.snd)=<<hsFDsFromInside match +                 inMatch _ =mzero++                 inPat (pat@(Dec (HsPatBind loc p rhs ds)):: HsDeclP)+                    |findPN pn rhs+                     =(return.snd)=<<hsFDsFromInside pat +                 inPat _=mzero  ++class (Term t) =>UsedByRhs t where+  +    usedByRhs:: t->[PName]->Bool++instance UsedByRhs HsExpP where+    usedByRhs (Exp (HsLet ds e)) pns = or $ map (flip findPN e) pns++instance UsedByRhs HsAltP where+    usedByRhs (HsAlt _ _ rhs _) pns  =or $ map (flip findPN rhs) pns ++instance UsedByRhs HsStmtP where+    usedByRhs (HsLetStmt _ stmt) pns =or $ map (flip findPN stmt) pns  ++instance UsedByRhs HsMatchP where   +    usedByRhs (HsMatch loc1 fun pats rhs ds) pns =or $ map (flip findPN rhs) pns   +           +instance UsedByRhs  HsDeclP where+    usedByRhs (Dec (HsPatBind loc p rhs ds)) pns =or $ map (flip findPN rhs) pns               +    usedByRhs _ pn=False++instance UsedByRhs HsModuleP where+    usedByRhs mod pns=False+++{- foldParams:remove parameters in the demotedDecls if possible+   parameters: pn -- the function/pattern name to be demoted in PName format+               match--where the demotedDecls will be demoted to+               demotedDecls -- the declarations to be demoted.+   example:+    module Test where        demote 'sq'       module Test where+    sumSquares x y               ===>          sumSquares x y =(sq 0) + (sq y) +      = sq x 0+ sq x y                               where sq y=x ^ y+    sq x y=x^y+-}+--PROBLEM: TYPE SIGNATURE SHOULD BE CHANGED.+--- TEST THIS FUCNTION!!!+foldParams pns (match@(HsMatch loc1 name pats rhs ds)::HsMatchP) decls  +     =do let matches=concatMap matchesInDecls demotedDecls+             pn=ghead "foldParams" pns    --pns /=[]+         params<-allParams pn rhs []+         if (length.nub.map length) params==1                  -- have same number of param +             && ((length matches)==1)      -- only one 'match' in the demoted declaration             +           then do let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches+                       subst=mkSubst patsInDemotedDecls params+                       fstSubst=map fst subst+                       sndSubst=map snd subst+                   rhs'<-rmParamsInParent pn sndSubst rhs+                   ls<-mapM hsFreeAndDeclaredPNs sndSubst+                   -- newNames contains the newly introduced names to the demoted decls---+                   let newNames=(map pNtoName (concatMap fst ls)) \\ (map pNtoName fstSubst)+                   --There may be name clashing because of introducing new names.+                   clashedNames<-getClashedNames fstSubst newNames (ghead "foldParams" matches)+                  {- --auotmatic renaming +                   demotedDecls'<-foldM (flip (autoRenameLocalVar True)) demotedDecls clashedNames+                   demotedDecls''<- foldM replaceExpWithUpdToks demotedDecls' subst +                   --remove substituted parameters in demoted declarations+                   demotedDecls'''<-rmParamsInDemotedDecls fstSubst demotedDecls'' -}+                   decls' <- foldInDemotedDecls pns clashedNames subst decls+                   let demotedDecls''' = definingDecls pns decls' True False+                   moveDecl pns (HsMatch loc1 name pats rhs' ds) False decls' False                  +                   return (HsMatch loc1 name pats rhs' (ds++(filter (not.isTypeSig) demotedDecls''')))+           else  do  moveDecl pns match False decls True+                     return (HsMatch loc1 name pats rhs (ds++demotedDecls))  -- no parameter folding ++    where  ++       matchesInDecls ((Dec (HsFunBind loc matches))::HsDeclP)=matches+       matchesInDecls x = []     +         +       patsInMatch ((HsMatch loc1 name pats rhs ds)::HsMatchP)+         =pats++       demotedDecls=definingDecls pns decls True False+           ++       foldInDemotedDecls  pns clashedNames subst decls+          = applyTP (stop_tdTP (failTP `adhocTP` worker)) decls  +          where+          worker (match@(HsMatch loc1 (PNT pname _ _) pats rhs ds)::HsMatchP)+            | isJust (find (==pname) pns) +            = do match' <- foldM (flip (autoRenameLocalVar True)) match clashedNames+                 match'' <- foldM replaceExpWithUpdToks match' subst+                 rmParamsInDemotedDecls (map fst subst) match''++          worker _ = mzero+                    ++      ------Get all of the paramaters supplied to pn --------------------------- +            {- eg. sumSquares x1 y1 x2 y2 = rt x1 y1 + rt x2 y2+                   rt x y = x+y+              demote 'rt' to 'sumSquares',+              'allParams pn rhs []'  returns [[x1,x2],[y1,y2]]+                where pn is 'rt' and  rhs is 'rt x1 y1 + rt x2 y2'             +           -}+       allParams pn rhs initial  -- pn: demoted function/pattern name.+        =do p<-getOneParam pn rhs+            --putStrLn (show p)+            if p/=[] then do rhs'<-rmOneParam pn rhs+                             allParams pn rhs' (initial++[p])           +                     else return initial+        where+           getOneParam pn +              =applyTU (stop_tdTU (failTU `adhocTU` worker))+                where+                  worker (Exp (HsApp e1 e2))+                   |(expToPN e1==pn) =return (rmLocs [e2])+                  worker _ =mzero+           rmOneParam pn+              =applyTP (stop_tdTP (failTP `adhocTP` worker))+                where+                  worker (Exp (HsApp e1 e2 ))+                    |expToPN e1==pn =return e1+                  worker _ =mzero+      +       -----------remove parameters in demotedDecls-------------------------------+       rmParamsInDemotedDecls ps +         =applyTP (once_tdTP (failTP `adhocTP` worker))  +            where worker ((HsMatch loc1 name pats rhs ds)::HsMatchP)+                    = do let pats'=filter (\x->not ((patToPN x /=defaultPN) && +                                          elem (patToPN x) ps)) pats+                         pats'<-update pats pats' pats                            +                         return (HsMatch loc1 name pats' rhs ds)++    +       ----------remove parameters in the parent functions' rhs-------------------+       --Attention: PNT i1 _ _==PNT i2 _ _ = i1 =i2 +       rmParamsInParent  pn es+         =applyTP (full_buTP (idTP `adhocTP` worker))+            where worker exp@(Exp (HsApp e1 e2))+                   | findPN pn e1 && elem e2 es+                      =update exp e1 exp                      +                  worker (exp@(Exp (HsParen e1)))+                    |pn==expToPN e1+                       =update exp e1 exp+                  worker x =return x +            +       getClashedNames oldNames newNames (match::HsMatchP)+         = do  (f,d)<-hsFDsFromInside match +               ds'<-mapM (flip hsVisiblePNs match) oldNames+               -- return clashed names+               return (filter (\x->elem (pNtoName x) newNames)  --Attention: nub+                                   ( nub (d `union` (nub.concat) ds')))+       ----- make Substitions between formal and actual parameters.-----------------+       mkSubst pats params+           = catMaybes (zipWith (\x y ->if (patToPN x/=defaultPN) && (length (nub y)==1)+                            then Just (patToPN x,(ghead "mkSubst") y)+                            else Nothing) pats params)  +     ++--substitute an old expression by new expression+replaceExpWithUpdToks  decls subst+   = applyTP (full_buTP (idTP `adhocTP` worker)) decls+         where worker (e::HsExpP)+                 |(expToPN e/=defaultPN) &&  (expToPN e)==(fst subst)+                     =update e (snd subst) e                      +               worker x=return x +++--return True if pn is a local function/pattern name+isLocalFunOrPatName pn scope+ =isLocalPN pn && isFunOrPatName pn scope+++-- |removeTypeSig removes the signature declaraion for pn from the decl list.+removeTypeSig ::PName->[HsDeclP]->[HsDeclP]+removeTypeSig pn decls=concatMap (removeTypeSig' pn) decls+      where removeTypeSig' pn sig@(Dec (HsTypeSig loc is c tp))+             =if definesTypeSig pn sig && length is==1 +                 then []+                 else [Dec (HsTypeSig loc (filter (\x-> (pNTtoPN x)/=pn) is) c tp)]+            removeTypeSig' pn x=[x]   +++-- |Divide a declaration list into three parts (before, parent, after) according to the PNT,+-- where 'parent' is the first decl containing the PNT, 'before' are those decls before 'parent'+-- and 'after' are those decls after 'parent'.++divideDecls::[HsDeclP]->PNT->([HsDeclP],[HsDeclP],[HsDeclP])+divideDecls ds pnt+  = let (before,after)=break (\x->findPNT pnt x) ds+    in if (after/=[])+         then (before, [ghead "divideDecls" after], tail after)+         else (ds,[],[])+ 
+ refactorer/RefacMvDefBtwMod.hs view
@@ -0,0 +1,318 @@+++module RefacMvDefBtwMod(moveDefBtwMod) where++import Maybe+import List +import RefacUtils  hiding (getQualifier)+import PFE0 (findFile)+import PrettyPrint++{-This refactoring moves a user-selected function definition/pattern binding from current module to a+  user specified module.+  To perform this refactoring: put the cursor at the begining of the function/pattern name, then select+  the 'moveDefBtwMod' menu from the 'refactor' menu, and input the target module name in the mini-buffer+  as prompted.-}++moveDefBtwMod args+ = do let fileName     = ghead "filename" args  +          destModName' = args!! 1      +          destModName  = strToModName destModName'  -- there may be problem with the main module+          row          = read (args!!2)::Int+          col          = read (args!!3)::Int+      origModName <- fileNameToModName fileName+      r <-isAnExistingMod destModName+      unless r $  error "The specified module does not exist!"  +      unless (origModName /= destModName) $ error "The target module name is the same as the current module name!"+      (origInscps, _, origMod, origToks) <- parseSourceFile fileName    +      let pn = pNTtoPN $ locToPNT fileName (row, col) origMod  +          decl =definingDecls [pn] (hsModDecls origMod) False True                                      +      unless (pn /= defaultPN) +         $ error "Invalid cursor position. Please point the cursor to the beginning of the function/pattern name!"+      unless (isTopLevelPN pn && decl/=[]) $ error "The selected definition is not a top-level function/pattern definition!"+      -- Find the file name of the target module.+      destFile<-PFE0.findFile destModName  +      -- Parse the target module.+      (destInscps, _, destMod, destToks) <-parseSourceFile destFile +      -- get the pnames defined by the declaration to be moved.+      let pns  = nub $ concatMap definedPNs decl+      -- get the subset of 'pns' which are already defined in the target module.+      namesDefined <- namesDefinedIn (map pNtoName pns)  destMod+      unless (namesDefined == [] )+           (if length namesDefined == 1 +               then error ("The function/pattern name: " ++ show (head (namesDefined))+                    ++ " is already defined in module "++ destModName'++ " !")+               else error ("The pattern names: " ++ show namesDefined ++ " are already defined in module " ++ destModName'++ " !"))+      -- Get the client modules and the corresponding file names of the original module.+      clientsOfOrigMod <- clientModsAndFiles =<< RefacUtils.fileNameToModName fileName +      -- Get the client modules and the corresponding file names of the original module.+      clientsOfDestMod <- clientModsAndFiles =<< RefacUtils.fileNameToModName destFile +      -- get the free variables in the definition to be moved.+      freePnts <- freePNTsIn pns decl            +      let pnsNotInscope = varsNotInScope freePnts destInscps                          +      unless (pnsNotInscope == [])   -- why can not import these variables in the dest module?+          (if length pnsNotInscope == 1+             then error ("The free variable: '" ++ pNtoName (head pnsNotInscope)+++                      "', which is used by the definition to be moved is not in scope in the target module "++destModName' ++ " !")+             else error ("The free variables: " ++ showEntities pNtoName pnsNotInscope +++                      ", which are used by the definition to be moved are not in scope in the target module " ++destModName' ++ " !")) +       -- Will the moving cause recursive modules?+      r <-causeRecursiveMods decl fileName origModName destModName    +      unless (not r) $ error ("Moving the definition to module " ++ show destModName++ " will cause mutually recursive modules!")+      -- Remove the definition from the original module.  +      (origMod', ((origToks',origM),_))<-rmCodeFromMod pns fileName (origMod, origToks) destModName destFile+      -- Parse all those client modules.+      let modsAndFiles=nub (clientsOfOrigMod++clientsOfDestMod) \\ [(origModName, fileName),(destModName, destFile)]+      parsedMods <-mapM parseSourceFile $ map snd modsAndFiles                 +      -- is the definition name used in modules other than the target module?+      let used = any (\(_,_,mod,_)->isUsedByMod pns mod) parsedMods  || isUsedByMod pns origMod+      -- Add the definition to the destination module.+      (destMod',((destToks',destM),_))<-addCodeToMod pns destFile (origMod, origToks)+                                        (destInscps,destModName,destMod, destToks) used+      --Do corrsponding modification in the client modules.+      refacClients <- mapM (refactorInClientMod origModName destModName pns) $ zip parsedMods $ map snd modsAndFiles +      +      -- output the result.+      writeRefactoredFiles False $ [((fileName,origM),(origToks',origMod')),+                                    ((destFile,destM),(destToks',destMod'))] ++ refacClients+++-- Return the subset of 'names' that are defined in 't'.+namesDefinedIn  names t+  =do (_,rd)<-hsFreeAndDeclaredPNs t+      return ((map pNtoName rd) `intersect` names)++--Get those free variables (used by the definition to be moved) that are not in scope in the destination module.+varsNotInScope pnts inScopeRel+   = nub $ map pNTtoPN (filter +          (\pnt->if isQualifiedPN (pNTtoPN pnt) then  hsQualifier pnt inScopeRel == []+                                                else not (isInScopeAndUnqualified (pNTtoName pnt) inScopeRel)) pnts)+        +-- get those pnts which are free in 't' and not included in 'pns'+freePNTsIn pns t + = do (pns', _) <- hsFDsFromInside t      -- Why not use freeAndDeclared?+      let pnts = nub $ hsPNTs =<< rmLocs t +      return $ filter (\t->elem  (pNTtoPN t) (pns' \\ pns)) pnts++--Return True if moving the definition from origMod to destMod will cause recursive modules.+causeRecursiveMods decl origFile origModName destModName+ =do let pns  = nub $ concatMap definedPNs decl+     clients<-clientModsAndFiles origModName+     servers <-serverModsAndFiles destModName +     let clientMods1 = map fst clients+         clientFiles =map snd clients+         serverMods = map fst servers+         serverFiles =map snd servers+     if elem destModName clientMods1+      then do let ms = origFile:(clientFiles `intersect` serverFiles)+              parsedMods<-mapM parseSourceFile ms+              let (_,_,origMod,_) = ghead "causeRecursiveMods" parsedMods+              return ( isUsedBy pns (hsDecls origMod \\ decl) ||+                       (any (\ (_,_,mod,_)->isUsedByMod pns mod) (tail parsedMods)))+      else if elem destModName serverMods+             then do clients <- clientModsAndFiles destModName+                     let ms = origModName : (map fst clients `intersect` serverMods)                            +                         r  = map fromJust (filter isJust (map hasModName $ nub (map pNTtoPN (hsPNTs decl)) \\ pns))+                     return $ any (\m-> elem m r ) ms+             else return False  + +isUsedByMod pns (HsModule _ _ _ _ ds) = isUsedBy pns ds++--Return True if any pname in 'pns' is used by 'mod'+isUsedBy pns t+   = fromMaybe False (applyTU (once_tdTU (failTU `adhocTU` worker)) t)+        where    +         worker (pnt::PNT)+           | elem (pNTtoPN pnt) pns && isUsedInRhs pnt t+          = Just True+         worker _ = mzero     +++-- Remove the definition from the original module.++rmCodeFromMod pns fileName (mod, tokList) destModName destFileName+  = runStateT (do -- remove the definition.+                  decls'<-rmDecl (ghead "rmCodeFromMod"  pns) True (hsDecls mod)  +                  -- remove the definition name from the export list+                  mod'<-rmItemsFromExport (replaceDecls mod decls') (Left ([],pns))+                  -- is the definition used in the current module?+                  if isUsedByMod pns mod' +                    then -- yes. add the definition name to the import.+                         do let qual=getQualifier destModName mod' +                            mod''<-replaceQualifier pns qual mod' +                            addImport destFileName destModName pns mod''+                    else --No, do nothing.+                         return mod') +             ((tokList,unmodified),(-1000,0))+++-- Add the definition to the client module, and modify the import/export if necessary.+addCodeToMod  pns destFileName (origMod, origToks) (destInscps,destModName, destMod, destToks) usedByClients  + = do let -- get the declaraion. False means not spliting the type signature.+          decl  = definingDecls pns (hsDecls origMod) True False+           --get the fun binding.+          funBinding = ghead "addCodeToMod" $ filter isFunOrPatBind decl  -- shoudn't be empty.+           --get the type signature if there is any.+          typeSig    = filter isTypeSig decl +          decl' = if typeSig==[]+                    then [funBinding]+                    else [ghead "addCodeToMod" (getTypeSig pns (head typeSig)),funBinding]+          +          toksTobeAdded =getDeclToks (ghead "addCodeToMod" pns) True decl origToks +      (decl'', toksTobeAdded') <- if isDirectRecursiveDef funBinding &&+                                     sameNameInScope (ghead "addCodeToMod" pns) destInscps+                                  then do (t,((toks',_), m))<-runStateT (addQualifier pns modName decl)+                                                             ((toksTobeAdded,unmodified),(-1000,0))+                                          return (t, toks')+                                  else return (decl', toksTobeAdded)+      (decl''',((toksTobeAdded'',_),_)) <-runStateT (replaceQualifier pns destModName decl'')+                                          ((toksTobeAdded',unmodified),(-1000,0))  --destFileName)+      runStateT ( do  destMod'<-resolveAmbiguity pns destInscps destMod+                      mod'<-replaceQualifier pns destModName destMod'+                      mod''<- addDecl mod' Nothing (decl''', Just toksTobeAdded'') True+                      mod''' <- rmItemsFromImport mod'' pns                            +                      if usedByClients && not (modIsExported destMod) +                          -- The definition name is used by other modules, but it is+                         then addItemsToExport mod''' Nothing False (Right (map pnToEnt pns))   --so make it exported.+                         else return mod'''      -- Do nothing.                            +                ) ((destToks,unmodified), (-1000,0)) --destFileName)++   where +        -- Get the type signatures defines the type of pns. +       getTypeSig pns (Dec (HsTypeSig loc is c tp))+         =[(Dec (HsTypeSig loc (filter (\x->isJust (find (==pNTtoPN x) pns)) is) c tp))]+       getTypeSig pns _ = []+  +       modName = modNameToStr destModName++       pnToEnt pn = EntE (Var (pNtoPNT pn Value))+++-- |Returns True if another identifier which has the same name but different meaning is in scope.+-- NOTE: The name space should be taken into account as well.+sameNameInScope::PName         -- ^ The identifier+                 ->InScopes    -- ^ The inscope relation+                 ->Bool        -- ^ The result+sameNameInScope pn inScopeRel = isJust $ find (\ (name, nameSpace, modName, _)-> name == pNtoName pn +                                                && hasModName pn /= Just modName ) $ inScopeInfo inScopeRel++       +-- modify the import interface in the client modules.+refactorInClientMod origModName destModName pns ((inscps, exps,mod, ts), fileName)+  = do (mod', ((ts',m),_)) <- +          runStateT ( do mod'<-rmItemsFromImport mod pns+                         mod''<- if isUsedByMod pns mod+                                  then do let qual=getQualifier destModName mod                                          +                                          addImport fileName destModName pns =<< replaceQualifier pns qual mod'+                                  else if itemIsImportedByDefault destModName mod && causeAmbiguity pns mod'+                                         then addHiding destModName mod' pns+                                         else return mod'+                         return mod'' +                    ) ((ts,unmodified),(-1000,0)) +       return ((fileName,m),(ts',mod'))++++--add a definition name to the import. If the module is not imported yet, then create a new import decl.+-- addImport::String->HsName.ModuleName->[PName]->HsModuleP->HsModuleP+addImport destFileName destModName pns mod@(HsModule _ _  _ imp _)+  =if itemIsImportedByDefault destModName mod     -- Is the definition name explicitly imported?+    then return mod                               -- Yes. Do nothing.+    else if itemsAreExplicitlyImported destModName mod  --Is the module imported and some of its items are explicitly imported?+          then addVarItemInImport1 destModName pns mod -- Yes. Then add the definition name to the list.+          else addImportDecl mod (modNameToStr destModName) False  Nothing False (map pNtoName pns)+               --addImportDecl mod (mkImportDecl destFileName destModName  False (map pNtoName pns)) --Create a new import decl.++  where  +   {- Compose a import declaration which imports the module specified by 'modName',+      and only imports the definition spcified by 'e'.+    -}+   --mkImportDecl::String->HsName.ModuleName->Bool->[HsName.Id]->HsImportDeclP+ {-  mkImportDecl fileName modName qual ids +     = (HsImportDecl loc0  (SN modName loc0)  qual Nothing (Just (False, (map makeEnt ids))))+      where+      makeEnt id= Var $ PNT (PN (UnQual id) (G modName id (N (Just loc0)))) Value (N (Just loc0)) -}+   +   itemsAreExplicitlyImported serverModName (HsModule _ _ _ imps _)+     = any (isExplicitlyImported serverModName) imps+    where+       isExplicitlyImported serverModName ((HsImportDecl _ (SN modName _) _ _ h)::HsImportDeclP)+         = serverModName == modName && isJust h && not (fst (fromJust h))++++-- are items defined in the serverModName imported by the current module by default?+itemIsImportedByDefault serverModName (HsModule _ _ _ imps _) +  = any (isImportedByDefault'  serverModName) imps+  where+    isImportedByDefault' serverModName ((HsImportDecl _ (SN modName _) _ _ h)::HsImportDeclP)+       = serverModName == modName && ( isNothing h  || (isJust h && fst(fromJust h)))+++addVarItemInImport1 serverModName pns mod+   = applyTP ((once_tdTP (failTP `adhocTP` inImport))  `choiceTP` idTP) mod+  where +    inImport (imp@(HsImportDecl loc@(SrcLoc fileName _ row col) (SN modName l) qual as (Just (b,ents))):: HsImportDeclP)+      | serverModName == modName && not b  +     =  {-do let ents'= map (\pn->Var (pNtoPNT pn Value)) pns +           addItemsToImport1 imp ents'          +           return (HsImportDecl loc (SN modName l) qual as (Just (b, (ents'++ents)))) -}+          addItemsToImport serverModName  Nothing (Left (map pNtoName pns)) imp+    inImport x = mzero++--same name but with different meaning is used.+causeAmbiguity pns mod+   = fromMaybe False (applyTU (once_tdTU (failTU `adhocTU` worker)) (hsDecls mod))+        where    +         worker (pnt::PNT)+           | not (isQualifiedPN (pNTtoPN pnt)) && elem (pNTtoName pnt) (map pNtoName pns)+             && not (elem (pNTtoPN pnt) pns)+          = Just True+         worker _ = Nothing   ++resolveAmbiguity pns inScopeRel t+  =applyTP (full_tdTP (adhocTP idTP rename)) t+       where+         rename  pnt@(PNT pn@(PN (UnQual s) l) ty loc@(N (Just (SrcLoc fileName _  row col))))+          | isTopLevelPNT pnt && ty==Value && elem (pNTtoName pnt) (map pNtoName pns) && not (elem (pNTtoPN pnt) pns) +          = do let qual@(PlainModule q)= ghead "resolveAmbiguity" (hsQualifier pnt inScopeRel)  +                   pnt'=(PNT (PN (Qual qual s) l) ty loc) +               update pnt pnt' pnt+         rename x = return x ++-- getQualifier :: HsName.ModuleName->HsModuleP->HsName.ModuleName+getQualifier  modName (HsModule  _ _  _ imp _)  +    = let r=(nub.ghead "getQualifier") (applyTU (once_tdTU (constTU [] `adhocTU` inImport)) imp)+      in if r==[] then modName +                  else head r     +    where +    inImport ((HsImportDecl _ (SN m loc) _ as _ )::HsImportDeclP)+      | show modName == show m   +      = if isJust as then return [simpModName (gfromJust "getQualifier"  as)]+                     else return [] +    inImport _ = mzero+ +    -- simpModName :: PosSyntax.ModuleName ->HsName.ModuleName+    simpModName (SN m loc) = m++replaceQualifier pns qual  t+    =applyTP (full_tdTP (adhocTP idTP rename)) t+       where+         rename  pnt@(PNT pn ty loc)+          |isQualifiedPN pn && elem pn pns +          = do let pnt'=PNT (replaceQual pn qual) ty loc+               update pnt pnt' pnt+             where +              replaceQual (PN (Qual modName  s) l) qual = PN (Qual qual s) l             +              replaceQual pn _ = pn+         rename x=return x++addQualifier pns qualifier t+  =applyTP (full_tdTP (adhocTP idTP rename)) t+       where+         rename pnt@(PNT pn@(PN (UnQual s) l) ty loc)+          | elem pn pns && isUsedInRhs pnt t+          = do let pnt'=(PNT (PN (Qual (strToModName qualifier) s) l) ty loc)+               update pnt pnt' pnt+         rename x=return x+
+ refactorer/RefacNewDef.hs view
@@ -0,0 +1,606 @@+++module RefacNewDef(introNewDef,unfoldDef,doUnfolding1) where++import PrettyPrint+import PosSyntax+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT +import TiPNT +import List  +import RefacUtils+import PFE0 (findFile)+import MUtils(( # ))+import AbstractIO+--Introdule a new defintion whose rhs is the user specified expression+introNewDef args+ = do let fileName   = args!!0+          newFunName = args!!1            +          beginRow   = read (args!!2)::Int+          beginCol   = read (args!!3)::Int+          endRow     = read (args!!4)::Int+          endCol     = read (args!!5)::Int+      modName <- fileNameToModName fileName +      if isVarId newFunName then+         do (inscps, exps, mod, tokList) <- parseSourceFile fileName  +            let exp = locToExp (beginRow,beginCol) (endRow, endCol) tokList mod +            (mod',((tokList',m),_))<-doIntroduce fileName newFunName (beginRow,beginCol)(endRow,endCol) mod tokList           +            writeRefactoredFiles False [((fileName,m), (tokList',mod'))]+         else error "Invalid new function name!"++  where+   ---Introduce the new defintion, and put it at the end of next lower level declaration list+   doIntroduce fileName newFunName beginPos endPos mod tokList +      =runStateT (applyTP (once_buTP (failTP `adhocTP` inMatch+                                             `adhocTP` inPat+                                             `adhocTP` inLetExp+                                             `adhocTP` inAlt+                                             `adhocTP` inStmt) `choiceTP` failure) mod) +                         ((tokList,unmodified), (-1000,0))+                         +        where+           --The sub-expression is in the rhs of a match+           inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+              | inRegion rhs tokList beginPos endPos && locToExp beginPos endPos tokList rhs /= defaultExp +                  =doIntroduce' match  rhsIn  replaceRhs                 +           inMatch _ =mzero+           +           --The sub-expression is in the rhs of a pattern binding+           inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+              | inRegion rhs tokList beginPos endPos && locToExp beginPos endPos tokList rhs /= defaultExp+                     =doIntroduce' pat  rhsIn   replaceRhs   +           inPat _ =mzero+ +           -- The sub-expression is in the expression of a 'Let ... in'      +           inLetExp (exp@(Exp (HsLet ds e))::HsExpP)+               | inRegion e tokList beginPos endPos && locToExp beginPos endPos tokList e /= defaultExp+                    =doIntroduce'' exp expIn  replaceExpInLet +           inLetExp _=mzero+                +           -- The sub-expression is in the rhs of a case alternative+           inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+                | inRegion rhs tokList beginPos endPos &&  locToExp beginPos endPos tokList rhs /= defaultExp+                    =doIntroduce' alt  rhsIn replaceRhs  +           inAlt _=mzero+      +           -- The sub-expression is in the stmts of a 'let'    +           inStmt (stmt@(HsLetStmt ds stmts):: HsStmtP)+                | inRegion stmts tokList beginPos endPos &&  locToExp beginPos endPos tokList stmts /= defaultExp+                     =doIntroduce' stmt  stmtsIn replaceStmtsInDo  +           inStmt  _=mzero++           failure=idTP `adhocTP` mod+                 where mod (m::HsModuleP)=error "The highlighted source does not contain a sub-expression!"          ++           --ORDER MATTERS HERE+           doIntroduce' parent getRhs replaceFun +               =do+                   (f,d)<-hsFDsFromInside parent		  +                   if elem newFunName (map pNtoName (f `union` d))+                      then +                         error "The new function name would cause name clash/capture, please select another name!"+                      else+                         do +                            let exp=locToExp beginPos endPos tokList (getRhs parent) +                            (freeVars,declVars)<-hsFreeAndDeclaredPNs exp        +                            let +                                params=(freeVars \\ (nub (f `union` d)))  --get parameters to the new function. +                                --params = freeVars `intersect` d +                                (newFun,newFunPName)=mkNewFun  newFunName params exp+                            parent'<-addDecl parent Nothing ([newFun], Nothing) False+                            --unified foldOneExp and foldAllExps to foldExps, +                            --then switched back to 1, see comment for foldExps -- Claus+                            --1: only fold the highlighted expression+                            --rhs'<-foldExps False exp newFunPName params (fromJust(getRhs parent))+                            --2: fold all the courrences of the same expression+                            rhs'<-foldExps True exp newFunPName params (fromJust(getRhs parent))   +                            return (replaceDecls (replaceFun parent rhs') (hsDecls parent'))+                            --return (replaceDecls parent (hsDecls parent ++ [newFun])) +                            --3: without folding expression:+                            -- return (replaceDecls parent (newFun:(hsDecls parent)))+           --ORDER MATTERS HERE.+           doIntroduce'' parent getRhs replaceFun  +               =do (f,d)<-hsFDsFromInside parent+                   if elem newFunName (map pNtoName (f `union` d))+                      then +                         error "The new function name would cause name clash/capture, please select another name!"+                      else+                         do let exp=locToExp beginPos endPos tokList (getRhs parent)+			      +                            (freeVars,_)<-hsFreeAndDeclaredPNs exp+                            let +                                params=(freeVars \\ (nub (f `union` d)))  --get parameters to the new function. +                                (newFun,newFunPName)=mkNewFun newFunName params exp+                            --unified foldOneExp and foldAllExps to foldExps, +                            --then switched back to 1, see comment for foldExps -- Claus+                            --1: only fold the highlighted expression+                            --rhs'<-foldExps False exp newFunPName params (fromJust(getRhs parent))+                            --2: fold all the courrences of the same expression+                            rhs'<-foldExps True exp newFunPName params (fromJust(getRhs parent))+                            parent'<-addDecl parent Nothing ([newFun], Nothing) False+                            return (replaceDecls (replaceFun parent rhs') (hsDecls parent'))+                            --return (replaceDecls parent (hsDecls parent ++ [newFun])) +                            --3: without folding expression:+                            -- return (replaceDecls parent (newFun:(hsDecls parent)))++           mkNewFun funName params e+             =let funPName= PN (UnQual funName) (S loc0)+                  funDecl = Dec (HsFunBind loc0 [HsMatch loc0 (PNT funPName Value (N (Just loc0)))+                           (map pNtoPat  params) (HsBody e) []])+                 --ATTENTION: if length[params]=0, SHOULD CREATE AN PATTERN BINDING.+                 --mkLocsUnique should apply here becaue the location of params need to change.+                 --funDecl'<-mkLocsUnique funDecl [(pNtoLoc funPName)]+              in (funDecl, funPName) ++         +   -- won't work for all==True! for identifiers, == looks *only* at the location,+   -- so after setting all locations to some default with rmLocs,+   -- *all* identifiers look equal +   foldExps all e funPName paramPNames+       =applyTP (traversal (failTP `adhocTP` exp))  --use once_tdTP if only fold one expression.                     +         where+            traversal   :: MonadPlus m => TP m -> TP m+            traversal    = if all then stop_tdTP else once_tdTP+            compare     :: (Eq t ,Term t) => t -> t -> Bool+            compare e1 e = if all +                            then toRelativeLocs e1 == toRelativeLocs e+                            --then e1==e --does not handle the cases like [\x->x, \x->x].+                            else sameOccurrence e1 e+            exp (e1 ::HsExpP)+               | compare e1 e =  do let funExp=pNtoExp funPName+                                        paramExps=map pNtoExp paramPNames+                                        newExp = foldl addParamToExp funExp paramExps+                                    update e1 newExp e1                                         +            exp (e1@(Exp (HsDo stmts))::HsExpP)+              |isDoExp e+              =do let atoms=doExp2StmtList e +                      atoms1 =getStmtList stmts                 +                  if atoms `intersect` atoms1 ==[]+                   then fail "Expession not found"+                   else do let (atoms11,atoms12) = break (== (ghead "foldExps" atoms)) atoms1+                               atoms12'=atoms12 \\ atoms +                               funExp=pNtoExp funPName+                               paramExps=map pNtoExp paramPNames+                               newExp' = (HsQualifierAtom (foldl addParamToExp funExp paramExps))+                           newStmts'<-atoms2Stmt (atoms11++[newExp'] ++ atoms12')                          +                           let newExp = Exp (HsDo newStmts')+                           (f,d)<-hsFreeAndDeclaredPNs newExp+                           (_,d1)<-hsFreeAndDeclaredPNs e+                           let vs= f `intersect` d1+                           if vs /= [] +                             then error ("The declared variable(s): " ++ showEntities (render.ppi) vs+                                         ++", is(are) used outside the selected statements.")+                             else update e1 newExp e1   +            exp _ =mzero+            +            --Add a parameter to an expression+            addParamToExp  e param=(Exp (HsApp e param)) ++            doExp2StmtList (Exp (HsDo stmts)) = getStmtList stmts+            doExp2StmtList _ = []++            isDoExp (Exp (HsDo _)) = True+            isDoExp _ = False+ ++            getStmtList (HsGenerator l p e s) = HsGeneratorAtom l p e : getStmtList s+            getStmtList (HsQualifier e s)   = HsQualifierAtom e : getStmtList s+            getStmtList (HsLetStmt ds s)    = HsLetStmtAtom ds : getStmtList s+            getStmtList (HsLast e)          = [HsQualifierAtom e]++            atoms2Stmt [HsQualifierAtom e]          = return (HsLast e)+            atoms2Stmt [HsLastAtom e]               = return (HsLast e)+            atoms2Stmt (HsGeneratorAtom s p e : ss) = HsGenerator s p e # atoms2Stmt ss+            atoms2Stmt (HsLetStmtAtom ds : ss)      = HsLetStmt ds # atoms2Stmt ss+            atoms2Stmt (HsQualifierAtom e : ss)     = HsQualifier e # atoms2Stmt ss+            atoms2Stmt _ = fail "last statement in a 'do' expression must be an expression"++   foldAllExps e funPName paramPNames+       =applyTP (stop_tdTP (failTP `adhocTP` exp))  --use once_tdTP if only fold one expression.                     +         where+            exp (e1 ::HsExpP)+               | rmLocs e1==e+              =do let funExp=pNtoExp funPName+                      paramExps=map pNtoExp paramPNames+                      newExp = foldl addParamToExp funExp paramExps+                  update e1 newExp e1           +            exp _ =mzero+            --Add a parameter to an expression+            addParamToExp  e param=(Exp (HsApp e param)) +++class (Term t) =>RhsIn t where+  +    rhsIn:: t->Maybe RhsP++instance RhsIn HsMatchP where   +    rhsIn (HsMatch loc1 fun pats rhs ds)=Just rhs+           +instance RhsIn  HsDeclP where+    rhsIn (Dec (HsPatBind loc p rhs ds))=Just rhs                +    rhsIn _ =Nothing++instance RhsIn HsModuleP where+    rhsIn mod=Nothing++instance RhsIn HsAltP where+    rhsIn (HsAlt loc p rhs ds)=Just rhs++expIn ((Exp (HsLet ds exp))::HsExpP)=Just exp+expIn _=Nothing ++stmtsIn ((HsLetStmt ds stmts):: HsStmtP)=Just stmts+stmtsIn _=Nothing++------------------------------End of introducing a new definition-------------------------------------++{-ufolding a definition replaces a function call by its definition, the unfolded definition should be + a function/simple pattern binding. -}++unfoldDef args+ =do let fileName = ghead "fileName'" args +         row      = read (args!!1)::Int+         col      = read (args!!2)::Int +     modName <-fileNameToModName fileName+     (inscps, exps, mod, tokList)<-parseSourceFile fileName+     let pnt = locToPNT fileName (row, col) mod+         pn  = pNTtoPN pnt                           +     if pn /=defaultPN  && (defineLoc pnt /= useLoc pnt)+       then +         do decl<-findDefiningDecl pn modName mod+            if decl/=[] +              then do unInscopeIds <- freeVarsNotInScope decl inscps pnt mod +                      if unInscopeIds == [] +                        then do (mod',((tokList',m),_))<-runStateT (doUnfolding pnt (ghead "unfoldDef" decl) mod)+                                                          ((tokList,unmodified), (-1000,0))+                                writeRefactoredFiles False [((fileName,m), (tokList',mod'))]+                        else showNotInScopeError unInscopeIds  +              else error "Selected identifer is not a function/pattern binding name!"  +       else error "\nInvalid cursor position!\n"+ +   where +         +    findDefiningDecl  pn currentModName currentMod+      = let defineModName=hasModName pn+        in if isLocalPN pn || defineModName == Just currentModName+             then return $ definingDecls [pn] (hsModDecls currentMod) False True+             else do (inscps, exps, mod, tokList)<-parseSourceFile =<<PFE0.findFile (fromJust defineModName)+                     return $ definingDecls [pn] (hsModDecls mod) False True++    freeVarsNotInScope unfoldedDecl inscps pnt mod+       = do (f,_)<-hsFreeAndDeclaredPNs unfoldedDecl +            dl<-hsVisiblePNs pnt mod         +            let freePnts=filter (\x->elem (pNTtoPN x) f) $ hsPNTs unfoldedDecl+                freePnts'=filter (\x-> not (elem (pNTtoPN x) dl)) freePnts+            return $ nub.(map pNTtoPN) $ filter (\x -> hsQualifier x inscps == []) freePnts'+++    showNotInScopeError unInscopeIds +       = if length unInscopeIds>1        +            then error ("The free identifiers:" ++ showEntities pNtoQuotedName unInscopeIds +++                        ", used in the definition to be unfolded, are not in scope in the current module!")+            else error ("The free identifier:" ++ showEntities pNtoQuotedName unInscopeIds +++                        ", used in the definition to be unfolded, is not in scope in the current module!")+        where+          pNtoQuotedName pn =" '"++pNtoName pn++"'" ++                           +    doUnfolding pnt unfoldedDecl mod +      =do simplifiedDecl<-simplifyDecl unfoldedDecl+          --simplifiedDecl <-mkLocsUnique simplifiedDecl' []+          doUnfolding' pnt simplifiedDecl mod +      where ++        doUnfolding' pnt simplifiedDecl mod+           =applyTP (once_tdTP (failTP `adhocTP` inMatch+                                       `adhocTP` inPat) `choiceTP` failure) mod +          where+            inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+              |findEntity pnt rhs +                = do match'<-renameInAppSite pnt simplifiedDecl match+                     doUnfolding'' pnt  simplifiedDecl  match'+            inMatch _ =mzero+     +            inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+              |findEntity pnt rhs +                =do pat'<-renameInAppSite pnt simplifiedDecl pat+                    doUnfolding'' pnt simplifiedDecl pat'                   +            inPat _=mzero+          +            failure=idTP `adhocTP` mod+                where mod (m::HsModuleP)=error "Refactoring failed!"  +          +            renameInAppSite pnt unfoldedDecl t+             =do (f,_)<-hsFreeAndDeclaredPNs unfoldedDecl +                 dl<-hsVisiblePNs pnt t+                 --'f\\dl' is used to handle in case that the unfoldedDecl is a local decl of the parent.+                 --see 'ComplexPatIn1.hs' for an example.+                 let clashedNames=filter (\x-> elem (pNtoName x) (map pNtoName (f\\dl))) (nub dl) +                 t'<-foldM (flip (autoRenameLocalVar True)) t clashedNames  +                 return t'+               +            renameInUnfoldedDecl unfoldedDecl subst@(pn, exp) --pn is the formal parameter, exp is the actual parameter.+              =do  ds<-hsVisiblePNs pn unfoldedDecl+                   (f,_)<-hsFreeAndDeclaredPNs exp+                   let clashedNames=filter (\x->elem (pNtoName x) (map pNtoName f)) (nub ds)+                   foldM (flip (autoRenameLocalVar False)) unfoldedDecl clashedNames++            doUnfolding'' pnt unfoldedDecl +              =applyTP (once_tdTP (failTP `adhocTP` exp)) +                where+                  exp (e::HsExpP) --Because of the once_td traversal, the 'e' here must be the whole rhs or guard expression.+                    |findPNT pnt e+                    =if isComplexPatBind unfoldedDecl+                        then do replacePatCallByExp pnt unfoldedDecl e+                        else do let formalParams=paramsInDecl unfoldedDecl --get formalParams in unfolded declaration.+                                    actualParams=allParams pnt e     --get actual parameters.+                                    subst=zipWith (,) (map patToPN  formalParams) actualParams                         +                                unfoldedDecl'<-foldM  renameInUnfoldedDecl unfoldedDecl subst+                                --some formal parameters may have been renamed.+                                let formalParams'=paramsInDecl unfoldedDecl' +                                    subst'=zipWith (,) (map patToPN formalParams') actualParams+                                    extraFormalParams=drop (length actualParams) formalParams'+                                decl'<-foldM replaceExp unfoldedDecl' subst'  -- why not modify the token stream?+                                let rhsExp=if extraFormalParams/=[]  --In case of partial application, convert extra+                                                                   --formal parameters into lambda exprssion.+                                        then (Exp (HsLambda extraFormalParams (fromJust (rhsExpInDecl decl'))))+                                        else fromJust (rhsExpInDecl decl')+                                    localDecls=hsDecls decl'+                                replaceFunCallByExp pnt rhsExp localDecls =<<(rmParams pnt (length subst')) e +                  exp _=mzero+          +       +     --a pattern binding is a complex if the pattern is not a single variable.+    isComplexPatBind decl=case decl of+                   Dec (HsPatBind _ p _ _)->patToPN2 p ==defaultPN+                   _ ->False++    patToPNT2::HsPatP->PNT+    patToPNT2 (Pat (HsPId (HsVar pnt)))= pnt+    patToPNT2 (Pat (HsPLit l (HsInt v))) = patToPNT2 (Pat (HsPId (HsVar (PNT (PN (UnQual (show v)) (S l)) Value (N (Just l))))) )+    patToPNT2 (Pat (HsPParen p))=patToPNT2 p+    patToPNT2 _=defaultPNT++    -- | If a pattern consists of only one identifier then returns this identifier in the PName format,+    --   otherwise returns the default PName.+    patToPN2::HsPatP->PName+    patToPN2=pNTtoPN.patToPNT2++    replacePatCallByExp pnt decl+     =applyTP (full_buTP (idTP `adhocTP` worker))+        where worker (e::HsExpP)+                | sameOccurrence (expToPNT e) pnt   --in 'sameOccurrence', use location matters.+                     =do let newExp=Exp (HsParen (Exp (HsLet [decl] e))) +                         update e newExp e                     +              worker x =return x++ +       +    ---replace the function name by its definition+    replaceFunCallByExp pnt exp localDecls+      = applyTP (full_buTP (idTP `adhocTP` worker)) +         where worker (e::HsExpP)+                 |sameOccurrence (expToPNT e) pnt+                     =do let newExp=if localDecls/=[]+                                     then Exp (HsParen (Exp (HsLet localDecls exp)))+                                     else Exp (HsParen exp)  --Should check if exp is already a Hsparen expression!+                         update e newExp e                             +               worker x=return x+   ++    --get the parameters in the declaration (there should be only once match).+    paramsInDecl decl = case decl of+                     (Dec (HsFunBind _ ((HsMatch _  _ pats _ _):_))) ->pats+                     _ ->[]+ +    --get the right hand side repression in a declaration+    rhsExpInDecl (Dec (HsFunBind _ ((HsMatch _ _  _ (HsBody e) _):_)))=Just e +    rhsExpInDecl (Dec (HsPatBind _ _ (HsBody e) _))=Just e++    --get all the parameters to pnt (which is a function name) in expression 'exp'+    allParams pnt exp=allParams' pnt exp []+        where allParams' pnt exp initial -- pnt:function/pattern name.+                 =let p=getOneParam pnt exp+                  in if p/=defaultExp  then allParams' pnt (rmOneParam pnt exp) (initial++[p])         +                                       else initial++    --get the first parameter of pnt+    getOneParam pnt t+       =fromMaybe defaultExp (applyTU (once_tdTU (failTU `adhocTU` worker)) t)+         where+           worker (Exp (HsApp e1 e2))+              |sameOccurrence (expToPNT e1) pnt=Just e2+           worker _ =Nothing++    --remove the first parameter of pnt+    rmOneParam  pnt t+        =fromMaybe defaultExp (applyTP (stop_tdTP (failTP `adhocTP` worker)) t)+           where+             worker (Exp (HsApp e1 e2 ))+               |sameOccurrence (expToPNT e1) pnt =Just e1+             worker _=Nothing++--substitute an old expression by new expression+replaceExp decls subst+    = applyTP (full_buTP (idTP `adhocTP` worker)) decls+           where worker (e::HsExpP)+                   |(expToPN e/=defaultPN) &&  (expToPN e) == (fst subst) +                       && pNtoName (expToPN e) == pNtoName (fst subst)+                       =return (snd subst)+                 worker x=return x +++--Replace the old rhs by a new one---- +class (Term t) => ReplaceRhs t where+  +    replaceRhs:: t->RhsP->t++instance ReplaceRhs HsMatchP where   +    replaceRhs (HsMatch loc1 fun pats rhs ds) rhs'+                 =(HsMatch loc1 fun pats rhs' ds)+           +instance ReplaceRhs HsDeclP where+    replaceRhs (Dec (HsPatBind loc p rhs ds)) rhs'+                =Dec (HsPatBind loc p rhs' ds)+    replaceRhs x _ =x+         +instance ReplaceRhs HsAltP where+    replaceRhs (HsAlt loc p rhs ds) rhs'+                 =HsAlt loc p rhs' ds+++replaceExpInLet (Exp (HsLet ds e)) e'=(Exp (HsLet ds e'))+replaceExpInLet x _=x ++replaceStmtsInDo (HsLetStmt ds stmts) stmts'=HsLetStmt ds stmts'+replaceStmtsInDo x _=x+++-----------------------------End of unfolding --------------------------------------------++----------------------Following code does not belong to any refactorings yet------------------+++doUnfolding1 pn unfoldedDecl mod +      =do simplifiedDecl<-simplifyDecl unfoldedDecl+          --simplifiedDecl <-mkLocsUnique simplifiedDecl' []+          doUnfolding' pn simplifiedDecl mod +      where ++        doUnfolding' pn  simplifiedDecl mod+           =applyTP (full_tdTP (idTP `adhocTP` inMatch+                                     `adhocTP` inPat) `choiceTP` failure) mod +          where+            inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP)+              |findPN pn rhs +                = do match'<-renameInAppSite pn simplifiedDecl match+                     let pnts = hsPNTs pn match'+                     foldM (doUnfolding' simplifiedDecl) match' pnts+            inMatch _ =mzero+     +            inPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+              |findPN pn rhs +                =do pat'<-renameInAppSite pn simplifiedDecl pat+                    let pnts = hsPNTs pn pat' +                    foldM (doUnfolding' simplifiedDecl) pat' pnts +            inPat _=mzero+          +            failure=idTP `adhocTP` mod+                where mod (m::HsModuleP)=error "Refactoring failed!"  +          +            hsPNTs pn =(nub.ghead "hsPNTs").applyTU (full_tdTU (constTU [] `adhocTU` inPnt))+               where+                 inPnt pnt@(PNT pn1  _ _)+                   |pn1 == pn +                   =return [pnt]++            renameInAppSite pn unfoldedDecl t+             =do (f,_)<-hsFreeAndDeclaredPNs unfoldedDecl +                 dl<-hsVisiblePNs pn t+                 --'f\\dl' is used to handle in case that the unfoldedDecl is a local decl of the parent.+                 --see 'ComplexPatIn1.hs' for an example.+                 let clashedNames=filter (\x-> elem (pNtoName x) (map pNtoName (f\\dl))) (nub dl) +                 t'<-foldM (flip (autoRenameLocalVar True)) t clashedNames  +                 return t'+               +            renameInUnfoldedDecl unfoldedDecl subst@(pn, exp) --pn is the formal parameter, exp is the actual parameter.+              =do  ds<-hsVisiblePNs pn unfoldedDecl+                   (f,_)<-hsFreeAndDeclaredPNs exp+                   let clashedNames=filter (\x->elem (pNtoName x) (map pNtoName f)) (nub ds)+                   foldM (flip (autoRenameLocalVar False)) unfoldedDecl clashedNames++            doUnfolding' unfoldedDecl t pnt+              =applyTP (once_tdTP (failTP `adhocTP` exp)) t+                where+                  exp (e::HsExpP) --Because of the once_td traversal, the 'e' here must be the whole rhs or guard expression.+                    |findPNT pnt e+                    =if isComplexPatBind unfoldedDecl+                        then do replacePatCallByExp pnt unfoldedDecl e+                        else do let formalParams=paramsInDecl unfoldedDecl --get formalParams in unfolded declaration.+                                    actualParams=allParams pnt e     --get actual parameters.+                                    subst=zipWith (,) (map patToPN  formalParams) actualParams                         +                                unfoldedDecl'<-foldM  renameInUnfoldedDecl unfoldedDecl subst+                                --some formal parameters may have been renamed.+                                let formalParams'=paramsInDecl unfoldedDecl' +                                    subst'=zipWith (,) (map patToPN formalParams') actualParams+                                    extraFormalParams=drop (length actualParams) formalParams'+                                decl'<-foldM replaceExp unfoldedDecl' subst'+                                let rhsExp=if extraFormalParams/=[]  --In case of partial application, convert extra+                                                                   --formal parameters into lambda exprssion.+                                        then (Exp (HsLambda extraFormalParams (fromJust (rhsExpInDecl decl'))))+                                        else fromJust (rhsExpInDecl decl')+                                    localDecls=hsDecls decl'+                                replaceFunCallByExp pnt rhsExp localDecls =<<(rmParams pnt (length subst') e) --do unfolding      +                  exp _=mzero+          +  +         --a pattern binding is a complex if the pattern is not a single variable.+        isComplexPatBind decl=case decl of+                   Dec (HsPatBind _ p _ _)->patToPN p ==defaultPN+                   _ ->False++        replacePatCallByExp pnt decl+         =applyTP (full_buTP (idTP `adhocTP` worker))+           where worker (e::HsExpP)+                  | sameOccurrence (expToPNT e) pnt   --in 'sameOccurrence', use location matters.+                     =do let newExp=Exp (HsParen (Exp (HsLet [decl] e)))+                         update e newExp e+                 worker x =return x++        ---replace the function name by it's defintion+        replaceFunCallByExp pnt exp localDecls+         = applyTP (full_buTP (idTP `adhocTP` worker)) +           where worker (e::HsExpP)+                  |sameOccurrence (expToPNT e) pnt+                     =do let newExp=if localDecls/=[]+                                     then Exp (HsParen (Exp (HsLet localDecls exp)))+                                     else Exp (HsParen exp)  --Should check if exp is ready a Hsparen expression!+                         update e newExp e                        +                 worker x=return x++        --get the parameters in the declaration (there should be only once match).+        paramsInDecl decl = case decl of+                     (Dec (HsFunBind _ ((HsMatch _  _ pats _ _):_))) ->pats+                     _ ->[]+ +        --get the right hand side repression in a declaration+        rhsExpInDecl (Dec (HsFunBind _ ((HsMatch _ _  _ (HsBody e) _):_)))=Just e +        rhsExpInDecl (Dec (HsPatBind _ _ (HsBody e) _))=Just e++         --get all the parameters to pnt (which is a function name) in expression 'exp'+        allParams pnt exp=allParams' pnt exp []+           where allParams' pnt exp initial -- pnt:function/pattern name.+                   =let p=getOneParam pnt exp+                    in if p/=defaultExp  then allParams' pnt (rmOneParam pnt exp) (initial++[p])         +                                         else initial++        --get the first parameter of pnt+        getOneParam pnt t+          =fromMaybe defaultExp (applyTU (once_tdTU (failTU `adhocTU` worker)) t)+             where+              worker (Exp (HsApp e1 e2))+                |sameOccurrence (expToPNT e1) pnt=Just e2+              worker _ =Nothing++        --remove the first parameter of pnt+        rmOneParam  pnt t+         =fromMaybe defaultExp (applyTP (stop_tdTP (failTP `adhocTP` worker)) t)+           where+             worker (Exp (HsApp e1 e2 ))+               |sameOccurrence (expToPNT e1) pnt =Just e1+             worker _=Nothing++        rmOneParamWithUpdToks pnt +         =applyTP (stop_tdTP (failTP `adhocTP` inExp)) +           where++             inExp (exp@(Exp (HsParen (Exp (HsApp e1 e2))))::HsExpP)+                |sameOccurrence (expToPNT e1) pnt +                 =do update exp e1 exp    ++             inExp exp@(Exp (HsApp e1 e2))+              | sameOccurrence (expToPNT e1) pnt+                 =do update exp e1 exp+             inExp  _=mzero
+ refactorer/RefacRedunDec.hs view
@@ -0,0 +1,570 @@+module RefacRedunDec (convertPatsToPn, +                      convertToPat, +                      refacRedunDec, +                      removeRedun, +                      removeRedunWhere, +                      removeRedunWhere2, +                      doRemovingWhere, doRemoving1, doRefac) where+ ++import AbstractIO+import Maybe+import List+import RefacUtils+import RefacLocUtils++data Patt = Match HsMatchP | MyPat HsDeclP | Def [Char]++refacRedunDec args+  = do let fileName   = args!!0+           beginRow   = read (args!!1)::Int+           beginCol   = read (args!!2)::Int+           endRow     = read (args!!3)::Int+           endCol     = read (args!!4)::Int+       AbstractIO.putStrLn "refacRedunDec"++       -- Parse the input file.+       modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName++       -- Find the function that's been highlighted as the refactree++       let (loc, pnt, pats, exp, wh, p)+             = findDefNameAndExp tokList+                                 (beginRow, beginCol)+                                 (endRow, endCol)+                                 mod +       +                                 +       (wh', newExp) <- removeRedunCase exp wh+       (wh'', newExp') <- doRefac wh' newExp+                 +       -- (mod',((tokList',modified),_))<-doRemovingWhere fileName mod tokList exp newExp wh'+       +       ((_,_), (tokList', mod')) <- applyRefac (doRemovingWhere exp newExp' wh'') (Just (inscps, exps, mod, tokList)) fileName+            +       +       ((_,m), (tokList'', mod'')) <- applyRefac (doRemoving1 exp newExp' wh'') (Just (inscps, exps, mod', tokList')) fileName++                   +       writeRefactoredFiles False [((fileName, True), (tokList'', mod''))]+       +    --   error (show mod')+       AbstractIO.putStrLn "Completed.\n"++doRefac wh exp = do+                 (decls, newExp) <- removeRedun wh exp+                 (newWhere) <- removeRedunWhere wh newExp+                 return (newWhere, newExp)++convertToPat [] _ = []+convertToPat _ [] = []+convertToPat (pat@(Pat (HsPId (HsVar (PNT (PN x y) Value s)))):ps) ((PN v z):xs)+      | x == v && y == z = pat : (convertToPat ps xs)+      | otherwise        = convertToPat ps ((PN v z):xs)+++convertPatsToPn [] = []+convertPatsToPn ((Pat (HsPId (HsVar (PNT (PN x y)Value s )))):ps)+                           = (PN x y): (convertPatsToPn ps)+convertPatsToPn _ = []+++--removeRedun :: [HsDeclP] -> HsExpP -> m ([HsDeclP], HsExpP)++removeRedunCase (Exp(HsParen e)) wh +                = do +                     res <- removeRedunCase e wh+                     return res+removeRedunCase (Exp(HsCase e alts)) wh+                = do+                     newAlts <- checkAlts alts+                     return (wh, (Exp (HsCase e newAlts)))+                        where+                           checkAlts [] = do+                                             return []+                           checkAlts ((HsAlt s p1 (HsBody e) ds):xs) +                              = do+                                   decls <- removeRedunWhere ds e+                                   res <- checkAlts xs+                                   return ((HsAlt s p1 (HsBody e) decls) : res)++removeRedunCase (exp@e) wh  = do+                               return (wh, e)++removeRedun wh (Exp (HsParen e))+   = do+        (wh', newExp) <- removeRedun wh e+        return (wh', (Exp (HsParen newExp)))+        +removeRedun wh (Exp (HsInfixApp e1 o e2))+ = do+      (wh'1, newExp1) <- removeRedun wh e1+      (wh'2, newExp2) <- removeRedun wh e2+      +      return ( nub ( wh'2 ++ wh), (Exp (HsInfixApp newExp1 o newExp2)))+ +removeRedun wh (Exp(HsLet ds e)) = do+                                   (_, newE) <- removeRedun wh e+                                   (free, dec) <- hsFreeAndDeclaredPNs newE+                                   let decls = checkFree free ds+                                   let decls' = checkFree free wh+                                   newWhere <- checkWhere wh decls+                                   moreDecls <- checkRestDecls decls' wh+                                   if decls /= [] +                                      then do                                   +                                        return ((nub (moreDecls++(decls'++newWhere))), (Exp(HsLet decls newE)))+                                      else do+                                        return ((nub (moreDecls++(decls'++newWhere))), newE)+                                      where+                                         checkWhere [] _ = do return wh+                                         checkWhere wh [] = do return wh+                                         checkWhere wh ((Dec(HsPatBind _ _ (HsBody e)_)):xs) +                                                      = do+                                                           (free, dec) <- hsFreeAndDeclaredPNs e +                                                           let decls = checkFree free wh+                                                           newDecls <- checkWhere decls xs+                                                           moreDecls <- checkRestDecls newDecls wh+                                                           return (nub (moreDecls ++ newDecls))+removeRedun wh exp@(Exp (HsLambda (p:ps) e))+      = do+           (free, dec) <- hsFreeAndDeclaredPNs e+           -- error $ show (free, (p:ps))+           let decls = myCheckFree e (p:ps)+           let decls' = checkFree free wh+           -- newWhere <- checkWhere wh [(Exp (HsLambda decls e))]+           moreDecls <- checkRestDecls decls' wh+           return ((nub (moreDecls ++ (decls'))), (Exp (HsLambda decls e)))+            where+              myCheckFree e list = checkSin e list+                                       where+                                        checkSin :: HsExpP -> [HsPatP] -> [HsPatP]+                                        checkSin e [] = []+                                        checkSin e (x:xs) +                                          | findPN' (patToPN x) e = x : checkSin e xs+                                          | otherwise   = checkSin e xs ++              checkWhere [] _ = do return wh+              checkWhere wh [] = do return wh+              checkWhere wh ((Dec(HsPatBind _ _ (HsBody e)_)):xs) +                                   = do+                                       (free, dec) <- hsFreeAndDeclaredPNs e +                                       let decls = checkFree free wh+                                       newDecls <- checkWhere decls xs+                                       moreDecls <- checkRestDecls newDecls wh+                                       return (nub (moreDecls ++ newDecls))+                                       +removeRedun wh (exp@(_)) = do return (wh, exp)++removeRedunWhere wh (exp@(_)) = do+                      (free, dec) <- hsFreeAndDeclaredPNs exp+                      let decls = checkFree free wh+                      -- check each declaration that is left for +                      -- declarations that are still needed+                      let dupsRemove = removeDups wh decls+                      moreDecls <- checkRestDecls decls dupsRemove+                      return (nub (decls++moreDecls))+                        where+                          removeDups [] ys = []+                          removeDups (x:xs) ys+                            | x `elem` ys = removeDups xs ys+                            | otherwise   = x : removeDups xs ys+removeRedunWhere2 wh (exp@(_)) = do+                      (free, dec) <- hsFreeAndDeclaredPNs exp+                      let decls = checkFree2 free wh+                      -- check each declaration that is left for +                      -- declarations that are still needed+                      moreDecls <- checkRestDecls decls wh+                      +                      return (nub (decls++moreDecls))++checkRestDecls [] _ = return []                         +checkRestDecls wh [] = return []+checkRestDecls ((Dec (HsPatBind loc1 ps (HsBody e) ds)):rest) (x:[])+                      = do+                          (free, dec) <- hsFreeAndDeclaredPNs e+                          let decls = checkFree free [x]+                          return decls+ +checkRestDecls ((Dec (HsPatBind loc1 ps (HsBody e) ds)):rest) (x:xs) +                      = do+                          (free, dec) <- hsFreeAndDeclaredPNs e+                          let decls = checkFree free (x:xs)+                         -- moreDecls <- checkRestDecls [x] xs+                          moreDecls <- checkRestDecls decls (x:xs)+                          moreDecls' <- checkRestDecls rest (x:xs)+                          return (decls ++ (moreDecls ++ moreDecls'))+                          +checkRestDecls ((Dec (HsFunBind loc1 ms)):rest) (x:xs)+  = do+       res <- checkRestMatches ms+       let newDec = (Dec (HsFunBind loc1 res))+       moreDecls <- checkRestDecls rest (x:xs)+       return (newDec :  moreDecls)+    where+      checkRestMatches [] = return [] +      checkRestMatches (m@(HsMatch l i1 ps (HsBody e) ds):ms)+                      = do+                          +                          (free, dec) <- hsFreeAndDeclaredPNs e+                          let decls = checkFree free (x:xs)+                         -- moreDecls <- checkRestDecls [x] xs+                          moreDecls1 <- checkRestMatches ms+                          return moreDecls1+                           ++doRemoving1 exp newExp wh (_, _, mod)+ = do+      newMod <- doRemoving exp newExp wh mod+      return newMod+++-- Stafunski function to traverse the AST and find the occurance of the exp that we+-- are interested in. When the exp is found, the redundant declarations are calculated+-- and rmDecls in then called. +-- the rusult is then a new expression with the new list of declarations returned by+-- rmDecls.+doRemoving exp newExp wh mod+    =  applyTP (stop_tdTP (failTP `adhocTP` (rmInLet newExp))) mod+                       +           where+             rmInLet (new::HsExpP) (letExp@(Exp (HsParen (Exp (HsCase e2 alts2))))::HsExpP) +                |sameOccurrence letExp exp+                    = do +                         -- error $ show new+                         r <- update letExp (Exp (HsParen new)) letExp+                         return r+                | otherwise = return (Exp (HsParen new))+           +             rmInLet (new::HsExpP) (letExp@(Exp (HsCase e2 alts2))::HsExpP) +                | rmLocs letExp == rmLocs exp+                    = do +                         -- error $ show new+                         r <- update letExp new letExp+                         return r+                | otherwise = return letExp+                            +             rmInLet (new@(Exp (HsParen e1))::HsExpP) (letExp@(Exp (HsLet ds e))::HsExpP)+               = do+                    res <- rmInLet e1 letExp+                    return res+           +             rmInLet (new@(Exp (HsLet ds e1))::HsExpP) (letExp@(Exp (HsParen (Exp (HsLet ds2 e2))))::HsExpP)+               | sameOccurrence letExp exp == True+                  = do+                     res <- update letExp (Exp (HsParen new)) letExp+                     return res+               | otherwise = return letExp+           +             --1. The definition to be removed is a local declaration in a let expression+             rmInLet (new@(Exp (HsLet decs e'))::HsExpP) (letExp@(Exp (HsLet ds e))::HsExpP) +               | sameOccurrence letExp exp == True+                  =do+                      let redunDecs = ds \\ decs+                      ds'<- rmDecls ds redunDecs+                      if ds'==[] then do res <- rmInLet new e+                                         -- r <- update letExp res exp+                                         -- error $ show (tokenise (Pos 0 v1 1) offset False $ printFun)+                                         return res+                                 else do +                                         r <- update letExp (Exp (HsLet ds' e')) letExp+                                         return r+               | otherwise = do+                                    -- error $ show (new, letExp)+                                    return letExp+++             +             rmInLet e1 (Exp (HsLet ds e)::HsExpP) +               | sameOccurrence e1 e == True+                  = do+                      ds' <- rmDecls ds ds+                      if ds' == [] then return e1+                                   else return (Exp (HsLet ds' e))+               | otherwise+                   = return e+             +             rmInLet (new@(Exp (HsParen (Exp (HsLambda ds1 e1))))::HsExpP) (lamExp@(Exp (HsParen (Exp (HsLambda ds e2))))::HsExpP)+              | sameOccurrence lamExp exp == True+                = do+                     res <- update lamExp new lamExp+                     return res+              | otherwise = return lamExp+             +             rmInLet (new@(Exp (HsParen e1))::HsExpP) (lamExp@(Exp (HsLambda ds e2))::HsExpP)+               = do+                    res <- rmInLet e1 lamExp+                    return res++             rmInLet (new@(Exp (HsLambda decs e'))::HsExpP) (letExp@(Exp (HsParen (Exp (HsLambda ds e))))::HsExpP) +               | sameOccurrence letExp exp == True+                  =do+                     res <- update letExp (Exp (HsParen new)) letExp+                     return res+               | otherwise = return letExp++             +             rmInLet (new@(Exp (HsLambda decs e'))::HsExpP) (letExp@(Exp (HsLambda ds e))::HsExpP) +               | sameOccurrence letExp exp == True+                  =do+                     res <- update letExp newExp letExp+                     return res  +               | otherwise =  return letExp++             +                        +      {-       rmInLet (e1@(Exp (HsLambda _ _))::HsExpP) (e2::HsExpP)+                = do res <- update e2 newExp e2+                     return res     -}+             +             rmInLet e1 e2@(Exp (HsInfixApp e11 o e22)::HsExpP)+                | findEntity e1 e11 = do  -- error $ show (e1, e11)+                                          res <- rmInLet e1 e11+                                          r <- update e2 res e2+                                          return r+                | findEntity e1 e22 = do  +                                          res <- rmInLet e1 e22+                                          r <- update e2 res e2+                                          return r+                                          +             rmInLet e1 e2@(Exp (HsParen e))+               = do+                    res <- rmInLet e1 e+                    -- r <- update e2 res e2+                    return res+             +             rmInLet e1 e2+               | sameOccurrence e2 exp == True+                             = do+                                  res <- update e2 e1 e2+                                  return res +               | otherwise   = return e2+               +             rmDecls wh [] = return wh+             rmDecls wh ((d@(Dec (HsPatBind loc1 pn (HsBody rhs) ds))::HsDeclP):xs)+                  = do+                      let newName = pNTtoPN (patToPNT pn)+                      decls' <- rmDecl newName False wh+                      decls'' <- rmDecls decls' xs+                      return decls''+             rmDecls d _ = return wh++         +doRemovingWhere exp newExp wh (_,_,mod)+     = (applyTP (stop_tdTP (failTP `adhocTP` (rmInPat exp) +                                   `adhocTP` (rmInMatch exp))) mod)+     +     {- runStateT (applyTP (stop_tdTP (failTP `adhocTP` (rmInPat exp) +                                              `adhocTP` (rmInMatch exp)+                                              `adhocTP` rmInCase)) mod) ((tokList,unmodified),fileName) -}+          where+             rmInCase (a@(HsAlt s p1 (HsBody e2) ds)::HsAltP)+                | findEntity newExp e2+                   =do+                       -- error $ show e2+                       ds' <- removeRedunWhere ds newExp+                       +                       -- let redunDecs = ds \\ wh+                       -- ds'<- rmDecls ds [] redunDecs      +                       -- let ds' = filter (not . (\x -> x `elem` redunDecs)) ds                +                       -- error $ show ds'+                       if ds' == [] then fail ""+                                    else do+                                      r <- update a (HsAlt s p1 (HsBody e2) ds') a+                                      -- return (HsAlt s p1 (HsBody e2) ds')+                                      return r  +             rmInCase e2 = fail ""+             rmInPat exp (pat@(Dec (HsPatBind loc p (HsBody rhs) ds))::HsDeclP)+                | sameOccurrence exp rhs && ds /= []+                   =do+                       --  error "3"+                       redunDecs2 <- removeRedunWhere ds newExp+                       let redunDecs = ds \\ redunDecs2+                       ds'<- rmDecls ds redunDecs                                        +                       return (Dec (HsPatBind  loc p (HsBody rhs) ds'))       +                | sameOccurrence exp rhs && ds == [] && wh /= []+                   = do+                         -- error "2"+                         r <- update pat (Dec (HsPatBind  loc p (HsBody rhs) wh)) pat +                         return r   +             rmInPat exp (pat@(Dec (HsPatBind loc p g@(HsGuard es) ds))::HsDeclP)+                | checkES exp es && ds /= []+                   =do+                       --  error "3"+                       redunDecs2 <- removeRedunWhere ds newExp+                       -- circle through all expressions in guards+                       let firstExp = getExp' es+                       redunDecs3 <- removeRedunWhere ds firstExp +                       gatherRedun <- getExp ds (tail es)+                       -- error $ show (redunDecs2, redunDecs3)+                       let redunDecs = nub (((ds \\ redunDecs2) \\ redunDecs3) \\ gatherRedun)+                       ds'<- rmDecls ds redunDecs                                        +                       return (Dec (HsPatBind loc p g ds'))     +                | checkES exp es && ds == [] && wh /= []+                   = do+                         -- error "2"+                         r <- update pat (Dec (HsPatBind  loc p g wh)) pat +                         return r           +             rmInPat _ e2 = fail ""+             rmInMatch exp  (match@(HsMatch loc1  pnt pats (rhs@(HsBody e)) ds)::HsMatchP)+                | sameOccurrence exp e && wh /= []+                   = do+                        -- ds'' <- addDecl (HsMatch loc1 pnt pats rhs ds) Nothing ((nub (wh++ds)), Nothing) False+                        ds' <- rmDecls ds ds+                        ds'' <- addDecl (HsMatch loc1 pnt pats rhs ds') Nothing (wh, Nothing) False+                        return ds''+                | sameOccurrence exp e && ds /= [] +                   =do  +                       redunDecs2 <- removeRedunWhere (nub (ds++wh)) newExp+                       let redunDecs = (ds \\ redunDecs2) +                       ds'<- rmDecls ds redunDecs2   +                       -- error $ show redunDecs+                       return (HsMatch loc1 pnt pats rhs ds')++                | sameOccurrence exp e && ds == [] && wh /= []+                    = do+                         -- error (show wh)+                         ds' <- addDecl match Nothing (wh, Nothing) False+                         return ds'+             rmInMatch exp  (match@(HsMatch loc1  pnt pats (rhs@(HsGuard es)) ds)::HsMatchP)+              | checkES exp es && ds /= []+                  =do+                       redunDecs2 <- removeRedunWhere (nub (ds++wh)) newExp+                       -- circle through all expressions in guards+                       let firstExp = getExp' es+                       redunDecs3 <- removeRedunWhere ds firstExp +                       gatherRedun <- getExp ds (tail es)+                       -- error $ show (redunDecs2, redunDecs3)+                       let redunDecs = nub (((ds \\ redunDecs2) \\ redunDecs3) \\ gatherRedun)+                       ds'<- rmDecls ds redunDecs   +                       -- error $ show redunDecs+                       return (HsMatch loc1 pnt pats rhs ds')++              | checkES exp es && ds == [] && wh /= []+                    = do+                         -- error (show wh)+                         ds' <- addDecl match Nothing (wh, Nothing) False+                         return ds'++             rmInMatch _ e2 = fail ""+             +             checkES _ [] = False+             checkES exp ((_,_, e):gs)+               | sameOccurrence exp e = True+               | otherwise            = checkES exp gs+               +             getExp ds [] = return []+             getExp ds ((_,e1,e2):gs)+               = do+                    redunDecs1 <- removeRedunWhere ds e1+                    redunDecs2 <- removeRedunWhere ds e2+                    rest <- getExp ds gs+                    return ((redunDecs1 \\ redunDecs2) \\ rest)+              +             getExp' [] = defaultExp+             getExp' ((_,e1,_):es) = e1   +             --error ((show e1) ++ " " ++ (show e2)  )+             rmDecls wh [] = return wh+             rmDecls wh ((d@(Dec (HsPatBind loc1 pn e ds))::HsDeclP):xs)+                  = do+                      let newName = pNTtoPN (patToPNT pn)+                      decls' <- rmDecl newName False wh+                      decls'' <- rmDecls decls' xs+                      return decls''+             rmDecls wh ((d@(Dec (HsFunBind _ ((HsMatch loc pnt pats e ds):ms)))::HsDeclP):xs)+                  = do+                      let newName = pNTtoPN pnt+                      decls' <- rmDecl newName False wh+                      decls'' <- rmDecls decls' xs+                      return decls''+             rmDecls d _ = return wh+             +           {-  rmDecls wh d [] = return []+             rmDecls wh d (((Dec (HsPatBind loc1 pn (HsBody rhs) ds))::HsDeclP):xs)+                  = do+                      let newName = pNTtoPN (patToPNT pn)+                      decls' <- rmDecl newName False wh+                      decls'' <- rmDecls wh decls' xs+                      return decls''+             rmDecls _ d _ = return d -}++newMatch loc pnt pats rhs ds = HsMatch loc pnt pats (HsBody rhs) ds +newDecl loc pnt pats rhs ds = Dec (HsFunBind loc [HsMatch loc pnt pats (HsBody rhs) ds] )++checkFree :: [PName] -> [HsDeclP] -> [HsDeclP]+checkFree [] _ = []+checkFree _ [] = []+checkFree (p:ps) list = (checkSin p list) ++ (checkFree ps list)+                                 where+                                   checkSin :: PName -> [HsDeclP] -> [HsDeclP]+                                   checkSin p [] = []+                                   checkSin p (x:xs) +                                      | defines p x = [x]+                                      | otherwise   = checkSin p xs++checkFree2 :: [PName] -> [HsDeclP] -> [HsDeclP]+checkFree2 [] _ = []+checkFree2 _ [] = []+checkFree2 (p:ps) list = (checkSin p list) ++ (checkFree ps list)+                                 where+                                   checkSin :: PName -> [HsDeclP] -> [HsDeclP]+                                   checkSin p [] = []+                                   checkSin p (x:xs) +                                      | defines' p x = x : (checkSin p xs)+                                      | otherwise   = checkSin p xs+++{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++{-findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (SrcLoc, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+ -}                    +findDefNameAndExp toks beginPos endPos t+  = fromMaybe ([], defaultPNT, [], defaultExp, [], Def [])+              (applyTU (once_tdTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t)++    where+      --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats rhs@(HsBody e) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just ([loc1], pnt, pats, e, ds, (Match match))+      inMatch (match@(HsMatch loc1 pnt pats (rhs@(HsGuard es)) ds)::HsMatchP)+          = checkES es+                where+                   checkES [] = Nothing+                   checkES ((s, e1 , e): es)+                     | locToExp beginPos endPos toks e /= defaultExp+                          = Just ([loc1], pnt, pats, e, ds, (Match match))+                     | otherwise = checkES es+      inMatch x = Nothing++      --The selected sub-expression is in the rhs of a pattern-binding+      inPat (pat@(Dec (HsPatBind loc1 ps (rhs@(HsBody e)) ds))::HsDeclP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = if isSimplePatBind pat+              then Just ([loc1], patToPNT ps, [], e, ds, (MyPat pat))+              else error "Please select the result of the function!"+      inPat (pat@(Dec (HsPatBind loc1 ps (rhs@(HsGuard es)) ds))::HsDeclP)+        = checkES es+            where+               checkES [] = Nothing+               checkES ((s, e1 , e): es)+                 | locToExp beginPos endPos toks e /= defaultExp+                      = Just ([loc1], patToPNT ps, [], e, ds, (MyPat pat))+                 | otherwise = checkES es+      inPat _ = Nothing+      +     +
+ refactorer/RefacRemoveField.hs view
@@ -0,0 +1,310 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacRemoveField+-- Copyright   :  (c) Christopher Brown 2007+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Remove a field from a constructor and resolve+-- pattern matching by placing references to said+-- field by calls to error.++-----------------------------------------------------------------------------++module RefacRemoveField where+ +import PrettyPrint+import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils hiding (getParams)+import PFE0 (findFile)+import MUtils (( # ))+import RefacLocUtils+import System+import IO+import Char++refacRemoveField args+  = do+       let +           fileName    = args!!0+           pos         = args!!1+           row         = read (args!!2)::Int+           col         = read (args!!3)::Int++       AbstractIO.putStrLn "refacRemoveField"+       +       modInfo@(inscps, exps, mod, tokList) <- parseSourceFile (fileName)+       case checkCursor fileName row col mod of+              Left errMsg -> do error errMsg+              Right dat ->+                do+                 let res = locToPNT fileName (row, col) mod+                 let res2 = locToPN fileName (row, col) mod       +                 let decs = hsDecls mod       +                 let datDec = definingDecls [res2] decs False True+                 let datName = (declToName (head datDec))+                 let datPNT = (declToPNT (head datDec))+       +                 -- if the field in question is a record we must get+                 -- the name of the record...+              +                 ((_,m), (newToks, newMod)) <- applyRefac (removeField datName datPNT res pos tokList) +                                                          (Just (inscps, exps, mod, tokList)) fileName+       +                 writeRefactoredFiles False [((fileName, m), (newToks, newMod))]+              +                 AbstractIO.putStrLn "Completed.\n"+ +checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToTypeDecl of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the constructor name!")+     Just decl@(Dec (HsDataDecl loc c tp xs _)) -> Right decl          +   where+    locToTypeDecl = find (definesTypeCon (locToPNT fileName (row, col) mod)) (hsModDecls mod)+    +    -- definesTypeCon pnt (Dec (HsDataDecl loc c tp xs _)) +    --  = isDataCon pnt && (findPNT pnt tp)+    +    definesTypeCon pnt (Dec (HsDataDecl _ _ _ i _))+      = isDataCon pnt && (findPNT pnt i)+    definesTypeCon pnt _ = False + +   +removeField datName datPNT pnt pos tok (_, _, t)+ = do+      let fType = getField pnt ((read pos)::Int) t+      let fName = typToPNT (convertBang fType)+      newMod <- removingField pnt pos t+      d <- checkPat2 datName pnt pos newMod +      newMod' <- removingFieldInPat datName pnt pos tok d+      if d /= newMod+        then do+              newD' <- addDecl newMod' Nothing ([errorDecl], Nothing) True+              dataType <- getDataType datPNT newD'+              newTypedMod <- cleanTypeSigs fType fName datPNT datName pnt dataType newD'+              return newTypedMod+        else do+              dataType <- getDataType datPNT newMod'+              newTypedMod <- cleanTypeSigs fType fName datPNT datName pnt dataType newMod'+              return newTypedMod+      where+       errorDecl = (Dec (HsFunBind loc0 +                                   [HsMatch loc0 (nameToPNT "errorData") +                                                 listOfPats +                                                 (HsBody (createFunc (nameToPNT ("error" ++ datName)) listOfExps)) []]))+                 +       listOfPats = nameToPat "field" : (nameToPat "dat" : [nameToPat "function"])+       listOfExps = [Exp (HsId (HsVar (nameToPNT "(\"the binding for \" ++ field ++ \" in a pattern binding involving \" ++ dat ++ \" has been removed in function \" ++ function)"+                      )))]++convertBang (HsUnBangedType t) = t+convertBang (HsBangedType t) = t++getField pnt pos+ = (fromMaybe (error "not a valid field to remove!")).(applyTU (once_tdTU (failTU `adhocTU` inDatDeclaration)))+     where+       inDatDeclaration (dat@(HsConDecl _ _ _ i ts)::HsConDeclP)+        | pnt ==  i+          = Just (ts !! (pos-1))++       inDatDeclaration x = Nothing+       +       flatternTApp :: HsTypeP -> [HsTypeP]+       flatternTApp (Typ (HsTyFun t1 t2)) = flatternTApp t1 ++ flatternTApp t2+       flatternTApp (Typ (HsTyApp t1 t2)) = flatternTApp t1 ++ flatternTApp t2+       flatternTApp x = [x] ++getDataType datPNT t+ = applyTU (once_tdTU (failTU `adhocTU` inDatDeclaration)) t+     where+        inDatDeclaration (dat@(Dec (HsDataDecl a b tp c d))::HsDeclP)+         | (defineLoc datPNT == (defineLoc.typToPNT.(ghead "inDatDeclaration").flatternTApp) tp)+            = return dat+        inDatDeclaration d = fail ""+        +        flatternTApp :: HsTypeP -> [HsTypeP]+        flatternTApp (Typ (HsTyFun t1 t2)) = flatternTApp t1 ++ flatternTApp t2+        flatternTApp (Typ (HsTyApp t1 t2)) = flatternTApp t1 ++ flatternTApp t2+        flatternTApp x = [x]   +       +cleanTypeSigs fType fName datPNT datName pnt dataType t+ = applyTP (full_buTP (idTP `adhocTP` inDatDeclaration)) t+     where+       inDatDeclaration (dat@(Dec (HsDataDecl a b tp c d))::HsDeclP)+        | (defineLoc datPNT == (defineLoc.typToPNT.(ghead "inDatDeclaration").flatternTApp) tp) &&+           (redunParam (tail (flatternTApp tp)) c)+             = +             -- update the data declaration with the type removed!+                update dat (Dec (HsDataDecl a b (createDataFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) tp)+                                                  ( (tail (flatternTApp tp)) <-> (convertBang fType))) c d)) dat+       inDatDeclaration (dat@(Dec (HsTypeSig s is c t))::HsDeclP) +        | datName `elem` (map (pNTtoName.typToPNT) (flatternTApp t) )                                           +           = do       +               let res = changeType t dataType       +               if res == t+                 then return dat+                 else update dat (Dec (HsTypeSig s is c res)) dat                        +       inDatDeclaration t =return t+        +        +        +       changeType :: HsTypeP -> HsDeclP -> HsTypeP+       changeType t@(Typ (HsTyFun t1 t2)) x+         = (Typ (HsTyFun (changeType t1 x) (changeType t2 x)))   ++       changeType t@(Typ (HsTyApp t1 t2)) (Dec (HsDataDecl a b tp c d))+        | (defineLoc datPNT) == (defineLoc (convertToCon t1))     && +          ((pNTtoName fName) `elem` (map (pNTtoName.typToPNT) (flatternTApp t))) &&+          isLower (head (pNTtoName fName)) &&+          (redunParam (tail (flatternTApp tp)) c)+            = (createDataFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) t) +                                              ( ( (tail (flatternTApp t)) <-> (convertBang fType))))+       changeType t _ = t+       +       convertToCon :: HsTypeP -> PNT+       convertToCon (Typ (HsTyFun t1 t2)) = convertToCon t1+       convertToCon (Typ (HsTyApp t1 t2)) = convertToCon t1+       convertToCon (Typ (HsTyCon t1))  = t1+       convertToCon t = defaultPNT+            +       -- (<->) :: Term t => [a] -> a -> [a]+       (<->) [] _ = []+       (<->) (x:xs) y+          | (pNTtoName (typToPNT x)) == (pNTtoName (typToPNT y))   = (xs <-> y)     +          | otherwise =  x : (xs <-> y)+             +        +       -- convertBangs :: [HsBangType t] -> [HsTypeP]+       +        +       redunParam [] _ = False+       redunParam xs (cs) +        = length (filter id (map (inT cs) (map (pNTtoName.typToPNT) xs))) == 1++       inT2 [] _ = [False]+       inT2 ((HsConDecl s i c p types) :cs) x+            = ((x `elem` (map (pNTtoName.typToPNT) (map convertBang types))) : (cs `inT2` x))+       +       inT x y = (not.or) (x `inT2` y)+          +       flatternTApp :: HsTypeP -> [HsTypeP]+       flatternTApp (Typ (HsTyFun t1 t2)) = flatternTApp t1 ++ flatternTApp t2+       flatternTApp (Typ (HsTyApp t1 t2)) = flatternTApp t1 ++ flatternTApp t2+       flatternTApp x = [x]   ++removingField pnt pos t+ = applyTP (stop_tdTP (failTP `adhocTP` inDat)) t+    where+     inDat (dat@(HsConDecl s i c p types)::HsConDeclP)+       | p == pnt = do+                      r <- update dat (HsConDecl s i c p (newTypes types (read pos::Int))) dat+                      return r+     inDat (dat@(HsRecDecl s i c p types)::HsConDeclP)+       | p == pnt = do+                      r <- update dat (HsRecDecl s i c p (newRecTypes types (read pos::Int))) dat+                      return r       +     inDat _ = fail ""+     +     newRecTypes :: (Eq a) => [([a], b)] -> Int -> [([a], b)]+     newRecTypes xs i = newRecTypes' xs i 1+       where+         newRecTypes' :: (Eq a) => [([a], b)] -> Int -> Int -> [([a], b)]+         newRecTypes' [] i n = error "Please select a valid field position for this constructor!"+         newRecTypes' ((x,y):xs) i n +          | i >= n && i < (n+(length x)) = case newTypes' x i n of+                                                  [] -> xs+                                                  x  -> (x,y) : xs+          | otherwise = (x,y) : (newRecTypes' xs i (n+(length x)))            +     +     newTypes :: [a] -> Int -> [a] -- -> [HsBangType HsTypeP]+     newTypes xs i = newTypes' xs i 1++     newTypes' :: [a] -> Int -> Int -> [a]+     newTypes' [] _ _ = error "Please select a valid field position for this constructor!"+     newTypes' (x:xs) i n +         | n == i    = xs+         | otherwise = x : (newTypes' xs i (n+1)) ++removingFieldInPat datName pnt pos tok t+ = applyTP (stop_tdTP (failTP `adhocTP` inPat)) t+      where+        inPat d@(Dec _::HsDeclP)+          = do+               d'  <- checkPat1 pnt pos d+               d'' <- checkCall pnt pos d'+               return d''+                 where+                    -- checkPat :: (Term t) => PNT -> String -> t -> HsPatP+                    checkPat1 pnt pos t+                      = applyTP (full_tdTP (idTP `adhocTP` inP)) t+                    inP pat@(Pat (HsPApp i p)) +                      | (defineLoc i) == (defineLoc pnt) = RefacUtils.delete (p !! ((read pos::Int)-1)) pat+                    inP x =  return x+                                                +                    checkCall pnt pos t+                      = applyTP (stop_tdTP (failTP `adhocTP` conApp)) t+                    -- a constructor application...+                    conApp exp@(Exp (HsApp e1 e2))+                      | defineLoc pnt == (defineLoc.expToPNT.(ghead "inE").flatternApp) exp+                        = RefacUtils.delete ((tail (flatternApp exp)) !! ((read pos::Int)-1)) exp+                    conApp _ = mzero+                     +                    flatternApp :: HsExpP -> [HsExpP]+                    flatternApp (Exp (HsApp e1 e2)) = flatternApp e1 ++ flatternApp e2+                    flatternApp x = [x] +                    +                    (!-) :: Int -> Int -> [a] -> [a]+                    (!-) _ _ [] = []+                    (!-) n pos (x:xs)+                     | n == pos  = xs+                     | otherwise = x : (!-) n (pos + 1) xs+                    +                    newPats :: [HsPatP] -> Int -> Int -> [HsPatP]+                    newPats (p:ps) pos n+                     | n == pos  = ps+                     | otherwise = p : (newPats ps pos (n+1)) +        -- inPat x = fail ""++checkPat2 datName pnt pos t+ = applyTP (stop_tdTP (failTP `adhocTP` inPat)) t+      where+        inPat d@(Dec _::HsDeclP)+          = do+               d'' <- addCall (declToName d) pnt pos d+               return d''+        addCall funcName pnt pos t+          = applyTP (stop_tdTP (failTP `adhocTP` (inE funcName))) t +      +        -- a name associated to a pattern binding somewhere...  +        inE funcName exp@(Exp (HsId (HsVar x)))+          | (findPatBind pnt x (read pos::Int) t) +              = update exp  (Exp (HsApp (Exp  (HsApp  (Exp (HsApp (nameToExp ("error" ++ datName)) +                                                                  (nameToExp ("\"" ++ (pNTtoName x) ++ "\""))))+                                                      (nameToExp ("\"" ++ (pNTtoName pnt) ++ "\""))))+                                        (nameToExp ("\"" ++ funcName ++ "\"")))) exp+        inE _ x = mzero++findPatBind :: (Term t) => PNT -> PNT -> Int -> t -> Bool+findPatBind pnt x pos+   = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inBind)))+        where             +           inBind (dat@(Pat (HsPApp i types))::HsPatP)+              | pnt == i && checkInTypes x (types!!(pos-1)) = Just True+           inBind _ = Nothing  +           checkInTypes x (Pat (HsPId (HsVar typePnt)))+            |  defineLoc x == defineLoc typePnt = True+           checkInTypes _ x = False++-- thePNT id = (PNT (PN (UnQual id) (G (PlainModule "unknown") id (N (Just loc0)))) (Type (TypeInfo (Just Primitive) [] []))  (N (Just loc0)))
+ refactorer/RefacRenaming.hs view
@@ -0,0 +1,281 @@+++module RefacRenaming(rename) where++import Prelude hiding (putStrLn)+import System.IO.Unsafe+import AbstractIO (putStrLn)+import Maybe+import List  +import TypeCheck+import RefacUtils ++{-This refactoring renames an indentifier to a user-specified name.+  Conditions: a: the indentifier to be renamed should be defined in the current module.+              b. the user provided name should be a valid name with regard to the name space of the identifier.+              c. the new name should not change the semantics of the program, and should not cause any name +                 clash/conflict/ambiguity problem in the program. +  Attention: a. To select an identifier, stop the cursor at the beginning position of any occurrence of the identifier.+             b. Renaming a qualified name will not change the qualifier; +             c. In current module, an unqualified name won't become qualified after renaming; but, in client modules,+                an unqualified name might become qualified after renaming to avoid ambiguity prolem. In case the new name,+                say 'f', will cause ambiguous occurrence in the current module (this is because the identifier 'f' is+                imported from other modules), the user will be prompted to choose another new name or qualify the use +                of 'f' before doing renaming.                      + -}++{-In the current implementation, we assume that module name is same as the file name, but we+  should keep in mind that people also use unnamed modules.+-}+rename args+ = do let fileName  = args!!0+          newName   = args!!1            +          row       = read (args!!2)::Int+          col       = read (args!!3)::Int+      modName <- fileNameToModName fileName+      AbstractIO.putStrLn $ show modName+      (inscps, exps, mod,tokList) <- parseSourceFile fileName +      ++      --AbstractIO.putStrLn x+   --   i <- lift $ ghcTypeCheck "Fish.hs"+   --   AbstractIO.putStrLn i+      let pnt       = locToPNT fileName (row, col) mod   +          defineMod = if isTopLevelPN (pNTtoPN pnt)+                           then (fromJust (hasModName pnt))+                           else modName+      +      unless (pnt /= defaultPNT  && isValidNewName pnt newName) +         $ error "Invalid cursor position or the new name is invalid!\n" +      unless (pNTtoName pnt/=newName) $ error "The new name is same as the old name" +      unless (defineMod == modName ) ( error ("This idenifier is defined in module " ++ modNameToStr defineMod ++ +                                             ", please do renaming in that module!"))+      if isMainModule modName && pNTtoName pnt == "main"+          then error ("The 'main' function defined in a 'Main' module should not be renamed!")+          else do (mod',((tokList',modified),_))<-doRenaming pnt newName modName mod inscps exps+                                                  ((tokList,unmodified),fileName)+                  if isExported pnt exps  --no matter whether this pn is used or not.+                     then do clients<-clientModsAndFiles modName  --returns [(module name ,filename)] +                             refactoredClients <- mapM (renameInClientMod pnt newName) clients                           +                             writeRefactoredFiles False $ ((fileName,modified),(tokList',mod')):refactoredClients+                     else writeRefactoredFiles False [((fileName,modified), (tokList',mod'))]++---------Rename a type constructor-------------------------- +doRenaming oldPNT@(PNT (PN _ (G _ _ _)) (Type _) _) newName modName mod inscps exps env+  =doRenaming' oldPNT newName  mod mod (hsTypeConstrsAndClasses modName) exps env++---------Rename a class name---------------------------------+doRenaming oldPNT@(PNT _ (Class _ _) _) newName modName mod inscps exps env +  =doRenaming' oldPNT newName  mod mod (hsTypeConstrsAndClasses modName) exps env ++---------Rename a data structure-----------------------------+doRenaming oldPNT@(PNT _ (ConstrOf _  _) _) newName modName mod inscps exps env+  =doRenaming' oldPNT newName mod mod (hsDataConstrs modName)  exps env++---------Rename an instance name-----------------------------+doRenaming oldPNT@(PNT _ (MethodOf i _  _) _) newName modName mod inscps exps env -- Claus+   =runStateT (renameTopLevelVarName oldPNT newName modName inscps  exps mod True True) env++---------Rename a type variable name------------------------------+doRenaming oldPNT@(PNT oldPN@(PN i (S loc)) (Type _) _) newName modName mod inscps exps env+   = do let (before, parent, after)=divideDecls (hsDecls mod) oldPNT+        (parent',toks)<-doRenaming' oldPNT newName parent mod  hsTypeVbls exps  env+        return ((replaceDecls mod (before++parent'++after)),toks) ++---------Rename a field name -------------------------------------+doRenaming oldPNT@(PNT _ (FieldOf con typeInfo) _) newName modName mod inscps exps env +  =do let (before,parent,after)=divideDecls (hsDecls mod) oldPNT+          siblingNames=siblingFieldNames oldPNT+      (f',d') <- hsFDsFromInside (before++after)  +      if elem newName (siblingNames ++ map pNtoName d')+        then error("Name '"++newName++"'  already existed\n")+        else if elem newName $ fieldNames oldPNT+               then runStateT (renameTopLevelVarName oldPNT newName modName inscps exps mod False False) env+               else runStateT (renameTopLevelVarName oldPNT newName modName inscps exps mod False True) env+--------Rename a value varaible name--------------------------------+doRenaming oldPNT@(PNT oldPN Value loc) newName modName mod inscps exps env + = runStateT (applyTP (once_buTP (failTP `adhocTP` renameInMod+                             `adhocTP` renameInMatch+                             `adhocTP` renameInPattern+                             `adhocTP` renameInExp+                             `adhocTP` renameInAlt+                             `adhocTP` renameInStmts)) mod) env+   where +     -- 1. The name is declared in a module(top level name)+     renameInMod (mod::HsModuleP)+        |isDeclaredIn oldPN mod=renameTopLevelVarName oldPNT newName modName inscps exps mod True True+     renameInMod mod=mzero++     -- 2. The name is declared in a match+     renameInMatch (match::HsMatchP)+        |isDeclaredIn oldPN match=renameLocalVarName oldPN newName match+     renameInMatch match=mzero++     -- 3. The name is declared in a pattern binding.+     renameInPattern (pat:: HsDeclP)+        |isDeclaredIn oldPN pat=renameLocalVarName oldPN newName pat+     renameInPattern pat=mzero+ +     --4.The name is declared in a expression+     renameInExp (exp::HsExpP)+       |isDeclaredIn oldPN exp=renameLocalVarName oldPN newName exp+     renameInExp exp=mzero++     --5.The name is declared in a case alternative+     renameInAlt (alt::HsAltP)+       |isDeclaredIn oldPN alt=renameLocalVarName oldPN newName alt+     renameInAlt alt=mzero++     --6: The name is declared in a statment expression+     renameInStmts (stmts::HsExpP)+       |isDeclaredIn oldPN stmts=renameLocalVarName oldPN newName stmts+     renameInStmts stmts=mzero+++doRenaming' oldPNT@(PNT oldPN _ _) newName parent mod fun exps env+ = let (f',d')= fun parent+       (f,d)  =((nub.map pNtoName.filter (not.isQualifiedPN)) f', (nub.map pNtoName) d')+   in if elem newName (d \\ [pNtoName oldPN])+         then error("Name '"++newName++"'  already existed\n")+         else if elem newName f +               then error ("The new name will cause ambiguous occurrence problem,"+                           ++" please select another new name or qualify the use of "+                           ++ newName ++ " before renaming!\n")             +               else if causeNameClashInExports oldPN newName mod exps+                    then error ("The new name will cause cause conflicting exports, please select another new name!")+                    else runStateT (renamePN oldPN Nothing newName True parent) env +       +renameTopLevelVarName oldPNT@(PNT oldPN _ _) newName modName inscps exps mod existChecking exportChecking+  =do -- f' contains names imported from other modules; +      -- d' contains the top level names declared in this module;  +     (f',d') <- hsFDsFromInside mod  +      --filter those qualified free variables in f'+     let (f,d) = ((nub.map pNtoName.filter (not.isQualifiedPN)) f', (nub.map pNtoName) d')+     if elem newName f+       then error ("The new name will cause ambiguous occurrence problem,"+                   ++" please select another new name or qualify the use of ' " +                   ++ newName ++ "' before renaming!\n")  -- Another implementation option is to add the qualifier+                                                         -- to newName automatically.+       else if existChecking && elem newName (d \\ [pNtoName oldPN])  --only check the declared names here.+             then error ("Name '"++newName++"'  already existed\n") --the same name has been declared in this module.+             else if exportChecking && causeNameClashInExports oldPN newName mod exps+                    then error ("The new name will cause  conflicting exports, please select another new name!") +                    else if exportChecking && causeAmbiguityInExports oldPN  newName inscps mod+                          then error $"The new name will cause ambiguity in the exports of module "++ show modName ++ ", please select another name!"   +                          else do  -- get all of those declared names visible to oldPN at where oldPN is used.+                                 ds<-hsVisibleNames oldPN mod+                                 -- '\\[pNtoName oldPN]' handles the case in which the new name is same as the old name   +                                 if existChecking && elem newName ((nub (ds `union` f)) \\[pNtoName oldPN])+                                   then error ("Name '"++newName++"'  already existed, or rename '"+                                                ++pNtoName oldPN++ "' to '"++newName+++                                                "' will change the program's semantics!\n")+                                   else if exportChecking && isInScopeAndUnqualified newName inscps+                                          then renamePN oldPN (Just modName) newName True mod+                                          else renamePN oldPN  Nothing newName True mod ++renameLocalVarName oldPN newName t  +  =do (f,d) <- hsFDNamesFromInside t+      if elem newName (d \\ [pNtoName oldPN])  --only check the declared names here.+        then error ("Name '"++newName++"'  already existed\n")+        else do -- get all of those declared names visible to oldPN at where oldPN is used.+                ds<-hsVisibleNames oldPN t+                -- '\\[pNtoName oldPN]' handles the case in which the new name is same as the old name   +                if elem newName ((nub (ds `union` f)) \\[pNtoName oldPN])+                  then error ("Name '"++newName++"'  already existed, or rename '"+                               ++pNtoName oldPN++ "' to '"++newName+++                              "' will change the program's semantics!\n")+                  else renamePN oldPN Nothing newName True t +      + +   +renameInClientMod pnt@(PNT oldPN _ _) newName (m, fileName)+  =do (inscps, exps ,mod ,ts) <-parseSourceFile fileName+      let qualifier= hsQualifier pnt inscps +      if  qualifier == []  --this name is not imported, but it maybe used in the import list+       then +        do (mod', ((ts',m),f))<-runStateT (renamePN oldPN Nothing newName True mod) ((ts,unmodified), fileName)   +           return ((f,m),(ts',mod'))  +       else+         do if causeNameClashInExports oldPN newName mod exps  +             then error $"The new name will cause conflicting exports in module "++ show m ++ ", please select another name!"+             else do (mod',((ts',modified),f))<-runStateT (do mod'<-qualifyTopLevelVar newName inscps mod+                                                              worker oldPN newName mod' inscps (head qualifier))+                                                           ((ts,unmodified),fileName)+                     return ((f,modified), (ts',mod')) +          +  where+     qualifyTopLevelVar name inscps t+       = applyTP(full_tdTP(adhocTP idTP atPnt)) t  +        where+           atPnt pnt@(PNT pn ty loc@(N (Just (SrcLoc fileName _  row col))))+              | isTopLevelPNT pnt &&  pNTtoName pnt == name && canBeQualified pnt t +               = do let qualifier = ghead "qualfyTopLevelVar" $ hsQualifier  pnt inscps                              +                    renamePN pn (Just qualifier) name True pnt+           atPnt x = return x++     worker oldPN newName mod inscps qual  +        = do  vs<-hsVisibleNames oldPN mod   --Does this check names other than variable names?+              if elem newName ((nub vs) \\[pNtoName oldPN])  || isInScopeAndUnqualified newName inscps+                 then renamePN oldPN (Just qual) newName True mod  --rename to qualified Name+                 else do renamePN oldPN Nothing newName True mod ++---------------------------------------------+causeAmbiguityInExports pn  newName inscps mod +  = isInScopeAndUnqualified (pNtoName pn) inscps &&+    usedWithoutQual newName (hsModExports mod)+   +siblingFieldNames (PNT pn (FieldOf con typeInfo) loc)+  = let cons=constructors typeInfo+        orig1 = pNtoLoc pn+        con=filter (\x->elem orig1 (map pNtoLoc (fromMaybe [] (conFields x)))) cons+    in if con==[] then []+                  else (map pNtoName1 (fromMaybe [] (conFields (head con))))\\ [pNtoName pn]+   where+     pNtoLoc (PN _ orig1) = orig1+     pNtoName1 (PN i _) = i++fieldNames  (PNT pn (FieldOf con typeInfo) _)+ =let cons=constructors typeInfo+  in  (nub. map pNtoName) $ concatMap (fromMaybe [].conFields) cons +  where  pNtoName (PN i _) = i+++isValidNewName oldName newName+ = case oldName of+        (PNT (PN i (G _ _ _)) (Type _) _) ->if isConId newName then True+                                                               else error "Invalid type constructor name!"  +        (PNT _ (Class _ _) _)               ->if isConId newName then True+                                                               else error "Invalid class name!"+        (PNT _ (ConstrOf _  _) _)         ->if isConId newName then True+                                                               else error "Invalid data constructor name!"++        (PNT _ (FieldOf _ _ ) _ )         ->if isVarId newName then True+                                                               else error "Invalid field name!" ++        (PNT _ (MethodOf i _ _) _)          ->if isVarId newName then True +                                                               else error "Invalid class instance name!"+        +        (PNT (PN i (S loc)) (Type _) _)   ->if isVarId newName then True+                                                               else error "Invalid type variable name!"+ +        (PNT oldPN Value loc)      +          ->  let oldName' = pNTtoName oldName+              in if isVarId oldName' && not (isVarId newName)+                   then error "The new name should be an identifier!"+                   else if isOperator oldName' && not (isOperator newName)+                          then error "The new name should be an operator!"+                          else if (isVarId oldName' && isVarId newName) || +                                   (isOperator oldName' && isOperator newName)+                                  then True+                                  else error "Invalid new name!"++-- |Divide a declaration list into three parts (before, parent, after) according to the PNT,+-- where 'parent' is the first decl containing the PNT, 'before' are those decls before 'parent'+-- and 'after' are those decls after 'parent'.++divideDecls::[HsDeclP]->PNT->([HsDeclP],[HsDeclP],[HsDeclP])+divideDecls ds pnt+  = let (before,after)=break (\x->findPNT pnt x) ds+    in if (after/=[])+         then (before, [head after], tail after)+         else (ds,[],[]) 
+ refactorer/RefacRmCon.hs view
@@ -0,0 +1,495 @@+++module RefacRmCon(refacRmCon) where++import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils hiding (getParams)+import PFE0 (findFile)+import MUtils (( # ))+import RefacLocUtils+import System+import IO++{- This refactoring removes a user selected constructor from a data type and resolves all pattern matching.++   When a constructor is removed, all equations over that value will be commented out; all references to that value within an expression will be replaced with a call to error. +   +   Copyright   :  (c) Christopher Brown 2008++   Maintainer  :  cmb21@kent.ac.uk+   Stability   :  provisional+   Portability :  portable   +   +-}++data Decls = PatBind HsDeclP | MatchBind HsMatchP deriving (Read, Show, Eq)++refacRmCon args+ = do let fileName = ghead "filename" args +          --fileName'= moduleName fileName+          --modName  = Module fileName'  +          row      = read (args!!1)::Int+          col      = read (args!!2)::Int+      modName <-fileNameToModName fileName+      (inscps, exps, mod, tokList)<-parseSourceFile fileName +      case checkCursor fileName row col mod of+        Left errMsg -> do error errMsg+        Right dat ->+          do+           let pnt = locToPNT fileName (row, col) mod +           if (pnt /= defaultPNT)+            then +             if isDataCon pnt +               then do +                    let (pnts, defDecl) = pntsToBeRemoved pnt mod+                    if isExported (declToPNT defDecl) exps+                      then do+                              clients <- clientModsAndFiles modName+                              info    <- mapM parseSourceFile $ map snd  clients +                              ((_,m), (newToks, newMod))<-applyRefac (doRemoving pnt defDecl modName) +                                                                      (Just (inscps, exps, mod, tokList)) fileName+                              refactoredClients<-mapM (removeInClientMod pnt defDecl modName) $ zip info (map snd clients)+                              writeRefactoredFiles False $ ((fileName,m),(newToks,newMod)):refactoredClients+                              AbstractIO.putStrLn "\nCompleted.\n"                      +                      else do +                              ((_,m), (newToks, newMod))<-applyRefac (doRemoving pnt defDecl modName) +                                                                     (Just (inscps, exps, mod, tokList)) fileName+                              writeRefactoredFiles False [((fileName,m), (newToks,newMod))]+                              AbstractIO.putStrLn "\nCompleted.\n"                      +               else error "Please select a constructor!"+             else+              error "\nInvalid cursor position!"++checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToTypeDecl of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the constructor name!")+     Just decl@(Dec (HsDataDecl loc c tp xs _)) -> Right decl          +   where+    locToTypeDecl = find (definesTypeCon (locToPNT fileName (row, col) mod)) (hsModDecls mod)+    +    -- definesTypeCon pnt (Dec (HsDataDecl loc c tp xs _)) +    --  = isDataCon pnt && (findPNT pnt tp)+    +    definesTypeCon pnt (Dec (HsDataDecl _ _ _ i _))+      = isDataCon pnt && (findPNT pnt i)+    definesTypeCon pnt _ = False+++removeInClientMod pnt defDecl modName ((inscps, exps, mod,ts), fileName)+ = do+       ((_,m), (newToks, newMod))<-applyRefac (doRemoving2 pnt defDecl modName) +                                              (Just (inscps, exps, mod, ts)) fileName     +       return ((fileName, m), (newToks, newMod))++doRemoving2 pnt defDecl modName (_, exps, t)+  = do +       mod''  <- removePatEquation pnt defDecl modName exps t+       mod''' <- replaceOrdPats pnt defDecl mod''+  +       return mod'''++ +doRemoving pnt defDecl modName (_, exps, t)+  = do mod'   <- removeConstr pnt defDecl t+       mod''  <- removePatEquation pnt defDecl modName exps mod'+       mod''' <- replaceOrdPats pnt defDecl mod''+  +       return mod'''++createError :: String -> String -> Int -> HsExpP+createError newE typeName line+   = (Exp (HsApp (nameToExp "error") (nameToExp ("\""++newE++" no longer defined for "++typeName++" at line: "++(show line)++"\""))))+        +              +pntToLine pnt = let (SrcLoc fileName _ row col) = (useLoc pnt) in row++-- replace normal expression patterns with call to error+replaceOrdPats pnt defDecl t+  = applyTP (stop_tdTP (failTP `adhocTP` rmInExp)) t+      where+        rmInExp e@(Exp (HsId (HsCon x))) +         | defineLoc x == defineLoc pnt +             = do+                  let newE = (render.ppi) e+                  let typeName = declToName defDecl+                  let line = pntToLine pnt+                  update e (Exp (HsParen (createError newE typeName line))) e+        rmInExp e@(Exp (HsInfixApp e1 o@(HsCon x) e2 ))+         | defineLoc x == defineLoc pnt +             = do+                  let newE = (render.ppi) e+                  let typeName = declToName defDecl+                  let line = pntToLine pnt+                  update e (Exp (HsParen (createError newE typeName line))) e     +        rmInExp x = mzero++-- comment out all equations referencing removed+-- constructor+removePatEquation pnt defDecl modName exps t+  = applyTP (full_buTP (idTP   `adhocTP` rmInMod+                               `adhocTP` rmInMatch+                               `adhocTP` rmInPat+                               `adhocTP` rmInLet+                               `adhocTP` rmInAlt+                               `adhocTP` rmInLetStmt+                               `adhocTP` rmInMonad+                               )) t+   where+     -- 1. the equation to comment out is on the top level of a definition...+     rmInMod (mod@(HsModule loc name exps imps ds):: HsModuleP)  +       | canBeRemoved pnt mod   +                  =do +                      let declsToRemove = whatCanBeRemoved pnt mod +                      ds' <- rmDecls declsToRemove ds+                      -- do we need to comment out the type signature+                      -- of any entities?     +                      dsCommented <- comTypeSigs ds' (HsModule loc name exps imps ds') ds'+                      -- check for calls to deleted definitions+                      let removedElems = ds \\\ dsCommented+                      dsReplacedCall <- checkCalls removedElems dsCommented   +                      -- check that deleted defintion is not exported...                      +                      return (HsModule loc name exps imps dsReplacedCall) +     rmInMod x = return x+     +     --2. The definition to be removed is a local declaration in a match+     rmInMatch (match@(HsMatch loc name pats rhs ds)::HsMatchP)+       | canBeRemoved pnt match+                   =do +                       let declsToRemove = whatCanBeRemoved pnt match+                       ds'<-rmDecls declsToRemove ds+                       dsCommented <- comTypeSigs ds' (HsMatch loc name pats rhs ds') ds'+                       let removedElems = ds \\\ dsCommented+                       rhsReplacedCall <- checkCalls removedElems rhs+                       return (HsMatch loc name pats rhsReplacedCall dsCommented)+     rmInMatch x =return x+   +     --3. The definition to be removed is a local declaration in a pattern binding+     rmInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+       | canBeRemoved pnt pat+                   =do +                       let declsToRemove = whatCanBeRemoved pnt pat+                       ds'<- rmDecls declsToRemove ds+                       dsCommented <- comTypeSigs ds' (Dec (HsPatBind loc p rhs ds')) ds'+                       let removedElems = ds \\\ dsCommented+                       rhsReplacedCall <- checkCalls removedElems rhs+                       return (Dec (HsPatBind  loc p rhsReplacedCall dsCommented))                      +     rmInPat x =return x+   +     --4.The definition to be removed is a local declaration in a let expression +     rmInLet (letExp@(Exp (HsLet ds e))::HsExpP)+       | canBeRemoved pnt letExp+                  = do +                       let declsToRemove = whatCanBeRemoved pnt letExp+                       ds'<- rmDecls declsToRemove ds+                       if ds'==[] then return e+                                  else do dsCommented <- comTypeSigs ds' (Exp (HsLet ds' e)) ds'+                                          let removedElems = ds \\\ dsCommented+                                          eReplacedCall <- checkCalls removedElems e+                                          return (Exp (HsLet dsCommented eReplacedCall))+     rmInLet (letExp@(Exp (HsListComp (HsLetStmt ds stmts))))  -- e.g. [0|z=1] => [0]+       | canBeRemoved pnt letExp+                 =do +                     let declsToRemove = whatCanBeRemoved pnt letExp+                     ds'<- rmDecls declsToRemove ds +                     dsCommented <- comTypeSigs ds' (Exp (HsListComp (HsLetStmt ds' stmts))) ds'+                     let removedElems = ds \\\ dsCommented+                     sReplacedCall <- checkCalls removedElems stmts+                     if ds'/=[] +                         then return (Exp (HsListComp (HsLetStmt dsCommented sReplacedCall)))+                         else if isLast stmts+                                then return (Exp (HsList [fromJust (expInLast sReplacedCall)]))+                                else return (Exp (HsListComp sReplacedCall))+     rmInLet x = return x +   +     --5. The defintion to be removed is a local decl in a case alternative.+     rmInAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+       |canBeRemoved pnt alt+           =do +               let declsToRemove = whatCanBeRemoved pnt alt+               ds'<- rmDecls declsToRemove ds+               dsCommented <- comTypeSigs ds' (HsAlt loc p rhs ds') ds'+               let removedElems = ds \\\ dsCommented+               rhsReplacedCall <- checkCalls removedElems rhs+               return (HsAlt loc p rhsReplacedCall dsCommented)+     rmInAlt x = return x +     +     --6. The definition to be removed is a local decl in a let statement.+     rmInLetStmt (letStmt@(HsLetStmt ds stmts)::(HsStmt (HsExpP) (HsPatP) [HsDeclP]))+       |canBeRemoved pnt letStmt+          =do +              let declsToRemove = whatCanBeRemoved pnt letStmt +              ds'<- rmDecls declsToRemove ds +              dsCommenting <- comTypeSigs ds' (HsLetStmt ds' stmts) ds'+              let removedElems = ds \\\ dsCommenting+              sReplacedCall <- checkCalls removedElems stmts+              if ds'==[]  then return sReplacedCall+                          else return (HsLetStmt dsCommenting sReplacedCall)+     rmInLetStmt x = return x+        +     --7. If the definition occurs within a pattern binding in a monadic expression+     -- give an error.+     rmInMonad (letStmt@(HsLetStmt ds stmts)::HsStmtP)+       |canBeRemoved pnt letStmt+          =do +              let declsToRemove = whatCanBeRemoved pnt letStmt +              ds'<- rmDecls declsToRemove ds +              dsCommenting <- comTypeSigs ds' (HsLetStmt ds' stmts) ds'+              let removedElems = ds \\\ dsCommenting+              sReplacedCall <- checkCalls removedElems stmts+              if ds'==[]  then return sReplacedCall+                          else return (HsLetStmt dsCommenting sReplacedCall)+     +     rmInMonad (mon@(HsGenerator s p e stmts)::HsStmtP)+       | (defineLoc pnt) `elem` flatternPat p+             = error "Refactoring cannot be performed as constructor is used in a pattern binding!"   -- [decl]+     rmInMonad x = return x++                +       +     -- list1 minus list2  +     (\\\) :: [HsDeclP] -> [HsDeclP] -> [HsDeclP] +     (\\\) list1 list2 = convertMatches list1 \\\\ convertMatches list2+    +       +     (\\\\) [] _ = []+     (\\\\) (d@(Dec (HsFunBind loc [HsMatch loc2 name _ _ _])):ls) list2+      | name `elem2` list2 = ls \\\\ list2+      | otherwise      = d : ls \\\\ list2+         where+           elem2 _ [] = False+           elem2 name (d@(Dec (HsFunBind loc [HsMatch loc2 name2 _ _ _])):ds)+             | name == name2 = True+             | otherwise     = name `elem2` ds+           elem2 name (d:ds) = name `elem2` ds+     (\\\\) (d:ds) list2+       | d `elem` list2 = ds \\\\ list2+       | otherwise      = d : ds \\\\ list2+     +     +     convertMatches :: [HsDeclP] -> [HsDeclP]+     convertMatches [] = []+     convertMatches ((Dec (HsFunBind loc ms)):ds)+               = let toFunBind m = Dec (HsFunBind loc [m])+                 in (map toFunBind ms) ++ (convertMatches ds)+     convertMatches (d:ds) = d : convertMatches ds+                 +        +     -- checkCalls searched for all identifiers and checks whether their +     -- defining entity still occurs or not.+     -- if not, the identifier is replaced with a call to error+     -- (passing in its parameters via a show)+        +     checkCalls decs t+        = applyTP (stop_tdTP (failTP   `adhocTP` rmInExp )) t+            where            +              rmInExp e@(Exp (HsId (HsVar x)))+               | definingDecls [pNTtoPN x] decs False True /= [] +                    = do+                         let newE = (render.ppi) e+                         let typeName = declToName defDecl+                         let line     = pntToLine pnt+                         update e (createError newE typeName line) e++              ++              rmInExp e@(Exp (HsApp e1 e2)) +               | concatMap (definingDecls' decs False True) (map expToPN (flatternApp e)) /= []+                = do+                    let newE = (render.ppi) e+                    let typeName = declToName defDecl+                    let line = pntToLine pnt+                    update e (createError newE typeName line) e+               +               +              rmInExp x = mzero                +               +              definingDecls' x y z l = definingDecls [l] x y z +                      +              flatternApp :: HsExpP -> [HsExpP]+              flatternApp (Exp (HsApp e1 e2)) = flatternApp e1 ++ flatternApp e2+              flatternApp (Exp (HsParen e)) = flatternApp e+              flatternApp x = [x]+        ++        +        +     -- comTypeSigs :: (MonadState (([PosToken], Bool), t1) m, MonadPlus m) => [HsDeclP] -> [HsDeclP] -> m [HsDeclP]+     comTypeSigs [] _ _ = return []+     comTypeSigs (d@(Dec (HsTypeSig _ _ _ _)):ds) e decs+      | not (any (isTypeSigOf' d) (map declToPNT' (hsDecls e)))+           = do -- we must comment out this type signature+                       rest <- comTypeSigs ds e decs+                       ((toks,_),others)<-get   +                       let (startPos,(endPosR, endPosC)) = getStartEndLoc toks d+                           (toks', decls') +                               = ((commentToks (startPos, (endPosR, endPosC)) toks),(rest \\ [d])) +                       put ((toks',modified),others)+                       let res = decls' +                       if isExported (declToPNT d) exps+                        then error ("Removing constructor forces " ++ (declToName d) ++ " in module " +                                  ++ (modNameToStr modName) ++ " to be removed. Please un-export it first.")+                        else return res+     --  | otherwise = rmTypeSig ds environ+     comTypeSigs (d:ds) e decs = do +                               rest <- comTypeSigs ds e decs+                               return (d : rest)+        +     -- | Return True if the declaration defines the type signature of the specified identifier.+     isTypeSigOf' :: HsDeclP -> PNT-> Bool+     isTypeSigOf' (Dec (HsTypeSig loc is c tp)) pnt = elem (rmLocs pnt) (map rmLocs is)  +     isTypeSigOf' _  _ =False   +        +        +     rmDecls :: (MonadState (([PosToken], Bool), t1) m, MonadPlus m)+                 => [Decls] -> [HsDeclP] -> m [HsDeclP]+     rmDecls [] e   = return e +     rmDecls  ((PatBind decl):ds) decls+       = do rest <- rmDecls ds decls+            ((toks,_),others)<-get   +            let (startPos,(endPosR, endPosC)) = getStartEndLoc toks decl+                (toks', decls') +                    = ((commentToks (startPos, (endPosR, endPosC)) toks),(rest \\ [decl])) +            put ((toks',modified),others)+            let res = decls' +            return res+            +     rmDecls ((MatchBind match):ds) decls+      = do rest <- rmDecls ds decls+           ((toks,_),others)<-get +           let (startPos,(endPosR, endPosC)) = getStartEndLoc toks match+               modDecls = removedMatch match rest -- decls  +               (toks', decls') +                    = ((commentToks  (startPos, (endPosR, endPosC)) toks), modDecls)+           put ((toks',modified),others)+           let res = decls' +           return res++           +     removedMatch match decls =+         concatMap (removeMatch match) decls+            +     removeMatch match decl@(Dec (HsFunBind loc (m:ms)))+       | removesMatches match (m:ms) == [] = []+       | otherwise  = [ (Dec (HsFunBind loc (removesMatches match (m:ms)))) ]+     removeMatch m d = [d]+            +     removesMatches match [] = []+     removesMatches match (m:ms)+         | sameOccurrence match m = removesMatches match ms   +         | otherwise              = m : removesMatches match ms+      +      +     isLast (HsLast e)=True+     isLast _=False++     --returns the expression included in the last statement.+     expInLast::HsStmtP->Maybe HsExpP +     expInLast (HsLast e)=Just e+     expInLast _=Nothing +++        +     canBeRemoved pn t +               =let decls=hsDecls t+                    decl=definingDecls2 pnt decls False+                    -- pnames=concatMap definedPNs decl   +                    in (decl/=[] && all (not.flip findPNRHS (replaceDecls t (decls \\ decl))) [pNTtoPN pn])++     whatCanBeRemoved pn t +               =let decls=hsDecls t+                    decl=definingDecls1 pnt decls False+                in decl+                +removeConstr pnt defDecl t+  = applyTP (once_tdTP (failTP `adhocTP` rmInDat)) t+ +      where+        --1. The constructor is within a data declaration+        rmInDat (dat@(Dec (HsDataDecl a b t c d))::HsDeclP)+          | sameOccurrence dat defDecl = do+                                            let newConstrs = removeConst c (pNTtoPN pnt)+                                            update dat (Dec (HsDataDecl a b t newConstrs d)) dat+        rmInDat _ = mzero+        +        +        removeConst [] _ = []+        removeConst (m@(HsConDecl _ _ _ (PNT pname _ _) _):ms) pn+           | pname == pn = (removeConst ms pn)+           | otherwise   = m : (removeConst ms pn)+        removeConst (m@(HsRecDecl _ _ _ (PNT pname _ _) _):ms) pn+           | pname == pn = (removeConst ms pn)+           | otherwise   = m : (removeConst ms pn)+ +pntsToBeRemoved pnt t+ = let decls=hsDecls t+       decl=definingDecls [pNTtoPN pnt] decls False False+   in (concatMap definedPNsForConstr decl, ghead "pntsToBeRemoved" decl)+   +--Find those declarations(function/pattern binding and type signature) which reference+-- the constructor on the LHS of the equation++-- if we are removing the last equation then we must also remove the type signature...+definingDecls1::PNT->[HsDeclP]->Bool->[Decls]+definingDecls1 pnt ds incTypeSig=concatMap (defines pnt) ds +      where +       defines pnt decl@(Dec (HsFunBind loc (m:ms)))+         = nub (definesMatches (m:ms))+            where+              definesMatches [] = []+              definesMatches (decl@(HsMatch loc1 (PNT pname ty loc2) pats rhs ds'):ms)+                 | (defineLoc pnt) `elem` (concatMap flatternPat pats) +                                                 = (MatchBind decl) : definesMatches ms+                 | otherwise = definesMatches ms+       defines pnt decl@(Dec (HsPatBind loc p rhs ds)) +         | (defineLoc pnt) `elem` flatternPat p = [PatBind decl]++       +       defines pn decl= []+ +--Find those declarations(function/pattern binding and type signature) which reference+-- the constructor on the LHS of the equation+definingDecls2::PNT->[HsDeclP]->Bool->[HsDeclP]+definingDecls2 pnt ds incTypeSig=concatMap (defines pnt) ds +      where +       defines pnt decl@(Dec (HsFunBind loc (m:ms)))+         | or (definesMatches (m:ms)) = [decl]+            where+              definesMatches [] = [False]+              definesMatches (decl@(HsMatch loc1 (PNT pname ty loc2) pats rhs ds'):ms)+                 | (defineLoc pnt) `elem` (concatMap flatternPat pats) +                                                        = True : definesMatches ms+                 | otherwise = definesMatches ms+       defines pnt decl@(Dec (HsPatBind loc p rhs ds)) +         | (defineLoc pnt) `elem` flatternPat p = error "Refactoring cannot be performed as constructor is used in a pattern binding!"   -- [decl]++       +       defines pn decl= []       +       +flatternPat :: HsPatP -> [SrcLoc]  +flatternPat t+  = inPat t+    where+      inPat (Pat (HsPId (HsVar pnt@(PNT _ _ _)))) = [defineLoc pnt]+      inPat (Pat (HsPInfixApp p1 pnt@(PNT _ _ _) p2)) +          = addPat (defineLoc pnt) (concatMap flatternPat [p1,p2])+      inPat (Pat (HsPApp pnt@(PNT _ _ _) pats))=addPat (defineLoc pnt) (concatMap flatternPat pats)+      inPat (Pat (HsPRec pnt@(PNT _ _ _) fields))=[defineLoc pnt]+      inPat (Pat (HsPTuple _ pats)) = concatMap flatternPat pats+      inPat (Pat (HsPList _ pats)) = concatMap flatternPat pats+      inPat (Pat (HsPParen pats) )  = flatternPat pats+      inPat (Pat (HsPAsPat _ pats)) = flatternPat pats+      inPat (Pat (HsPIrrPat pats))  = flatternPat pats+      inPat _ = []+ +      addPat pat mfd= ([pat] `union` mfd)+      +
+ refactorer/RefacRmDef.hs view
@@ -0,0 +1,162 @@+++module RefacRmDef(removeDef) where++import PosSyntax+import Maybe+import TypedIds+import UniqueNames+import List +import TiPNT +import RefacUtils +import PNT++{-This refactoring removes a user selected function binding or a pattern binding if it is not used elsewhere+  When a function/pattern is removed, it's corresponding type signature should be removed as well. In the case+  that the type signature is like this a,b:: blah balh, only the name is removed from the type signature.+  A function binding  can be removed if the function name is not used elsewhere; A pattern binding can be +  removed only if none of the names defined in this pattern binding is used elsewhere.+-}++removeDef args+ = do let fileName = ghead "filename" args +          --fileName'= moduleName fileName+          --modName  = Module fileName'  +          row      = read (args!!1)::Int+          col      = read (args!!2)::Int+      (inscps, _, mod, tokList)<-parseSourceFile fileName         +      let pn = pNTtoPN $ locToPNT fileName (row, col) mod                                            +      if (pn /= defaultPN) +       then if isTopLevelPN pn  +             then do let pns=pnsToBeRemoved pn mod +                     if any (flip isExplicitlyExported mod) pns+                       then error "This definition can not be removed, as it is explicitly exported by this module!"+                       else do +                               (mod',((tokList',modified),_))<-doRemoving pn fileName mod tokList+                               if isTopLevelPN pn +                                then do modName <- RefacUtils.fileNameToModName fileName  +                                        clients<-clientModsAndFiles modName+                                        refactoredClients <- mapM (refactorInClientMod pns) clients+                                        writeRefactoredFiles False $ ((fileName,modified),(tokList',mod')):refactoredClients+                                else writeRefactoredFiles False [((fileName,modified), (tokList',mod'))]+             else do (mod',((tokList',modified),_))<-doRemoving pn fileName mod tokList+                     writeRefactoredFiles False [((fileName,modified), (tokList',mod'))]+       else error "\nInvalid cursor position!" ++doRemoving pn fileName mod tokList +    =  runStateT (applyTP ((once_tdTP (failTP `adhocTP` rmInMod+                                              `adhocTP` rmInMatch+                                              `adhocTP` rmInPat+                                              `adhocTP` rmInLet+                                              `adhocTP` rmInAlt+                                              `adhocTP` rmInLetStmt)) `choiceTP` failure) mod)+                                                         ((tokList,unmodified),fileName)+                       +           where          +             --1. The definition to be removed is one of the module's top level declarations.+             rmInMod (mod@(HsModule loc name exps imps ds):: HsModuleP)  +                | canBeRemoved pn mod   +                  =do ds'<-rmDecl pn True ds+                      return (HsModule loc name exps imps ds') +             rmInMod _ =mzero++             --2. The definition to be removed is a local declaration in a match+             rmInMatch (match@(HsMatch loc name pats rhs ds)::HsMatchP)+                 | canBeRemoved pn match+                   =do ds'<-rmDecl pn True ds+                       return (HsMatch loc name pats rhs ds')+             rmInMatch _ =mzero++             --3. The definition to be removed is a local declaration in a pattern binding+             rmInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP)+                | canBeRemoved pn pat+                   =do ds'<- rmDecl pn True ds+                       return (Dec (HsPatBind  loc p rhs ds'))                      +             rmInPat _=mzero+              +             --4.The definition to be removed is a local declaration in a let expression+             rmInLet (letExp@(Exp (HsLet ds e))::HsExpP)+               | canBeRemoved pn letExp+                  =do ds'<- rmDecl pn True ds+                      if ds'==[] then return e+                                 else return (Exp (HsLet ds' e))+             rmInLet (letExp@(Exp (HsListComp (HsLetStmt ds stmts))))  -- e.g. [0|z=1] => [0]+               | canBeRemoved pn letExp+                 =do ds'<- rmDecl pn True ds +                     if ds'/=[] +                         then return (Exp (HsListComp (HsLetStmt ds' stmts)))+                         else if isLast stmts+                                then return (Exp (HsList [fromJust (expInLast stmts)]))+                                else return (Exp (HsListComp stmts))+             rmInLet _=mzero +       +             --5. The defintion to be removed is a local decl in a case alternative.+             rmInAlt (alt@(HsAlt loc p rhs ds)::(HsAlt (HsExpP) (HsPatP) [HsDeclP]))+                |canBeRemoved pn alt+                =do ds'<- rmDecl pn True ds+                    return (HsAlt loc p rhs ds')+             rmInAlt _=mzero+            +             --6. The definition to be removed is a local decl in a let statement.+             rmInLetStmt (letStmt@(HsLetStmt ds stmts)::(HsStmt (HsExpP) (HsPatP) [HsDeclP]))+                |canBeRemoved pn letStmt+               =do ds'<- rmDecl pn True ds +                   if ds'==[]  then return stmts+                              else return (HsLetStmt ds' stmts)+             rmInLetStmt _=mzero+      +             isLast (HsLast e)=True+             isLast _=False++             --returns the expression included in the last statement.+             expInLast::HsStmtP->Maybe HsExpP +             expInLast (HsLast e)=Just e+             expInLast _=Nothing+ +             failure=idTP `adhocTP` mod+              where+               mod (m::HsModuleP)+                = error ("Refactoring Failed! Possible reasons: a) selected identifier is not a function/pattern name defined in this module;"+++                          " b) the identifer is used elsewhere;") +  +             canBeRemoved pn t +               =let decls=hsDecls t+                    decl=definingDecls1 [pn] decls False+                    pnames=concatMap definedPNs decl                    +                in (decl/=[] && all (not.flip findPN (replaceDecls t (decls \\ decl))) pnames)++  +pnsToBeRemoved pn t+ = let decls=hsDecls t+       decl=definingDecls [pn] decls False False+   in concatMap definedPNs decl         ++refactorInClientMod pns (modName, fileName)+  = do (inscps, exps, mod ,ts) <-parseSourceFile fileName+       if any (flip findPN (hsModDecls mod)) pns || any (flip findPN (hsModExports mod)) pns+          then error $ "This definition can not be removed, as it is used by the client module '"++modName'++"'!"+          else do let pnsToBeHided= filter (flip findPN (hsModImports mod)) pns +                  if pnsToBeHided/=[]  +                     then do (mod', ((ts',m),_))<-runStateT (rmItemsFromImport mod pnsToBeHided)+                                                       ((ts,unmodified),fileName)+                             return ((fileName,m), (ts',mod'))+                     else return ((fileName,unmodified), (ts,mod)) +     where modName' = modNameToStr modName++--Find those declarations(function/pattern binding and type signature) which define pn-+--splitTypeSig indicates whether the corresponding type signature will be splited.+definingDecls1::[PName]->[HsDeclP]->Bool->[HsDeclP]+definingDecls1 pns ds incTypeSig=concatMap (defines pns) ds +      where +       defines pn decl@(Dec (HsFunBind loc ((HsMatch loc1 (PNT pname ty loc2) pats rhs ds):ms)))+          | isJust (find (==pname) pns)=[decl]+       defines pn decl@(Dec (HsPatBind loc p rhs ds))    ---CONSIDER AGAIN----+          |(hsPNs p) `intersect` pns /=[]=[decl]+       defines pn decl@(Dec (HsTypeSig loc is c tp)) --handle cases like  a,b::Int +          |(map pNTtoPN is) `intersect` pns /=[]+          =if incTypeSig then [(Dec (HsTypeSig loc (filter (\x->isJust (find (==pNTtoPN x) pns)) is) c tp))]+                           else [decl]+       defines pn decl=[]   +++
+ refactorer/RefacSimplify.hs view
@@ -0,0 +1,826 @@+module RefacSimplify (zipPatExp, simplifyExpr) where++import TypeCheck+import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils hiding (getParams)+import PFE0 (findFile, allFiles, allModules)+import MUtils (( # ))+import RefacLocUtils+import System+import IO+import Relations+import Ents+import Data.Set (toList)+import Data.List+import System.IO.Unsafe+import System.Cmd+import LocalSettings+-- | An argument list for a function which of course is a list of paterns.+type FunctionPats = [HsPatP]++-- | A list of declarations used to represent a where or let clause.+type WhereDecls = [HsDeclP]++data PatFun = Mat | Patt | Er deriving (Eq, Show)++simplifyExpr args+ =do let fileName = ghead "fileName'" args +         beginRow         = read (args!!1)::Int+         beginCol         = read (args!!2)::Int+         endRow           = read (args!!3)::Int+         endCol           = read (args!!4)::Int+     AbstractIO.putStrLn "SimplifyExpr"    +          +     modName <-fileNameToModName fileName+     let modName1 = convertModName modName+     AbstractIO.putStrLn $ show modName1+     (inscps, exps, mod, tokList)<-parseSourceFile fileName+     let subExp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod+     let (ty, pnt, pats, _, wh)+             = findDefNameAndExp tokList+                                 (beginRow, beginCol)+                                 (endRow, endCol)+                                 mod+      +     case subExp of+       (Exp (HsCase _ _)) +         -> do                                                         +                                      +               ((_,m), (newToks, newMod)) <- applyRefac +                                                       (addExpression pnt subExp) +                                                       (Just (inscps, exps, mod, tokList)) fileName+               writeRefactoredFiles True [((fileName, m), (newToks, newMod))] +     +               -- need to reparse to capture added definition...+               (inscps2, exps2, mod2, tokList2)<-parseSourceFile fileName+               ((_,m'), (newToks', newMod')) <- applyRefac +                                                          (changeExpression fileName (modNameToStr modName) pnt subExp) +                                                          (Just (inscps2, exps2, mod2, tokList2)) fileName+               writeRefactoredFiles True [((fileName, m'), (newToks', newMod'))] +               -- can we evaluate the result to get a further simplification?+               -- Warning: this may cause the refactorer to loop indefinately,+               -- and will only succedd in decidable evaluations that can be+               -- converted to string via show.+               {-(inscps3, exps3, mod3, tokList3)<-parseSourceFile fileName+               ((_,m''), (newToks'', newMod'')) <- applyRefac +                                                          (evalExpression fileName ses (modNameToStr modName) pnt subExp) +                                                          (Just (inscps3, exps3, mod3, tokList3)) fileName+               writeRefactoredFiles True [((fileName, m''), (newToks'', newMod''))] -}+               +               +               +               AbstractIO.putStrLn "Completed.\n"+       x -> error "Please highlight a case expression!"+convertModName (PlainModule s) = s+convertModName m@(MainModule f) = modNameToStr m  ++evalExpression f ses modName pnt e (_,_,t)+ = do+      mod <- evalExpression' f ses modName pnt e t+      return mod+      +evalExpression' f ses modName pnt e t+  = applyTP (full_tdTP (idTP `adhocTP` inDec)) t+     where+       inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)+         | findPNT pnt matches+             = do +                  let match@(HsMatch loc name pats rhs@(HsBody exp) ds) = getMatch pnt matches+                  (free,decs) <- hsFreeAndDeclaredNames match+                  let lambdas  = getFreeLambdas rhs+                  +                  -- lift $ AbstractIO.putStrLn $ show lambdas+                  +                  let newPats   = map createCall (pats++lambdas)+                      newName   = pNTtoName name+                  result <- ghcEvalExpr f ((newName ++ " " ++ (concatMapWithSpace (render.ppi) newPats))) modName+                  case result of +                    "-1" -> return dec+                    _ -> do+                            let newExp = (Exp (HsId (HsVar (nameToPNT result))))+                                 +                                 -- insertComment ("Result of " ++ newName ++" :" ++ result) (pNTtoPN (patToPNT p)) t +                                 +                            update exp newExp exp+                            return dec++       inDec (dec@(Dec (HsPatBind s p rhs@(HsBody exp) ds)))+         | findPNT pnt p+            = do +                  -- let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches+                  +                  -- try and evaluate the highlighted expression+                  -- first let's transform the case so that each pattern match returns +                  -- a number, we can then use this to determine which+                  -- clause has suceeded.+                  (free,decs) <- hsFreeAndDeclaredNames dec+                  +                  let lambdas  = getFreeLambdas rhs+                      lambdas2 = getAllLambdas rhs+                  +                  +                  let newPats   = map createCall lambdas+                      newName   = pNTtoName (patToPNT p)+                  result <- ghcEvalExpr f ((newName ++ " " ++ (concatMapWithSpace (render.ppi) newPats))) modName+                  case result of+                    ("-1") -> do+                                 return dec+                    _ -> do+                                 let newExp = (Exp (HsId (HsVar (nameToPNT result))))+                                 +                                 -- insertComment ("Result of " ++ newName ++" :" ++ result) (pNTtoPN (patToPNT p)) t +                                 +                                 update exp newExp exp+                                 return dec+       inDec x = return x+changeExpression f modName pnt e (_,_,t) + = do+      mod <- changeExpression' f modName pnt e t+      return mod + +changeExpression' f modName pnt e t+  = applyTP (full_tdTP (idTP `adhocTP` inDec)) t+     where+       inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)+         | findPNT pnt matches+             = do +                  let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches+                  +                  -- try and evaluate the highlighted expression+                  -- first let's transform the case so that each pattern match returns +                  -- a number, we can then use this to determine which+                  -- clause has suceeded.+                  (free,decs) <- hsFreeAndDeclaredNames match+                  +                  let lambdas  = getFreeLambdas rhs+                  +                  -- lift $ AbstractIO.putStrLn $ show lambdas+                  +                  let newPats   = map createCall (pats++lambdas)+                      newName   = mkNewName (pNTtoName name) (free++decs) 0+                  result <- ghcEvalExpr f ((newName ++ " " ++ (concatMapWithSpace (render.ppi) newPats))) modName+                  case result of+                    ("-1") -> do+                               -- remove the temp declaration...                  +                               let declsP = map declToPName2 (hsDecls t)+                                   declP = findDec newName declsP+                               rmDecl declP False (hsDecls t)+                               return dec+                    _    -> do+                               let ps = patternise (hsDecls rhs)+                               -- lift $ AbstractIO.putStrLn $ show (ps)+                               lift $ AbstractIO.putStrLn $ (result \\ result)+                                    +                               newExp <- rewriteExp result (pats++(ps++lambdas)) e rhs ++                               -- remove the temp declaration...                  +                               let declsP = map declToPName2 (hsDecls t)+                                   declP = findDec newName declsP+                                        +                  +                               rmDecl declP False (hsDecls t)+                               return dec+       +       inDec (dec@(Dec (HsPatBind s p rhs ds)))+         | findPNT pnt p+            = do +                  -- let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches+                  +                  -- try and evaluate the highlighted expression+                  -- first let's transform the case so that each pattern match returns +                  -- a number, we can then use this to determine which+                  -- clause has suceeded.+                  (free,decs) <- hsFreeAndDeclaredNames dec+                  +                  let lambdas  = getFreeLambdas rhs+                      lambdas2 = getAllLambdas rhs+                  -- lift $ AbstractIO.putStrLn $ show lambdas+                  +                  let newPats   = map createCall lambdas+                      newName   = mkNewName (pNTtoName (patToPNT p)) (free++decs) 0+                  result <- ghcEvalExpr f ((newName ++ " " ++ (concatMapWithSpace (render.ppi) newPats))) modName+                  case result of+                    ("-1") -> do+                               -- remove the temp declaration...                  +                               let declsP = map declToPName2 (hsDecls t)+                                   declP = findDec newName declsP+                               rmDecl declP False (hsDecls t)+                               return dec+                    _ -> do+                            let ps = patternise (hsDecls rhs)+                            lift $ AbstractIO.putStrLn $ (result \\ result)+                                    +                            newExp <- rewriteExp result ([p]++(ps++lambdas2)) e rhs +                  +    +                            -- remove the temp declaration...                  +                            let declsP = map declToPName2 (hsDecls t)+                                declP = findDec newName declsP+                      +                            -- lift $ AbstractIO.putStrLn $ show (declP, (hsDecls t))+                  +                  +                            rmDecl declP False (hsDecls t)+                            return dec+       +       inDec x = return x+       +       patternise :: [HsDeclP] -> [HsPatP]+       patternise+        = (nub.ghead "patternise").applyTU (full_tdTU (constTU [] `adhocTU` inPat))+        +        +       inPat (Dec (HsPatBind _ (Pat (HsPId (HsVar x))) (HsBody e) ds))+         = return [Pat (HsPAsPat x (ghead "inPat" $ expToPat e))]+       +       inPat (Dec (HsPatBind _ (Pat (HsPTuple l ps)) (HsBody e) ds))+         = do+              let res = expToPat e+              return (swapPositions ps res)+       +       inPat (Dec (HsPatBind _ (Pat (HsPList l ps)) (HsBody e) ds))+         = do+              let res = expToPat e+              return (swapPositions ps res)+       +       inPat (Dec (HsPatBind _ p (HsBody e) ds))+         = return [p]+         +       swapPositions :: [HsPatP] -> [HsPatP] -> [HsPatP]+       swapPositions [] x = x+       swapPositions x [] = x+       swapPositions (x:xs) (y:ys) +         = (changeDefineLoc (defineLoc (patToPNT x)) y) : (swapPositions xs ys)++       +       changeDefineLoc::(Term t)=>SrcLoc -> t -> t+       changeDefineLoc s e = runIdentity (applyTP (full_tdTP (idTP `adhocTP` (inLoc s))) e)+         +       inLoc s (SrcLoc f c row col)+         = return s+       -- inLoc s loc = return loc++       defLocs e = ((nub.ghead "toRelativeLoc").applyTU (full_tdTU (constTU [] +                                                              `adhocTU` inPnt ))) e+         +       inPnt pnt@(PNT pn ty loc)+            |defineLoc pnt == useLoc pnt= return [(\(SrcLoc _ _ r c)->(r,c)) (srcLoc pn)]+       inPnt _ = return []+         +       +       +          +       -- inPat d = []+       +       -- traverse into the expression+       -- two cases to consider:+       -- something of the form+       -- 1:   x = (a,b)+       --       then return x@(a,b)+       -- 2:   (x,y) = (a,b)+       --        then return (a,b) (replacing a and b location with x and y).+       -- expToPatCall :: HsPatP -> HsExpP -> [HsPatP] +       -- expToPatCall (Pat (HsPId x)) e = (Pat (HsPAsPat x (expToPat e)))+       +       +       +       +       +       expToPat :: HsExpP -> [HsPatP]+       expToPat (Exp (HsId x)) = [Pat (HsPId x)]+       expToPat (Exp (HsLit s l)) = [Pat (HsPLit s l)]+       expToPat (Exp (HsInfixApp e1 (HsCon i) e2)) = [Pat (HsPInfixApp (ghead "expToPat" $ expToPat e1) +                                                             i (ghead "expToPat" $ expToPat e2))]+       expToPat (Exp (HsApp e1 e2)) = [Pat (HsPApp (expToPNT e1) +                                                   (expToPat e2))]+       -- expToPat (Exp (HsNegApp s e)) = [Pat (HsPNeg s e)]+       expToPat (Exp (HsLambda ps e)) = ps+       expToPat (Exp (HsTuple es)) = concatMap expToPat es   --[Pat (HsPTuple loc0 (concatMap expToPat es))]+       expToPat (Exp (HsList es)) = concatMap expToPat es+       expToPat (Exp (HsParen e1)) = [Pat (HsPParen (ghead "expToPat" $ expToPat e1))]+       expToPat _ = [] +       +       +       findDec :: String -> [PName] -> PName+       findDec n [] = defaultPN+       findDec n (p:ps) +        | n == (pNtoName p) = p+        | otherwise         = findDec n ps +       +       rewriteExp result pats e t+          = applyTP (stop_tdTP (failTP `adhocTP` (subExp result pats))) t+       subExp r pats exp@((Exp _)::HsExpP)+          | sameOccurrence exp e+               = do +                    newExp <- rewriteExp2 r pats exp+                    -- error $ show (exp, e, newExp)+                    update exp newExp exp+          | otherwise                     +                  = mzero+                  +       rewriteExp2 r pats n@(Exp (HsCase e alts))+         = do+             -- there are basically two cases to consider.+             -- the first is that the patterns in the case scrutiny+             -- are bound in the LHS. This is the easy case.+             -- the more difficult case is when the patterns are+             -- bound else where, or a combination of the two.+             -- It is neccessary to check if patterns are bound+             -- in lets/lambdas etc and convert to pattern if+             -- possible.+             +             -- ergo, pats is the predetermined set of pats.+             -- these are calculated at the call site for rewriteExp.+         +             -- e may be an explicit variable that is bound+             -- in the pattern bindings. If it is, then+             -- let's get the pattern and rename variables, if+             -- needed.+             +             let pat = getPatBind pats e+                 zippedPat = zipPatExp e n (alts !! (read r::Int)) pats+             -- lift $ AbstractIO.putStrLn $ show zippedPat+             return zippedPat+       +zipPatExp e (Exp (HsCase e' alts)) a@(HsAlt _ p (HsGuard e2) ds) pats = (Exp (HsCase e' [a]))    +zipPatExp e n (HsAlt _ p (HsBody e2) ds) pats+      = res +        where+         res = altToExp (flatternPat p) (zipPatExp'' (zipPatExp' e p) pats) e2+         zipPatExp' :: HsExpP -> HsPatP -> [(HsExpP, HsPatP)]+         zipPatExp' e@(Exp (HsTuple xs)) (Pat (HsPTuple _ ys))+           = zip xs ys+         zipPatExp' e@(Exp (HsList xs)) (Pat (HsPList _ ys))+           = zip xs ys+         zipPatExp' e p = [(e,p)]+        +         zipPatExp'' :: [(HsExpP, HsPatP)] -> [HsPatP] -> [(HsExpP, HsPatP)]+         zipPatExp'' [] _ = []+         zipPatExp'' ((x,y):xs) pats+          | res == [] = ( x,y) : (zipPatExp'' xs pats)+          | otherwise = (patToExp (ghead "zipPatExp''" res), y) : (zipPatExp'' xs pats)+            where +             res = getPatBind pats x+          +flatternPat :: HsPatP -> [HsPatP] +flatternPat (Pat (HsPAsPat i p)) = flatternPat p+flatternPat (Pat (HsPApp i p)) = p+flatternPat (Pat (HsPTuple _ p)) = p+flatternPat (Pat (HsPList _ p)) = p+flatternPat (Pat (HsPInfixApp p1 i p2)) = (flatternPat p1) ++ (flatternPat p2)+flatternPat (Pat (HsPParen p)) = flatternPat p+-- flatternPat pnt (Pat (HsPId i)) = 1+flatternPat p = [p]  +++expToPat :: HsExpP -> [HsPatP]+expToPat (Exp (HsId x)) = [Pat (HsPId x)]+expToPat (Exp (HsLit s l)) = [Pat (HsPLit s l)]+expToPat (Exp (HsInfixApp e1 (HsVar i) e2)) = [Pat (HsPInfixApp (ghead "expToPat" $ expToPat e1) +                                                             i (ghead "expToPat" $ expToPat e2))]+expToPat (Exp (HsInfixApp e1 (HsCon i) e2)) = [Pat (HsPInfixApp (ghead "expToPat" $ expToPat e1) +                                                             i (ghead "expToPat" $ expToPat e2))]+expToPat e@(Exp (HsApp e1 e2)) =    [Pat (HsPApp (nameToPNT " ")+                                                   (concatMap expToPat exps))]+                               where+                                 exps = flatternApp e         +-- expToPat (Exp (HsLambda ps e)) = ps+expToPat (Exp (HsTuple es)) = [Pat (HsPTuple loc0 (concatMap expToPat es))]+expToPat (Exp (HsList es)) = [Pat (HsPList loc0 (concatMap expToPat es))]+expToPat (Exp (HsParen e1)) + | expToPat e1 /= [] = [Pat (HsPParen (ghead "expToPat" $ expToPat e1))]+expToPat e = [] ++patToExp :: HsPatP -> HsExpP+patToExp (Pat (HsPId x)) = (Exp (HsId x))+patToExp (Pat (HsPLit s l)) = (Exp (HsLit s l))+patToExp (Pat (HsPInfixApp p1 i p2)) = (Exp (HsInfixApp (patToExp p1) (HsCon i) (patToExp p2)))+patToExp (Pat (HsPApp pnt p2)) = (cApp ((nameToPat (pNTtoName pnt)) : p2))+                                    where+                                      cApp :: [HsPatP] -> HsExpP+                                      cApp [p] = patToExp p+                                      cApp (p:ps) = Exp (HsApp (cApp (init (p:ps))) (patToExp (last ps)))+patToExp (Pat (HsPTuple s ps)) = (Exp (HsTuple (map patToExp ps)))+patToExp (Pat (HsPList s ps)) = (Exp (HsList (map patToExp ps)))+patToExp (Pat (HsPParen p1)) = (Exp (HsParen (patToExp p1)))+patToExp p@(Pat (HsPAsPat pnt pat)) = patToExp pat+patToExp (Pat (HsPIrrPat p)) = patToExp p+patToExp (Pat (HsPWildCard)) = nameToExp "undefined"++flatternApp :: HsExpP -> [HsExpP]+flatternApp (Exp (HsApp e1 e2)) = flatternApp e1 ++ flatternApp e2+flatternApp (Exp (HsParen e)) = flatternApp e+flatternApp x = [x]++            +altToExp :: [HsPatP] -> [(HsExpP, HsPatP)] -> HsExpP -> HsExpP+altToExp p [] e = e+altToExp p pats e+          = symbolicTrans p pats e -- (myMap fromAsPat pats) e+             where+              myMap f [] = []+              myMap f ((x,y):xs)+                = (f x, y): (myMap f xs)+              fromAsPat :: HsPatP -> HsPatP+              fromAsPat (Pat (HsPAsPat _ p)) = p+              fromAsPat p = p+      +symbolicTrans :: [HsPatP] -> [(HsExpP, HsPatP)] -> HsExpP -> HsExpP+symbolicTrans p [] e = e+symbolicTrans p pats e +          = rewritePatsInExp p pats e+        +rewriteExpPat ((p1,p2):pats) (Exp (HsId (HsVar i)))+   | findPNT i (patToPNT p2) = (Exp (HsId (HsVar (patToPNT p1))))+rewriteExpPat p q = q+       -- rewriteExpPat p q = error $ show (p,q) ++unravelAndFind :: [HsPatP] -> PNT -> HsExpP -> HsPatP -> HsExpP+unravelAndFind _ i p@(Exp (HsLit x y)) q+ = (Exp (HsLit x y))+unravelAndFind ps i p@(Exp (HsId (HsVar i2))) q@(Pat (HsPId (HsVar i3)))+  | (pNTtoName i2) `elem` (map pNTtoName (hsPNTs q))   = (Exp (HsId (HsVar i)))+  | q `elem` ps = (Exp (HsId (HsVar i2))) -- not a top level entity+  | otherwise = (Exp (HsId (HsVar i)))+unravelAndFind ps i p@(Exp (HsId (HsVar i2))) q +  | (rmAllLocs i2) `elem` (map rmAllLocs (hsPNTs q))   = (Exp (HsId (HsVar i)))+  | q `elem` ps = (Exp (HsId (HsVar i2))) -- not a top level entity+  | otherwise = (Exp (HsId (HsVar i)))+unravelAndFind _ i (Exp (HsInfixApp e1 _ e2)) (Pat (HsPInfixApp p3 _ p4))+  | defineLoc i == defineLoc (patToPNT p3) = (Exp (HsId (HsVar (expToPNT e1))))+  | defineLoc i == defineLoc (patToPNT p4) = (Exp (HsId (HsVar (expToPNT e2))))+unravelAndFind ps i e@(Exp (HsApp e1 e2)) p@(Pat (HsPApp pnt pats2)) + = unravelAndFind2 i (flatternApp e) ((nameToPat (pNTtoName pnt)) : pats2)++ -- = (Exp (HsApp (unravelAndFind ps i e1 p)+ --               (unravelAndFind ps i e2 p)))+--   = unravelAndFind2 i (flatternApp e) pats2 +unravelAndFind _ i p1@(Exp (HsTuple exps)) p2@(Pat (HsPTuple _ pats2))+        = unravelAndFind2 i exps pats2 +       -- unravelAndFind i p1@(Pat (HsPTuple _ pats)) p2+       -- = unravelAndFind2  +unravelAndFind ps x (Exp (HsParen p)) y = unravelAndFind ps x p y+unravelAndFind ps x y (Pat (HsPParen p)) = unravelAndFind ps x y p+unravelAndFind _ _ p q@(Pat (HsPId x)) = p+unravelAndFind _ i p q = (Exp (HsId (HsVar i)))+       +++unravelAndFind2 :: PNT -> [HsExpP] -> [HsPatP] -> HsExpP+unravelAndFind2 i [] _ = Exp (HsId (HsVar i))+unravelAndFind2 i _ [] = Exp (HsId (HsVar i))+unravelAndFind2 i (p:ps) (p2:ps2) +         | defineLoc (patToPNT p2) == defineLoc i = Exp (HsId (HsVar (expToPNT p)))+         | otherwise = unravelAndFind2 i ps ps2 +       +myMap _ [] _ = False+myMap f ((p,q):pats) i+         = or ((f (hsPNTs q) i) : [myMap f pats i])+        +definedInPats [] e = False+definedInPats pats i+        = myMap checkPNTInPat pats i+       +         +getPatFromPats _ [] i = Exp (HsId (HsVar i))+getPatFromPats ps ((p,q):pats) i+     | myMap checkPNTInPat ((p,q):pats) i = checkPQ ps ((p,q):pats)+     | otherwise = getPatFromPats ps pats i+            where+              checkPQ ps [] = Exp (HsId (HsVar i))+              checkPQ ps ((p,q):pats) +                | checkPNTInPat (hsPNTs q) i = unravelAndFind ps i p q+                | otherwise = checkPQ ps pats ++       +rewritePatsInExp :: [HsPatP] -> [(HsExpP, HsPatP)] -> HsExpP -> HsExpP+rewritePatsInExp _ pats e@(Exp (HsLit s i)) = e+rewritePatsInExp p pats e@(Exp (HsId (HsVar i)))+         | definedInPats pats i =  getPatFromPats p pats i+         | otherwise = e+rewritePatsInExp _ pats e@(Exp (HsId (HsCon i)))  = e+       +rewritePatsInExp p pats (Exp (HsInfixApp e1 i e2))+         = (Exp (HsInfixApp (rewritePatsInExp p pats e1) i (rewritePatsInExp p pats e2)))+         +rewritePatsInExp p pats e@(Exp (HsApp e1 e2)) +         = (Exp (HsApp (rewritePatsInExp p pats e1) (rewritePatsInExp p pats e2)))+         +rewritePatsInExp p pats (Exp (HsNegApp s e))+         = Exp (HsNegApp s (rewritePatsInExp p pats e))+         +rewritePatsInExp p pats l@(Exp (HsLambda ps e)) +         = Exp (HsLambda ps (rewritePatsInExp p pats e))+         +rewritePatsInExp p pats (Exp (HsLet ds e))+         = Exp (HsLet ds (rewritePatsInExp p pats e))+         +rewritePatsInExp p pats (Exp (HsIf e1 e2 e3))+         = Exp (HsIf e1' e2' e3')+            where+              e1' = rewritePatsInExp p pats e1+              e2' = rewritePatsInExp p pats e2+              e3' = rewritePatsInExp p pats e3+rewritePatsInExp p pats (Exp (HsCase e alts)) -- test this!!+         = Exp (HsCase (rewritePatsInExp p pats e) (rewritePatsInAlts p pats alts))+    +rewritePatsInExp p pats (Exp (HsTuple es))+         = Exp (HsTuple (map (rewritePatsInExp p pats) es))+rewritePatsInExp p pats (Exp (HsList es))+         = Exp (HsList (map (rewritePatsInExp p pats) es))+rewritePatsInExp p pats (Exp (HsParen e))+         = Exp (HsParen (rewritePatsInExp p pats e))+rewritePatsInExp p pats (Exp (HsRecConstr s i fields))+         = Exp (HsRecConstr s i (rewritePatsInFields p pats fields))+rewritePatsInExp p pats (Exp (HsRecUpdate s e1 fields))+         = Exp (HsRecUpdate s (rewritePatsInExp p pats e1) (rewritePatsInFields p pats fields))+rewritePatsInExp _ pats e = e+       -- check whether any of the PNTs are defined in the Pat or not...+ +rewritePatsInFields p pats [HsField i e] = [HsField i (rewritePatsInExp p pats e)]+rewritePatsInFields p pats ((HsField i e):fs)+  = (HsField i (rewritePatsInExp p pats e)) : (rewritePatsInFields p pats fs)     ++rewritePatsInAlts p pats [HsAlt s p2 (HsBody e) ds] = [HsAlt s p2 (HsBody (rewritePatsInExp p pats e)) ds]+rewritePatsInAlts p pats ((HsAlt s p2 (HsBody e) ds):fs)+  = (HsAlt s p2 (HsBody (rewritePatsInExp p pats e)) ds) : (rewritePatsInAlts p pats fs)++       +checkPNTInPat :: [PNT] -> PNT -> Bool+checkPNTInPat [] _ = False+checkPNTInPat (p:ps) i +        | defineLoc i == (SrcLoc "__unknown__" 0 0 0) = False+        | defineLoc i == defineLoc p = True+        | otherwise = checkPNTInPat ps i+       +       +getPatBind :: [HsPatP] -> HsExpP -> [HsPatP]+getPatBind pats (Exp (HsParen e)) = getPatBind pats e+getPatBind [] e = []+getPatBind (p:ps) e@(Exp (HsLit x y)) +           = [Pat (HsPLit x y)]+getPatBind (p:ps) e@(Exp (HsId (HsVar i)))+         | definesPNT i (patToPNT p) = [p]+        -- | checkPNTInPat (hsPNTs p) i = [p]+         | otherwise = getPatBind ps e +getPatBind pats e@(Exp (HsTuple es)) +         = concatMap (getPatBind pats) es+getPatBind pats e@(Exp (HsList es))+         = concatMap (getPatBind pats) es   +getPatBind pats (Exp (HsApp e1 e2)) = [] +getPatBind pats (Exp (HsInfixApp e1 o1 e2)) = []+-- getPatBind x y = error $ show (x,y)+getPatBind x y = [] -- error $ show (x,y)+  +getAllLambdas :: Term t => t -> [HsPatP]+getAllLambdas +  = (nub.concat).applyTU (full_tdTU (constTU [] `adhocTU` inExp3))+      where     +       inExp3 (Exp (HsLambda ps e)) = return ps+       inExp3 e1 = return []             +getFreeLambdas :: Term t => t -> [HsPatP]+getFreeLambdas +  = (fromMaybe []).applyTU (once_tdTU (failTU `adhocTU` inExp))+      where  +       inExp (Exp (HsApp (Exp (HsParen (Exp (HsLambda _ _)))) _)) = Just []+       inExp (Exp (HsLambda ps e)) +            = do let res = getFreeLambdas e+                 Just (ps++res)+       inExp _ = Nothing  +  +       +createCall (Pat (HsPList  s pats)) = (Pat (HsPList s (map createCall pats)))+createCall p@(Pat (HsPLit _ _)) = p+createCall (Pat (HsPAsPat _ p))+  = createCall p+createCall (Pat (HsPInfixApp p1 i p2)) = (Pat (HsPInfixApp (createCall p1) i (createCall p2)))+createCall (Pat (HsPParen p)) = (Pat (HsPParen (createCall p)))+createCall (Pat (HsPId (HsVar i))) = (Pat (HsPId (HsVar (nameToPNT "undefined"))))+createCall p@(Pat (HsPId (HsCon i))) = p+createCall (Pat (HsPApp i pats)) = (Pat (HsPApp i (map createCall pats)))+createCall (Pat (HsPTuple s ps)) = (Pat (HsPTuple s (map createCall ps)))+createCall p = error ("createCall: " ++ (show p))+       +createFun name names pats newExp ds+  = (Dec (HsFunBind loc0 [HsMatch loc0 (nameToPNT newName) pats (HsBody newExp) ds]), newName)+     where+       newName = mkNewName (pNTtoName name) names 0+       +       rewriteCase (Exp (HsCase e alts))+        = (Exp (HsCase e (rewriteAlts 0 alts)))+       rewriteCase e = e+       +       rewriteAlts i [] = []+       rewriteAlts i ((HsAlt s p (HsBody e) ds):as)+        -- = (HsAlt s p (HsBody (Exp (HsApp (nameToExp "return") (nameToExp (show i))))) ds) : (rewriteAlts (i+1) as)+           = (HsAlt s p (HsBody (nameToExp (show i))) ds) : (rewriteAlts (i+1) as)+       rewriteAlts i ((HsAlt s p (HsGuard (e:es)) ds):as)+        --  = (HsAlt s p (HsBody (Exp (HsApp (nameToExp "return") (nameToExp (show i))))) ds) : (rewriteAlts (i+1) as)+           = (HsAlt s p (HsBody  (nameToExp (show i))) ds) : (rewriteAlts (i+1) as)+       -- rewriteAlts i ((HsAlt s p (HsGuard ( + +  +addExpression pnt e (_,_,t)+ = do+      mod <- addExpression' pnt e t+      return mod  +     +addExpression' pnt e t+  = applyTP (full_tdTP (idTP `adhocTP` inDec)) t+     where+       inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)+         | findPNT pnt matches+             = do +                  let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches+                  +                  -- try and evaluate the highlighted expression+                  -- first let's transform the case so that each pattern match returns +                  -- a number, we can then use this to determine which+                  -- clause has suceeded.+                  (free,decs) <- hsFreeAndDeclaredNames match+                  +                  newExp       <- rewriteCase e (rmGuard rhs)+                  let (newFun, newName) = createFun name (free++decs) pats (HsBody newExp) ds+                      newPats   = map createCall pats+                                    +                  addDecl t (Just (pNTtoPN name)) ([newFun], Nothing) True+                  return dec+       inDec (dec@(Dec (HsPatBind s p rhs ds)))+        | findPNT pnt p+            = do+                  -- let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches+                  +                  -- try and evaluate the highlighted expression+                  -- first let's transform the case so that each pattern match returns +                  -- a number, we can then use this to determine which+                  -- clause has suceeded.+                  (free,decs) <- hsFreeAndDeclaredNames dec+                  +                  newExp       <- rewriteCase e rhs+                  let (newFun, newName) = createFun (patToPNT p) (free++decs) [] newExp ds+                      newPats   = map createCall []+                                    +                  addDecl t (Just (patToPN p)) ([newFun], Nothing) True+                  return dec+ +                                    +       inDec x = return x+       +       createCall (Pat (HsPList  s pats)) = (Pat (HsPList s (map createCall pats)))+       createCall p@(Pat (HsPLit _ _)) = p+       createCall (Pat (HsPAsPat _ p))+        = createCall p+       createCall p = error $ show p+       +       createFun name names pats newExp ds+        = (Dec (HsFunBind loc0 [HsMatch loc0 (nameToPNT newName) pats newExp ds]), newName)+         where+           newName = mkNewName (pNTtoName name) names 0       +       +       rewriteCase :: (Term t, MonadPlus m) => HsExpP -> t -> m t+       rewriteCase e+         = applyTP (once_tdTP (failTP `adhocTP` (inExp e)))+       +       inGen e (HsLetStmt ds more) = do +                                      rest <- inGen e more+                                      return (HsLetStmt ds rest)+       inGen e x@(HsLast e1) = do+                                  e1' <- inExp e e1+                                  return (HsLast e1')+       inGen e (HsQualifier e1 more) = do+                                      rest <- inGen e more+                                      e1' <- inExp e e1+                                      return (HsQualifier e1' rest)+       inGen e (HsGenerator s p e1 more)+                                  = do+                                       rest <- inGen e more+                                       e1' <- inExp e e1+                                       return (HsGenerator s p e1' rest)+       inExp e x@(Exp (HsDo stmts)) = do+                                         stmts' <- inGen e stmts+                                         return (Exp (HsDo stmts'))+       +       inExp e x@(Exp (HsApp (Exp (HsParen e1)) e2))+         = do -- rewrite the case in x  +             newX <- rewriteCase2 e x+             return newX+              where+                rewriteCase2 :: (Term t, MonadPlus m) => HsExpP -> t -> m t+                rewriteCase2 e+                  = applyTP (once_tdTP (failTP `adhocTP` (inExp2 e)))+                +                inExp2 x@(Exp (HsCase e alts)) y      +                 | sameOccurrence x y = return (Exp (HsCase e (rewriteAlts 0 alts)))+                inExp2 e1 _ = mzero +                 +       inExp e (Exp (HsLambda ps e2)) = do+                                           res <- inExp e e2+                                           return (Exp (HsLambda ps res))+       inExp e (Exp (HsLet ds e2)) = do+                                        res <- inExp e e2+                                        return (Exp (HsLet ds res))+       inExp e (Exp (HsParen e2)) = do+                                        res <- inExp e e2+                                        return (Exp (HsParen res))+       inExp (Exp (HsCase e alts)) e2 = do+                                          +                                          return (Exp (HsCase e (rewriteAlts 0 alts)))+       +       inExp e1 e2 = return e1+       +       rewriteAlts i [] = []+       rewriteAlts i ((HsAlt s p (HsBody e) ds):as)+        -- = (HsAlt s p (HsBody (Exp (HsApp (nameToExp "return") (nameToExp (show i))))) ds) : (rewriteAlts (i+1) as)+         = (HsAlt s p (HsBody  (nameToExp (show i))) ds) : (rewriteAlts (i+1) as)+       rewriteAlts i ((HsAlt s p (HsGuard (e:es)) ds):as)+        --  = (HsAlt s p (HsBody (Exp (HsApp (nameToExp "return") (nameToExp (show i))))) ds) : (rewriteAlts (i+1) as)+         = (HsAlt s p (HsBody (nameToExp (show i))) ds) : (rewriteAlts (i+1) as)++       -- rewriteAlts i ((HsAlt s p (HsGuard (+ +-- utility functions +getMatch :: PNT -> [HsMatchP] -> HsMatchP   +getMatch _ [] = error "Please select a case in top-level expression scope!"+getMatch pnt (match@(HsMatch loc name pats rhs ds):ms)+  | useLoc pnt == useLoc name      = match+  | otherwise        = getMatch pnt ms+++ghcEvalExpr x y z = do+                       let res = unsafePerformIO $ rawSystem evaluate [x,y,z] --   :: String -> [String] -> IO ExitCode+                       lift $ AbstractIO.putStrLn $ show res+                       res2 <- lift $ AbstractIO.readFile evaluate_result+                       case res of+                         (ExitFailure _) -> do+                                               error "The simplification could not be performed, some of the formals to the highlighted expression may not be well-defined."+                                               return "-1"+                         _  -> do --lift $ AbstractIO.putStrLn $ show res2+                                  return res2++{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (PatFun, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+                     +findDefNameAndExp toks beginPos endPos t+  = fromMaybe (Er, defaultPNT, [], defaultExp, [])+              (applyTU (once_buTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t)++    where+      --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats rhs@(HsBody e) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (Mat, pnt, pats, locToExp beginPos endPos toks rhs, ds)+      inMatch (match@(HsMatch loc1  pnt pats rhs@(HsGuard e) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just (Mat, pnt, pats, rmGuard rhs, ds)          +      inMatch _ = Nothing+++      --The selected sub-expression is in the rhs of a pattern-binding+      inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+        | locToExp beginPos endPos toks rhs /= defaultExp+             = if isSimplePatBind pat+                then Just (Patt, patToPNT ps, [], locToExp beginPos endPos toks rhs, ds)    +                else error "A complex pattern binding can not be simplified!"+      inPat _ = Nothing+    +    +-- concatMapWithSpace :: (String -> String) -> [String] -> String+concatMapWithSpace f [] = " "+concatMapWithSpace f (x:xs) = ((f x) ++ " ") ++ concatMapWithSpace f xs    +                    +rmGuard ((HsGuard gs)::RhsP)+  = let (_,e1,e2)=glast "guardToIfThenElse" gs+               in  if ((pNtoName.expToPN) e1)=="otherwise" +                   then (foldl mkIfThenElse e2 (tail(reverse gs)))+                   else (foldl mkIfThenElse defaultElse (reverse gs)) +                   +    where+      mkIfThenElse e (_,e1, e2)=(Exp (HsIf e1 e2 e)) ++      defaultElse=(Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "error") (G (PlainModule "Prelude") "error" +                    (N (Just loc0)))) Value (N (Just loc0)))))) (Exp (HsLit loc0 (HsString "UnMatched Pattern")))))+rmGuard (HsBody e) = e+
+ refactorer/RefacSlicTuple.hs view
@@ -0,0 +1,1558 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacSlicTuple+-- Copyright   :  (c) Christopher Brown 2006+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Symoblic Evaluation on tuples.+-- creates functions which evaluate the expressions+-- within the return value of a function.+--  e.g.+--+-- @ f x y = (x, y) @+--+-- @ f1 x = x @+--+-- @ f2 y = y @+--+-----------------------------------------------------------------------------++module RefacSlicTuple where+++import System.IO.Unsafe++import RefacTypeSyn+import RefacLocUtils+import Data.Char+import GHC.Unicode+import AbstractIO+import Maybe+import List+import RefacUtils+import RefacRedunDec+import SlicingUtils++data Patt = Match HsMatchP | MyPat HsDeclP | Def [Char] deriving Show++refacSlicTuple args+  = do let +           fileName    = args!!0+           row         = read (args!!1)::Int+           col         = read (args!!2)::Int+           answer      = args!!3++       AbstractIO.putStrLn "refacTuple"++       -- Parse the input file.+       modName1 <- fileNameToModName fileName ++       let modName = modNameToStr modName1+       modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName++       -- Find the function that's been highlighted as the refactree+       case checkCursor fileName row col mod of+         Left errMsg -> do error errMsg+         Right decl ->+           do+              -- get the RHS+              let (x@(listExp, rhs, wh, wh2, localDefs, p):xs) = getRHS fileName answer decl  (locToPNT fileName (row, col) mod) False []  modName  +                                                  +              let name = (locToPN fileName (row, col) mod)                      +              -- let newDecl2 = getNamesFromDecl decl   +                            +              let newDecl = map (getDeclInWhere decl) (map (\(a,b,c,d,e,f) -> (b)) (x:xs))+         +                                          +              let newAnswer = convertAnswer answer listExp+                                          +              -- error $ show (x:xs)               +              res <- myMapM f (newAnswer, (x:xs))+              let res2 = map (\(a,b,c) -> a) res+                            +              let local2 = makeBools res+              let names = makeNames res+              let sortedDecls0 = sortDecls ((concat res2), local2, names)+              let sortedDecls = map (\(a,b, c) -> a) sortedDecls0+              let local3 = map (\(a,b, c) -> b) sortedDecls0+              let names2 = map (\(a,b,c) -> c) sortedDecls0+              -- newSortedDecls <- matchPatterns sortedDecls newDecl+                                          +              replacedDecls <- replaceWithNew answer (locToPN fileName (row, col) mod) sortedDecls (length listExp)+              +              newReplacedDecls <- removeDeadPatterns answer replacedDecls names2 -- (getNameOfDec (head newDecl))+                            +              newReplacedDecls2 <- removeDeadTupleCase newReplacedDecls newReplacedDecls +              +              newReplacedDecls3 <- dependencyAnalysis newReplacedDecls2 (head newDecl) newReplacedDecls2 names2+                                                                                                                +              newSortedDecls2 <- createDecl newReplacedDecls3 decl local3 0 newAnswer              +              let newSortedDecls3 = sortDecls (newSortedDecls2, local3, names2)+              +              let refactoredDecls = map (\(a,b, c) -> a) newSortedDecls3+                                          +              res2 <- applyRefac (addDecls refactoredDecls name) (Just (inscps, exps, mod, tokList)) fileName    +              +              +                            +              writeRefactoredFiles True [res2]+              (inscps2, exps2, mod2, tokList2) <- parseSourceFile fileName+              +              let newRefactoredDecls1 = hsDecls mod2+              +              -- AbstractIO.putStrLn $ show (map declToName refactoredDecls)+              +              let newRefactoredDecls2 = definingDecls (map (declToPName (map declToName refactoredDecls)) newRefactoredDecls1) newRefactoredDecls1 False False+              +              +              -- AbstractIO.putStrLn $ show newRefactoredDecls2+              ++              +              sigs <- mapM (getSigAsString fileName modName) (map declToName newRefactoredDecls2)+              +              -- AbstractIO.putStrLn $ show sigs+              +              -- AbstractIO.putStrLn $ show (map declToName newRefactoredDecls2)+               +              -- AbstractIO.putStrLn $ show (map (declToPName (map declToName refactoredDecls)) newRefactoredDecls1) +               +               +              res3 <- applyRefac (addTypes (dropWhile (\x -> x == defaultPN) (map (declToPName (map declToName refactoredDecls)) newRefactoredDecls1)) sigs) (Just (inscps2, exps2, mod2, tokList2)) fileName+              +              +              -- error $ show res3+              +              writeRefactoredFiles True [res3]+              +          {-    (inscps5, exps5, mod5, tokList5, ses5) <- parseSourceFile2 fileName modName++              +              (mod',((tokList'',modified),_))<-(doCommenting (dropWhile (\x -> x == defaultPN) (map (declToPName (map declToName refactoredDecls)) newRefactoredDecls1))) fileName mod5 tokList5+              +              +              writeRefactoredFiles True [((fileName, True), (tokList'', mod'))] -}+               +              where +                f a l@((listExp:es), rhs, wh, wh2, localDefs, p1) -- (tok, m)+                     = do      +                         if (listExp:es) == []+                          then error "Please select a definition that returns a tuple!"+                          else +                           if localDefs == False +                            then do     +                              let (funRHS, funName, wher, pats) = simpleGetRHS decl (locToPNT fileName (row, col) mod)+                              decl <- forEach (listExp:es) rhs wh wh2 fileName 0 a (funName, p1) (inscps, exps, mod, tokList)+                              +                              return (decl, False, funName)+                            else do+                              let (begin, end) = getStartEndLoc tokList (get1Element listExp)+                              let blah@(loc, pnt, pats, exp, wh2, p)+                                    = findDefNameAndExp tokList+                                      begin+                                      end+                                      mod +                              let (funRHS, funName, wher, pats) = simpleGetRHS decl (locToPNT fileName (row, col) mod)+                              decl <- forEach2 wher (listExp:es) rhs wh wh2 fileName 0 a (funName, p1) (inscps, exps, mod, tokList)+                              return (decl, True, pnt) +                writeRefactored2 x = writeRefactoredFiles False [x]     +            +                myMapM f (a, [l])  +                  = do  +                        res <- f a l -- (tokList, mod)+                        return [res]+                        +                myMapM f (a , (l:list)) +                  = do +                       res <- f a l -- (tokList, mod)+                       x <- myMapM f (a ,list) -- (tokList, mod)   +                       return (res : x)  ++convertModName (PlainModule s) = s+convertModName m@(MainModule f) = modNameToStr m+++--createTypeSig :: String -> [String] -> [String] -> HsDeclP+createTypeSig name [] types + = Dec (HsTypeSig loc0 [nameToPNT name] [] (createApplication types)) +createTypeSig name context types  + = Dec (HsTypeSig loc0 [nameToPNT name] [(Typ (HsTyVar (nameToPNT context)))] (createApplication types)) + + -- (Typ (HsTyVar (nameToTypePNT (head types))) ) )+ ++nameToTypePNT :: String -> PNT +nameToTypePNT id = (PNT (PN (UnQual id) (S loc0)) (Type (TypeInfo {defType = Nothing, constructors = [], fields = []})) (N (Just loc0)))+++createApplication [var]+ = (Typ (HsTyVar (nameToTypePNT var)))+createApplication (var:vars)+ = createApplication' (Typ (HsTyVar (nameToTypePNT var))) vars+ +createApplication' x [y]+  = (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y)))))+createApplication' x (y:ys)+  = (createApplication' (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y))))) ys)+       +findType pnt t+  = applyTU (stop_tdTU (failTU `adhocTU` inSig)) t+      where+        inSig (dec@(Dec (HsTypeSig _ _ _ _))::HsDeclP)+          = do+               let res = definesTypeSig (pNTtoPN pnt) dec+               if res == True+                  then return [True]+                  else fail ""+          +        inSig _ = fail "" + + + +{- declToName :: HsDeclP -> String+declToName (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))  + = pNTtoName pnt+declToName (Dec (HsPatBind _ pnt _ _)) = pNTtoName (patToPNT pnt) -}++{- declToPName ::  [ String  ] -> HsDeclP -> PName+declToPName [] _ = defaultPN+declToPName (name: names) d@(Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs))) + | name == pNTtoName pnt = pNTtoPN pnt+ | otherwise = declToPName  names d+declToPName (name:names) d@(Dec (HsPatBind _ pnt _ _))  -- = pNTtoPN (patToPNT pnt)+ | name == pNTtoName (patToPNT pnt) = pNTtoPN (patToPNT pnt)+ | otherwise = declToPName  names d+declToPName _ _ = defaultPN+-}+{- getSig ses modName name + = do+      let types = getTypes name ses modName+      -- error $ show types+      let types1 = cleanTypes (tail types)++      let (context, l) = getContext (head types)+      let types2 = l : types1+   --   let context2 = init context+      let types3 = map (filter (/= '\n')) types2+      let newSig = createTypeSig name context types3+     -- error $ show newSig+      +      return newSig -}+++makeBools :: [ ([HsDeclP], Bool, PNT) ] -> [Bool]+makeBools [] = []+makeBools (( x, False, _) : xs)+ = (replicate (length x) False) ++ (makeBools xs)+makeBools (( x, True, _) : xs)+ = (replicate  (length x) True) ++ ( makeBools xs )++makeNames :: [ ([HsDeclP], Bool, PNT) ] -> [PNT]+makeNames [] = []+makeNames (( x, _, y) : xs)+ = (replicate (length x) y) ++ (makeNames xs)++++createDecl [] _ _ _ _ = return []+createDecl (d3@(Dec (HsFunBind _ (m@(HsMatch l i1 ps (HsBody e) ds):ms) )):ds3) t@(Dec (HsPatBind loc2 p2 (HsBody e2) ds2)) (True:xs) count a+ = do+      let (newCount, newAnswer) = countAnswer count a   +      result2 <- renamePN2 (getNameFromExp e2)  i1  e2+      let (jj,ii) = span (defines' (pNTtoPN i1)) (d3:ds3)+      newSortedDecls3 <- removeRedunWhere2 ((d3:ds3) ++ ds2) result2   +      rest <- createDecl (ii) t (drop (length jj) (True:xs)) newCount newAnswer+      return ((Dec (HsPatBind loc2 (nameToPat ((pNTtoName (patToPNT p2)) ++ (show newCount))) (HsBody result2) newSortedDecls3)) : rest)+createDecl (d3@(Dec (HsFunBind _ (m@(HsMatch l i1 ps (HsBody e) ds):ms) )):ds3) t@(Dec (HsFunBind loc (m2@(HsMatch l2 i2 ps2 (HsBody e2) ds2):ms2))) (True:xs) count a+ = do+      let (newCount, newAnswer) = countAnswer count a   +      result <- checkMatch (m2:ms2) i1 newCount+      let (jj,ii) = span (defines' (pNTtoPN i1)) (d3:ds3)+      rest <- createDecl (ii) t (drop (length jj) (True:xs)) newCount newAnswer+      return ( (Dec (HsFunBind loc result)) : rest )++       where+        checkMatch [] _ _ = return []+        checkMatch (m2@(HsMatch l2 i2 ps2 (HsBody e2) ds2):ms2) i1 newCount+         = do +              if isPrefixOf (pNtoName (getNameFromExp e2)) (pNTtoName i1)+               then do+                result2 <- renamePN2 (getNameFromExp e2)  i1  e2+                newSortedDecls3 <- removeRedunWhere2 ((d3:ds3) ++ ds2) result2 +                rest2 <- checkMatch ms2 i1 newCount  +                return ((HsMatch l2 (nameToPNT ((pNTtoName i2) ++ (show newCount))) ps2 (HsBody result2) newSortedDecls3):rest2)+               else do+                result <- checkMatch ms2 i1 newCount+                return result+                +createDecl (d:ds) t (False:xs) c a = do+                                      rest <- createDecl ds t xs c a+                                      return (d : rest)+  +-- xcreateDecl _ _ [] _ = return []                                   +-- createDecl a x y z  = error $ show (a, x,y,z)                                     +                                     +renamePN2::  (Monad m, Term t) =>+               PName               -- ^ The identifier to be renamed.+             ->PNT                 -- ^ The new name +             ->t                   -- ^ The syntax phrase+             ->m t  ++renamePN2 oldPN  newName  t+  = applyTP (full_tdTP (adhocTP idTP rename)) t+  where+    rename  pnt@(PNT pn y z )+     | (pn ==oldPN) && (srcLoc oldPN == srcLoc pn)+     = return newName +    --  where +    --    replaceName = replaceNameInPN Nothing       +    rename x = return x +++getNameFromExp (Exp (HsApp e1 e2))+ = getNameFromExp e1+getNameFromExp e1+ = expToPN e1++                        +getNameOfDec :: HsDeclP -> PNT+getNameOfDec (Dec (HsFunBind loc ms))+ = getNameOfDecMatch ms+      where+        getNameOfDecMatch (m@(HsMatch l i1 ps (HsBody e) ds):ms)+          = i1++getNameOfDec (Dec (HsPatBind loc p (HsBody e) ds))+ = patToPNT p++getDeclInWhere :: HsDeclP -> HsExpP -> HsDeclP +getDeclInWhere decl (Exp (HsApp e1 e2))+ = head ( findDef (expToPNT (e1)) decl )+getDeclInWhere decl _  = decl++++mapNew (x@(listExp, rhs, wh, wh2, localDefs):xs)+ | localDefs == True = map (\(a,b,c,d,e) -> (a,b,c,d,True)) (x:xs)+ | otherwise = (x:xs)++convertAnswer [] ys = []+convertAnswer (x:xs) ys+ | x == 'a' || x == 'A' = replicate (length ys) 'x'+ | isDigit x = 'x' : (convertAnswer (nextXS xs) ys)+ | x == 'x' || x == 'X' = 'x' : (convertAnswer (nextXS xs) ys)+ | x == '_' = '_' : (convertAnswer (nextXS xs) ys)+ | otherwise = convertAnswer xs ys+++matchPatterns [] _ = return []+matchPatterns (x:xs) (Dec (HsFunBind loc ms)) +  =  do+        let len = length ms+        let ft = take len (x:xs)+        let result = correctPatterns ft ms+        result2 <- matchPatterns (drop len (x:xs)) (Dec (HsFunBind loc ms))+        return (result ++ result2)+matchPatterns (x:xs) (Dec (HsPatBind loc p (HsBody e) ds))+ = do+        return (x:xs)+ +correctPatterns [] _ = []+correctPatterns _ [] = []+correctPatterns ((Dec (HsFunBind loc0 ((HsMatch loc  pnt pats rhs ds):ms))):ds2) (m@(HsMatch _ _ pats2 _ _):ms2) + = ((Dec (HsFunBind loc0 ((HsMatch loc pnt pats2 rhs ds):ms))) : (correctPatterns ds2 ms2))+ ++getLengthAnswer [] count = count+getLengthAnswer (x:xs) count+ = case x of+    '(' -> if (or (map isDigit xs)) then getLengthAnswer xs count+                                    else getLengthAnswer (tail (dropWhile (\x -> x /= ')') xs)) (count+1)+    ',' -> getLengthAnswer xs count+    '/' -> getLengthAnswer xs count+    'X' -> getLengthAnswer xs (count+1)+    'x' -> getLengthAnswer xs (count+1)   +    '_' -> getLengthAnswer xs (count+1)+    ')' -> count +    _   -> if not (isDigit x) then error "Incorrect usage syntax" +                              else maximum (map digitToInt (filter (isDigit) (x:xs)))                         ++getLength1 "A" rhs = getLength2 rhs+getLength1 "a" rhs = getLength2 rhs+getLength1 _ _ = 0+              +getLength2 (rhs@(Exp (HsTuple x))) = length x+getLength2 _ = 0+++shuffleRHS :: String -> [HsExpP] -> [HsExpP]+shuffleRHS _ [] = []+shuffleRHS [] _ = []+shuffleRHS ('x':xs) (y:ys) = y : (shuffleRHS xs ys)+shuffleRHS ('X':xs) (y:ys) = y : (shuffleRHS xs ys)+shuffleRHS ('_':xs) (y:ys) = shuffleRHS xs ys+shuffleRHS ('(':xs) (y:ys) +  | or (map isDigit xs) = (Exp (HsTuple (shuffleRHS2 xs (y:ys)))) : (shuffleRHS (nextXS xs) (y:ys))+  | otherwise = (shuffleRHS xs (nestedTuples y)) ++ (shuffleRHS (nextXS xs) ys)+                  where+                   nestedTuples :: HsExpP -> [HsExpP]+                   nestedTuples (Exp (HsTuple ts)) = ts+                   nestedTuples e = error "The input string does not match the pattern of the RHS."+shuffleRHS (x:xs) (y:ys)+ | isDigit x = ((y:ys) !! ((digitToInt x)-1)) : ( shuffleRHS xs (y:ys))+ | otherwise = shuffleRHS xs (y:ys)++shuffleRHS2 (')':xs) (y:ys) = []+shuffleRHS2 (x:xs) (y:ys) + | isDigit x = ( (y:ys) !! ((digitToInt x)-1) ) : shuffleRHS2 xs (y:ys)+ | otherwise = shuffleRHS2 xs (y:ys)++nextXS [] = []+-- nextXS (')':xs) = [] +nextXS ('/':xs) = xs  +nextXS (x:xs) = nextXS xs++addDecls (x:xs) id (_,_,mod) = do+                                mod' <- addDecl mod (Just id) ((x:xs),Nothing) True+                                return mod'+++addTypes _ [] (_,_,mod) = return mod+addTypes (x:xs) (y:ys) (a,b,mod) = do++                                      -- mod' <- addTypeSigDecl mod (Just x) ([y], Nothing) True +                                      +                                      let name = pNtoName x+                                      +                                      mod' <- insertComment (name ++ " :: " ++ y) x mod+                                      +                                      -- commentOutTypeSig x (y:ys)                                   +                                      res <- addTypes xs ys (a,b,mod')+                                      return mod'+                                      +commentThemOut (x:xs) (y:ys) = do+  commentOutTypeSig x (y:ys)+  +  +doCommenting (x:xs) fileName mod tokList +    =  runStateT (applyTP ((once_tdTP (failTP `adhocTP` (rmInMod (x:xs) )+                                              ))) mod)+                                                         ((tokList,unmodified),fileName)+                       +           where          +             --1. The definition to be removed is one of the module's top level declarations.+             rmInMod [] mod = return mod+             rmInMod (p:ps) (mod@(HsModule loc name exps imps ds):: HsModuleP)  +                = do ds'<-commentOutTypeSig p ds+                     -- ds' <- +                     res2 <- rmInMod ps (HsModule loc name exps imps ds')+                     return res2+             -- rmInMod _ _ =mzero  +  +{- removeDeadPatternsCase [] _ = return []+removeDeadPatternsCase (d@(Dec (HsFunBind loc ms)):ds) decs+ = do+      res <- removeDeadCaseArgs ms decs+      rest <- removeDeadPatternsCase ds decs+      return ((Dec (HsFunBind loc )):rest)+       where+        removeDeadCaseArgs [] _ = return []+        removeDeadCaseArgs _ [] = return []+        removeDeadCaseArgs (m@(HsMatch l i1 ps (HsBody e) ds):ms) d+         = do+              res <- removeDeadCaseArgs2 i1 ds d+              rest <- removeDeadCaseArgs ms d+              return ((HsMatch l i1 ps (HsBody e) res):rest)+              +        removeDeadCaseArgs2 _ [] _ = return []+        removeDeadCaseArgs2 pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss) decs+         = case p of+            (Pat (HsPTuple s (l:ls))) -> if returnRHS pnt e+                                           then do+                                             newRHS <- removeDeadTupleCase ds decs    +                                             return newRHS+                                           else do+                                            return (d:dss)+            p                         ->  -}+++createNewRHS count (d:ds) pnt var params+     = do+         let result = res (findDec (d:ds) ((pNTtoName pnt) ++ (show count)) (pNTtoName pnt) (show count) var (d:ds) )+         return result+           where+                res (Dec (HsFunBind _ (m@(HsMatch l i1 ps (HsBody e) ds):ms))) = createFunc i1 params+                res (Dec (HsPatBind loc p _ _)) = pNtoExp (patToPN p)+                convertPNTs [] = []+                convertPNTs (pnt:pnts) = ((pNTtoName pnt) ++ (show count)) : (convertPNTs pnts)+++findDec [] x fun var name list = error ( "The variable: " ++ name ++ " requires element " ++ +                                 var ++ " from " ++ fun ++ ". Please retry slicing element " ++ var ++ " as well.")+findDec (d@(Dec (HsFunBind _ (m@(HsMatch l i1 ps (HsBody e) ds1):ms))):ds) name a b c list+   | (pNTtoName i1) == name = d+   | otherwise = findDec ds name a b c list+findDec (d@(Dec (HsPatBind loc p _ _)):ds) name a b c list+   | pNTtoName (patToPNT p) == name = d+   | otherwise = findDec ds name a b c list++{-|+	createFunc takes the function name and a list of expressions to be+	used in the call. createFunc then creates a function application+	based on the expressions in the second argument.++createFunc :: PNT -> [HsExpP] -> HsExpP+createFunc _ [] = defaultExp+createFunc pat [exp]+  = (Exp (HsApp (Exp (HsId (HsVar pat))) exp))+createFunc pat (exp:exps)+  = createFunc' (Exp (HsId (HsVar (pat)))) (exp:exps)++-- | createFunc' is used by createFunc to build up a function application+createFunc' :: HsExpP -> [HsExpP] -> HsExpP+createFunc' exp [x]+  = (Exp (HsApp exp x))+createFunc' exp (x:xs)+  = (createFunc' (Exp (HsApp (exp) x)) xs)++-}++ +dependencyAnalysis [] _ _ _ = return []+dependencyAnalysis (d@(Dec (HsFunBind loc ms)):ds) origDec decs (pnt:pnts)+	= do+		res <- fixDependency ms origDec decs (pnt:pnts)+		rest <- dependencyAnalysis ds origDec decs pnts+		return ((Dec (HsFunBind loc res)):rest)+			where+                fixDependency [] _ _ _ = return []+                fixDependency (m@(HsMatch l i1 ps (HsBody e) ds):ms) d decs (p:pns)+                  = do+                     res <- fixDependency2 p ds d decs+                     rest <- fixDependency ms d decs pns+                     return ((HsMatch l i1 ps (HsBody e) res):rest)++                +                fixDependency2 _ [] _ _ = return []+                fixDependency2 pnt d@((Dec (HsFunBind loc ms)):dss) decs allDecs+                 = do+                      rest <- fixDependency2 pnt dss decs allDecs+                      return ((Dec (HsFunBind loc ms)): rest)+                fixDependency2 pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss) decs allDecs+				 = case p of+				    (Pat (HsPTuple s (p1:ps1))) +				       ->  if returnRHS pnt e+ 				           then do+  				            rhs <- correctTupleRHS pnt (p1:ps1) dss decs allDecs e+ 				            {- count <- correctRHS p1 decs   -}+ 				            rest <- fixDependency2 pnt dss decs allDecs+ 				            let rhs2 = case e of+ 				                        (Exp (HsCase _ alts)) -> (Exp (HsCase (Exp (HsTuple rhs)) alts))+ 				                        _                     -> (Exp (HsTuple rhs))+ 				               + 				            return ((Dec (HsPatBind loc p (HsBody rhs2) ds)):rest)+ 				           else do+ 					         rest <- fixDependency2 pnt dss decs allDecs+ 					         return ((Dec (HsPatBind loc p (HsBody e) ds)):rest)+				    _ ->  if returnRHS pnt e+				           then do+				            count <- correctRHS p decs +				            if count /= 0+				              then do  +				                rest <- fixDependency2 pnt dss decs allDecs+				                let params = getParams pnt e +				                newRHS <- createNewRHS count allDecs pnt (pNTtoName (patToPNT p)) params+				                return ((Dec (HsPatBind loc p (HsBody newRHS) ds)):rest)+				              else do+				                rest <- fixDependency2 pnt dss decs allDecs+				                return rest+				           else do+					         rest <- fixDependency2 pnt dss decs allDecs+					         return ((Dec (HsPatBind loc p (HsBody e) ds)):rest)+					         +					         +               	correctTupleRHS :: Monad m => PNT -> [HsPatP] -> [HsDeclP] -> HsDeclP -> [HsDeclP] -> HsExpP -> m [HsExpP]+                correctTupleRHS _ [] _ _ _ _ = return []	+                correctTupleRHS pnt (p:ps) dss decs allDecs e+                 = do+                     count <- correctRHS p decs+                     if count /=0 +                       then do+                         -- rest <- fixDependency2 pnt dss decs allDecs+                         let params = getParams pnt e +                       --  error $ show (count, pnt, (pNTtoName (patToPNT p)))+                         newRHS <- createNewRHS count allDecs pnt (pNTtoName (patToPNT p)) params+                         rest <- correctTupleRHS pnt ps dss decs allDecs e+                         return ( newRHS : rest)		+				       else do+				         rest <- correctTupleRHS pnt ps dss decs allDecs e+				         return rest+				       +correctRHS :: Monad m => HsPatP -> HsDeclP -> m Int+correctRHS (Pat (HsPParen p)) origDec+  = do+		result <- correctRHS p origDec+		return result+correctRHS (Pat (HsPTuple _ (p:ps))) origDec+  = do+		result <- correctRHS p origDec+		return result+			+correctRHS (Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _)))) (Dec (HsFunBind loc ms))+  = do+		result <- correctRHS2 ms x2+		return result+correctRHS p d+ = return 0					+				+correctRHS2 [] _ = return 0+correctRHS2 (m@(HsMatch l i1 ps _ ds):ms) x2+ = do+      res  <- correctRHS3 i1 ds x2+      rest <- correctRHS2 ms x2+      if res /= 0+        then return res+        else return rest+ +correctRHS3 _ [] _ = return 0+correctRHS3 pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss) x2+	= if returnRHS pnt e+		then do+			-- which element is x2 contained within p?+			count <- countPat [p] x2 1+			return count+		else do+			rest <- correctRHS3 pnt dss x2+			return rest+correctRHS3 pnt (d@(Dec (HsFunBind loc ms)):dss) x2+    = do+         matches <- checkMatches ms x2+         if matches /= 0 +           then return matches+           else do+                  res <- correctRHS3 pnt dss x2+                  return res+         where+           checkMatches [] _ = return 0+           checkMatches (m@(HsMatch l i1 ps (HsBody e) ds):ms) x2+            = do+                  res  <- correctRHS3 i1 ds x2+                  rest <- correctRHS2 ms x2+                  if res /= 0+                   then return res+                   else return rest+															+{-}	correctRHS3 (d:dss) x2 = do rest <- correctRHS3 dss x2 +							                         return 0 -}+						+countPat :: Monad m => [HsPatP] -> String -> Int -> m Int+countPat  [] x count = return count+countPat [Pat (HsPTuple _ (p:ps))] x2 count+ = do+       let result = inPat [p] x2+       if result then return count+                 else do result2 <- countPat ps x2 (count+1)+                         return result2+countPat  ((Pat (HsPTuple _ (p:ps))):ps2) x2 count+ = do+		let result = inPat (p:ps) x2+		if result then return count+                  else do result2 <- countPat ps2 x2 (count + 1)+                          return result2+countPat (p:ps) x2 count+ = do+       let result = inPat [p] x2+       if result then return count+                 else do result2 <- countPat ps x2 (count+1)		+                         return result2	+                         		+inPat [] _ = False	+inPat ((Pat (HsPId (HsVar (PNT (PN (UnQual x1) s) _ _)))):ps) x2+	| x1 == x2 = True+	| otherwise = inPat ps x2	     +inPat ((Pat (HsPTuple _ (p:ps))):ps2) x2+	| inPat (p:ps) x2 = True+	| otherwise = inPat ps2 x2 +inPat ((Pat (HsPParen p)):ps) x2+ = inPat (p:ps) x2+inPat (p:ps) x2+	= inPat ps x2+						            +           ++removeDeadTupleCase [] _ = return []+removeDeadTupleCase (d@(Dec (HsFunBind loc ms)):ds) decs+ = do+      res <- removeDeadCaseArgs ms decs+      rest <- removeDeadTupleCase ds decs+      return ((Dec (HsFunBind loc res)):rest)+       where+        removeDeadCaseArgs [] _ = return []+        removeDeadCaseArgs _ [] = return []+        removeDeadCaseArgs (m@(HsMatch l i1 ps (HsBody e) ds):ms) d+         = do+              res <- removeDeadCaseArgs2 i1 ds d+              rest <- removeDeadCaseArgs ms d+              return ((HsMatch l i1 ps (HsBody e) res):rest)++        removeDeadCaseArgs2 _ [] _ = return []+        removeDeadCaseArgs2 pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss) decs+         = case p of+            (Pat (HsPTuple s (l:ls))) -> if returnRHS pnt e+                                           then do+                                             newRHS <- removeDeadTupleCase2 (l:ls) decs [e]   +                                             rest <- removeDeadCaseArgs2 pnt dss decs+                                             if length newRHS == 1+                                                then do+                                                  let newRHS1 = newRHS !! 0+                                                  return ((Dec (HsPatBind loc p (HsBody newRHS1) ds)):rest)+                                                else do+                                                  return ((Dec (HsPatBind loc p (HsBody (Exp (HsTuple newRHS))) ds)):rest)+                                           else do+                                                rest <- removeDeadCaseArgs2 pnt dss decs+                                                return (d:rest)+            _                         -> if returnRHS pnt e+                                           then do+                                             newRHS <- removeDeadTupleCase2 [p] decs [e]+                                                                                          +                                             rest <- removeDeadCaseArgs2 pnt dss decs+   +                                             if length newRHS == 1+                                                then do+                                                  let newRHS1 = newRHS !! 0+                                                  return ((Dec (HsPatBind loc p (HsBody newRHS1) ds)):rest)+                                                else do+                                                  return ((Dec (HsPatBind loc p (HsBody (Exp (HsTuple newRHS))) ds)):rest)+                                           else do +                                                   rest <- removeDeadCaseArgs2 pnt dss decs+                                                   return (d:rest)+        removeDeadCaseArgs2 pnt (d:dss) decs = do rest <- removeDeadCaseArgs2 pnt dss decs+                                                  return (d:rest)++                                            +        removeDeadTupleCase2 pats decs [(Exp (HsCase e1 alts ))]+               = do+                  newExp <- removeFromExp [e1] pats decs+                  return [(Exp (HsCase newExp alts))]+                  +        removeDeadTupleCase2 pats decs [e]+               = do +                    newExp <- removeFromExp [e] pats decs+                    return [e]+                              +                  +        -- removeDeadTupleCase2 pats decs [e] = return [e]+           +        removeFromExp [(Exp (HsTuple (e:es)))] [p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _))))] (d:ds)+           = do+               -- error $ show (d:ds)+               let dec = head (findDec e (d:ds) )+               -- error $ show (x2, dec, [p])+               if defines2 (PN (UnQual x2) s) [p] dec+                then do+                  -- error $ show e+                  return e  +                else do+                  -- error $ show (defines2 (PN (UnQual x2) s) [p] dec)+                  rest <- removeFromExp2 es [p] (d:ds)+                  return (Exp (HsTuple rest))+                           +        removeFromExp [(Exp (HsTuple (e:es)))] (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _)))):ps) (d:ds)+                     = do+                         let dec = head (findDec e (d:ds) )+                         -- check there is a wildcard. If there is we need to find the definition which defines+                         -- the names and the wildcard replacment+                         +                         -- error $ show dec+                         let pns = defines3 (PN (UnQual x2) s) (p:ps) dec+                         if defaultPN `elem` pns+                          then do+                            rest <- removeFromExp2 es (p:ps) (d:ds)+                            return (Exp (HsTuple rest)) +                          else do     +                            -- error $ show (x2, dec)+                           if and (map ( (\a b c d -> a d b c)  defines2 (p:ps) dec) (hsPNs (p:ps)))+                            then do+                             rest <- removeFromExp2 es ps (d:ds)+                             return (Exp (HsTuple (e:rest)))+                         +                       {-  if defines2 (PN (UnQual x2) s) dec+                          then do+                           rest <- removeFromExp2 es ps (d:ds) +                           return (Exp (HsTuple (e:rest)))   -}+                            else do+                             rest <- removeFromExp2 es ps (d:ds)+                             return (Exp (HsTuple rest))+        removeFromExp [e] _ _ = return e+                           +        removeFromExp2 [] _ _ = return []   +        removeFromExp2 (e@(Exp _):es) [p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _))))] (d:ds)+                     = do+                          let dec = head (findDec e (d:ds) )+                          if defines2 (PN (UnQual x2) s) [p] dec+                           then do+                            -- error $ show (x2, dec)+                            return [e]   +                           else do+                            res <- removeFromExp2 es [p] (d:ds)+                            return res+        removeFromExp2 (e@(Exp _):es) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _)))):ps) (d:ds)+                     = do+                          let dec = head (findDec e (d:ds) )+                          if defines2 (PN (UnQual x2) s) (p:ps) dec+                           then do+                            -- error $ show (x2, dec)+                            rest <- removeFromExp2 es ps (d:ds)+                            return (e:rest)   +                           else do+                            rest <- removeFromExp2 es ps (d:ds)+                            return rest+        removeFromExp2 a b c = return []+                    +                    +        findDec _ [] = error "this wasn't supposed to happen"+        findDec e@(Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual x) s) _ _ )))) e2)) (d:ds)+                     | inDec x d = [d]+                     | otherwise = findDec e ds+                     +                     +        inDec x (Dec (HsPatBind loc (Pat (HsPId (HsVar (PNT (PN (UnQual x2) s) _ _)))) (HsBody e) ds))+                     | x == x2 = True+                     | otherwise = False+        inDec x (Dec (HsFunBind _ ((HsMatch _ (PNT (PN (UnQual x2) s)_ _) _ _ _):ms)))+                     | x == x2 = True+                     | otherwise = False+        inDec _ _ = False++{- removeDeadPatterns _ [] _ = return []+removeDeadPatterns a ((Dec (HsFunBind loc ms)):ds) pnt+       = do+           res <- removeDeadPats ms pnt+           -- error $ show ds+           rest <- removeDeadPatterns a ds pnt+           return ((Dec (HsFunBind loc res)): rest)+            where+             removeDeadPats [] pnt = return []+             removeDeadPats (m@(HsMatch l i1 ps (HsBody e) ds):ms) pnt+              = do+                   (dec, free) <- hsFreeAndDeclaredPNs e+                   -- error $ show dec+                   res <- removeDeadPats2 a dec i1 ds+                   rest <- removeDeadPats ms pnt+                   return ((HsMatch l i1 ps (HsBody e) res):rest) +                   +             removeDeadPats2 a dec pnt [] = return []+             removeDeadPats2 a dec pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss)+              = case p of+                  (Pat (HsPTuple s (l:ls))) -> if returnRHS2 pnt e+                                                  then do+                                                   newPats <- removeDeadPats3' s dec (l:ls)+                                                   newRHS <- removeDeadTupleEl pnt dec (l:ls) [e]+                                                   rest <- removeDeadPats2 a dec pnt dss+                                                   if length newRHS == 1+                                                     then do+                                                      let newRHS1 = newRHS !! 0+                                                      return ((Dec (HsPatBind loc newPats (HsBody newRHS1) ds)):rest)+                                                     else do+                                                      if length newRHS == 0+                                                       then error "There is an error with the variable dependency analysis!"+                                                       else+                                                        return ((Dec (HsPatBind loc newPats (HsBody (Exp (HsTuple newRHS))) ds)):rest)+                                                  else do+                                                   rest <- removeDeadPats2 a dec pnt dss+                                                   return ((Dec (HsPatBind loc p (HsBody e) ds)):rest)+                  _                          -> do+                                                  rest <- removeDeadPats2 a dec pnt dss+                                                  return (d:rest)+             removeDeadPats2 a dec pnt x = return x -}++removeDeadPatterns a ((Dec (HsFunBind loc ms)):ds) (pnt:pnts)+       = do+           res <- removeDeadPats ms pnt+           rest <- removeDeadPatterns a ds pnts+           return ((Dec (HsFunBind loc res)): rest)+            where+             removeDeadPats [] pnt = return []+             removeDeadPats (m@(HsMatch l i1 ps (HsBody e) ds):ms) pnt+              = do+                   (dec, free) <- hsFreeAndDeclaredPNs e+                   -- error $ show dec+                   res <- removeDeadPats2 a dec pnt ds+                   rest <- removeDeadPats ms pnt+                   return ((HsMatch l i1 ps (HsBody e) res):rest) +                   +             removeDeadPats2 a dec pnt [] = return []+             removeDeadPats2 a dec pnt (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss)+              = case p of+                  (Pat (HsPTuple s (l:ls))) -> if returnRHS pnt e+                                                  then do+                                                   newPats <- removeDeadPats3' s dec (l:ls)+                                                   newRHS <- removeDeadTupleEl pnt dec (l:ls) [e]+                                                   rest <- removeDeadPats2 a dec pnt dss+                                                   if length newRHS == 1+                                                     then do+                                                      let newRHS1 = newRHS !! 0+                                                      return ((Dec (HsPatBind loc newPats (HsBody newRHS1) ds)):rest)+                                                     else do+                                                      if length newRHS == 0+                                                       then error "There is an error with the variable dependency analysis!"+                                                       else+                                                        return ((Dec (HsPatBind loc newPats (HsBody (Exp (HsTuple newRHS))) ds)):rest)+                                                  else do+                                                   error $ show (pnt, e)+                                                   rest <- removeDeadPats2 a dec pnt dss+                                                   return ((Dec (HsPatBind loc p (HsBody e) ds)):rest)+                  _                          -> do+                                                  rest <- removeDeadPats2 a dec pnt dss+                                                  return (d:rest)+             removeDeadPats2 a dec pnt x = return x++             -- removeDeadPats3 [] _ = []+             removeDeadPats3' s a b+              = do+                   let res = removeDeadPats3 a b+                   if length res == 1+                    then do+                      let newRes = res !! 0+                      return newRes+                    else do+                      if res == []+                        then error "there is a problem with the dependency analysis on the RHS"+                        else return (Pat (HsPTuple s res))+             +             removeDeadPats3 :: [PName] -> [HsPatP] -> [HsPatP]+             removeDeadPats3 [] _ = []+             removeDeadPats3 _ [] = []+             removeDeadPats3 (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps)+               | myElem p (x:xs) = p : (removeDeadPats3 (x:xs) ps)+            --   | x1 == x2  = p : (removeDeadPats3 xs ps)+               | otherwise = removeDeadPats3 (x:xs) ps+             removeDeadPats3 (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPTuple s (p1:ps))):pss)+                | allBlank (removeDeadPats3Tuple (x:xs) (p1:ps))   = removeDeadPats3 (x:xs) pss+                | otherwise = (Pat (HsPTuple s (removeDeadPats3Tuple (x:xs) (p1:ps)))) : (removeDeadPats3 (x:xs) pss)+                    where+                     allBlank ps = and (allBlank2 ps)+                     allBlank2 [] = [True]+                     allBlank2 ((Pat (HsPWildCard)):ps)+                      = True : (allBlank2 ps)+                     allBlank2 (p:ps)+                      = False : (allBlank2 ps)+                    +                     removeDeadPats3Tuple [] _ = []+                     removeDeadPats3Tuple _ [] = []+                     removeDeadPats3Tuple (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps)+                      | myElem p (x:xs) = p : (removeDeadPats3Tuple (x:xs) ps)+                      | otherwise =  (Pat (HsPWildCard)) : ( removeDeadPats3Tuple (x:xs) ps )   +                     removeDeadPats3Tuple a (p:ps)+                      = p : (removeDeadPats3Tuple a ps  )               +             -- pattern is either a wildcard or a literal+             removeDeadPats3 a  (p:ps) -- = error $ show p+               = removeDeadPats3 a ps+            -- removeDeadPats3 a b = error $ show b+               +               +               +             myElem :: HsPatP -> [PName] -> Bool+             myElem _ [] = False+             myElem a@(Pat (HsPParen p1)) (p:ps) = myElem p1 (p:ps)+             myElem a@(Pat (HsPId (HsVar (PNT (PN (UnQual x1)_) _ _)))) (p@(PN (UnQual x2) _):ps)+              | x1 == x2 = True+              | otherwise = myElem a ps+               +             removeDeadPats4' s a b c+              = do+                   let res = removeDeadPats4 a b c+                   if length res == 1+                    then do+                      let newRes = res !! 0+                      return newRes+                    else do+                      if res == []+                        then error $ show "blah"+                        else return (Pat (HsPTuple s res))+  +             removeDeadPats4 [] _ _ = []+             removeDeadPats4 _ [] _ = []+             removeDeadPats4 _ _ [] = []+             removeDeadPats4 (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPParen p1)):ps)  (l:ls)+               = removeDeadPats4 (x:xs) (p1:ps) (l:ls)+             removeDeadPats4 (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPTuple s (p1:ps1))):ps) (l:ls)+               | or (map (flip myElem (x:xs)) (p1:ps1)) = l : (removeDeadPats4 (x:xs) ps ls)+               | otherwise = removeDeadPats4 (x:xs) ps ls+             removeDeadPats4 (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps) (l:ls)+               | myElem p (x:xs) = l : (removeDeadPats4 (x:xs) ps ls)+               | otherwise = removeDeadPats4 (x:xs) ps ls+            -- removeDeadPats4 a b c =  error $ show (a,b,c)+             +             removeDeadTupleEl _ [] _ _ = return []+             removeDeadTupleEl _ _ [] _ = return []+             removeDeadTupleEl _ _ _ [] = return [] +             removeDeadTupleEl pnt (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps) e1@[(Exp (HsTuple (e:es)))]+               = return e1+          --     | x1 == x2   = do+          {-     | myElem p (x:xs) = do+                                  res <- removeDeadTupleEl pnt (x:xs) ps es+                                  return (e : res)+               | otherwise  = do res <-  removeDeadTupleEl pnt (x:xs) ps es+                                 return res+                                 -}+                                 +             removeDeadTupleEl p a b [(Exp (HsIf e1 e2 e3))]+              = do+                   -- e1' <- removeDeadTupleEl' a b [e1]+                   e2' <- removeDeadTupleEl' p a b [e2]+                   e3' <- removeDeadTupleEl' p a b [e3]+                   return [(Exp (HsIf e1 e2' e3'))] +                    +                                        +                                 +             removeDeadTupleEl pnt a b [(Exp (HsCase e1 (al:als) ))]+               = do+                  result <- removeDeadAlts (al:als) +                  return [(Exp (HsCase e1 result))]+                   where+                    removeDeadAlts [] = return []+                    removeDeadAlts ((HsAlt s p (HsBody e) ds):as)+                     = +                      case p of+                      (Pat (HsPTuple s2 (l:ls))) ->+                       do+                         if returnRHS pnt e1 && (length (l:ls) == length b)+                           then do+                            newPats <- removeDeadPats4' s2 a b (l:ls)+                            let res = removeDeadCase a b [e]+                            rest <- removeDeadAlts as+                            return ((HsAlt s newPats (HsBody (Exp (HsTuple res))) ds):rest)+                           else do+                            let res = removeDeadCase a b [e]+                            rest <- removeDeadAlts as+                            return ((HsAlt s p (HsBody (Exp (HsTuple res))) ds):rest)+                      _ ->+                       do    +                         let res = removeDeadCase a b [e]+                         rest <- removeDeadAlts as+                         return ((HsAlt s p (HsBody (Exp (HsTuple res))) ds):rest)                  +          --     | x1 == x2   = e : (removeDeadTupleEl xs ps es)+          --     | otherwise  = removeDeadTupleEl (x:xs) ps es+             removeDeadTupleEl pnt (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps) (e:es)+              = return (e:es)+          {-     | myElem p (x:xs) = do+                                  res <- removeDeadTupleEl pnt (x:xs) ps es+                                  return (e : res)+               | otherwise  = do res <-  removeDeadTupleEl pnt (x:xs) ps es+                                 return res  +                                 +                                 -}        +             removeDeadTupleEl _ _ _ x = return x+             +             removeDeadTupleEl' p a b e+               = do+                    res <- removeDeadTupleEl p a b e+                    if length res == 1+                      then do+                        let newRes = res !! 0+                        return newRes+                      else return (Exp (HsTuple res))++             removeDeadCase [] _ _ = []+             removeDeadCase _ [] _ = []+             removeDeadCase _ _ [] = []+             removeDeadCase (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps) [(Exp(HsTuple (e:es)))]+                | myElem p (x:xs) = e : (removeDeadCase (x:xs) ps es)+                | otherwise = removeDeadCase (x:xs) ps es+             removeDeadCase (x@(PN(UnQual x1) _):xs) (p@(Pat (HsPId (HsVar (PNT (PN (UnQual x2)_) _ _)))):ps) (e:es)+                | myElem p (x:xs) = e : (removeDeadCase (x:xs) ps es)+                | otherwise = removeDeadCase (x:xs) ps es+             removeDeadCase _ _ e = e  +++-- return (d:dss) +removeDeadPatterns a d _ = return d+++                          ++replaceWithNew a name [] _ = return []+replaceWithNew a name (d@(Dec (HsFunBind loc ms)):dss) total+ = do+      newMatches <- replaceInMatch ms total+      rest <- replaceWithNew a name dss total+      return ((Dec (HsFunBind loc newMatches)) : rest) +  where+   replaceInMatch [] _ = return []+   replaceInMatch (m@(HsMatch l i1 ps (HsBody e) ds):ms) total+    = do+        newExp <- replaceInE a name total e+        let newExp2 = cleanNew newExp+        rest2' <- replaceWithNew a name ds total+        rest' <- replaceInMatch ms total+        return ((HsMatch l i1 ps (HsBody newExp2) rest2') : rest')+        +replaceWithNew a name (d@(Dec (HsPatBind loc p (HsBody e) ds)):dss) total+ = do+      newExp <- replaceInE a name total e+      let newExp2 = cleanNew newExp+      rest <- replaceWithNew a name ds total+      rest2 <- replaceWithNew a name dss total+      return ((Dec (HsPatBind loc p (HsBody newExp2) rest)): rest2)+      +cleanNew :: HsExpP -> HsExpP+cleanNew e@(Exp (HsTuple l))+ | length l == 1 = head l+ | otherwise     = e      +cleanNew e = e     +        +removeName (Exp (HsApp e1 e2))+ | removeName e1 == defaultExp = (Exp (HsApp defaultExp e2))+ | otherwise =  (Exp (HsApp (removeName e1) e2))    +removeName  e = defaultExp  +    +     +replaceInE a name total e+  = applyTP (once_tdTP (adhocTP idTP (rename' a))) e+     where+        rename' a e'@(Exp (HsApp e1 e2)::HsExpP)+         -- | a /= "a" && a /= "A" = return e+          | findPN name e1 =  return (Exp (HsTuple (makeTuple (pNtoName name) newCount (removeName e) total newAnswer)))+          | findPN name e2 = do newExp <- replaceInE a name total e2+                                return (Exp (HsApp e1 (newExp) ))+          | otherwise = return e'+          +              where+                  (newCount, newAnswer) = countAnswer 0 a+        rename' a e'@(Exp (HsParen e1)::HsExpP) = do newExp <- replaceInE a name total e1+                                                     return (Exp (HsParen (newExp)))+        rename' a e'@(Exp (HsLet ds e1)::HsExpP) = do newDS <- replaceWithNew a name ds total+                                                      newExp <- replaceInE a name total e1+                                                      return (Exp (HsLet newDS newExp))+        rename' a e'@(Exp (HsIf e1 e2 e3)::HsExpP) = do newExp1 <- replaceInE a name total e1+                                                        newExp2 <- replaceInE a name total e2+                                                        newExp3 <- replaceInE a name total e3+                                                        return (Exp (HsIf newExp1 newExp2 newExp3))+                                                      +        rename' a e'@(Exp (HsTuple (e1:e1s))::HsExpP) = do newExp1 <- replaceInE a name total e1+                                                           newExps2 <- mapM (replaceInE a name total) e1s+                                                           return (Exp(HsTuple (newExp1 : newExps2)))+                    +        rename' a e'@(Exp (HsList (e1:e1s))::HsExpP) = do newExp1 <- replaceInE a name total e1+                                                          newExps2 <- mapM (replaceInE a name total) e1s+                                                          return (Exp(HsList (newExp1 : newExps2)))+                                                        +        rename' a e'@(Exp (HsLambda ps e1)::HsExpP) = do newExp1 <- replaceInE a name total e1+                                                         return (Exp (HsLambda ps newExp1))+                            +        rename' a e'@(Exp (HsInfixApp e1 i e2)::HsExpP) = do newExp1 <- replaceInE a name total e1+                                                             newExp2 <- replaceInE a name total e2+                                                             return (Exp(HsInfixApp newExp1 i newExp2))+                                                           +        rename' a e'@(Exp (HsCase e1 as)::HsExpP) = do newExp1 <- replaceInE a name total e1+                                                       newAlts <- mapM (replaceInA name total) as+                                                       return (Exp (HsCase newExp1 newAlts))+                                                        where+                                                         replaceInA name total (HsAlt s p (HsBody e1) ds) +                                                          = do+                                                               newExp1 <- replaceInE a name total e1+                                                               newDS <- replaceWithNew a name ds total+                                                               return (HsAlt s p (HsBody newExp1) newDS)+                                                             +                                                         replaceInA name total (HsAlt s p (HsGuard es) ds) +                                                          = do+                                                         +                                                             newExp1 <- mapM replaceInG es+                                                             newDS <- replaceWithNew a name ds total+                                                             return (HsAlt s p (HsGuard newExp1) newDS)+                                                              where+                                                               replaceInG (s, e1, e2) = do newExp1 <- replaceInE a name total e1+                                                                                           newExp2 <- replaceInE a name total e2+                                                                                           return (s, newExp1, newExp2) +                                                             +                                                      +        rename' a (x::HsExpP) +            | findPN name x = return (Exp (HsTuple (makeSimpleTuple (pNtoName name) newCount total newAnswer)))+            | otherwise = return x+                where+                  (newCount, newAnswer) = countAnswer 0 a+        + +makeTuple _ _ _ 0 _= []+makeTuple name i e2 total a+ =  (Exp (HsApp (nameToExp (name ++ (show i))) e2)) : (makeTuple name newCount e2 (total-1) newAnswer) +    where+       (newCount, newAnswer) = countAnswer 0 a+makeTuple2 _ _ _ 0 _ = []+makeTuple2 name i e1 total a+ =  (Exp (HsApp e1 (nameToExp (name ++ (show i))))) : (makeTuple2 name newCount e1 (total-1) newAnswer) +    where+       (newCount, newAnswer) = countAnswer 0 a+makeSimpleTuple _ _ 0 _ = []+makeSimpleTuple name i total a+ = (nameToExp (name ++ (show i))) : (makeSimpleTuple name newCount (total-1) newAnswer)  +     where+         (newCount, newAnswer) = countAnswer 0 a  ++ +sortDecls :: ([HsDeclP], [Bool], [PNT]) -> [(HsDeclP, Bool, PNT)]+sortDecls ([],_, _) = []+sortDecls ((d@(Dec (HsFunBind loc (m@(HsMatch l i1 ps (HsBody e) ds):ms))):dss), (b:bs), (s:ss))+ = (( (d, b, s) : (findRest i1 (dss, bs, ss) )) ++ sortDecls ((map (\(a,b,c) -> a) (removeAll i1 ((d:dss), (b:bs) , (s:ss))) ) , (map (\(a,b,c) -> b) (removeAll i1 ((d:dss), (b:bs), (s:ss) ))  ), (map (\(a,b,c)->c) (removeAll i1 ((d:dss), (b:bs), (s:ss))))   ) )+   where+      findRest :: PNT -> ([HsDeclP], [Bool], [PNT]) -> [(HsDeclP, Bool, PNT)]+      findRest i ([], _, _) = []+      findRest i ((d@(Dec(HsFunBind loc (m@(HsMatch l i1 ps (HsBody e) ds):ms))):dss), (b:bs), (s:ss))+        | i == i1 = (d, b, s) : (findRest i (dss, bs, ss))+        | otherwise = findRest i (dss, bs, ss)+      findRest i (_, _, k) = error $ show k+    +      removeAll :: PNT -> ([HsDeclP], [Bool], [PNT]) -> [(HsDeclP, Bool, PNT)]+      removeAll i ([], _, _) = []+      removeAll i ((d@(Dec(HsFunBind loc (m@(HsMatch l i1 ps (HsBody e) ds):ms))):dss) , (b:bs), (s:ss) )                    +        | i == i1 = removeAll i (dss, bs, ss)+        | otherwise = (d,b, s) : (removeAll i (dss, bs, ss) )+ +        +correctExpression [] exp  = exp+correctExpression (x:xs) exp+      | x == defaultExp = correctExpression xs exp+      | otherwise = x+ +get1Element :: HsExpP -> HsExpP+get1Element (Exp (HsTuple (e:es))) = e+get1Element e = e + +  +forEach [] _ _ _ fileName i a _ (inscps, exps, mod, tokList) + = do    +       return []+                              +forEach (e:es) rhs wh wh3 fileName i a (funName, funPats) (inscps, exps, mod, tokList)  +  = do+        let (newCount, newAnswer) = countAnswer i a          ++        let (begin, end) = getStartEndLoc tokList (get1Element e)+        let (loc, pnt, pats, exp, wh2, p)+                  = findDefNameAndExp tokList+                                      begin+                                      end+                                      mod +                                      +                                      +        -- error $ "1" ++ (show (begin, end))+        res <- checkLetAndLambda begin end tokList wh e rhs+        let res' = correctExpression res rhs+        newExp' <- checkIfOrLet res' e tokList begin end+        (refactoredExp,wh') <- checkCase newExp' e wh+        res1 <- sliceSubExp p rhs refactoredExp wh' wh3 (head loc) funName pats newCount         +        res2 <- forEach es rhs wh wh3 fileName newCount newAnswer (funName, funPats) (inscps, exps, mod, tokList)+        return (res1 ++ res2)+        +forEach2 wher [] rhs wh wh3 fileName i a (funName, funPats) (inscps, exps, m, tokList) = do+       return []+                              +forEach2 wher (e:es) rhs wh wh3 fileName i a (funName, funPats) (inscps, exps, m, tokList)+  = do+        let (newCount, newAnswer) = countAnswer i a          ++++        let (begin, end) = getStartEndLoc tokList (get1Element e)+        let blah@(loc, pnt, pats, exp, wh2, p)+                  = findDefNameAndExp tokList+                                      begin+                                      end+                                      m +        let (begin2, end2) = getStartEndLoc tokList rhs+        +        -- error $ "2" ++ (show (loc, pnt, pats, exp, wh2, p) )++        let (_,_, mainPats, _, _,_)+                  = findDefNameAndExp tokList+                                      begin2+                                      end2+                                      m   +                                                                               +        res <- checkLetAndLambda begin end tokList wh e rhs+        let res' = correctExpression res rhs+        newExp' <- checkIfOrLet res' e tokList begin end+        (refactoredExp,wh') <- checkCase newExp' e wh+                +        res1 <- sliceSubExp3 wher rhs e pnt p refactoredExp wh' wh3 (head loc) pnt mainPats funPats newCount+        res2 <- forEach2 wher es rhs wh wh3 fileName newCount newAnswer (funName, funPats) (inscps, exps, m, tokList)+        +        -- error $ show (res1 ++ res2)+        +        return (res1 ++ res2)++countAnswer :: Int -> String -> (Int, String)+countAnswer i [] = (i, [])+countAnswer i "a" = (i+ 1, "a")+countAnswer i "A" = (i+ 1, "a")+countAnswer i ('_':xs) = countAnswer (i+1) xs+countAnswer i ('x':xs) = ((i+1), xs)+countAnswer i ('X':xs) = ((i+1), xs)+countAnswer i (x:xs)  =  countAnswer i xs+++sliceSubExp2 (_,_,mod) = return mod                                   +sliceSubExp p old exp wh wh2 loc pnt pats i -- (_,_, mod) +   = do+       (decls, newExp) <- removeRedun wh exp  +       return (updating p loc pnt pats newExp decls i)+                                                 +sliceSubExp3 wher funRHS rhs funName p old wh wh2 loc pnt mainPats pats i -- (_,_, mod) +   = do+       (decls, newExp) <- removeRedun wh rhs+       newWher <- removeRedunWhere wher rhs+       return [(newDecl3 loc (nameToPNT ((pNTtoName funName) ++ (show i))) pats newExp decls i)]+       +       +       -- return (updating2 p (wh2++newWher) funRHS funName loc pnt mainPats pats newExp decls i)+                                                                                                                                                                            +changeName newName (PNT (PN (UnQual _) (G modName _ optSrc)) Value s) +                  = PNT (PN (UnQual newName) (G modName newName optSrc)) Value s+                                                             +updating (match@(Match x)) loc pnt pats rhs ds i=  [Dec (HsFunBind loc0 [newMatch loc pnt pats rhs ds i])]+                                                        +updating (pat@(MyPat x))loc pnt pats rhs ds i = [newDecl loc pnt pats rhs ds i]++updating x _ _ _ _ _ _ = error $ show x++updating2 (match@(Match x)) wher funRHS funName loc pnt mainPats pats rhs ds i=  [Dec (HsFunBind loc0 [newMatch2 wher funRHS funName loc pnt mainPats pats rhs ds i])]+                                                      +updating2 (pat@(MyPat x)) wher funRHS funName loc pnt mainPats pats rhs ds i = [newDecl2 wher funRHS funName loc pnt mainPats pats rhs ds i]++newMatch loc pnt pats rhs ds i= HsMatch loc (nameToPNT ((pNTtoName pnt) ++ (show i))) pats (HsBody rhs) ds +newDecl loc pnt pats rhs ds i = Dec (HsFunBind loc [HsMatch loc (nameToPNT ((pNTtoName pnt) ++ (show i))) pats (HsBody rhs) ds] )++newMatch2 wher funRHS funName loc pnt mainPats pats rhs ds i= HsMatch loc (nameToPNT ((pNTtoName funName) ++ (show i))) mainPats (HsBody funRHS) ([newDecl3 loc pnt pats rhs ds i] ++ wher)++newDecl2 wher funRHS funName loc pnt mainPats pats rhs ds i = Dec (HsFunBind loc [HsMatch loc (nameToPNT ((pNTtoName funName) ++ (show i)))  mainPats (HsBody funRHS) ([newDecl3 loc pnt pats rhs ds i] ++ wher)] )++newDecl3 loc pnt pats rhs ds i = Dec (HsFunBind loc [HsMatch loc pnt pats (HsBody rhs) ds] )+++getRHS :: String -> String -> HsDeclP -> PNT -> Bool -> [HsDeclP] -> String -> [([HsExpP], HsExpP, [HsDeclP], [HsDeclP], Bool, [HsPatP])]              +getRHS fileName a (Dec (HsPatBind loc p (HsBody e) ds)) pnt local localDefs modName+ = res e+     where+      res e =+       case e of+        (Exp (HsTuple es)) -> if (getLength1 a e) == (length es)+                                 then [(es, e, ds, [],  local, [p])]+                                 else do let l = getLengthAnswer a 0 +                                         if (length es) /= l+                                            then error "Please supply the correct number of elements"+                                            else [((shuffleRHS a es), e, ds, [], local, [p])]   +        (Exp (HsId (HsVar i)))     +             -> do+                    let types = getTypes fileName (pNTtoName (patToPNT p) ) modName+                    let returnType = last types+                    if local == False+                      then do+                        let isTuple = elem '(' returnType && elem ',' returnType && elem ')' returnType+                        if isTuple +                         then+                          if or (map (defines (pNTtoPN i)) ds)+                            then +                              do+                                -- find the definition+                                let def = findDef i ds+                                if def == []+                                  then error "Definition does not appear on the RHS"+                                  else+                                   do+                                    let ((listExp, rhs, wh, wh2, localDefs, p'):xs) = (getRHS fileName a (head def) i True ds modName)+                                    ((listExp, e, wh, wh2, True, p'):xs)++                            else+                               error "Definition does not appear on the RHS"+                         else error $ show isTuple+                      else+                        if or (map (defines (pNTtoPN i)) ds)+                         then +                           do+                             -- find the definition+                             let def = findDef i ds+                             if def == []+                               then error "Definition not defined on RHS"+                               else+                                 do+                                   let ((listExp, rhs, wh, wh2, localDefs, p'):xs) = (getRHS fileName a (head def) i True ds modName)+                                   ((listExp, e, wh, wh2, True, p'):xs)+                         else+                            error "Definition not definied on RHS"+        (Exp (HsApp e1 e2)) -> do let ((listExp, e', wh, wh2, True, p'):xs) =  res e1+                                  ((listExp, e, wh, wh2, True, p'):xs)+        _  -> [([e], e, ds,[], False, [p])]   ++     +getRHS fileName a (Dec (HsFunBind loc ms)) pnt local localDefs modName+ = findInMatch ms pnt+     where+       findInMatch [] _ = []+       findInMatch (m@(HsMatch l i1 ps (HsGuard [(s, e1, e2)]) ds):ms) pnt+          = findInMatch ((HsMatch l i1 ps (HsBody e2) ds):ms) pnt+       findInMatch (m@(HsMatch l i1 ps (HsBody e) ds):ms) pnt+          = (res e) ++ (findInMatch ms pnt)+             where  +               mapM2 f [e] = do let ((listExp, e', wh, wh2, localDefs, p):xs) = res e+                                ((listExp, e, wh, wh2, True, p):xs)+               mapM2 f (e:es) = do let ((listExp, e', wh, wh2, localDefs, p):xs) = res e+                                   (((e:es), e, wh, wh2, True, p):xs) ++ mapM2 f es+               res e = +                 case e of+                   (Exp (HsTuple es)) -> if (getLength1 a e) == (length es)+                                           then [(es, e, ds, [],  local, ps)]+                                           else do let l = getLengthAnswer a 0 +                                                   if (length es) /= l+                                                    then error "Please supply the correct number of elements"+                                                    else [((shuffleRHS a es), e, ds, [], local, ps)] -- [((shuffleRHS a es), e, ds, [], False)]                   +                   (Exp (HsId (HsVar i)))   +                      -> do+                          let types = getTypes fileName (pNTtoName i1) modName+                          let returnType = last types+                          if local == False+                            then do+                                   let isTuple = elem '(' returnType && elem ',' returnType && elem ')' returnType                              +                                   if isTuple +                                         then+                                              if or (map (defines (pNTtoPN i)) ds)+                                                then +                                                  do+                                                   -- find the definition+                                                   let def = findDef i ds+                                                   if def == []+                                                     then error ("Definition does not appear on the RHS" ++ (show i))+                                                     else+                                                       do+                                                        let ((listExp, rhs, wh, wh2, localDefs, p):xs) = (getRHS fileName a (head def) i True ds modName)+                                                        ((listExp, e, wh, wh2, True, p):xs)+                                                else+                                                   error "Definition does not appear on the RHS"+                                         else error $ show isTuple+                                    else+                                     if or (map (defines (pNTtoPN i)) ds)+                                                then +                                                  do+                                                   -- find the definition+                                                   let def = findDef i ds+                                                   if def == []+                                                     then error $ show def+                                                     else+                                                       do+                                                        [([e], e, ds, [] ,True, ps)]++                                                else do+                                                   -- let def = definingDecls [(nameToPN (pNTtoName i))] localDefs False False+                                                   let def = findDef i localDefs+                                                   if def == []+                                                    then error ( "Definition does not fully appear on RHS" ++ (show i) )+                                                    else+                                                     do+                                                      let newDec = (Dec (HsFunBind loc [m]))+                                                      [([e], e, ds, [] ,True, ps)]+                   (Exp (HsApp e1 e2)) -> do let ((listExp, e', wh, wh2, True, p):xs) =  res e1+                                             ((listExp, e, wh, wh2, True, p):xs)+                   e -> [([e], e, ds,[], False, ps)]        +       -- findInMatch m pnt = error $ show m           +findDef pnt t+ = fromMaybe ([])+    (applyTU (once_tdTU (failTU `adhocTU` inDef)) t)                                       +     where+      inDef d@(Dec (HsPatBind loc p (HsBody e) ds)) +        | pNTtoName (patToPNT p) == pNTtoName pnt = Just [d]+        | otherwise                    = Nothing+      inDef d@(Dec (HsFunBind loc ms))+        | traverseMS ms = Just [d]+        | otherwise     = Nothing+            where+              traverseMS [] = False+              traverseMS (m@(HsMatch l i1 ps (HsBody e) ds):ms)+               | pNTtoName i1 == pNTtoName pnt = True+               | lookInPats ps pnt = True+               | otherwise = traverseMS ms+      inDef _ = Nothing+      +lookInPats [] _ = False      +lookInPats (p:ps) pnt +  | patToPNT p == pnt = True+  | otherwise         = lookInPats ps pnt+      +simpleGetRHS (Dec (HsPatBind loc p (HsBody e) ds)) pnt  = (e, patToPNT p, ds, [])+simpleGetRHS (Dec (HsFunBind loc ms)) pnt +   = findInMatch ms pnt+       where+        findInMatch [] _ = (defaultExp, defaultPNT, [], [])+        findInMatch (m@(HsMatch l i ps (HsBody e) ds):ms) pnt+         | findPNT pnt m = (e, i, ds, ps) +         | otherwise     = findInMatch ms pnt+        findInMatch (m@(HsMatch l i ps (HsGuard [(l', e1, e2)]) ds):ms) pnt+         | findPNT pnt m = (e2, i, ds, ps)+         | otherwise     = findInMatch ms pnt +         +removeFromWhere [] _ = []         +removeFromWhere (d:ds) pnt + | defines pnt d = removeFromWhere ds pnt+ | otherwise     = d : (removeFromWhere ds pnt)+                                 ++--check whether the cursor points to the beginning of the datatype declaration+--taken from RefacADT.hs+checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToTypeDecl of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the definiton!")+     Just decl -> Right decl+   where+    locToTypeDecl = find (definesPNT (locToPNT fileName (row, col) mod)) (hsModDecls mod)+    +    definesPNT pnt d@(Dec (HsPatBind loc p e ds))+      = findPNT pnt d+    definesPNT pnt d@(Dec (HsFunBind loc ms)) = findPNT pnt d+    definesPNT pnt _ = False+    +{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++{-findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (SrcLoc, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+ -}                    +findDefNameAndExp toks beginPos endPos t+  = fromMaybe ([], defaultPNT, [], defaultExp, [], Def [])+              (applyTU (once_tdTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t)++    where+      --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats (rhs@(HsBody e)) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just ([loc1], pnt, pats, e, ds, (Match match))+      inMatch (match@(HsMatch loc1 pnt pats (rhs@(HsGuard [(s, e1, e2)])) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just ([loc1], pnt, pats, e2, ds, (Match match))+      inMatch _ = Nothing++      --The selected sub-expression is in the rhs of a pattern-binding+      inPat (pat@(Dec (HsPatBind loc1 ps (rhs@(HsBody e)) ds))::HsDeclP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = if isSimplePatBind pat+              then Just ([loc1], patToPNT ps, [], e, ds, (MyPat pat))+              else error "A complex pattern binding can not be generalised!"+      inPat _ = Nothing+      +    +    
+ refactorer/RefacSlicing.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacSlicing+-- Copyright   :  (c) Christopher Brown 2005+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Symoblic Evaluation on tuples.+-- creates functions which evaluate tha expressions+-- within the return value of a function.+--  e.g.+--+-- @ f x y = (x, y) @+--+-- @ f1 x = x @+--+-- @ f2 y = y @+--+-----------------------------------------------------------------------------++module RefacSlicing where+ + +import AbstractIO+import Maybe+import List+import RefacUtils+import RefacRedunDec+import SlicingUtils++data Patt = Match HsMatchP | MyPat HsDeclP | Def [Char]++refacSlicing args+  = do let +           fileName    = args!!0+           beginRow   = read (args!!1)::Int+           beginCol   = read (args!!2)::Int+           endRow     = read (args!!3)::Int+           endCol     = read (args!!4)::Int+       AbstractIO.putStrLn "refacSlicing"++       -- Parse the input file.+       modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName++       -- Find the function that's been highlighted as the refactree++       let (loc, pnt, pats, exp, wh, p)+             = findDefNameAndExp tokList+                                 (beginRow, beginCol)+                                 (endRow, endCol)+                                 mod ++       let newExp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod+              +       let transExp = rewriteExpression exp newExp         +                            +       if newExp == defaultExp  +            then do+               error "Program slicing can only be performed on an expression."+            else do+               (wh', newExp') <- doRefac wh transExp+               +               -- ((_,_), (tokList', mod')) <- applyRefac (checkCase exp newExp wh') (Just inscps, exps, mod, tokList) fileName+          +               -- AbstractIO.putStrLn $ show (newExp, wh'')+               +               (_,refWh) <- checkCase exp newExp wh'+          +               -- (mod',((tokList',modified),_))<-doRemovingWhere fileName mod tokList exp newExp' wh'+                              +               +               ((_,_), (tokList', mod')) <- applyRefac (doRemovingWhere exp newExp' refWh) (Just (inscps, exps, mod, tokList)) fileName+                                                                               +               ((_,m), (tokList'', mod'')) <- applyRefac (doRemoving1 exp  newExp' wh) (Just (inscps, exps, mod', tokList')) fileName+               +               -- ((_,_), (newTokList, newMod)) <- applyRefac (doTranslation exp transExp) (Just (inscps, exps, mod'', tokList'')) fileName+                +               -- AbstractIO.putStrLn $ show tokList''           +               writeRefactoredFiles False [((fileName, True), (tokList'', mod''))]+               +               AbstractIO.putStrLn "Completed.\n"+++doTranslation e nT (_,_,mod)+  = do+       newMod <- update e nT mod+       return newMod++sliceSubExp p old exp wh loc pnt pats (_,_, mod) = do++                                                 (decls, newExp) <- removeRedun wh exp+                                                 +                                                 mod' <- updating p mod loc pnt pats newExp decls++                                                 return mod'+                                               +changeName newName (PNT (PN (UnQual _) (G modName _ optSrc)) Value s) +                  = PNT (PN (UnQual newName) (G modName newName optSrc)) Value s+                  +updating (match@(Match x)) mod loc pnt pats rhs ds = do +                                                       mod' <- update x (newMatch loc pnt pats rhs ds) mod+                                                       return mod'+updating (pat@(MyPat x)) mod loc pnt pats rhs ds = do +                                                      mod' <- update x (newDecl loc pnt pats rhs ds) mod+                                                      return mod'++newMatch loc pnt pats rhs ds = HsMatch loc pnt pats (HsBody rhs) ds +newDecl loc pnt pats rhs ds = Dec (HsFunBind loc [HsMatch loc pnt pats (HsBody rhs) ds] )++checkFreeInWhere :: [PName] -> [HsDeclP] -> [HsDeclP]+checkFreeInWhere [] _ = []+checkFreeInWhere _ [] = []+checkFreeInWhere (p:ps) list = (checkSinInWhere p list) ++ (checkFreeInWhere ps list)+                                 where+                                   checkSinInWhere :: PName -> [HsDeclP] -> [HsDeclP]+                                   checkSinInWhere p [] = []+                                   checkSinInWhere p (x:xs) +                                      | defines p x = [x]+                                      | otherwise   = checkSinInWhere p xs+++rewriteExpression :: HsExpP -> HsExpP -> HsExpP+rewriteExpression e@(Exp (HsInfixApp e1 o e2)) newExp + | findEntity newExp e1 = (rewriteExpression e1 newExp)+ | findEntity newExp e2 = (rewriteExpression e2 newExp)+ | otherwise = e+rewriteExpression (Exp (HsLet ds e)) newExp = (Exp (HsLet ds (rewriteExpression e newExp)))+rewriteExpression (Exp (HsLambda ds e)) newExp = (Exp (HsLambda ds newExp))+rewriteExpression (Exp (HsParen e1)) newExp = rewriteExpression e1 newExp+rewriteExpression e1 e2 = e2++{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++{-findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (SrcLoc, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+ -}                    +findDefNameAndExp toks beginPos endPos t+  = fromMaybe ([], defaultPNT, [], defaultExp, [], Def [])+              (applyTU (once_tdTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t)++    where+      --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats (rhs@(HsBody e)) ds)::HsMatchP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = Just ([loc1], pnt, pats, e, ds, (Match match))+      inMatch _ = Nothing++      --The selected sub-expression is in the rhs of a pattern-binding+      inPat (pat@(Dec (HsPatBind loc1 ps (rhs@(HsBody e)) ds))::HsDeclP)+        | locToExp beginPos endPos toks rhs /= defaultExp+          = if isSimplePatBind pat+              then Just ([loc1], patToPNT ps, [], e, ds, (MyPat pat))+              else error "A complex pattern binding can not be generalised!"+      inPat _ = Nothing+++
+ refactorer/RefacSwapArgs.hs view
@@ -0,0 +1,50 @@++module RefacSwapArgs(swapArgs) where+import RefacUtils++swapArgs args  + = do let fileName = ghead "filename" args       +          row      = read (args!!1)::Int        +          col      = read (args!!2)::Int        +      modInfo@(_,exps, mod, toks)<-parseSourceFile fileName  +      let pnt =locToPNT fileName (row, col) mod     +      if isFunPNT pnt mod   +       then do r<-applyRefac (doSwap pnt) (Just modInfo) fileName+               rs <-if isExported pnt exps +                      then  applyRefacToClientMods (doSwap pnt) fileName+                      else  return []+               writeRefactoredFiles False (r:rs)      +       else error "\nInvalid cursor position!"  ++-- Inside a single module.+doSwap pnt (_ , _, mod) = applyTP (full_buTP (idTP `adhocTP`  inMatch +                                                   `adhocTP`  inExp+                                                   `adhocTP`  inDecl)) mod+  where +    -- In the define site.+    inMatch ((HsMatch loc fun pats rhs ds)::HsMatchP)+      | fun == pnt   +      = case pats of    +         (p1:p2:ps) -> do  pats''<-update p2 p1 =<< update p1 p2 pats+                           return (HsMatch loc fun pats'' rhs ds)+         _          -> error "Insufficient arguments to swap." +    inMatch m = return m  ++    -- In the call-site.+    inExp exp@((Exp (HsApp (Exp (HsApp e e1)) e2))::HsExpP)+      | expToPNT e == pnt     +      = update e2 e1 =<< update e1 e2 exp     +    inExp e = return e + +    -- In the type signature,.+    inDecl (decl@(Dec (HsTypeSig loc is c tp))::HsDeclP)+      |isTypeSigOf pnt decl +      = if length is ==1 +         then do let (t1:t2:ts)= tyFunToList tp +                 update t2 t1 =<< update t1 t2 decl+         else error "This type signature defines the type of more than one identifiers."+    inDecl d = return d ++    tyFunToList (Typ (HsTyFun t1 t2)) = t1:(tyFunToList t2)+    tyFunToList t = [t]+ 
+ refactorer/RefacTypeAddCon.hs view
@@ -0,0 +1,397 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacAddCon+-- Copyright   :  (c) Christopher Brown 2006+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Add a new constructor to a data type++-----------------------------------------------------------------------------++module RefacTypeAddCon where+ +import PrettyPrint+import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacTypeUtils+import PFE0 (findFile)+import MUtils (( # ))+import RefacTypeLocUtils+import System+import IO+import TiDecorate++-- | An argument list for a function which of course is a list of paterns.+type FunctionPats = [HsPatP]++-- | A list of declarations used to represent a where or let clause.+type WhereDecls = [HsDeclP]+++alphabet :: String+alphabet = "abcdefghijklmnopqrstuvwxyz"++refacTypeAddCon args+  = do +       let len = length args+       if len > 2 +         then do +            let (first,sec) = splitAt ((length args)-2) args+            let fileName    = first!!0+                ans         = concat ( map ( ++ " ") (tail first))+                row         = read (sec!!0)::Int+                col         = read (sec!!1)::Int+            AbstractIO.putStrLn "refacAddCon"       +            (s, col', row', inf) <- doFileStuff fileName row col ans    +            modInfo2@(inscps', exps', mod', tokList') <- parseSourceFile (fileName ++ ".temp")+            -- Find the datatype that's been highlighted as the refactree+            let res = locToPN (fileName ++ ".temp") (row, col) mod'+            +            if res == defaultPN+              then do s <- AbstractIO.readFile (fileName ++ ".temp")+                      AbstractIO.writeFile fileName s+                      AbstractIO.removeFile (fileName ++ ".temp")+                      error "You must select the beginning of a constructor"+              else do   +                let decs = hsDecls mod'               +                let datDec = definingDecls [res] decs False True             +                -- get the list of constructors from the data type+                let datDec' = head datDec+                let datName = getDataName [datDec']+                let pnames = definedPNs datDec'+                -- ==================             +                let newPN = locToPN (fileName ++ ".temp") (row', col') mod'+                let newPNT = locToPNT (fileName ++ ".temp") (row', col') mod'+                -- ==================+                numParam <- getParams datDec' newPNT+                let oldPnames = filter (/= newPN) pnames+                let position = findPos 0 newPN pnames            +              --  newMod <- removeFromInts mod'+                +                                     +                ((_,m), (newToks, newMod)) <- applyRefac (addCon pnames newPN newPNT numParam oldPnames position inf datName (tail first)) (Just (inscps', exps', mod', tokList')) (fileName ++ ".temp")+ +                writeRefactoredFiles False [((fileName, m), (newToks, newMod))]              +                AbstractIO.removeFile (fileName ++ ".temp")                         +                AbstractIO.putStrLn "Completed.\n"      +         else do+            error "refacAddCon must take a new constructor and a list of arguments."++findPos _ _ [] = 0+findPos count newPn (x:xs)+ | newPn == x = count + | otherwise  = findPos (count + 1) newPn xs++getBeforePN _ _ [] = 0            +getBeforePN c newPN (x:xs)+  | newPN /= x = (c + 1) + (getBeforePN (c + 1)newPN xs)+  | otherwise = c      +            ++createFun name (x:xs) newPN+ = TiDecorate.Dec ( HsPatBind loc0 (pNtoPat funPName) (HsBody (nameToExp ("error \"added " ++ (concat (map ( ++ " ") (x:xs))) ++ " to " ++ name ++ " \"") )) (Decs [] ([],[])) )+     where funPName= PN (UnQual ("added" ++ x)) (S loc0)++            +getParams (TiDecorate.Dec (HsDataDecl _ _ _ cons _)) newPNT+ = numParam cons+     where+      -- numParam :: (MonadPlus m) => [HsConDeclP] -> m Int+       numParam [] = return 0+       numParam (x@(HsConDecl _ _ _ pnt list):cs)+        | newPNT == pnt = do list' <- countCon x+                             return $ length list'+        | otherwise = do x <- numParam cs+                         return x+       numParam (x@(HsRecDecl _ _ _ pnt list):cs)+        | newPNT == pnt = do list' <- countCon' x+                             return $ length list'+        | otherwise = do x <- numParam cs+                         return x++       numParam _ = return 0+       +countCon :: (MonadPlus m, Term t) => t -> m [Int]  +countCon co+ = applyTU (full_tdTU (constTU [] `adhocTU` inCon)) co+    where+ --     inCon :: (Monad m) =>  HsTypeP -> m [Int]+      inCon a@(HsTyCon _::TI PNT (HsTypeI PNT)) = return [0]+      inCon _ = return []++countCon' :: (MonadPlus m, Term t) => t -> m [Int]+countCon' co+ = applyTU (full_tdTU (constTU [] `adhocTU` inCon)) co+    where+      inCon a@((x, _)::([PNT], HsBangType (HsTypeI PNT))) = return $ replicate (length x) 0+      inCon _ = return []      +       +addCon pnames newPn newPNT numParam oldPnames  position inf datName xs (inscps, exps, mod)+ = do+      newMod <- addDecl mod Nothing ([createFun datName xs newPn], Nothing) True+      res <- findFuncs newMod pnames newPn newPNT numParam oldPnames position datName inf xs+      +      return res +          ++ +findPosBefore newPN [] = []+findPosBefore newPN (x:[]) = [x]+findPosBefore newPN (x:y:ys)+ | newPN == y = [x]+ | otherwise  = findPosBefore newPN (y:ys)+ +            +findFuncs t pnames newPn newPNT numParam oldPnames position datName inf (x:xs)+  = applyTP (stop_tdTP ( failTP `adhocTP` inFun)) t+     where+      inFun dec1 +        = do+            (pat, exp1) <- findCase dec1+            -- error $ show dec1    +            if pat /= False+             then do +                    let altPNs = getPNPats exp1+                    if oldPnames /= altPNs+                     then do+                      let posBefore = findPosBefore newPn pnames+                      update exp1 (newPat3 exp1 (head posBefore)) dec1+                --    update exp1 (newPat exp1) exp1    +                     else do+                      update exp1 (newPat2 exp1) dec1    +        +             else +              do match <- findFun dec1+                 if match == False +                   then do  --error "not found"+                       fail ""+                   else +                     do  let funPNs = getPNs dec1+                 --      error $ show funPNs+                         if oldPnames /= funPNs +                           then do+                            let posBefore = findPosBefore newPn pnames+                            if length posBefore > 1+                             then do+                              update dec1 (newMatch3 dec1 (head posBefore)) dec1+                             else do+                           --  error $ show posBefore+                              update dec1 (newMatch dec1) dec1+                           else do+                          -- error $ show position+                           update dec1 (newMatch2 dec1) dec1+                       where+                        newMatch (TiDecorate.Dec (HsFunBind loc1 matches@((HsMatch _ pnt _ e ds):ms))) +                          =  TiDecorate.Dec (HsFunBind loc1 (newMatches matches pnt))  +                          +                        newMatch2 (TiDecorate.Dec (HsFunBind loc1 matches@((HsMatch _ pnt _ e ds):ms) ))+                          = TiDecorate.Dec (HsFunBind loc1 (fst ++ (newMatch' pnt) ++ snd) )+                            where +                              (fst, snd) = splitAt position matches+                              +                        newMatch3 (TiDecorate.Dec (HsFunBind loc1 matches@((HsMatch _ pnt _ e ds):ms))) posBefore+                          = TiDecorate.Dec (HsFunBind loc1 (newMatches' matches pnt posBefore))+                                       +                                                                         +                        newMatches [] pnt = newMatch' pnt   +                        newMatches (m@(HsMatch _ _ pats _ _):ms) pnt+                         | or (map wildOrID pats) = (newMatch' pnt) ++ (m : ms)+                         | otherwise                     = m : (newMatches ms pnt)++                        newMatches' [] pnt posBefore = newMatch' pnt+                        newMatches' (m@(HsMatch _ _ pats _ _):ms) pnt posBefore+                         | (getPN pats) == posBefore = m : ((newMatch' pnt) ++ ms)+                         | or (map wildOrID pats) = (newMatch' pnt) ++ (m : ms)+      --                   | (TiDecorate.Pat HsPWildCard) `elem` pats = (newMatch' pnt) ++ (m : ms)+                         | otherwise      = m : (newMatches' ms pnt posBefore)                                       +                                       +                        newMatch' pnt +                         | numParam == 0  =  [HsMatch loc0 pnt [pNtoPat newPn] (HsBody (nameToExp ("added" ++ x))) (Decs [] ([], []))]  +                         | otherwise = [HsMatch loc0 pnt [patt] (HsBody (nameToExp ("added" ++ x))) (Decs [] ([], []))]+                                        where+                                         patt +                                          | inf == False = (TiDecorate.Pat (HsPParen (TiDecorate.Pat (HsPApp newPNT (createNames numParam ['a'..'z']))))::HsPatP)+                                          | otherwise    = (TiDecorate.Pat (HsPInfixApp (nameToPat "a") newPNT (nameToPat "b"))::HsPatP)+                                         createNames 0 _ = []+                                         createNames count (x:xs)+                                          = (nameToPat [x]) : (createNames (count-1) xs)+                                          +                        newPat (TiDecorate.Exp (HsCase e pats@((HsAlt loc p e2 ds):ps)))+                          = TiDecorate.Exp (HsCase e (newPats pats))+                     +                        newPat2 (TiDecorate.Exp (HsCase e pats))+                          = TiDecorate.Exp (HsCase e (fst ++ newPat' ++ snd))+                             where+                              (fst, snd) = splitAt position pats+                                       + +                        newPat3 (TiDecorate.Exp (HsCase e pats)) posBefore+                          = TiDecorate.Exp (HsCase e (newPats' pats posBefore))+                     +                        newPats [] = newPat'+                        newPats(pa@(HsAlt _ p _ _):ps)+                         | wildOrID p = newPat' ++ (pa:ps)+                         | otherwise              = pa : (newPats ps)+                     +                        newPats' [] posBefore = newPat'+                        newPats' (pa@(HsAlt _ p _ _):ps) posBefore+                         | (getPN p) == posBefore = pa : (newPat' ++ ps)+                         | wildOrID p = newPat' ++ (pa:ps)+                         | otherwise = pa : (newPats' ps posBefore)++                     +                        newPat' +                         | numParam == 0 = [HsAlt loc0 (pNtoPat newPn) (HsBody (nameToExp ("added" ++ x))) (Decs [] ([], []))]+                         | otherwise = [HsAlt loc0 patt (HsBody (nameToExp ("added" ++ x))) (Decs [] ([], []))]+                            where+                             patt +                              | inf == False = (TiDecorate.Pat (HsPParen (TiDecorate.Pat (HsPApp newPNT  (createNames numParam ['a'..'z']))))::HsPatP)+                              | otherwise    = (TiDecorate.Pat (HsPInfixApp (nameToPat "a") newPNT (nameToPat "b"))::HsPatP)++                             createNames 0 _ = []+                             createNames count (x:xs)+                               = (nameToPat [x]) : (createNames (count-1) xs)++      --The selected sub-expression is in the argument list of a match+      --and the function only takes 1 parameter+      findFun dec@(TiDecorate.Dec (HsFunBind loc matches)::HsDeclP)+        =  return $ findMatch matches+           where findMatch match +                   = fromMaybe (False)+                      (applyTU (once_tdTU (failTU `adhocTU` inMatch)) match)+                 inMatch (mat@(HsMatch loc1  pnt pats (HsBody e) ds)::HsMatchP)+                  = Just (checkTypes datName [mat])+                 inMatch x@(_) = Nothing++      findFun a@(_) = return False+   +      findCase dec@(TiDecorate.Dec (HsFunBind loc matches)::HsDeclP)+        = return $ findExp matches+           where findExp alt+                  = fromMaybe ((False, defaultExp))+                     (applyTU (once_tdTU (failTU `adhocTU` inExp)) alt)+                 inExp (exp@(TiDecorate.Exp e)::HsExpP)+                  = Just ((findPat e), exp)  +                 inExp _ = Nothing                       +                 findPat alt+                  = fromMaybe (False)+                     (applyTU (once_tdTU (failTU `adhocTU` inPat)) alt)+                 inPat (pat@(HsAlt loc p e ds)::HsAltP)+                  = Just (checkTypes datName [pat])+                 inPat _ = Nothing              +      findCase pat@(_) =  return (False, defaultExp)+                           +wildOrID (TiDecorate.Pat HsPWildCard) = True+wildOrID (TiDecorate.TiPSpec _ _ _ )    = True+wildOrID _ = False+++doFileStuff fileName r c a = do+    s <- AbstractIO.readFile fileName+    +    -- get the first half of the file (up to point user has selected)+    let rev = reverse (returnHalf r c (1,1) s)++    let rest = returnSndHalf r c (1,1) s+    +    let str = parseIt rest a++    let str' = parseIt' rest a       +   +    let len = length (myDiff s str')    +    +    let (st, fin) = splitAt len s++    let new = st ++ str ++ fin   +    +    let extraCol = parseTick 0 str+    +    let (col, row) = getRowCol r c (1,1) st+                                +    AbstractIO.catch (AbstractIO.writeFile (fileName ++ ".temp") new)+                      (\_ -> do AbstractIO.removeFile (fileName ++ ".temp")+                                AbstractIO.writeFile (fileName ++ ".temp") new)+  --  AbstractIO.writeFile fileName new+    +    if '`' `elem` a +      then do return (new, col + extraCol, row, True)+      else do return (new, col + extraCol, row, False)+ +-- function to parse to see if user is placing contructor at the beginning or end of statement...   +-- if the user has selected a ' ' or a character+-- parse forwards (which is really backwards) until a '|' or a '=' character is found+parseTick _ [] = 3+parseTick count (x:xs)+ | x == '`' = count + 1+ | otherwise = parseTick (count+1) xs++++myDiff :: String -> String -> String+myDiff [] _ = []+myDiff (y:ys) (x:xs) + | (y:ys) == (x:xs) = ""+ | otherwise = y : (myDiff ys (x:xs))++ +parseIt :: String -> String -> String+parseIt "" str = error "Please select a position on the right hand side of the data type."+parseIt (x:xs) str + | x == '\n' || x == '|' = " | " ++ str ++ " "+ | x /= '\n' || x /= '|' = parseIt xs str+ | otherwise            = " | " ++ str ++ " "++ +parseIt' :: String -> String -> String+parseIt' "" str = ""+parseIt' (x:xs) str+ | x == '\n' || x == '|' = (x:xs)+ | x /= '\n' || x /= '|' = parseIt' xs str+ | otherwise             = (x:xs)++                                 +-- perform some primitve parsing. We need to check where abouts the user wants+-- to add the data structure: +-- a) if the it is at the beginning - we need to check that the+--    use has selected at the end of a "=" sign -- if this is the case append "|" to the end+--    of the user string;+-- b) if a "=" does not proceed the position - append a "|" to the end+--+-- we do not need to check for any other cases as Programatica will pick up the errors+-- (if the position of adding the constructor is invalid, for example.)++-- function to return the half of the file that comes before the user position+returnHalf r c (col, row) "" = ""+returnHalf r c (col, row) (x:xs) +  | x == '\n' = if (r == row) && (c == col)   then [x]+                                              else x : (returnHalf r c (1, row+1) xs)+  | otherwise = if c == col && (r == row)     then [x]+                                              else x : (returnHalf r c (col+1, row) xs)+                                              +returnSndHalf r c (col, row) "" = ""+returnSndHalf r c (col, row) (x:xs) +  | x == '\n' = if (r == row) && (c == col)   then xs+                                              else (returnSndHalf r c (1, row+1) xs)+  | otherwise = if c == col && (r == row)     then xs+                                              else (returnSndHalf r c (col+1, row) xs)                                       +                                           +getRowCol r c (col, row) "" = (col, row)+getRowCol r c (col, row) (x:xs) + | x == '\n' = getRowCol r c (1, row+1) xs+ | otherwise = getRowCol r c (col+1, row) xs++++                    +
+ refactorer/RefacTypeSig.hs view
@@ -0,0 +1,222 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacTypeSig+-- Copyright   :  (c) Christopher Brown 2006+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- Add type signatures for top-level function definitions++-----------------------------------------------------------------------------++module RefacTypeSig where+ +import PrettyPrint+import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils+import PFE0 (findFile)+import MUtils (( # ))+import RefacLocUtils+import System+import IO++refacTypeSig args+  = do let fileName   = args!!0++       AbstractIO.putStrLn "refacTypeSig"+       modName1 <- fileNameToModName fileName ++       let modName = convertModName modName1++       -- Parse the input file.+       (inscps, exps, mod, tokList) <- parseSourceFile fileName+       +       let newRefactoredDecls = hsDecls mod+       sigs <- mapM (getSig fileName modName) (filter (/="") (map declToName newRefactoredDecls))++       res <- applyRefac (addTypes (dropWhile (\x -> x == defaultPN) (map (declToPName (map declToName newRefactoredDecls)) newRefactoredDecls)) sigs) (Just (inscps, exps, mod, tokList)) fileName+       -- ((_,m), (newToks, newMod)) <- applyRefac (addType ses modName ) (Just (inscps, exps, mod, tokList)) fileName+           +           +    --   res <- findDefsWithType ses mod+       +    --   AbstractIO.putStrLn $ show res    +        +       writeRefactoredFiles True [res]+       +       (inscps5, exps5, mod5, tokList5) <- parseSourceFile fileName++              +       (mod',((tokList'',modified),_))<-(doCommenting (dropWhile (\x -> x == defaultPN) (map (declToPName (map declToName newRefactoredDecls)) newRefactoredDecls))) fileName mod5 tokList5+              +              +       writeRefactoredFiles True [((fileName, True), (tokList'', mod'))]+           +       AbstractIO.putStrLn "Completed."+++doCommenting (x:xs) fileName mod tokList +    =  runStateT (applyTP ((once_tdTP (failTP `adhocTP` (rmInMod (x:xs) )+                                              ))) mod)+                                                         ((tokList,unmodified),fileName)+                       +           where          +             --1. The definition to be removed is one of the module's top level declarations.+             rmInMod [] mod = return mod+             rmInMod (p:ps) (mod@(HsModule loc name exps imps ds):: HsModuleP)  +                = do ds'<-commentOutTypeSig p ds+                     res2 <- rmInMod ps (HsModule loc name exps imps ds')+                     return res2++addTypes [] _ (_,_,mod) = return mod+addTypes _ [] (_,_,mod) = return mod+addTypes (x:xs) (y:ys) (a,b,mod) = do++                                      mod' <- addTypeSigDecl mod (Just x) ([y], Nothing) True +                                      +                                      -- commentOutTypeSig x (y:ys)                                   +                                      res <- addTypes xs ys (a,b,mod')+                                      return mod'+++{- declToName :: HsDeclP -> String+declToName (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))  + = pNTtoName pnt+declToName (Dec (HsPatBind _ pnt _ _)) = pNTtoName (patToPNT pnt)+declToName _ = "" -}++{- declToPName ::  [ String  ] -> HsDeclP -> PName+declToPName [] _ = defaultPN+declToPName (name: names) d@(Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs))) + | name == pNTtoName pnt = pNTtoPN pnt+ | otherwise = declToPName  names d+declToPName (name:names) d@(Dec (HsPatBind _ pnt _ _))  -- = pNTtoPN (patToPNT pnt)+ | name == pNTtoName (patToPNT pnt) = pNTtoPN (patToPNT pnt)+ | otherwise = declToPName  names d+declToPName _ _ = defaultPN++-}       +addType ses modName (inscps, exps, mod)+  = do+       res <- findDefsWithType ses mod modName+       return res++convertModName (PlainModule s) = s+convertModName m@(MainModule f) = modNameToStr m        +       +findDefsWithType ses t modName+  = applyTP (stop_tdTP (failTP `adhocTP` inMatch)) t+      where+       inMatch (mat@(Dec (HsFunBind _ ((HsMatch loc1  pnt pats (HsBody e) ds):xs)))::HsDeclP)+         = do+              res3 <- findType pnt t +              if res3 == [True]+                then do+                       addTypeSigDecl t Nothing ([], Nothing) True++                else do+                        -- create a type signature!+                        res <- getSig  ses modName (pNTtoName pnt)+                        +                        -- addTypeDecl  mat (Just (pNTtoPN pnt))  ([res], Nothing) True+                        +                        addTypeSigDecl t (Just (declToPName [declToName mat] mat)) ([res], Nothing) True+                        --    return [res2]+                       --     inMatch _ = fail "" +       inMatch (dec@(Dec (HsPatBind _ pnt _ _))::HsDeclP)+         = do+              res3 <- findType (patToPNT pnt) t+              if res3 == [True]+                then+                  return dec+                else do+                  -- create a type signature!+                  res <- getSig  ses modName (pNTtoName (patToPNT pnt))+                        +                  -- addTypeDecl dec (Just (pNTtoPN (patToPNT pnt))) ([res], Nothing) True+                  addTypeSigDecl dec (Just (declToPName [declToName dec] dec)) ([res], Nothing) True++                  +                 --   return [res2]+       inMatch _ = fail ""+{- getSig ses modName name + = do+      let types = getTypes name ses modName+      -- error $ show types+      let types1 = cleanTypes (tail types)++      let (context, l) = getContext (head types)+      let types2 = l : types1+   --   let context2 = init context+      let types3 = map (filter (/= '\n')) types2+      let newSig = createTypeSig name context types3+     -- error $ show newSig+      +      return newSig       +getSig name ses modName+ = do+      let types = getTypes name ses modName+      let types1 = cleanTypes (tail types) -- modName++      let (context, l) = getContext (head types) -- modName+      let types2 = l : types1+   --   let context2 = init context+      let newSig = createTypeSig name context types2+     -- error $ show newSig+      +      return newSig -}+++ +--createTypeSig :: String -> [String] -> [String] -> HsDeclP+createTypeSig name [] types + = Dec (HsTypeSig loc0 [nameToPNT name] [] (createApplication types)) +createTypeSig name context types  + = Dec (HsTypeSig loc0 [nameToPNT name] [(Typ (HsTyVar (nameToPNT context)))] (createApplication types)) + + -- (Typ (HsTyVar (nameToTypePNT (head types))) ) )+ ++nameToTypePNT :: String -> PNT +nameToTypePNT id = (PNT (PN (UnQual id) (S loc0)) (Type (TypeInfo {defType = Nothing, constructors = [], fields = []})) (N (Just loc0)))+++createApplication [var]+ = (Typ (HsTyVar (nameToTypePNT var)))+createApplication (var:vars)+ = createApplication' (Typ (HsTyVar (nameToTypePNT var))) vars+ +createApplication' x [y]+  = (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y)))))+createApplication' x (y:ys)+  = (createApplication' (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y))))) ys)+       +findType pnt t+  = applyTU (stop_tdTU (failTU `adhocTU` inSig)) t+      where+        inSig (dec@(Dec (HsTypeSig _ _ _ _))::HsDeclP)+          = do+               let res = definesTypeSig (pNTtoPN pnt) dec+               if res == True+                  then return [True]+                  else fail ""+          +        inSig _ = fail ""+              ++       +       +       ++
+ refactorer/RefacTypeSyn.hs view
@@ -0,0 +1,40 @@++module RefacTypeSyn where++--Modules from Programatic: +import PosSyntax+import ScopeModule+import HsName hiding (ModuleName)+import PNT+import Ents+import PosName +import Relations+import Names++data NameSpace = ValueName | ClassName | TypeCon | DataCon | Other  deriving (Eq, Show)++type HsDeclP   =HsDeclI PNT+type HsPatP    =HsPatI PNT+type HsExpP    =HsExpI PNT +type HsMatchP  =HsMatchI PNT (HsExpP) (HsPatP) [HsDeclP]+-- type HsModuleP =HsModuleI (SN HsName.HsName) [HsDeclI PNT]  +type HsModuleP =HsModuleI ModuleName PNT [HsDeclI PNT]  +type HsImportDeclP=HsImportDeclI ModuleName PNT -- (SN HsName.HsName)+type HsExportEntP = HsExportSpecI ModuleName PNT+type RhsP      =HsRhs HsExpP +type GuardP    =(SrcLoc, HsExpP, HsExpP)+type HsAltP    =HsAlt HsExpP HsPatP [HsDeclP]+--type HsConDeclP=HsConDeclI PNT (HsTypeI PNT)+type HsStmtP   =HsStmt HsExpP HsPatP [HsDeclP]+type HsStmtAtomP = HsStmtAtom HsExpP HsPatP [HsDeclP]+type HsFieldP  =HsFieldI PNT HsExpP+type HsTypeP   = HsTypeI PNT +type EntSpecP  = EntSpec PNT+type HsConDeclP = HsConDeclI PNT HsTypeP [HsTypeP]+type HsConDeclP' = HsConDeclI PNT (TI PNT HsTypeP) [TI PNT HsTypeP]+type ENT =Ents.Ent PosName.Id+type InScopes=((Relations.Rel Names.QName (Ents.Ent PosName.Id)))++type Exports =[(PosName.Id, Ent PosName.Id)]++type SimpPos = (Int,Int) 
+ refactorer/RefacTypeUtils.hs view
@@ -0,0 +1,3043 @@++----------------------------------------------------------------------------------------------------------------+-- Module      : RefacTypeUtils++-- Maintainer  : refactor-fp\@kent.ac.uk  +-- |+--+-- This module contains a collection of program analysis and transformation functions (the API) that work+-- over the Type Decorated AST. Most of the functions defined in the module are taken directly from the API,+-- but in some cases are modified to work with the type decorated AST.+--+-- In particular some new functions have been added to make type decorated AST traversals easier.+--+-- In HaRe, in order to preserve the+-- comments and layout of refactored programs, a refactoring modifies not only the AST but also the token stream, and+-- the program source after the refactoring is extracted from the token stream rather than the AST, for the comments+-- and layout information is kept in the token steam instead of the AST. As a consequence, a program transformation+-- function from this API modifies both the AST and the token stream (unless explicitly stated). So when you build +-- your own program transformations, try to use the API to do the transformation, as this can liberate you from +-- caring about the token stream.+--+-- As the API is based on Programatica's abstract syntax for Haskell, we have re-exported those related module from+-- Programatica, so that you can browse the datatypes for the abstract syntax. Alternatively, you can go to +-- Programatica's webpage at: <http://www.cse.ogi.edu/~hallgren/Programatica/>. For Strafunski, you can find it +-- at: <http://www.cs.vu.nl/Strafunski/>.+--  +-- This type decorated API is still in development. Any suggestions and comments are very much welcome.+++------------------------------------------------------------------------------------------------------------------++module RefacTypeUtils(module DriftStructUtils, module StrategyLib, module RefacTITypeSyn, module PosSyntax,+                  module SourceNames, module UniqueNames, module PNT, +                  module Ents, module Relations, module QualNames, module TypedIds + -- * Program Analysis +    -- ** Imports and exports+   ,inScopeInfo, isInScopeAndUnqualified, hsQualifier, {-This function should be removed-} rmPrelude +   ,exportInfo, isExported, isExplicitlyExported, modIsExported++    -- ** Variable analysis+    ,hsPNs,hsPNTs,hsDataConstrs,hsTypeConstrsAndClasses, hsTypeVbls+    ,hsClassMembers, HsDecls(hsDecls,isDeclaredIn, replaceDecls)+    ,hsFreeAndDeclaredPNs,hsFreeAndDeclaredNames+    ,hsVisiblePNs, hsVisibleNames+    ,hsFDsFromInside, hsFDNamesFromInside ++    -- ** Property checking+    ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isTopLevelPNT+    ,isQualifiedPN,isFunPNT, isFunName, isPatName, isFunOrPatName,isTypeCon,isTypeSig,isFunBind,isPatBind,isSimplePatBind+    ,isComplexPatBind,isFunOrPatBind,isClassDecl,isInstDecl,isDirectRecursiveDef+    ,usedWithoutQual,canBeQualified, hasFreeVars,isUsedInRhs+    ,findPNT,findPN      -- Try to remove this.+    ,findPNs, findEntity+    ,sameOccurrence   +    ,defines,definesTypeSig, isTypeSigOf+    ,HasModName(hasModName), HasNameSpace(hasNameSpace)  +   +    +    -- ** Modules and files+    ,clientModsAndFiles,serverModsAndFiles,isAnExistingMod+    ,fileNameToModName, strToModName, modNameToStr++    -- ** Locations+    ,defineLoc, useLoc,locToPNT,locToPN,locToExp, getStartEndLoc  ++ -- * Program transformation +    -- ** Adding+    ,addDecl ,addItemsToImport, addHiding, rmItemsFromImport, addItemsToExport+    ,addParamsToDecls, addGuardsToRhs, addImportDecl, duplicateDecl, moveDecl+    -- ** Rmoving+    ,rmDecl, rmTypeSig, commentOutTypeSig, rmParams+    ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete)+    -- ** Updating+    ,Update(update)+    ,qualifyPName,rmQualifier,renamePN,replaceNameInPN,autoRenameLocalVar++-- * Miscellous+    -- ** Parsing, writing and showing+   ,parseSourceFile,writeRefactoredFiles, showEntities ,showPNwithLoc, newProj, addFile, chase+    -- ** Locations+   ,toRelativeLocs, rmLocs+    -- ** Default values+   ,defaultPN,defaultPNT,defaultModName,defaultExp,defaultPat, defaultExpUnTyped+  +    -- ** Identifiers, expressions, patterns and declarations+    ,pNTtoPN,pNTtoName,pNtoName,nameToPNT, nameToPN,pNtoPNT+    ,expToPNT, expToPN, nameToExp,pNtoExp,patToPNT, patToPN, nameToPat,pNtoPat+    ,definingDecls, definedPNs+    ,simplifyDecl+    -- ** Others+   ,mkNewName, applyRefac, applyRefacToClientMods+                   +    -- The following functions are not in the the API yet.+    ,getDeclToks, causeNameClashInExports, inRegion , ghead, glast, gfromJust, unmodified, prettyprint,+    getDeclAndToks++-- * Typed AST traversals (added by CMB)+    -- * Miscellous+    ,removeFromInts, getDataName, checkTypes, getPNs, getPN, getPNPats, mapASTOverTAST+ )+where+import Prelude hiding (putStr,putStrLn,writeFile,readFile)+import Maybe+import List hiding (delete)+import Char+--------------------------------+import PfeChase+import PFE0 +import PFE2+import PFE3(parseModule,parseModule', parseSourceFile')+import PFE4+import PosSyntax hiding (ModuleName, HsName, SN)+import SourceNames ++import ScopeModule+import UniqueNames hiding (srcLoc)+import HsName+import HsLexerPass1+import AbstractIO +import PNT +import TiPNT+import SimpleGraphs(reverseGraph,reachable)+import Ents hiding (isValue)+import Relations+import QualNames+import TypedIds hiding (NameSpace, HasNameSpace)+import WorkModule+import TiDecorate+import TI hiding (TI)++import Pfe4Cmds++import PrettyPrint+import Unlit(readHaskellFile,writeHaskellFile)+import MUtils hiding (swap)+import EditorCommands(sendEditorModified)+import qualified MT(lift)+import HsTokens+-------------------------+import RefacTITypeSyn+import RefacTypeLocUtils+-------------------------+import StrategyLib hiding (findFile)++#if __GLASGOW_HASKELL__ <604 ++instance (Monoid a, Monoid b) => Monoid (a,b) where+   mappend (a,b) (a',b') = (mappend a a', mappend b b')+   mempty                = (mempty, mempty)+#endif+++------------------------------------------------------------------------------------------++{- | The Delete class. -}+class (Term t, Term t1)=>Delete t t1 where+   +  -- | Delete the occurrence of a syntax phrase in a given context.+  delete::(MonadPlus m, MonadState (([PosToken],Bool),t2) m)=> t   -- ^ The syntax phrase to delete.+                                                          ->t1     -- ^ The contex where the syntax phrase occurs.+                                                          ->m t1   -- ^ The result.++-- An expression can only be deleted in certain circumstances.+instance (Term t) => Delete HsExpP t where+  delete e t +    = applyTP (once_tdTP (failTP `adhocTP` inExp)`choiceTP` failure) t   +     where+     {-  inExp ((Exp (HsApp e1 e2))::HsExpP)+        |  sameOccurrence e e1 +        = do deleteFromToks e1+             return e2 -}+       inExp (TiDecorate.Exp (HsApp e1 e2)::HsExpP)+        | sameOccurrence e e2 +        = do deleteFromToks e2 getStartEndLoc+             return e1+       inExp (TiDecorate.Exp (HsList es))+         |isJust $ find (\x->sameOccurrence e x) es+        = do ((toks,_),others)<-get +             let toks'=deleteEnt toks $ getStartEndLoc toks e+             put ((toks',modified),others)+             return (TiDecorate.Exp (HsList (es \\[e])))+       inExp _ = mzero+  +       sameOccurrence t1 t2+        = rmParen t1== rmParen t2 && srcLocs t1 == srcLocs t2    ++       rmParen (TiDecorate.Exp (HsParen e)) = rmParen e+       rmParen e = e        ++       failure = error "Delete: This expression can not be deleted!"+instance (Term t) => Delete HsPatP t where+   +  delete p t+    = applyTP (once_tdTP (failTP `adhocTP` inPats)) t+    where+      inPats (ps::[HsPatP])+        |isJust $ find(\x->sameOccurrence p x) ps+        = do deleteFromToks p  getStartEndLoc+             return (ps\\[p])+      inPats _ = mzero++instance (Term t) => Delete HsImportDeclP t where+  delete imp t +   = applyTP (once_tdTP (failTP `adhocTP` inImps)) t+   where +     inImps (imps::[HsImportDeclP])+       | isJust $ find (\x->sameOccurrence imp x) imps+       = do deleteFromToks imp startEndLocIncFowNewLn+            return (imps \\ [imp])+     inImps _ = mzero+++{- | The Update class, -}+class (Term t, Term t1)=>Update t t1 where++  -- | Update the occurrence of one syntax phrase in a given scope by another syntax phrase of the same type.+  update::(MonadPlus m, MonadState (([PosToken],Bool),(Int,Int)) m)=>  t     -- ^ The syntax phrase to be updated.+                                                             -> t     -- ^ The new syntax phrase.+                                                             -> t1    -- ^ The contex where the old syntex phrase occurs.+                                                             -> m t1  -- ^ The result.+ +instance (Term t) =>Update HsExpP t where++ update oldExp newExp  t+   = applyTP (once_tdTP (failTP `adhocTP` inExp)) t+   where +    inExp (e::HsExpP)+     | e == oldExp && srcLocs e == srcLocs oldExp +       = do (newExp', _) <-updateToks oldExp newExp prettyprint+            return newExp'+    inExp e = mzero++instance (Term t) =>Update PNT t where+  update oldExp newExp  t+   = applyTP (once_tdTP (failTP `adhocTP` inExp)) t+   where +    inExp (e::PNT)+     | e == oldExp && srcLocs e == srcLocs oldExp +       = do (newExp',_) <- updateToks oldExp newExp prettyprint+            return newExp'+    inExp e = mzero++instance (Term t) =>Update HsMatchP t where+  update oldExp newExp  t+   = applyTP (once_tdTP (failTP `adhocTP` inExp)) t+   where +    inExp (e::HsMatchP)+     | e == oldExp && srcLocs e == srcLocs oldExp +       = do (newExp',_) <- updateToks oldExp newExp prettyprint+            return newExp'+    inExp e = mzero+    +instance (Term t) =>Update HsPatP t where++ update oldPat newPat  t+   = applyTP (once_tdTP (failTP `adhocTP` inPat)) t+   where +    inPat (p::HsPatP)+     | p == oldPat && srcLocs p == srcLocs oldPat +       = do (newPat', _) <- updateToks [oldPat] [newPat] (prettyprintPatList False)+            return $ ghead "update" newPat'+    inPat e = mzero++instance (Term t) =>Update [HsPatP] t where++ update oldPat newPat  t+   = applyTP (once_tdTP (failTP `adhocTP` inPat)) t+   where +    inPat (p::[HsPatP])+     | sameOccurrence p oldPat +       = do  (newPat', _) <- updateToks oldPat newPat (prettyprintPatList False)+             return newPat'+    inPat e = mzero++instance (Term t) =>Update HsDeclsP t where++ update oldDecl@(Decs x y) newDecl@(Decs x2 y2)  t+   = applyTP (once_tdTP (failTP `adhocTP` inDecl)) t+   where +    inDecl (d::HsDeclsP)+     | sameOccurrence d oldDecl +       = do+            (newDecl', _) <- updateToks oldDecl newDecl prettyprint+            return newDecl'+    inDecl e = mzero++instance (Term t) =>Update [HsDeclP] t where++ update oldDecl newDecl  t+   = applyTP (once_tdTP (failTP `adhocTP` inDecl)) t+   where +    inDecl (d::[HsDeclP])+     | sameOccurrence d oldDecl +       = do+            (newDecl',_) <- updateToks oldDecl newDecl prettyprint+            return newDecl'+    inDecl e = mzero ++instance (Term t) =>Update HsDeclP t where++ update oldDecl newDecl  t+   = applyTP (once_tdTP (failTP `adhocTP` inDecl)) t+   where +    inDecl (d::HsDeclP)+     | sameOccurrence d oldDecl+       = do (newDecl',_) <- updateToks oldDecl newDecl prettyprint+            return newDecl'+    inDecl e = mzero++instance (Term t) =>Update HsImportDeclP t where++ update oldImpDecl newImpDecl  t+   = applyTP (once_tdTP (failTP `adhocTP` inDecl)) t+   where +    inDecl (d::HsImportDeclP)+     | sameOccurrence d oldImpDecl +       =do (newImpDecl', _) <-updateToks oldImpDecl newImpDecl prettyprint+           return newImpDecl'+    inDecl e = mzero++instance (Term t) => Update HsExportEntP t where+   update oldEnt@(EntE s) newEnt@(EntE s1) t+     = applyTP (once_tdTP (failTP `adhocTP` inEnt)) t+       where+         inEnt (e::HsExportEntP)+           | sameOccurrence e oldEnt+          =  do (s1',_) <- updateToks s s1 prettyprint+                return (EntE s1')+         inEnt e = mzero++instance (Term t) => Update HsTypeP t where+ update oldType newType t+   = applyTP (once_tdTP (failTP `adhocTP` inType)) t +   where+     inType (t::HsTypeP)+        | sameOccurrence t oldType+       = do (newType', _) <- updateToks oldType newType prettyprint+            return newType'+     inType t = mzero++{- ++{- | The Swap Class. The instances may be not complete, tell us what you need so that we can add it.-}+class (Term t, Term t1 ) => Swap t t1 where++  -- | Swap the occurrences of two syntax phrases( of the same type) in a given scope.+  swap :: (MonadState (([PosToken],Bool),t2) m)=> t   -- ^ The first syntax phrase.+                                               -> t   -- ^ The second syntax phrase.+                                               ->t1   -- ^ The context where the two syntax phrases occur.+                                               ->m t1 -- ^ The result.++instance (Term t)=>Swap HsExpP t  where +  swap e1 e2  t+    = do  swapInToks e1 e2+          applyTP (full_tdTP (idTP `adhocTP` inExp)) t       -- both full_td and full_bu should wor                       +    where +      inExp (e ::HsExpP)+       | sameOccurrence e e1                                  +         = return  e2                          +      inExp (e::HsExpP)+       | e == e2 && srcLocs e == srcLocs e2+         = return e1+      inExp x = return x++instance (Term t) => Swap HsPatP t where+  swap p1 p2 t +   = do swapInToks p1 p2 +        applyTP (full_tdTP (idTP `adhocTP` inPat)) t +    where+      inPat (p::HsPatP)+       | sameOccurrence p p1                                  +        = return  p2       +      inPat (p::HsPatP)+       | sameOccurrence p p2+         = return p1+      inPat x = return x++instance (Term t) => Swap HsTypeP t where+   swap t1 t2 t +     = do swapInToks t1 t2+          applyTP (full_tdTP (idTP `adhocTP` inType)) t+     where+       inType (t::HsTypeP)+        | sameOccurrence t t1+          = return t2+       inType (t::HsTypeP)+        | sameOccurrence t t2+         = return t1+       inType t = return t +-}++class (DeclStartLoc t) =>CanHaveWhereClause t where++ canHaveWhereClause:: t-> Bool++instance CanHaveWhereClause HsMatchP where+ + canHaveWhereClause t = True++instance CanHaveWhereClause HsDeclP where+ canHaveWhereClause t = isPatBind t ++instance CanHaveWhereClause HsAltP where+  canHaveWhereClause t = True++{-+instance CanHaveWhereClause HsModuleP where+  canHaveWhereClause t = True+-}++instance CanHaveWhereClause HsExpP where+  canHaveWhereClause t = False++instance CanHaveWhereClause HsStmtP where+  canHaveWhereClause t = False++  +class (StartEndLoc t) =>DeclStartLoc  t where+  +  -- | Given a syntax phrase, get the start location of enclosed top-level declaration list.+  declStartLoc:: [PosToken]->t->Maybe RefacTITypeSyn.SimpPos++instance DeclStartLoc HsMatchP where+  declStartLoc toks (HsMatch loc1 name pats rhs ds@(Decs x y))+    = if x/=[] then Just $ fst (getStartEndLoc toks (ghead "declStartLoc" x))+                else Nothing +++instance DeclStartLoc HsDeclP where+  declStartLoc toks (TiDecorate.Dec (HsPatBind loc p rhs ds@(Decs x y)))+     = if x/=[] then Just$ (fst (getStartEndLoc toks (ghead "declStartLoc" x)))+                 else Nothing+  declStartLoc toks _ = Nothing++instance DeclStartLoc HsExpP where+  declStartLoc toks letExp@(TiDecorate.Exp (HsLet ds@(Decs x y) e))+    = if x/=[] then Just $ fst (getStartEndLoc toks (ghead "declStartLoc" x))+                else let (startPos,endPos)=getStartEndLoc toks letExp+                         expToks= getToks (startPos,endPos) toks +                in Just $ ((tokenPos.(ghead "declStartLoc")) $ dropWhile (not.isIn) expToks)+instance DeclStartLoc HsAltP where+ declStartLoc toks (HsAlt loc p rhs ds@(Decs x y))  +    =if x/=[] then Just $ (fst (getStartEndLoc toks (ghead "declStartLoc" x)))+               else Nothing++instance DeclStartLoc HsStmtP where+ declStartLoc toks (HsLetStmt ds@(Decs x y) stmts)+   = if x/=[] then Just $ fst (getStartEndLoc toks (ghead "declStartLoc" x))+               else Just $ fst (getStartEndLoc toks stmts)   -- Qn: Is this possible?+++-- | Return True if syntax phrases t1 and t2 refer to the same one.+sameOccurrence:: (Term t, Eq t) => t -> t -> Bool+sameOccurrence t1 t2+ = t1==t2 && srcLocs t1 == srcLocs t2++{- | The 'HasNameSpace' class. -}+class HasNameSpace t where+   hasNameSpace::t->NameSpace++instance HasNameSpace PNT where+   hasNameSpace (PNT _ Value _)           = ValueName+   hasNameSpace (PNT _ (ConstrOf _ _ ) _) = DataCon+   hasNameSpace (PNT _ (FieldOf _ _ ) _)  = ValueName+   hasNameSpace (PNT _ (MethodOf _  _ _) _)  = ValueName+   hasNameSpace (PNT _ (TypedIds.Class _  _) _)       = ClassName+   hasNameSpace (PNT _ (Type _) _ )       = TypeCon     -- It is also possible that it is a type variable.+   hasNameSpace  _                        = Other       -- We don't care about Assertion & Property so far.++instance HasNameSpace ENT  where+   hasNameSpace (Ent _ _ Value)           = ValueName+   hasNameSpace (Ent _ _ (ConstrOf _ _ )) = DataCon+   hasNameSpace (Ent _ _ (FieldOf _ _ ))  = ValueName+   hasNameSpace (Ent _ _ (MethodOf _ _ _))  = ValueName+   hasNameSpace (Ent _ _ (TypedIds.Class _  _))       = ClassName+   hasNameSpace (Ent _ _ (Type _))        = TypeCon     +   hasNameSpace  _                        = Other       ++----------------------------------------------------------------------------------------------+-- |Compose ModuleName from  String.+strToModName::String->ModuleName+strToModName name = if name =="Main" then MainModule "Main.hs"  -- THIS IS BASED ON ASSUMPTION.+                                     else PlainModule name +-- |From ModuleName to string.+modNameToStr::ModuleName->String+modNameToStr (PlainModule name) = name+modNameToStr (MainModule _)     = "Main"            +                 +-- | From file name to module name.+--fileNameToModName::( )=>String->PFE0MT n i ds ext m ModuleName      ++fileNameToModName::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+                   String->PFE0MT n i ds ext m ModuleName         +fileNameToModName fileName = +  do gf <- getCurrentModuleGraph+     let fileAndMods = [(m,f)|(f,(m,ms))<-gf]+         f = filter (\(m,f) -> f==fileName) fileAndMods+     if f ==[] then error $ "Can't find module name"+                    else return $ (fst.head) f++-- | Return the client module and file names. The client modules of module, say m, are those modules+-- which import m directly or indirectly.++-- clientModsAndFiles::( ) =>ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]+clientModsAndFiles::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+                     ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]+clientModsAndFiles m =+  do gf <- getCurrentModuleGraph+     let fileAndMods = [(m,f)|(f,(m,ms))<-gf]+         g           = (reverseGraph.(map snd)) gf     +         clientMods  = reachable g [m] \\ [m]+         clients     = concatMap (\m'->[(m,f)|(m,f)<-fileAndMods, m==m']) clientMods+     return clients++-- | Return the server module and file names. The server modules of module, say  m, are those modules+-- which are directly or indirectly imported by module m.++--serverModsAndFiles::( )=>ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]++serverModsAndFiles::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+                     ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]+serverModsAndFiles m =+   do gf <- getCurrentModuleGraph+      let fileAndMods = [(m,f)|(f,(m,ms))<-gf]+          g           = (map snd) gf  +          serverMods  = reachable g [m] \\ [m]+          servers     = concatMap (\m'->[(m,f)|(m,f)<-fileAndMods, m==m']) serverMods+      return servers++-- | Return True if the given module name exists in the project.+--isAnExistingMod::( ) =>ModuleName->PFE0MT n i ds ext m Bool+++isAnExistingMod::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+                  ModuleName->PFE0MT n i ds ext m Bool++isAnExistingMod m +  =  do ms<-allModules+        return (elem m ms)++{-Whenever an identifier is imported, the qualified name is imported, whereas the unqualified name+ may or may not be imported. -}++-- | Return all the possible qualifiers for the identifier. The identifier is not inscope if the +-- result is an empty list.+hsQualifier::PNT                   -- ^ The identifier.+            ->InScopes             -- ^ The in-scope relation.+            ->[ModuleName]         -- ^ The result.+hsQualifier pnt@(PNT pname _ _ ) inScopeRel+  = let r = filter ( \ ( name, nameSpace, modName, qual) -> pNtoName pname == name+                   && hasModName pname == Just modName && hasNameSpace pnt == nameSpace +                   && isJust qual) $ inScopeInfo inScopeRel+    in  map (\ (_,_,_,qual) -> fromJust qual ) r+                            +                    +-- |Process the inscope relation returned from the parsing and module analysis pass, and +-- return a list of four-element tuples. Each tuple contains an identifier name, the identifier's namespace+-- info, the identifier's defining module name and its qualifier name. The same identifier may have multiple+-- entries in the result because it may have different qualifiers. This makes it easier to decide whether the+-- identifier can be used unqualifiedly by just checking whether there is an entry for it with the qualifier field+-- being Nothing.+-- +inScopeInfo::InScopes                                                -- ^ The inscope relation .+           ->[(String, NameSpace, ModuleName, Maybe ModuleName)]     -- ^ The result+inScopeInfo inScopeRel =nub $  map getEntInfo $ relToList inScopeRel +  where +     getEntInfo (qual, ent@(Ent modName ident _))+       =(identToName ident, hasNameSpace ent,  modName, getQualifier qual)+       +-- | Process the export relation returned from the parsing and module analysis pass, and +--   return a list of trhee-element tuples. Each tuple contains an identifier name, the +--   identifier's namespace info, and the identifier's define module. +exportInfo::Exports                             -- ^ The export relation.+          -> [(String, NameSpace, ModuleName)]  -- ^ The result+exportInfo exports = nub $ map getEntInfo  exports+  where +    getEntInfo (_, ent@(Ent modName ident _))+      =(identToName ident, hasNameSpace ent,  modName)++-- | Return True if the identifier is inscope and can be used without a qualifier.          +isInScopeAndUnqualified::String       -- ^ The identifier name.+                       ->InScopes     -- ^ The inscope relation +                       ->Bool         -- ^ The result.+isInScopeAndUnqualified id inScopeRel+ = isJust $ find (\ (x, _,_, qual) -> x == id && isNothing qual ) $ inScopeInfo inScopeRel+ +--Id is defined in two modules: HsNames.hs (type Id = String) and PosName.hs (type Id = SN HsNames.Id)+identToName (HsVar (SN i _)) = i+identToName (HsCon (SN i _)) = i++-- | Return True if the current module is exported either by default or by specifying the module name in the export.+modIsExported::HsModuleP  -- ^ The AST of the module+               ->Bool     -- ^ The result+modIsExported mod+   = let exps    = hsModExports mod+         modName = hsModName mod+     in if isNothing exps+           then True+           else isJust $ find (==(ModuleE modName)) (fromJust exps)+                      +-- | Return True if the identifier is exported either implicitly or explicitly.         +isExported::PNT         -- ^ The identifier.+           ->Exports    -- ^ The export relation.+           ->Bool       -- ^ The result.+isExported pnt@(PNT pn t1 _) exps+   = if isTopLevelPNT pnt +       then case hasModName pn of +               Just modName  -> isJust (find (\(name, nameSpace, modName1) -> name == pNtoName pn+                                         && modName == modName1 && hasNameSpace pnt == nameSpace) $ exportInfo exps)  +               Nothing       -> False+       else False    ++-- | Return True if an identifier is explicitly exported by the module.+isExplicitlyExported::PName          -- ^ The identifier+                     ->HsModuleP    -- ^ The AST of the module+                     ->Bool         -- ^ The result+isExplicitlyExported pn mod+  = findEntity pn $ hsModExports mod++{-+causeNameClashInExports::String      -- ^ The identifier name+                        ->HsModuleP  -- ^ The AST of the module+                        ->Exports    -- ^ The export relation of the module+                        ->Bool       -- ^ The result -}++-- Note that in the abstract representation of exps, there is no qualified entities.+causeNameClashInExports  pn newName mod exps +  = let modNames=nub (concatMap (\(x, Ent modName _ _)->if show x==show newName +                                                        then [modName]+                                                        else []) exps)+    in (isExplicitlyExported pn mod) && +        ( any (modIsUnQualifedImported mod) modNames +            || elem (let (SN modName1 _) =hsModName mod+                     in modName1)  modNames)+ where     +    modIsUnQualifedImported mod modName+     =let imps =hsModImports mod+      in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify  _ h)->modName==modName1 && (not qualify)) imps++          +-------------------------------------------------------------------------------------------------+{-append an import declaration to the end of the import list in the module, this functions+  modifies both the token stream and the AST+-}++-------------------------------------------------------------------------------------+addImportDecl mod@(HsModule _ _ _ imp decls) moduleName qualify alias hide idNames +  = do ((toks, _),(v,v1)) <- get+       let (toks1, toks2)+               =if imps' /= []+                   then let (startLoc, endLoc) = startEndLocIncComments toks (last imps')+                            (toks1, toks2)= break (\t->tokenPos t==endLoc) toks+                        in (toks1 ++ [ghead "addImportDecl1" toks2], tail toks2)    +                   else if decls /=[]  +                          then let startLoc = fst $ startEndLocIncComments toks (ghead "addImportDecl1" decls)+                                   (toks1, toks2) = break (\t ->tokenPos t==startLoc) toks  +                               in (toks1,  toks2)+                          else (toks,[])+           before = if toks1/=[] && endsWithNewLn (glast "addImportDecl1" toks1) then "" else "\n"+           after  = if (toks2 /=[] && startsWithNewLn (ghead "addImportDecl1" toks2)) then "" else "\n"         +           colOffset = if imps'==[] && decls==[] +                        then 1  +                        else getOffset toks+                                $ if imps'/=[] then fst $ startEndLoc toks  (ghead "addImportDecl1" imps') +                                               else fst $ startEndLoc toks  (ghead "addImportDecl1" decls)+           impToks =tokenise (Pos 0 v1 1) (colOffset-1) True +                      $ before++(render.ppi) impDecl++"\n" ++ after  --- refactorer this+       (impDecl', _) <- addLocInfo (impDecl,impToks)+       let toks' = toks1++impToks++toks2+       put ((toks',modified), ((tokenRow (glast "addImportDecl1" impToks) - 10,v1)))  -- 10: step ; generalise this.+       return (mod {hsModImports = imp ++ [impDecl']})+  where+     alias' = case alias of +                  Just m -> Just $ SN (PlainModule m) loc0+                  _      -> Nothing+     impDecl = HsImportDecl loc0 (SN (PlainModule moduleName) loc0) qualify alias' +                      (if idNames==[] && hide==False +                          then Nothing+                          else  (Just (hide, map nameToEnt idNames)))  -- what about "Main"+     imps' = imp \\ prelimps+     nameToEnt name = Var (nameToPNT name)+    ++---------------------------------------------------------------------------------------++-- | Adding a declaration to the declaration list of the given syntax phrase(so far only adding function\/pattern binding+--  has been tested).  If the second argument is Nothing, then the declaration will be added to the beginning of the+-- declaration list, but after the data type declarations is there is any.+{-addDecl::( ) =>t                -- ^ The AST.+   -> Maybe PName     -- ^ If this is Just, then the declaration will be added right after this identifier's definition.+   ->([HsDeclP], Maybe [PosToken])  -- ^ The declaration to be added, in both AST and Token stream format (optional).+   ->Bool               -- ^ True means the declaration is a toplevel declaration.+   ->m t+-}++addDecl::((MonadState (([PosToken],Bool),(Int,Int)) m), StartEndLoc t, HsDecls t, Printable t)+                    =>t-> Maybe PName +                    ->([HsDeclP], Maybe [PosToken]) +                    ->Bool               +                    ->m t++addDecl parent pn (decl, declToks) topLevel+ = if isJust pn +     then appendDecl parent (fromJust pn) (decl, declToks)+     else if topLevel +            then addTopLevelDecl (decl, declToks) parent+            else addLocalDecl parent (decl,declToks)+ where++  {- Add a definition to the beginning of the definition declaration list, but after the data type declarations+     if there is any. The definition will be pretty-printed if its token stream is not provided. -}+  addTopLevelDecl (decl, declToks) parent +    = do let decls = hsDecls parent +             (decls1,decls2)=break (\x->isFunOrPatBind x || isTypeSig x) decls      +         ((toks,_),(v1, v2))<-get   +         let loc1 = if decls2/=[]  -- there are function/pattern binding decls. +                    then let ((startRow,_),_) = startEndLocIncComments toks (ghead "addTopLevelDecl"  decls2)+                         in  (startRow, 1)+                    else simpPos0  -- no function/pattern binding decls in the module.+             (toks1, toks2) = if loc1==simpPos0  then (toks, [])+                                 else break (\t->tokenPos t==loc1) toks+             +             declStr = case declToks of +                        Just ts -> concatMap tokenCon ts+                        Nothing -> prettyprint decl++"\n\n"+             colOffset = if decls ==[] then 1 else getOffset toks $ fst (getStartEndLoc toks (head decls))+             newToks = tokenise (Pos 0 v1 1) colOffset True declStr+             toks' = toks1 ++ newToks ++ toks2+     --    error $ show decl++         put ((toks',modified),((tokenRow (glast "addTopLevelDecl" newToks) -10), v2))                                    +         (decl',_) <- addLocInfo (decl, newToks)+     --    error $ show decl+         return (replaceDecls parent (Decs (decls1++decl'++decls2) ([], [])))++  appendDecl parent pn (decl, declToks)+    = do ((toks,_),(v1, v2))<-get   +         -- error (show parent ++ "----" ++ show pn ++ "-----" ++ show (decl, declToks))+         let (startPos,endPos) = startEndLocIncFowComment toks (ghead "appendDecl1" after) +             -- divide the toks into three parts.+             (toks1, toks2, toks3) = splitToks' (startPos, endPos) toks +              --get the toks defining pn+             defToks = dropWhile (\t->tokenPos t /=startPos) toks2+             offset = getOffset toks $ fst (getStartEndLoc toks (ghead "appendDecl2" decls))+             declStr = case declToks of +                          Just ts -> concatMap tokenCon ts+                          Nothing -> prettyprint decl +             newToks = tokenise (Pos 0 v1 1) offset True declStr +             toks' = if  endsWithNewLn  (glast "appendDecl2" toks2)+                      then  toks1++ toks2 ++ (newLnToken: newToks) ++ [newLnToken]++ compressPreNewLns toks3  +                      else  replaceToks toks startPos endPos (defToks++[newLnToken,newLnToken]++newToks)+    --     (decl',_) <- addLocInfo (decl, newToks)+         put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))  +         return (replaceDecls parent (Decs (before ++ [ghead "appendDecl14" after]++ decl++ tail after) ([], [])))        +      where +        decls = hsDecls parent +        (before,after) = break (defines pn) decls -- Need to handle the case that 'after' is empty?+        splitToks' (startPos, endPos) toks +           = let (ts1, ts2, ts3) = splitToks ( startPos, endPos) toks  +                 (ts11, ts12) = break hasNewLn (reverse ts1)+             in (reverse ts12, reverse ts11++ts2, ts3)      ++  -- This function need to be tested.+  addLocalDecl parent (newFun, newFunToks)+    =do+        ((toks,_), (v1, v2))<-get  +        let (startPos@(_,startCol),endPos'@(endRow',_))  --endPos' does not include the following newline or comment.+              =if localDecls==[] then startEndLocIncFowComment toks parent    --The 'where' clause is empty+                                 else startEndLocIncFowComment toks localDecls +            toks1=gtail "addLocalDecl1"  $ dropWhile (\t->tokenPos t/=endPos') toks +            ts1=takeWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t)  toks1    +            --nextTokPos is only used to test whether there is a 'In' or a nested comment. +            nextTokPos= case (dropWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t) toks1) of+                           [] -> simpPos0 +                           l  -> (tokenPos.ghead "addLocalFunInToks") l +            needNewLn=if nextTokPos==simpPos0  --used to decide whether add a new line character before a introduced fun.+                      then if toks1==[] then True+                                        else (not.endsWithNewLn) (last ts1) +                      else endRow'==fst nextTokPos +            --endPos@(endRow,_)=if ts1==[] then endPos'+            --                             else tokenPos (last ts1)+            offset = if localDecls == [] then getOffset toks startPos + 4 else getOffset toks startPos+            newToks = tokenise (Pos 0 v1 1) offset True +                          $ if needNewLn then "\n"++newSource else newSource++"\n"+            oldToks'=getToks (startPos,endPos') toks+            toks'=replaceToks toks startPos endPos' (oldToks'++newToks)           +        (newFun',_) <- addLocInfo (newFun, newToks) -- This function calles problems because of the lexer.+        put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))  +        return (replaceDecls parent (Decs (hsDecls parent ++ newFun') ([], [])))+    where+         localDecls = hsDecls parent+        +         newSource  = if localDecls == []+                      then "where\n"++ concatMap (\l-> "  "++l++"\n") (lines newFun')+                      else newFun'+            where+            newFun' = case newFunToks of +                           Just ts -> concatMap tokenCon ts +                           Nothing -> prettyprint newFun ++-- | Remove the type signature that defines the given identifier's type from the declaration list.+{-rmTypeSig::(MonadState (([PosToken],Bool),t1) m)+            => PName       -- ^ The identifier whose type signature is to be removed.+            ->[HsDeclP]    -- ^ The declaration list+            ->m [HsDeclP]  -- ^ The result -}++rmTypeSig pn  t = applyTP (full_tdTP (idTP `adhocTP` inDecls)) t+  where +   inDecls (decls::[HsDeclP])+      | snd (break (definesTypeSig pn) decls) /=[] +     = do ((toks,_), others) <- get+          let (decls1,decls2)= break  (definesTypeSig pn) decls+              (toks',decls')=+               let sig@(TiDecorate.Dec (HsTypeSig loc is c tp))=ghead "rmTypeSig" decls2  -- as decls2/=[], no problem with head +                   (startPos,endPos)=getStartEndLoc toks sig +               in if length is>1  +                     then let newSig=(TiDecorate.Dec (HsTypeSig loc (filter (\x-> (pNTtoPN x)/=pn) is) c tp))+                              pnt = ghead "rmTypeSig" (filter (\x-> pNTtoPN x == pn) is)+                              (startPos1, endPos1) = let (startPos1', endPos1') = getStartEndLoc toks pnt+                                                     in if fromJust (elemIndex pnt is) >0+                                                        then extendForwards toks startPos1' endPos1' isComma+                                                        else extendBackwards toks startPos1' endPos1' isComma+                          in (deleteToks toks startPos1 endPos1,(decls1++[newSig]++tail decls2))+                     else  ((deleteToks toks startPos endPos),(decls1++tail decls2)) +          put ((toks',modified),others)+          return decls' +   inDecls x = return x++-- |Comment out the type signature that defines pn's type in the token stream and remove it from the AST. +commentOutTypeSig::(MonadState (([PosToken],Bool),t1) m)+            => PName       -- ^ The identifier.+            ->[HsDeclP]    -- ^ The deckaration list.+            ->m [HsDeclP]  -- ^ The result.+commentOutTypeSig pn decls  + =let (decls1,decls2)=break  (definesTypeSig pn) decls+  in if decls2/=[] then    --There is a type signature for pn+       do ((toks,_),others)<-get   +          let (toks',decls')=+               let sig@(TiDecorate.Dec (HsTypeSig loc is c tp))=ghead "rmTypeSig" decls2  -- as decls2/=[], no problem with head +               in if length is>1   --This type signature also defines the type of  variables other than pn+                     then let newSig=(TiDecorate.Dec (HsTypeSig loc (filter (\x-> (pNTtoPN x)/=pn) is) c tp))+                              pnt = ghead "commentTypeSig" $ filter (\x->pNTtoPN x==pn) is +                              (startPos,endPos) = getStartEndLoc toks pnt +                          in ((commentToks (startPos, endPos) toks),(decls1++[newSig]++tail decls2))+                     else let  (startPos,endPos)=getStartEndLoc toks sig +                          in  ((commentToks  (startPos, endPos) toks),(decls1++tail decls2)) +          put ((toks',modified),others)+          return decls' +      else return decls  ++++-- | Remove the declaration (and the type signature is the second parameter is True) that defines the given identifier+-- from the declaration list.+{-+rmDecl::(MonadState (([PosToken],Bool),t1) m)+        =>PName       -- ^ The identifier whose definition is to be removed.+        ->Bool        -- ^ True means including the type signature.+        ->[HsDeclP]   -- ^ The declaration list.+        -> m [HsDeclP]-- ^ The result.+-}+rmDecl pn incSig t = applyTP (once_tdTP (failTP `adhocTP` inDecls)) t+  where +    inDecls (decls::[HsDeclP])+      | snd (break (defines pn) decls) /=[] +      = do let (decls1, decls2) = break (defines pn) decls+               decl = ghead "rmDecl" decls2+           -- error $ (render.ppi) t -- ecl ++ (show decl) +           case isTopLevelPN  pn of+                     True   -> if incSig then rmTopLevelDecl decl =<< rmTypeSig pn decls+                                         else rmTopLevelDecl decl decls+                     False  -> if incSig then rmLocalDecl decl =<< rmTypeSig pn decls +                                         else rmLocalDecl decl decls+    inDecls x = mzero +    rmTopLevelDecl decl decls +      =do ((toks,_),others)<-get   +          let (startLoc, endLoc)=startEndLocIncComments toks decl      +              toks'=deleteToks toks startLoc endLoc+          put ((toks',modified),others)+          return (decls \\ [decl]) +++  {- The difference between removing a top level declaration and a local declaration is:+     if the local declaration to be removed is the only declaration in current declaration list, +     then the 'where'/ 'let'/'in' enclosing this declaration should also be removed.+     Whereas, when a only top level decl is removed, the 'where' can not be removed.+   -}+-- |Remove a location declaration that defines pn.+    rmLocalDecl decl decls+     =do ((toks,_),others)<-get   +         let (startPos,endPos)=getStartEndLoc toks decl   --startEndLoc toks decl  +             (startPos',endPos')=startEndLocIncComments toks decl       +             --(startPos',endPos')=startEndLocIncFowComment toks decl +             toks'=if length decls==1  --only one decl, which means the accompaning 'where',+                                       --'let' or'in' should be removed too.+                   then let (toks1,toks2)=break (\t->tokenPos t==startPos) toks --devide the token stream.+                              --get the  'where' or 'let' token+                            rvToks1=dropWhile (not.isWhereOrLet) (reverse toks1)+                            --There must be a 'where' or 'let', so rvToks1 can not be empty.+                            whereOrLet=ghead "rmLocalFunPatBind:whereOrLet" rvToks1 +                            --drop the 'where' 'or 'let' token+                            toks1'=takeWhile (\t->tokenPos t/=tokenPos whereOrLet) toks1+                            --remove the declaration from the token stream.+                            toks2'=gtail "rmLocalDecl" $ dropWhile (\t->tokenPos t/=endPos') toks2+                            --get the remained tokens after the removed declaration.+                            remainedToks=dropWhile isWhite toks2'+                        in if remainedToks==[] +                             then --the removed declaration is the last decl in the file.+                                  (compressEndNewLns toks1'++ compressPreNewLns toks2') +                             else if --remainedToks/=[], so no problem with head.+                                    isIn (ghead "rmLocalDecl:isIn"  remainedToks)  +                                         || isComma (ghead "rmLocalDecl:isComma" remainedToks) +                                        --There is a 'In' after the removed declaration.+                                   then if isWhere whereOrLet+                                           then deleteToks toks (tokenPos whereOrLet) endPos'+                                           else deleteToks toks (tokenPos whereOrLet) +                                                   $ tokenPos (ghead "rmLocalDecl:tokenPos" remainedToks)+                                        --delete the decl and adjust the layout                      +                                   else if isCloseSquareBracket (ghead "rmLocalDecl:isCloseSquareBracker" remainedToks) &&+                                           (isBar.(ghead "rmLocalDecl:isBar")) (dropWhile isWhite (tail rvToks1))+                                         then deleteToks toks (tokenPos((ghead "rmLocalDecl") +                                                        (dropWhile isWhite (tail rvToks1)))) endPos'+                                         else deleteToks toks (tokenPos whereOrLet) endPos' +                        --there are more than one decls+                   else  deleteToks toks startPos' endPos'+         put ((toks',modified),others)  --Change the above endPos' to endPos will not delete the following comments.+         return $ (decls \\ [decl])++{- ********* IMPORTANT : THIS FUNCTION SHOULD BE UPDATED TO THE NEW TOKEN STREAM METHOD ****** -}+-- | Duplicate a functon\/pattern binding declaration under a new name right after the original one.+duplicateDecl::(MonadState (([PosToken],Bool),t1) m)+                 =>[HsDeclP]            -- ^ The declaration list+                 ->PName                -- ^ The identifier whose definition is going to be duplicated+                 ->String               -- ^ The new name+                 ->m [HsDeclP]          -- ^ The result+{-there maybe fun/simple pattern binding and type signature in the duplicated decls+  function binding, and type signature are handled differently here: the comment and layout+  in function binding are preserved.The type signature is output ted by pretty printer, so+  the comments and layout are NOT preserved.+ -}+duplicateDecl decls pn newFunName+ = do ((toks,_), others)<-get   +      let (startPos, endPos) =startEndLocIncComments toks funBinding  +          {-take those tokens before (and include) the function binding and its following+            white tokens before the 'new line' token. (some times the function may be followed by +            comments) -}+          toks1 = let (ts1, ts2) =break (\t->tokenPos t==endPos) toks in ts1++[ghead "duplicateDecl" ts2]+          --take those token after (and include) the function binding+          toks2 = dropWhile (\t->tokenPos t/=startPos || isNewLn t) toks+      put((toks2,modified), others)+      --rename the function name to the new name, and update token stream as well+      funBinding'<-renamePN pn Nothing newFunName True funBinding+      --rename function name in type signature  without adjusting the token stream+      typeSig'  <- renamePN pn Nothing newFunName False typeSig+      ((toks2,_), others)<-get    +      let offset = getOffset toks (fst (startEndLoc toks funBinding))+          newLineTok = if toks1/=[] && endsWithNewLn (glast "doDuplicating" toks1)+                         then [newLnToken]+                         else [newLnToken,newLnToken] +          toks'= if typeSig/=[] +                 then let offset = tokenCol ((ghead "doDuplicating") (dropWhile (\t->isWhite t) toks2))+                          sigSource = concatMap (\s->replicate (offset-1) ' '++s++"\n")((lines.render.ppi) typeSig')+                          t = mkToken Whitespace (0,0) sigSource  +                      in  (toks1++newLineTok++[t]++(whiteSpacesToken (0,0) (snd startPos-1))++toks2)+                 else (toks1++newLineTok++(whiteSpacesToken (0,0) (snd startPos-1))++toks2) +      put ((toks',modified),others)+      return (typeSig'++funBinding')+     where +       declsToDup = definingDecls [pn] decls True False    +       funBinding = filter isFunOrPatBind declsToDup     --get the fun binding.+       typeSig    = filter isTypeSig declsToDup      --get the type signature.   +++------------------------------------------------------------------------------++-- | Add identifiers to the export list of a module. If the second argument is like: Just p, then do the adding only if p occurs+-- in the export list, and the new identifiers are added right after p in the export list. Otherwise the new identifiers are add+-- to the beginning of the export list. In the case that the export list is emport, then if the third argument is True, then create+-- an explict export list to contain only the new identifiers, otherwise do nothing.+{-+addItemsToExport::( )+                 => HsModuleP                           -- The module AST.    +                   -> Maybe PName                       -- The condtion identifier.+                   -> Bool                              -- Create an explicit list or not+                   -> Either [String] [HsExportEntP]    -- The identifiers to add in either String or HsExportEntP format.+                   -> m HsModuleP                       -- The result.+-}++addItemsToExport::(MonadState (([PosToken],Bool), t1) m)+                 => HsModuleP                           -- The module AST.    +                   -> Maybe PName                       -- The condtion identifier.+                   -> Bool                              -- Create an explicit list or not+                   -> Either [String] [HsExportEntP]    -- The identifiers to add in either String or HsExportEntP format.+                   -> m HsModuleP                       -- The result.+++addItemsToExport mod _  _ (Left [])  = return mod+addItemsToExport mod _  _ (Right []) = return mod+addItemsToExport mod@(HsModule loc modName exps imps ds) (Just pn) _ ids+  =  case exps  of+       Just ents ->let (e1,e2) = break (findEntity pn) ents+                   in if e2 /=[]  +                        then do ((toks,_),others)<-get   +                                let e = (ghead "addVarItemInExport" e2)+                                    es = case ids of +                                          (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'+                                          (Right es') -> es' +                                let (_,endPos) = getStartEndLoc toks e+                                    (t, (_,s)) = ghead "addVarItemInExport" $ getToks (endPos,endPos) toks+                                    newToken = mkToken t endPos (s++","++ showEntities (render.ppi) es) +                                    toks' = replaceToks toks endPos endPos [newToken]+                                put ((toks',modified),others)                                   +                                return (HsModule loc modName (Just (e1++(e:es)++tail e2)) imps ds)+                        else return mod                     +       Nothing   -> return mod   ++addItemsToExport mod@(HsModule _ _ (Just ents) _ _) Nothing createExp ids+    = do ((toks,_),others)<-get+         let es = case ids of +                    (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'+                    (Right es') -> es'+             (t, (pos,s))=fromJust $ find isOpenBracket toks  -- s is the '('+             newToken = if ents /=[] then  (t, (pos,(s++showEntities (render.ppi) es++",")))+                                     else  (t, (pos,(s++showEntities (render.ppi) es)))+             pos'= simpPos pos+             toks' = replaceToks toks pos' pos' [newToken]+         put ((toks',modified),others)  +         return mod {hsModExports=Just (es++ ents)}++addItemsToExport mod@(HsModule _  (SN modName (SrcLoc _ c row col))  Nothing _ _)  Nothing createExp ids+  =case createExp of +       True ->do ((toks,_),others)<-get+                 let es = case ids of +                               (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'+                               (Right es') -> es'+                     pos = (row,col)+                     newToken = mkToken Varid pos (modNameToStr modName++ "(" +                                         ++ showEntities (render.ppi) es++")")+                     toks' = replaceToks toks pos pos [newToken]+                 put  ((toks', modified), others)       +                 return mod {hsModExports=Just es}+       False ->return mod               ++-- | Add identifiers (given by the third argument) to the explicit entity list in the declaration importing the+--   specified module name. The second argument serves as a condition: if it is like : Just p, then do the adding +--   the if only 'p' occurs in the entity list; if it is Nothing, then do the adding as normal. This function+--   does nothing if the import declaration does not have an explicit entity list.+{-+addItemsToImport::( )+                 =>ModuleName                  -- ^ The imported module name.+                 ->Maybe PName                 -- ^ The condition identifier.+                 ->Either [String] [EntSpecP]  -- ^ The identifiers to add in either String or EntSpecP format.+                 ->t                           -- ^ The given syntax phrase.+                 ->m t                         -- ^ The result.+-}++addItemsToImport::(Term t,MonadState (([PosToken],Bool),t1) m) +                 =>ModuleName                  -- ^ The imported module name.+                 ->Maybe PName                 -- ^ The condition identifier.+                 ->Either [String] [EntSpecP]  -- ^ The identifiers to add in either String or EntSpecP format.+                 ->t                           -- ^ The given syntax phrase.+                 ->m t                         -- ^ The result.++addItemsToImport serverModName pn (Left [])  t = return t +addItemsToImport serverModName pn (Right []) t = return t+addItemsToImport serverModName pn ids t+ =applyTP (full_buTP (idTP `adhocTP` inImport)) t+  where +    inImport (imp@(HsImportDecl loc m@(SN modName _) qual  as h):: HsImportDeclP)+      | serverModName == modName && (if isJust pn then findPN (fromJust pn) h else True)+       = case h of+           Nothing        -> return imp                     +           Just (b, ents) -> do let ents'=case ids of+                                          Left  is'  -> map (\x-> Var (nameToPNT x)) is'+                                          Right es   -> es+                                ((toks,_),others)<-get+                                let (_,endPos)=getStartEndLoc toks (glast "addItemsToImport" ents)+                                    (t,(_,s))=ghead "addItemsToImport" $ getToks (endPos,endPos) toks+                                    newToken = mkToken t endPos (s++","++showEntities (render.ppi) ents')+                                    toks'=replaceToks toks endPos endPos [newToken]+                                put ((toks',modified),others)+                                return (HsImportDecl loc m qual as (Just (b, ents++ents')))+    inImport imp = return imp++-- | add items to the hiding list of an import declaration which imports the specified module.+addHiding::(MonadState (([PosToken],Bool),t1) m) +            =>ModuleName           -- ^ The imported module name+            ->HsModuleP            -- ^ The current module+            ->[PName]              -- ^ The items to be added+            ->m HsModuleP          -- ^ The result +addHiding serverModName mod pns+   = applyTP (full_tdTP (idTP `adhocTP` inImport)) mod+  where +    inImport (imp@(HsImportDecl loc (SN modName _) qual  as h)::HsImportDeclP)+      | serverModName == modName  && not qual+       = case h of+           Nothing ->do ((toks,_),others)<-get  +                        let (_,endPos)=getStartEndLoc toks imp+                            (t,(_,s)) = ghead "addHiding" $ getToks (endPos,endPos) toks +                            newToken=mkToken t endPos (s++" hiding ("++showEntities pNtoName pns++")")+                            toks'=replaceToks toks endPos endPos [newToken]+                        put ((toks',modified),others)    +                        return (replaceHiding imp (Just (True, map mkNewEnt pns )))+           Just (True, ents) ->do ((toks,_),others)<-get  +                                  let (_,endPos)=getStartEndLoc toks imp+                                      (t, (_,s))=ghead "addHiding"  $ getToks (endPos,endPos) toks+                                      newToken=mkToken t endPos (","++showEntities pNtoName pns ++s)+                                      toks'=replaceToks toks endPos endPos [newToken]+                                  put ((toks',modified),others) +                                  return (replaceHiding imp  (Just (True, (map mkNewEnt  pns)++ents))) +           Just (False, ent)  -> return imp +    inImport x = return x++    mkNewEnt pn = (Var (PNT pn Value (N (Just loc0))))+    replaceHiding (HsImportDecl loc modName qual as h) h1 = HsImportDecl loc modName qual as h1    +++-- | Remove those specified items from the entity list in the import declaration.+{-+ rmItemsFromImport::( ) +                   =>HsModuleP    -- ^ The module AST+                   ->[PName]      -- ^ The items to be removed+                   ->m HsModuleP  -- ^ The result+-}+++rmItemsFromImport::(MonadState (([PosToken],Bool),t1) m) +                   =>HsModuleP    -- ^ The module AST+                   ->[PName]      -- ^ The items to be removed+                   ->m HsModuleP  -- ^ The result+++rmItemsFromImport mod pns+  = applyTP (full_buTP (idTP `adhocTP` inImport)) mod+   where +     inImport (imp@(HsImportDecl loc modName qual  as h)::HsImportDeclP)+      | any (flip findEntity imp) pns+       = case h of+           Just (b, ents) ->+             do let matchedEnts=findEnts pns ents+                if  matchedEnts==[] +                  then return imp+                  else if length matchedEnts == length ents   +                         then do ((toks,_),others)<-get  +                                 let (startPos,endPos)=getStartEndLoc toks ents+                                     toks'=deleteToks toks startPos endPos+                                 put ((toks',modified),others)+                                 return (HsImportDecl loc modName qual as (Just (b,[])))+                         else do ((toks,_),others)<-get  +                                 let remainedEnts=concatMap (\pn->filter (not.match pn) ents) pns +                                     toks'=foldl deleteEnt toks $ map (getStartEndLoc toks) matchedEnts+                                 put ((toks',modified),others)+                                 return (HsImportDecl loc modName qual as (Just (b, remainedEnts)))+           _ ->return imp +     inImport x = return x+   +     findEnts pns ents =nub $ concatMap (\pn->filter (match pn) ents) pns++     -- this function does not check this sub entities of the ListSubs. any problems?+     match::PName -> EntSpec PNT ->Bool+     match pn (Var pnt) = pNTtoPN pnt == pn+     match pn (Abs pnt) = pNTtoPN pnt == pn+     match pn (AllSubs pnt) = pNTtoPN pnt == pn+     match pn (ListSubs pnt _) = pNTtoPN pnt == pn++-- | Remove the sub entities of a type constructor or class from the export list.+rmSubEntsFromExport::(MonadState (([PosToken],Bool),(Int,Int)) m)+                     =>PName       -- ^ The type constructor or class name+                     ->HsModuleP   -- ^ The module AST+                     ->m HsModuleP -- ^ The result+rmSubEntsFromExport typeCon +  = applyTP (full_buTP (idTP `adhocTP` inEntSpec))+  where+   inEntSpec (ent@(AllSubs pnt)::EntSpec PNT)+     | pNTtoPN pnt == typeCon +      =do (ent', _)<-updateToks ent (Abs pnt) prettyprint+          return ent'+   inEntSpec (ent@(ListSubs pnt _))+     | pNTtoPN pnt == typeCon +     = do (ent', _) <- updateToks ent (Abs pnt) prettyprint+          return ent'+   inEntSpec ent = return ent+     +---------------------------------------------------------------------------------------+-- | Remove the specified entities from the module's exports. The entities can be specified in either of two formats:+-- i.e. either specify the module names and identifier names to be removed, so just given the exact AST for these entities.+{-rmItemsFromExport::( ) +                   =>HsModuleP                                      -- ^ The module AST.+                    ->Either ([ModuleName],[PName]) [HsExportEntP]  -- ^ The entities to remove. +                                                                    +                    ->m HsModuleP                                   -- ^ The result.+-}+rmItemsFromExport::(MonadState (([PosToken],Bool),t1) m) +                   =>HsModuleP                                      -- ^ The module AST.+                    ->Either ([ModuleName],[PName]) [HsExportEntP]  -- ^ The entities to remove. +                                                                    +                    ->m HsModuleP                                   -- ^ The result.++rmItemsFromExport mod@(HsModule loc modName exps imps ds)  (Left (modNames, pns))+  =if isNothing exps+     then return mod+     else do let ents =findEnts (modNames, pns) (fromJust exps)+             rmItemsFromExport mod (Right ents) +  where   +    findEnts (modNames, pns) ents+      =let ms = concatMap (\m ->filter (\e -> case e of +                                         ModuleE (SN m' _) -> m==m'+                                         EntE e'    -> False) ents) modNames +           es =concatMap (\pn->filter (\e ->case e of +                                            ModuleE _ -> False+                                            EntE e'    -> match pn e') ents) pns +       in (ms++es)+    match::PName -> EntSpec PNT ->Bool+    match pn (Var pnt) = pNTtoPN pnt == pn+    match pn (Abs pnt) = pNTtoPN pnt == pn+    match pn (AllSubs pnt) = pNTtoPN pnt == pn+    match pn (ListSubs pnt _) = pNTtoPN pnt == pn++rmItemsFromExport mod@(HsModule loc modName exps@(Just es) imps ds) (Right ents)+  = do exps'<- if ents==[] +                  then return exps+                  else if length ents == length es +                         then do ((toks,_),others)<-get             +                                 let (startPos,endPos) = getStartEndLoc toks ents+                                     toks'= deleteToks toks startPos endPos+                                 put ((toks',modified),others)+                                 return (Just [] )  -- should not remove the empty bracket!!!+                         else do ((toks,_),others)<-get +                                 let toks' = foldl deleteEnt toks $ map (getStartEndLoc toks) ents+                                 put ((toks',modified),others)+                                 return (Just (es \\ ents))                 +       return (HsModule loc modName exps' imps ds)+rmItemsFromExport mod _ = return mod++--This function is only used by this module, and should not be exported.+deleteEnt toks (startPos, endPos)+  = let (toks1,toks2)=break (\t->tokenPos t==startPos) toks+        previousTok=ghead "deleteEnt" $ dropWhile isWhiteSpace $ reverse toks1+        toks' = dropWhile isWhiteSpace $ gtail "deleteEnts" $ dropWhile (\t->tokenPos t/=endPos) toks2+        nextTok = ghead "deleteEnt" toks'+        startPos'=if isComma previousTok && (not (isComma nextTok)) then tokenPos previousTok else startPos+    in if isComma nextTok                    +         then let remainedToks = tail toks' +              in if remainedToks /= [] +                   then let whites = takeWhile isWhiteSpace remainedToks+                        in if whites /= [] then deleteToks toks startPos' (tokenPos (last whites))+                                           else deleteToks toks startPos' (tokenPos nextTok)+                   else deleteToks toks startPos' (tokenPos nextTok)+         else deleteToks toks startPos' endPos  ++++--------------------------------TRY TO REMOVE THIS FUNCTION------------------------------+{-                                    +moveDecl::(CanHaveWhereClause t,DeclStartLoc t, Term t,Printable t,MonadPlus m, +           MonadState (([PosToken],Bool),(Int, Int)) m)+     => [PName]        -- ^ The identifier(s) whose defining declaration is to be moved. List is used to handle pattern bindings where multiple identifiers are defined.+     -> t              -- ^ The syntax phrase where the declaration is going to be moved to.+     -> Bool           -- ^ True mean the function\/pattern binding being moved is going to be at the same level with t. Otherwise it will be a local declaration of t.+     -> [HsDeclP]      -- ^ The declaration list where the definition\/pattern binding originally exists.+     -> Bool           -- ^ True means the type signature will not be discarded.+     -> m t            -- ^ The result.+-}                    +moveDecl pns dest sameLevel decls incSig+   = do ((ts,_),_)<-get  +        let defToks' =(getDeclToks (ghead "moveDecl:0" pns) True decls ts)      +            defToks  =whiteSpaceTokens (tokenRow (ghead "moveDecl" defToks'),0)+                                       -- do not use tokenCol here. should count the whilte spaces.+                                       (tokenCol (ghead "moveDecl2" defToks') -1) ++ defToks'+            movedDecls = definingDecls pns decls True False+        decls'<-rmDecl (ghead "moveDecl3"  pns) False =<<foldM (flip rmTypeSig) decls pns+        addDecl dest Nothing (movedDecls, Just defToks) False++---------------------------------------------------------------------------------------------++-- |Parse a Haskell source files, and returns a four-element tuple. The first element in the result is the inscope +-- relation, the second element is the export relation, the third is the type decorated AST of the module and the forth element is+-- the token stream of the module.+{- +parseSourceFile:: ( ) =>FilePath+                      ->m (InScopes,Exports,HsModuleP,[PosToken])  +-}++parseSourceFile filename +   = do+        +         modle <- fileNameToModName filename        +         (inscps, exps, mod, tokList) <- (checkScope @@ parseSourceFile') filename +        +         mod' <- typeCheckMod [modle]+         -- map the normal AST over the typed AST preserving type info+         mod2 <- mapASTOverTAST mod mod'+        +         return (inscps, exps, mod2, tokList)+  where +   checkScope (ts,(((wm,_),mod),refs))+     = check (checkRefs refs) >> return (inscpRel wm, exports wm, mod, expandNewLnTokens ts) ++   check [] = done+   check errs = fail $ pp $ "Scoping errors" $$ vcat errs   +   +   typeCheckMod [mod] = do+         x <- typeCheck (Just [mod])         +         let y = [map snd tms | (_,(x,(tms,y))) <- x]+        -- let y' = map snd y+        +         +         +         return (head (head y))+         +newProj args = do +             newProject     +             addPaths True args+addFile fileName + = addPaths False fileName ++chase fileNames+ = findMissing fileNames++--preprocssing the token stream to expand the white spaces to individual tokens.+expandNewLnTokens::[PosToken]->[PosToken]+expandNewLnTokens ts = concatMap expand ts+  where+    expand tok@(Whitespace,(pos,s)) = doExpanding pos s                +    expand x = [x]++    doExpanding pos [] =[]+    doExpanding pos@(Pos c row col) (t:ts)+      = case t of +           '\n'  -> (Whitespace, (pos,[t])):(doExpanding (Pos c (row+1) 1) ts)+           _     -> (Whitespace, (pos,[t])):(doExpanding (Pos c row (col+1)) ts)++------------------------------------------------------------------------------------------------+++-- | Write refactored program source to files. +{-+writeRefactoredFiles::Bool   -- ^ True means the current refactoring is a sub-refactoring+         ->[((String,Bool),([PosToken],HsModuleP))]  --  ^ String: the file name; Bool: True means the file has been modified.[PosToken]: the token stream; HsModuleP: the module AST.+         -> m ()  +-}      +writeRefactoredFiles (isSubRefactor::Bool) (files::[((String,Bool),([PosToken], HsModuleP))]) +  = do let modifiedFiles = filter (\((f,m),_)->m==modified) files+       addToHistory isSubRefactor $ map (fst.fst) modifiedFiles+       mapM_ modifyFile modifiedFiles+       mapM_ writeTestDataForFile files   -- This should be removed for the release version.+       {-   -- the 'writeTestDataForFile' causes a 'stack overflow' problem, when applying refactorings to+          -- large-scale programs,and the possible reason might be lazy evaluation and the huge size of AST.+         -}+     where+       modifyFile ((fileName,_),(ts,mod)) = do+           --let source =(render.ppi) mod +           let source = concatMap (snd.snd) ts+           seq (length source) $ writeHaskellFile fileName source+           editorCmds <-getEditorCmds +           MT.lift $ sendEditorModified editorCmds fileName        +       writeTestDataForFile ((fileName,_),(ts,mod)) = do+           let source=concatMap (snd.snd) ts+           seq (length source) $ writeFile (createNewFileName "_TokOut" fileName) source +           writeHaskellFile (createNewFileName "AST" fileName) ((render.ppi.rmPrelude) mod)   +       createNewFileName str fileName +          =let (name, posfix)=span (/='.') fileName+           in (name++str++posfix) ++--------------------------------------------------------------------------------------- +-----Remove the 'Prelude' imports added by Programatica------------------------------+rmPrelude::HsModuleP->HsModuleP+rmPrelude (HsModule s m e is ds) = HsModule s m e (is \\ prelimps) ds++prelimps = [HsImportDecl loc0  (SN (PlainModule "Prelude") loc0)  True Nothing Nothing,+            HsImportDecl loc0  (SN (PlainModule "Prelude") loc0) False Nothing Nothing]+    ++-- | Return True if a string is a lexically  valid variable name.+isVarId::String->Bool+isVarId id =RefacTypeUtils.isId id && isSmall (ghead "isVarId" id) +     where isSmall c=isLower c || c=='_'++-- | Return True if a string is a lexically valid constructor name.+isConId::String->Bool+isConId id =RefacTypeUtils.isId id && isUpper (ghead "isConId" id)++-- | Return True if a string is a lexically valid operator name.+isOperator::String->Bool+isOperator id = id /= [] && isOpSym (ghead "isOperator" id) &&+                isLegalOpTail (tail id) && not (isReservedOp id)+   where++    isOpSym id = elem id opSymbols+       where opSymbols = ['!', '#', '$', '%', '&', '*', '+','.','/','<','=','>','?','@','\'','^','|','-','~']++    isLegalOpTail tail = all isLegal tail+       where isLegal c = isOpSym c || c==':'++    isReservedOp id = elem id reservedOps+       where reservedOps = ["..", ":","::","=","\"", "|","<-","@","~","=>"]++{-Returns True if a string lexically is an identifier. *This function should not be exported.*+-}  +isId::String->Bool+isId id = id/=[] && isLegalIdTail (tail id) && not (isReservedId id)+  where+    isLegalIdTail tail=all isLegal tail+        where isLegal c=isSmall c|| isUpper c || isDigit c || c=='\''++    isReservedId id=elem id reservedIds +      where reservedIds=["case", "class", "data", "default", "deriving","do","else" ,"if",+                         "import", "in", "infix","infixl","infixr","instance","let","module",+                         "newtype", "of","then","type","where","_"]++    isSmall c=isLower c || c=='_'++-----------------------------------------------------------------------------+-- |Return True if a PName is a toplevel PName.+isTopLevelPN::PName->Bool+isTopLevelPN (PN i (G _ _ _))=True+isTopLevelPN _ =False++-- |Return True if a PName is a local PName.+isLocalPN::PName->Bool+isLocalPN (PN i (UniqueNames.S _))=True+isLocalPN _ =False++-- |Return True if a PName is a qualified PName.+isQualifiedPN::PName->Bool+isQualifiedPN (PN (Qual mod id) _)=True+isQualifiedPN _ =False ++-- |Return True if an PNT is a toplevel PNT.+isTopLevelPNT::PNT->Bool+isTopLevelPNT = isTopLevelPN.pNTtoPN++-- |Return True if a PName is a function\/pattern name defined in t.+isFunOrPatName::(Term t)=>PName->t->Bool+isFunOrPatName pn +   =isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where+        worker (decl::HsDeclP)+           | defines pn decl=Just True+        worker _ =Nothing++-- |Return True if a PNT is a function name defined in t.+isFunPNT::(Term t)=>PNT -> t -> Bool+isFunPNT pnt t = isFunName (pNTtoPN pnt) t ++isFunName::(Term t)=>PName->t->Bool+isFunName pn +   =isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where+        worker (decl::HsDeclP)+           | isFunBind decl && defines pn decl =Just True+        worker _ =Nothing++-- |Return True if a PName is a pattern name defined in t.+isPatName::(Term t)=>PName->t->Bool+isPatName pn +   =isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where+        worker (decl::HsDeclP)+           | isPatBind decl && defines pn decl =Just True+        worker _ =Nothing+-------------------------------------------------------------------------------+-- | Return True if a PNT is a type constructor.+isTypeCon :: PNT -> Bool+isTypeCon (PNT pn (Type typeInfo) _) = defType typeInfo == Just TypedIds.Data+isTypeCon _ = False ++-- | Return True if a declaration is a type signature declaration.+isTypeSig ::HsDeclP->Bool+isTypeSig (TiDecorate.Dec (HsTypeSig loc is c tp))=True+isTypeSig _=False++-- | Return True if a declaration is a function definition.+isFunBind::HsDeclP->Bool+isFunBind (TiDecorate.Dec (HsFunBind loc matches))=True+isFunBind _ =False++-- | Returns True if a declaration is a pattern binding.+isPatBind::HsDeclP->Bool+isPatBind (TiDecorate.Dec (HsPatBind _ _ _ _))=True+isPatBind _=False++-- | Return True if a declaration is a pattern binding which only defines a variable value.+isSimplePatBind::HsDeclP->Bool+isSimplePatBind decl=case decl of+     TiDecorate.Dec (HsPatBind _ p _ _)->patToPN p /=defaultPN+     _ ->False++-- | Return True if a declaration is a pattern binding but not a simple one.+isComplexPatBind::HsDeclP->Bool+isComplexPatBind decl=case decl of+     TiDecorate.Dec (HsPatBind _ p _ _)->patToPN p ==defaultPN+     _ -> False++-- | Return True if a declaration is a function\/pattern definition.+isFunOrPatBind::HsDeclP->Bool+isFunOrPatBind decl=isFunBind decl || isPatBind decl++-- | Return True if a declaration is a Class declaration.+isClassDecl :: HsDeclP ->Bool+isClassDecl (TiDecorate.Dec (HsClassDecl _ _ _ _ _)) = True+isClassDecl _ = False++-- | Return True if a declaration is a Class instance declaration.+isInstDecl :: HsDeclP -> Bool+isInstDecl (TiDecorate.Dec (HsInstDecl _ _ _ _ _)) = True+isInstDecl _ = False+        +-- | Return True if a function is a directly recursive function.+isDirectRecursiveDef::HsDeclP->Bool+isDirectRecursiveDef (TiDecorate.Dec (HsFunBind loc ms)) +   = any isUsedInDef ms +  where +   isUsedInDef (HsMatch loc1 fun pats rhs ds)+     = findEntity (pNTtoPN fun) rhs+isDirectRecursiveDef _ = False++------------------------------------------------------------------------------------------------++-- | Add a qualifier to an identifier if it is not qualified.+qualifyPName::ModuleName  -- ^ The qualifier.+              ->PName     -- ^ The identifier.+              ->PName     -- ^ The result.+qualifyPName qual pn + = case pn of +      PN (UnQual n) ty -> PN (Qual qual n ) ty+      _                -> pn++-- | Remove the qualifier from the given identifiers in the given syntax phrase.+rmQualifier::((MonadState (([PosToken], Bool), t1) m),Term t)+             =>[PName]  -- ^ The identifiers.+               ->t      -- ^ The syntax phrase.+               ->m t    -- ^ The result.+rmQualifier pns t +  = applyTP (full_tdTP (adhocTP idTP rename )) t+   where +     rename pnt@(PNT  pn@(PN (Qual modName  s) l) ty loc@(N (Just (SrcLoc fileName _ row col))))+       | elem pn pns+       = do do ((toks,_), others)<-get+               let toks' =replaceToks toks (row,col) (row,col) [mkToken Varid (row,col) s]+               put ((toks', modified), others)+               return (PNT (PN (UnQual s) l) ty loc)+     rename x = return  x++-- | Show a list of entities, the parameter f is a function that specifies how to format an entity.+showEntities::(Eq t, Term t)=>(t->String)->[t]->String+showEntities f [] = ""+showEntities f [pn] = f pn+showEntities f (pn:pns) =f pn ++ "," ++ showEntities f pns++-- | Show a PName in a format like: 'pn'(at row:r, col: c).+showPNwithLoc::PName->String+showPNwithLoc pn+  = let (SrcLoc _ _ r c)=srcLoc pn+    in  " '"++pNtoName pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")"+++----------------------------------------------------------------------------------+-- | Default identifier in the PName format.+defaultPN::PName+defaultPN=PN (UnQual "unknown") (G (PlainModule "unknown") "--" (N Nothing)) :: PName++-- | Default identifier in the PNT format.+defaultPNT::PNT+defaultPNT=PNT defaultPN Value  (N Nothing) :: PNT ++-- | Default module name.+defaultModName::ModuleName+defaultModName = PlainModule "unknown"++-- | Default expression.+defaultExp::HsExpP+defaultExp=TiDecorate.Exp (HsId (HsVar defaultPNT))++-- | Default expression for untyped AST+defaultExpUnTyped::HsExpI PNT+defaultExpUnTyped = PosSyntax.Exp (HsId (HsVar defaultPNT))++-- | Default pattern.+defaultPat::HsPatP+defaultPat=TiDecorate.Pat (HsPId (HsVar defaultPNT))++------------------------------------------------------------------------------------++-- | From PNT to PName.+pNTtoPN :: PNT->PName+pNTtoPN (PNT pname _ _)=pname++-- | From PName to Name. This function ignores the qualifier.+pNtoName::PName->String+pNtoName (PN (UnQual i) orig)=i+pNtoName (PN (Qual modName i) orig)=i   ++-- | From PNT to Name. This function ingnores the qualifier.+pNTtoName::PNT->String+pNTtoName=pNtoName.pNTtoPN+----------------------------------------------------------------------------------++class (Term t) => HasModName t where++    -- | Fetch the module name from an identifier.+    hasModName :: t->Maybe ModuleName++instance HasModName PNT  where++    hasModName (PNT (PN _ (G modName s1 loc)) _ _)=Just modName+    hasModName _ =Nothing   ++instance HasModName PName where+  +    hasModName (PN _ (G modName s1 loc))=Just modName+    hasModName _ =Nothing++----------------------------------------------------------------------+-- | Compose a PNT form a String.+nameToPNT::String->PNT+nameToPNT id =(PNT (PN (UnQual id) (G (PlainModule "unknown") id+                 (N (Just loc0)))) Value (N (Just loc0)))++-- | Compose a PName from String.+nameToPN::String->PName+nameToPN id =(PN (UnQual id) (G (PlainModule "unknown") id (N (Just loc0))))++-- | Compose a PNT from a PName and the PName's name space Information+pNtoPNT::PName->IdTy PId->PNT+pNtoPNT pname ty =  PNT pname ty (N (Just loc0))++-- | If an expression consists of only one identifier then return this identifier in the PNT format,+--  otherwise return the default PNT.+expToPNT::HsExpP->PNT+expToPNT (TiDecorate.Exp (HsId (HsVar pnt)))=pnt +expToPNT (TiDecorate.Exp (HsParen e))=expToPNT e +expToPNT _ =defaultPNT++-- | If an expression consists of only one identifier then return this identifier in the PName format,+--   otherwise returns the default PName. +expToPN::HsExpP->PName+expToPN =pNTtoPN.expToPNT++-- | Compose an expression from a String.+nameToExp ::String ->HsExpP+nameToExp name+    =TiDecorate.Exp (HsId (HsVar (PNT (PN (UnQual name) (UniqueNames.S loc0)) Value (N (Just loc0)))))++-- | Compose an expression from a pName.+pNtoExp::PName->HsExpP+pNtoExp pn =TiDecorate.Exp (HsId (HsVar (PNT pn  Value (N (Just loc0)))))++-- | If a pattern consists of only one identifier then return this identifier in the PNT format,+--  otherwise returns the default PNT. +patToPNT::HsPatP->PNT+patToPNT (TiDecorate.Pat (HsPId (HsVar pnt)))= pnt+patToPNT (TiDecorate.Pat (HsPParen p))=patToPNT p+patToPNT _=defaultPNT++-- | If a pattern consists of only one identifier then returns this identifier in the PName format,+--   otherwise returns the default PName.+patToPN::HsPatP->PName+patToPN=pNTtoPN.patToPNT++-- | Compose a pattern from a String.+nameToPat::String->HsPatP+nameToPat name+    =TiDecorate.Pat (HsPId (HsVar (PNT (PN (UnQual name) (UniqueNames.S loc0)) Value (N (Just loc0)))))++-- | Compose a pattern from a pName.+pNtoPat :: PName -> HsPatP+pNtoPat pname+    =let loc=srcLoc pname+     in (TiDecorate.Pat (HsPId (HsVar (PNT pname Value (N (Just loc))))))+---------------------------------------------------------------------------+++-- |Create a new name base on the old name. Suppose the old name is 'f', then +--  the new name would be like 'f_i' where 'i' is an integer.+mkNewName::String      -- ^ The old name+          ->[String]   -- ^ The set of names which the new name cannot take+          ->Int        -- ^ The posfix value+          ->String     -- ^ The result+mkNewName oldName fds init+  =let newName=if init==0 then oldName+                          else oldName++"_"++ show init+   in if elem newName fds+        then mkNewName oldName fds (init+1)+        else newName ++-- | Return the identifier's defining location.+defineLoc::PNT->SrcLoc+defineLoc (PNT pname _ _) = srcLoc pname++-- | Return the identifier's source location.+useLoc::PNT->SrcLoc+useLoc (PNT pname _ (N (Just loc))) = loc+useLoc (PNT _ _ _ )                 = loc0++-- | Return True if the identifier is used in the RHS if a function\/pattern binding.+isUsedInRhs::(Term t)=>PNT->t->Bool+isUsedInRhs pnt t= useLoc pnt /= defineLoc pnt  && not (notInLhs pnt t)+  where+    notInLhs pnt+     = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inMatch+                                                     `adhocTU` inDecl)))+     where+      inMatch ((HsMatch loc1 name pats rhs ds)::HsMatchP)+         | isJust (find (sameOccurrence pnt) [name]) = Just True+      inMatch _ =Nothing++      inDecl ((TiDecorate.Dec (HsTypeSig loc is c tp))::HsDeclP)+        |isJust (find (sameOccurrence pnt) is)   = Just True+      inDecl _ =Nothing    ++-- | Return True is the identifier is unqualifiedly used in the given syntax phrase.+usedWithoutQual::(Term t)=>String->t->Bool+usedWithoutQual name t+   =(fromMaybe False) (applyTU (once_tdTU (failTU `adhocTU` worker)) t)+      where+         worker (pnt::PNT)+           |pNTtoName pnt ==name && isUsedInRhs pnt t && not (isQualifiedPN (pNTtoPN pnt)) +          = Just True+         worker _ =Nothing++-- |Find the identifier(in PNT format) whose start position is (row,col) in the+-- file specified by the fileName, and returns defaultPNT is such an identifier does not exist.++locToPNT::(Term t)=>String      -- ^ The file name +                    ->(Int,Int) -- ^ The row and column number               +                    ->t         -- ^ The syntax phrase+                    ->PNT       -- ^ The result+locToPNT  fileName (row, col) +  =(fromMaybe defaultPNT). applyTU (once_buTU (failTU `adhocTU` worker))+     where +        worker pnt@(PNT pname ty (N (Just (SrcLoc fileName1 _ row1 col1))))+           |fileName1==fileName && (row1,col1) == (row,col) =Just pnt+        worker _ =Nothing ++++-- | The same as locToPNT, except that it returns the identifier in the PName format.+locToPN::(Term t)=>String->(Int,Int)->t->PName+locToPN fileName pos = pNTtoPN.(locToPNT fileName pos)++++-- | Given the syntax phrase (and the token stream), find the largest-leftmost expression contained in the+--  region specified by the start and end position. If no expression can be found, then return the defaultExp.+locToExp::(Term t) => RefacTITypeSyn.SimpPos   -- ^ The start position.+                  -> RefacTITypeSyn.SimpPos    -- ^ The end position.+                  -> [PosToken]         -- ^ The token stream which should at least contain the tokens for t.+                  -> t                  -- ^ The syntax phrase.+                  -> HsExpP             -- ^ The result.+locToExp beginPos endPos toks t+  = fromMaybe defaultExp $ applyTU (once_tdTU (failTU `adhocTU` exp)) t+     where+       {- exp (e@(Exp (HsDo stmts))::HsExpP)+         | filter inScope (map (getStartEndLoc toks) (getStmtList stmts))/=[]+         = do let atoms = filter (\atom->inScope (getStartEndLoc toks atom)) (getStmtList stmts)+                  atoms'= reverse (dropWhile (not.isQualifierOrLastAtom) (reverse atoms))+              if atoms'==[] +                  then fail "Expession not selected"+                  else do stmts' <-atoms2Stmt atoms'  +                          Just (Exp (HsDo stmts')) -}+        exp (e::HsExpP)+         |inScope e = Just e+        exp _ =Nothing                     +             +        inScope e +          = let (startLoc, endLoc) +                 = if expToPNT e /= defaultPNT +                    then let (SrcLoc _ _ row col) = useLoc (expToPNT e)+                         in ((row,col), (row,col))+                    else getStartEndLoc toks e+            in (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && endLoc<=endPos   ++        isQualifierOrLastAtom (HsQualifierAtom e) = True+        isQualifierOrLastAtom (HsLastAtom e)      = True+        isQualifierOrLastAtom _ = False + +        atoms2Stmt [HsQualifierAtom e]          = return (HsLast e)+        atoms2Stmt [HsLastAtom e]               = return (HsLast e)+        atoms2Stmt (HsGeneratorAtom s p e : ss) = HsGenerator s p e # atoms2Stmt ss+        atoms2Stmt (HsLetStmtAtom ds : ss)      = HsLetStmt ds # atoms2Stmt ss+        atoms2Stmt (HsQualifierAtom e : ss)     = HsQualifier e # atoms2Stmt ss+        atoms2Stmt _ = fail "last statement in a 'do' expression must be an expression"+  +---------------------------------------------------------------------------------------+-- | Collect the identifiers (in PName format) in a given syntax phrase.     +hsPNs::(Term t)=> t->[PName]+hsPNs=(nub.ghead "hsPNs").applyTU (full_tdTU (constTU [] `adhocTU` inPnt)) +  where +     inPnt (PNT pname ty loc) = return [pname]++-- | Collect the identifiers (in PNT format) in a given syntax phrase.+hsPNTs ::(Term t)=>t->[PNT]+hsPNTs =(nub.ghead "hsPNTs").applyTU (full_tdTU (constTU [] `adhocTU` inPnt))+   where+     inPnt pnt@(PNT _  _ _) = return [pnt]+++-- |Find those declarations(function\/pattern binding and type signature) which define the specified PNames.+--incTypeSig indicates whether the corresponding type signature will be included.+definingDecls::[PName]         -- ^ The specified identifiers.+            ->[HsDeclP]        -- ^ A collection of declarations.+            ->Bool             -- ^ True means to include the type signature.+            ->Bool             -- ^ True means to look at the local declarations as well. +            ->[HsDeclP]        -- ^ The result.+definingDecls pns ds incTypeSig recursive=concatMap defines ds  +  where+   defines decl+     =if recursive+        then ghead "defines" $ applyTU (stop_tdTU (failTU `adhocTU` inDecl)) decl+        else defines' decl+     where+      inDecl (d::HsDeclP)+        |defines' d /=[] =return $ defines' d+      inDecl _=mzero ++      defines' decl@(TiDecorate.Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) _ _ _):ms))) +        |isJust (find (==pname) pns) = [decl]+      defines' decl@(TiDecorate.Dec (HsPatBind loc p rhs ds))    ---CONSIDER AGAIN----+        |(hsPNs p) `intersect` pns /=[] = [decl]+      defines' decl@(TiDecorate.Dec (HsTypeSig loc is c tp))     --handle cases like  a,b::Int +        |(map pNTtoPN is) `intersect` pns /=[]+        =if incTypeSig +           then [(TiDecorate.Dec (HsTypeSig loc (filter (\x->isJust (find (==pNTtoPN x) pns)) is) c tp))]+           else []+      defines' decl@(TiDecorate.Dec (HsDataDecl loc c tp cons i))+       = if checkCons cons == True then [decl]+                                   else []+                                     +             where+               checkCons [] = False+               checkCons ((HsConDecl loc i c (PNT pname _ _) t):ms)+                 | isJust (find (==pname) pns) = True+                 | otherwise = checkCons ms+      defines' _ =[]   ++-- | Return True if the  function\/pattern binding defines the specified identifier.+defines::PName->HsDeclP->Bool+defines pn decl@(TiDecorate.Dec (HsFunBind loc ((HsMatch loc1 (PNT pname ty loc2) pats rhs ds):ms))) + = pname == pn+defines pn decl@(TiDecorate.Dec (HsPatBind loc p rhs ds)) = elem pn (hsPNs p)+defines _ _= False+++-- | Return True if the declaration defines the type signature of the specified identifier.+definesTypeSig :: PName -> HsDeclP -> Bool+definesTypeSig pn (TiDecorate.Dec (HsTypeSig loc is c tp))=elem pn (map pNTtoPN is)  +definesTypeSig _  _ =False+++-- | Return True if the declaration defines the type signature of the specified identifier.+isTypeSigOf :: PNT -> HsDeclP -> Bool+isTypeSigOf pnt (TiDecorate.Dec (HsTypeSig loc is c tp))= elem pnt is  +isTypeSigOf _  _ =False+++-- | Return the list of identifiers (in PName format) defined by a function\/pattern binding.+definedPNs::HsDeclP->[PName]+definedPNs (TiDecorate.Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) _ _ _):_))) =[pname]+definedPNs (TiDecorate.Dec (HsPatBind _ p _ _)) =hsPNs p+definedPNs (TiDecorate.Dec (HsDataDecl _ _ _ cons _) )+   = getCons cons +       where+         getCons [] = []+         getCons ((HsConDecl _ _ _ (PNT pname _ _) _):ms)+           = pname : (getCons ms)+         getCons ((HsRecDecl _ _ _ (PNT pname _ _) _):ms)+           = pname : (getCons ms)  +         getCons _ = []+definedPNs _=[] +++-- |Return True if the given syntax phrase contains any free variables.+hasFreeVars::(Term t)=>t->Bool+hasFreeVars t = fromMaybe False (do (f,_)<-hsFreeAndDeclaredPNs t+                                    if f/=[] then Just True+                                             else Nothing) ++{- Remove source location information in the syntax tree. that is to replace all+   source locations by default location: loc0 -}       +-- | Remove source location information in the syntax tree.+rmLocs :: (Term t)=> t->t +rmLocs t =runIdentity (applyTP (full_tdTP (idTP `adhocTP` exp+                                                `adhocTP` pnt+                                                `adhocTP` alt+                                                `adhocTP` lit)) t) +   where +         exp ((TiDecorate.Exp (HsNegApp loc e)) ::HsExpP)=return (TiDecorate.Exp (HsNegApp loc0 e))+         exp (TiDecorate.Exp (HsExpTypeSig loc e c t))=return (TiDecorate.Exp (HsExpTypeSig loc0 e c t))+         exp x=return x ++         alt ((HsAlt loc p e ds)::HsAltP)=return (HsAlt loc0 p e ds)++         lit (HsInt int) = return (HsInt int)+         lit (HsFrac rat)= return (HsFrac rat)++         pnt (PNT pname ty _)= return (PNT pname ty (N (Just loc0)))++-- | Change the absolute define locations of local variables to relative ones,+--   so that equality between expressions can be compared via alpha-renaming.++toRelativeLocs::(Term t)=>t->t+toRelativeLocs e = runIdentity (applyTP (full_tdTP (idTP `adhocTP` inLoc)) e)+  where+    inLoc (SrcLoc f c row col)+      | elem (row,col) defLocs+          = let index=fromJust (elemIndex (row,col) defLocs) + 1 +            in return (SrcLoc f index index index)+    inLoc loc = return loc++    defLocs= ((nub.ghead "toRelativeLoc").applyTU (full_tdTU (constTU [] +                                                      `adhocTU` inPnt ))) e+        where+         inPnt pnt@(PNT pn ty loc)+            |defineLoc pnt == useLoc pnt= return [(\(SrcLoc _ _ r c)->(r,c)) (srcLoc pn)]+         inPnt _ = return []+         +    +------------------------------------------------------------------------------------------ +-- | Replace the name (and qualifier if specified) by a new name (and qualifier) in a PName.+--   The function does not modify the token stream.+replaceNameInPN::Maybe ModuleName    -- ^ The new qualifier+                 ->PName             -- ^ The old PName+                 ->String            -- ^ The new name +                 ->PName             -- ^ The result +replaceNameInPN qualifier (PN (UnQual s)(UniqueNames.S loc))  newName+  = if isJust qualifier then (PN (Qual (fromJust qualifier) newName) (UniqueNames.S loc))+                        else (PN (UnQual newName) (UniqueNames.S loc)) +replaceNameInPN qualifier (PN (Qual modName  s)(UniqueNames.S loc))  newName+  = if isJust qualifier  then (PN (Qual (fromJust qualifier) newName)(UniqueNames.S loc))+                         else (PN (Qual modName newName) (UniqueNames.S loc))+replaceNameInPN qualifier (PN (UnQual s) (G modName s1 loc))  newName+  = if isJust qualifier then (PN (Qual (fromJust qualifier)  newName) (G modName newName loc))+                        else (PN (UnQual newName) (G modName newName loc)) +replaceNameInPN qualifier (PN (Qual modName s) (G modName1 s1 loc))  newName+  =if isJust qualifier then (PN (Qual (fromJust qualifier) newName) (G modName1 newName loc)) +                       else (PN (Qual modName newName) (G modName1 newName loc))++-- | Rename each occurrences of the identifier in the given syntax phrase with the new name.+--   If the Bool parameter is True, then modify both the AST and the token stream, otherwise only modify the AST.++{-+renamePN::(Term t)+           =>PName               -- ^ The identifier to be renamed.+             ->Maybe ModuleName  -- ^ The qualifier+             ->String            -- ^ The new name +             ->Bool              -- ^ True means modifying the token stream as well.+             ->t                 -- ^ The syntax phrase+             ->m t  +-}++renamePN::((MonadState (([PosToken], Bool), t1) m),Term t)+           =>PName               -- ^ The identifier to be renamed.+             ->Maybe ModuleName  -- ^ The qualifier+             ->String            -- ^ The new name +             ->Bool              -- ^ True means modifying the token stream as well.+             ->t                 -- ^ The syntax phrase+             ->m t  ++renamePN oldPN qualifier newName updateToks t+  = applyTP (full_tdTP (adhocTP idTP rename)) t+  where+    rename  pnt@(PNT pn ty (N (Just (SrcLoc fileName c  row col))))+     | (pn ==oldPN) && (srcLoc oldPN == srcLoc pn)+     = do if updateToks  +           then  do ((toks,_),others)<-get                           +                    let toks'=replaceToks toks (row,col) (row,col)+                              [mkToken Varid  (row,col) ((render.ppi) (replaceName pn  newName))]+                    put ((toks', modified),others)+                    return (PNT (replaceName pn newName) ty (N (Just (SrcLoc fileName c  row col))))+           else return (PNT (replaceName pn newName) ty (N (Just (SrcLoc fileName c  row col))))+      where +        replaceName = if isJust qualifier && canBeQualified pnt t +                        then replaceNameInPN qualifier+                        else replaceNameInPN Nothing       +    rename x = return x +  +-- | Return True if the identifier can become qualified.+canBeQualified::(Term t)=>PNT->t->Bool+canBeQualified pnt t+  = isTopLevelPNT pnt && isUsedInRhs pnt t && not (findPntInImp pnt t) +  where +    findPntInImp pnt +      = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inImp)))+      where +       inImp ((HsImportDecl loc modName qual  as h)::HsImportDeclP)+        |findEntity pnt h = Just True+       inImp _ = Nothing+  + +-- | Return True if the identifier(in PNT format) occurs in the given syntax phrase.+findPNT::(Term t)=>PNT->t->Bool  +findPNT pnt +  = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))+  where+    worker (pnt1::PNT)+      | sameOccurrence pnt pnt1 =Just True+    worker _ =Nothing  ++-- | Return True if the identifier (in PName format) occurs in the given syntax phrase.+findPN::(Term t)=>PName->t->Bool+findPN pn +  =(fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where +        worker (pn1::PName)+           |pn == pn1 && srcLoc pn == srcLoc pn1 = Just True +        worker _ =Nothing ++-- | Return True if any of the specified PNames ocuur in the given syntax phrase.+findPNs::(Term t)=>[PName]->t->Bool +findPNs pns +   =(fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where +        worker (pn1::PName)+           |elem pn1 pns = Just True+        worker _ =Nothing  ++++----------------------------------------------------------------------------------------+-- | Check whether the specified identifier is declared in the given syntax phrase t,+-- if so, rename the identifier by creating a new name automatically. If the Bool parameter +-- is True, the token stream will be modified, otherwise only the AST is modified. ++{-+autoRenameLocalVar::(MonadPlus m, Term t)+                    =>Bool         -- ^ True means modfiying the token stream as well.  +                     ->PName       -- ^ The identifier.+                     ->t           -- ^ The syntax phrase.+                     -> m t        -- ^ The result.+-}+autoRenameLocalVar::(MonadPlus m, (MonadState (([PosToken], Bool), (Int,Int)) m), Term t)+                    =>Bool         -- ^ True means modfiying the token stream as well.  +                     ->PName       -- ^ The identifier.+                     ->t           -- ^ The syntax phrase.+                     -> m t        -- ^ The result.+++autoRenameLocalVar updateToks pn +  =applyTP (once_buTP (failTP `adhocTP` renameInMatch +                              `adhocTP` renameInPat+                              `adhocTP` renameInExp+                              `adhocTP` renameInAlt+                              `adhocTP` renameInStmts))  +      where +         renameInMatch (match::HsMatchP)+           |isDeclaredIn pn match=worker match+         renameInMatch _ =mzero+     +         renameInPat (pat::HsDeclP)+          |isDeclaredIn pn pat=worker pat                 +         renameInPat _ =mzero+     +         renameInExp (exp::HsExpP)+          |isDeclaredIn pn exp=worker exp                 +         renameInExp _ =mzero+ +         renameInAlt (alt::HsAltP)+          |isDeclaredIn pn alt=worker alt                 +         renameInAlt _ =mzero+       +         renameInStmts (stmt::HsStmtP)+          |isDeclaredIn pn stmt=worker stmt+         renameInStmts _=mzero+         +         worker t =do (f,d)<-hsFDNamesFromInside t+                      ds<-hsVisibleNames pn (hsDecls t)+                      let newName=mkNewName (pNtoName pn) (nub (f `union` d `union` ds)) 1+                      if updateToks+                        then renamePN pn Nothing newName True t +                        else renamePN pn Nothing newName False t     ++-------------------------------------------------------------------------------------+-- | Add a guard expression to the RHS of a function\/pattern definition. If a guard already+--   exists in the RHS, the new guard will be added to the beginning of the existing one.+addGuardsToRhs::(MonadState (([PosToken], Bool), (Int,Int)) m)+                => RhsP     -- ^ The RHS of the declaration.+                -> HsExpP   -- ^ The guard expression to be added.+                -> m RhsP     -- ^ The result.+addGuardsToRhs (HsBody e) guardExp +  = do ((toks,_), (v1,v2)) <-get+       let (startPos', _) = startEndLoc toks e+           (toks1,toks2) = break (\t->tokenPos t==startPos') toks+           reversedToks1BeforeEqOrArrow = dropWhile (\t->not (isEqual t || isArrow t)) (reverse toks1) +           eqOrArrowTok = ghead "addGuardsToRhs"  reversedToks1BeforeEqOrArrow+           startPos = tokenPos eqOrArrowTok +           offset = lengthOfLastLine (reverse (gtail "addGuardsToRhs" reversedToks1BeforeEqOrArrow))+           newCon = "|"++(render.ppi) guardExp ++ "\n" ++ replicate offset ' '++ tokenCon eqOrArrowTok+           newToks = tokenise (Pos 0 v1 1) 0  False newCon+           toks' = replaceToks toks startPos startPos newToks+       put ((toks',modified), ((tokenRow (glast "addFormalParams" newToks) -10), v2))+   --    (guardExp',_) <- addLocInfo (guardExp, newToks)    +       return $ HsGuard [(loc0, guardExp, e)]++addGuardsToRhs (HsGuard gs) guardExp+  = do newGuards <- mapM (addGuard guardExp) gs+       return (HsGuard newGuards)+   where +   addGuard guardExp (loc, e1, e2)+     = do (e', _)<-updateToks e1 (TiDecorate.Exp (HsInfixApp guardExp (HsVar (nameToPNT "&&")) e1)) prettyprint+          return (loc, e', e2)+++------------------------------------------------------------------------------------------------------+{-+addParamsToDecls::(MonadPlus m) +               => [HsDeclP]   -- ^ A declaration list where the function is defined and\/or used.+                  ->PName     -- ^ The function name.+                  ->[PName]   -- ^ The parameters to be added.+                  ->Bool      -- ^ Modify the token stream or not.+                  ->m [HsDeclP] -- ^ The result. +-}++addParamsToDecls::(MonadPlus m, (MonadState (([PosToken], Bool), (Int,Int)) m))+               => [HsDeclP]   -- ^ A declaration list where the function is defined and\/or used.+                  ->PName     -- ^ The function name.+                  ->[PName]   -- ^ The parameters to be added.+                  ->Bool      -- ^ Modify the token stream or not.+                  ->m [HsDeclP] -- ^ The result.+ +addParamsToDecls decls pn paramPNames modifyToks+   = if (paramPNames/=[])+        then mapM addParamToDecl decls+        else return decls +  where +   addParamToDecl (TiDecorate.Dec (HsFunBind loc matches@((HsMatch _ fun pats rhs ds):ms)))+    | pNTtoPN fun == pn+    = do matches'<-mapM addParamtoMatch matches +         return (TiDecorate.Dec (HsFunBind loc matches'))+      where +       addParamtoMatch (HsMatch loc  fun  pats rhs  decls) +        = do rhs'<-addActualParamsToRhs pn paramPNames rhs +             let pats' = map pNtoPat paramPNames +             pats'' <- if modifyToks then do (p, _)<-addFormalParams fun pats'+                                             return p+                                     else return pats' +             return (HsMatch loc  fun  (pats'++pats)  rhs' decls)++   addParamToDecl (TiDecorate.Dec (HsPatBind loc p rhs ds))+     |patToPN p == pn +       = do rhs'<-addActualParamsToRhs pn paramPNames rhs+            let pats' = map pNtoPat paramPNames +            pats'' <- if modifyToks  then do (p, _) <-addFormalParams p pats'+                                             return p+                                     else return pats'                        +            return (TiDecorate.Dec (HsFunBind loc [HsMatch loc (patToPNT p) pats' rhs ds]))+   addParamToDecl x=return x + +   addActualParamsToRhs pn paramPNames+    = applyTP (stop_tdTP (failTP `adhocTP` worker))  +     where                   +       worker exp@(TiDecorate.Exp (HsId (HsVar (PNT pname ty loc))))+        | pname==pn+         = do let newExp=TiDecorate.Exp (HsParen (foldl addParamToExp exp (map pNtoExp paramPNames)))+              if modifyToks then do (newExp', _) <- updateToks exp newExp prettyprint+                                    return newExp' +                            else return newExp+       worker x =mzero ++       addParamToExp  exp param=(TiDecorate.Exp (HsApp exp param))++ +-------------------------------------------------------------------++-- | Remove the first n parameters of a given identifier in an expression.+rmParams:: (MonadPlus m,MonadState (([PosToken], Bool), (Int,Int)) m)=>+             PNT          -- ^ The identifier whose parameters are to be removed.+             ->Int        -- ^ Number of parameters to be removed.+             ->HsExpP     -- ^ The original expression.+             ->m HsExpP   -- ^ The result expression.+rmParams pnt n exp +  = if n==0 then return exp+            else do exp'<-rmOneParam pnt exp+                    rmParams pnt (n-1) exp' +   where +         rmOneParam pnt= applyTP (stop_tdTP (failTP `adhocTP` inExp))+       +         inExp (exp@(TiDecorate.Exp (HsParen (TiDecorate.Exp (HsApp e1 e2))))::HsExpP)+          ---dfd+           |sameOccurrence (expToPNT e1) pnt +            =do updateExp exp e1     +         inExp exp@(TiDecorate.Exp (HsApp e1 e2))+           | sameOccurrence (expToPNT e1) pnt+            =do updateExp exp e1+         inExp  _=mzero++         updateExp exp e1 +           = do ((toks,_),others)<-get     --handle the case like '(fun x) => fun "+                let (startPos,endPos)=getStartEndLoc toks exp+                    toks'=replaceToks toks startPos endPos $ getToks (getStartEndLoc toks e1) toks+                put ((toks',modified),others)+                return e1  +             +-------------------------------------------------------------------------------------------------------+++{-A simple function binding satisfies : 1. all parameters are variables+                                        2. only one match(equation)+                                        3. The rhs of the match is not in guard style.+  that is:+   HsFunBind SrcLoc ((HsMatch SrcLoc i [var] (HsBody e) ds):[]) ds++  If a function binding is not a simple function binding, then convert it into a simple binding +  using Case or IfThenElse expressions like this:+    case1: there are multi matches => case expression+    case2: there is only one match, however the parameters are not simple variables =>case expression.+    case3: there is only one match and the parameters are all simple variables, however there is a guard+           in Rhs => If then else++  In case of pattern binding: if there is guard in its Rhs, then convert it into IfThenElse style. -}++                              +-- | If a function\/pattern binding then convert it into a simple binding using case and\/or if-then-else expressions.     +-- A simple function\/pattern binding should satisfy: a) all the paraneters are simple variables; b). only has one equation; +-- c). the RHS does not have guards. This function DOES NOT modify the token stream not AST.+simplifyDecl::(Monad m)=>HsDeclP->m HsDeclP+simplifyDecl decl+      |isFunBind decl =if (multiMatches decl) || (singleMatchWithComplexParams decl)+                           then matchesToCase decl+                           else return (guardToIfThenElse decl)+      |isPatBind decl=return (guardToIfThenElse  decl)++      |otherwise      = return decl+   where++      multiMatches (TiDecorate.Dec (HsFunBind loc matches))=length matches>1+      multiMatches _ = False ++      singleMatchWithComplexParams (TiDecorate.Dec (HsFunBind loc matches@((HsMatch loc1 pnt pats rhs ds):ms)))+            =length matches==1 && any (==defaultPN) (map patToPN pats)+      singleMatchWithComplexParams _ =False++      --convert a multi-match function declaration into a single-match declration using case expression.+      matchesToCase decl@(TiDecorate.Dec (HsFunBind loc matches@((HsMatch loc1 pnt pats rhs ds):ms)))+        =do params<-mkNewParamPNames (length pats)+            exp<-pNamesToExp params+            return (TiDecorate.Dec (HsFunBind loc [(HsMatch loc1 pnt (map pNtoPat params)+                      (HsBody (TiDecorate.Exp (HsCase exp (map matchToAlt matches)))) (Decs [] ([], [])))]))++      --make n new parameters like [x_0,x_1, ...,x_n]+      mkNewParamPNames n=mkNewParamPNames' n []+              where mkNewParamPNames' n pNames+                         =if n==0 then return pNames+                                     else do let pn'= PN (UnQual  ("x_"++show (n-1))) (UniqueNames.S loc0)+                                             mkNewParamPNames' (n-1) (pn':pNames)+                                        +      matchToAlt ((HsMatch loc1 pnt pats rhs ds)::HsMatchP)=HsAlt loc0 (listToTuple pats) rhs ds+        where+         listToTuple pats=if (length pats)==1 then ghead "listToTuple" pats   --no problem with head+                                              else (TiDecorate.Pat (HsPTuple loc0 pats))++      pNamesToExp pns@(p:ps)=if ps==[] then return $ pNtoExp p+                                        else  do let exp'=map pNtoExp pns+                                                 return (TiDecorate.Exp (HsTuple exp')) +     +      guardToIfThenElse decl= case decl of+          (TiDecorate.Dec (HsPatBind loc p g@(HsGuard gs) ds))->(TiDecorate.Dec (HsPatBind loc p (rmGuard g) ds))+          (TiDecorate.Dec (HsFunBind loc ((HsMatch loc1 pnt pats  g@(HsGuard gs) ds):[]))) ->+                            (TiDecorate.Dec (HsFunBind loc ((HsMatch loc1 pnt pats (rmGuard g) ds):[])))+          _ ->decl+           +          where+           rmGuard ((HsGuard gs)::RhsP)+             = let (_,e1,e2)=glast "guardToIfThenElse" gs+               in  if ((pNtoName.expToPN) e1)=="otherwise" +                   then  HsBody (foldl mkIfThenElse e2 (tail(reverse gs)))+                   else  HsBody (foldl mkIfThenElse defaultElse (reverse gs)) +           +           mkIfThenElse e (_,e1, e2)=(TiDecorate.Exp (HsIf e1 e2 e)) ++           defaultElse=(TiDecorate.Exp (HsApp (TiDecorate.Exp (HsId (HsVar (PNT (PN (UnQual "error") (G (PlainModule "Prelude") "error" +                        (N (Just loc0)))) Value (N (Just loc0)))))) (TiDecorate.Exp (HsLit loc0 (HsString "UnMatched Pattern")))))+            ++-----------------------------------------------------------------------------------------+-- | Collect those data constructors that occur in the given syntax phrase, say t. In the result, +--   the first list contains the data constructors that are declared in other modules, and the second+--   list contains the data constructors that are declared in the current module.+hsDataConstrs::Term t=>ModuleName              -- ^ The name of the module which 't' belongs to.+                     -> t                      -- ^ The given syntax phrase.+                     ->([PName],[PName])       -- ^ The result.+hsDataConstrs modName  +  = ghead "hsDataConstrs". (applyTU (stop_tdTU (failTU `adhocTU` pnt)))  +  where+    pnt (PNT pname (ConstrOf _  _) _)+      = if hasModName pname==Just modName +          then return ([],[pname])+          else return ([pname],[])+    pnt _ = mzero+++-- | Collect those type constructors and class names that occur in the given syntax phrase, say t.+--   In the result, the first list contains the type constructor\/classes which are+--   declared in other modules, and the second list contains those type constructor\/classes+--  that are declared in the current module.++hsTypeConstrsAndClasses::Term t=>ModuleName                  -- ^ The name of the module which 't' belongs to.+                               -> t                          -- ^ The given syntax phrase.+                               -> ([PName],[PName])          -- ^ The result.+hsTypeConstrsAndClasses modName+  = ghead "hsTypeConstrAndClasses".(applyTU (stop_tdTU (failTU `adhocTU` pnt))) +  where +    pnt (PNT (PN i (G  modName1 id loc)) (Type _) _)+      = if modName == modName1+                     then return ([],[(PN i (G  modName id loc))])+                     else return ([(PN i (G  modName id loc))], [])+    pnt (PNT pname (TypedIds.Class _ _) _)=if hasModName pname==Just modName +                                 then return ([],[pname])+                                 else return ([pname],[])+    pnt _ =mzero+++-- |Collect those type variables that are declared in a given syntax phrase t.+-- In the returned result, the first list is always be empty.+hsTypeVbls::(Term t) => t -> ([PName],[PName])+hsTypeVbls =ghead "hsTypeVbls".(applyTU (stop_tdTU (failTU `adhocTU` pnt))) +  where +    pnt (PNT (PN i (UniqueNames.S loc)) (Type _) _) = return ([], [(PN i (UniqueNames.S loc))])+    pnt _ =mzero+++-- |Collect the class instances of the spcified class from the given syntax phrase. In the result,+-- the first list contains those class instances which are declared in other modules, +-- and the second list contains those class instances that are declared in the current module.+hsClassMembers::Term t => String               -- ^ The class name.+                        ->ModuleName           -- ^ The module name.+                        ->t                    -- ^ The syntax phrase.+                        ->([PName],[PName])    -- ^ The result.+hsClassMembers className modName +    = ghead "hsClassMembers". (applyTU (stop_tdTU (failTU `adhocTU` pnt))) +         where+            pnt(PNT pname (MethodOf i _ _) _) -- Claus+                | pNtoId i==className+                  = if hasModName pname == Just modName +                      then return ([],[pname])+                      else return ([pname],[])+            pnt _ = mzero   +            +            pNtoId :: PN (HsName.Id) ->String+            pNtoId (PN i orig)=i++------------------------------------------------------------------------------------------+-- | Collect the free and declared variables (in the PName format) in a given syntax phrase t.+-- In the result, the first list contains the free variables, and the second list contains the declared variables.+hsFreeAndDeclaredPNs:: (Term t, MonadPlus m)=> t-> m ([PName],[PName])+hsFreeAndDeclaredPNs t=do (f,d)<-hsFreeAndDeclared' t+                          return (nub f, nub d)+   where +          hsFreeAndDeclared'=applyTU (stop_tdTU (failTU  `adhocTU` exp+                                                         `adhocTU` pat+                                                         `adhocTU` match+                                                         `adhocTU` patBind+                                                         `adhocTU` alt+                                                         `adhocTU` decls+                                                         `adhocTU` stmts+                                                         `adhocTU` recDecl))  +                          +          exp (TiDecorate.Exp (HsId (HsVar (PNT pn _ _))))=return ([pn],[])+          exp (TiDecorate.Exp (HsId (HsCon (PNT pn _ _))))=return ([pn],[])+          exp (TiDecorate.Exp (HsInfixApp e1 (HsVar (PNT pn _ _)) e2))+              =addFree pn (hsFreeAndDeclaredPNs [e1,e2])+          exp (TiDecorate.Exp (HsLambda pats body))+              = do (pf,pd) <-hsFreeAndDeclaredPNs pats+                   (bf,_) <-hsFreeAndDeclaredPNs body+                   return ((bf `union` pf) \\ pd, [])+          exp (TiDecorate.Exp (HsLet decls exp))+              = do (df,dd)<- hsFreeAndDeclaredPNs decls+                   (ef,_)<- hsFreeAndDeclaredPNs exp +                   return ((df `union` (ef \\ dd)),[])+          exp (TiDecorate.Exp (HsRecConstr _  (PNT pn _ _) e))+               =addFree  pn  (hsFreeAndDeclaredPNs e)   --Need Testing+          exp (TiDecorate.Exp (HsAsPat (PNT pn _ _) e))+              =addFree  pn  (hsFreeAndDeclaredPNs e)  +          exp _ = mzero++          +          pat (TiDecorate.Pat (HsPId (HsVar (PNT pn _ _))))=return ([],[pn])+          pat (TiDecorate.Pat (HsPInfixApp p1 (PNT pn _ _) p2))=addFree pn (hsFreeAndDeclaredPNs [p1,p2])+          pat (TiDecorate.Pat (HsPApp (PNT pn _ _) pats))=addFree pn (hsFreeAndDeclaredPNs pats)+          pat (TiDecorate.Pat (HsPRec (PNT pn _ _) fields))=addFree pn (hsFreeAndDeclaredPNs fields)+          pat _ =mzero+                               ++          match ((HsMatch _ (PNT fun _ _)  pats rhs  decls)::HsMatchP)+            = do (pf,pd) <- hsFreeAndDeclaredPNs pats+                 (rf,rd) <- hsFreeAndDeclaredPNs rhs+                 (df,dd) <- hsFreeAndDeclaredPNs decls+                 return ((pf `union` ((rf `union` df) \\ (dd `union` pd `union` [fun]))),[fun])++         -------Added by Huiqing Li-------------------------------------------------------------------++          patBind ((TiDecorate.Dec (HsPatBind _ pat (HsBody rhs) decls))::HsDeclP)+             =do (pf,pd) <- hsFreeAndDeclaredPNs pat+                 (rf,rd) <- hsFreeAndDeclaredPNs rhs+                 (df,dd) <- hsFreeAndDeclaredPNs decls+                 return (pf `union` ((rf `union` df) \\(dd `union` pd)),pd)+          patBind _=mzero+         ------------------------------------------------------------------------------------------- ++          alt ((HsAlt _ pat exp decls)::(HsAlt (HsExpP) (HsPatP) HsDeclsP))+             = do (pf,pd) <- hsFreeAndDeclaredPNs pat+                  (ef,ed) <- hsFreeAndDeclaredPNs exp+                  (df,dd) <- hsFreeAndDeclaredPNs decls+                  return (pf `union` (((ef \\ dd) `union` df) \\ pd),[])+++          decls (ds :: [HsDeclP])+             =do (f,d) <-hsFreeAndDeclaredList ds+                 return (f\\d,d)+          +          stmts ((HsGenerator _ pat exp stmts) :: HsStmt (HsExpP) (HsPatP) HsDeclsP) -- Claus+             =do (pf,pd) <-hsFreeAndDeclaredPNs pat+                 (ef,ed) <-hsFreeAndDeclaredPNs exp+                 (sf,sd) <-hsFreeAndDeclaredPNs stmts+                 return (pf `union` ef `union` (sf\\pd),[]) -- pd) -- Check this ++          stmts ((HsLetStmt decls stmts) :: HsStmt (HsExpP) (HsPatP) HsDeclsP)+             =do (df,dd) <-hsFreeAndDeclaredPNs decls+                 (sf,sd) <-hsFreeAndDeclaredPNs stmts+                 return (df `union` (sf \\dd),[])+          stmts _ =mzero++          recDecl ((HsRecDecl _ _ _ _ is) :: HsConDeclI PNT (HsTypeI PNT) [HsTypeI PNT])+                =do let d=map pNTtoPN $ concatMap fst is+                    return ([],d)+          recDecl _ =mzero+            +       +          addFree free mfd=do (f,d)<-mfd+                              return ([free] `union` f, d)++          hsFreeAndDeclaredList l=do fds<-mapM hsFreeAndDeclaredPNs l+                                     return (foldr union [] (map fst fds),+                                             foldr union [] (map snd fds))++-- |The same as `hsFreeAndDeclaredPNs` except that the returned variables are in the String format.           +hsFreeAndDeclaredNames::(Term t, MonadPlus m)=> t->m([String],[String])+hsFreeAndDeclaredNames t =do (f1,d1)<-hsFreeAndDeclaredPNs t+                             return ((nub.map pNtoName) f1, (nub.map pNtoName) d1)++-----------------------------------------------------------------------------------------+{- |`hsFDsFromInside` is different from `hsFreeAndDeclaredPNs` in that: given an syntax phrase t,+    `hsFDsFromInside` returns not only the declared variables that are visible from outside of t,+     but also those declared variables that are visible to the main expression inside t.+-}+++hsFDsFromInside:: (Term t, MonadPlus m)=> t-> m ([PName],[PName])+hsFDsFromInside t = do (f,d)<-hsFDsFromInside' t+                       return (nub f, nub d)+   where +     hsFDsFromInside' = applyTU (once_tdTU (failTU  `adhocTU` mod+                                                    -- `adhocTU` decls+                                                     `adhocTU` decl+                                                     `adhocTU` match+                                                     `adhocTU` exp+                                                     `adhocTU` alt+                                                     `adhocTU` stmts ))+                                                    ++     mod ((HsModule loc modName exps imps ds)::HsModuleP)+        = hsFreeAndDeclaredPNs ds  ++ {-    decls (ds::[HsDeclP])                    --CHECK THIS.+       = hsFreeAndDeclaredPNs decls +-}+     match ((HsMatch loc1 (PNT fun _ _) pats rhs ds) ::HsMatchP)+       = do (pf, pd) <-hsFreeAndDeclaredPNs pats+            (rf, rd) <-hsFreeAndDeclaredPNs rhs+            (df, dd) <-hsFreeAndDeclaredPNs ds+            return (nub (pf `union` ((rf `union` df) \\ (dd `union` pd `union` [fun]))), +                    nub (pd `union` rd `union` dd `union` [fun]))++     decl ((TiDecorate.Dec (HsPatBind loc p rhs ds))::HsDeclP)+      = do (pf, pd)<-hsFreeAndDeclaredPNs p+           (rf, rd)<-hsFreeAndDeclaredPNs rhs+           (df, dd)<-hsFreeAndDeclaredPNs ds +           return (nub (pf `union` ((rf `union` df) \\ (dd `union` pd))),+                   nub ((pd `union` rd `union` dd)))++     decl (TiDecorate.Dec (HsFunBind loc matches))+         =do fds <-mapM hsFDsFromInside matches+             return (nub (concatMap fst fds), nub(concatMap snd fds))+   +     decl _ = mzero + +     exp ((TiDecorate.Exp (HsLet decls exp))::HsExpP)+          = do (df,dd)<- hsFreeAndDeclaredPNs decls+               (ef,_)<- hsFreeAndDeclaredPNs exp +               return (nub (df `union` (ef \\ dd)), nub dd)+     exp (TiDecorate.Exp (HsLambda pats body))+            = do (pf,pd) <-hsFreeAndDeclaredPNs pats+                 (bf,_) <-hsFreeAndDeclaredPNs body+                 return (nub ((bf `union` pf) \\ pd), nub pd)      +     exp _ = mzero++     alt ((HsAlt _ pat exp decls)::HsAltP)+         = do (pf,pd) <- hsFreeAndDeclaredPNs pat+              (ef,ed) <- hsFreeAndDeclaredPNs exp+              (df,dd) <- hsFreeAndDeclaredPNs decls+              return (nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), nub (pd `union` dd))      ++     stmts ((HsLetStmt decls stmts)::HsStmtP)+          = do (df,dd) <-hsFreeAndDeclaredPNs decls+               (sf,sd) <-hsFreeAndDeclaredPNs stmts+               return (nub (df `union` (sf \\dd)),[]) -- dd)++     stmts (HsGenerator _ pat exp stmts) +          = do (pf,pd) <-hsFreeAndDeclaredPNs pat+               (ef,ed) <-hsFreeAndDeclaredPNs exp+               (sf,sd) <-hsFreeAndDeclaredPNs stmts+               return (nub (pf `union` ef `union` (sf\\pd)),[]) -- pd)+     +     stmts _ = mzero    +++-- | The same as `hsFDsFromInside` except that the returned variables are in the String format+hsFDNamesFromInside::(Term t, MonadPlus m)=>t->m ([String],[String])+hsFDNamesFromInside t =do (f,d)<-hsFDsFromInside t+                          return ((nub.map pNtoName) f, (nub.map pNtoName) d)++------------------------------------------------------------------------------------------+-- | Same as `hsVisiblePNs' except that the returned identifiers are in String format.+hsVisibleNames:: (Term t1, Term t2, FindEntity t1, MonadPlus m) => t1 -> t2 -> m [String]+hsVisibleNames e t =do d<-hsVisiblePNs e t+                       return ((nub.map pNtoName) d)+ +-- | Given syntax phrases e and t, if e occurs in  t, then return those vairables+--  which are declared in t and accessible to e, otherwise return []. +hsVisiblePNs :: (Term t1, Term t2, FindEntity t1, MonadPlus m) => t1 -> t2 -> m [PName]+hsVisiblePNs e t =applyTU (full_tdTU (constTU [] `adhocTU` mod +                                                  `adhocTU` exp+                                                  `adhocTU` match+                                                  `adhocTU` patBind+                                                  `adhocTU` alt+                                                  `adhocTU` stmts)) t+      where         +          mod ((HsModule loc modName exps imps decls)::HsModuleP)+            |findEntity e decls+           =do (df,dd)<-hsFreeAndDeclaredPNs decls+               return dd+          mod _=return []+                                                             +          exp ((TiDecorate.Exp (HsLambda pats body))::HsExpP)+            |findEntity e body+             = do (pf,pd) <-hsFreeAndDeclaredPNs pats+                  return pd         ++          exp (TiDecorate.Exp (HsLet decls e1))+             |findEntity e e1 || findEntity e decls+             = do (df,dd)<- hsFreeAndDeclaredPNs decls+                  return dd      +          exp _ =return [] +                   +          match (m@(HsMatch _ (PNT fun _ _)  pats rhs  decls)::HsMatchP)+            |findEntity e rhs || findEntity e decls+            = do (pf,pd) <- hsFreeAndDeclaredPNs pats+                 (df,dd) <- hsFreeAndDeclaredPNs decls+                 return  (pd `union` dd `union` [fun])+          match _=return []+ +          patBind (p@(TiDecorate.Dec (HsPatBind _ pat rhs decls))::HsDeclP)+            |findEntity e rhs || findEntity e decls +             =do (pf,pd) <- hsFreeAndDeclaredPNs pat+                 (df,dd) <- hsFreeAndDeclaredPNs decls+                 return (pd `union` dd)+          patBind _=return [] ++          alt ((HsAlt _ pat exp decls)::HsAltP)+             |findEntity e exp || findEntity e decls+             = do (pf,pd) <- hsFreeAndDeclaredPNs pat+                  (df,dd) <- hsFreeAndDeclaredPNs decls+                  return (pd `union` dd)+          alt _=return []+                    +          stmts ((HsGenerator _ pat exp stmts) :: HsStmtP) +            |findEntity e stmts+             =do (pf,pd) <-hsFreeAndDeclaredPNs pat+                 return pd++          stmts (HsLetStmt decls stmts)+            |findEntity e decls || findEntity e stmts+             =do (df,dd) <-hsFreeAndDeclaredPNs decls+                 return dd+          stmts _ =return []++-------------------------------------------------------------------------------++{- | The HsDecls class -}+class (Term t) => HsDecls t where  +    -- | Return the declarations that are directly enclosed in the given syntax phrase.+    hsDecls :: t->[HsDeclP]+    -- | Replace the  directly enclosed declaration list by the given declaration list.+    --  Note: This function does not modify the token stream.+    replaceDecls :: t->HsDeclsP->t+   +    -- | Return True if the specified identifier is declared in the given syntax phrase.+    isDeclaredIn :: PName -> t->Bool ++instance HsDecls HsMatchP where   +    hsDecls (HsMatch loc1 fun pats rhs ds@(Decs x y))=x ++    replaceDecls (HsMatch loc1 fun pats rhs ds) ds'+      =(HsMatch loc1 fun pats rhs ds')++    isDeclaredIn  pn match@(HsMatch loc1 (PNT fun _ _) pats rhs ds)+       =fromMaybe False ( do (_,d)<-hsFDsFromInside match+                             Just (elem pn (d \\ [fun])))+instance HsDecls HsDeclP where+    hsDecls (TiDecorate.Dec (HsPatBind loc p rhs ds@(Decs x y)))=x+    hsDecls (TiDecorate.Dec (HsFunBind loc matches))=concatMap hsDecls matches  +    hsDecls _ =[]++    replaceDecls (TiDecorate.Dec (HsPatBind loc p rhs ds)) ds'+        =TiDecorate.Dec (HsPatBind loc p rhs ds')+    replaceDecls x ds' =x++    isDeclaredIn pn (TiDecorate.Dec (HsPatBind loc p rhs ds))+      = fromMaybe False (do (_, rd)<-hsFreeAndDeclaredPNs rhs+                            (_, dd)<-hsFreeAndDeclaredPNs ds+                            Just (elem pn (rd `union` dd)))               +    isDeclaredIn pn _ =False +    +instance HsDecls HsDeclsP where+    hsDecls ds@(Decs x y) = concatMap hsDecls x+    replaceDecls ds _ = ds+    isDeclaredIn _ ds@(Decs x y) = False++instance HsDecls [HsDeclP] where+    hsDecls ds= concatMap hsDecls ds+    replaceDecls ds _ = ds             -- This should not happen.+    isDeclaredIn _ ds = False            -- This should not happen.++instance HsDecls HsModuleP where+    hsDecls (HsModule loc modName exps imps ds@(Decs x y))=x++    replaceDecls (HsModule loc modName exps imps ds) ds'+       = HsModule loc modName exps imps ds'++    isDeclaredIn pn (HsModule loc modName exps imps ds)+       =fromMaybe False  (do (rf,rd)<-hsFreeAndDeclaredPNs ds+                             Just (elem pn rd))   ++instance HsDecls RhsP where+    hsDecls rhs=fromMaybe [] (applyTU (stop_tdTU (failTU `adhocTU` inLet+                                                                        `adhocTU` inAlt+                                                                        `adhocTU` inStmt)) rhs) +             where inLet ((TiDecorate.Exp (HsLet ds@(Decs x y) e)) ::HsExpP)=Just x+                   inLet _ =mzero++                   inAlt ((HsAlt _ p rhs ds@(Decs x y))::HsAlt HsExpP HsPatP HsDeclsP)=Just x++                   inStmt ((HsLetStmt ds@(Decs x y) _)::HsStmt HsExpP HsPatP HsDeclsP)=Just x+                   inStmt _=mzero++    replaceDecls rhs _ = rhs           -- This should not happen.+    isDeclaredIn _ _  = False            -- This should not happen.++instance HsDecls HsExpP where+    hsDecls rhs=fromMaybe [] (applyTU (stop_tdTU (failTU `adhocTU` inLet+                                                         `adhocTU` inAlt                  +                                                         `adhocTU` inStmt)) rhs) +             where inLet ((TiDecorate.Exp (HsLet ds@(Decs x y) e)) ::HsExpP)=Just x+                   inLet (TiDecorate.Exp (HsListComp (HsLetStmt ds@(Decs x y) stmts)))=Just x+                   inLet (TiDecorate.Exp (HsDo (HsLetStmt ds@(Decs x y) stmts)))=Just x+                   inLet _ =Nothing++                   inAlt ((HsAlt _ p rhs ds@(Decs x y))::HsAlt HsExpP HsPatP HsDeclsP)=Just x++                   inStmt ((HsLetStmt ds@(Decs x y) _)::HsStmt HsExpP HsPatP HsDeclsP)=Just x+                   inStmt _=Nothing +    +    replaceDecls (TiDecorate.Exp (HsLet ds e)) ds'+            =if ds'== Decs [] ([], [])+                then e +                else (TiDecorate.Exp (HsLet ds' e))+                     +    replaceDecls (TiDecorate.Exp (HsListComp (HsLetStmt ds stmts))) ds'@(Decs x y)+            =if x==[] && isLast stmts +               then (TiDecorate.Exp (HsList [fromJust (expInLast stmts)]))+               else (TiDecorate.Exp (HsListComp (HsLetStmt ds' stmts)))+       where+         isLast (HsLast e)=True+         isLast _=False+         +         expInLast (HsLast e)=Just e+         expInLast _=Nothing++    replaceDecls (TiDecorate.Exp (HsDo (HsLetStmt ds stmts))) ds'@(Decs x y)+            =if x==[] +                then (TiDecorate.Exp (HsDo stmts))+                else (TiDecorate.Exp (HsDo (HsLetStmt ds' stmts)))+    replaceDecls x ds'=x+++    isDeclaredIn pn (TiDecorate.Exp (HsLambda pats body))+            = fromMaybe False (do (pf,pd) <-hsFreeAndDeclaredPNs pats+                                  Just (elem pn  pd))++    isDeclaredIn pn (TiDecorate.Exp (HsLet decls e))        +           =fromMaybe False (do (df,dd)<- hsFreeAndDeclaredPNs decls+                                Just (elem pn dd))+        +    isDeclaredIn pn _=False +                   ++instance HsDecls HsStmtP where+    hsDecls (HsLetStmt ds@(Decs x y) stmts)=x+    hsDecls  _ = []+    +    replaceDecls (HsLetStmt ds stmts) ds'@(Decs x y)+     = if x/=[] then  HsLetStmt ds' stmts         +                  else stmts++    isDeclaredIn pn (HsGenerator _ pat exp stmts) -- Claus+        =fromMaybe False (do (pf,pd) <-hsFreeAndDeclaredPNs pat+                             Just (elem pn pd))++    isDeclaredIn pn (HsLetStmt decls stmts)+        =fromMaybe False (do (df,dd) <-hsFreeAndDeclaredPNs decls+                             Just (elem pn dd))++    isDeclaredIn pn _=False++instance HsDecls HsAltP where+    hsDecls (HsAlt _ p rhs ds@(Decs x y))=x++    replaceDecls (HsAlt loc p rhs ds) ds'=HsAlt loc p rhs ds'++    isDeclaredIn pn (HsAlt _ pat exp decls)+       =fromMaybe False ( do (pf,pd) <- hsFreeAndDeclaredPNs pat+                             (df,dd) <- hsFreeAndDeclaredPNs decls+                             Just (elem pn (pd `union` dd)))+    ++-------------------------------------------------------------------------------------------+class (Term a)=>FindEntity a where+  -- | Returns True is a syntax phrase, say a, is part of another syntax phrase, say b.+  findEntity:: (Term b)=> a->b->Bool++instance FindEntity HsExpP  where++  findEntity e b+    =(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inExp)) b)+     where+       inExp (e1::HsExpP)+         | e==e1 =Just True+       inExp _ =Nothing++instance FindEntity PName  where++  findEntity pn b   +   =(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` worker)) b)+     where +        worker (PNT pname _ _ ) +           |pname==pn= Just True+        worker _ =Nothing ++instance FindEntity PNT where++  findEntity pnt b+   =(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` worker)) b)+      where +        worker (pnt1::PNT)+           |sameOccurrence pnt pnt1 = Just True++        worker _ =Nothing ++     +----------------------------------------------------------------------------------------- ++-- Get the toks for a declaration, and adjust its offset to 0.   +getDeclAndToks pn incSig toks t+    = ghead "getDeclAndToks" $ applyTU (stop_tdTU (failTU `adhocTU` inDecls)) t+  where +    inDecls decls +      |snd (break (defines pn) decls) /=[] +      = return $ getDeclAndToks' pn incSig decls toks +    inDecls x = mzero +    +    getDeclAndToks' pn incSig decls toks  +     = let typeSig = if (not incSig)+                      then Nothing+                      else let (decls1,decls2) =break (definesTypeSig pn) decls+                           in if decls2==[] then Nothing else Just (ghead "getDeclAndToks" decls2) +           (decls1', decls2') = break (defines pn) decls+           decl = if decls2' == [] then error "getDeclAndToks:: declaration does not exisit"+                                   else ghead "getDeclAndToks2" decls2'+           offset = getOffset toks (fst (startEndLoc toks decl))+           declToks =removeOffset offset $ getToks' decl toks+           sigToks = case typeSig of +                       Nothing  -> []+                       Just (sig@(TiDecorate.Dec (HsTypeSig _ [i] _ _)))-> removeOffset offset $ getToks' sig toks+                       Just (TiDecorate.Dec (HsTypeSig loc is c ty))-> let sig' =(TiDecorate.Dec (HsTypeSig loc0 [nameToPNT (pNtoName pn)] c ty))+                                                            in  tokenise (Pos 0 (-1111) 1) 0 True $ prettyprint sig'++"\n" +       in  (if isJust typeSig then [fromJust typeSig, decl] else [decl], (sigToks ++ declToks))+       +    getToks' decl toks+      = let (startPos, endPos) = startEndLocIncComments toks decl+            (toks1, _) =let(ts1, (t:ts2'))= break (\t -> tokenPos t == endPos) toks+                        in (ts1++[t], ts2')+        in dropWhile (\t -> tokenPos t /= startPos || isNewLn t) toks1++    removeOffset offset toks +     = let groupedToks = groupTokensByLine toks+       in  concatMap  (doRmWhites offset) groupedToks++              +{-+-- THIS FUNCTION SHOULD NOT BE IN THE API.+-- | Get the list of tokens which represent the declaration that defines pn.+getDeclToks :: PName           -- ^ The identifier. +              -> Bool          -- ^ True means type signature should be included.+              -> [HsDeclP]     -- ^ The declaration list in which the identifier is defined.+              -> [PosToken]    -- ^ The input token stream.+              -> [PosToken]    -- ^ The result.+-}+---  IMPORTANT: GET RID OF THE -1111*****************+getDeclToks pn incSig decls toks +  = let (decls1,decls2) =break (definesTypeSig pn) decls+        typeSig = if decls2==[] then Nothing else Just (ghead "getDeclToks1" decls2) --There may or may not type signature.+        (decls1', decls2') = break (defines pn) decls+        decl = if decls2' == [] then error "getDeclToks:: declaration does not exisit"+                                else ghead "getDeclToks2" decls2'+        declToks = getToks' decl toks+        sigToks +         = case typeSig of +            Nothing  -> []+            Just (sig@(TiDecorate.Dec (HsTypeSig _ [i] _ _)))-> getToks' sig toks+            Just (TiDecorate.Dec (HsTypeSig loc is c ty))-> let sig' =(TiDecorate.Dec (HsTypeSig loc0 [nameToPNT (pNtoName pn)] c ty))+                                                 in  tokenise (Pos 0 (-1111) 1) 0 True $ prettyprint sig'++"\n"   +    in if incSig then sigToks ++ declToks  else declToks +   where   +     getToks' decl toks+          = let (startPos, endPos) = startEndLocIncComments toks decl+                (toks1, _) =let(ts1, (t:ts2'))= break (\t -> tokenPos t == endPos) toks+                            in (ts1++[t], ts2')+            in dropWhile (\t -> tokenPos t /= startPos || isNewLn t) toks1+++inRegion t toks beginPos endPos +  =let (sLoc', eLoc')={-getStartEndLoc-} startEndLoc  toks t+       (sLoc,eLoc)=extendBothSides  toks sLoc' eLoc' isWhite isWhite+   in beginPos>=sLoc && beginPos<=eLoc +++applyRefac refac Nothing fileName+  = do (inscps, exps, mod, toks)<-parseSourceFile fileName+       (mod',((toks',m),_))<-runStateT (refac (inscps, exps, mod)) ((toks,False), (-1000,0)) +       return ((fileName,m),(toks',mod'))++applyRefac refac (Just (inscps, exps, mod, toks)) fileName+  = do (mod',((toks',m),_))<-runStateT (refac (inscps, exps, mod)) ((toks,False), (-1000,0)) +       return ((fileName,m),(toks', mod'))  +                                    +applyRefacToClientMods refac fileName+   = do clients <- clientModsAndFiles =<< fileNameToModName fileName+        mapM (applyRefac refac Nothing) (map snd clients)++++{-+--this function try to find an identifier through a textual interface. More details will be added.+findPNByPath::String->HsModuleP->Either String PName+findPNByPath path mod +  = case  findDeclByPath path mod of+      Left errMsg -> Left errMsg+      Right decl  -> Right $ head $ definedPNs decl +  where     +    findDeclByPath path mod+      = let names = extractPath path+        in findPNByPath' names (hsModDecls mod)+    +    extractPath path = extractPath' [] path+    extractPath' r path =+      case span (/='.') path of+            (name, "")      -> r++[name]+            (name, subPath) -> extractPath' (r++[name]) (tail subPath) ++    findPNByPath' (name:names) [] = Left "Can not find the declaration"+    findPNByPath' (name:names) decls+      = let decl = findDeclByName name decls+        in if decl==[] then Left "Can not find the declaration"+                       else if names==[] then Right (head decl)+                                         else findPNByPath' names (hsDecls (head decl))    +    findDeclByName name decls = filter definesName decls+     where+       definesName (Dec (HsFunBind _ ((HsMatch _ (PNT pn _ _) _ _ _):_)))+          = pNtoName pn == name+       definesName (Dec (HsPatBind _ p _ _)) = name == (pNtoName.head.hsPNs) p +       definesName  _ = False+-}+++-- THe following functions were added Chris Brown to work specifically with the Typed AST+-- created by the type checker++------------------------------------------------------------------------------------------+-- | Collect the free and declared variables (in the PName format) in a given syntax phrase t.+-- In the result, the first list contains the free variables, and the second list contains the declared variables.+removeFromInts :: (MonadPlus m, Term t) => t -> m t+removeFromInts mod+ = do+     let dName = findDname mod+     newMod <- removeFromInts' dName mod+     return newMod+      where +        findDname t+          = fromMaybe (defaultExp)+             (applyTU (once_tdTU (failTU `adhocTU` findDname))t )+              where+                findDname (TiDecorate.Exp (HsApp (TiDecorate.Exp (HsApp (TiSpec (HsVar (PNT (PN (UnQual "fromInteger") _)_ _))_ _) d)) x)::HsExpP)+                  = Just d+                findDname _ = mzero+                +        removeFromInts' :: (MonadPlus m, Term t) => HsExpP -> t -> m t+        removeFromInts' dName t+          = applyTP (full_tdTP (idTP `adhocTP` remFromInt `adhocTP` (remFromPat dName))) t+             where+              remFromInt (TiDecorate.Exp (HsApp (TiDecorate.Exp (HsApp (TiSpec (HsVar (PNT (PN (UnQual "fromInteger") _)_ _))_ _) d)) x)::HsExpP)+               = return x+              remFromInt e@(_) = return e+       +              remFromPat (TiDecorate.Exp (HsId x)) ((HsMatch t1 t2 ((TiDecorate.Pat (HsPId y)):ps) e ds)::HsMatchI PNT HsExpP HsPatP HsDeclsP)+               | x == y = return (HsMatch t1 t2 ps e ds)+              remFromPat _ e@(_) = return e ++------------------------------------------------------------------------------------------+-- | Takes a [HsDeclP] which is a data type and returns the data type name        +getDataName :: Term t => t -> String+getDataName t+ = fromMaybe ""+    (applyTU (once_tdTU (failTU `adhocTU` inData)) t)+    where+     inData ((HsTyCon (PNT (PN (UnQual x)_) _ _)) :: TI PNT HsTypeP)+       = Just x+     inData _ = mzero  ++------------------------------------------------------------------------------------------+-- | CheckTypes takes a string represetation of a type. List types must be supplied in the form+-- | "[]Int" or "[]a"+-- | CheckTypes checks to see whether the type occurs within the syntax phrase+-- | (returns True if an identifier within the syntax phrase is of the type in question    +checkTypes :: Term t => String -> t -> Bool              +checkTypes ty t+ = fromMaybe False ( applyTU (once_tdTU (failTU `adhocTU` inType)) t)+     where+        inType ((HsTyCon (PNT (PN (UnQual x) _) _ _)) :: TI PNT (HsTypeI PNT))+         = if x == ty then Just True else mzero+        inType _ = mzero+        +--| checkTypes takes a string representation of a type, and the name of a pattern match or function +--| checkTypes calls the ghc typechecker, and returns True if the data type appears within the+--| type of the function.+--| checkTypes also removes the return type of the fuction/pattern as we are only interested in+--| the type of the arguments.+-- checkTypes :: String -> String -> Bool+checkTypes dat name ses = dat `elem` (ghcTypeCheck1 ses name)+        +-- | getPNs take a declaration and returns all the PNames within that declaration +getPNs :: HsDeclP -> [PName]      +getPNs (TiDecorate.Dec (HsFunBind _ (m:ms) ))+ = checkMatch (m:ms)+    where checkMatch [] = []+          checkMatch ((HsMatch _ _ (p:ps) _ _):ms)+            | (getPN p) /= defaultPN = (getPN p) : checkMatch ms+            | otherwise = checkMatch ms+            +-- | getPNPats takes an expression and returns a list of PNames that occur+-- | within that expression.+getPNPats :: HsExpP -> [PName]            +getPNPats (TiDecorate.Exp (HsCase e pats))+ = checkAlt pats+    where checkAlt [] = []+          checkAlt ((HsAlt loc p e2 ds):ps)+            | p /= (TiDecorate.Pat HsPWildCard) = (getPN p) : checkAlt ps+            | otherwise = checkAlt ps ++-- | getPN takes a pattern and returns the PName belonging to that Pattern.+getPN :: (Term t) => t -> PName            +getPN p + = fromMaybe (defaultPN)+             (applyTU (once_tdTU (failTU `adhocTU` inPat)) p)+    where+      inPat (pat::PName)+       = Just pat+      inPat _ = Nothing+++-- | mapASTOverTAST maps the normal AST over the type decorated AST, preserving the type information+-- | but also preserving the information from the normal AST. This is to remove the things that the +-- | type checker places into the AST to resolve types. Such as dictionaries and fromIntegers.+-- | this function is called automatically when you parse a function.      +mapASTOverTAST :: (MonadPlus m, Term t, Term t1) => t -> t1 -> m t1+mapASTOverTAST ast tast+ = applyTP (full_tdTP (idTP `adhocTP` inTAST)) tast+     where+       inTAST a@(TiDecorate.Exp (HsApp e1 e2))+         = do+              x <- mapASTOverTAST ast e1+              y <- mapASTOverTAST ast e2+              if x == defaultExp then return y+                                 else if y == defaultExp then return x+                                                         else return a+       inTAST a@(TiSpec i _ _)+         = do +              return $ findExpAst ast a+      +       inTAST a@(_) = return a+       +       inTPAT a@(TiPSpec i _ _)+         = do+              return $ findPatAst ast a+              +       findPatAst :: Term t => t -> HsPatP -> HsPatP+       findPatAst ast pat+        = fromMaybe (defaultPat)+         (applyTU (once_tdTU (failTU `adhocTU` (inPat pat))) ast)+           where+             inPat a@(TiPSpec i _ _) b@(PosSyntax.Pat (HsPId i2))+              | i == i2   = Just a+              | otherwise = mzero+             inPat a b = mzero++       findExpAst :: Term t => t -> HsExpP -> HsExpP+       findExpAst ast exp+        = fromMaybe (defaultExp)+          ( applyTU (once_tdTU (failTU `adhocTU` (inExp exp)))  ast)+            where+              inExp a@(TiSpec i _ _) b@(PosSyntax.Exp (HsInfixApp e1 i2 e2))+               | i == i2 = Just a+               | otherwise = mzero+              inExp a@(TiSpec i _ _) b@(PosSyntax.Exp (HsLeftSection e i2))+               | i == i2 = Just a+               | otherwise = mzero+              inExp a@(TiSpec i _ _) b@(PosSyntax.Exp (HsRightSection i2 e))+               | i == i2 = Just a+               | otherwise = mzero+              inExp a@(TiSpec i _ _) b@(PosSyntax.Exp (HsId i2))+               | i == i2 = Just a+               | otherwise = mzero+              inExp a b = mzero+               
+ refactorer/RefacUnGuard.hs view
@@ -0,0 +1,705 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacUnGuard+-- Copyright   :  (c) Jose Proenca 2005+-- License     :  GPL+--+-- Maintainer  :  jproenca@di.uminho.pt+-- Stability   :  experimental+-- Portability :  portable+--+-- Refactoring that tries to convert guards to if then else, after merging+--  necessary matches.+--+-----------------------------------------------------------------------------++module RefacUnGuard(+    -- * The refactoring+    guardToIte, -- won't appear in report because no type information was given++{- | The main goal of this refactoring is to convert a function declaration+where guards can be found into another with no guards, and with /if then else/+expressions instead. But the biggest problem aboarded in this transformation is how to+remove this guards if they afect more than one match that can be merged into+a single one, where different name for the variables is used and some line swapping may+be needed.++This refactoring is then divided into three different sub-problems, that will+be explained in more detail in this document:++    * Check which matches can be converted and swaped with matches defined+      bellow, without changing the function behaviour;++    * Merge the similar matches with guards to a single match, renaming the+      needed variables;++    * In each match replace the guards by /if then else/ when possible.+-}++    -- * Stages of the refactoring+    -- ** Consistency check+{- | Before any other evaluation each match is compared with the matches below+on the same declaration by 'isConsist'. It is then associated with a boolean+that states if the declaration has any inconsitency below. A match is said to+be inconsitent with a second one below it if the patterns are not disjoint and+if a constant value is found in the a pattern of the second match where a+variable was in the first one. All possibles patterns were contemplated.++-}+    findConsist,+    isConsist,+    +    -- ** Merge of matches+{- | After knowing which matches can be manipulated and swaped, the next step+is to try to merge matches using all possible combinations.++Because there are sometimes the need to create fresh variables, a name that is+not the prefix of any of the variable names (in this case is the smaller+sequence of x's) is used as the base name and a counter is added to the+variable name. The 'mergeMatches' is a function that uses a state monad with+partiality, whith the base name and the conter inside the state, and that+fails when the merging of two matches is not possible.++Before trying to merge matches, the declarations of the consistent matches are+passed to inside the guards and to the main expressions, using the function 'declsToLet',+since after the merging the declarations will afect more than the original+expressions. This will duplicate the declarations inside the where clause.++-}++    getInitSt,+    dmerge,++{- | In the merge of two matches all the possible patterns were contemplated.+In some cases there is more than way to merge patterns. Each case will now be+explained in more detailed.++[Similar patterns]  If the two patterns are equivalent according to the+function 'similar', then no transformation is applied. Since this is the first+test to be performed, the patterns are considered to be different in the+remaing tests;++[Variables] When two different varibles are found they are replaced by a fresh+variable, in the pattern, in the guards and in the main expression;++[Parentisis] They are initialy ignored, and in the end they are placed back;++[WildCard (underscore)] Can only be matched with a variable. In this case a+fresh variable will replace both the wild card and the variable, in every+important place of the match;++[var \@ pattern] If both matches have this construction, then the variable and+the associated pattern are splited into two different patterns, and after the+recursive evaluation the resulting variable is \"glued\" back to the resulting+pattern. If only one match have this construction, then the variable is+replaced by a fresh variable, so that the same variable can also be assigned+to the second pattern; ++[Irrefutable pattern] When a irrefutable pattern is found, it is replaced by a+fresh variable, and inside the guards and in the main expression a /let/+constructor is added, assigning the irrefutable pattern to take the value of+the fresh variable. This way the fact that haskell uses lazy evaluation allows+the behaviour of the function to be the same as before;+++[Constructors with fields] Whenever a constructor with fields is found, it is+converted into a pattern where the constructor is applied to the different+variable, using wild cards to when a variable name is not assigned;++[Application] When in both matches a application of a constructor is found,+and the constructors are similar (according to the 'similar' function), then+the list of arguments are added to the remaining patterns to be merged, and in+the end they are extracted and \"glued\" with constructor again;++[Infix application] Same approach to normal application was taken.++[Tupples and lists] Each pattern inside the tupple or list is added to the+remaining patterns to be merged, and in the end they are \"glued\" again with+the tuple or list constructor.++-}+    mergeMatches,++++    -- ** Conversion from guards to /if then else/'s+{- | The final stage is the most simple one, since there are not many cases to+evaluate. The function 'guards2ifs' is applied to each match with a guard and+with the consisty check mark. When the /otherwise/ guard is not found+the /else/ of the resultig expression issues an error message. +-} +    guards2ifs,++    -- * Auxiliary functions+{-| In this section some of the auxiliary functions used in this+refactoring are presented. This functions may be of some use in later refactorings.+-}+    similar,+    differ,+    replaceExp,+    declsToLet,+    pRecToPApp+    +    -- * Future work+{- | This refactoring tries to be as complete as possible, but it is still+possible to improve some cases. A possible improvement would be to infer the /otherwise/+case, as presented in the following example:++@+f x | x > 0 = 1+f x = 0+@++that could be initialy converted to++@+f x | x > 0 = 1+f x | otherwise = 0+@++but instead it does nothing to avoid overriding the last expression. This is+not very easy because a single expression in the end may be used to merge with+more then one group of matches above.++Another improvement would be to check if the declarations could also be merged+before converting them into /if then else/'s.+-}++    ) where++import RefacUtils+import PrettyPrint (pp)+import Maybe +import Control.Monad.State ++type Match = HsMatchI PNT (HsExpI PNT) (HsPatI PNT) [HsDeclI PNT]++guardToIte args  + = do let fileName = ghead "filename" args       +          row      = read (args!!1)::Int        +          col      = read (args!!2)::Int        +      modInfo@(_,exps, mod, _)<-parseSourceFile fileName  +      let pn =locToPN fileName (row, col) mod                                 +          decls = definingDecls [pn] (hsModDecls mod) False False+      if decls /= []+         then do r <- applyRefac (replaceGuards (head decls)) (Just modInfo) fileName+                 writeRefactoredFiles False [r]      +         else error "\nInvalid cursor position!"  ++++-- | Applies the transformation to a given declaration, using the auxiliary functions+--  defined bellow+replaceGuards d@(Dec (HsFunBind loc matches)) (_,_,mod)+    = do let newMs1 = findConsist matches -- :: [(Bool,Match)]+             initSt = getInitSt [m | (b,m) <- newMs1, b]+             newMs2 = map declsToLet' newMs1+             newMs3 = dmerge newMs2 initSt+             newMs4 = map guards2ifs newMs3 +         update d+                -- to see intermediate results use this line with the desired number +                --(error (show [(b,pp m) | (b,m)<-newMs1]))+                --(Dec (HsFunBind loc (map snd newMs1)))+                (Dec (HsFunBind loc newMs4))+                mod+replaceGuards decl (_,_,mod) = return mod++-- | Convert a match with guards to another match where the guards are+--   translated to /if then else/'s+guards2ifs :: (Bool,HsMatchP) -> HsMatchP+guards2ifs (True, HsMatch l i p (HsGuard lst) ds) = HsMatch l i p (HsBody $ g2i lst) ds+     where+        -- the empty list should never occur+        g2i [] = error "empty list of guards!"+        g2i [(loc,cond,exp)] +            | isOtherwise cond = exp+            | otherwise = mkIte cond exp undefError+        g2i ((loc,cond,exp):xs) = mkIte cond exp (g2i xs)++        isOtherwise (Exp (HsId (HsVar (PNT (PN (UnQual "otherwise")+            (G (PlainModule "Prelude") "otherwise"+            (N (Just _)))) Value (N (Just _))))))+                      = True+        isOtherwise _ = False++        mkIte e1 e2 e3 = Exp (HsIf e1 e2 e3)++        undefError = (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "error")+                     (G (PlainModule "Prelude") "error" +                     (N (Just loc0)))) Value (N (Just loc0)))))) (Exp+                     (HsLit loc0 (HsString "UnMatched Pattern")))))++guards2ifs (_,x) = x++     +++--------------------------+--- Consistency check ---- +--------------------------++-- | Given a set of matches, checks which ones have guards that can be+--  removed without afecting the program's behaviour. This implies going throw+--  every pattern to check if each pair is similar, disjoint or inconsistent.+--  It uses the binary function 'isConsist'.+findConsist :: [HsMatchP] -> [(Bool,HsMatchP)]+findConsist [] = []+findConsist (m:ms) +       = let ms' = findConsist ms+         in case m of+            (HsMatch _ _ pats (HsGuard _) _)+                    -> (and $ map (checkGuard m) $ map (isConsist pats . getPats) ms+                       , m) : ms'+            _ -> (False,m) : ms'+  where+    getPats (HsMatch _ _ pats _ _) = pats++    -- if a match is consistent with every match below, but not disjoint, then+    --  the guard can only be removed if it exists+    checkGuard (HsMatch _ _ _ (HsGuard _) _) Nothing = True+    checkGuard (HsMatch _ _ _ _ _) Nothing = False+    checkGuard _ (Just x) = x+    ++-- | Checks if two lists of patterns are consistents. Possible results are:+--+--  - Just True  - if disjoint patterns are found+--+--  - Just False - if an incongruence is found and there are no disjoint patterns+--+--  - Nothing    - if no incongruence nor disjoint patterns are found+isConsist :: [HsPatP] -> [HsPatP] -> Maybe Bool+isConsist [] _ = Nothing+isConsist _ [] = Nothing+-- similar values -> continue+isConsist (p1:pats1) (p2:pats2) | p1 `similar` p2+    = isConsist pats1 pats2+-- different constants -> True +isConsist (k1:pats1) (k2:pats2) | isConstant k1 && isConstant k2+    = if k1 `differ` k2  then Just True+                         else isConsist pats1 pats2+-- var - const -> False+isConsist ((Pat (HsPId (HsVar _))):pats1) (k:pats2) | isConstant k+        = case isConsist pats1 pats2 of+             Just True -> Just True+             _         -> Just False+-- const - var -> False+isConsist (k:pats1) ((Pat (HsPId (HsVar _))):pats2) | isConstant k+        = case isConsist pats1 pats2 of+             Just True -> Just True+             _         -> Just False+-- var - var -> continue+isConsist ((Pat (HsPId (HsVar _))):pats1) ((Pat (HsPId (HsVar _))):pats2)+    = isConsist pats1 pats2++---- const - _ -> Continue+--isConsist (k:pats1) (_:pats2) | isConstant k+--        = isConsist pats1 pats2+---- _ - var -> Continue+--isConsist (_:pats1) ((Pat (HsPId (HsVar _))):pats2)++--      = isConsist pats1 pats2+-- x - y -> unfold x and y, and check if they are consistent before continuing+isConsist (pat1:pats1) (pat2:pats2)+      = case  isConsist (unfoldPat pat1) (unfoldPat pat2) of+           Just True -> Just True+           Nothing   -> isConsist pats1 pats2+           _         -> case isConsist pats1 pats2 of+                           Just True -> Just True+                           _         -> Just False+++-- Only used in the consistency check.+-- For each complex pattern, it is decomposed into a list of more simple patterns,+--   that will be checked for consistency.+unfoldPat :: HsPatP  -> [HsPatP]+unfoldPat (Pat HsPWildCard)    = [nameToPat "_"] -- name is not important+unfoldPat (Pat (HsPIrrPat p))  = [nameToPat "irr"] -- name is not important+unfoldPat (Pat (HsPAsPat i p)) = unfoldPat p+unfoldPat  (Pat (HsPApp i ps))+    = (Pat $ HsPId $ HsCon i) : (map unparen ps)+unfoldPat (Pat (HsPInfixApp p1 i p2))+    = (Pat $ HsPId (HsCon i)) : (map unparen [p1,p2])+unfoldPat (Pat prec@(HsPRec constr fields))+    = unfoldPat (Pat $ pRecToPApp prec)+unfoldPat (Pat (HsPList _ lst))+    = (Pat $ HsPId $ HsCon $ nameToPNT "(:)"):lst -- the name is not important+unfoldPat (Pat (HsPTuple _ lst)) +    = (Pat $ HsPId $ HsCon $ nameToPNT "(tup)"):lst -- the name is not important+unfoldPat x@(Pat _) = [unparen x]++unparen (Pat (HsPParen m)) = unparen m+unparen x = x++++                   ++-------------------------+--- merge of matches ---- +-------------------------++-- To create fresh variables a partial State monad is used, to store the base name and the seed.+type ST = StateT St Maybe++data St = St {baseName :: String,+              seed :: Int}++getSt :: ST St+getSt = do sd <- gets seed+           bn <- gets baseName+           return $ St bn sd++getSeed :: ST Int+getSeed = do n <- gets seed+             modify (\s -> s {seed = n+1})+             return n++getFreshVar :: ST String+getFreshVar = do s <- getSeed+                 n <- gets baseName+                 return (n++"_"++(show s))+++-- | To get an initial state it is necessery to find a base name that is not prefix of any of the used names.+-- In this case it will be 'x' replicated until it is not a prefix. The+-- counter is initiated to zero.+getInitSt :: [HsMatchP] -> St+getInitSt ms+  = let xs = (runIdentity $ applyTU strat ms) :: [Int]+        base = replicate (maximum xs) 'x'+    in St base 0+ where strat = full_tdTU ((constTU [1]) `adhocTU` getNumberX)+       getNumberX :: HsIdentI PNT -> Identity [Int]+       getNumberX (HsVar pnt) =+            let name = pNTtoName pnt+                n = length $ takeWhile (=='x') name+            in return $ [n+1]+       getNumberX _ = return []++++-- | Distributes the binary function 'mergeMatches'.+--+-- The state of each evaluation of 'mergeMatches' as to be extracted to be+--  passed to further calls. It doesn't make sense to put the same state+--  inside 'dmerge', because it would fail when the first 'mergeMatches' failed,+--  which is not desired.  +dmerge :: [(Bool,HsMatchP)] -> St -> [(Bool,HsMatchP)]+dmerge [] _ = []+dmerge [x] _ = [x]+dmerge ((False,h):rest) st = (False,h):(dmerge rest st)+dmerge ((True,h):rest) st +    = case dmerge2 h rest st of+        Just (st',newMs) -> dmerge newMs st'+        Nothing -> (True,h) : (dmerge rest st)++dmerge2 h [] _ = fail "end"+dmerge2 h ((False,t):rest) st+  = do (st',newMs) <- dmerge2 h rest st+       return (st',(False,t):newMs)+dmerge2 h ((True,t):rest) st+  = case tryMergeMatches h t st of+        Just (st',newM)+           -> return (st',(True,newM):rest)+        _  -> do (st',newMs) <- dmerge2 h rest st+                 return (st',(True,t):newMs)++tryMergeMatches h t st+    = evalStateT+         (do newM <- mergeMatches h t+             st' <- getSt+             return (st',newM))+         st+                 +++{- | Tries to merge two matches with guards, using a state monad to create+fresh variables whith partiality to fail when no merging is possible.+-}+mergeMatches :: HsMatchP+             -> HsMatchP+             -> ST HsMatchP++-- no more patterns+mergeMatches (HsMatch l1 i1 [] (HsGuard lst1) ds) (HsMatch l2 i2 [] (HsGuard lst2) _)+    = return $ HsMatch l1 i1 [] (HsGuard (lst1++lst2)) ds++-- similar values+mergeMatches (HsMatch l1 i1 (p1:pats1)  e1 [])+             (HsMatch l2 i2 (p2:pats2)  e2 []) +    | p1 `similar` p2 +     = do HsMatch l i ps e _ <- mergeMatches (HsMatch l1 i1 pats1 e1 [])+                                             (HsMatch l2 i2 pats2 e2 [])+          return $ HsMatch l i (p1:ps) e []++-- parentisis+mergeMatches (HsMatch l1 i1 ((Pat (HsPParen p1)):ps1) e1 [])+             (HsMatch l2 i2 ((Pat (HsPParen p2)):ps2) e2 []) +    = do HsMatch l i (p:ps) e _ <- mergeMatches (HsMatch l1 i1 (p1:ps1) e1 [])+                                                (HsMatch l2 i2 (p2:ps2) e2 [])+         return $ HsMatch l i ((Pat (HsPParen p)):ps) e []+mergeMatches (HsMatch l1 i1 ((Pat (HsPParen p1)):ps1) e1 []) m2 +    = do HsMatch l i (p:ps) e _ <- mergeMatches (HsMatch l1 i1 (p1:ps1) e1 []) m2+         return $ HsMatch l i ((Pat (HsPParen p)):ps) e []+mergeMatches m1 (HsMatch l2 i2 ((Pat (HsPParen p2)):ps2) e2 [])+    = do HsMatch l i (p:ps) e _ <- mergeMatches m1 (HsMatch l2 i2 (p2:ps2) e2 [])+         return $ HsMatch l i ((Pat (HsPParen p)):ps) e []++-- WildCard+{-mergeMatches (HsMatch l1 i1 ((Pat HsPWildCard):ps1) e1 [])+             (HsMatch l2 i2 ((Pat HsPWildCard):ps2) e2 [])+    = do HsMatch l i (p:ps) e _ <- mergeMatches (HsMatch l1 i1 ps1 e1 [])+                                                (HsMatch l2 i2 ps2 e2 [])+         return $ HsMatch l i ((Pat HsPWildCard):ps) e []-}+mergeMatches (HsMatch l1 i1 ((Pat HsPWildCard):ps1) e1 [])+             (HsMatch l2 i2 ((Pat (HsPId (HsVar var))):ps2) e2 [])+    = do v <- getFreshVar+         let e2' = replaceRhs var v Nothing e2+         HsMatch l i ps e _ <- mergeMatches (HsMatch l1 i1 ps1 e1 [])+                                            (HsMatch l2 i2 ps2 e2' [])+         return $ HsMatch l i ((Pat $ HsPId $ HsVar $ changeName var v):ps) e []+mergeMatches (HsMatch l1 i1 ((Pat (HsPId (HsVar var))):ps1) e1 [])+             (HsMatch l2 i2 ((Pat HsPWildCard):ps2) e2 [])+    = do v <- getFreshVar+         let e1' = replaceRhs var v Nothing e1+         HsMatch l i ps e _ <- mergeMatches (HsMatch l1 i1 ps1 e1' [])+                                            (HsMatch l2 i2 ps2 e2 [])+         return $ HsMatch l i ((Pat $ HsPId $ HsVar $ changeName var v):ps) e []++-- x @ pat+mergeMatches (HsMatch l1 i1 ((Pat (HsPAsPat var1 p1)):ps1) e1 [])+             (HsMatch l2 i2 ((Pat (HsPAsPat var2 p2)):ps2) e2 [])+    = do HsMatch l i ((Pat (HsPId (HsVar var))):p:ps) e _ <-+                 mergeMatches (HsMatch l1 i1 ((Pat $ HsPId $ HsVar var1):p1:ps1) e1 [])+                              (HsMatch l2 i2 ((Pat $ HsPId $ HsVar var1):p2:ps2) e2 [])+         return $ HsMatch l i ((Pat $ HsPAsPat var p):ps) e []+mergeMatches (HsMatch l1 i1 ((Pat (HsPAsPat var p1)):ps1) e1 [])+             (HsMatch l2 i2 ps2 e2 [])+    = do v <- getFreshVar+         let e1' = replaceRhs var v Nothing e1+             var' = changeName var v+         HsMatch l i (p:ps) e _ <- mergeMatches (HsMatch l1 i1 (p1:ps1) e1' [])+                                                (HsMatch l2 i2 ps2 e2 [])+         return $ HsMatch l i ((Pat $ HsPAsPat var' p):ps) e []+mergeMatches (HsMatch l1 i1 ps1 e1 [])+             (HsMatch l2 i2 ((Pat (HsPAsPat var p2)):ps2) e2 [])+    = do v <- getFreshVar+         let e2' = replaceRhs var v Nothing e2+             var' = changeName var v+         HsMatch l i (p:ps) e _ <- mergeMatches (HsMatch l1 i1 ps1 e1 [])+                                                (HsMatch l2 i2 (p2:ps2) e2' [])+         return $ HsMatch l i ((Pat $ HsPAsPat var' p):ps) e []+++-- ~ pat+mergeMatches (HsMatch l1 i1 ((Pat (HsPIrrPat p1)):ps1) e1 [])+             (HsMatch l2 i2 ps2 e2 [])+    = do v <- getFreshVar+         let e1' = addLet p1 (nameToExp v)  e1+             p1' = nameToPat v+         mergeMatches (HsMatch l1 i1 (p1':ps1) e1' [])+                      (HsMatch l2 i2 ps2 e2 [])+mergeMatches (HsMatch l1 i1 ps1 e1 [])+             (HsMatch l2 i2 ((Pat (HsPIrrPat p2)):ps2) e2 [])+    = do v <- getFreshVar+         let e2' = addLet p2 (nameToExp v) e2+             p2' = nameToPat v+         mergeMatches (HsMatch l1 i1 ps1 e1 [])+                      (HsMatch l2 i2 (p2':ps2) e2' [])++-- C { ...}+mergeMatches (HsMatch l1 i1 (Pat (r@(HsPRec _ _)):ps1) e1 [])+             (HsMatch l2 i2 ps2 e2 [])+    = mergeMatches (HsMatch l1 i1 ((Pat (pRecToPApp r)):ps1) e1 [])+                   (HsMatch l2 i2 ps2 e2 [])+mergeMatches (HsMatch l1 i1 ps1 e1 [])+             (HsMatch l2 i2 (Pat (r@(HsPRec _ _)):ps2) e2 [])+    = mergeMatches (HsMatch l1 i1 ps1 e1 [])+                   (HsMatch l2 i2 ((Pat (pRecToPApp r)):ps2) e2 [])+                    ++-- 2 variables (different)+mergeMatches (HsMatch l1 i1 ((Pat (HsPId (HsVar var1))):pats1)  e1 [])+             (HsMatch l2 i2 ((Pat (HsPId (HsVar var2))):pats2)  e2 [])+    = do v <- getFreshVar+         let e1' = replaceRhs var1 v Nothing     e1+             e2' = replaceRhs var2 v (Just var1) e2+         HsMatch l i ps e _ <- mergeMatches (HsMatch l1 i1 pats1 e1' [])+                                            (HsMatch l2 i2 pats2 e2' [])+         return $ HsMatch l i ((Pat $ HsPId $ HsVar $ changeName var1 v):ps) e []++-- application+mergeMatches (HsMatch l1 i1 ((Pat (HsPApp pnt1 lst1)):pats1)  e1 [])+             (HsMatch l2 i2 ((Pat (HsPApp pnt2 lst2)):pats2)  e2 [])+   | pnt1 `similar` pnt2+    = do let n = length lst1 -- assuming equal lengths+         HsMatch l i ps e _ <- mergeMatches (HsMatch l1 i1 (lst1++pats1) e1 [])+                                            (HsMatch l2 i2 (lst2++pats2) e2 [])+         let (lst',ps') = splitAt n ps+         return $ HsMatch l i ((Pat (HsPApp pnt1 lst')):ps') e []++-- infix application+mergeMatches (HsMatch l1 i1 ((Pat (HsPInfixApp pl1 op1 pr1)):pats1)  e1 [])+             (HsMatch l2 i2 ((Pat (HsPInfixApp pl2 op2 pr2)):pats2)  e2 [])+   | op1 `similar` op2+    = do HsMatch l i (pl:pr:ps) e _ <- +                  mergeMatches (HsMatch l1 i1 (pl1:pr1:pats1) e1 [])+                               (HsMatch l2 i2 (pl2:pr2:pats2) e2 [])+         return $ HsMatch l i ((Pat (HsPInfixApp pl op2 pr)):ps) e []++-- tuples+mergeMatches (HsMatch l1 i1 ((Pat (HsPList loc1 lst1)):pats1)  e1 [])+             (HsMatch l2 i2 ((Pat (HsPList loc2 lst2)):pats2)  e2 [])+    = do let n = length lst1 -- assuming equal lengths+         HsMatch l i ps e _ <- mergeMatches (HsMatch l1 i1 (lst1++pats1) e1 [])+                                            (HsMatch l2 i2 (lst2++pats2) e2 [])+         let (lst',ps') = splitAt n ps+         return $ HsMatch l i ((Pat (HsPList loc1 lst')):ps') e []++-- lists+mergeMatches (HsMatch l1 i1 ((Pat (HsPTuple loc1 lst1)):pats1)  e1 [])+             (HsMatch l2 i2 ((Pat (HsPTuple loc2 lst2)):pats2)  e2 [])+    = do let n = length lst1 -- assuming equal lengths+         HsMatch l i ps e _ <- mergeMatches (HsMatch l1 i1 (lst1++pats1) e1 [])+                                            (HsMatch l2 i2 (lst2++pats2) e2 [])+         let (lst',ps') = splitAt n ps+         return $ HsMatch l i ((Pat (HsPTuple loc1 lst')):ps') e []++-- merge is not possible+mergeMatches m1 m2 +    = fail "no merge possible"++++---------------------------+--- Auxiliary functions ---+---------------------------++-- puts declarations inside an expression by the use of let+declsToLet' :: (Bool,HsMatchP) -> (Bool,HsMatchP)+declsToLet' (False,m) = (False,m)+declsToLet' (True,HsMatch l i p rhs ds)+    =  (True,HsMatch l i p (declsToLet rhs ds) [])++-- | Places declarations inside an expression by the use of the /let/+--   constructor+declsToLet :: RhsP -> [HsDeclP] -> RhsP+declsToLet x [] = x+declsToLet (HsBody e) ds    = HsBody (Exp (HsLet ds e))+declsToLet (HsGuard lst) ds = HsGuard $ map aux lst+    where aux (l,e1,e2) = (l,Exp (HsLet ds e1) , Exp (HsLet ds e2))++addLet :: HsPatP -> HsExpP -> RhsP -> RhsP+addLet pat exp1 (HsBody exp2) +    = HsBody $ Exp (HsLet [Dec $ HsPatBind loc0 pat (HsBody exp1) []] exp2)+addLet pat exp1 (HsGuard lst) =  HsGuard $ map aux lst+    where aux (l,e1,e2) = (l,+                           Exp (HsLet [Dec $ HsPatBind loc0 pat (HsBody exp1) []] e1),+                           Exp (HsLet [Dec $ HsPatBind loc0 pat (HsBody exp1) []] e2))+++-- | Relplaces a variable by another, without checking if it will become bounded or not+--  (should be used fresh variables for that).+replaceRhs u v l (HsBody e) = HsBody (replaceExp u v l e)+replaceRhs u v lc (HsGuard lst) = HsGuard $+                               map (\(l,e1,e2)->(l,replaceExp u v lc e1,replaceExp u v lc e2))+                               lst+++-- | Replaces a variable name (given a PNT) by changing the name to a new name+--  and, when another PNT is passed, also changes the source location to the+--  same the second PNT.+replaceExp :: Term t => PNT -> String -> Maybe PNT -> t -> t+--replaceExp pnt@(PNT (PN (UnQual "x") _) _ _) str l exp =+--  error $ "trying to replace "++ show pnt ++" by \""++str++"\" with possible location "++show l ++" in expression "++show exp--pp exp+replaceExp pnt str locPnt exp+    = let exp1 = evalState (renamePN (pNTtoPN pnt) Nothing str False exp)+                undefined --(([],undefined),undefined)+          exp2 = let loc1 = getLoc pnt+                     loc2 = getSLoc $ fromJust locPnt+                 in replaceSLoc loc1 loc2 exp1+      in if isJust locPnt then exp2 +                          else exp1+  where+    getLoc = useLoc+    getSLoc (PNT (PN _ (S loc)) _ _) = loc++    replaceSLoc loc1 loc2 exp = runIdentity $ applyTP strat exp+        where strat = full_tdTP (adhocTP idTP replace)+              replace (S loc) | loc == loc1 = return $ S loc2+              replace x = return x+++-- changes the name of a PNT, preserving the remaining information+changeName (PNT (PN (Qual mod  v) orig) a b) nv+   = (PNT (PN (Qual mod nv) orig) a b)+changeName (PNT (PN (UnQual  v) orig) a b)   nv+   = (PNT (PN (UnQual nv) orig) a b)++-- |Checks if two terms are similar, by using the defined equality, and after some+--  simplifications to the term:+--+--       * all locations are converted to the \"unknown\" location (are ignored)+--+--       * the origin location of the PN's is set to a null position in a file+--          with the same name that the variable, because two PN's are considered+--          to be equal if they have the same origin location, but in this case two+--          PN's  should be similar if they have the same name.+similar :: (Eq t1, Term t1) => t1 -> t1 -> Bool+similar x y = unLocate x == unLocate y+  where+   unLocate = runIdentity . applyTP strat+      where strat = full_buTP (idTP `adhocTP` getIdName `adhocTP` eraseLoc `adhocTP` unparenP `adhocTP` unparenE)+            getIdName (PN v@(UnQual str) id) = return $ PN v (S (SrcLoc str 0 0 0))+            getIdName (PN v@(Qual m str) id) = return $ PN v (S (SrcLoc (pp m ++ str) 0 0 0))+            eraseLoc (SrcLoc _ _ _ _) = return loc0+            unparenP :: HsPatI PNT -> Identity (HsPatI PNT)+            unparenP (Pat (HsPParen p)) = return p+            unparenP x = return x+            unparenE :: HsExpI PNT -> Identity (HsExpI PNT)+            unparenE (Exp (HsParen e)) = return e+            unparenE x = return x++-- | Checks if two terms differ by negating the 'similar' definition+differ :: (Eq t1, Term t1) => t1 -> t1 -> Bool+differ x = not . similar x++-- | Checks if a given pattern is a constant. The possible constants are+--   constructors, literals and negations.+isConstant :: HsPatP -> Bool+isConstant (Pat (HsPId (HsCon _))) = True+isConstant (Pat (HsPLit _ _)) = True+isConstant (Pat (HsPNeg _ _)) = True+isConstant _ = False++-- | Converts a constructor with fields in a pattern to the corresponding patterns+--   with the same constructor but without the fields (ex: C {x = myx} --> C myx _)+pRecToPApp (HsPRec constr fields)+                = let fieldsNames = getInfo constr+                      patFields = buildFields fieldsNames fields+                  in HsPApp constr patFields+   where+            getInfo x@(PNT _ --(PN name _)+                           (ConstrOf _ (TypeInfo {constructors = constrs})) _)+              = let name = pNTtoName x -- case name of UnQual n -> n; Qual _ n -> n+                    fields = findFields constrs++                    findFields [] = Nothing+                    findFields ((ConInfo {conName = PN n _ , conFields = f}):tl)+                        | n == name = f+                        | otherwise  = findFields tl++                    getFieldNames Nothing = error $ "No fields were found for the constructor "++ name+                    getFieldNames (Just fs) = [str | (PN str _) <- fs]+                in getFieldNames fields++            buildFields fNames usedFields = map (update usedFields) fNames+               where update lst name =+                        case findName name lst of+                            Just pat -> pat+                            Nothing  -> Pat HsPWildCard --nameToPat name -- the name doesn't matter, because is only to check consistency+                     findName _ [] = Nothing+                     findName name ((HsField pnt pat):fs)+                          | pNTtoName pnt == name = Just pat+                          | otherwise = findName name fs
+ refactorer/RefacUnfoldAsPatterns.hs view
@@ -0,0 +1,475 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  RefacUnfoldAsPatterns+-- Copyright   :  (c) Christopher Brown 2007+--+-- Maintainer  :  cmb21@kent.ac.uk+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains a transformation for HaRe.+-- unfold all references to an AS pattern in a function.+--+-----------------------------------------------------------------------------++module RefacUnfoldAsPatterns where+++import System.IO.Unsafe+import PrettyPrint+import RefacTypeSyn+import RefacLocUtils+import Data.Char+import GHC.Unicode+import AbstractIO+import Maybe+import List+import RefacUtils++data Patt = Match HsMatchP | MyAlt HsAltP | MyDo HsStmtP | MyListComp HsExpP+             deriving (Show)+             +data Expp = MyExp HsExpP | MyStmt (HsStmt HsExpP HsPatP [HsDeclP]) | MyGuard (SrcLoc, HsExpP, HsExpP) | DefaultExp+             deriving (Show)++refacUnfoldAsPatterns args+  = do let +           fileName    = args!!0+           beginRow         = read (args!!1)::Int+           beginCol         = read (args!!2)::Int+           endRow           = read (args!!3)::Int+           endCol           = read (args!!4)::Int++       AbstractIO.putStrLn "refacUnfoldAsPatterns"++       -- Parse the input file.+       modInfo@(inscps, exps, mod, tokList) <- parseSourceFile fileName+              +       let (pat, term) = findPattern tokList (beginRow, beginCol) (endRow, endCol) mod       +              +       case pat of+         Pat (HsPId (HsVar defaultPNT))+             -> do+                        -- writeRefactoredFiles False [((fileName, m), (newToks, newMod))]+                        -- Allow the highlighting of a particular expression+                        -- rather than a pattern. (For Some).+       +                        let exp = locToExp (beginRow, beginCol) (endRow, endCol) tokList mod+       +                        let (pat, term) = patDefinesExp exp mod+                                                +                        patsInTerm <- getPats term+                        let patsPNT = hsPNTs pat+                        let patsPNT2 = hsPNTs patsInTerm                +                        when (patsPNT `myElem` patsPNT2) $ error "There are conflicts in the binding analysis! Please do a renaming"+                     +                        ((_,m), (newToks, (newMod, _))) <- applyRefac (changeExpression True exp pat) +                                                                 (Just (inscps, exps, mod, tokList)) fileName+  +                        when (newMod == mod) +                             $ AbstractIO.putStrLn +                                      ( "Warning: the expression:\n" ++ ((render.ppi) exp) ++ "\nis not associated with a pattern!" )+        +                        writeRefactoredFiles False [((fileName, m), (newToks, newMod))] +                        AbstractIO.putStrLn "Completed.\n"+         _ -> do+       +                -- Allow the highlighting of a particular as-pattern+                -- t@p+                -- this should substitute all t for p in scope.+                -- derive the patterns defined in the term (the RHS of the selected pattern)+                patsInTerm <- getPats term+                let patsPNT = hsPNTs pat+                let patsPNT2 = hsPNTs patsInTerm                +                when (patsPNT `myElem` patsPNT2) $ error "There are conflicts in the binding analysis! Please do a renaming"+       +                exp <- getExpAssociatedPat pat mod+                +                let patWOParen = convertPat pat+                            +                ((_,m), (newToks, newMod)) <- doRefac True changeExpression exp patWOParen inscps exps mod tokList fileName+                              +                writeRefactoredFiles False [((fileName, m), (newToks, newMod))]+                AbstractIO.putStrLn "Completed.\n" +    +myElem :: [PNT] -> [PNT] -> Bool+myElem [] list = False+myElem (p:pnts) list+  | p `elem` list = error ("Please rename: " ++ ((render.ppi) p) ++ " as it conflicts with patterns of the same name.")+  | otherwise     = myElem pnts list+--  = or ((p `elem` list) : [myElem pnts list])+++getPats :: (MonadPlus m) => Expp -> m [HsPatP]+getPats (MyExp e)+  = hsPats e+  +getPats (MyStmt (HsGenerator _ p _ rest))+  = do pats <- hsPats p+       result <- getPats (MyStmt rest)+       return (pats ++ result)+getPats (MyStmt (HsQualifier e rest))+  = getPats (MyStmt rest)+getPats (MyStmt (HsLetStmt ds rest))+  = do+       pats <- hsPats ds+       result <- getPats (MyStmt rest)+       return (pats ++ result)+getPats (MyStmt (HsLast e))+ = return []+ +getPats (MyGuard (_, e1, e2))+ = hsPats e2    -- modify this? lets in e2? +getPats _ = error "Pattern is not associated with an as-pattern. Check Pattern is highlight correctly!"++hsPats :: (MonadPlus m, Term t) => t -> m [HsPatP]+hsPats t = applyTU (full_tdTU (constTU [] `adhocTU` inPat)) t+           where+             inPat (p::HsPatP) = return [p]+                +convertPat :: HsPatP -> HsPatP+convertPat (Pat (HsPParen p)) = p+convertPat p = p++doRefac predPat f [] p inscps exps mod tokList fileName = +  return ((fileName, True), (tokList, mod))       +doRefac predPat f (exp:_) p inscps exps mod tokList fileName+ = do+      ((_,m), (newToks, (newMod, newPat))) <- applyRefac (f predPat exp p) (Just (inscps, exps, mod, tokList)) fileName+      +      writeRefactoredFiles True [((fileName, m), (newToks, newMod))]+      +      modInfo@(inscps', exps', mod', tokList') <- parseSourceFile fileName+      +      newExps <- getExpAssociatedPat p mod'+            +      -- error $ show newExps+      +      if length newExps == 1+        then do+           rest <- doRefac False f newExps newPat inscps' exps' mod' tokList' fileName +      +           return rest           +        else do+           let (_, es) = splitAt 1 newExps+      +           rest <- doRefac False f es newPat inscps' exps' mod' tokList' fileName +      +           return rest+       +getExpAssociatedPat :: (Term t, MonadPlus m) => HsPatP -> t -> m [HsExpP]+getExpAssociatedPat (Pat (HsPParen p)) t = getExpAssociatedPat p t+getExpAssociatedPat pat@(Pat (HsPAsPat p1 p)) t+ = applyTU (full_tdTU (constTU [] `adhocTU` inPnt)) t+    where+       inPnt e@(Exp (HsId (HsVar p2))) +         | definesPNT p1 p2 = return [e]+       inPnt _ = return []+         ++-- changeExpression [] pat (a,b,t) = return t      +changeExpression predPat exp pat (a, b,t)+  = do +        names <- addName exp t+        (newExp, newPat) <- checkPats names pat exp+        newT  <- update exp newExp t+        -- liftIO (AbstractIO.putStrLn $ show (exp,newExp))+        +        if predPat == True+          then do+            newT2 <- update pat newPat newT                +            return (newT2, newPat)+          else do+            return (newT, newPat)+       +addName e mod   = do+                   names <- hsVisibleNames e mod +                   return names+++                   +checkPats :: (MonadPlus m, Monad m) => [String] -> HsPatP -> HsExpP -> m (HsExpP, HsPatP)+checkPats names (Pat (HsPParen p)) e +      = do+           (a,b) <- checkPats names p e+           return (a, Pat (HsPParen b))+           +checkPats names (pat@(Pat (HsPAsPat i p))) e+      = do+          -- names <- addName e t+          let (newExp1, newPat) = rewritePats names 1 p+          newExp2 <- rewriteExp i newExp1 e+          return ((Exp (HsParen newExp2)), (Pat (HsPAsPat i newPat)))+++-- rewrite exp checks to see whether the given expression occurs within+-- the second exp. If it does, the expression is replaced with the name of the 'as'+-- pattern.+-- rewriteExp :: String -> HsExpP -> HsExpP -> HsExpP+rewriteExp name e1 e2+  = applyTP (full_tdTP (idTP `adhocTP` (inExp e1))) e2+     where+       -- inExp :: HsExpP -> HsExpP -> HsExpP+       inExp (Exp (HsParen e1)::HsExpP) (e2@(Exp (HsId (HsVar pnt@(PNT pname ty loc))))::HsExpP)+        = do+             +             if (rmLocs pnt) == (rmLocs name) +              then do+               return e1+              else do +                return e2 +                    +       inExp (e1::HsExpP) (e2@(Exp (HsId (HsVar pnt@(PNT pname ty loc))))::HsExpP)+         | findPNT pnt pname  = return e1+         | otherwise = return e2+         +       inExp e1 e2 = return e2+  +allDefined e t+  = applyTU (full_tdTU (constTU [] `adhocTU` inPNT)) e+      where+        inPNT (p@(PNT pname ty _)::PNT)   +         = return [findPN pname t]++rewritePats :: [ String ] -> Int  -> HsPatP -> (HsExpP, HsPatP)+rewritePats names index (pat1@(Pat (HsPRec x y)))+  = (Exp (HsRecConstr loc0 x (map sortField y)), pat1)+    where+      sortField :: HsFieldI a HsPatP -> HsFieldI a HsExpP+      sortField (HsField i e) = (HsField i es)+                                  where+                                   (es, ps) = rewritePats names index e+       +rewritePats _ _ (pat1@(Pat (HsPLit x y)))+  = (Exp (HsLit x y), pat1)++rewritePats names index (pat1@(Pat (HsPAsPat i p1)))+  = (Exp (HsAsPat i es), (Pat (HsPAsPat i ps)))+      where+       (es, ps) = rewritePats names index p1++rewritePats names index (pat1@(Pat (HsPIrrPat p1)))+  = (Exp (HsIrrPat es), Pat (HsPIrrPat ps))+      where+       (es, ps) = rewritePats names index p1+       +rewritePats names i (pat1@(Pat (HsPWildCard)))+  = (nameToExp (mkNewName "a" names i), nameToPat (mkNewName "a" names i))++rewritePats names i (pat1@(Pat (HsPApp i1 p1)))+  = (createFuncFromPat i1 es, Pat (HsPApp i1 ps))+     where+       es = map fst result+       ps = map snd result+       result = myMap (rewritePats names) i p1++rewritePats names i (pat1@(Pat (HsPList i2 p1)))+  = (Exp (HsList es), Pat (HsPList i2 ps))+     where+       es = map fst result+       ps = map snd result+       result = myMap (rewritePats names) i p1+       +rewritePats names i (pat1@(Pat (HsPTuple i1 p1)))+  = (Exp (HsTuple es), Pat (HsPTuple i1 ps))+       where+        es = map fst result+        ps = map snd result+        result = myMap (rewritePats names) i p1+  ++rewritePats names i (pat1@(Pat (HsPInfixApp p1 x p2)))+  =  (Exp (HsInfixApp es+                      (HsCon x)+                      es2),+      Pat (HsPInfixApp ps+                       x+                       ps2))+                     +     where+       (es, ps) = rewritePats names i p1+       (es2, ps2) = rewritePats names (i+42) p2++rewritePats names i (pat@(Pat (HsPParen p1)))+  = (Exp (HsParen es), (Pat (HsPParen ps)))+       where+        (es, ps) = rewritePats names i p1++rewritePats _ _ (pat1@(Pat (HsPId (HsVar (PNT (PN (UnQual (i:is)) a) b c)))))+ | isUpper i = ((Exp (HsId (HsCon (PNT (PN (UnQual (i:is)) a) b c)))), pat1)+ | otherwise = ((Exp (HsId (HsVar (PNT (PN (UnQual (i:is)) a) b c)))), pat1)+rewritePats _ _ (pat1@(Pat (HsPId (HsCon (PNT (PN (UnQual (i:is)) a) b c)))))+  = ((Exp (HsId (HsCon (PNT (PN (UnQual (i:is)) a) b c)))), pat1)+-- rewritePats p = error $ show p++myMap _ _ [] = []+myMap f i (x:xs) = f i x : myMap f (i+1) xs++-- strip removes whitespace and '\n' from a given string+strip :: String -> String+strip [] = []+strip (' ':xs) = strip xs+strip ('\n':xs) = strip xs+strip (x:xs) = x : strip xs++isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)++--check whether the cursor points to the beginning of the datatype declaration+--taken from RefacADT.hs+checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP+checkCursor fileName row col mod+ = case locToTypeDecl of+     Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the definition!")+     Just decl -> Right decl+   where+    locToTypeDecl = find (definesPNT (locToPNT fileName (row, col) mod)) (hsModDecls mod)+    +    definesPNT pnt d@(Dec (HsPatBind loc p e ds))+      = findPNT pnt d+    definesPNT pnt d@(Dec (HsFunBind loc ms)) = findPNT pnt d+    definesPNT pnt _ = False++findGuard [] exp = error "The expression is not defined within a guard!"+findGuard ((a ,e1, e2):gs) exp+  | findEntityWithLocation exp e2 = (a,e1,e2)+  | otherwise         = findGuard gs exp++patDefinesExp exp t+  = fromMaybe (defaultPat, DefaultExp)+              (applyTU (once_tdTU (failTU `adhocTU` inMatch +                                          `adhocTU` inCase+                                          `adhocTU` inDo +                                          `adhocTU` inList )) t)+      where+       --The selected sub-expression is in the rhs of a match+       inMatch (match@(HsMatch loc1  pnt pats (HsGuard (g@(_,_,e):gs)) ds)::HsMatchP)+         -- is the highlighted region selecting a pattern?+         | inPat pats == Nothing = Nothing+         | otherwise = do +                         let guard = findGuard (g:gs) exp+                         let pat = fromJust (inPat pats) +                         Just (pat, MyGuard guard)++       +       inMatch (match@(HsMatch loc1  pnt pats (HsBody rhs) ds)::HsMatchP)+        -- is the highlighted region selecting a pattern?+        | inPat pats == Nothing = Nothing+        | otherwise = do +                         let pat = fromJust (inPat pats) +                         Just (pat, MyExp rhs)+      +       inCase (alt@(HsAlt s p (HsGuard (g@(_,_,e):gs)) ds)::HsAltP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let guard = findGuard (g:gs) exp+                          let pat = fromJust (inPat [p])+                          Just (pat, MyGuard guard)++      +       inCase (alt@(HsAlt s p (HsBody rhs) ds)::HsAltP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let pat = fromJust (inPat [p])+                          Just (pat, MyExp rhs)+                          +       inDo (inDo@(HsGenerator s p e rest)::HsStmtP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let pat = fromJust (inPat [p])+                          Just (pat, MyStmt rest)+       inDo x = Nothing+      +       inList (inlist@(Exp (HsListComp (HsGenerator s p e rest)))::HsExpP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let pat = fromJust (inPat [p])+                          Just (pat, MyStmt rest)+       inList x = Nothing+      +      +       inPat p +         = (applyTU (once_tdTU (failTU `adhocTU` worker))) p+      +       worker (pat@(Pat (HsPAsPat i p))::HsPatP)+         | expToPNT exp == i+                         = Just pat+       worker p = Nothing+{-|+Takes the position of the highlighted code and returns+the function name, the list of arguments, the expression that has been+highlighted by the user, and any where\/let clauses associated with the+function. +-}++{-findPattern :: Term t => [PosToken] -- ^ The token stream for the +                                          -- file to be+                                          -- refactored.+                  -> (Int, Int) -- ^ The beginning position of the highlighting.+                  -> (Int, Int) -- ^ The end position of the highlighting.+                  -> t          -- ^ The abstract syntax tree.+                  -> (SrcLoc, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of,+                     -- (the function name, the list of arguments,+                     -- the expression highlighted, any where\/let clauses+                     -- associated with the function).+ -}                    +findPattern toks beginPos endPos t+  = fromMaybe (defaultPat, DefaultExp)+              (applyTU (once_tdTU (failTU `adhocTU` inMatch +                                          `adhocTU` inCase+                                          `adhocTU` inDo +                                          `adhocTU` inList )) t)++    where+       --The selected sub-expression is in the rhs of a match+      inMatch (match@(HsMatch loc1  pnt pats (HsGuard (g@(_,_,e):gs)) ds)::HsMatchP)+        -- is the highlighted region selecting a pattern?+        | inPat pats == Nothing = Nothing+        | otherwise = do +                         let pat = fromJust (inPat pats) +                         Just (pat, MyGuard g)++       +      inMatch (match@(HsMatch loc1  pnt pats (HsBody rhs) ds)::HsMatchP)+        -- is the highlighted region selecting a pattern?+        | inPat pats == Nothing = Nothing+        | otherwise = do +                         let pat = fromJust (inPat pats) +                         Just (pat, MyExp rhs)+      +      inCase (alt@(HsAlt s p (HsGuard (g@(_,_,e):gs)) ds)::HsAltP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let pat = fromJust (inPat [p])+                          Just (pat, MyGuard g)++      +      inCase (alt@(HsAlt s p (HsBody rhs) ds)::HsAltP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let pat = fromJust (inPat [p])+                          Just (pat, MyExp rhs)+                          +      inDo (inDo@(HsGenerator s p e rest)::HsStmtP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let pat = fromJust (inPat [p])+                          Just (pat, MyStmt rest)+      inDo x = Nothing+      +      inList (inlist@(Exp (HsListComp (HsGenerator s p e rest)))::HsExpP)+        | inPat [p] == Nothing = Nothing+        | otherwise = do+                          let pat = fromJust (inPat [p])+                          Just (pat, MyStmt rest)+      inList x = Nothing+      +      inPat :: [HsPatP] -> Maybe HsPatP+      inPat [] = Nothing+      inPat (p:ps)+       = if p1 /= defaultPat+           then Just p1+           else inPat ps+              where +                p1 = locToLocalPat beginPos endPos toks p+   --   inPat _ = Nothing+
+ refactorer/RefacUtils.hs view
@@ -0,0 +1,3908 @@++----------------------------------------------------------------------------------------------------------------+-- Module      : RefacUtils++-- Maintainer  : refactor-fp\@kent.ac.uk  +-- |+--+-- This module contains a collection of program analysis and transformation functions(the API). In general,+-- a program analysis function returns some information about the program, but does NOT modify the program; whereas a+-- program transformation function transforms the program from one state to another state. This API is built+-- on top of Programatica's abstract syntax for Haskell and Strafunski's traversal API for large abstract syntax+-- trees, and is used extensively in the implementation of primitive refactorings. In HaRe, in order to preserve the+-- comments and layout of refactored programs, a refactoring modifies not only the AST but also the token stream, and+-- the program source after the refactoring is extracted from the token stream rather than the AST, for the comments+-- and layout information is kept in the token steam instead of the AST. As a consequence, a program transformation+-- function from this API modifies both the AST and the token stream (unless explicitly stated). So when you build +-- your own program transformations, try to use the API to do the transformation, as this can liberate you from +-- caring about the token stream.--+-- As the API is based on Programatica's abstract syntax for Haskell, we have re-exported those related module from+-- Programatica, so that you can browse the datatypes for the abstract syntax. Alternatively, you can go to +-- Programatica's webpage at: <http://www.cse.ogi.edu/~hallgren/Programatica/>. For Strafunski, you can find it +-- at: <http://www.cs.vu.nl/Strafunski/>.+--  +-- This API is still in development. Any suggestions and comments are very much welcome.+++------------------------------------------------------------------------------------------------------------------++module RefacUtils(module Control.Monad.State, module StrategyLib, module RefacTypeSyn, module PosSyntax,+                  module SourceNames, module UniqueNames, module PNT, +                  module Ents, module Relations, module QualNames, module TypedIds + -- * Program Analysis +    -- ** Imports and exports+   ,inScopeInfo, isInScopeAndUnqualified, hsQualifier, hsQualifier2, isQuald, {-This function should be removed-} rmPrelude +   ,exportInfo, isExported, isExplicitlyExported, modIsExported, parseSourceFileOld++    -- ** Variable analysis+    ,hsPNs,hsPNTs,hsDataConstrs,hsTypeConstrsAndClasses, hsTypeVbls+    ,hsClassMembers, HsDecls(hsDecls,isDeclaredIn, replaceDecls)+    ,hsFreeAndDeclaredPNs,hsFreeAndDeclaredNames+    ,hsVisiblePNs, hsVisibleNames+    ,hsFDsFromInside, hsFDNamesFromInside ++    -- ** Property checking+    ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isTopLevelPNT+    ,isQualifiedPN,isFunPNT, isFunName, isPatName, isDataCon, isFunOrPatName,isTypeCon,isTypeSig,isFunBind,isPatBind,isSimplePatBind+    ,isComplexPatBind,isFunOrPatBind,isClassDecl,isInstDecl,isDirectRecursiveDef+    ,usedWithoutQual,canBeQualified, hasFreeVars,isUsedInRhs, isUsedInRhsName, returnRHS, returnRHS2, getParams+    ,findPNT,findPN, findPN', findPNRHS      -- Try to remove this.+    ,findPNs, findEntity, findEntityWithLocation+    ,sameOccurrence, sameOccurrence2+    ,defines,definesTypeSig, isTypeSigOf, defines2, defines3, defines', definesPNT+    ,HasModName(hasModName), HasNameSpace(hasNameSpace)  +   +    +    -- ** Modules and files+    ,clientModsAndFiles,serverModsAndFiles,isAnExistingMod+    ,fileNameToModName, strToModName, modNameToStr, newProj, addFile, chase++    -- ** Locations+    ,defineLoc, useLoc,locToPNT,locToPN,locToExp, locToExp2, locToPat, locToLocalPat, getStartEndLoc , isLocalPNT++ -- * Program transformation +    -- ** Adding+    ,addDecl ,addItemsToImport, addHiding, rmItemsFromImport, addItemsToExport, addTypeSigDecl+    ,addParamsToDecls, addGuardsToRhs, addImportDecl, duplicateDecl, moveDecl+    -- ** Rmoving+    ,rmDecl, rmTypeSig, commentOutTypeSig, insertComment, extractComment, insertTerm, rmParams+    ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete)+    -- ** Updating+    ,Update(update)+    ,qualifyPName,rmQualifier,renamePN,replaceNameInPN,autoRenameLocalVar++-- * Miscellous+    -- ** Parsing, writing and showing+   ,parseSourceFile, {-parseSourceFile2,-} writeRefactoredFiles, showEntities ,showPNwithLoc, parsePrelude+    -- ** Locations+   ,toRelativeLocs, rmLocs, rmAllLocs+    -- ** Default values+   ,defaultPN,defaultPNT,defaultModName,defaultExp,defaultPat+  +    -- ** Identifiers, expressions, patterns and declarations+    ,pNTtoPN,pNTtoName,pNtoName,nameToPNT, nameToPN,pNtoPNT, declToName, declToName2,declToPNT, declToPNT', declToPName, declToPName2+    ,expToPNT, expToPN, nameToExp, nameToIdent,pNtoExp,patToPNT, patToPN, nameToPat,pNtoPat, typToPNT, nameToTyp+    ,definingDecls, definedPNs, definedPNsForConstr+    ,simplifyDecl, createFunc, createFunc', createFuncFromPat, createTypFunc, createTypFunc', createDataFunc+    -- ** Others+   ,mkNewName, applyRefac, applyRefacToClientMods+                   +    -- The following functions are not in the the API yet.+    ,getDeclToks, causeNameClashInExports, inRegion , ghead, glast, gfromJust, unmodified, prettyprint, prettyprintGuardsAlt,+    getDeclAndToks, wildCardAllPNs+    +    -- Type checker stuff+    ,checkTypes, getDataName, checkTypes2, checkTypesInPat, getTypes, getContext, cleanTypes, addTypeDecl, getSig, getSigAsString, getSigOmitLast, lines2+ )+where+import Prelude hiding (putStr,putStrLn,writeFile,readFile)+import Maybe+import List hiding (delete)+import Char+--------------------------------+import PfeChase+import PFE0 +import PFE2+import PFE3(parseModule,parseModule', parseSourceFile', parseScopeSourceFile)+import PosSyntax hiding (ModuleName, HsName, SN)+import SourceNames ++import ScopeModule+import UniqueNames hiding (srcLoc)+import HsName+import HsLexerPass1+import AbstractIO +import PNT +import TiPNT+import SimpleGraphs(reverseGraph,reachable)+import Ents hiding (isValue)+import Relations+import QualNames+import TypedIds hiding (NameSpace, HasNameSpace)+import WorkModule++import PrettyPrint+import Unlit(readHaskellFile,writeHaskellFile)+import MUtils hiding (swap)+import EditorCommands(sendEditorModified)+import qualified MT(lift)+import HsTokens+-------------------------+import RefacTypeSyn+import RefacLocUtils+import LocalSettings+-------------------------+--import DriftStructUtils  +import StrategyLib hiding (findFile, fail, (>>=), (>>), return, mfix, Monad, Functor, MonadFix, MonadPlus, fmap, (=<<),+                           sequence_, sequence, mapM_, mapM, liftM5, liftM4, liftM3, mzero, mplus, guard, filterM, msum,+                           join, mapAndUnzipM, zipWithM, zipWithM_, foldM, when, unless, liftM, liftM2, ap, MonadTrans, MonadIO,+                           fix, lift, liftIO, StateT, runStateT, State, runState )+import Control.Monad.State+import TypeCheck++#if __GLASGOW_HASKELL__ <604 ++instance (Monoid a, Monoid b) => Monoid (a,b) where+   mappend (a,b) (a',b') = (mappend a a', mappend b b')+   mempty                = (mempty, mempty)+#endif+------------------------------------------------------------------------------------------++{- | The Delete class. -}+class (Term t, Term t1)=>Delete t t1 where+   +  -- | Delete the occurrence of a syntax phrase in a given context.+  delete::(MonadPlus m, MonadState (([PosToken],Bool),t2) m)=> t   -- ^ The syntax phrase to delete.+                                                          ->t1     -- ^ The contex where the syntax phrase occurs.+                                                          ->m t1   -- ^ The result.++-- An expression can only be deleted in certain circumstances.+instance (Term t) => Delete HsExpP t where+  delete e t +    = applyTP (once_tdTP (failTP `adhocTP` inExp)`choiceTP` failure) t   +     where+     {-  inExp ((Exp (HsApp e1 e2))::HsExpP)+        |  sameOccurrence e e1 +        = do deleteFromToks e1+             return e2 -}+       inExp (Exp (HsApp e1 e2)::HsExpP)+        | sameOccurrence e e2 +        = do deleteFromToks e2 getStartEndLoc+             return e1+       inExp (Exp (HsList es))+         |isJust $ find (\x->sameOccurrence e x) es+        = do ((toks,_),others)<-get +             let toks'=deleteEnt toks $ getStartEndLoc toks e+             put ((toks',modified),others)+             return (Exp (HsList (es \\[e])))+       inExp _ = mzero+  +       sameOccurrence t1 t2+        = rmParen t1== rmParen t2 && srcLocs t1 == srcLocs t2    ++       rmParen (Exp (HsParen e)) = rmParen e+       rmParen e = e        ++       failure = error "Delete: This expression can not be deleted!"+instance (Term t) => Delete HsPatP t where+   +  delete p t+    = applyTP (once_tdTP (failTP `adhocTP` inPats)) t+    where+      inPats (ps::[HsPatP])+        |isJust $ find(\x->sameOccurrence p x) ps+        = do deleteFromToks p  getStartEndLoc+             return (ps\\[p])+      inPats _ = mzero+instance (Term t) => Delete HsTypeP t where+   +  delete p t+    = applyTP (once_tdTP (failTP `adhocTP` inTypes)) t+    where+      inTypes (t::HsTypeP)+        |isJust $ find(\x-> (rmAllLocs p)== (rmAllLocs x)) (flatternTApp t)+        = do deleteFromToks p  getStartEndLoc+             return (createDataFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) t) +                                              ( ( (tail (flatternTApp t)) <->  p  )))+      inTypes _ = mzero+      +      (<->) [] _ = []+      (<->) (x:xs) y +             | (rmAllLocs x) == (rmAllLocs y)   = xs <-> y     +             | otherwise = x : (xs <-> y)++      flatternTApp :: HsTypeP -> [HsTypeP]+      flatternTApp (Typ (HsTyFun t1 t2)) = flatternTApp t1 ++ flatternTApp t2+      flatternTApp (Typ (HsTyApp t1 t2)) = flatternTApp t1 ++ flatternTApp t2+      flatternTApp x = [x]  ++instance (Term t) => Delete HsImportDeclP t where+  delete imp t +   = applyTP (once_tdTP (failTP `adhocTP` inImps)) t+   where +     inImps (imps::[HsImportDeclP])+       | isJust $ find (\x->sameOccurrence imp x) imps+       = do deleteFromToks imp startEndLocIncFowNewLn+            return (imps \\ [imp])+     inImps _ = mzero+++{- | The Update class, -}+class (Term t, Term t1)=>Update t t1 where++  -- | Update the occurrence of one syntax phrase in a given scope by another syntax phrase of the same type.+  update::(MonadPlus m, MonadState (([PosToken],Bool),(Int,Int)) m)=>  t     -- ^ The syntax phrase to be updated.+                                                             -> t     -- ^ The new syntax phrase.+                                                             -> t1    -- ^ The contex where the old syntax phrase occurs.+                                                             -> m t1  -- ^ The result.+                                                             +instance (Term t) =>Update RhsP t where+ update oldRhs newRhs t+   = applyTP (once_tdTP (failTP `adhocTP` inRhs)) t+   where+     inRhs (r::RhsP)+      | r == oldRhs && srcLocs r == srcLocs oldRhs+         = do (newRhs',_) <- updateToks oldRhs newRhs prettyprint+              return newRhs'+     inRhs r = mzero++++instance (Term t) =>Update HsExpP t where++ update oldExp newExp  t+   = applyTP (once_tdTP (failTP `adhocTP` inExp)) t+   where +    inExp (e::HsExpP)+     | e == oldExp && srcLocs e == srcLocs oldExp +       = do (newExp', _) <-updateToks oldExp newExp prettyprint+            return newExp'+    inExp e = mzero++instance (Term t) =>Update HsStmtP t where++ update oldStmt newStmt  t+   = applyTP (once_tdTP (failTP `adhocTP` inStmt)) t+   where +    inStmt (s::HsStmtP)+     | s == oldStmt && srcLocs s == srcLocs oldStmt+       = do (newStmt', _) <-updateToks oldStmt newStmt prettyprint+            return newStmt'+    inStmt s = mzero++instance (Term t) => Update HsAltP t where+ update oldExp newExp  t+   = applyTP (once_tdTP (failTP `adhocTP` inExp)) t+   where +    inExp (e::HsAltP)+     | e == oldExp && srcLocs e == srcLocs oldExp +       = do (newExp', _) <-updateToks oldExp newExp prettyprint+            return newExp'+    inExp e = mzero++instance (Term t) =>Update PNT t where+  update oldExp newExp  t+   = applyTP (once_tdTP (failTP `adhocTP` inExp)) t+   where +    inExp (e::PNT)+     | e == oldExp && srcLocs e == srcLocs oldExp +       = do (newExp',_) <- updateToks oldExp newExp prettyprint+            return newExp'+    inExp e = mzero++instance (Term t) =>Update HsMatchP t where+  update oldExp newExp  t+   = applyTP (once_tdTP (failTP `adhocTP` inExp)) t+   where +    inExp (e::HsMatchP)+     | e == oldExp && srcLocs e == srcLocs oldExp +       = do (newExp',_) <- updateToks oldExp newExp prettyprint+            return newExp'+    inExp e = mzero+    +instance (Term t) =>Update HsPatP t where++ update oldPat newPat  t+   = applyTP (once_tdTP (failTP `adhocTP` inPat)) t+   where +    inPat (p::HsPatP)+     | p == oldPat && srcLocs p == srcLocs oldPat +       = do (newPat', _) <- updateToks [oldPat] [newPat] (prettyprintPatList False)+            return $ ghead "update" newPat'+    inPat e = mzero++instance (Term t) =>Update [HsPatP] t where++ update oldPat newPat  t+   = applyTP (once_tdTP (failTP `adhocTP` inPat)) t+   where +    inPat (p::[HsPatP])+     | sameOccurrence p oldPat +       = do  (newPat', _) <- updateToks oldPat newPat (prettyprintPatList False)+             return newPat'+    inPat e = mzero++instance (Term t) =>Update [HsDeclP] t where++ update oldDecl newDecl  t+   = applyTP (once_tdTP (failTP `adhocTP` inDecl)) t+   where +    inDecl (d::[HsDeclP])+     | sameOccurrence d oldDecl +       = do+            (newDecl',_) <- updateToks oldDecl newDecl prettyprint+            return newDecl'+    inDecl e = mzero++instance (Term t) =>Update HsDeclP t where++ update oldDecl newDecl  t+   = applyTP (once_tdTP (failTP `adhocTP` inDecl)) t+   where +    inDecl (d::HsDeclP)+     | sameOccurrence d oldDecl +       = do (newDecl',_) <- updateToks oldDecl newDecl prettyprint+            return newDecl'+    inDecl e = mzero++instance (Term t) =>Update HsImportDeclP t where++ update oldImpDecl newImpDecl  t+   = applyTP (once_tdTP (failTP `adhocTP` inDecl)) t+   where +    inDecl (d::HsImportDeclP)+     | sameOccurrence d oldImpDecl +       =do (newImpDecl', _) <-updateToks oldImpDecl newImpDecl prettyprint+           return newImpDecl'+    inDecl e = mzero++instance (Term t) => Update HsExportEntP t where+   update oldEnt@(EntE s) newEnt@(EntE s1) t+     = applyTP (once_tdTP (failTP `adhocTP` inEnt)) t+       where+         inEnt (e::HsExportEntP)+           | sameOccurrence e oldEnt+          =  do (s1',_) <- updateToks s s1 prettyprint+                return (EntE s1')+         inEnt e = mzero++instance (Term t) => Update HsTypeP t where+ update oldType newType t+   = applyTP (once_tdTP (failTP `adhocTP` inType)) t +   where+     inType (t::HsTypeP)+        | sameOccurrence t oldType+       = do (newType', _) <- updateToks oldType newType prettyprint+            return newType'+     inType t = mzero++instance (Term t) => Update HsConDeclP t where+ update oldType newType t+   = applyTP (once_tdTP (failTP `adhocTP` inType)) t +   where+     inType (t::HsConDeclP)+        | sameOccurrence t oldType+       = do (newType', _) <- updateToks oldType newType prettyprint+            return newType'+     inType t = mzero++{- ++{- | The Swap Class. The instances may be not complete, tell us what you need so that we can add it.-}+class (Term t, Term t1 ) => Swap t t1 where++  -- | Swap the occurrences of two syntax phrases( of the same type) in a given scope.+  swap :: (MonadState (([PosToken],Bool),t2) m)=> t   -- ^ The first syntax phrase.+                                               -> t   -- ^ The second syntax phrase.+                                               ->t1   -- ^ The context where the two syntax phrases occur.+                                               ->m t1 -- ^ The result.++instance (Term t)=>Swap HsExpP t  where +  swap e1 e2  t+    = do  swapInToks e1 e2+          applyTP (full_tdTP (idTP `adhocTP` inExp)) t       -- both full_td and full_bu should wor                       +    where +      inExp (e ::HsExpP)+       | sameOccurrence e e1                                  +         = return  e2                          +      inExp (e::HsExpP)+       | e == e2 && srcLocs e == srcLocs e2+         = return e1+      inExp x = return x++instance (Term t) => Swap HsPatP t where+  swap p1 p2 t +   = do swapInToks p1 p2 +        applyTP (full_tdTP (idTP `adhocTP` inPat)) t +    where+      inPat (p::HsPatP)+       | sameOccurrence p p1                                  +        = return  p2       +      inPat (p::HsPatP)+       | sameOccurrence p p2+         = return p1+      inPat x = return x++instance (Term t) => Swap HsTypeP t where+   swap t1 t2 t +     = do swapInToks t1 t2+          applyTP (full_tdTP (idTP `adhocTP` inType)) t+     where+       inType (t::HsTypeP)+        | sameOccurrence t t1+          = return t2+       inType (t::HsTypeP)+        | sameOccurrence t t2+         = return t1+       inType t = return t +-}++class (DeclStartLoc t) =>CanHaveWhereClause t where++ canHaveWhereClause:: t-> Bool++instance CanHaveWhereClause HsMatchP where+ + canHaveWhereClause t = True++instance CanHaveWhereClause HsDeclP where+ canHaveWhereClause t = isPatBind t ++instance CanHaveWhereClause HsAltP where+  canHaveWhereClause t = True++{-+instance CanHaveWhereClause HsModuleP where+  canHaveWhereClause t = True+-}++instance CanHaveWhereClause HsExpP where+  canHaveWhereClause t = False++instance CanHaveWhereClause HsStmtP where+  canHaveWhereClause t = False++  +class (StartEndLoc t) =>DeclStartLoc  t where+  +  -- | Given a syntax phrase, get the start location of enclosed top-level declaration list.+  declStartLoc:: [PosToken]->t->Maybe SimpPos++instance DeclStartLoc HsMatchP where+  declStartLoc toks (HsMatch loc1 name pats rhs ds)+    = if ds/=[] then Just $ fst (getStartEndLoc toks (ghead "declStartLoc" ds))+                else Nothing++instance DeclStartLoc HsDeclP where+  declStartLoc toks (Dec (HsPatBind loc p rhs ds))+     = if ds/=[] then Just$ (fst (getStartEndLoc toks (ghead "declStartLoc" ds)))+                 else Nothing+  declStartLoc toks _ = Nothing++instance DeclStartLoc HsExpP where+  declStartLoc toks letExp@(Exp (HsLet ds e))+    = if ds/=[] then Just $ fst (getStartEndLoc toks (ghead "declStartLoc" ds))+                else let (startPos,endPos)=getStartEndLoc toks letExp+                         expToks= getToks (startPos,endPos) toks +                in Just $ ((tokenPos.(ghead "declStartLoc")) $ dropWhile (not.isIn) expToks)+instance DeclStartLoc HsAltP where+ declStartLoc toks (HsAlt loc p rhs ds)  +    =if ds/=[] then Just $ (fst (getStartEndLoc toks (ghead "declStartLoc" ds)))+               else Nothing++instance DeclStartLoc HsStmtP where+ declStartLoc toks (HsLetStmt ds stmts)+   = if ds/=[] then Just $ fst (getStartEndLoc toks (ghead "declStartLoc" ds))+               else Just $ fst (getStartEndLoc toks stmts)   -- Qn: Is this possible?+++-- | Return True if syntax phrases t1 and t2 refer to the same one.+sameOccurrence:: (Term t, Eq t) => t -> t -> Bool+sameOccurrence t1 t2+ = t1==t2 && srcLocs t1 == srcLocs t2+ +-- | Return True if syntax phrases t1 and t2 refer to the same one.+sameOccurrence2:: (Term t, Eq t) => t -> t -> Bool+sameOccurrence2 t1 t2+ = srcLocs t1 == srcLocs t2 + +sameName :: PNT -> PNT -> Bool+sameName (PNT (PN (UnQual n) _)_ _) (PNT (PN (UnQual n2) _)_ _)+ = isPrefixOf n n2 || n == n2++{- | The 'HasNameSpace' class. -}+class HasNameSpace t where+   hasNameSpace::t->NameSpace++instance HasNameSpace PNT where+   hasNameSpace (PNT _ Value _)           = ValueName+   hasNameSpace (PNT _ (ConstrOf _ _ ) _) = DataCon+   hasNameSpace (PNT _ (FieldOf _ _ ) _)  = ValueName+   hasNameSpace (PNT _ (MethodOf _  _ _) _)  = ValueName+   hasNameSpace (PNT _ (Class _  _) _)       = ClassName+   hasNameSpace (PNT _ (Type _) _ )       = TypeCon     -- It is also possible that it is a type variable.+   hasNameSpace  _                        = Other       -- We don't care about Assertion & Property so far.++instance HasNameSpace ENT  where+   hasNameSpace (Ent _ _ Value)           = ValueName+   hasNameSpace (Ent _ _ (ConstrOf _ _ )) = DataCon+   hasNameSpace (Ent _ _ (FieldOf _ _ ))  = ValueName+   hasNameSpace (Ent _ _ (MethodOf _ _ _))  = ValueName+   hasNameSpace (Ent _ _ (Class _  _))       = ClassName+   hasNameSpace (Ent _ _ (Type _))        = TypeCon     +   hasNameSpace  _                        = Other       ++----------------------------------------------------------------------------------------------+-- |Create a new project+newProj args = do +             newProject     +             addPaths True args+             +-- |Add new file to a project+addFile fileName + = addPaths False fileName ++-- |Chase filenames+chase fileNames+ = findMissing fileNames++-- |Compose ModuleName from  String.+strToModName::String->ModuleName+strToModName name = if name =="Main" then MainModule "Main.hs"  -- THIS IS BASED ON ASSUMPTION.+                                     else PlainModule name +-- |From ModuleName to string.+modNameToStr::ModuleName->String+modNameToStr (PlainModule name) = name+modNameToStr (MainModule _)     = "Main"            +                 +-- | From file name to module name.+--fileNameToModName::( )=>String->PFE0MT n i ds ext m ModuleName      ++fileNameToModName::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+                   String->PFE0MT n i ds ext m ModuleName         +fileNameToModName fileName = +  do gf <- getCurrentModuleGraph+     let fileAndMods = [(m,f)|(f,(m,ms))<-gf]+         f = filter (\(m,f) -> f==fileName) fileAndMods+     if f ==[] then error $ "Can't find module name"+                    else return $ (fst.head) f++-- | Return the client module and file names. The client modules of module, say m, are those modules+-- which import m directly or indirectly.++-- clientModsAndFiles::( ) =>ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]+clientModsAndFiles::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+                     ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]+clientModsAndFiles m =+  do gf <- getCurrentModuleGraph+     let fileAndMods = [(m,f)|(f,(m,ms))<-gf]+         g           = (reverseGraph.(map snd)) gf     +         clientMods  = reachable g [m] \\ [m]+         clients     = concatMap (\m'->[(m,f)|(m,f)<-fileAndMods, m==m']) clientMods+     return clients++-- | Return the server module and file names. The server modules of module, say  m, are those modules+-- which are directly or indirectly imported by module m.++--serverModsAndFiles::( )=>ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]++serverModsAndFiles::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+                     ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]+serverModsAndFiles m =+   do gf <- getCurrentModuleGraph+      let fileAndMods = [(m,f)|(f,(m,ms))<-gf]+          g           = (map snd) gf  +          serverMods  = reachable g [m] \\ [m]+          servers     = concatMap (\m'->[(m,f)|(m,f)<-fileAndMods, m==m']) serverMods+      return servers++-- | Return True if the given module name exists in the project.+--isAnExistingMod::( ) =>ModuleName->PFE0MT n i ds ext m Bool+++isAnExistingMod::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+                  ModuleName->PFE0MT n i ds ext m Bool++isAnExistingMod m +  =  do ms<-allModules+        return (elem m ms)++{-Whenever an identifier is imported, the qualified name is imported, whereas the unqualified name+ may or may not be imported. -}++-- | Return all the possible qualifiers for the identifier. The identifier is not inscope if the +-- result is an empty list.+hsQualifier::PNT                   -- ^ The identifier.+            ->InScopes             -- ^ The in-scope relation.+            ->[ModuleName]         -- ^ The result.+hsQualifier pnt@(PNT pname _ _ ) inScopeRel+  = let r = filter ( \ ( name, nameSpace, modName, qual) -> pNtoName pname == name+                   && hasModName pname == Just modName && hasNameSpace pnt == nameSpace +                   && isJust qual) $ inScopeInfo inScopeRel+    in  map (\ (_,_,_,qual) -> fromJust qual ) r+                            +hsQualifier2::PNT                   -- ^ The identifier.+            ->InScopes             -- ^ The in-scope relation.+            ->[ModuleName]         -- ^ The result.+hsQualifier2 pnt@(PNT pname _ _ ) inScopeRel+  = let r = filter ( \ ( name, nameSpace, modName, qual) -> pNtoName pname == name && isJust qual) $ inScopeInfo inScopeRel+                 +    in  map (\ (_,_,_,qual) -> fromJust qual ) r   +    +isQuald :: [ModuleName] -> String -> Bool+isQuald [] _ = False+isQuald ((PlainModule s):xs) n + | s == n = True+ | otherwise = isQuald xs n+isQuald (x:xs) n = isQuald xs n    +                     +-- |Process the inscope relation returned from the parsing and module analysis pass, and +-- return a list of four-element tuples. Each tuple contains an identifier name, the identifier's namespace+-- info, the identifier's defining module name and its qualifier name. The same identifier may have multiple+-- entries in the result because it may have different qualifiers. This makes it easier to decide whether the+-- identifier can be used unqualifiedly by just checking whether there is an entry for it with the qualifier field+-- being Nothing.+-- +inScopeInfo::InScopes                                                -- ^ The inscope relation .+           ->[(String, NameSpace, ModuleName, Maybe ModuleName)]     -- ^ The result+inScopeInfo inScopeRel =nub $  map getEntInfo $ relToList inScopeRel +  where +     getEntInfo (qual, ent@(Ent modName ident _))+       =(identToName ident, hasNameSpace ent,  modName, getQualifier qual)+       +-- | Process the export relation returned from the parsing and module analysis pass, and +--   return a list of trhee-element tuples. Each tuple contains an identifier name, the +--   identifier's namespace info, and the identifier's define module. +exportInfo::Exports                             -- ^ The export relation.+          -> [(String, NameSpace, ModuleName)]  -- ^ The result+exportInfo exports = nub $ map getEntInfo  exports+  where +    getEntInfo (_, ent@(Ent modName ident _))+      =(identToName ident, hasNameSpace ent,  modName)++-- | Return True if the identifier is inscope and can be used without a qualifier.          +isInScopeAndUnqualified::String       -- ^ The identifier name.+                       ->InScopes     -- ^ The inscope relation +                       ->Bool         -- ^ The result.+isInScopeAndUnqualified id inScopeRel+ = isJust $ find (\ (x, _,_, qual) -> x == id && isNothing qual ) $ inScopeInfo inScopeRel+ +--Id is defined in two modules: HsNames.hs (type Id = String) and PosName.hs (type Id = SN HsNames.Id)+identToName (HsVar (SN i _)) = i+identToName (HsCon (SN i _)) = i++-- | Return True if the current module is exported either by default or by specifying the module name in the export.+modIsExported::HsModuleP  -- ^ The AST of the module+               ->Bool     -- ^ The result+modIsExported mod+   = let exps    = hsModExports mod+         modName = hsModName mod+     in if isNothing exps+           then True+           else isJust $ find (==(ModuleE modName)) (fromJust exps)+                      +-- | Return True if the identifier is exported either implicitly or explicitly.         +isExported::PNT         -- ^ The identifier.+           ->Exports    -- ^ The export relation.+           ->Bool       -- ^ The result.+isExported pnt@(PNT pn t1 _) exps+   = if isTopLevelPNT pnt +       then case hasModName pn of +               Just modName  -> isJust (find (\(name, nameSpace, modName1) -> name == pNtoName pn+                                         && modName == modName1 && hasNameSpace pnt == nameSpace) $ exportInfo exps)  +               Nothing       -> False+       else False    ++-- | Return True if an identifier is explicitly exported by the module.+isExplicitlyExported::PName          -- ^ The identifier+                     ->HsModuleP    -- ^ The AST of the module+                     ->Bool         -- ^ The result+isExplicitlyExported pn mod+  = findEntity pn $ hsModExports mod++{-+causeNameClashInExports::String      -- ^ The identifier name+                        ->HsModuleP  -- ^ The AST of the module+                        ->Exports    -- ^ The export relation of the module+                        ->Bool       -- ^ The result -}++-- Note that in the abstract representation of exps, there is no qualified entities.+causeNameClashInExports  pn newName mod exps +  = let modNames=nub (concatMap (\(x, Ent modName _ _)->if show x==show newName +                                                        then [modName]+                                                        else []) exps)+    in (isExplicitlyExported pn mod) && +        ( any (modIsUnQualifedImported mod) modNames +            || elem (let (SN modName1 _) =hsModName mod+                     in modName1)  modNames)+ where     +    modIsUnQualifedImported mod modName+     =let imps =hsModImports mod+      in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify  _ h)->modName==modName1 && (not qualify)) imps++          +-------------------------------------------------------------------------------------------------+{-append an import declaration to the end of the import list in the module, this functions+  modifies both the token stream and the AST+-}++-------------------------------------------------------------------------------------+addImportDecl mod@(HsModule _ _ _ imp decls) moduleName qualify alias hide idNames +  = do ((toks, _),(v,v1)) <- get+       let (toks1, toks2)+               =if imps' /= []+                   then let (startLoc, endLoc) = startEndLocIncComments toks (last imps')+                            (toks1, toks2)= break (\t->tokenPos t==endLoc) toks+                        in (toks1 ++ [ghead "addImportDecl1" toks2], tail toks2)    +                   else if decls /=[]  +                          then let startLoc = fst $ startEndLocIncComments toks (ghead "addImportDecl1" decls)+                                   (toks1, toks2) = break (\t ->tokenPos t==startLoc) toks  +                               in (toks1,  toks2)+                          else (toks,[])+           before = if toks1/=[] && endsWithNewLn (glast "addImportDecl1" toks1) then "" else "\n"+           after  = if (toks2 /=[] && startsWithNewLn (ghead "addImportDecl1" toks2)) then "" else "\n"         +           colOffset = if imps'==[] && decls==[] +                        then 1  +                        else getOffset toks+                                $ if imps'/=[] then fst $ startEndLoc toks  (ghead "addImportDecl1" imps') +                                               else fst $ startEndLoc toks  (ghead "addImportDecl1" decls)+           impToks =tokenise (Pos 0 v1 1) (colOffset-1) True +                      $ before++(render.ppi) impDecl++"\n" ++ after  --- refactorer this+       (impDecl', _) <- addLocInfo (impDecl,impToks)+       let toks' = toks1++impToks++toks2+       put ((toks',modified), ((tokenRow (glast "addImportDecl1" impToks) - 10,v1)))  -- 10: step ; generalise this.+       return (mod {hsModImports = imp ++ [impDecl']})+  where+     alias' = case alias of +                  Just m -> Just $ SN (PlainModule m) loc0+                  _      -> Nothing+     impDecl = HsImportDecl loc0 (SN (PlainModule moduleName) loc0) qualify alias' +                      (if idNames==[] && hide==False +                          then Nothing+                          else  (Just (hide, map nameToEnt idNames)))  -- what about "Main"+     imps' = imp \\ prelimps+     nameToEnt name = Var (nameToPNT name)+    ++---------------------------------------------------------------------------------------++-- | Adding a declaration to the declaration list of the given syntax phrase(so far only adding function\/pattern binding+--  has been tested).  If the second argument is Nothing, then the declaration will be added to the beginning of the+-- declaration list, but after the data type declarations is there is any.+{-addDecl::( ) =>t                -- ^ The AST.+   -> Maybe PName     -- ^ If this is Just, then the declaration will be added right after this identifier's definition.+   ->([HsDeclP], Maybe [PosToken])  -- ^ The declaration to be added, in both AST and Token stream format (optional).+   ->Bool               -- ^ True means the declaration is a toplevel declaration.+   ->m t+-}++addDecl::((MonadState (([PosToken],Bool),(Int,Int)) m), StartEndLoc t, HsDecls t, Printable t)+                    =>t-> Maybe PName +                    ->([HsDeclP], Maybe [PosToken]) +                    ->Bool               +                    ->m t++addDecl parent pn (decl, declToks) topLevel+ = if isJust pn +     then appendDecl parent (fromJust pn) (decl, declToks)+     else if topLevel +            then addTopLevelDecl (decl, declToks) parent+            else addLocalDecl parent (decl,declToks)+ where++  {- Add a definition to the beginning of the definition declaration list, but after the data type declarations+     if there is any. The definition will be pretty-printed if its token stream is not provided. -}+  addTopLevelDecl (decl, declToks) parent +    = do let decls = hsDecls parent +             (decls1,decls2)=break (\x->isFunOrPatBind x || isTypeSig x) decls      +         ((toks,_),(v1, v2))<-get   +         let loc1 = if decls2/=[]  -- there are function/pattern binding decls. +                    then let ((startRow,_),_) = startEndLocIncComments toks (ghead "addTopLevelDecl"  decls2)+                         in  (startRow, 1)+                    else simpPos0  -- no function/pattern binding decls in the module.+             (toks1, toks2) = if loc1==simpPos0  then (toks, [])+                                 else break (\t->tokenPos t==loc1) toks+             declStr = case declToks of +                        Just ts -> concatMap tokenCon ts ++"\n"+                        Nothing -> prettyprint decl++"\n\n"+             colOffset = if decls ==[] then 1 else getOffset toks $ fst (getStartEndLoc toks (head decls))+             newToks = tokenise (Pos 0 v1 1) colOffset True declStr+             toks' = toks1 ++ newToks ++ toks2+         put ((toks',modified),((tokenRow (glast "addTopLevelDecl" newToks) -10), v2)) +         -- (decl',_) <- addLocInfo (decl, newToks)+         -- error "after"                                   +         return (replaceDecls parent (decls1++decl++decls2))++  appendDecl parent pn (decl, declToks)+    = do ((toks,_),(v1, v2))<-get   +         -- error (show parent ++ "----" ++ show pn ++ "-----" ++ show (decl, declToks))+         let (startPos,endPos) = startEndLocIncFowComment toks (ghead "appendDecl1" after) +             -- divide the toks into three parts.+             (toks1, toks2, toks3) = splitToks' (startPos, endPos) toks +              --get the toks defining pn+             defToks = dropWhile (\t->tokenPos t /=startPos) toks2+             offset = getOffset toks $ fst (getStartEndLoc toks (ghead "appendDecl2" decls))+             declStr = case declToks of +                          Just ts -> concatMap tokenCon ts+                          Nothing -> prettyprint decl +             newToks = tokenise (Pos 0 v1 1) offset True declStr +             toks' = if  endsWithNewLn  (glast "appendDecl2" toks2)+                      then  toks1++ toks2 ++ (newLnToken: newToks) ++ [newLnToken]++ compressPreNewLns toks3  +                      else  replaceToks toks startPos endPos (defToks++[newLnToken,newLnToken]++newToks)   -- ++[newLnToken])+         -- (decl',_) <- addLocInfo (decl, newToks)+         put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))  +         return (replaceDecls parent (before ++ [ghead "appendDecl14" after]++decl++ tail after))        +      where +        decls = hsDecls parent +        (before,after) = break (defines pn) decls -- Need to handle the case that 'after' is empty?+        splitToks' (startPos, endPos) toks +           = let (ts1, ts2, ts3) = splitToks ( startPos, endPos) toks  +                 (ts11, ts12) = break hasNewLn (reverse ts1)+             in (reverse ts12, reverse ts11++ts2, ts3)      ++  -- This function need to be tested.+  addLocalDecl parent (newFun, newFunToks)+    =do+        ((toks,_), (v1, v2))<-get  +        let (startPos@(_,startCol),endPos'@(endRow',_))  --endPos' does not include the following newline or comment.+              =if localDecls==[] then startEndLocIncFowComment toks parent    --The 'where' clause is empty+                                 else startEndLocIncFowComment toks localDecls +            toks1=gtail "addLocalDecl1"  $ dropWhile (\t->tokenPos t/=endPos') toks +            ts1=takeWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t)  toks1    +            --nextTokPos is only used to test whether there is a 'In' or a nested comment. +            nextToks = (dropWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t) toks1)+            nextTokPos= case nextToks of+                           [] -> simpPos0 +                           l  -> (tokenPos.ghead "addLocalDecl:0") l +            oldToks'=getToks (startPos,endPos') toks+            needNewLn=if nextTokPos==simpPos0  --used to decide whether add a new line character before a introduced fun.+                      then if toks1==[] then (not.endsWithNewLn) (glast "addLocalDecl:1" oldToks')+                                        else (not.endsWithNewLn) (last ts1) +                      else endRow'==fst nextTokPos || (not.endsWithNewLn) (glast "addLocalDecl:2" oldToks')+            --endPos@(endRow,_)=if ts1==[] then endPos'+            --                             else tokenPos (last ts1)+            offset = if localDecls == [] then getOffset toks startPos + 2 else getOffset toks startPos+            newToks = tokenise (Pos 0 v1 1) offset True +                           $ if needNewLn then "\n"++newSource else newSource   --  ++"\n"+            toks'=replaceToks toks startPos endPos' (oldToks'++newToks) -- ++[newLnToken])           +        (newFun',_) <- addLocInfo (newFun, newToks) -- This function calles problems because of the lexer.+        put ((toks',modified),((tokenRow (glast "addLocalDecl:3" newToks) -10), v2))  +        return (replaceDecls parent (hsDecls parent ++ newFun'))+    where+         localDecls = hsDecls parent+        +         newSource  = if localDecls == []+                      then "where\n"++ concatMap (\l-> "  "++l++"\n") (lines newFun')+                      else newFun'+            where+            offset1 = case newFunToks of +                        Just ts -> lengthOfToks (takeWhile  isWhiteSpace  ts)   +                        Nothing -> 0+            newFun' = case newFunToks of +                           Just ts ->let offset = lengthOfToks (takeWhile isWhiteSpace ts) +                                     in concatMap tokenCon (removeOffset offset ts) +                           Nothing -> prettyprint newFun +            removeOffset offset toks +                = let groupedToks = groupTokensByLine toks+                  in  concatMap  (doRmWhites offset) groupedToks++                           +addTypeSigDecl parent pn (decl, declToks) topLevel+ = if isJust pn +     then appendDecl parent (fromJust pn) (decl, declToks)+     else if topLevel +            then addTopLevelDecl (decl, declToks) parent+            else addLocalDecl parent (decl,declToks)+ where++  {- Add a definition to the beginning of the definition declaration list, but after the data type declarations+     if there is any. The definition will be pretty-printed if its token stream is not provided. -}+  addTopLevelDecl (decl, declToks) parent +    = do let decls = hsDecls parent +             (decls1,decls2)=break (\x->isFunOrPatBind x || isTypeSig x) decls      +         ((toks,_),(v1, v2))<-get   +         -- error "blah"++         let loc1 = if decls2/=[]  -- there are function/pattern binding decls. +                    then let ((startRow,_),_) = startEndLocIncComments toks (ghead "addTopLevelDecl"  decls2)+                         in  (startRow, 1)+                    else simpPos0  -- no function/pattern binding decls in the module.+             (toks1, toks2) = if loc1==simpPos0  then (toks, [])+                                 else break (\t->tokenPos t==loc1) toks+             declStr = case declToks of +                        Just ts -> concatMap tokenCon ts+                        Nothing -> prettyprint decl++"\n\n"+             colOffset = if decls ==[] then 1 else getOffset toks $ fst (getStartEndLoc toks (head decls))+             newToks = tokenise (Pos 0 v1 1) colOffset True declStr+             toks' = toks1 ++ newToks ++ toks2+         put ((toks',modified),((tokenRow (glast "addTopLevelDecl" newToks) -10), v2))                                    +         return (replaceDecls parent (decl ++ decls1 ++decls2))++  appendDecl parent pn (decl, declToks)+    = do ((toks,_),(v1, v2))<-get   +         -- error (show parent ++ "----" ++ show pn ++ "-----" ++ show (decl, declToks))+         let (startPos,endPos) = startEndLocIncFowComment toks (ghead "appendDecl1" after) +             -- divide the toks into three parts.+             (toks1, toks2, toks3) = splitToks' (startPos, endPos) toks +              --get the toks defining pn+             defToks = dropWhile (\t->tokenPos t /=startPos) toks2+             offset = getOffset toks $ fst (getStartEndLoc toks (ghead "appendDecl2" decls))+             declStr = case declToks of +                          Just ts -> concatMap tokenCon ts+                          Nothing -> prettyprint decl +             newToks = tokenise (Pos 0 v1 1) offset True declStr +             toks' = if  endsWithNewLn  (glast "appendDecl2" toks2)+                      then  toks1++ (newLnToken: newToks) ++ [newLnToken]++ toks2 ++ compressPreNewLns toks3  +                      else  replaceToks toks startPos endPos ((newToks ++ [newLnToken]) ++ defToks++[newLnToken,newLnToken])+         -- error $ show newToks+          -- (decl',_) <- addLocInfo (decl, newToks)+         put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))  +         return (replaceDecls parent (decl ++ [ghead "appendDecl14" after]++ before ++  tail after))        +      where +        decls = hsDecls parent +        (before,after) = break (defines pn) decls -- Need to handle the case that 'after' is empty?+        splitToks' (startPos, endPos) toks +           = let (ts1, ts2, ts3) = splitToks ( startPos, endPos) toks  +                 (ts11, ts12) = break hasNewLn (reverse ts1)+             in (reverse ts12, reverse ts11++ts2, ts3)      ++  -- This function need to be tested.+  addLocalDecl parent (newFun, newFunToks)+    =do+        ((toks,_), (v1, v2))<-get  +        let (startPos@(_,startCol),endPos'@(endRow',_))  --endPos' does not include the following newline or comment.+              =if localDecls==[] then startEndLocIncFowComment toks parent    --The 'where' clause is empty+                                 else startEndLocIncFowComment toks localDecls +            toks1=gtail "addLocalDecl1"  $ dropWhile (\t->tokenPos t/=endPos') toks +            ts1=takeWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t)  toks1    +            --nextTokPos is only used to test whether there is a 'In' or a nested comment. +            nextTokPos= case (dropWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t) toks1) of+                           [] -> simpPos0 +                           l  -> (tokenPos.ghead "addLocalFunInToks") l +            needNewLn=if nextTokPos==simpPos0  --used to decide whether add a new line character before a introduced fun.+                      then if toks1==[] then True+                                        else (not.endsWithNewLn) (last ts1) +                      else endRow'==fst nextTokPos +            --endPos@(endRow,_)=if ts1==[] then endPos'+            --                             else tokenPos (last ts1)+            offset = if localDecls == [] then getOffset toks startPos + 4 else getOffset toks startPos+            newToks = tokenise (Pos 0 v1 1) offset True +                          $ if needNewLn then "\n"++newSource else newSource++"\n"+            oldToks'=getToks (startPos,endPos') toks+            toks'=replaceToks toks startPos endPos' (oldToks'++newToks)         +            +        -- error "blah 2"  +        (newFun',_) <- addLocInfo (newFun, newToks) -- This function calles problems because of the lexer.+        put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))  +        return (replaceDecls parent (newFun' ++ hsDecls parent))+    where+         localDecls = hsDecls parent+        +         newSource  = if localDecls == []+                      then "where\n"++ concatMap (\l-> "  "++l++"\n") (lines newFun')+                      else newFun'+            where+            newFun' = case newFunToks of +                           Just ts -> concatMap tokenCon ts +                           Nothing -> prettyprint newFun                            +                           +addTypeDecl parent pn (decl, declToks) topLevel+ = if isJust pn +     then appendDecl parent (fromJust pn) (decl, declToks)+     else if topLevel +            then addTopLevelDecl (decl, declToks) parent+            else addLocalDecl parent (decl,declToks)+ where++  {- Add a definition to the beginning of the definition declaration list, but after the data type declarations+     if there is any. The definition will be pretty-printed if its token stream is not provided. -}+  addTopLevelDecl (decl, declToks) parent +    = do let decls = hsDecls parent +             (decls1,decls2)=break (\x->isFunOrPatBind x || isTypeSig x) decls      +         ((toks,_),(v1, v2))<-get   +         -- error "blah"++         let loc1 = if decls2/=[]  -- there are function/pattern binding decls. +                    then let ((startRow,_),_) = startEndLocIncComments toks (ghead "addTopLevelDecl"  decls2)+                         in  (startRow, 1)+                    else simpPos0  -- no function/pattern binding decls in the module.+             (toks1, toks2) = if loc1==simpPos0  then (toks, [])+                                 else break (\t->tokenPos t==loc1) toks+             declStr = case declToks of +                        Just ts -> concatMap tokenCon ts+                        Nothing -> prettyprint decl++"\n\n"+             colOffset = if decls ==[] then 1 else getOffset toks $ fst (getStartEndLoc toks (head decls))+             newToks = tokenise (Pos 0 v1 1) colOffset True declStr+             toks' = toks1 ++ newToks ++ toks2+         put ((toks',modified),((tokenRow (glast "addTopLevelDecl" newToks) -10), v2))                                    +         return (replaceDecls parent (decls1++decl++decls2))+  appendDecl parent pn (decl, declToks)+    = do ((toks,_),(v1, v2))<-get   +         -- error (show parent ++ "----" ++ show pn ++ "-----" ++ show (decl, declToks))+         let (startPos,endPos) = startEndLocIncFowComment toks (ghead "appendDecl1" after) +             -- divide the toks into three parts.+             (toks1, toks2, toks3) = splitToks' (startPos, endPos) toks +              --get the toks defining pn+             defToks = dropWhile (\t->tokenPos t /=startPos) toks2+             offset = getOffset toks $ fst (getStartEndLoc toks (ghead "appendDecl2" decls))+             declStr = case declToks of +                          Just ts -> concatMap tokenCon ts+                          Nothing -> prettyprint decl +             newToks = tokenise (Pos 0 v1 1) offset True declStr +             toks' = if  endsWithNewLn  (glast "appendDecl2" toks2)+                      then  toks1++ toks2 ++ (newLnToken: newToks) ++ [newLnToken]++ compressPreNewLns toks3  +                      else  replaceToks toks startPos endPos (defToks++[newLnToken,newLnToken]++newToks)+         -- (decl',_) <- addLocInfo (decl, newToks)+         put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))  +         return (replaceDecls parent (before ++ [ghead "appendDecl14" after]++ decl++ tail after))        +      where +        decls = hsDecls parent +        (before,after) = break (defines pn) decls -- Need to handle the case that 'after' is empty?+        splitToks' (startPos, endPos) toks +           = let (ts1, ts2, ts3) = splitToks ( startPos, endPos) toks  +                 (ts11, ts12) = break hasNewLn (reverse ts1)+             in (reverse ts12, reverse ts11++ts2, ts3)      ++  -- This function need to be tested.+  addLocalDecl parent (newFun, newFunToks)+    =do+        ((toks,_), (v1, v2))<-get  +        let (startPos@(_,startCol),endPos'@(endRow',_))  --endPos' does not include the following newline or comment.+              =if localDecls==[] then startEndLocIncFowComment toks parent    --The 'where' clause is empty+                                 else startEndLocIncFowComment toks localDecls +            toks1=gtail "addLocalDecl1"  $ dropWhile (\t->tokenPos t/=endPos') toks +            ts1=takeWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t)  toks1    +            --nextTokPos is only used to test whether there is a 'In' or a nested comment. +            nextTokPos= case (dropWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t) toks1) of+                           [] -> simpPos0 +                           l  -> (tokenPos.ghead "addLocalFunInToks") l +            needNewLn=if nextTokPos==simpPos0  --used to decide whether add a new line character before a introduced fun.+                      then if toks1==[] then True+                                        else (not.endsWithNewLn) (last ts1) +                      else endRow'==fst nextTokPos +            --endPos@(endRow,_)=if ts1==[] then endPos'+            --                             else tokenPos (last ts1)+            offset1 = case newFunToks of +                        Just ts -> lengthOfToks (takeWhile  isWhiteSpace  ts)   +                        Nothing -> 0+                      +            offset = if localDecls == [] then getOffset toks startPos + 2 -offset1 else getOffset toks startPos -offset1+            newToks = tokenise (Pos 0 v1 1) offset True +                          $ if needNewLn then "\n"++newSource else newSource++"\n"+            oldToks'=getToks (startPos,endPos') toks+            toks'=replaceToks toks startPos endPos' (oldToks'++newToks)         +            +        -- error "blah 2"  +        (newFun',_) <- addLocInfo (newFun, newToks) -- This function calles problems because of the lexer.+        put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))  +        return (replaceDecls parent (hsDecls parent ++ newFun'))+    where+         localDecls = hsDecls parent+        +         newSource  = if localDecls == []+                      then "where\n"++ concatMap (\l-> "  "++l++"\n") (lines newFun')+                      else newFun'+            where+            newFun' = case newFunToks of +                           Just ts -> concatMap tokenCon ts +                           Nothing -> prettyprint newFun +++-- | Remove the type signature that defines the given identifier's type from the declaration list.+{-rmTypeSig::(MonadState (([PosToken],Bool),t1) m)+            => PName       -- ^ The identifier whose type signature is to be removed.+            ->[HsDeclP]    -- ^ The declaration list+            ->m [HsDeclP]  -- ^ The result -}++rmTypeSig pn  t = applyTP (full_tdTP (idTP `adhocTP` inDecls)) t+  where +   inDecls (decls::[HsDeclP])+      | snd (break (definesTypeSig pn) decls) /=[] +     = do ((toks,_), others) <- get+          let (decls1,decls2)= break  (definesTypeSig pn) decls+              (toks',decls')=+               let sig@(Dec (HsTypeSig loc is c tp))=ghead "rmTypeSig" decls2  -- as decls2/=[], no problem with head +                   (startPos,endPos)=getStartEndLoc toks sig +               in if length is>1  +                     then let newSig=(Dec (HsTypeSig loc (filter (\x-> (pNTtoPN x)/=pn) is) c tp))+                              pnt = ghead "rmTypeSig" (filter (\x-> pNTtoPN x == pn) is)+                              (startPos1, endPos1) = let (startPos1', endPos1') = getStartEndLoc toks pnt+                                                     in if fromJust (elemIndex pnt is) >0+                                                        then extendForwards toks startPos1' endPos1' isComma+                                                        else extendBackwards toks startPos1' endPos1' isComma+                          in (deleteToks toks startPos1 endPos1,(decls1++[newSig]++tail decls2))+                     else  ((deleteToks toks startPos endPos),(decls1++tail decls2)) +          put ((toks',modified),others)+          return decls' +   inDecls x = return x++-- |Comment out the type signature that defines pn's type in the token stream and remove it from the AST. +commentOutTypeSig::(MonadState (([PosToken],Bool),t1) m)+            => PName       -- ^ The identifier.+            ->[HsDeclP]    -- ^ The deckaration list.+            ->m [HsDeclP]  -- ^ The result.+commentOutTypeSig pn decls  + =let (decls1,decls2)=break  (definesTypeSig pn) decls+  in if decls2/=[] then    --There is a type signature for pn+       do ((toks,_),others)<-get   +          let (toks',decls')=+               let sig@(Dec (HsTypeSig loc is c tp))=ghead "rmTypeSig" decls2  -- as decls2/=[], no problem with head +               in if length is>1   --This type signature also defines the type of  variables other than pn+                     then let newSig=(Dec (HsTypeSig loc (filter (\x-> (pNTtoPN x)/=pn) is) c tp))+                              pnt = ghead "commentTypeSig" $ filter (\x->pNTtoPN x==pn) is +                              (startPos,(endPosR, endPosC)) = getStartEndLoc toks pnt +                          in ((commentToks (startPos, (endPosR, endPosC)) toks),(decls1++[newSig]++tail decls2))+                     else let  (startPos,(endPosR, endPosC))=getStartEndLoc toks sig +                          in  ((commentToks  (startPos, (endPosR, endPosC)) toks),(decls1++tail decls2)) +          put ((toks',modified),others)+          return decls' +      else return decls  +++-- |Insert a term supplied as a string at the position supplied+insertTerm :: (HsDecls t, (MonadState (([PosToken], Bool), t1) m))+     => String       -- ^ The comment.+     -> PName      -- ^ The definition to which we want to add the comment+     -> t    -- ^ The declaration list.+     -> m t  -- ^ The result.+insertTerm com pn t+ = do+      ((toks,_),others)<-get+      let (startPos,endPos) = startEndLocIncFowComment toks (ghead "insertComment" after)+      let (toks', t') = ((insertTerms (startPos,endPos) toks com), t)+      put ((toks', modified), others)+      return t'+       where+        decls = hsDecls t+        (before,after) = break (defines pn) decls++-- |Insert a comment supplied as a string at the position supplied+insertComment :: (HsDecls t, (MonadState (([PosToken], Bool), t1) m))+     => String       -- ^ The comment.+     -> PName      -- ^ The definition to which we want to add the comment+     -> t    -- ^ The declaration list.+     -> m t  -- ^ The result.+insertComment com pn t+ = do+      ((toks,_),others)<-get+      let (startPos,endPos) = startEndLocIncFowComment toks (ghead "insertComment" after)+      let (toks', t') = ((insertComments (startPos,endPos) toks com), t)+      put ((toks', modified), others)+      return t'+       where+        decls = hsDecls t+        (before,after) = break (defines pn) decls+      +{- extractComment :: (HsDecls t, (MonadState (([PosToken], Bool), t1) m))+     => PName+     -> t+     -> m [PosToken] -}+extractComment pn t+  = do+       ((toks, _), others) <- get+       let (startPos, endPos) = startEndLocIncFowComment toks (ghead "extractComment" after)+       let toks' = extractComments (startPos, endPos) toks+       return toks'+         where+           decls = hsDecls t+           (before, after) = break (defines pn) decls    +++-- | Remove the declaration (and the type signature is the second parameter is True) that defines the given identifier+-- from the declaration list.+{-+rmDecl::(MonadState (([PosToken],Bool),t1) m)+        =>PName       -- ^ The identifier whose definition is to be removed.+        ->Bool        -- ^ True means including the type signature.+        ->[HsDeclP]   -- ^ The declaration list.+        -> m [HsDeclP]-- ^ The result.+-}+rmDecl pn incSig t = applyTP (once_tdTP (failTP `adhocTP` inDecls)) t+  where +    inDecls (decls::[HsDeclP])+      | snd (break (defines pn) decls) /=[] +      = do let (decls1, decls2) = break (defines pn) decls+               decl = ghead "rmDecl" decls2+           -- error $ (render.ppi) t -- ecl ++ (show decl) +           case isTopLevelPN  pn of+                     True   -> if incSig then rmTopLevelDecl decl =<< rmTypeSig pn decls+                                         else rmTopLevelDecl decl decls+                     False  -> if incSig then rmLocalDecl decl =<< rmTypeSig pn decls +                                         else rmLocalDecl decl decls+    inDecls x = mzero +    rmTopLevelDecl decl decls +      =do ((toks,_),others)<-get   +          let (startLoc, endLoc)=startEndLocIncComments toks decl      +              toks'=deleteToks toks startLoc endLoc+          put ((toks',modified),others)+          return (decls \\ [decl]) +          +  {- The difference between removing a top level declaration and a local declaration is:+     if the local declaration to be removed is the only declaration in current declaration list, +     then the 'where'/ 'let'/'in' enclosing this declaration should also be removed.+     Whereas, when a only top level decl is removed, the 'where' can not be removed.+   -}+   -- |Remove a location declaration that defines pn.+    rmLocalDecl decl decls+     =do ((toks,_),others)<-get   +         let (startPos,endPos)=getStartEndLoc toks decl   --startEndLoc toks decl  +             (startPos',endPos')=startEndLocIncComments toks decl       +             --(startPos',endPos')=startEndLocIncFowComment toks decl +             toks'=if length decls==1  --only one decl, which means the accompaning 'where',+                                       --'let' or'in' should be removed too.+                   then let (toks1,toks2)=break (\t->tokenPos t==startPos) toks --devide the token stream.+                              --get the  'where' or 'let' token+                            rvToks1=dropWhile (not.isWhereOrLet) (reverse toks1)+                            --There must be a 'where' or 'let', so rvToks1 can not be empty.+                            whereOrLet=ghead "rmLocalFunPatBind:whereOrLet" rvToks1 +                            --drop the 'where' 'or 'let' token+                            toks1'=takeWhile (\t->tokenPos t/=tokenPos whereOrLet) toks1+                            --remove the declaration from the token stream.+                            toks2'=gtail "rmLocalDecl" $ dropWhile (\t->tokenPos t/=endPos') toks2+                            --get the remained tokens after the removed declaration.+                            remainedToks=dropWhile isWhite toks2'+                        in if remainedToks==[] +                             then --the removed declaration is the last decl in the file.+                                  (compressEndNewLns toks1'++ compressPreNewLns toks2') +                             else if --remainedToks/=[], so no problem with head.+                                    isIn (ghead "rmLocalDecl:isIn"  remainedToks)  +                                         || isComma (ghead "rmLocalDecl:isComma" remainedToks) +                                        --There is a 'In' after the removed declaration.+                                   then if isWhere whereOrLet+                                           then deleteToks toks (tokenPos whereOrLet) endPos'+                                           else deleteToks toks (tokenPos whereOrLet) +                                                   $ tokenPos (ghead "rmLocalDecl:tokenPos" remainedToks)+                                        --delete the decl and adjust the layout                      +                                   else if isCloseSquareBracket (ghead "rmLocalDecl:isCloseSquareBracker" remainedToks) &&+                                           (isBar.(ghead "rmLocalDecl:isBar")) (dropWhile isWhite (tail rvToks1))+                                         then deleteToks toks (tokenPos((ghead "rmLocalDecl") +                                                        (dropWhile isWhite (tail rvToks1)))) endPos'+                                         else deleteToks toks (tokenPos whereOrLet) endPos' +                        --there are more than one decls+                   else  deleteToks toks startPos' endPos'+         put ((toks',modified),others)  --Change the above endPos' to endPos will not delete the following comments.+         return $ (decls \\ [decl])++{- ********* IMPORTANT : THIS FUNCTION SHOULD BE UPDATED TO THE NEW TOKEN STREAM METHOD ****** -}+-- | Duplicate a functon\/pattern binding declaration under a new name right after the original one.+duplicateDecl::(MonadState (([PosToken],Bool),t1) m)+                 =>[HsDeclP]            -- ^ The declaration list+                 ->PName                -- ^ The identifier whose definition is going to be duplicated+                 ->String               -- ^ The new name+                 ->m [HsDeclP]          -- ^ The result+{-there maybe fun/simple pattern binding and type signature in the duplicated decls+  function binding, and type signature are handled differently here: the comment and layout+  in function binding are preserved.The type signature is output ted by pretty printer, so+  the comments and layout are NOT preserved.+ -}+duplicateDecl decls pn newFunName+ = do ((toks,_), others)<-get   +      let (startPos, endPos) =startEndLocIncComments toks funBinding  +          {-take those tokens before (and include) the function binding and its following+            white tokens before the 'new line' token. (some times the function may be followed by +            comments) -}+          toks1 = let (ts1, ts2) =break (\t->tokenPos t==endPos) toks in ts1++[ghead "duplicateDecl" ts2]+          --take those token after (and include) the function binding+          toks2 = dropWhile (\t->tokenPos t/=startPos || isNewLn t) toks+      put((toks2,modified), others)+      --rename the function name to the new name, and update token stream as well+      funBinding'<-renamePN pn Nothing newFunName True funBinding+      --rename function name in type signature  without adjusting the token stream+      typeSig'  <- renamePN pn Nothing newFunName False typeSig+      ((toks2,_), others)<-get    +      let offset = getOffset toks (fst (startEndLoc toks funBinding))+          newLineTok = if toks1/=[] && endsWithNewLn (glast "doDuplicating" toks1)+                         then [newLnToken]+                         else [newLnToken,newLnToken] +          toks'= if typeSig/=[] +                 then let offset = tokenCol ((ghead "doDuplicating") (dropWhile (\t->isWhite t) toks2))+                          sigSource = concatMap (\s->replicate (offset-1) ' '++s++"\n")((lines.render.ppi) typeSig')+                          t = mkToken Whitespace (0,0) sigSource  +                      in  (toks1++newLineTok++[t]++(whiteSpacesToken (0,0) (snd startPos-1))++toks2)+                 else (toks1++newLineTok++(whiteSpacesToken (0,0) (snd startPos-1))++toks2) +      put ((toks',modified),others)+      return (typeSig'++funBinding')+     where +       declsToDup = definingDecls [pn] decls True False    +       funBinding = filter isFunOrPatBind declsToDup     --get the fun binding.+       typeSig    = filter isTypeSig declsToDup      --get the type signature.   +++------------------------------------------------------------------------------++-- | Add identifiers to the export list of a module. If the second argument is like: Just p, then do the adding only if p occurs+-- in the export list, and the new identifiers are added right after p in the export list. Otherwise the new identifiers are add+-- to the beginning of the export list. In the case that the export list is emport, then if the third argument is True, then create+-- an explict export list to contain only the new identifiers, otherwise do nothing.+{-+addItemsToExport::( )+                 => HsModuleP                           -- The module AST.    +                   -> Maybe PName                       -- The condtion identifier.+                   -> Bool                              -- Create an explicit list or not+                   -> Either [String] [HsExportEntP]    -- The identifiers to add in either String or HsExportEntP format.+                   -> m HsModuleP                       -- The result.+-}++addItemsToExport::(MonadState (([PosToken],Bool), t1) m)+                 => HsModuleP                           -- The module AST.    +                   -> Maybe PName                       -- The condtion identifier.+                   -> Bool                              -- Create an explicit list or not+                   -> Either [String] [HsExportEntP]    -- The identifiers to add in either String or HsExportEntP format.+                   -> m HsModuleP                       -- The result.+++addItemsToExport mod _  _ (Left [])  = return mod+addItemsToExport mod _  _ (Right []) = return mod+addItemsToExport mod@(HsModule loc modName exps imps ds) (Just pn) _ ids+  =  case exps  of+       Just ents ->let (e1,e2) = break (findEntity pn) ents+                   in if e2 /=[]  +                        then do ((toks,_),others)<-get   +                                let e = (ghead "addVarItemInExport" e2)+                                    es = case ids of +                                          (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'+                                          (Right es') -> es' +                                let (_,endPos) = getStartEndLoc toks e+                                    (t, (_,s)) = ghead "addVarItemInExport" $ getToks (endPos,endPos) toks+                                    newToken = mkToken t endPos (s++","++ showEntities (render.ppi) es) +                                    toks' = replaceToks toks endPos endPos [newToken]+                                put ((toks',modified),others)                                   +                                return (HsModule loc modName (Just (e1++(e:es)++tail e2)) imps ds)+                        else return mod                     +       Nothing   -> return mod   ++addItemsToExport mod@(HsModule _ _ (Just ents) _ _) Nothing createExp ids+    = do ((toks,_),others)<-get+         let es = case ids of +                    (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'+                    (Right es') -> es'+             (t, (pos,s))=fromJust $ find isOpenBracket toks  -- s is the '('+             newToken = if ents /=[] then  (t, (pos,(s++showEntities (render.ppi) es++",")))+                                     else  (t, (pos,(s++showEntities (render.ppi) es)))+             pos'= simpPos pos+             toks' = replaceToks toks pos' pos' [newToken]+         put ((toks',modified),others)  +         return mod {hsModExports=Just (es++ ents)}++addItemsToExport mod@(HsModule _  (SN modName (SrcLoc _ c row col))  Nothing _ _)  Nothing createExp ids+  =case createExp of +       True ->do ((toks,_),others)<-get+                 let es = case ids of +                               (Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'+                               (Right es') -> es'+                     pos = (row,col)+                     newToken = mkToken Varid pos (modNameToStr modName++ "(" +                                         ++ showEntities (render.ppi) es++")")+                     toks' = replaceToks toks pos pos [newToken]+                 put  ((toks', modified), others)       +                 return mod {hsModExports=Just es}+       False ->return mod               ++-- | Add identifiers (given by the third argument) to the explicit entity list in the declaration importing the+--   specified module name. The second argument serves as a condition: if it is like : Just p, then do the adding +--   the if only 'p' occurs in the entity list; if it is Nothing, then do the adding as normal. This function+--   does nothing if the import declaration does not have an explicit entity list.+{-+addItemsToImport::( )+                 =>ModuleName                  -- ^ The imported module name.+                 ->Maybe PName                 -- ^ The condition identifier.+                 ->Either [String] [EntSpecP]  -- ^ The identifiers to add in either String or EntSpecP format.+                 ->t                           -- ^ The given syntax phrase.+                 ->m t                         -- ^ The result.+-}++addItemsToImport::(Term t,MonadState (([PosToken],Bool),t1) m) +                 =>ModuleName                  -- ^ The imported module name.+                 ->Maybe PName                 -- ^ The condition identifier.+                 ->Either [String] [EntSpecP]  -- ^ The identifiers to add in either String or EntSpecP format.+                 ->t                           -- ^ The given syntax phrase.+                 ->m t                         -- ^ The result.++addItemsToImport serverModName pn (Left [])  t = return t +addItemsToImport serverModName pn (Right []) t = return t+addItemsToImport serverModName pn ids t+ =applyTP (full_buTP (idTP `adhocTP` inImport)) t+  where +    inImport (imp@(HsImportDecl loc m@(SN modName _) qual  as h):: HsImportDeclP)+      | serverModName == modName && (if isJust pn then findPN (fromJust pn) h else True)+       = case h of+           Nothing        -> return imp                     +           Just (b, ents) -> do let ents'=case ids of+                                          Left  is'  -> map (\x-> Var (nameToPNT x)) is'+                                          Right es   -> es+                                ((toks,_),others)<-get+                                let (_,endPos)=getStartEndLoc toks (glast "addItemsToImport" ents)+                                    (t,(_,s))=ghead "addItemsToImport" $ getToks (endPos,endPos) toks+                                    newToken = mkToken t endPos (s++","++showEntities (render.ppi) ents')+                                    toks'=replaceToks toks endPos endPos [newToken]+                                put ((toks',modified),others)+                                return (HsImportDecl loc m qual as (Just (b, ents++ents')))+    inImport imp = return imp++-- | add items to the hiding list of an import declaration which imports the specified module.+addHiding::(MonadState (([PosToken],Bool),t1) m) +            =>ModuleName           -- ^ The imported module name+            ->HsModuleP            -- ^ The current module+            ->[PName]              -- ^ The items to be added+            ->m HsModuleP          -- ^ The result +addHiding serverModName mod pns+   = applyTP (full_tdTP (idTP `adhocTP` inImport)) mod+  where +    inImport (imp@(HsImportDecl loc (SN modName _) qual  as h)::HsImportDeclP)+      | serverModName == modName  && not qual+       = case h of+           Nothing ->do ((toks,_),others)<-get  +                        let (_,endPos)=getStartEndLoc toks imp+                            (t,(_,s)) = ghead "addHiding" $ getToks (endPos,endPos) toks +                            newToken=mkToken t endPos (s++" hiding ("++showEntities pNtoName pns++")")+                            toks'=replaceToks toks endPos endPos [newToken]+                        put ((toks',modified),others)    +                        return (replaceHiding imp (Just (True, map mkNewEnt pns )))+           Just (True, ents) ->do ((toks,_),others)<-get  +                                  let (_,endPos)=getStartEndLoc toks imp+                                      (t, (_,s))=ghead "addHiding"  $ getToks (endPos,endPos) toks+                                      newToken=mkToken t endPos (","++showEntities pNtoName pns ++s)+                                      toks'=replaceToks toks endPos endPos [newToken]+                                  put ((toks',modified),others) +                                  return (replaceHiding imp  (Just (True, (map mkNewEnt  pns)++ents))) +           Just (False, ent)  -> return imp +    inImport x = return x++    mkNewEnt pn = (Var (PNT pn Value (N (Just loc0))))+    replaceHiding (HsImportDecl loc modName qual as h) h1 = HsImportDecl loc modName qual as h1    +++-- | Remove those specified items from the entity list in the import declaration.+{-+ rmItemsFromImport::( ) +                   =>HsModuleP    -- ^ The module AST+                   ->[PName]      -- ^ The items to be removed+                   ->m HsModuleP  -- ^ The result+-}+++rmItemsFromImport::(MonadState (([PosToken],Bool),t1) m) +                   =>HsModuleP    -- ^ The module AST+                   ->[PName]      -- ^ The items to be removed+                   ->m HsModuleP  -- ^ The result+++rmItemsFromImport mod pns+  = applyTP (full_buTP (idTP `adhocTP` inImport)) mod+   where +     inImport (imp@(HsImportDecl loc modName qual  as h)::HsImportDeclP)+      | any (flip findEntity imp) pns+       = case h of+           Just (b, ents) ->+             do let matchedEnts=findEnts pns ents+                if  matchedEnts==[] +                  then return imp+                  else if length matchedEnts == length ents   +                         then do ((toks,_),others)<-get  +                                 let (startPos,endPos)=getStartEndLoc toks ents+                                     toks'=deleteToks toks startPos endPos+                                 put ((toks',modified),others)+                                 return (HsImportDecl loc modName qual as (Just (b,[])))+                         else do ((toks,_),others)<-get  +                                 let remainedEnts=concatMap (\pn->filter (not.match pn) ents) pns +                                     toks'=foldl deleteEnt toks $ map (getStartEndLoc toks) matchedEnts+                                 put ((toks',modified),others)+                                 return (HsImportDecl loc modName qual as (Just (b, remainedEnts)))+           _ ->return imp +     inImport x = return x+   +     findEnts pns ents =nub $ concatMap (\pn->filter (match pn) ents) pns++     -- this function does not check this sub entities of the ListSubs. any problems?+     match::PName -> EntSpec PNT ->Bool+     match pn (Var pnt) = pNTtoPN pnt == pn+     match pn (Abs pnt) = pNTtoPN pnt == pn+     match pn (AllSubs pnt) = pNTtoPN pnt == pn+     match pn (ListSubs pnt _) = pNTtoPN pnt == pn++-- | Remove the sub entities of a type constructor or class from the export list.+rmSubEntsFromExport::(MonadState (([PosToken],Bool),(Int,Int)) m)+                     =>PName       -- ^ The type constructor or class name+                     ->HsModuleP   -- ^ The module AST+                     ->m HsModuleP -- ^ The result+rmSubEntsFromExport typeCon +  = applyTP (full_buTP (idTP `adhocTP` inEntSpec))+  where+   inEntSpec (ent@(AllSubs pnt)::EntSpec PNT)+     | pNTtoPN pnt == typeCon +      =do (ent', _)<-updateToks ent (Abs pnt) prettyprint+          return ent'+   inEntSpec (ent@(ListSubs pnt _))+     | pNTtoPN pnt == typeCon +     = do (ent', _) <- updateToks ent (Abs pnt) prettyprint+          return ent'+   inEntSpec ent = return ent+     +---------------------------------------------------------------------------------------+-- | Remove the specified entities from the module's exports. The entities can be specified in either of two formats:+-- i.e. either specify the module names and identifier names to be removed, so just given the exact AST for these entities.+{-rmItemsFromExport::( ) +                   =>HsModuleP                                      -- ^ The module AST.+                    ->Either ([ModuleName],[PName]) [HsExportEntP]  -- ^ The entities to remove. +                                                                    +                    ->m HsModuleP                                   -- ^ The result.+-}+rmItemsFromExport::(MonadState (([PosToken],Bool),t1) m) +                   =>HsModuleP                                      -- ^ The module AST.+                    ->Either ([ModuleName],[PName]) [HsExportEntP]  -- ^ The entities to remove. +                                                                    +                    ->m HsModuleP                                   -- ^ The result.++rmItemsFromExport mod@(HsModule loc modName exps imps ds)  (Left (modNames, pns))+  =if isNothing exps+     then return mod+     else do let ents =findEnts (modNames, pns) (fromJust exps)+             rmItemsFromExport mod (Right ents) +  where   +    findEnts (modNames, pns) ents+      =let ms = concatMap (\m ->filter (\e -> case e of +                                         ModuleE (SN m' _) -> m==m'+                                         EntE e'    -> False) ents) modNames +           es =concatMap (\pn->filter (\e ->case e of +                                            ModuleE _ -> False+                                            EntE e'    -> match pn e') ents) pns +       in (ms++es)+    match::PName -> EntSpec PNT ->Bool+    match pn (Var pnt) = pNTtoPN pnt == pn+    match pn (Abs pnt) = pNTtoPN pnt == pn+    match pn (AllSubs pnt) = pNTtoPN pnt == pn+    match pn (ListSubs pnt _) = pNTtoPN pnt == pn++rmItemsFromExport mod@(HsModule loc modName exps@(Just es) imps ds) (Right ents)+  = do exps'<- if ents==[] +                  then return exps+                  else if length ents == length es +                         then do ((toks,_),others)<-get             +                                 let (startPos,endPos) = getStartEndLoc toks ents+                                     toks'= deleteToks toks startPos endPos+                                 put ((toks',modified),others)+                                 return (Just [] )  -- should not remove the empty bracket!!!+                         else do ((toks,_),others)<-get +                                 let toks' = foldl deleteEnt toks $ map (getStartEndLoc toks) ents+                                 put ((toks',modified),others)+                                 return (Just (es \\ ents))                 +       return (HsModule loc modName exps' imps ds)+rmItemsFromExport mod _ = return mod++--This function is only used by this module, and should not be exported.+deleteEnt toks (startPos, endPos)+  = let (toks1,toks2)=break (\t->tokenPos t==startPos) toks+        previousTok=ghead "deleteEnt" $ dropWhile isWhiteSpace $ reverse toks1+        toks' = dropWhile isWhiteSpace $ gtail "deleteEnts" $ dropWhile (\t->tokenPos t/=endPos) toks2+        nextTok = ghead "deleteEnt" toks'+        startPos'=if isComma previousTok && (not (isComma nextTok)) then tokenPos previousTok else startPos+    in if isComma nextTok                    +         then let remainedToks = tail toks' +              in if remainedToks /= [] +                   then let whites = takeWhile isWhiteSpace remainedToks+                        in if whites /= [] then deleteToks toks startPos' (tokenPos (last whites))+                                           else deleteToks toks startPos' (tokenPos nextTok)+                   else deleteToks toks startPos' (tokenPos nextTok)+         else deleteToks toks startPos' endPos  ++++--------------------------------TRY TO REMOVE THIS FUNCTION------------------------------+{-                                    +moveDecl::(CanHaveWhereClause t,DeclStartLoc t, Term t,Printable t,MonadPlus m, +           MonadState (([PosToken],Bool),(Int, Int)) m)+     => [PName]        -- ^ The identifier(s) whose defining declaration is to be moved. List is used to handle pattern bindings where multiple identifiers are defined.+     -> t              -- ^ The syntax phrase where the declaration is going to be moved to.+     -> Bool           -- ^ True mean the function\/pattern binding being moved is going to be at the same level with t. Otherwise it will be a local declaration of t.+     -> [HsDeclP]      -- ^ The declaration list where the definition\/pattern binding originally exists.+     -> Bool           -- ^ True means the type signature will not be discarded.+     -> m t            -- ^ The result.+-}                    +moveDecl pns dest sameLevel decls incSig+   = do ((ts,_),_)<-get  +        let defToks' =(getDeclToks (ghead "moveDecl:0" pns) True decls ts)      +            defToks  =whiteSpaceTokens (tokenRow (ghead "moveDecl" defToks'),0)+                                       -- do not use tokenCol here. should count the whilte spaces.+                                       (tokenCol (ghead "moveDecl2" defToks') -1) ++ defToks'+            movedDecls = definingDecls pns decls True False+        decls'<-rmDecl (ghead "moveDecl3"  pns) False =<<foldM (flip rmTypeSig) decls pns+        addDecl dest Nothing (movedDecls, Just defToks) False++---------------------------------------------------------------------------------------------++-- |Parse a Haskell source files, and returns a four-element tuple. The first element in the result is the inscope +-- relation, the second element is the export relation, the third is the AST of the module and the forth element is+-- the token stream of the module.+{- +parseSourceFile:: ( ) =>FilePath+                      ->m (InScopes,Exports,HsModuleP,[PosToken])  +-}++parseSourceFileOld filename+   = (checkScope  @@ parseSourceFile') filename ++  where +   checkScope (ts,(((wm,_),mod),refs))+     = check (checkRefs refs) >> return (inscpRel wm, exports wm, mod, expandNewLnTokens ts) ++   check [] = done+   check errs = fail $ pp $ "Scoping errors" $$ vcat errs   +   +parseSourceFile filename+   = do+        name <- fileNameToModName filename +        res <- ((checkScope  @@ parseModule') name)+        return res++  where +   checkScope (ts,(((wm,_),mod),refs))+     = check (checkRefs refs) >> return (inscpRel wm, exports wm, mod, expandNewLnTokens ts) ++   check [] = done+   check errs = fail $ pp $ "Scoping errors" $$ vcat errs    +   +parsePrelude+   = do+        name <- fileNameToModName (release_root ++ "/tools/base/tests/HaskellLibraries/Prelude.hs")+        res <- ((checkScope  @@ parseModule') name)+        return res++  where +   checkScope (ts,(((wm,_),mod),refs))+     = check (checkRefs refs) >> return (inscpRel wm, exports wm, mod, expandNewLnTokens ts) ++   check [] = done+   check errs = fail $ pp $ "Scoping errors" $$ vcat errs    +   +   +{- removed CMB MAY 2010, migrated to HINT library, sessions now redundant. -}   +{- parseSourceFile2 filename modName+   = (checkScope @@ parseSourceFile') filename +  where +   checkScope (ts,(((wm,_),mod),refs))+     = check (checkRefs refs) >> return (inscpRel wm, exports wm, mod, expandNewLnTokens ts, ghcTypeCheck filename modName) ++   check [] = done+   check errs = fail $ pp $ "Scoping errors" $$ vcat errs -}++--preprocssing the token stream to expand the white spaces to individual tokens.+expandNewLnTokens::[PosToken]->[PosToken]+expandNewLnTokens ts = concatMap expand ts+  where+    expand tok@(Whitespace,(pos,s)) = doExpanding pos s                +    expand x = [x]++    doExpanding pos [] =[]+    doExpanding pos@(Pos c row col) (t:ts)+      = case t of +           '\n'  -> (Whitespace, (pos,[t])):(doExpanding (Pos c (row+1) 1) ts)+           _     -> (Whitespace, (pos,[t])):(doExpanding (Pos c row (col+1)) ts)++------------------------------------------------------------------------------------------------+++-- | Write refactored program source to files. +{-+writeRefactoredFiles::Bool   -- ^ True means the current refactoring is a sub-refactoring+         ->[((String,Bool),([PosToken],HsModuleP))]  --  ^ String: the file name; Bool: True means the file has been modified.[PosToken]: the token stream; HsModuleP: the module AST.+         -> m ()  +-}      +writeRefactoredFiles (isSubRefactor::Bool) (files::[((String,Bool),([PosToken], HsModuleP))]) +  = do let modifiedFiles = filter (\((f,m),_)->m==modified) files+       addToHistory isSubRefactor $ map (fst.fst) modifiedFiles+       mapM_ modifyFile modifiedFiles+       -- mapM_ writeTestDataForFile files   -- This should be removed for the release version.+       {-   -- the 'writeTestDataForFile' causes a 'stack overflow' problem, when applying refactorings to+          -- large-scale programs,and the possible reason might be lazy evaluation and the huge size of AST.+         -}+     where+       modifyFile ((fileName,_),(ts,mod)) = do+           --let source =(render.ppi) mod +           let source = concatMap (snd.snd) ts+           seq (length source) $ writeHaskellFile fileName source+           editorCmds <-getEditorCmds +           MT.lift $ sendEditorModified editorCmds fileName        +       writeTestDataForFile ((fileName,_),(ts,mod)) = do+           let source=concatMap (snd.snd) ts+           seq (length source) $ writeFile (createNewFileName "_TokOut" fileName) source +           writeHaskellFile (createNewFileName "AST" fileName) ((render.ppi.rmPrelude) mod)   +       createNewFileName str fileName +          =let (name, posfix)=span (/='.') fileName+           in (name++str++posfix) ++--------------------------------------------------------------------------------------- +-----Remove the 'Prelude' imports added by Programatica------------------------------+rmPrelude::HsModuleP->HsModuleP+rmPrelude (HsModule s m e is ds) = HsModule s m e (is \\ prelimps) ds++prelimps = [HsImportDecl loc0  (SN (PlainModule "Prelude") loc0)  True Nothing Nothing,+            HsImportDecl loc0  (SN (PlainModule "Prelude") loc0) False Nothing Nothing]+    ++-- | Return True if a string is a lexically  valid variable name.+isVarId::String->Bool+isVarId id =isId id && isSmall (ghead "isVarId" id) +     where isSmall c=isLower c || c=='_'++-- | Return True if a string is a lexically valid constructor name.+isConId::String->Bool+isConId id =isId id && isUpper (ghead "isConId" id)++-- | Return True if a string is a lexically valid operator name.+isOperator::String->Bool+isOperator id = id /= [] && isOpSym (ghead "isOperator" id) &&+                isLegalOpTail (tail id) && not (isReservedOp id)+   where++    isOpSym id = elem id opSymbols+       where opSymbols = ['!', '#', '$', '%', '&', '*', '+','.','/','<','=','>','?','@','\'','^','|','-','~']++    isLegalOpTail tail = all isLegal tail+       where isLegal c = isOpSym c || c==':'++    isReservedOp id = elem id reservedOps+       where reservedOps = ["..", ":","::","=","\"", "|","<-","@","~","=>"]++{-Returns True if a string lexically is an identifier. *This function should not be exported.*+-}  +isId::String->Bool+isId id = id/=[] && isLegalIdTail (tail id) && not (isReservedId id)+  where+    isLegalIdTail tail=all isLegal tail+        where isLegal c=isSmall c|| isUpper c || isDigit c || c=='\''++    isReservedId id=elem id reservedIds +      where reservedIds=["case", "class", "data", "default", "deriving","do","else" ,"if",+                         "import", "in", "infix","infixl","infixr","instance","let","module",+                         "newtype", "of","then","type","where","_"]++    isSmall c=isLower c || c=='_'++-----------------------------------------------------------------------------+-- |Return True if a PName is a toplevel PName.+isTopLevelPN::PName->Bool+isTopLevelPN (PN i (G _ _ _))=True+isTopLevelPN _ =False++-- |Return True if a PName is a local PName.+isLocalPN::PName->Bool+isLocalPN (PN i (S _))=True+isLocalPN _ =False++-- |Return True if a PName is a qualified PName.+isQualifiedPN::PName->Bool+isQualifiedPN (PN (Qual mod id) _)=True+isQualifiedPN _ =False ++-- |Return True if an PNT is a toplevel PNT.+isTopLevelPNT::PNT->Bool+isTopLevelPNT = isTopLevelPN.pNTtoPN++isLocalPNT :: PNT -> Bool+isLocalPNT = isLocalPN.pNTtoPN++-- |Return True if a PName is a function\/pattern name defined in t.+isFunOrPatName::(Term t)=>PName->t->Bool+isFunOrPatName pn +   =isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where+        worker (decl::HsDeclP)+           | defines pn decl=Just True+        worker _ =Nothing++-- |Return True if a PNT is a function name defined in t.+isFunPNT::(Term t)=>PNT -> t -> Bool+isFunPNT pnt t = isFunName (pNTtoPN pnt) t ++isFunName::(Term t)=>PName->t->Bool+isFunName pn +   =isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where+        worker (decl::HsDeclP)+           | isFunBind decl && defines pn decl =Just True+        worker _ =Nothing++-- |Return True if a PName is a pattern name defined in t.+isPatName::(Term t)=>PName->t->Bool+isPatName pn +   =isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where+        worker (decl::HsDeclP)+           | isPatBind decl && defines pn decl =Just True+        worker _ =Nothing+-------------------------------------------------------------------------------+-- | Return True if a PNT is a type constructor.+isTypeCon :: PNT -> Bool+isTypeCon (PNT pn (Type typeInfo) _) = defType typeInfo == Just Data+isTypeCon _ = False ++-- | Return True if PNT is a data type constructor.+isDataCon :: PNT -> Bool+isDataCon (PNT pn (ConstrOf _ typeInfo) _) = defType typeInfo == Just Data+isDataCon _ = False++-- | Return True if a declaration is a type signature declaration.+isTypeSig ::HsDeclP->Bool+isTypeSig (Dec (HsTypeSig loc is c tp))=True+isTypeSig _=False++-- | Return True if a declaration is a function definition.+isFunBind::HsDeclP->Bool+isFunBind (Dec (HsFunBind loc matches))=True+isFunBind _ =False++-- | Returns True if a declaration is a pattern binding.+isPatBind::HsDeclP->Bool+isPatBind (Dec (HsPatBind _ _ _ _))=True+isPatBind _=False++-- | Return True if a declaration is a pattern binding which only defines a variable value.+isSimplePatBind::HsDeclP->Bool+isSimplePatBind decl=case decl of+     Dec (HsPatBind _ p _ _)->patToPN p /=defaultPN+     _ ->False++-- | Return True if a declaration is a pattern binding but not a simple one.+isComplexPatBind::HsDeclP->Bool+isComplexPatBind decl=case decl of+     Dec (HsPatBind _ p _ _)->patToPN p ==defaultPN+     _ -> False++-- | Return True if a declaration is a function\/pattern definition.+isFunOrPatBind::HsDeclP->Bool+isFunOrPatBind decl=isFunBind decl || isPatBind decl++-- | Return True if a declaration is a Class declaration.+isClassDecl :: HsDeclP ->Bool+isClassDecl (Dec (HsClassDecl _ _ _ _ _)) = True+isClassDecl _ = False++-- | Return True if a declaration is a Class instance declaration.+isInstDecl :: HsDeclP -> Bool+isInstDecl (Dec (HsInstDecl _ _ _ _ _)) = True+isInstDecl _ = False+        +-- | Return True if a function is a directly recursive function.+isDirectRecursiveDef::HsDeclP->Bool+isDirectRecursiveDef (Dec (HsFunBind loc ms)) +   = any isUsedInDef ms +  where +   isUsedInDef (HsMatch loc1 fun pats rhs ds)+     = findEntity (pNTtoPN fun) rhs+isDirectRecursiveDef _ = False++------------------------------------------------------------------------------------------------++-- | Add a qualifier to an identifier if it is not qualified.+qualifyPName::ModuleName  -- ^ The qualifier.+              ->PName     -- ^ The identifier.+              ->PName     -- ^ The result.+qualifyPName qual pn + = case pn of +      PN (UnQual n) ty -> PN (Qual qual n ) ty+      _                -> pn++-- | Remove the qualifier from the given identifiers in the given syntax phrase.+rmQualifier::((MonadState (([PosToken], Bool), t1) m),Term t)+             =>[PName]  -- ^ The identifiers.+               ->t      -- ^ The syntax phrase.+               ->m t    -- ^ The result.+rmQualifier pns t +  = applyTP (full_tdTP (adhocTP idTP rename )) t+   where +     rename pnt@(PNT  pn@(PN (Qual modName  s) l) ty loc@(N (Just (SrcLoc fileName _ row col))))+       | elem pn pns+       = do do ((toks,_), others)<-get+               let toks' =replaceToks toks (row,col) (row,col) [mkToken Varid (row,col) s]+               put ((toks', modified), others)+               return (PNT (PN (UnQual s) l) ty loc)+     rename x = return  x++-- | Show a list of entities, the parameter f is a function that specifies how to format an entity.+showEntities::(Eq t, Term t)=>(t->String)->[t]->String+showEntities f [] = ""+showEntities f [pn] = f pn+showEntities f (pn:pns) =f pn ++ "," ++ showEntities f pns++-- | Show a PName in a format like: 'pn'(at row:r, col: c).+showPNwithLoc::PName->String+showPNwithLoc pn+  = let (SrcLoc _ _ r c)=srcLoc pn+    in  " '"++pNtoName pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")"+++----------------------------------------------------------------------------------+-- | Default identifier in the PName format.+defaultPN::PName+defaultPN=PN (UnQual "unknown") (G (PlainModule "unknown") "--" (N Nothing)) :: PName++-- | Default identifier in the PNT format.+defaultPNT::PNT+defaultPNT=PNT defaultPN Value  (N Nothing) :: PNT ++-- | Default module name.+defaultModName::ModuleName+defaultModName = PlainModule "unknown"++-- | Default expression.+defaultExp::HsExpP+defaultExp=Exp (HsId (HsVar defaultPNT))++-- | Default Type.+defaultTyp :: HsTypeP+defaultTyp = Typ (HsTyCon defaultPNT)++-- | Default pattern.+defaultPat::HsPatP+defaultPat=Pat (HsPId (HsVar defaultPNT))++++------------------------------------------------------------------------------------++-- | From PNT to PName.+pNTtoPN :: PNT->PName+pNTtoPN (PNT pname _ _)=pname++-- | From PName to Name. This function ignores the qualifier.+pNtoName::PName->String+pNtoName (PN (UnQual i) orig)=i+pNtoName (PN (Qual modName i) orig)=i   ++-- | From PNT to Name. This function ingnores the qualifier.+pNTtoName::PNT->String+pNTtoName=pNtoName.pNTtoPN++-- | From HsDeclP to String.+declToName :: HsDeclP -> String+declToName (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))  + = pNTtoName pnt+declToName (Dec (HsPatBind _ pnt _ _)) = pNTtoName (patToPNT pnt)+declToName (Dec (HsDataDecl _ _ t _ _)) = pNTtoName (extractPNT t)+declToName (Dec (HsTypeSig _ (i:is) _ _)) = pNTtoName (extractPNT i)+declToName _ = ""++declToName2 (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))  + = pNTtoName pnt+declToName2 (Dec (HsPatBind _ pnt _ _)) = pNTtoName (patToPNT pnt)+declToName2 _ = ""++-- | From HsDeclP to PNT.+declToPNT' :: HsDeclP -> PNT+declToPNT' (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))  + = pnt+declToPNT' (Dec (HsPatBind _ pnt _ _)) = patToPNT pnt+declToPNT' (Dec (HsDataDecl _ _ t _ _)) = extractPNT t+declToPNT' _ = defaultPNT++-- | From HsDeclP to PNT.+declToPNT :: HsDeclP -> PNT+declToPNT (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))  + = pnt+declToPNT (Dec (HsPatBind _ pnt _ _)) = patToPNT pnt+declToPNT (Dec (HsDataDecl _ _ t _ _)) = extractPNT t+declToPNT (Dec (HsTypeSig _ (i:is) _ _)) = extractPNT i+declToPNT _ = defaultPNT++extractPNT::(Term t)=>t->PNT+extractPNT = (fromMaybe defaultPNT).(applyTU (once_tdTU (failTU `adhocTU` inPNT)))+     where+      inPNT (p@(PNT x y z)::PNT)+        = Just p+      inMatch _ =Nothing++declToPName2 :: HsDeclP -> PName+declToPName2 (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))  + = pNTtoPN pnt+declToPName2 (Dec (HsPatBind _ pnt _ _)) = patToPN pnt+declToPName2 _ = defaultPN++-- | From HsDeclP to PName+declToPName ::  [ String  ] -> HsDeclP -> PName+declToPName [] _ = defaultPN+declToPName (name: names) d@(Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs))) + | name == pNTtoName pnt = pNTtoPN pnt+ | otherwise = declToPName  names d+declToPName (name:names) d@(Dec (HsPatBind _ pnt _ _))  -- = pNTtoPN (patToPNT pnt)+ | name == pNTtoName (patToPNT pnt) = pNTtoPN (patToPNT pnt)+ | otherwise = declToPName  names d+declToPName _ _ = defaultPN+----------------------------------------------------------------------------------++class (Term t) => HasModName t where++    -- | Fetch the module name from an identifier.+    hasModName :: t->Maybe ModuleName++instance HasModName PNT  where++    hasModName (PNT (PN _ (G modName s1 loc)) _ _)=Just modName+    hasModName _ =Nothing   ++instance HasModName PName where+  +    hasModName (PN _ (G modName s1 loc))=Just modName+    hasModName _ =Nothing++----------------------------------------------------------------------+-- | Compose a PNT form a String.+nameToPNT::String->PNT+nameToPNT id =(PNT (PN (UnQual id) (G (PlainModule "unknown") id+                 (N (Just loc0)))) Value (N (Just loc0)))++-- | Compose a PName from String.+nameToPN::String->PName+nameToPN id =(PN (UnQual id) (G (PlainModule "unknown") id (N (Just loc0))))++-- | Compose a PNT from a PName and the PName's name space Information+pNtoPNT::PName->IdTy PId->PNT+pNtoPNT pname ty =  PNT pname ty (N (Just loc0))++-- | If an expression consists of only one identifier then return this identifier in the PNT format,+--  otherwise return the default PNT.+expToPNT::HsExpP->PNT+expToPNT (Exp (HsId (HsVar pnt)))=pnt +expToPNT (Exp (HsId (HsCon pnt)))=pnt+expToPNT (Exp (HsParen e))=expToPNT e +expToPNT _ =defaultPNT++typToPNT ::HsTypeP->PNT+typToPNT (Typ (HsTyCon pnt))=pnt +typToPNT (Typ (HsTyVar pnt))=pnt+typToPNT _ =defaultPNT++-- | If an expression consists of only one identifier then return this identifier in the PName format,+--   otherwise returns the default PName. +expToPN::HsExpP->PName+expToPN =pNTtoPN.expToPNT++-- | Compose an expression from a String.+nameToExp ::String ->HsExpP+nameToExp name+    =Exp (HsId (HsVar (PNT (PN (UnQual name) (S loc0)) Value (N (Just loc0)))))++nameToTyp :: String -> HsTypeP+nameToTyp name +    = Typ (HsTyVar (PNT (PN (UnQual name) (S loc0)) Value (N (Just loc0))))++-- nameToIdent :: String -> HsIdent i++-- | Compose an Identifier from a String+nameToIdent name+    = (HsVar (PNT (PN (UnQual name) (S loc0)) Value (N (Just loc0))))++-- | Compose an expression from a pName.+pNtoExp::PName->HsExpP+pNtoExp pn =Exp (HsId (HsVar (PNT pn  Value (N (Just loc0)))))++-- | If a pattern consists of only one identifier then return this identifier in the PNT format,+--  otherwise returns the default PNT. +patToPNT::HsPatP->PNT+patToPNT (Pat (HsPId (HsVar pnt)))= pnt+patToPNT (Pat (HsPLit l (HsInt v))) = patToPNT (Pat (HsPId (HsVar (PNT (PN (UnQual (show v)) (S l)) Value (N (Just l))))) )+patToPNT (Pat (HsPParen p))=patToPNT p+patToPNT (Pat (HsPAsPat pnt p)) = pnt+patToPNT _=defaultPNT++-- | If a pattern consists of only one identifier then returns this identifier in the PName format,+--   otherwise returns the default PName.+patToPN::HsPatP->PName+patToPN=pNTtoPN.patToPNT++-- | Compose a pattern from a String.+nameToPat::String->HsPatP+nameToPat name+    =Pat (HsPId (HsVar (PNT (PN (UnQual name) (S loc0)) Value (N (Just loc0)))))++-- | Compose a pattern from a pName.+pNtoPat :: PName -> HsPatP+pNtoPat pname+    =let loc=srcLoc pname+     in (Pat (HsPId (HsVar (PNT pname Value (N (Just loc))))))+---------------------------------------------------------------------------+++-- |Create a new name base on the old name. Suppose the old name is 'f', then +--  the new name would be like 'f_i' where 'i' is an integer.+mkNewName::String      -- ^ The old name+          ->[String]   -- ^ The set of names which the new name cannot take+          ->Int        -- ^ The posfix value+          ->String     -- ^ The result+mkNewName oldName fds init+  =let newName=if init==0 then oldName+                          else oldName++"_"++ show init+   in if elem newName fds+        then mkNewName oldName fds (init+1)+        else newName ++-- | Return the identifier's defining location.+defineLoc::PNT->SrcLoc+defineLoc (PNT pname _ _) = srcLoc pname++-- | Return the identifier's source location.+useLoc::PNT->SrcLoc+useLoc (PNT pname _ (N (Just loc))) = loc+useLoc (PNT _ _ _ )                 = loc0++-- | Return True if the identifier is used in the RHS if a function\/pattern binding.+isUsedInRhs::(Term t)=>PNT->t->Bool+isUsedInRhs pnt t= useLoc pnt /= defineLoc pnt  && not (notInLhs pnt t)+  where+    notInLhs pnt+     = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inMatch+                                                     `adhocTU` inDecl)))+     where+      inMatch ((HsMatch loc1 name pats rhs ds)::HsMatchP)+         | isJust (find (sameOccurrence pnt) [name]) = Just True+      inMatch _ =Nothing++      inDecl ((Dec (HsTypeSig loc is c tp))::HsDeclP)+        |isJust (find (sameOccurrence pnt) is)   = Just True+      inDecl _ =Nothing    +      +isUsedInRhsName :: (Term t) => PNT -> t -> Bool+isUsedInRhsName pnt t= notInLhs pnt t+  where+    notInLhs pntget+     = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inPNT)))+     where+      inPNT (p@(PNT (PN (UnQual x)_)_ _)::PNT)+        | isJust (find (sameName pnt) [p]) = Just True+      inPNT _ = Nothing+     +      inMatch ((HsMatch loc1 name pats rhs ds)::HsMatchP)+         | isJust (find (sameName pnt) [name]) = Just True+      inMatch _ =Nothing++      inDecl ((Dec (HsTypeSig loc is c tp))::HsDeclP)+        |isJust (find (sameName pnt) is)   = Just True+      inDecl _ =Nothing    ++returnRHS :: PNT -> HsExpP -> Bool+returnRHS pnt e@(Exp (HsApp e1 e2)) = (returnRHS pnt e1) || (returnRHS pnt e2)+returnRHS pnt e@(Exp (HsId (HsVar x))) = sameName pnt x+returnRHS pnt e@(Exp (HsTuple (e1:es))) = or ( map (returnRHS pnt) (e1:es)  )+returnRHS pnt e@(Exp (HsParen e1)) = returnRHS pnt e1+returnRHS pnt e@(Exp (HsCase e1 _)) = returnRHS pnt e1+returnRHS pnt e = False++returnRHS2 :: PNT -> HsExpP -> Bool+returnRHS2 pnt e@(Exp (HsApp e1 e2)) = (returnRHS2 pnt e1) || (returnRHS2 pnt e2)+returnRHS2 pnt e@(Exp (HsId (HsVar x))) = sameName x pnt+returnRHS2 pnt e@(Exp (HsTuple (e1:es))) = or ( map (returnRHS2 pnt) (e1:es)  )+returnRHS2 pnt e@(Exp (HsParen e1)) = returnRHS2 pnt e1+returnRHS2 pnt e@(Exp (HsCase e1 _)) = returnRHS2 pnt e1+returnRHS2 pnt e = False++-- getParams pnt defaultExp = []+-- getParams _ e = error $ show  e+getParams pnt (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "unknown") (G (PlainModule "unknown") "--" (N Nothing))) Value (N Nothing)) ))) e2)) = [e2]+getParams pnt e@(Exp (HsCase e1 _)) = getParams pnt e1+getParams pnt e@(Exp (HsApp e1 e2)) + = (getParams pnt e1) ++ getParams2 e2+getParams pnt (Exp (HsTuple (e:es))) + | getParams pnt e /= [] = getParams pnt e+ | otherwise = getParams pnt (Exp (HsTuple es))+getParams pnt e = []+++getParams2 (Exp (HsId (HsVar (PNT (PN (UnQual "unknown") (G (PlainModule "unknown") "--" (N Nothing))) Value (N Nothing)) ))) = []+getParams2 (Exp (HsApp e1 e2)) = (getParams2 e1) ++ (getParams2 e2)+getParams2 e = [e]++-- | Return True is the identifier is unqualifiedly used in the given syntax phrase.+usedWithoutQual::(Term t)=>String->t->Bool+usedWithoutQual name t+   =(fromMaybe False) (applyTU (once_tdTU (failTU `adhocTU` worker)) t)+      where+         worker (pnt::PNT)+           |pNTtoName pnt ==name && isUsedInRhs pnt t && not (isQualifiedPN (pNTtoPN pnt)) +          = Just True+         worker _ =Nothing++-- |Find the identifier(in PNT format) whose start position is (row,col) in the+-- file specified by the fileName, and returns defaultPNT is such an identifier does not exist.++locToPNT::(Term t)=>String      -- ^ The file name +                    ->(Int,Int) -- ^ The row and column number               +                    ->t         -- ^ The syntax phrase+                    ->PNT       -- ^ The result+locToPNT  fileName (row, col) +  =(fromMaybe defaultPNT). applyTU (once_buTU (failTU `adhocTU` worker))+     where +        worker pnt@(PNT pname ty (N (Just (SrcLoc fileName1 _ row1 col1))))+           |fileName1==fileName && (row1,col1) == (row,col) =Just pnt+        worker _ =Nothing +++-- | The same as locToPNT, except that it returns the identifier in the PName format.+locToPN::(Term t)=>String->(Int,Int)->t->PName+locToPN fileName pos = pNTtoPN.(locToPNT fileName pos)++-- | Given the syntax phrase (and the token stream), find the largest-leftmost expression contained in the+--  region specified by the start and end position. If no expression can be found, then return the defaultExp.+locToExp2::(Term t) => SimpPos            -- ^ The start position.+                  -> SimpPos            -- ^ The end position.+                  -> [PosToken]         -- ^ The token stream which should at least contain the tokens for t.+                  -> t                  -- ^ The syntax phrase.+                  -> HsExpP             -- ^ The result.+locToExp2 beginPos endPos toks t+  = fromMaybe defaultExp $ applyTU (once_tdTU (failTU `adhocTU` exp)) t+     where+       {- exp (e@(Exp (HsDo stmts))::HsExpP)+         | filter inScope (map (getStartEndLoc toks) (getStmtList stmts))/=[]+         = do let atoms = filter (\atom->inScope (getStartEndLoc toks atom)) (getStmtList stmts)+                  atoms'= reverse (dropWhile (not.isQualifierOrLastAtom) (reverse atoms))+              if atoms'==[] +                  then fail "Expession not selected"+                  else do stmts' <-atoms2Stmt atoms'  +                          Just (Exp (HsDo stmts')) -}+        exp (e::HsExpP)+         |inScope e = Just e+        exp _ =Nothing                     +             +        inScope e +          = let (startLoc, endLoc) +                 = if expToPNT e /= defaultPNT +                    then let (SrcLoc _ _ row col) = useLoc (expToPNT e)+                         in ((row,col), (row,col))+                    else getStartEndLoc toks e+            in (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && endLoc<=endPos ++        isQualifierOrLastAtom (HsQualifierAtom e) = True+        isQualifierOrLastAtom (HsLastAtom e)      = True+        isQualifierOrLastAtom _ = False + +        atoms2Stmt [HsQualifierAtom e]          = return (HsLast e)+        atoms2Stmt [HsLastAtom e]               = return (HsLast e)+        atoms2Stmt (HsGeneratorAtom s p e : ss) = HsGenerator s p e # atoms2Stmt ss+        atoms2Stmt (HsLetStmtAtom ds : ss)      = HsLetStmt ds # atoms2Stmt ss+        atoms2Stmt (HsQualifierAtom e : ss)     = HsQualifier e # atoms2Stmt ss+        atoms2Stmt _ = fail "last statement in a 'do' expression must be an expression"+++-- | Given the syntax phrase (and the token stream), find the largest-leftmost expression contained in the+--  region specified by the start and end position. If no expression can be found, then return the defaultExp.+locToPat::(Term t) => SimpPos            -- ^ The start position.+                  -> SimpPos            -- ^ The end position.+                  -> [PosToken]         -- ^ The token stream which should at least contain the tokens for t.+                  -> t                  -- ^ The syntax phrase.+                  -> HsPatP             -- ^ The result.+locToPat beginPos endPos toks t+  = fromMaybe defaultPat $ applyTU (once_tdTU (failTU `adhocTU` pat)) t+     where+       {- exp (e@(Exp (HsDo stmts))::HsExpP)+         | filter inScope (map (getStartEndLoc toks) (getStmtList stmts))/=[]+         = do let atoms = filter (\atom->inScope (getStartEndLoc toks atom)) (getStmtList stmts)+                  atoms'= reverse (dropWhile (not.isQualifierOrLastAtom) (reverse atoms))+              if atoms'==[] +                  then fail "Expession not selected"+                  else do stmts' <-atoms2Stmt atoms'  +                          Just (Exp (HsDo stmts')) -}+        pat (p::HsPatP)+         |inScope p = Just p+        pat _ =Nothing                     +             +        inScope p +          = let (startLoc, endLoc) +                 = if patToPNT p /= defaultPNT +                    then let (SrcLoc _ _ row col) = useLoc (patToPNT p)+                         in ((row,col), (row,col))+                    else getStartEndLoc toks p+            in (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && endLoc<=endPos   ++-- | Given the syntax phrase (and the token stream), find the expression contained in the+--  region specified by the start and end position. If no expression can be found, then return the defaultExp.+locToLocalPat::(Term t) => SimpPos      -- ^ The start position.+                  -> SimpPos            -- ^ The end position.+                  -> [PosToken]         -- ^ The token stream which should at least contain the tokens for t.+                  -> t                  -- ^ The syntax phrase.+                  -> HsPatP             -- ^ The result.+locToLocalPat beginPos endPos toks t+  = fromMaybe defaultPat $ applyTU (once_tdTU (failTU `adhocTU` pat)) t+     where+       {- exp (e@(Exp (HsDo stmts))::HsExpP)+         | filter inScope (map (getStartEndLoc toks) (getStmtList stmts))/=[]+         = do let atoms = filter (\atom->inScope (getStartEndLoc toks atom)) (getStmtList stmts)+                  atoms'= reverse (dropWhile (not.isQualifierOrLastAtom) (reverse atoms))+              if atoms'==[] +                  then fail "Expession not selected"+                  else do stmts' <-atoms2Stmt atoms'  +                          Just (Exp (HsDo stmts')) -}+        pat (p::HsPatP)+         |inScope p = Just p+        pat _ =Nothing                     +             +        inScope p +          = let (startLoc, endLoc) +                 = if patToPNT p /= defaultPNT +                    then let (SrcLoc _ _ row col) = useLoc (patToPNT p)+                         in ((row,col), (row,col))+                    else getStartEndLoc toks p+            in (startLoc==beginPos) && (startLoc<= endPos) && (endLoc >= beginPos) && endLoc<=endPos+++      {- isQualifierOrLastAtom (HsQualifierAtom p) = True+        isQualifierOrLastAtom (HsLastAtom p)      = True+        isQualifierOrLastAtom _ = False + +        atoms2Stmt [HsQualifierAtom p]          = return (HsLast e)+        atoms2Stmt [HsLastAtom e]               = return (HsLast e)+        atoms2Stmt (HsGeneratorAtom s p e : ss) = HsGenerator s p e # atoms2Stmt ss+        atoms2Stmt (HsLetStmtAtom ds : ss)      = HsLetStmt ds # atoms2Stmt ss+        atoms2Stmt (HsQualifierAtom e : ss)     = HsQualifier e # atoms2Stmt ss+        atoms2Stmt _ = fail "last statement in a 'do' expression must be an expression" -}+        ++-- | Given the syntax phrase (and the token stream), find the largest-leftmost expression contained in the+--  region specified by the start and end position. If no expression can be found, then return the defaultExp.+locToExp::(Term t) => SimpPos            -- ^ The start position.+                  -> SimpPos            -- ^ The end position.+                  -> [PosToken]         -- ^ The token stream which should at least contain the tokens for t.+                  -> t                  -- ^ The syntax phrase.+                  -> HsExpP             -- ^ The result.+locToExp beginPos endPos toks t+  = fromMaybe defaultExp $ applyTU (once_tdTU (failTU `adhocTU` exp)) t+     where+        {- exp (e@(Exp (HsDo stmts))::HsExpP)+         | filter inScope2 (map (getStartEndLoc toks) (getStmtList stmts))/=[]+         = do let atoms = filter (\atom->inScope (getStartEndLoc toks atom)) (getStmtList stmts)+                  atoms'= reverse (dropWhile (not.isQualifierOrLastAtom) (reverse atoms))+              if atoms'==[] +                  then fail "Expession not selected"+                  else do stmts' <-atoms2Stmt atoms'  +                          Just (Exp (HsDo stmts')) -}+        exp (e::HsExpP)+         |inScope e = Just e+        exp _ =Nothing                     +             +        inScope e +          = let (startLoc, endLoc) +                 = if expToPNT e /= defaultPNT +                    then let (SrcLoc _ _ row col) = useLoc (expToPNT e)+                         in ((row,col), (row,col))+                    else getStartEndLoc toks e+            in (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && endLoc<=endPos   ++        isQualifierOrLastAtom (HsQualifierAtom e) = True+        isQualifierOrLastAtom (HsLastAtom e)      = True+        isQualifierOrLastAtom _ = False + +        atoms2Stmt [HsQualifierAtom e]          = return (HsLast e)+        atoms2Stmt [HsLastAtom e]               = return (HsLast e)+        atoms2Stmt (HsGeneratorAtom s p e : ss) = HsGenerator s p e # atoms2Stmt ss+        atoms2Stmt (HsLetStmtAtom ds : ss)      = HsLetStmt ds # atoms2Stmt ss+        atoms2Stmt (HsQualifierAtom e : ss)     = HsQualifier e # atoms2Stmt ss+        atoms2Stmt _ = fail "last statement in a 'do' expression must be an expression"+  +---------------------------------------------------------------------------------------+-- | Collect the identifiers (in PName format) in a given syntax phrase.     +hsPNs::(Term t)=> t->[PName]+hsPNs=(nub.ghead "hsPNs").applyTU (full_tdTU (constTU [] `adhocTU` inPnt)) +  where +     inPnt (PNT pname ty loc) = return [pname]+     +hsPNs2::(Term t)=> t->[PName]+hsPNs2=(nub.ghead "hsPNs2").applyTU (full_tdTU (constTU [] `adhocTU` inPat)) +  where +     -- inPat :: HsPatP -> [PName]+     inPat (Pat (HsPWildCard)::HsPatP) = return [defaultPN]+     inPat (_::HsPatP) = return []++-- | Collect the identifiers (in PNT format) in a given syntax phrase.+hsPNTs ::(Term t)=>t->[PNT]+hsPNTs =(nub.ghead "hsPNTs").applyTU (full_tdTU (constTU [] `adhocTU` inPnt))+   where+     inPnt pnt@(PNT _  _ _) = return [pnt]+++-- |Find those declarations(function\/pattern binding and type signature) which define the specified PNames.+--incTypeSig indicates whether the corresponding type signature will be included.+definingDecls::[PName]         -- ^ The specified identifiers.+            ->[HsDeclP]        -- ^ A collection of declarations.+            ->Bool             -- ^ True means to include the type signature.+            ->Bool             -- ^ True means to look at the local declarations as well. +            ->[HsDeclP]        -- ^ The result.+definingDecls pns ds incTypeSig recursive=concatMap defines ds  +  where+   defines decl+     =if recursive+        then ghead "defines" $ applyTU (stop_tdTU (failTU `adhocTU` inDecl)) decl+        else defines' decl+     where+      inDecl (d::HsDeclP)+        |defines' d /=[] =return $ defines' d+      inDecl _=mzero ++      defines' decl@(Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) (p:ps) _ _):ms))) +        |isJust (find (==pname) pns) = [decl]+        |otherwise = check (p:ps)+                      where+                        check [] = []+                        check (Pat (HsPId (HsVar (PNT pname _ _))):ps) +                         | isJust (find (==pname) pns) = [decl] +                         | otherwise = check ps+                        check (_:ps) = check ps+      defines' decl@(Dec (HsPatBind loc p rhs ds))    ---CONSIDER AGAIN----+        |(hsPNs p) `intersect` pns /=[] = [decl]+      defines' decl@(Dec (HsTypeSig loc is c tp))     --handle cases like  a,b::Int +        |(map pNTtoPN is) `intersect` pns /=[]+        =if incTypeSig +           then [(Dec (HsTypeSig loc (filter (\x->isJust (find (==pNTtoPN x) pns)) is) c tp))]+           else []+      defines' decl@(Dec (HsDataDecl loc c tp cons i))+       = if checkCons cons    then [decl]+                              else []               +             where+               checkCons [] = False+               checkCons ((HsConDecl loc i c (PNT pname _ _) t):ms)+                 | isJust (find (==pname) pns) = True+                 | otherwise = checkCons ms+               checkCons ((HsRecDecl s i c (PNT pname _ _) t):ms)+                 | isJust (find (==pname) pns) = True+                 | otherwise = checkCons ms+      defines' _ =[]   ++-- | Return True if the  function\/pattern binding defines the specified identifier.+defines::PName->HsDeclP->Bool+defines pn decl@(Dec (HsFunBind loc ((HsMatch loc1 (PNT pname ty loc2) pats rhs ds):ms))) + = pname == pn+defines pn decl@(Dec (HsPatBind loc p rhs ds)) = elem pn (hsPNs p)+defines _ _= False++-- | Return True if the second PNT defines the first.+definesPNT :: PNT -> PNT -> Bool+definesPNT p1 p2+  = defineLoc p1 == defineLoc p2+++defines'::PName->HsDeclP->Bool+defines' (PN (UnQual x) s) decl@(Dec (HsFunBind loc ((HsMatch loc1 (PNT (PN (UnQual x2) s2) ty loc2) pats rhs ds):ms))) + = x == x2+defines' (PN (UnQual x) s) decl@(Dec (HsPatBind loc p rhs ds)) = x == pNTtoName (patToPNT p)+defines' _ _= False+++defines2 :: PName -> [HsPatP] -> HsDeclP -> Bool+-- defines2 a b c = error $ show (a,b,c)++defines2 pn@(PN (UnQual x) s) (p1:ps) decl@(Dec (HsFunBind loc ((HsMatch loc1 (PNT (PN (UnQual x2) s2) ty loc2) pats rhs ds):ms))) + = x == x2 || (or (map (defines2 pn (p1:ps)) ds))+defines2 pn@(PN (UnQual x1) s) (p1:ps) decl@(Dec (HsPatBind loc p rhs ds)) = (elem x1 (map pNtoName (hsPNs p)) || (or (map (defines2 pn (p1:ps)) ds))) && and (litsInPat (p1:ps) [p])+defines2 _ _ _= False++litsInPat [] _ = [True]+litsInPat _ [] = [True]+litsInPat (p:ps) [Pat (HsPTuple s (p2:ps2))] + | p == p2 = True : (litsInPat ps ps2)+ | otherwise = [False]    +litsInPat (a:as) (p@(Pat (HsPLit x y)):ps) + | a == p = True : (litsInPat as ps)+ | otherwise = [False] -- error $ show (a, b) -- [True]+litsInPat (a:as) (b:bs) = litsInPat as bs ++defines3 :: PName -> [HsPatP] -> HsDeclP -> [PName]+defines3 pn@(PN (UnQual x) s) (p:ps) decl@(Dec (HsFunBind loc ((HsMatch loc1 (PNT (PN (UnQual x2) s2) ty loc2) pats rhs ds):ms))) + | x == x2 = [(PN (UnQual x2) s2)]+ | (or (map (defines2 pn (p:ps)) ds)) = concat (map (defines3 pn (p:ps)) ds)+ | otherwise = []+defines3 pn@(PN (UnQual x1) s) (p1:ps1) decl@(Dec (HsPatBind loc p rhs ds)) + | elem x1 (map pNtoName (hsPNs p)) = (hsPNs p) ++ (hsPNs2 p)+ | (or (map (defines2 pn (p1:ps1)) ds)) = concat (map (defines3 pn (p1:ps1)) ds)+defines3 _ _ _ = []+++-- | Return True if the declaration defines the type signature of the specified identifier.+definesTypeSig :: PName -> HsDeclP -> Bool+definesTypeSig pn (Dec (HsTypeSig loc is c tp))=elem pn (map pNTtoPN is)  +definesTypeSig _  _ =False+++-- | Return True if the declaration defines the type signature of the specified identifier.+isTypeSigOf :: PNT -> HsDeclP -> Bool+isTypeSigOf pnt (Dec (HsTypeSig loc is c tp))= elem pnt is  +isTypeSigOf _  _ =False+++-- | Return the list of identifiers (in PName format) defined by a function\/pattern binding.+definedPNs::HsDeclP->[PName]+definedPNs (Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) _ _ _):_))) =[pname]+definedPNs (Dec (HsPatBind _ p _ _)) =hsPNs p+definedPNs (Dec (HsDataDecl _ _ _ cons _) )+   = getCons cons +       where+         getCons [] = []+         getCons ((HsConDecl _ _ _ (PNT pname _ _) _):ms)+           = pname : (getCons ms)+         getCons ((HsRecDecl _ _ _ (PNT pname _ _) _):ms)+           = pname : (getCons ms)  +        -- getCons _ = []+definedPNs _=[] ++-- | Return the list of identifiers (in PName format) defined by a function\/pattern binding.+definedPNsForConstr :: HsDeclP -> [PName]+definedPNsForConstr (Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) _ _ _):_))) =[pname]+definedPNsForConstr (Dec (HsPatBind _ p _ _)) =hsPNs p+definedPNsForConstr (Dec (HsDataDecl _ _ t _ _) )+   = [pNTtoPN (extractPNT t)]+definedPNsForConstr _=[] ++-- |Return True if the given syntax phrase contains any free variables.+hasFreeVars::(Term t)=>t->Bool+hasFreeVars t = fromMaybe False (do (f,_)<-hsFreeAndDeclaredPNs t+                                    if f/=[] then Just True+                                             else Nothing) ++{- Remove source location information in the syntax tree. that is to replace all+   source locations by default location: loc0 -}       +-- | Remove source location information in the syntax tree.+rmLocs :: (Term t)=> t->t +rmLocs t =runIdentity (applyTP (full_tdTP (idTP `adhocTP` exp+                                                `adhocTP` pnt+                                                `adhocTP` alt+                                                `adhocTP` lit)) t) +   where +         exp ((Exp (HsNegApp loc e)) ::HsExpP)=return (Exp (HsNegApp loc0 e))+         exp (Exp (HsExpTypeSig loc e c t))=return (Exp (HsExpTypeSig loc0 e c t))+         exp x=return x ++         alt ((HsAlt loc p e ds)::HsAltP)=return (HsAlt loc0 p e ds)++         lit (HsInt int) = return (HsInt int)+         lit (HsFrac rat)= return (HsFrac rat)+         lit (HsString s) = return (HsString s)++         pnt (PNT pname ty _)= return (PNT pname ty (N (Just loc0)))++rmAllLocs :: (Term t)=> t->t +rmAllLocs t =runIdentity (applyTP (full_tdTP (idTP `adhocTP` l)) t) +   where +         l ((SrcLoc _ _ _ _)::SrcLoc) = return loc0+++wildCardAllPNs :: (Term t)=> t -> t+wildCardAllPNs t = runIdentity (applyTP (full_tdTP (idTP `adhocTP` l `adhocTP` s)) t)+   where+     l ((PN (UnQual n) s)) = return (PN (UnQual "_") s) +     s ((SrcLoc _ _ _ _)::SrcLoc) = return loc0+-- | Change the absolute define locations of local variables to relative ones,+--   so that equality between expressions can be compared via alpha-renaming.++toRelativeLocs::(Term t)=>t->t+toRelativeLocs e = runIdentity (applyTP (full_tdTP (idTP `adhocTP` inLoc)) e)+  where+    inLoc (SrcLoc f c row col)+      | elem (row,col) defLocs+          = let index=fromJust (elemIndex (row,col) defLocs) + 1 +            in return (SrcLoc f index index index)+    inLoc loc = return loc++    defLocs= ((nub.ghead "toRelativeLoc").applyTU (full_tdTU (constTU [] +                                                      `adhocTU` inPnt ))) e+        where+         inPnt pnt@(PNT pn ty loc)+            |defineLoc pnt == useLoc pnt= return [(\(SrcLoc _ _ r c)->(r,c)) (srcLoc pn)]+         inPnt _ = return []+         +    +------------------------------------------------------------------------------------------ +-- | Replace the name (and qualifier if specified) by a new name (and qualifier) in a PName.+--   The function does not modify the token stream.+replaceNameInPN::Maybe ModuleName    -- ^ The new qualifier+                 ->PName             -- ^ The old PName+                 ->String            -- ^ The new name +                 ->PName             -- ^ The result +replaceNameInPN qualifier (PN (UnQual s)(S loc))  newName+  = if isJust qualifier then (PN (Qual (fromJust qualifier) newName) (S loc))+                        else (PN (UnQual newName) (S loc)) +replaceNameInPN qualifier (PN (Qual modName  s)(S loc))  newName+  = if isJust qualifier  then (PN (Qual (fromJust qualifier) newName)(S loc))+                         else (PN (Qual modName newName) (S loc))+replaceNameInPN qualifier (PN (UnQual s) (G modName s1 loc))  newName+  = if isJust qualifier then (PN (Qual (fromJust qualifier)  newName) (G modName newName loc))+                        else (PN (UnQual newName) (G modName newName loc)) +replaceNameInPN qualifier (PN (Qual modName s) (G modName1 s1 loc))  newName+  =if isJust qualifier then (PN (Qual (fromJust qualifier) newName) (G modName1 newName loc)) +                       else (PN (Qual modName newName) (G modName1 newName loc))++-- | Rename each occurrences of the identifier in the given syntax phrase with the new name.+--   If the Bool parameter is True, then modify both the AST and the token stream, otherwise only modify the AST.++{-+renamePN::(Term t)+           =>PName               -- ^ The identifier to be renamed.+             ->Maybe ModuleName  -- ^ The qualifier+             ->String            -- ^ The new name +             ->Bool              -- ^ True means modifying the token stream as well.+             ->t                 -- ^ The syntax phrase+             ->m t  +-}++renamePN::((MonadState (([PosToken], Bool), t1) m),Term t)+           =>PName               -- ^ The identifier to be renamed.+             ->Maybe ModuleName  -- ^ The qualifier+             ->String            -- ^ The new name +             ->Bool              -- ^ True means modifying the token stream as well.+             ->t                 -- ^ The syntax phrase+             ->m t  ++renamePN oldPN qualifier newName updateToks t+  = applyTP (full_tdTP (adhocTP idTP rename)) t+  where+    rename  pnt@(PNT pn ty (N (Just (SrcLoc fileName c  row col))))+     | (pn ==oldPN) && (srcLoc oldPN == srcLoc pn)+     = do if updateToks  +           then  do ((toks,_),others)<-get                           +                    let toks'=replaceToks toks (row,col) (row,col)+                              [mkToken Varid  (row,col) ((render.ppi) (replaceName pn  newName))]+                    put ((toks', modified),others)+                    return (PNT (replaceName pn newName) ty (N (Just (SrcLoc fileName c  row col))))+           else return (PNT (replaceName pn newName) ty (N (Just (SrcLoc fileName c  row col))))+      where +        replaceName = if isJust qualifier && canBeQualified pnt t +                        then replaceNameInPN qualifier+                        else replaceNameInPN Nothing       +    rename x = return x +  +-- | Return True if the identifier can become qualified.+canBeQualified::(Term t)=>PNT->t->Bool+canBeQualified pnt t+  = isTopLevelPNT pnt && isUsedInRhs pnt t && not (findPntInImp pnt t) +  where +    findPntInImp pnt +      = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inImp)))+      where +       inImp ((HsImportDecl loc modName qual  as h)::HsImportDeclP)+        |findEntity pnt h = Just True+       inImp _ = Nothing+  + +-- | Return True if the identifier(in PNT format) occurs in the given syntax phrase.+findPNT::(Term t)=>PNT->t->Bool  +findPNT pnt +  = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))+  where+    worker (pnt1::PNT)+      | sameOccurrence pnt pnt1 =Just True+    worker _ =Nothing  +    +-- | Return True if the identifier(in PNT format) occurs in the given syntax phrase.+findPN'::(Term t)=>PName->t->Bool  +findPN' p1+  = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))+  where+    worker (p2@(PN (UnQual x) s)::PName)+      | rmLocs p1 == rmLocs p2 = Just True+    worker _ =Nothing  ++-- | Return True if the identifier (in PName format) occurs in the given syntax phrase.+findPN::(Term t)=>PName->t->Bool+findPN pn +  =(fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where +        worker (pn1::PName)+           |pn == pn1 && srcLoc pn == srcLoc pn1 = Just True +        worker _ =Nothing +        +-- | Return True if the identifier (in PName format) occurs on the RHS of given syntax phrase.+findPNRHS::(Term t)=>PName->t->Bool+findPNRHS pn +  =(fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where +        worker (match@(HsMatch loc name pats rhs ds)::HsMatchP)+           | findPN pn pats = Just True+        worker _ =Nothing ++-- | Return True if any of the specified PNames ocuur in the given syntax phrase.+findPNs::(Term t)=>[PName]->t->Bool +findPNs pns +   =(fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))+     where +        worker (pn1::PName)+           |elem pn1 pns = Just True+        worker _ =Nothing  ++++----------------------------------------------------------------------------------------+-- | Check whether the specified identifier is declared in the given syntax phrase t,+-- if so, rename the identifier by creating a new name automatically. If the Bool parameter +-- is True, the token stream will be modified, otherwise only the AST is modified. ++{-+autoRenameLocalVar::(MonadPlus m, Term t)+                    =>Bool         -- ^ True means modfiying the token stream as well.  +                     ->PName       -- ^ The identifier.+                     ->t           -- ^ The syntax phrase.+                     -> m t        -- ^ The result.+-}+autoRenameLocalVar::(MonadPlus m, (MonadState (([PosToken], Bool), (Int,Int)) m), Term t)+                    =>Bool         -- ^ True means modfiying the token stream as well.  +                     ->PName       -- ^ The identifier.+                     ->t           -- ^ The syntax phrase.+                     -> m t        -- ^ The result.+++autoRenameLocalVar updateToks pn +  =applyTP (once_buTP (failTP `adhocTP` renameInMatch +                              `adhocTP` renameInPat+                              `adhocTP` renameInExp+                              `adhocTP` renameInAlt+                              `adhocTP` renameInStmts))  +      where +         renameInMatch (match::HsMatchP)+           |isDeclaredIn pn match=worker match+         renameInMatch _ =mzero+     +         renameInPat (pat::HsDeclP)+          |isDeclaredIn pn pat=worker pat                 +         renameInPat _ =mzero+     +         renameInExp (exp::HsExpP)+          |isDeclaredIn pn exp=worker exp                 +         renameInExp _ =mzero+ +         renameInAlt (alt::HsAltP)+          |isDeclaredIn pn alt=worker alt                 +         renameInAlt _ =mzero+       +         renameInStmts (stmt::HsStmtP)+          |isDeclaredIn pn stmt=worker stmt+         renameInStmts _=mzero+         +         worker t =do (f,d)<-hsFDNamesFromInside t+                      ds<-hsVisibleNames pn (hsDecls t)+                      let newName=mkNewName (pNtoName pn) (nub (f `union` d `union` ds)) 1+                      if updateToks+                        then renamePN pn Nothing newName True t +                        else renamePN pn Nothing newName False t     ++-------------------------------------------------------------------------------------+-- | Add a guard expression to the RHS of a function\/pattern definition. If a guard already+--   exists in the RHS, the new guard will be added to the beginning of the existing one.+addGuardsToRhs::(MonadState (([PosToken], Bool), (Int,Int)) m)+                => RhsP     -- ^ The RHS of the declaration.+                -> HsExpP   -- ^ The guard expression to be added.+                -> m RhsP     -- ^ The result.+addGuardsToRhs (HsBody e) guardExp +  = do ((toks,_), (v1,v2)) <-get+       let (startPos', _) = startEndLoc toks e+           (toks1,toks2) = break (\t->tokenPos t==startPos') toks+           reversedToks1BeforeEqOrArrow = dropWhile (\t->not (isEqual t || isArrow t)) (reverse toks1) +           eqOrArrowTok = ghead "addGuardsToRhs"  reversedToks1BeforeEqOrArrow+           startPos = tokenPos eqOrArrowTok +           offset = lengthOfLastLine (reverse (gtail "addGuardsToRhs" reversedToks1BeforeEqOrArrow))+           newCon = "|"++(render.ppi) guardExp ++ "\n" ++ replicate offset ' '++ tokenCon eqOrArrowTok+           newToks = tokenise (Pos 0 v1 1) 0  False newCon+           toks' = replaceToks toks startPos startPos newToks+       put ((toks',modified), ((tokenRow (glast "addFormalParams" newToks) -10), v2))+       (guardExp',_) <- addLocInfo (guardExp, newToks)    +       return $ HsGuard [(loc0, guardExp, e)]++addGuardsToRhs (HsGuard gs) guardExp+  = do newGuards <- mapM (addGuard guardExp) gs+       return (HsGuard newGuards)+   where +   addGuard guardExp (loc, e1, e2)+     = do (e', _)<-updateToks e1 (Exp (HsInfixApp guardExp (HsVar (nameToPNT "&&")) e1)) prettyprint+          return (loc, e', e2)+++------------------------------------------------------------------------------------------------------+{-+addParamsToDecls::(MonadPlus m) +               => [HsDeclP]   -- ^ A declaration list where the function is defined and\/or used.+                  ->PName     -- ^ The function name.+                  ->[PName]   -- ^ The parameters to be added.+                  ->Bool      -- ^ Modify the token stream or not.+                  ->m [HsDeclP] -- ^ The result. +-}++addParamsToDecls::(MonadPlus m, (MonadState (([PosToken], Bool), (Int,Int)) m))+               => [HsDeclP]   -- ^ A declaration list where the function is defined and\/or used.+                  ->PName     -- ^ The function name.+                  ->[PName]   -- ^ The parameters to be added.+                  ->Bool      -- ^ Modify the token stream or not.+                  ->m [HsDeclP] -- ^ The result.+ +addParamsToDecls decls pn paramPNames modifyToks+   = if (paramPNames/=[])+        then mapM addParamToDecl decls+        else return decls +  where +   addParamToDecl (Dec (HsFunBind loc matches@((HsMatch _ fun pats rhs ds):ms)))+    | pNTtoPN fun == pn+    = do matches'<-mapM addParamtoMatch matches +         return (Dec (HsFunBind loc matches'))+      where +       addParamtoMatch (HsMatch loc  fun  pats rhs  decls) +        = do rhs'<-addActualParamsToRhs pn paramPNames rhs +             let pats' = map pNtoPat paramPNames +             pats'' <- if modifyToks then do (p, _)<-addFormalParams fun pats'+                                             return p+                                     else return pats' +             return (HsMatch loc  fun  (pats'++pats)  rhs' decls)++   addParamToDecl (Dec (HsPatBind loc p rhs ds))+     |patToPN p == pn +       = do rhs'<-addActualParamsToRhs pn paramPNames rhs+            let pats' = map pNtoPat paramPNames +            pats'' <- if modifyToks  then do (p, _) <-addFormalParams p pats'+                                             return p+                                     else return pats'                        +            return (Dec (HsFunBind loc [HsMatch loc (patToPNT p) pats' rhs ds]))+   addParamToDecl x=return x + +   addActualParamsToRhs pn paramPNames+    = applyTP (stop_tdTP (failTP `adhocTP` worker))  +     where                   +       worker exp@(Exp (HsId (HsVar (PNT pname ty loc))))+        | pname==pn+         = do let newExp=Exp (HsParen (foldl addParamToExp exp (map pNtoExp paramPNames)))+              if modifyToks then do (newExp', _) <- updateToks exp newExp prettyprint+                                    return newExp' +                            else return newExp+       worker x =mzero ++       addParamToExp  exp param=(Exp (HsApp exp param))++ +-------------------------------------------------------------------++-- | Remove the first n parameters of a given identifier in an expression.+rmParams:: (MonadPlus m,MonadState (([PosToken], Bool), (Int,Int)) m)=>+             PNT          -- ^ The identifier whose parameters are to be removed.+             ->Int        -- ^ Number of parameters to be removed.+             ->HsExpP     -- ^ The original expression.+             ->m HsExpP   -- ^ The result expression.+rmParams pnt n exp +  = if n==0 then return exp+            else do exp'<-rmOneParam pnt exp+                    rmParams pnt (n-1) exp' +   where +         rmOneParam pnt= applyTP (stop_tdTP (failTP `adhocTP` inExp))+       +         inExp (exp@(Exp (HsParen (Exp (HsApp e1 e2))))::HsExpP)+          ---dfd+           |sameOccurrence (expToPNT e1) pnt +            =do updateExp exp e1     +         inExp exp@(Exp (HsApp e1 e2))+           | sameOccurrence (expToPNT e1) pnt+            =do updateExp exp e1+         inExp  _=mzero++         updateExp exp e1 +           = do ((toks,_),others)<-get     --handle the case like '(fun x) => fun "+                let (startPos,endPos)=getStartEndLoc toks exp+                    toks'=replaceToks toks startPos endPos $ getToks (getStartEndLoc toks e1) toks+                put ((toks',modified),others)+                return e1  +             +-------------------------------------------------------------------------------------------------------+++{-A simple function binding satisfies : 1. all parameters are variables+                                        2. only one match(equation)+                                        3. The rhs of the match is not in guard style.+  that is:+   HsFunBind SrcLoc ((HsMatch SrcLoc i [var] (HsBody e) ds):[]) ds++  If a function binding is not a simple function binding, then convert it into a simple binding +  using Case or IfThenElse expressions like this:+    case1: there are multi matches => case expression+    case2: there is only one match, however the parameters are not simple variables =>case expression.+    case3: there is only one match and the parameters are all simple variables, however there is a guard+           in Rhs => If then else++  In case of pattern binding: if there is guard in its Rhs, then convert it into IfThenElse style. -}++                              +-- | If a function\/pattern binding then convert it into a simple binding using case and\/or if-then-else expressions.     +-- A simple function\/pattern binding should satisfy: a) all the paraneters are simple variables; b). only has one equation; +-- c). the RHS does not have guards. This function DOES NOT modify the token stream not AST.+simplifyDecl::(Monad m)=>HsDeclP->m HsDeclP+simplifyDecl decl+      |isFunBind decl =if (multiMatches decl) || (singleMatchWithComplexParams decl)+                           then matchesToCase decl+                           else return (guardToIfThenElse decl)+      |isPatBind decl=return (guardToIfThenElse  decl)++      |otherwise      = return decl+   where++      multiMatches (Dec (HsFunBind loc matches))=length matches>1+      multiMatches _ = False ++      singleMatchWithComplexParams (Dec (HsFunBind loc matches@((HsMatch loc1 pnt pats rhs ds):ms)))+            =length matches==1 && any (==defaultPN) (map patToPN pats)+      singleMatchWithComplexParams _ =False++      --convert a multi-match function declaration into a single-match declration using case expression.+      matchesToCase decl@(Dec (HsFunBind loc matches@((HsMatch loc1 pnt pats rhs ds):ms)))+        =do params<-mkNewParamPNames (length pats)+            exp<-pNamesToExp params+            return (Dec (HsFunBind loc [(HsMatch loc1 pnt (map pNtoPat params)+                      (HsBody (Exp (HsCase exp (map matchToAlt matches)))) [])]))++      --make n new parameters like [x_0,x_1, ...,x_n]+      mkNewParamPNames n=mkNewParamPNames' n []+              where mkNewParamPNames' n pNames+                         =if n==0 then return pNames+                                     else do let pn'= PN (UnQual  ("x_"++show (n-1))) (S loc0)+                                             mkNewParamPNames' (n-1) (pn':pNames)+                                        +      matchToAlt ((HsMatch loc1 pnt pats rhs ds)::HsMatchP)=HsAlt loc0 (listToTuple pats) rhs ds+        where+         listToTuple pats=if (length pats)==1 then ghead "listToTuple" pats   --no problem with head+                                              else (Pat (HsPTuple loc0 pats))++      pNamesToExp pns@(p:ps)=if ps==[] then return $ pNtoExp p+                                        else  do let exp'=map pNtoExp pns+                                                 return (Exp (HsTuple exp')) +      guardToIfThenElse :: HsDeclP -> HsDeclP     +      guardToIfThenElse decl= case decl of+          (Dec (HsPatBind loc p g@(HsGuard gs) ds))->(Dec (HsPatBind loc p (rmGuard g) ds))+          (Dec (HsFunBind loc ((HsMatch loc1 pnt pats  g@(HsGuard gs) ds):[]))) ->+                            (Dec (HsFunBind loc ((HsMatch loc1 pnt pats (rmGuard g) ds):[])))+          _ ->decl+           +          where+           rmGuard ((HsGuard gs)::RhsP)+             = let (_,e1,e2)=glast "guardToIfThenElse" gs+               in  if ((pNtoName.expToPN) e1)=="otherwise" +                   then  HsBody (foldl mkIfThenElse e2 (tail(reverse gs)))+                   else  HsBody (foldl mkIfThenElse defaultElse (reverse gs)) +           +           mkIfThenElse e (_,e1, e2)=(Exp (HsIf e1 e2 e)) ++           defaultElse=(Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "error") (G (PlainModule "Prelude") "error" +                        (N (Just loc0)))) Value (N (Just loc0)))))) (Exp (HsLit loc0 (HsString "UnMatched Pattern")))))+            ++-----------------------------------------------------------------------------------------+-- | Collect those data constructors that occur in the given syntax phrase, say t. In the result, +--   the first list contains the data constructors that are declared in other modules, and the second+--   list contains the data constructors that are declared in the current module.+hsDataConstrs::Term t=>ModuleName              -- ^ The name of the module which 't' belongs to.+                     -> t                      -- ^ The given syntax phrase.+                     ->([PName],[PName])       -- ^ The result.+hsDataConstrs modName  +  = ghead "hsDataConstrs". (applyTU (stop_tdTU (failTU `adhocTU` pnt)))  +  where+    pnt (PNT pname (ConstrOf _  _) _)+      = if hasModName pname==Just modName +          then return ([],[pname])+          else return ([pname],[])+    pnt _ = mzero+++-- | Collect those type constructors and class names that occur in the given syntax phrase, say t.+--   In the result, the first list contains the type constructor\/classes which are+--   declared in other modules, and the second list contains those type constructor\/classes+--  that are declared in the current module.++hsTypeConstrsAndClasses::Term t=>ModuleName                  -- ^ The name of the module which 't' belongs to.+                               -> t                          -- ^ The given syntax phrase.+                               -> ([PName],[PName])          -- ^ The result.+hsTypeConstrsAndClasses modName+  = ghead "hsTypeConstrAndClasses".(applyTU (stop_tdTU (failTU `adhocTU` pnt))) +  where +    pnt (PNT (PN i (G  modName1 id loc)) (Type _) _)+      = if modName == modName1+                     then return ([],[(PN i (G  modName id loc))])+                     else return ([(PN i (G  modName id loc))], [])+    pnt (PNT pname (Class _ _) _)=if hasModName pname==Just modName +                                 then return ([],[pname])+                                 else return ([pname],[])+    pnt _ =mzero+++-- |Collect those type variables that are declared in a given syntax phrase t.+-- In the returned result, the first list is always be empty.+hsTypeVbls::(Term t) => t -> ([PName],[PName])+hsTypeVbls =ghead "hsTypeVbls".(applyTU (stop_tdTU (failTU `adhocTU` pnt))) +  where +    pnt (PNT (PN i (S loc)) (Type _) _) = return ([], [(PN i (S loc))])+    pnt _ =mzero+++-- |Collect the class instances of the spcified class from the given syntax phrase. In the result,+-- the first list contains those class instances which are declared in other modules, +-- and the second list contains those class instances that are declared in the current module.+hsClassMembers::Term t => String               -- ^ The class name.+                        ->ModuleName           -- ^ The module name.+                        ->t                    -- ^ The syntax phrase.+                        ->([PName],[PName])    -- ^ The result.+hsClassMembers className modName +    = ghead "hsClassMembers". (applyTU (stop_tdTU (failTU `adhocTU` pnt))) +         where+            pnt(PNT pname (MethodOf i _ _) _) -- Claus+                | pNtoId i==className+                  = if hasModName pname == Just modName +                      then return ([],[pname])+                      else return ([pname],[])+            pnt _ = mzero   +            +            pNtoId :: PN (HsName.Id) ->String+            pNtoId (PN i orig)=i++------------------------------------------------------------------------------------------+-- | Collect the free and declared variables (in the PName format) in a given syntax phrase t.+-- In the result, the first list contains the free variables, and the second list contains the declared variables.+hsFreeAndDeclaredPNs:: (Term t, MonadPlus m)=> t-> m ([PName],[PName])+hsFreeAndDeclaredPNs t=do (f,d)<-hsFreeAndDeclared' t+                          return (nub f, nub d)+   where +          hsFreeAndDeclared'=applyTU (stop_tdTU (failTU  `adhocTU` exp+                                                         `adhocTU` pat+                                                         `adhocTU` match+                                                         `adhocTU` patBind+                                                         `adhocTU` alt+                                                         `adhocTU` decls+                                                         `adhocTU` stmts+                                                         `adhocTU` recDecl))  +                          +          exp (Exp (HsId (HsVar (PNT pn _ _))))=return ([pn],[])+          exp (Exp (HsId (HsCon (PNT pn _ _))))=return ([pn],[])+          exp (Exp (HsInfixApp e1 (HsVar (PNT pn _ _)) e2))+              =addFree pn (hsFreeAndDeclaredPNs [e1,e2])+          exp (Exp (HsLambda pats body))+              = do (pf,pd) <-hsFreeAndDeclaredPNs pats+                   (bf,_) <-hsFreeAndDeclaredPNs body+                   return ((bf `union` pf) \\ pd, [])+          exp (Exp (HsLet decls exp))+              = do (df,dd)<- hsFreeAndDeclaredPNs decls+                   (ef,df)<- hsFreeAndDeclaredPNs exp +                   return ((df `union` (ef \\ dd)), dd ++ df) -- [])+          exp (Exp (HsRecConstr _  (PNT pn _ _) e))+               =addFree  pn  (hsFreeAndDeclaredPNs e)   --Need Testing+          exp (Exp (HsAsPat (PNT pn _ _) e))+              =addFree  pn  (hsFreeAndDeclaredPNs e)  +          exp _ = mzero++          +          pat (Pat (HsPId (HsVar (PNT pn _ _))))=return ([],[pn])+          pat (Pat (HsPInfixApp p1 (PNT pn _ _) p2))=addFree pn (hsFreeAndDeclaredPNs [p1,p2])+          pat (Pat (HsPApp (PNT pn _ _) pats))=addFree pn (hsFreeAndDeclaredPNs pats)+          pat (Pat (HsPRec (PNT pn _ _) fields))=addFree pn (hsFreeAndDeclaredPNs fields)+          pat _ =mzero+                               ++          match ((HsMatch _ (PNT fun _ _)  pats rhs  decls)::HsMatchP)+            = do (pf,pd) <- hsFreeAndDeclaredPNs pats+                 (rf,rd) <- hsFreeAndDeclaredPNs rhs+                 (df,dd) <- hsFreeAndDeclaredPNs decls+                 return ((pf `union` ((rf `union` df) \\ (dd `union` pd `union` [fun]))),[fun])++         -------Added by Huiqing Li-------------------------------------------------------------------++          patBind ((Dec (HsPatBind _ pat (HsBody rhs) decls))::HsDeclP)+             =do (pf,pd) <- hsFreeAndDeclaredPNs pat+                 (rf,rd) <- hsFreeAndDeclaredPNs rhs+                 (df,dd) <- hsFreeAndDeclaredPNs decls+                 return (pf `union` ((rf `union` df) \\(dd `union` pd)),pd)+          patBind _=mzero+         ------------------------------------------------------------------------------------------- ++          alt ((HsAlt _ pat exp decls)::(HsAlt (HsExpP) (HsPatP) [HsDeclP]))+             = do (pf,pd) <- hsFreeAndDeclaredPNs pat+                  (ef,ed) <- hsFreeAndDeclaredPNs exp+                  (df,dd) <- hsFreeAndDeclaredPNs decls+                  return (pf `union` (((ef \\ dd) `union` df) \\ pd),[])+++          decls (ds :: [HsDeclP])+             =do (f,d) <-hsFreeAndDeclaredList ds+                 return (f\\d,d)+          +          stmts ((HsGenerator _ pat exp stmts) :: HsStmt (HsExpP) (HsPatP) [HsDeclP]) -- Claus+             =do (pf,pd) <-hsFreeAndDeclaredPNs pat+                 (ef,ed) <-hsFreeAndDeclaredPNs exp+                 (sf,sd) <-hsFreeAndDeclaredPNs stmts+                 return (pf `union` ef `union` (sf\\pd),[]) -- pd) -- Check this ++          stmts ((HsLetStmt decls stmts) :: HsStmt (HsExpP) (HsPatP) [HsDeclP])+             =do (df,dd) <-hsFreeAndDeclaredPNs decls+                 (sf,sd) <-hsFreeAndDeclaredPNs stmts+                 return (df `union` (sf \\dd),[])+          stmts _ =mzero++          recDecl ((HsRecDecl _ _ _ _ is) :: HsConDeclI PNT (HsTypeI PNT) [HsTypeI PNT])+                =do let d=map pNTtoPN $ concatMap fst is+                    return ([],d)+          recDecl _ =mzero+            +       +          addFree free mfd=do (f,d)<-mfd+                              return ([free] `union` f, d)++          hsFreeAndDeclaredList l=do fds<-mapM hsFreeAndDeclaredPNs l+                                     return (foldr union [] (map fst fds),+                                             foldr union [] (map snd fds))++-- |The same as `hsFreeAndDeclaredPNs` except that the returned variables are in the String format.           +hsFreeAndDeclaredNames::(Term t, MonadPlus m)=> t->m([String],[String])+hsFreeAndDeclaredNames t =do (f1,d1)<-hsFreeAndDeclaredPNs t+                             return ((nub.map pNtoName) f1, (nub.map pNtoName) d1)++-----------------------------------------------------------------------------------------+{- |`hsFDsFromInside` is different from `hsFreeAndDeclaredPNs` in that: given an syntax phrase t,+    `hsFDsFromInside` returns not only the declared variables that are visible from outside of t,+     but also those declared variables that are visible to the main expression inside t.+-}+++hsFDsFromInside:: (Term t, MonadPlus m)=> t-> m ([PName],[PName])+hsFDsFromInside t = do (f,d)<-hsFDsFromInside' t+                       return (nub f, nub d)+   where +     hsFDsFromInside' = applyTU (once_tdTU (failTU  `adhocTU` mod+                                                    -- `adhocTU` decls+                                                     `adhocTU` decl+                                                     `adhocTU` match+                                                     `adhocTU` exp+                                                     `adhocTU` alt+                                                     `adhocTU` stmts ))+                                                    ++     mod ((HsModule loc modName exps imps ds)::HsModuleP)+        = hsFreeAndDeclaredPNs ds  ++ {-    decls (ds::[HsDeclP])                    --CHECK THIS.+       = hsFreeAndDeclaredPNs decls +-}+     match ((HsMatch loc1 (PNT fun _ _) pats rhs ds) ::HsMatchP)+       = do (pf, pd) <-hsFreeAndDeclaredPNs pats+            (rf, rd) <-hsFreeAndDeclaredPNs rhs+            (df, dd) <-hsFreeAndDeclaredPNs ds+            return (nub (pf `union` ((rf `union` df) \\ (dd `union` pd `union` [fun]))), +                    nub (pd `union` rd `union` dd `union` [fun]))++     decl ((Dec (HsPatBind loc p rhs ds))::HsDeclP)+      = do (pf, pd)<-hsFreeAndDeclaredPNs p+           (rf, rd)<-hsFreeAndDeclaredPNs rhs+           (df, dd)<-hsFreeAndDeclaredPNs ds +           return (nub (pf `union` ((rf `union` df) \\ (dd `union` pd))),+                   nub ((pd `union` rd `union` dd)))++     decl (Dec (HsFunBind loc matches))+         =do fds <-mapM hsFDsFromInside matches+             return (nub (concatMap fst fds), nub(concatMap snd fds))+   +     decl _ = mzero + +     exp ((Exp (HsLet decls exp))::HsExpP)+          = do (df,dd)<- hsFreeAndDeclaredPNs decls+               (ef,_)<- hsFreeAndDeclaredPNs exp +               return (nub (df `union` (ef \\ dd)), nub dd)+     exp (Exp (HsLambda pats body))+            = do (pf,pd) <-hsFreeAndDeclaredPNs pats+                 (bf,_) <-hsFreeAndDeclaredPNs body+                 return (nub ((bf `union` pf) \\ pd), nub pd)      +     exp _ = mzero++     alt ((HsAlt _ pat exp decls)::HsAltP)+         = do (pf,pd) <- hsFreeAndDeclaredPNs pat+              (ef,ed) <- hsFreeAndDeclaredPNs exp+              (df,dd) <- hsFreeAndDeclaredPNs decls+              return (nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), nub (pd `union` dd))      ++     stmts ((HsLetStmt decls stmts)::HsStmtP)+          = do (df,dd) <-hsFreeAndDeclaredPNs decls+               (sf,sd) <-hsFreeAndDeclaredPNs stmts+               return (nub (df `union` (sf \\dd)),[]) -- dd)++     stmts (HsGenerator _ pat exp stmts) +          = do (pf,pd) <-hsFreeAndDeclaredPNs pat+               (ef,ed) <-hsFreeAndDeclaredPNs exp+               (sf,sd) <-hsFreeAndDeclaredPNs stmts+               return (nub (pf `union` ef `union` (sf\\pd)),[]) -- pd)+     +     stmts _ = mzero    +++-- | The same as `hsFDsFromInside` except that the returned variables are in the String format+hsFDNamesFromInside::(Term t, MonadPlus m)=>t->m ([String],[String])+hsFDNamesFromInside t =do (f,d)<-hsFDsFromInside t+                          return ((nub.map pNtoName) f, (nub.map pNtoName) d)++------------------------------------------------------------------------------------------+-- | Same as `hsVisiblePNs' except that the returned identifiers are in String format.+hsVisibleNames:: (Term t1, Term t2, FindEntity t1, MonadPlus m) => t1 -> t2 -> m [String]+hsVisibleNames e t =do d<-hsVisiblePNs e t+                       return ((nub.map pNtoName) d)+ +-- | Given syntax phrases e and t, if e occurs in  t, then return those vairables+--  which are declared in t and accessible to e, otherwise return []. +hsVisiblePNs :: (Term t1, Term t2, FindEntity t1, MonadPlus m) => t1 -> t2 -> m [PName]+hsVisiblePNs e t =applyTU (full_tdTU (constTU [] `adhocTU` mod +                                                  `adhocTU` exp+                                                  `adhocTU` match+                                                  `adhocTU` patBind+                                                  `adhocTU` alt+                                                  `adhocTU` stmts)) t+      where         +          mod ((HsModule loc modName exps imps decls)::HsModuleP)+            |findEntity e decls+           =do (df,dd)<-hsFreeAndDeclaredPNs decls+               return dd+          mod _=return []+                                                             +          exp ((Exp (HsLambda pats body))::HsExpP)+            |findEntity e body+             = do (pf,pd) <-hsFreeAndDeclaredPNs pats+                  return pd         ++          exp (Exp (HsLet decls e1))+             |findEntity e e1 || findEntity e decls+             = do (df,dd)<- hsFreeAndDeclaredPNs decls+                  return dd      +          exp _ =return [] +                   +          match (m@(HsMatch _ (PNT fun _ _)  pats rhs  decls)::HsMatchP)+            |findEntity e rhs || findEntity e decls+            = do (pf,pd) <- hsFreeAndDeclaredPNs pats+                 (df,dd) <- hsFreeAndDeclaredPNs decls+                 return  (pd `union` dd `union` [fun])+          match _=return []+ +          patBind (p@(Dec (HsPatBind _ pat rhs decls))::HsDeclP)+            |findEntity e rhs || findEntity e decls +             =do (pf,pd) <- hsFreeAndDeclaredPNs pat+                 (df,dd) <- hsFreeAndDeclaredPNs decls+                 return (pd `union` dd)+          patBind _=return [] ++          alt ((HsAlt _ pat exp decls)::HsAltP)+             |findEntity e exp || findEntity e decls+             = do (pf,pd) <- hsFreeAndDeclaredPNs pat+                  (df,dd) <- hsFreeAndDeclaredPNs decls+                  return (pd `union` dd)+          alt _=return []+                    +          stmts ((HsGenerator _ pat exp stmts) :: HsStmtP) +            |findEntity e stmts+             =do (pf,pd) <-hsFreeAndDeclaredPNs pat+                 return pd++          stmts (HsLetStmt decls stmts)+            |findEntity e decls || findEntity e stmts+             =do (df,dd) <-hsFreeAndDeclaredPNs decls+                 return dd+          stmts _ =return []++-------------------------------------------------------------------------------++{- | The HsDecls class -}+class (Term t) => HsDecls t where  +    -- | Return the declarations that are directly enclosed in the given syntax phrase.+    hsDecls :: t->[HsDeclI PNT]+    -- | Replace the  directly enclosed declaration list by the given declaration list.+    --  Note: This function does not modify the token stream.+    replaceDecls :: t->[HsDeclI PNT]->t+   +    -- | Return True if the specified identifier is declared in the given syntax phrase.+    isDeclaredIn :: PName -> t->Bool ++instance HsDecls HsMatchP where   +    hsDecls (HsMatch loc1 fun pats rhs ds)=ds ++    replaceDecls (HsMatch loc1 fun pats rhs ds) ds'+      =(HsMatch loc1 fun pats rhs ds')++    isDeclaredIn  pn match@(HsMatch loc1 (PNT fun _ _) pats rhs ds)+       =fromMaybe False ( do (_,d)<-hsFDsFromInside match+                             Just (elem pn (d \\ [fun])))+instance HsDecls HsDeclP where+    hsDecls (Dec (HsPatBind loc p rhs ds))=ds+    hsDecls (Dec (HsFunBind loc matches))=concatMap hsDecls matches  +    hsDecls _ =[]++    replaceDecls (Dec (HsPatBind loc p rhs ds)) ds'+        =Dec (HsPatBind loc p rhs ds')+    replaceDecls x ds' =x++    isDeclaredIn pn (Dec (HsPatBind loc p rhs ds))+      = fromMaybe False (do (_, rd)<-hsFreeAndDeclaredPNs rhs+                            (_, dd)<-hsFreeAndDeclaredPNs ds+                            Just (elem pn (rd `union` dd)))               +    isDeclaredIn pn _ =False ++instance HsDecls [HsDeclP] where+    hsDecls ds=concatMap hsDecls ds+    replaceDecls ds _ = ds             -- This should not happen.+    isDeclaredIn _ ds = False            -- This should not happen.++instance HsDecls HsModuleP where+    hsDecls (HsModule loc modName exps imps ds)=ds++    replaceDecls (HsModule loc modName exps imps ds) ds'+       = HsModule loc modName exps imps ds'++    isDeclaredIn pn (HsModule loc modName exps imps ds)+       =fromMaybe False  (do (rf,rd)<-hsFreeAndDeclaredPNs ds+                             Just (elem pn rd))   ++instance HsDecls RhsP where+    hsDecls rhs=fromMaybe [] (applyTU (stop_tdTU (failTU `adhocTU` inLet+                                                         `adhocTU` inAlt+                                                         `adhocTU` inStmt)) rhs) +             where inLet ((Exp (HsLet ds e)) ::HsExpP)=Just ds+                   inLet _ =mzero++                   inAlt ((HsAlt _ p rhs ds)::HsAlt HsExpP HsPatP [HsDeclP])=Just ds++                   inStmt ((HsLetStmt ds _)::HsStmt HsExpP HsPatP [HsDeclP])=Just ds+                   inStmt _=mzero++    replaceDecls rhs _ = rhs           -- This should not happen.+    isDeclaredIn _ _  = False            -- This should not happen.++instance HsDecls HsExpP where+    hsDecls rhs=fromMaybe [] (applyTU (stop_tdTU (failTU `adhocTU` inLet+                                                         `adhocTU` inAlt+                                                         `adhocTU` inStmt)) rhs) +             where inLet ((Exp (HsLet ds e)) ::HsExpP)=Just ds+                   inLet (Exp (HsListComp (HsLetStmt ds stmts)))=Just ds+                   inLet (Exp (HsDo (HsLetStmt ds stmts)))=Just ds+                   inLet _ =Nothing++                   inAlt ((HsAlt _ p rhs ds)::HsAlt HsExpP HsPatP [HsDeclP])=Just ds++                   inStmt ((HsLetStmt ds _)::HsStmt HsExpP HsPatP [HsDeclP])=Just ds+                   inStmt _=Nothing +    +    replaceDecls (Exp (HsLet ds e)) ds'+            =if ds'==[]+                then e +                else (Exp (HsLet ds' e))+                     +    replaceDecls (Exp (HsListComp (HsLetStmt ds stmts))) ds'+            =if ds'==[] && isLast stmts +               then (Exp (HsList [fromJust (expInLast stmts)]))+               else (Exp (HsListComp (HsLetStmt ds' stmts)))+       where+         isLast (HsLast e)=True+         isLast _=False+         +         expInLast (HsLast e)=Just e+         expInLast _=Nothing++    replaceDecls (Exp (HsDo (HsLetStmt ds stmts))) ds'+            =if ds'==[] +                then (Exp (HsDo stmts))+                else (Exp (HsDo (HsLetStmt ds' stmts)))+    replaceDecls x ds'=x+++    isDeclaredIn pn (Exp (HsLambda pats body))+            = fromMaybe False (do (pf,pd) <-hsFreeAndDeclaredPNs pats+                                  Just (elem pn  pd))++    isDeclaredIn pn (Exp (HsLet decls e))        +           =fromMaybe False (do (df,dd)<- hsFreeAndDeclaredPNs decls+                                Just (elem pn dd))+        +    isDeclaredIn pn _=False +                   ++instance HsDecls HsStmtP where+    hsDecls (HsLetStmt ds stmts)=ds+    hsDecls  _ = []+    +    replaceDecls (HsLetStmt ds stmts) ds'+     = if ds'/=[] then  HsLetStmt ds' stmts         +                  else stmts++    isDeclaredIn pn (HsGenerator _ pat exp stmts) -- Claus+        =fromMaybe False (do (pf,pd) <-hsFreeAndDeclaredPNs pat+                             Just (elem pn pd))++    isDeclaredIn pn (HsLetStmt decls stmts)+        =fromMaybe False (do (df,dd) <-hsFreeAndDeclaredPNs decls+                             Just (elem pn dd))++    isDeclaredIn pn _=False++instance HsDecls HsAltP where+    hsDecls (HsAlt _ p rhs ds)=ds++    replaceDecls (HsAlt loc p rhs ds) ds'=HsAlt loc p rhs ds'++    isDeclaredIn pn (HsAlt _ pat exp decls)+       =fromMaybe False ( do (pf,pd) <- hsFreeAndDeclaredPNs pat+                             (df,dd) <- hsFreeAndDeclaredPNs decls+                             Just (elem pn (pd `union` dd)))+    ++-------------------------------------------------------------------------------------------+class (Term a)=>FindEntity a where+  -- | Returns True is a syntax phrase, say a, is part of another syntax phrase, say b.+  findEntity:: (Term b)=> a->b->Bool++instance FindEntity HsDeclP where+  findEntity d b+   = (fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inDec)) b)+    where+     inDec (d1::HsDeclP)+      | d == d1 = Just True+     inDec _ = Nothing++instance FindEntity HsExpP  where++  findEntity e b+    =(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inExp)) b)+     where+       inExp (e1::HsExpP)+         | e==e1 =Just True+       inExp _ =Nothing++instance FindEntity HsStmtP  where++  findEntity s b+    =(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inStmt)) b)+     where+       inStmt (s1::HsStmtP)+         | s==s1 =Just True+       inStmt _ =Nothing++instance FindEntity PName  where++  findEntity pn b   +   =(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` worker)) b)+     where +        worker (PNT pname _ _ ) +           |pname==pn= Just True+        worker _ =Nothing ++instance FindEntity PNT where++  findEntity pnt b+   =(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` worker)) b)+      where +        worker (pnt1::PNT)+           |sameOccurrence pnt pnt1 = Just True++        worker _ =Nothing ++     +-------------------------------------------------------------------------------------------+class (Term a)=>FindEntityWithLocation a where+  -- | Returns True is a syntax phrase, say a, is part of another syntax phrase, say b.+  findEntityWithLocation:: (Term b)=> a->b->Bool++instance FindEntityWithLocation HsExpP  where++  findEntityWithLocation e b+    =(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inExp)) b)+     where+       inExp (e1::HsExpP)+         | e==e1 && srcLocs e == srcLocs e1 =Just True+       inExp _ =Nothing++instance FindEntityWithLocation HsStmtP where+  findEntityWithLocation e b+    = (fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inStmt)) b)+        where+          inStmt (s1::HsStmtP)+            | e == s1 && srcLocs e == srcLocs s1 = Just True+          inStmt _ = Nothing++instance FindEntityWithLocation PName  where++  findEntityWithLocation pn b   +   =(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` worker)) b)+     where +        worker (PNT pname _ _ ) +           |pname==pn= Just True+        worker _ =Nothing ++instance FindEntityWithLocation PNT where++  findEntityWithLocation pnt b+   =(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` worker)) b)+      where +        worker (pnt1::PNT)+           |sameOccurrence pnt pnt1 = Just True++        worker _ =Nothing ++     ++----------------------------------------------------------------------------------------- ++-- Get the toks for a declaration, and adjust its offset to 0.   +getDeclAndToks pn incSig toks t+    = ghead "getDeclAndToks" $ applyTU (stop_tdTU (failTU `adhocTU` inDecls)) t+  where +    inDecls decls +      |snd (break (defines pn) decls) /=[] +      = return $ getDeclAndToks' pn incSig decls toks +    inDecls x = mzero +    +    getDeclAndToks' pn incSig decls toks  +     = let typeSig = if (not incSig)+                      then Nothing+                      else let (decls1,decls2) =break (definesTypeSig pn) decls+                           in if decls2==[] then Nothing else Just (ghead "getDeclAndToks" decls2) +           (decls1', decls2') = break (defines pn) decls+           decl = if decls2' == [] then error "getDeclAndToks:: declaration does not exisit"+                                   else ghead "getDeclAndToks2" decls2'+           offset = getOffset toks (fst (startEndLoc toks decl))+           declToks =removeOffset offset $ getToks' decl toks+           sigToks = case typeSig of +                       Nothing  -> []+                       Just (sig@(Dec (HsTypeSig _ [i] _ _)))-> removeOffset offset $ getToks' sig toks+                       Just (Dec (HsTypeSig loc is c ty))-> let sig' =(Dec (HsTypeSig loc0 [nameToPNT (pNtoName pn)] c ty))+                                                            in  tokenise (Pos 0 (-1111) 1) 0 True $ prettyprint sig'++"\n" +       in  (if isJust typeSig then [fromJust typeSig, decl] else [decl], (sigToks ++ declToks))+       +    getToks' decl toks+      = let (startPos, endPos) = startEndLocIncComments toks decl+            (toks1, _) =let(ts1, (t:ts2'))= break (\t -> tokenPos t == endPos) toks+                        in (ts1++[t], ts2')+        in dropWhile (\t -> tokenPos t /= startPos || isNewLn t) toks1++    removeOffset offset toks +     = let groupedToks = groupTokensByLine toks+       in  concatMap  (doRmWhites offset) groupedToks++              +{-+-- THIS FUNCTION SHOULD NOT BE IN THE API.+-- | Get the list of tokens which represent the declaration that defines pn.+getDeclToks :: PName           -- ^ The identifier. +              -> Bool          -- ^ True means type signature should be included.+              -> [HsDeclP]     -- ^ The declaration list in which the identifier is defined.+              -> [PosToken]    -- ^ The input token stream.+              -> [PosToken]    -- ^ The result.+-}+---  IMPORTANT: GET RID OF THE -1111*****************+getDeclToks pn incSig decls toks +  = let (decls1,decls2) =break (definesTypeSig pn) decls+        typeSig = if decls2==[] then Nothing else Just (ghead "getDeclToks1" decls2) --There may or may not type signature.+        (decls1', decls2') = break (defines pn) decls+        decl = if decls2' == [] then error "getDeclToks:: declaration does not exisit"+                                else ghead "getDeclToks2" decls2'+        declToks = getToks' decl toks+        sigToks +         = case typeSig of +            Nothing  -> []+            Just (sig@(Dec (HsTypeSig _ [i] _ _)))-> getToks' sig toks+            Just (Dec (HsTypeSig loc is c ty))-> let sig' =(Dec (HsTypeSig loc0 [nameToPNT (pNtoName pn)] c ty))+                                                 in  tokenise (Pos 0 (-1111) 1) 0 True $ prettyprint sig'++"\n"   +    in if incSig then sigToks ++ declToks  else declToks +   where   +     getToks' decl toks+          = let (startPos, endPos) = startEndLocIncComments toks decl+                (toks1, _) =let(ts1, (t:ts2'))= break (\t -> tokenPos t == endPos) toks+                            in (ts1++[t], ts2')+            in dropWhile (\t -> tokenPos t /= startPos || isNewLn t) toks1+++inRegion t toks beginPos endPos +  =let (sLoc', eLoc')={-getStartEndLoc-} startEndLoc  toks t+       (sLoc,eLoc)=extendBothSides  toks sLoc' eLoc' isWhite isWhite+   in beginPos>=sLoc && beginPos<=eLoc +++applyRefac refac Nothing fileName+  = do (inscps, exps, mod, toks)<-parseSourceFile fileName+       (mod',((toks',m),_))<-runStateT (refac (inscps, exps, mod)) ((toks,False), (-1000,0)) +       return ((fileName,m),(toks',mod'))++applyRefac refac (Just (inscps, exps, mod, toks)) fileName+  = do (mod',((toks',m),_))<-runStateT (refac (inscps, exps, mod)) ((toks,False), (-1000,0)) +       return ((fileName,m),(toks', mod'))  +                                    +applyRefacToClientMods refac fileName+   = do clients <- clientModsAndFiles =<< fileNameToModName fileName+        mapM (applyRefac refac Nothing) (map snd clients)++++{-+--this function try to find an identifier through a textual interface. More details will be added.+findPNByPath::String->HsModuleP->Either String PName+findPNByPath path mod +  = case  findDeclByPath path mod of+      Left errMsg -> Left errMsg+      Right decl  -> Right $ head $ definedPNs decl +  where     +    findDeclByPath path mod+      = let names = extractPath path+        in findPNByPath' names (hsModDecls mod)+    +    extractPath path = extractPath' [] path+    extractPath' r path =+      case span (/='.') path of+            (name, "")      -> r++[name]+            (name, subPath) -> extractPath' (r++[name]) (tail subPath) ++    findPNByPath' (name:names) [] = Left "Can not find the declaration"+    findPNByPath' (name:names) decls+      = let decl = findDeclByName name decls+        in if decl==[] then Left "Can not find the declaration"+                       else if names==[] then Right (head decl)+                                         else findPNByPath' names (hsDecls (head decl))    +    findDeclByName name decls = filter definesName decls+     where+       definesName (Dec (HsFunBind _ ((HsMatch _ (PNT pn _ _) _ _ _):_)))+          = pNtoName pn == name+       definesName (Dec (HsPatBind _ p _ _)) = name == (pNtoName.head.hsPNs) p +       definesName  _ = False+-}+++-- checkTypes takes a string representation of a type, and the name of a pattern match or function +-- checkTypes calls the ghc typechecker, and returns True if the data type appears within the+-- type of the function.+-- checkTypes also removes the return type of the fuction/pattern as we are only interested in+-- the type of the arguments.+-- checkTypes :: String -> String -> Bool+checkTypes dat name modName fileName = or (map (ordSubset dat) (tails (ghcTypeCheck1 name modName fileName)))+++getTypes expr modName fileName =  lines2 (ghcTypeCheck1 expr modName fileName)++cleanTypes types = map (reverse. removeGHCBracket . removeGHC . reverse) types++getContext x = (res1, res2)+                 where+                  res1 = reverse $ {-removeBracket $ removeContextGHC $-} reverse con +                  res2 = head $ cleanTypes [last (createContext x)]+                  con +                    | length (createContext x) == 1 = []+                    | otherwise = head (createContext x)++removeGHC [] = []+-- removeGHC (']':xs) = ']' : ((removeGHC xs) ++ "[" )+removeGHC (x:xs)+ | x == '.'  = removeGHC xs2+ | otherwise = x : (removeGHC xs)+    where+      (_, xs2) = break (\x -> x==' ' || x == '[' || x == '(') xs+    +removeContextGHC [] = []+removeContextGHC (']':xs) = ']' : ((removeContextGHC xs) ++ "[" )+removeContextGHC (x:xs)+ | x == '.'  = []+ | otherwise = x : (removeContextGHC xs)++ + +removeBracket [] = []+removeBracket (')':'(':xs) = ")(" ++ (removeBracket xs)+removeBracket (x:xs)+ | x == '(' = xs+ | otherwise = x : (removeBracket xs)++removeGHCBracket [] = []+removeGHCBracket (')':'(':xs) = ")(" ++ (removeBracket xs)+removeGHCBracket (x:xs)+ | x == ')' = (x : xs)+ | otherwise = x : (removeBracket xs)+++-- checkTypes2 is the same as checkTypes, the only difference is that it returns +-- which argument (the arity) is of the type in question.+-- currently it returns the number of the first argument of the type in question.+checkTypes2 dat name modName fileName+ | res /= []  = (True, res2)+ | otherwise  = (False, []) +   where+     res = findArity (lines2 (ghcTypeCheck1 name modName fileName)) dat+     (res2, _) = splitAt (length res -1) res+     +checkTypesInPat dat pats modName fileName+ = (False, (res (convertPats pats)))+    where+      res [] = [([],"")]+      res (x:xs)+       | x == "NULL" = ([0],"") : (res xs)+       | otherwise   = ((init (findArity (lines2 (ghcTypeCheck1 x modName fileName)) dat) ), x) : (res xs)+       +      convertPats [] = []+      convertPats ((Pat (HsPParen (Pat (HsPApp i _)))):xs) = (pNtoName (pNTtoPN i)) : convertPats xs+   --   convertPats ((HsPApp (HsCon i) [p]):xs) =  (pNtoName (pNTtoPN i)) : convertPats xs+      convertPats (x:xs) = "NULL" : convertPats xs+     +     +findArity :: Eq a => [[a]] -> [a] -> [Int]+findArity [] _ = []+findArity (x:xs) p + | or (map (ordSubset p) (tails x)) = 1 : (findArity xs p)+ | otherwise = 0 : (findArity xs p)+ +--lines2 :: Eq a => [a] -> [[a]]++createContext [] = []+createContext (x:xs) +  = l : ls+   where+     (l, xs')   = break (== '=') (x:xs)+     (l2, xs'') = break (== '>') xs'+     ls+       | xs'' == [] = []+       | otherwise = createContext (tail xs'')++lines2 [] = []+lines2 (x:xs)+  = l : ls+  where+  (l, xs') = break (== '-') (x:xs)+  (l2,xs'') = break (=='>') xs'+  ls+    | xs'' == [] = []+    | otherwise = lines2 (tail xs'')+++getDataName :: Term t => t -> String+getDataName t+ = fromMaybe ""+    (applyTU (once_tdTU (failTU `adhocTU` inData)) t)+    where+     inData ((HsTyCon (PNT (PN (UnQual x)_) _ _)) :: TI PNT HsTypeP)+       = Just x+     inData _ = mzero  +     +ordSubset :: Eq a => [a] -> [a] -> Bool+ordSubset [] _ = True+ordSubset _ [] = False+ordSubset (x:xs) (y:ys)+  | x == y = True && (ordSubset xs ys)+  | x /= y = False && (ordSubset (x:xs) ys)+  | otherwise = False++++{-|+createFuncFromPat takes the function name and a list of expressions to be+used in the call. createFunc then creates a function application+based on the expressions in the second argument.+-}+createFuncFromPat :: PNT -> [HsExpP] -> HsExpP+createFuncFromPat _ [] = defaultExp+createFuncFromPat pat [exp]+  = (Exp (HsApp (Exp (HsId (HsCon pat))) exp))+createFuncFromPat pat (exp:exps)+  = createFunc' (Exp (HsId (HsCon (pat)))) (exp:exps)+ +createDataFunc :: PNT -> [HsTypeP] -> HsTypeP+createDataFunc pat [] = (Typ (HsTyCon pat))+createDataFunc pat [typ]+  = (Typ (HsTyApp (Typ (HsTyCon pat)) typ))+createDataFunc pat (typ:typs)+  = createTypFunc' (Typ (HsTyCon pat)) (typ:typs)  + +{-|+createTypFun takes the data type name and a list of types to be+used in the declaration. createTypFunc then creates a data type application+based on the types in the second argument.+-}+createTypFunc :: PNT -> [HsTypeP] -> HsTypeP+createTypFunc _ [] = defaultTyp+createTypFunc pat [typ]+  = (Typ (HsTyApp (Typ (HsTyCon pat)) typ))+createTypFunc pat (typ:typs)+  = createTypFunc' (Typ (HsTyCon pat)) (typ:typs)  +  +-- | createFunc' is used by createFunc to build up a function application+createTypFunc' :: HsTypeP -> [HsTypeP] -> HsTypeP+createTypFunc' typ [x]+  = (Typ (HsTyApp typ x))+createTypFunc' typ (x:xs)+  = (createTypFunc' (Typ (HsTyApp (typ) x)) xs)+  +{-|+createFunc takes the function name and a list of expressions to be+used in the call. createFunc then creates a function application+based on the expressions in the second argument.+-}+createFunc :: PNT -> [HsExpP] -> HsExpP+createFunc n [] = (Exp (HsId (HsVar n)))+createFunc pat [exp]+  = (Exp (HsApp (Exp (HsId (HsVar pat))) exp))+createFunc pat (exp:exps)+  = createFunc' (Exp (HsId (HsVar (pat)))) (exp:exps)++-- | createFunc' is used by createFunc to build up a function application+createFunc' :: HsExpP -> [HsExpP] -> HsExpP+createFunc' exp [x]+  = (Exp (HsApp exp x))+createFunc' exp (x:xs)+  = (createFunc' (Exp (HsApp (exp) x)) xs)+  ++-- | call the GHC typechecker to return a typed String  +getSig fileName modName name + = do+      let types = getTypes name modName fileName         +      -- error $ show types+      let types1 = cleanTypes (tail types)++      -- error $ show types1++      let (context, l) = getContext (head types)+      let types2 = l : types1+   --   let context2 = init context+      let types3 = map (filter (/= '\n')) types2+      let newSig = createTypeSig name context types3+     -- error $ show newSig+      return newSig+ +getSigAsString fileName modName name +  = do+      let types = getTypes name modName fileName      +      -- error $ show types+      let types1 = cleanTypes (tail types)++      -- error $ show types1++      let (context, l) = getContext (head types)+      let types2 = l : types1+   --   let context2 = init context+      let types3 = map (filter (/= '\n')) types2+      let types4 = fold (tail types3)+      +      return (context ++ " => " ++ (head types3) ++ " -> " ++ types4) +        where +         fold [] = []+         fold [x] = x+         fold  (x:xs) = x ++ (" -> " ++ fold xs) +      +      +getSigOmitLast modName name fileName+ = do+      let types = getTypes name modName fileName           +      -- error $ show types+      let types1 = cleanTypes (tail types)++      -- error $ show types1++      let (context, l) = getContext (head types)+      let types2 = l : types1+   --   let context2 = init context+      let types3 = map (filter (/= '\n')) types2+      let newSig = createTypeSig name context (init types3)+     -- error $ show newSig+      return newSig+      +-- | createTypeSig :: String -> [String] -> [String] -> HsDeclP+createTypeSig name [] types + = Dec (HsTypeSig loc0 [nameToPNT name] [] (createApplication types)) +createTypeSig name context types  + = Dec (HsTypeSig loc0 [nameToPNT name] [(Typ (HsTyVar (nameToPNT context)))] (createApplication types))+ ++createApplication [var]+ = (Typ (HsTyVar (nameToTypePNT var)))+createApplication (v:vars)+ = Typ (HsTyVar (nameToTypePNT (v ++ (concatMap (" -> "++) vars))))+    where+     myConcat :: [ String ] -> String+     myConcat [] = []+     myConcat (x:xs) = (x ++ " -> ") ++ (myConcat xs)+ + +createApplication' x [y]+  = (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y)))))+createApplication' x (y:ys)+  = (createApplication' (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y))))) ys)+       +findType pnt t+  = applyTU (stop_tdTU (failTU `adhocTU` inSig)) t+      where+        inSig (dec@(Dec (HsTypeSig _ _ _ _))::HsDeclP)+          = do+               let res = definesTypeSig (pNTtoPN pnt) dec+               if res == True+                  then return [True]+                  else fail ""+          +        inSig _ = fail "" +        ++nameToTypePNT :: String -> PNT +nameToTypePNT id = (PNT (PN (UnQual id) (S loc0)) (Type (TypeInfo {defType = Nothing, constructors = [], fields = []})) (N (Just loc0)))+
+ refactorer/RefacWhereLet.hs view
@@ -0,0 +1,199 @@+++module RefacWhereLet(whereToLet) where++import PrettyPrint+import PosSyntax+import AbstractIO+import Maybe+import TypedIds+import UniqueNames hiding (srcLoc)+import PNT+import TiPNT+import List+import RefacUtils hiding (getParams)+import PFE0 (findFile)+import MUtils (( # ))+import RefacLocUtils+import System+import IO++{- This refactoring converts a where into a let. Could potentially narrow the scrope of those involved bindings.+   +   Copyright   :  (c) Christopher Brown 2008++   Maintainer  :  cmb21@kent.ac.uk+   Stability   :  provisional+   Portability :  portable   +   +-}++whereToLet args+ = do let fileName = ghead "filename" args +          --fileName'= moduleName fileName+          --modName  = Module fileName'  +          row      = read (args!!1)::Int+          col      = read (args!!2)::Int+      modName <-fileNameToModName fileName++      (inscps, exps, mod, tokList)<-parseSourceFile fileName +      let pnt = locToPNT fileName (row, col) mod +      if not (checkInFun pnt mod)+        then error "Please select a definition within a where clause!"+        else do+              if (pnt /= defaultPNT)+               then do+                ((_,m), (newToks, newMod))<-applyRefac (doWhereToLet pnt) +                                                       (Just (inscps, exps, mod, tokList)) fileName+                writeRefactoredFiles False [((fileName,m), (newToks,newMod))]+                AbstractIO.putStrLn "Completed.\n"+               else error "\nInvalid cursor position!"+  +doWhereToLet pnt (_,_,t)+ = do  +      mod <- convertToWhere pnt t+      return mod+      ++convertToWhere pnt t+  = applyTP (full_tdTP (idTP `adhocTP` conInMatch+                             `adhocTP` conInPat+                             `adhocTP` conInAlt+                              )) t+      where+      +        conInMatch (match@(HsMatch loc name pats (HsBody e) ds)::HsMatchP)+         | canBeConverted ds pnt+             = do             +                  let decl = definingDecls [pNTtoPN pnt] ds True True+                  let updateRHS = (Exp (HsLet decl e))+                  ds' <- rmDecl (pNTtoPN pnt) True ds+                  -- we need to check that nothing else in the where+                  -- clause depends on this entity...+                  +                  allDecs <- mapM hsFreeAndDeclaredPNs ds'+                  if (declToPName2 $ ghead "conInMatch" decl) `elem` (concat (map fst allDecs))+                    then error "Entity cannot be converted as another declaration in the where clause depends on it!"+                    else do e' <- update e updateRHS e+                            return (HsMatch loc name pats (HsBody e') ds')+                  +        conInMatch (match@(HsMatch loc name pats g@(HsGuard e) ds)::HsMatchP)+         | canBeConverted ds pnt+             = do let decl = definingDecls [pNTtoPN pnt] ds True True+                  let updateRHS = (HsBody (Exp (HsLet decl (rmGuard g))))+                  ds' <- rmDecl (pNTtoPN pnt) True ds+                  allDecs <- mapM hsFreeAndDeclaredPNs ds'+                  if (declToPName2 $ ghead "conInMatch Guard" decl) `elem` (concat (map fst allDecs))+                    then error "Entity cannot be converted as another declaration in the where clause depends on it!"+                    else do e' <- update g updateRHS g+                            return (HsMatch loc name pats e' ds')++                 +        conInMatch x = return x +        +        conInPat (pat@(Dec (HsPatBind loc p (HsBody e) ds))::HsDeclP)+         | canBeConverted ds pnt+             = do             +                  let decl = definingDecls [pNTtoPN pnt] ds True True+                  let updateRHS = (Exp (HsLet decl e))+                  ds' <- rmDecl (pNTtoPN pnt) True ds+                  allDecs <- mapM hsFreeAndDeclaredPNs ds'+                  if (declToPName2 $ ghead "conInPat" decl) `elem` (concat (map fst allDecs))+                    then error "Entity cannot be converted as another declaration in the where clause depends on it!"+                    else do e' <- update e updateRHS e+                            return (Dec (HsPatBind loc p (HsBody e') ds'))++                  +        conInPat (pat@(Dec (HsPatBind loc p g@(HsGuard e) ds))::HsDeclP)+         | canBeConverted ds pnt+             = do let decl = definingDecls [pNTtoPN pnt] ds True True+                  let updateRHS = (HsBody (Exp (HsLet decl (rmGuard g))))+                  ds' <- rmDecl (pNTtoPN pnt) True ds+                  allDecs <- mapM hsFreeAndDeclaredPNs ds'                  +                  if (declToPName2 $ ghead "conInPat" decl) `elem` (concat (map fst allDecs))+                    then error "Entity cannot be converted as another declaration in the where clause depends on it!"+                    else do e' <- update g updateRHS g+                            return (Dec (HsPatBind loc p e' ds'))+++        conInPat x = return x+        +        +        conInAlt (alt@(HsAlt loc p (HsBody e) ds)::HsAltP)+         | canBeConverted ds pnt+            = do  let decl = definingDecls [pNTtoPN pnt] ds True True+                  let updateRHS = (Exp (HsLet decl e))+                  ds' <- rmDecl (pNTtoPN pnt) True ds+                  e' <- update e updateRHS e+                  return (HsAlt loc p (HsBody e') ds')+                  +        conInAlt (alt@(HsAlt loc p g@(HsGuard e) ds)::HsAltP)+         | canBeConverted ds pnt+             = do let decl = definingDecls [pNTtoPN pnt] ds True True+                  let updateRHS = (HsBody (Exp (HsLet decl (rmGuard g))))+                  ds' <- rmDecl (pNTtoPN pnt) True ds+                  e' <- updateGuardAlt g updateRHS g+                  return (HsAlt loc p e' ds')+       +        conInAlt x = return x+        +        updateGuardAlt oldRhs newRhs t+            = applyTP (once_tdTP (failTP `adhocTP` inRhs)) t+            where+              inRhs (r::RhsP)+               | r == oldRhs && srcLocs r == srcLocs oldRhs+                   = do (newRhs',_) <- updateToks oldRhs newRhs prettyprintGuardsAlt+                        return newRhs'+              inRhs r = mzero+        +        +        rmGuard ((HsGuard gs)::RhsP)+             = let (_,e1,e2)=glast "guardToIfThenElse" gs+               in  if ((pNtoName.expToPN) e1)=="otherwise" +                   then (foldl mkIfThenElse e2 (tail(reverse gs)))+                   else (foldl mkIfThenElse defaultElse (reverse gs)) +           +        mkIfThenElse e (_,e1, e2)=(Exp (HsIf e1 e2 e)) ++        defaultElse=(Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "error") (G (PlainModule "Prelude") "error" +                    (N (Just loc0)))) Value (N (Just loc0)))))) (Exp (HsLit loc0 (HsString "UnMatched Pattern")))))+                    +        +        canBeConverted :: [HsDeclP] -> PNT -> Bool+        canBeConverted ds pnt+          = pnt `elem` map declToPNT ds+++checkInFun :: Term t =>  PNT -> t -> Bool+                     +checkInFun pnt t+  = checkInMatch pnt t || checkInPat pnt t || checkInAlt pnt t+  +  where+   checkInAlt pnt t+     = fromMaybe (False)+                 (applyTU (once_tdTU (failTU `adhocTU` inAlt)) t)+  +   checkInPat pnt t+     = fromMaybe (False)+                 (applyTU (once_tdTU (failTU `adhocTU` inPat)) t)+  +   checkInMatch pnt t+      = fromMaybe (False)+              (applyTU (once_tdTU (failTU `adhocTU` inMatch)) t)+    +   inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)+      | findPNT pnt ds = Just True+   inAlt _ = Nothing++   --The selected sub-expression is in the rhs of a match+   inMatch (match@(HsMatch loc1  _ pats rhs ds)::HsMatchP)+    | findPNT pnt ds+          = Just True+   inMatch _ = Nothing++   --The selected sub-expression is in the rhs of a pattern-binding+   inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)+     | findPNT pnt ds+          = Just True+   inPat _ = Nothing
+ refactorer/SlicingUtils.hs view
@@ -0,0 +1,136 @@+module SlicingUtils where++import AbstractIO+import Maybe+import List+import RefacUtils+import RefacRedunDec+++checkCase (Exp(HsInfixApp e11 o e22 )) high wh+  | findEntity high e11 = do+                             (e, wh) <- checkCase e11 high wh+                             return (e, wh)+  | findEntity high e22 = do+                             (e, wh) <- checkCase e22 high wh+                             return (e,wh)++checkCase (Exp(HsParen e)) high wh +                = do +                     res <- checkCase e high wh+                     return res+checkCase (Exp(HsCase e alts)) high wh+                = do+                     newWhere <- checkAlts alts+                     return (high, (newWhere++wh))+                        where+                           checkAlts [] = do+                                             return []+                           checkAlts ((HsAlt _ _ _ ds):xs) +                              = do+                                   decls <- removeRedunWhere ds high+                                   res <- checkAlts xs+                                   return (decls ++ res)++checkCase (exp@e) high wh  = do+                              decls <- removeRedunWhere wh e+                              return (exp, decls)+++checkIfOrLet (Exp(HsParen e)) newExp tokList start end+                = do+                     res <- checkIfOrLet e newExp tokList start end+                     return (Exp(HsParen res))++checkIfOrLet (Exp(HsIf e1 e2 e3)) newExp tokList start end+                = do+                     let expRes = findExpInIf tokList+                                              start+                                              end+                                              e2+                     if expRes == defaultExp+                         then do+                                 let expRes' = findExpInIf tokList+                                                           start+                                                           end+                                                           e3+                                 if expRes' == defaultExp +                                      then return (Exp(HsIf e1 e2 e3)) +                                      else return (newExp)+                         else return (newExp)+checkIfOrLet (Exp(HsLet ds e)) newExp _ _ _ +                = do+                     return (Exp(HsLet ds newExp))++checkIfOrLet (exp@_) newExp _ _ _ = do+                               return newExp+-- check whether the identifiers within the highlighted subexpression are +-- used within the let statement - if they are then return the statement+checkLetAndLambda begin end tokList wh high exp+  = applyTU (full_tdTU (constTU [] `adhocTU` inLet)) exp+     where+           inLet (ex@(Exp(HsLet ds e))::HsExpP)+               = do +                    let newExp = (Exp(HsLet ds high))+                    (decls, x) <- removeRedun wh newExp+                    res <- inLet e+                    if res == [defaultExp] then do+                                             return [x]+                                           else do+                                             let exp' = ammendDecs res x+                                             return [exp']+                                                where+                                                  ammendDecs ((Exp(HsLet ds e)):xs) ((Exp(HsLet decls e2))) +                                                                 = (Exp(HsLet (decls++ds) e))+                                                  ammendDecs _ _ = defaultExp++           inLet (Exp(HsParen e)) = do res <- inLet e +                                       return res+           inLet (Exp(HsInfixApp e1 _ e2)) = do+                                           res <- inLet e1+                                           if res == [defaultExp]+                                               then do+                                                  res' <- inLet e2+                                                  return res'+                                               else do+                                                  return res+           inLet (Exp(HsApp e1 e2)) = do+                                        res <- inLet e1+                                        if res == [defaultExp]+                                           then do+                                             res' <- inLet e2+                                             return res'+                                           else do+                                             return res+           inLet (Exp(HsCase e alts))+                = do +                     return [(Exp(HsCase high alts))]++           inLet (exp@(Exp(HsDo _)))+               = do+                    if (locToExp begin end tokList exp) /= defaultExp+                       then do+                         error "Cannot perform a slicing on a monad"+                       else do return [exp] ++           inLet (exp@(Exp(HsListComp _))) = do+                                              if (locToExp begin end tokList exp) /= defaultExp+                                                then do+                                                  error "Cannot perform slicing with List Comprehension"+                                                else do return [defaultExp]++           inLet (_::HsExpP) = do+                                return [defaultExp]+                    ++findExpInIf toks beginPos endPos t+  = fromMaybe (defaultExp)+              (applyTU (once_tdTU (failTU `adhocTU` inExp)) t)+        where+          inExp (exp@(_)::HsExpP)+           | locToExp beginPos endPos toks exp /= defaultExp+              = Just (exp)+          inExp _ = Nothing+          ++
+ refactorer/TypeCheck.hs view
@@ -0,0 +1,139 @@+module TypeCheck where++import System+import Unsafe.Coerce+import Control.Exception+import System.IO.Unsafe+import System.IO+import List+--import PackageConfig    ( stringToPackageId )+import GHC hiding (SrcLoc)+import DynFlags (defaultDynFlags)+import HsSyn+import Outputable+import SrcLoc+--import AbstractIO+import Control.Monad+import Language.Haskell.Interpreter hiding (runGhc)++import LocalSettings++libdir = "/Library/Frameworks/GHC.framework/Versions/612/usr/lib/ghc-6.12.1"+targetFile = "/Users/chrisbrown/hare/tests/A1.hs"++ghcTypeCheck1 expr modName fileName =+  unsafePerformIO(+   do+      putStrLn "ghcTypeCheck1"+      putStrLn expr+      putStrLn modName+      putStrLn fileName+      r <- runInterpreter (testHint expr modName fileName)+      case r of +         Left err -> do printInterpreterError err+                        return ""+         Right e -> return e+   )+   +-- observe that Interpreter () is an alias for InterpreterT IO ()+testHint :: String -> String -> String -> InterpreterT IO String+testHint expr modName fileName =+    do+      -- say "Load SomeModule.hs"+      loadModules [fileName]+      --+      --say "Put the Prelude, Data.Map and *SomeModule in scope"+      --say "Data.Map is qualified as M!"+      setTopLevelModules [modName]+      setImportsQ [("Prelude", Nothing)]+      --+      say "Now we can query the type of an expression"+      let expr1 = modName ++ "." ++ expr+      say $ "e.g. typeOf " ++ expr1+      say =<< typeOf expr1+      return =<< typeOf expr1+++say :: String -> Interpreter ()+say = liftIO . putStrLn++printInterpreterError :: InterpreterError -> IO ()+printInterpreterError e = error $ "Ups... " ++ (show e)+++ghcTypeCheckPattern closure closure_name modName fileName =+  unsafePerformIO(+   do+      r <- runInterpreter (testPattern closure closure_name modName fileName)+      case r of +         Left err -> do printInterpreterError err+                        return ""+         Right e -> return e+   )  +  +testPattern :: String -> String -> String -> String -> InterpreterT IO String+testPattern closure closure_name modName fileName =+    do+      say fileName+      say modName+      -- say "Load SomeModule.hs"+      --+      --say "Put the Prelude, Data.Map and *SomeModule in scope"+      --say "Data.Map is qualified as M!"+      set [languageExtensions := [ExistentialQuantification, ScopedTypeVariables]]+      loadModules [fileName]+      setTopLevelModules [modName]+      setImportsQ [("Prelude", Nothing)]+      --+      say "Now we can query the type of an expression"+      let expr1 = closure+      say closure+      say closure_name+      say $ "e.g. typeOf " ++ expr1+      say =<< typeOf expr1+      -- say =<< typeOf closure_name+      return =<< typeOf expr1++debugLog :: String -> b -> b+debugLog msg b =+  unsafePerformIO (+    do+      putErrStrLn msg+      return b+    )++logAndDump :: (Outputable a) => String -> a -> b -> b+logAndDump msg a b =+  unsafePerformIO (+    do+      putErrStrLn msg+      putErrStrLn $ showSDoc (ppr a)+      return b+    )++tidyFileName :: String -> String+tidyFileName ('.':'/':str) = str+tidyFileName str           = str++data Tag = Tag TagName TagFile TagLine TagDesc+  deriving (Eq)++instance Ord Tag where+  compare (Tag t1 _ _ _) (Tag t2 _ _ _) = compare t1 t2++instance Show Tag where+  show (Tag t f l d) = makeTagsLine t f l d++type TagName = String+type TagFile = String+type TagLine = Int+type TagDesc = String++makeTagsLine :: String -> String -> Int -> String -> String+makeTagsLine tag file line desc = tag `sep` file `sep` (show line) `sep` ";\t\"" ++ desc ++ "\""+  where a `sep` b = a ++ '\t':b+++putErrStrLn = hPutStrLn stderr+putErrStr = hPutStr stderr+ 
+ refactorer/log.txt view
@@ -0,0 +1,1 @@+Linking evaluate ...
+ refactorer/pfe.hs view
@@ -0,0 +1,48 @@++--import System(getArgs)+import PPU(getPPopts)++import HsParser(parse)+import HsLexerPass1(lexerPass0)+--import DefinedNamesBase()+import FreeNamesBase()+import ScopeNamesBase()+import NameMapsBase()+import ReAssocBase()+import RemoveListCompBase()+import SimpPatMatchBase()++import TiDecorate(TiDecls) -- to choose result type from the type checker+import HsModule+import qualified IO+import Pfe0Cmds(addHelpCmd)+import Pfe4Cmds(pfe4Cmds)+import PFE4(PFE4Info)+import Pfe3Metrics(pfe3MetricsCmds)+import PFEdeps(clean5)+import PfeHtmlCmds(pfeHtmlCmds)+import PfeChase(pfeChaseCmds)+import PfeTransformCmds(pfeTransformCmds)+import PfeDepCmds(runPFE5Cmds,pfeDepCmds)+import PfeCleanCmd(pfeCleanCmd)+-- import PfeInteractive(pfeiAllCmds,runSIO)+import MapDeclMBase() -- for removing pattern bindings in PfeTransformCmds.+--import RemoveIrrefPatsBase()++import PfeRefactoringCmds(pfeRefactoringCmds) ++main = do+          IO.hSetBuffering IO.stdout IO.NoBuffering+          x <- getPPopts+          runPFE5Cmds () pfeCmds (lexerPass0,parse) x   +++-- main = runPFE5Cmds () pfeCmds (lexerPass0,parse) =<< getPPopts++pfeCmds = pfe4Cmds tcOutput++pfeTransformCmds+          ++pfeChaseCmds++pfeHtmlCmds++pfeDepCmds++pfeCleanCmd clean5+          ++pfeRefactoringCmds ++tcOutput = id :: I (PFE4Info i2 (TiDecls i2))+--tcOutput = id :: I [[HsModuleR]]+type I a = a->a
+ refactorer/pfe_client.hs view
@@ -0,0 +1,7 @@+
+-- a miniature client for a refactoring server
+module Main where
+
+import EditorCommands
+
+main = clientCmd

+ tools/HEADER.html view
@@ -0,0 +1,37 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!-- This file is included by the web server in the automatically generated+     directory index.+-->+<head>+<title>Programatica Tools</title>+<link rel=parent href="../" title="Programatica Docs and Sources">+<link rel=author href="http://www.cse.ogi.edu/~hallgren/" title="Thomas Hallgren">+<link rel=copyright href="LICENSE">+<link rel="alternate stylesheet" type="text/css" HREF="web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="web/src.css" title="Normal">+<link rel=icon type="image/gif" href="web/icon1.png">+</head>++<body>+<h1><img align=right src="web/icon1.png" alt="">Programatica Tools</h1>++<h2>Browsing the source</h2>++Some recent version of the source is available for browsing+via the links below. These files can be used freely under a BSD-like+license (see <a href="LICENSE">LICENSE</a> for details).++<p>+The directory index pages combine an automatically generated file index+and a manually written README file describing the contents of the directory.+The automatic index section reflects reality,+but may also contain files/directories that are obsolete.+The README section is more informative, but can at times be out-of-date.++<p>+There is also an <a href="pfe.cgi">HTML rendering of the+source code</a>, with syntax highlighting and hyperlinks from uses+to definitions.  (See the+<a href="http://www.cse.ogi.edu/~hallgren/h2h.html">notes on the+conversion tool</a>.)+
+ tools/HuMakefile view
@@ -0,0 +1,11 @@++PFE_DIR=pfe+BASE=base+HS2HTML_DIR=hs2html+STRATEGO=hs2stratego+PROP=property+HS2ALFA_DIR=hs2alfa++. $HS2ALFA_DIR/HuMakefile++SRC_DIRS=$APFE_DIRS:$BPARSE_DIRS
+ tools/INSTALL.html view
@@ -0,0 +1,96 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<head>+<title>Compiling and installing the Tools from the Programatica project</title>+<link rel=parent href="./" title="Programatica Tools">+<link rel=author href="http://www.cse.ogi.edu/~hallgren/" title="Thomas Hallgren">+<link rel=copyright href="LICENSE">+<link rel="alternate stylesheet" type="text/css" HREF="/~hallgren/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="/~hallgren/src.css" title="Normal">+<link rel=icon type="image/gif" href="web/icon1.png">+</head>++<body>+<h1><img align=right src="web/icon1.png" alt="">Compiling and installing+the Tools from the Programatica project</h1>+<h2>What you need to compile the tools</h2>++<div>+You need Linux (or SunOS or FreeBSD or Mac&nbsp;OS&nbsp;X or something similar)+(with the X&nbsp;Window system) and the following additional software and+tools:++<ul>+  <li><a href="http://www.haskell.org/ghc/">GHC</a> 5.02 or later.+  <li><a href="http://www.haskell.org/happy/">Happy</a> 1.11 or later.+  <li><a href="http://www.cse.ogi.edu/~hallgren/Programatica/download/alfaforpfe.tar.gz">alfaforpfe.tar.gz</a>, part of+      <a href="http://www.cs.chalmers.se/~hallgren/Alfa/">Alfa</a>, needed for+      the Haskell-to-Alfa translator. It should be untared in the+      <a href="hs2alfa/">hs2alfa</a> subdirectory.+  <li>For pfebrowser, you also need+      <ul>+      <li><a href="http://www.cs.chalmers.se/Fudgets/">Fudgets</a> and+      <a href="http://www.cs.chalmers.se/~hallgren/InternetLib/">InternetLib</a>     (get <a href="http://www.cse.ogi.edu/~hallgren/untested/">recent snapshots</a>),+      </ul>+</ul>++<p>+Regarding hardware requirements: we compile and test the tools under Linux on+machines ranging from a 800MHz P-III laptop with 256MB RAM to a 1.9GHZ+P4 servers with 2GB RAM.+(To limit the amount of memory used by GHC (and programs compiled with GHC),+you can set the environment variable <code>GHCRTS</code> to for example+<code>-M150M</code>.)+</div>+<h2>How to compile and install the tools</h2>+<div>++<p>+The following command sequence should work:+<ol>+<!--+<li><code class=code>./configure</code>+-->+<li><code class=code>make</code>+<li><code class=code>make install</code>+</ol>++This will compile all of the code with optimization (ghc -O).+You can replace the+<code class=code>make</code> step with <code class=code>make OPT=</code>+to turn off optimization. This will speed up compilation with a+factor of ~4, but slow down the resulting tools by a factor of ~2.++<p>+The <code>Makefile</code> in this directory has the following useful targets:++<dl>+<dt><code>all</code> (this is the default)+<dd>This compiles pfe and pfebrowser. It also creates the <code>bin/</code>+    and <code>lib/</code> subdirectories containing a template of the things+    that get installed by <code>make install</code>.+<dt><code>install</code>+<dd>This installs all the programs and library files.+    Use <code class=code>make PREFIX=...</code> to control where things get installed.+<dt><code>tar</code>+<dd>creates a tar file containing the programs and the library files, allowing+    easy installation of them on another computer.+<dt><code>clean</code>+<dd>removes (almost all) automatically generated files.+</dl>++</div>+<h3>Testing without installing</h3>+<div>+<p>+To test the tools without installing them first, add the+<code class=code>bin/</code> subdirectory to your <code class=code>$PATH</code>+and set <code class=code>$PROGRAMATICA</code> to point to the+<code class=code>lib/Programatica</code> subdirectory. (If you are using+(t)csh, do <code class=code>source scripts/setEnv.csh</code> from this+directory.)+<!--+<p>+Some additional test programs can be compiled by going+to one of the subdirectories running the command <code>make</code> there.+-->+</div>
+ tools/LICENSE view
@@ -0,0 +1,32 @@+Copyright (c) 2003, OGI School of Science & Engineering, Oregon+Health & Science University, All rights reserved.++Redistribution and use in source and binary forms, with or+without modification, are permitted provided that the following+conditions are met:++- Redistributions of source code must retain the above copyright+  notice, this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above+  copyright notice, this list of conditions and the following+  disclaimer in the documentation and/or other materials provided+  with the distribution.++- Neither the name of OGI or OHSU nor the names of its+  contributors may be used to endorse or promote products derived+  from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ tools/Makefile view
@@ -0,0 +1,94 @@++#PREFIX=/usr/local+PREFIX=/home/projects/pacsoft/tools+PROGRAMATICA=$(PREFIX)/lib/Programatica+PLOVER=../Plogic/Plover++#OPT=-O2+OPT=-O+#OPT=-O -prof -auto-all++SUBDIRS=evman hs2alfa pfe pfe/Browser          # for make all+ALLSUBDIRS=$(SUBDIRS) base property hs2html    # for make clean++ADJUST=scripts/adjustscript PROGRAMATICA $(PROGRAMATICA)++#SCRIPTS=bin/pfesetup bin/cert bin/pfebrowser++#MAKEFLAGS=-no-print-directory+################################################################################++all: config+	@for dir in $(SUBDIRS) ; do $(MAKE) -C $$dir OPT="$(OPT)" ; done+	@$(MAKE) template++## Make directories holding a template structure of things to install:+template:: bin lib+++install::+	rsync -aLHvC bin lib $(PREFIX)++tar::+	@$(MAKE) PREFIX=/usr/local template+	tar -czh --exclude CVS --exclude objs --exclude '*.hi' -f pfe-`date +%y%m%d`.tar.gz lib bin++bin::+	@echo Creating the bin directory+	@rm -rf bin && mkdir -p bin+	@cd bin; ln -s ../hs2alfa/apfe pfe+	@cd bin; ln -s ../pfe/pfeclient pfeclient+	@cd bin; if [ -x "../$(PLOVER)" ] ; then ln -s ../$(PLOVER) Plover ; fi+#	-[ -x hs2alfa/apfe ] && { cd bin; ln -s ../hs2alfa/apfe apfe; }+	@$(ADJUST) <pfe/pfesetup >bin/pfesetup+	@$(ADJUST) <evman/cert.sh >bin/cert+	@$(ADJUST) <pfe/Browser/pfebrowser.sh >bin/pfebrowser+	@chmod +x bin/pfesetup bin/cert bin/pfebrowser++L=lib/Programatica+C=types/certificate++lib::+	@echo Creating the lib directory+	@rm -rf lib+	@cd evman; $(MAKE) icons lib+	@mkdir -p $L/bin $L/libs $L/icons+	@ln LICENSE $L+	@cd $L/libs; ln -s ../../../base/tests/*Libraries .+#	@cd $L/libs/Monads; ln -s ../../../../base/lib/Monads/*.hs .+	@cd $L/icons; ln -s ../../../evman/icons/smiley.sad.gif .+	@cd $L/bin; ln -s ../../../pfe/Browser/pfebrowser .+++################################################################################++html:: config+	$(MAKE) hi/srclist.txt+	-[ -d hi/html ] && cd hi/html && gunzip *.gz+	pfe noplogic htmlfiles+	cd hi/html && gzip -9 *.html++hi/srclist.txt:+	@$(MAKE) -C property propparser+	@$(MAKE) -C pfe baseparser+	@sh scripts/updateNow.sh pfe/Now.hs+	TARGET=apfe pfesetup +h noplogic cpp pfe/pfe.hs pfe/pfeclient.hs property/ppfe.hs hs2alfa/apfe.hs+++################################################################################++config: scripts/hsmake.sh scripts/hsfudmake.sh pfe/Browser/InternetLib++scripts/hsmake.sh scripts/hsfudmake.sh pfe/Browser/InternetLib:+	./configure++unconfig:+	cd scripts && rm -f hsmake.sh hsfudmake.sh+	cd pfe/Browser && rm -f InternetLib++################################################################################++clean: unconfig+	rm -rf bin lib hi+	for dir in $(ALLSUBDIRS) ; do $(MAKE) -C $$dir clean ; done+	find . '(' -name '*.o' -o -name '*.hi' ')' -exec rm '{}' ';'
+ tools/Phugs/ASTCmds.hs view
@@ -0,0 +1,45 @@+module ASTCmds where+import Prelude hiding (print)++import Pfe0Cmds(moduleArg)+--import PFE2(analyzeModules',pfe2info0)+import PFE3(parseModule)+import HsModule(hsModDecls)++import AbstractIO+import MUtils((@@))+--import Front2AST+import Front2Stratego+import StrategoPretty()+--import Phugs++astCmds = [--("trans"   , moduleArg trans),+           --("phugs"   , moduleArg eval),+           ("prove"   , (moduleArg stratego,"translate to Stratego"))]+{-+trans ms =+    do info <- analyzeModules' pfe2info0 (Just ms)+       mapM_ (trans1 info) ms+  where+    trans1 info m = print.trM.snd=<<parseModule info m+++trM = map trD . hsModDecls+-}+---------------------------------------------------++stratego = (print.transM.snd) @@ parseModule++transM = transDecs . hsModDecls++---------------------------------------------------+{-+eval ms =+    do info <- analyzeModules' pfe2info0 (Just ms)+       mapM_ (trans1 info) ms+  where+    trans1 info m = print.phugs.translateM.snd=<<parseModule info m+++translateM = map translateD . hsModDecls+-}
+ tools/Phugs/Base2Stratego.hs view
@@ -0,0 +1,20 @@+{-++Knot-tying definitions for the base syntax to Stratego translation.+-}++module Base2Stratego where+import BaseStruct2Stratego(transP,transD,transE,showId)+import Syntax(HsPatI(..),HsDeclI(..),HsExpI(..)) -- recursive base syntax++--transPat :: HsPat -> P+transPat (Pat p) = transP showId transPat p++transDecs ds = map transDec ds++--transDec :: HsDecl -> D+transDec (Dec d) = transD showId transExp transPat transDecs bad bad bad d++--transExp :: HsExp -> E+transExp (Exp e) = transE showId transExp transPat transDecs bad bad e++bad x = error "Base2Stratego: not yet"
+ tools/Phugs/BaseStruct2Stratego.hs view
@@ -0,0 +1,66 @@+{-++Reusable functions for translation from the (non-recursive) base structure+to Stratego.+-}++module BaseStruct2Stratego where+import StrategoAST+import BaseSyntax hiding (EntSpec(..)) -- non-recursive base syntax structure+import PrettyPrint(pp)++transP trId trP p =+ case mapPI trId trP p of+   HsPId n -> Pvar (getHSName n) -- constructor vs variable ??+   HsPLit (HsInt _ i) -> Pconst i+   HsPInfixApp x op y -> Pcondata (getHSName op) [x,y] -- con vs var ??+   HsPApp n ps -> Pcondata n ps+   HsPTuple ps -> Ptuple ps+   HsPIrrPat p -> Ptilde p+   HsPParen p -> p+   _ -> error ("no "++pp p++" patterns yet")+++transD trId trE trP trDs trT trC trTp d =+ case mapDI trId trE trP trDs trT trC trTp d of+   HsPatBind loc p b ds -> Val p (transRhs b) ds+   HsFunBind loc matches -> Fun (name matches) (map g matches)+      where name (HsMatch loc nm ps rhs ds: ms) =  nm+            g (HsMatch loc nm ps rhs ds) = (ps,transRhs rhs,ds)+   other -> error ("illegal dec "++pp d)+      +--transRhs :: HsRhs E -> B+transRhs (HsBody e) = Normal e+transRhs (HsGuard triples) = Guarded(map f triples)+        where f (loc,guard,body) = (guard,body)++--transAlt :: HsAlt E P [D] -> (P,B,[D])+transAlt (HsAlt loc pat rhs ds) = (pat,transRhs rhs,ds)+++transE trId trE trP trDs trT trC e =+ case mapEI trId trE trP trDs trT trC e of +   HsId n                 -> Var (getHSName n) -- constructor vs variable ??+   HsApp x y              -> App x y+   HsLit (HsInt _ i)      -> Const i+   HsInfixApp x op z      -> App (App (Var (getHSName op)) x) z -- con vs var ??+   HsNegApp _ x           -> App (Var "negate") x  +   HsLambda ps e          -> Abs ps e+   HsLet ds e             -> Let ds e+   HsIf x y z             -> Cond x y z+   HsCase e alts          -> Case e (map transAlt alts)+   HsTuple xs             -> TupleExp xs+   HsList xs              -> foldr cons nil xs+      where cons x xs = ConApp ":" [(x,Lazy),(xs,Lazy)]+	    nil = ConApp "[]" []+   HsParen x              -> x+   HsLeftSection x op     -> Abs[Pvar "zzz"] (App (App (Var (getHSName op)) x) +                                             (Var "zzz"))+   HsRightSection op y    -> Abs[Pvar "zzz"] (App (App (Var (getHSName op)) +                                             (Var "zzz")) y)+   other -> error ("no translation yet for: "++pp e)+++--showId (HsVar x) = show x+--showId (HsCon x) = show x++showId x = pp x
+ tools/Phugs/Flags.ghc view
@@ -0,0 +1,1 @@+ASTCmds.hs: -fno-monomorphism-restriction
+ tools/Phugs/Front2AST.hs view
@@ -0,0 +1,190 @@+module Front2AST where++import Syntax+import PrettyPrint(pp)++type Name = String+data Op = Plus | Mult | IntEq | IntLess+data LS = Lazy | Strict deriving Eq++data Pat +  = Pconst Integer         -- { 5 }+  | Pvar Name              -- { x }+  | Ptuple [Pat]           -- { (p1,p2) }+  | Pcondata Name [Pat]    -- data T1 = C1 t1 t2 \nl {C1 p1 p1} = e +  | Pnewdata Name Pat      -- newtype T2 = C2 t1 t2 \nl {C2 p1 p2} = e+  | Ptilde Pat             -- { ~p }+data Exp +  = Var Name               -- { x }+  | Const Integer          -- { 5 }+  | App Exp Exp            -- { f x }+  | Abs [Pat] Exp          -- { \ p1 p2 -> e }+  | TupleExp [Exp]         -- { (e1,e2) }+  | ConApp Name [(Exp,LS)] -- data T1 = C1 t1 t2 \nl p = {C1 e1 e2}+  | NewApp Name Exp        -- newtype T2 = C2 t1 t2 \nl p = {C2 e1 e2}+  | Seq Exp Exp            -- { seq e1 e2 }               +  | Bin Op Exp Exp         -- { e1 + e2 }+  | Cond Exp Exp Exp       -- { if e1 then e2 else e3 }+  | Let [Dec] Exp          -- { let x=e1 \nl   y=e2 in e3 }+  | Case Exp [Match]       -- { case e of m1 \nl m2 }+type Match = +      (Pat, Body, [Dec])   -- case e of { pat -> body where decs } +data Dec +  = Fun Name [Clause]      -- { f p1 p2 = b where decs }+  | Val Pat Body [Dec]     -- { p = b where decs }+type Clause = +      ([Pat],Body,[Dec])   -- f { p1 p2 = body where decs }+data Body+  = Guarded [(Exp,Exp)]    -- f p { | e1 = e2 | e3 = e4 } where ds+  | Normal Exp             -- f p = { e } where ds+++showB :: Body -> String+showB (Normal e) = showE e+showB (Guarded ps) = foldr f "\n" ps+   where f (e1,e2) ans = "| "++(showE e1) ++ " = " ++(showE e2)++ ans++showWhere ds = if null ds then "" else "   where "++showD :: Dec -> String+showD (Val p body ds) =  "VALDEF " ++ showP p ++ "=" ++ (showB body) ++ "\n" +++                         (showWhere ds) ++ (showDs ds)+showD (Fun nm xs) = "FUNDEF "++ foldr (++) "" (map f xs)+   where f (ps,body,ds) = +           nm ++ " " ++(showPs ps) ++ " = " ++(showB body) ++ "\n" +++           (showWhere ds) ++ (showDs ds)+   ++showDs dcls = foldr (++) "" (map showD dcls)+++showOp :: Op -> String+showOp Plus = "+"+showOp Mult = "*"+showOp IntEq = "=="+showOp IntLess = "<"++showP (Pconst i) = show i+showP (Pvar n) = n+showP (Pcondata n ns) = +                "(" ++ n ++ " " ++ +                (foldr (\ s t -> if t/="" then (showP s) ++ "," ++ t+                                     else (showP s)) +                        "" ns)+                ++ ")"+showP (Pnewdata n x) = "(" ++ n ++ " " ++ (showP x) ++ ")"              +showP (Ptilde p) = "~" ++ (showP p)++showPs [] = ""+showPs (p:ps) = (showP p)++" "++(showPs ps)++showE :: Exp -> String+showE (Var nm) = nm+showE (Const i) = show i+showE (App d d') = "(" ++ showE d ++ " " ++ showE d' ++ ")"+showE (Abs p d) = "(\\" ++ (foldr (++) " " (map showP p)) ++ " -> " +                        ++ showE d ++ ")"+showE (TupleExp l) =  "(" ++   +                (foldr (\ s t -> +                            if t/="" then (showE s) ++ "," ++ t+                                     else (showE s)) +                       "" l)+                      ++ ")"+showE (ConApp n l) =  "(" ++ n ++ " " ++  +                (foldr (\ (s,ls) t -> +                            let sa = if (ls == Strict) then "!" else "" +                            in+                                 if t/="" then sa ++ (showE s) ++ "," ++ t+                                     else sa ++ (showE s)) +                        "" l)+                      ++ ")"+showE (NewApp n x) = "(" ++ n ++ " " ++  (showE x) ++ ")"                     +showE (Seq x y) = "(seq "++(showE x) ++ " " ++ (showE y) ++ ")"+showE (Bin op d d') = "(" ++ showE d ++ " " ++ showOp op ++ " " ++ +                               showE d' ++ ")"+showE (Cond b e1 e2) = "if "++showE b++" then "++showE e1++" else "++show e2+showE (Let dcls d) = "let " ++ +                          foldr (++) "" (map showD dcls)+                            ++ +                        " in " ++ showE d+showE (Case e ms) =+      "(case " ++ showE e ++ " of " ++ +           (foldr (++) "" +           (map (\ alt -> "[" ++ (showAlt alt) ++ "]") ms)) ++ ")"+   where showAlt (p,b,ds) = show p ++ " -> " ++ show b ++ "\n" ++ showDs ds+++instance Show Dec where+  show = showD++instance Show Exp where+  show = showE++instance Show Pat where+  show = showP++instance Show Body where+  show = showB++-----------------------------------------------------------------------++bad x = error "not yet"++--trP :: HsPat -> Pat+trP (Pat p) =+ case mapP trP p of+   HsPId n -> Pvar (showId n)+   HsPLit (HsInt _ n) -> Pconst n+   HsPInfixApp x op y -> Pcondata (showId op) [x,y]+   HsPApp n ps -> Pcondata (showId n) ps+   HsPTuple ps -> Ptuple ps+   HsPIrrPat p -> Ptilde p+   HsPParen p -> p+   other -> error ("no "++(show other)++" patterns yet")+++--trD :: HsDecl -> Dec+trD (d @ (Dec x)) =+ case mapD trE trP (map trD) bad bad bad x of+   HsPatBind loc p b ds -> Val p (trRhs b) ds+   HsFunBind loc matches -> Fun (name matches) (map g matches)+      where name ((HsMatch loc nm ps rhs ds): ms) = (showId (HsVar nm))+            g (HsMatch loc nm ps rhs ds) = (ps,trRhs rhs,ds)+   other -> error ("illegal dec "++(pp d))          +      +--trRhs :: HsRhs Exp -> Body+trRhs (HsBody e) = Normal e+trRhs (HsGuard triples) = Guarded(map f triples)+        where f (loc,guard,body) = (guard,body)++--trAlt :: HsAlt Exp Pat [Dec] -> (Pat,Body,[Dec])+trAlt (HsAlt loc pat rhs ds) = (pat,trRhs rhs,ds)++--trE :: HsExp -> Exp+trE (e @ (Exp x)) = + case mapE trE trP (map trD) bad bad x of +   HsId n                 -> Var (showId n)+   HsApp x y              -> App x y+   HsLit (HsInt _ n)      -> Const n+   HsInfixApp x op z      -> App (App (Var (showId op)) x) z+   HsNegApp _ x           -> App (Var "negate") x  +   HsLambda ps e          -> Abs ps e+   HsLet ds e             -> Let ds e+   HsIf x y z             -> Cond x y z+   HsCase e alts          -> Case e (map trAlt alts)+   HsTuple xs             -> TupleExp xs+   HsList xs              -> f xs+      where f [] = ConApp "[]" []+            f (x:xs) = ConApp ":" [(x,Lazy),(f xs,Lazy)]+   HsParen x              -> x+   HsLeftSection x op     -> Abs[Pvar "zzz"] (App (App (Var (showId op)) x) +                                             (Var "zzz"))+   HsRightSection op y    -> Abs[Pvar "zzz"] (App (App (Var (showId op)) +                                             (Var "zzz")) y)+   other -> error ("no translation yet for: "++(pp e))+++--showId (HsVar x) = show x+--showId (HsCon x) = show x++showId x = pp x
+ tools/Phugs/Front2Stratego.hs view
@@ -0,0 +1,3 @@+module Front2Stratego(module Tr) where+import Prop2Stratego as Tr+--import Base2Stratego as Tr
+ tools/Phugs/HEADER.html view
@@ -0,0 +1,17 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<head>+<title>Programatica Tools, tools/Phugs</title>+<link rel=parent href="../" title="Programatica Tools">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../web/icon1.png">+</head>+<body>+<h1><img align=right src="../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/Phugs</h2>++<!--The README file is displayed below the directory index.+<p>+See also the <a href="pfe.cgi">HTML version of the source code for spfe</a>.-->
+ tools/Phugs/HuMakefile view
@@ -0,0 +1,5 @@++PROP=../property+. $PROP/HuMakefile++SRC_DIRS=.:$SRC_DIRS
+ tools/Phugs/Makefile view
@@ -0,0 +1,42 @@+TARGETS=spfe++MYGHC=../scripts/myghc--make++#HMAKE=ghumake -batch+HMAKE=sh $(MYGHC)++HFLAGS=++### Optimization?+OPT=+#OPT=-O2++RM=rm -f++################################################################################+### Rules for compiling the programs++all: $(TARGETS)++spfe::+	cd ../property/parse2; make HMAKE="sh ../$(MYGHC)"+	$(HMAKE) $(OPT) $(HFLAGS) spfe -o spfe+++################################################################################+### Rules for generating HTML++hi/srclist.txt:+	PFE_LIBS=../base/tests pfesetup noplogic cpp spfe.hs++html:: hi/srclist.txt+	-[ -d hi/html ] && cd hi/html && gunzip *.gz+	pfe htmlfiles+	cd hi/html && gzip -9 *.html++################################################################################+### Rules for cleaning up++clean:+	$(RM) -r $(TARGETS) hi+	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'
+ tools/Phugs/Phugs.hs view
@@ -0,0 +1,555 @@+module Phugs where
+
+
+----------------------------------------------------------------------
+-- AST, etc.
+----------------------------------------------------------------------
+
+import Syntax hiding (E,P,D)
+import PrettyPrint(pp)
+
+type Name = String
+data Op = Plus | Mult | IntEq | IntLess
+data LS = Lazy | Strict deriving Eq
+
+data P --- Nested Patterns
+  = Pconst Integer          -- { 5 }
+  | Pvar Name               -- { x }
+  | Ptuple [P]              -- { (p1,p2) }
+  | Pcondata Name [P]       -- data T1 = C1 t1 t2; {C1 p1 p1} = e 
+  | Pnewdata Name P         -- newtype T2 = C2 t1;  {C2 p1} = e
+  | Ptilde P                -- { ~p }
+  | Paspat Name P           -- { x@p }
+  | Pwildcard               -- { _ }
+
+data E 
+  = Var Name             -- { x }
+  | Const Integer        -- { 5 }
+  | App E E              -- { f x }
+  | Abs [P] E            -- { \ p1 p2 -> e }
+  | TupleExp [E]         -- { (e1,e2) }
+  | ConApp Name [(E,LS)] -- data T1 = C1 t1 t2 \nl p = {C1 e1 e2}
+  | NewApp Name E        -- newtype T2 = C2 t1 t2 \nl p = {C2 e1 e2}
+  | Seq E E              -- { seq e1 e2 }               
+  | Bin Op E E           -- { e1 + e2 }
+  | Cond E E E           -- { if e1 then e2 else e3 }
+  | Let [D] E            -- { let x=e1 \nl   y=e2 in e3 }
+  | Case E [Match]       -- { case e of m1 \nl m2 }
+  | Undefined            -- undefined
+
+type Match = 
+      (P, B, [D])        -- case e of { pat -> body where decs } 
+
+data D 
+  = Fun Name [Clause]    -- { f p1 p2 = b where decs }
+  | Val P B [D]          -- { p = b where decs }
+
+type Clause = 
+      ([P],B,[D])        -- f { p1 p2 = body where decs }
+data B
+  = Guarded [(E,E)]      -- f p { | e1 = e2 | e3 = e4 } where ds
+  | Normal E             -- f p = { e } where ds
+
+
+showB :: B -> String
+showB (Normal e) = showE e
+showB (Guarded ps) = foldr f "\n" ps
+   where f (e1,e2) ans = "| "++(showE e1) ++ " = " ++(showE e2)++ ans
+
+showWhere ds = if null ds then "" else "   where "
+
+showD :: D -> String
+showD (Val p body ds) =  "VALDEF " ++ showP p ++ "=" ++ (showB body) ++ "\n" ++
+                         (showWhere ds) ++ (showDs ds)
+showD (Fun nm xs) = "FUNDEF "++ (foldr (++) "" (map f xs))
+   where f (ps,body,ds) = 
+           nm ++ " " ++(showPs ps) ++ " = " ++(showB body) ++ "\n" ++
+           (showWhere ds) ++ (showDs ds)
+   
+
+showDs dcls = foldr (++) "" (map showD dcls)
+
+showOp :: Op -> String
+showOp Plus = "+"
+showOp Mult = "*"
+showOp IntEq = "=="
+showOp IntLess = "<"
+
+showP (Pconst i)      = "LitPat("++show i++")"
+showP (Pvar n)        = "VarPat(\""++n++"\")"
+showP (Pcondata n ns) = "ConstrPat(" ++ n ++ "," ++ (mkSlist ns) ++")"
+showP (Paspat n p)    = "AsPattern("++n++","++show p++")"
+showP (Pnewdata n x)  = error "no new constructor pattern yet"
+showP (Ptilde p)      = error "no tilde pattern yet"
+showP (Ptuple ps)     = "TuplePat(" ++ mkSlist ps ++ ")" 
+showP Pwildcard       = "WildCard"
+
+showPs [] = ""
+showPs (p:ps) = (showP p)++" "++(showPs ps)
+
+{- Pretty prints a haskell list expression into a stratego list -}
+mkSlist = foldr 
+             (\ s t -> if t/="Nil" then (show s++","++t) else (show s))
+             "Nil" 
+
+{- N.b., the resulting string is Stratego code -}
+showE :: E -> String
+showE (Var nm)     = "HVar(\""++nm++"\")"
+showE (Const i)    = "HLit("++show i++")"
+showE (App d d')   = "HApp(" ++ showE d ++ "," ++ showE d' ++ ")"
+showE (Abs p d)    = "(\\" ++ (foldr (++) " " (map showP p)) ++ " -> " 
+                           ++ showE d ++ ")"
+showE (TupleExp l) =  "(" ++   
+                (foldr (\ s t -> 
+                            if t/="" then (showE s) ++ "," ++ t
+                                     else (showE s)) 
+                       "" l)
+                      ++ ")"
+showE (ConApp n l) =  "(" ++ n ++ " " ++  
+                (foldr (\ (s,ls) t -> 
+                            let sa = if (ls == Strict) then "!" else "" 
+                            in
+                                 if t/="" then sa ++ (showE s) ++ "," ++ t
+                                     else sa ++ (showE s)) 
+                        "" l)
+                      ++ ")"
+showE (NewApp n x)  = "(" ++ n ++ " " ++  (showE x) ++ ")"                     
+showE (Seq x y)     = "(seq "++(showE x) ++ " " ++ (showE y) ++ ")"
+showE (Bin op d d') = "(" ++ showE d ++ " " ++ showOp op ++ " " ++ 
+                               showE d' ++ ")"
+showE (Cond b e1 e2) = "if "++showE b++" then "++showE e1++" else "++show e2
+showE (Let dcls d)   = "let " ++ 
+                            foldr (++) "" (map showD dcls)
+                              ++ " in " ++ showE d
+showE (Case e ms) =
+      "(case " ++ showE e ++ " of " ++ 
+           (foldr (++) "" 
+           (map (\ alt -> "[" ++ (showAlt alt) ++ "]") ms)) ++ ")"
+   where showAlt (p,b,ds) = show p ++ " -> " ++ show b ++ "\n" ++ showDs ds
+
+
+instance Show D where
+  show = showD
+
+instance Show E where
+  show = showE
+
+instance Show P where
+  show = showP
+
+instance Show B where
+  show = showB
+
+-----------------------------------------------------------------------
+
+bad x = error "not yet"
+
+--translateP :: HsPat -> P
+translateP (Pat p) =
+ case mapP translateP p of
+   HsPId n -> Pvar (showId n)
+   HsPLit (HsInt _ n) -> Pconst n
+   HsPInfixApp x op y -> Pcondata (show op) [x,y]
+   HsPApp n ps -> Pcondata (show n) ps
+   HsPTuple ps -> Ptuple ps
+   HsPIrrPat p -> Ptilde p
+   HsPParen p -> p
+   other -> error ("no "++(show other)++" patterns yet")
+
+
+--translateD :: HsDecl -> D
+translateD (d @ (Dec x)) =
+ case mapD translateE translateP (map translateD) bad bad bad x of
+   HsPatBind loc p b ds -> Val p (translateRhs b) ds
+   HsFunBind loc matches -> Fun (name matches) (map g matches)
+      where name ((HsMatch loc nm ps rhs ds): ms) = (showId (HsVar nm))
+            g (HsMatch loc nm ps rhs ds) = (ps,translateRhs rhs,ds)
+   other -> error ("illegal dec "++(show d))          
+      
+--translateRhs :: HsRhs E -> B
+translateRhs (HsBody e) = Normal e
+translateRhs (HsGuard triples) = Guarded(map f triples)
+        where f (loc,guard,body) = (guard,body)
+
+--translateAlt :: HsAlt E P [D] -> (P,B,[D])
+translateAlt (HsAlt loc pat rhs ds) = (pat,translateRhs rhs,ds)
+
+--translateE :: HsExp -> E
+translateE (e @ (Exp x)) = 
+ case mapE translateE translateP (map translateD) bad bad x of 
+   HsId n                 -> Var (showId n)
+   HsApp x y              -> App x y
+   HsLit (HsInt _ n)      -> Const n
+   HsInfixApp x op z      -> App (App (Var (showId op)) x) z
+   HsNegApp _ x           -> App (Var "negate") x  
+   HsLambda ps e          -> Abs ps e
+   HsLet ds e             -> Let ds e
+   HsIf x y z             -> Cond x y z
+   HsCase e alts          -> Case e (map translateAlt alts)
+   HsTuple xs             -> TupleExp xs
+   HsList xs              -> f xs
+      where f [] = ConApp "[]" []
+            f (x:xs) = ConApp ":" [(x,Lazy),(f xs,Lazy)]
+   HsParen x              -> x
+   HsLeftSection x op     -> Abs[Pvar "zzz"] (App (App (Var (show op)) x) 
+                                             (Var "zzz"))
+   HsRightSection op y    -> Abs[Pvar "zzz"] (App (App (Var (show op)) 
+                                             (Var "zzz")) y)
+   other -> error ("no translation yet for: "++(show e))
+
+
+--showId (HsVar x) = show x
+--showId (HsCon x) = show x
+
+showId x = pp x
+
+----------------------------------------------------------------------
+-- Values
+----------------------------------------------------------------------
+
+data V 
+  = Z Integer        --- scalars
+  | FV (V -> V)      --- functions
+  | Tagged Name [V]  --- algebraic structured data
+  | TV [V]           --- tuple values 
+
+-------------------------------------------------------------
+-------------------------------------------------------------
+type Env = Name -> V              -- Maps Names to Values V
+
+xEnv :: Env -> [Name] -> [V] -> Env
+xEnv rho (x:xs) (b:bs) = (xEnv (tweek rho x b) xs bs)
+    where tweek f x y = \ z -> if x == z then y else f z
+xEnv rho [] [] = rho
+
+------------------------------------------------------------------
+{-
+There are variables in a pattern p with the appropriate types corresponding 
+to the range of this function x1::b1, ..., xn::bn.
+
+Call these variables the "fringe" of p. (fringe p) returns the free 
+variables of p in *order* of occurrence from left to right. -}
+
+-- returns the fringe of p in order  from left to right.
+fringe :: P -> [Name]
+fringe (Pconst i) = []
+fringe (Pvar x) = [x]
+fringe (Pcondata n ps) = foldr (++) [] (map fringe ps)
+fringe (Ptilde p) = fringe p
+fringe (Ptuple ps)= foldr (++) [] (map fringe ps)
+fringe (Paspat n p) = n : (fringe p)
+fringe Pwildcard = []
+
+data Predicate = Univ | Strong Predicate | List [Predicate] 
+               | TCongruence Name [Predicate] deriving Show
+
+
+patPred :: P -> [(Name,Predicate)] -> Bool -> (Predicate,Bool)
+patPred (Pvar x) sigma b   = (purify $ lookup x sigma, is_strong (purify $ lookup x sigma))
+                 where     
+	                 is_strong (Strong _) = True
+	                 is_strong _          = False
+                     --xb                   = purify $ lookup x sigma		   
+					 
+patPred Pwildcard sigma b       = (Univ,False)
+patPred (Ptilde p) sigma b      = patPred p sigma False
+patPred (Pcondata n ps) sigma b = 
+       let (List preds, s) = map_patPred ps sigma b
+	   in
+	      if (s || b) then 
+		         (Strong (TCongruence n preds), True)
+		  else   (Univ, False)
+
+map_patPred :: [P] -> [(Name,Predicate)] -> Bool -> (Predicate,Bool)
+map_patPred [] sigma b     = (List [], False)
+map_patPred (p:ps) sigma b = (List (pp:pps), s1 || s2)
+                   where
+                       (pp,s1)       = patPred p sigma b
+                       (List pps,s2) = map_patPred ps sigma b
+
+pat2pred :: P -> [Predicate] -> Predicate
+pat2pred p plist = fst (patPred p (zip (fringe p) plist) True)
+
+frD :: [D] -> [Name]
+frD [] = []
+frD ((Fun f _):ds) = f : (frD ds)
+frD ((Val p _ _):ds) = fringe p ++ (frD ds)
+
+--- This collects the function names & patterns from declarations
+--- as a single tuple pattern
+declared :: [D] -> P
+declared ds = ptuple $ map getbinder ds
+     where     
+	     getbinder (Fun f _)   = Pvar f
+	     getbinder (Val p _ _) = tildefy p
+
+arity (Pvar x) = 1
+arity (Ptuple ps) = sum(map arity ps)
+arity (Pcondata n ps) = sum(map arity ps)
+arity (Ptilde p) = arity p
+		 
+tuple :: [V] -> V
+tuple [v] = v
+tuple vs = TV vs
+
+tagtuple :: [V] -> V
+tagtuple [v] = v
+tagtuple vs = Tagged "tuple" vs
+
+ptuple :: [P] -> P
+ptuple [p] = p
+ptuple ps = Pcondata "tuple" ps
+
+tildefy :: P -> P
+tildefy p = case p of 
+                  (Ptilde p') -> p
+                  (Pvar x)    -> p
+                  _           -> (Ptilde p)
+
+-------------------------------------------
+--      Important Semantic Operators     --
+-------------------------------------------
+
+-- Composition operators (N.b., both diagrammatic order.)
+(>>>) :: (a -> b) -> (b -> c) -> a -> c
+f >>> g = g . f              -- Functional
+
+(<>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
+f <> g = \x -> f x >>= g     -- Kleisli 
+
+bottom :: a                             -- domains are pointed
+bottom = undefined
+
+purify :: Maybe a -> a                  -- "run" of Maybe monad
+purify (Just x) =  x
+purify Nothing  = bottom
+
+fix :: (a -> a) -> a                    -- least fixed point
+fix f = f (fix f)
+
+semseq :: V -> V -> V
+semseq x y = case x of 
+                (Z _)        -> y  ;
+				(FV _)       -> y  ;
+			    (Tagged _ _) -> y  ;
+				(TV _)       -> y  
+
+sharp :: Int -> [V] -> (V -> V) -> V    -- Currying
+sharp 0 vs beta = beta (tuple vs)
+sharp n vs beta = FV $ \ v -> sharp (n-1) (vs++[v]) beta
+
+app :: V -> V -> V                      -- Application
+app (FV f) x = f x
+
+fatbar :: (a -> Maybe b) -> (a -> Maybe b) -> (a -> Maybe b)
+f `fatbar` g = \ x -> (f x) `fb` (g x)
+     where 
+          fb :: Maybe a -> Maybe a -> Maybe a
+          Nothing `fb` y = y
+          (Just v) `fb` y = (Just v)
+		  
+
+
+{- The function match is used to construct the meaning of a Match. -}
+match :: Env -> (P, B, [D]) -> V -> Maybe V
+match rho (p,b,ds) = mP p <> (\vs -> mwhere (xEnv rho xs vs) b ds)
+     where xs = fringe p
+
+-- used in letbind and mE
+lam :: P -> E -> Env -> V -> V
+lam p e rho = (mP p <> ((\vs -> mE e (xEnv rho xs vs)) >>> Just)) >>> purify
+     where xs = fringe p
+
+mcase :: Env -> [Match] -> V -> V
+mcase rho ml = (fatbarL $ map (match rho) ml) >>> purify
+                     where fatbarL :: [V -> Maybe V] -> V -> Maybe V
+                           fatbarL ms = foldr fatbar (\ _ -> (Just bottom)) ms
+
+{-
+(letbind rho ds e) is the meaning of Haskell's mutually recursive
+let construct. Its definition uses a standard technique for 
+defining mutual recursion with explicit fix-points:
+
+let p1 = e1    
+      ...
+    pn = en    === (\(p1,...,pn) -> e) (fix \(~p1,...,~pn) -> (e1,...,en))
+in 
+    e
+
+In order for the fixpoint to be defined, each pattern pi in the argument 
+to fix is "~"-ed, so that the function is lazy.
+-}
+
+letbind ::  Env -> [D] -> E -> V
+letbind rho [] e = mE e rho
+letbind rho ds e = (lam dp e rho) v
+    where
+       dp = tildefy $ declared ds
+       xs = frD ds
+       decls env = tagtuple $ map (\d -> mD d env) ds
+       v = fix $ ((mP dp) <> 
+                   ((\vs -> decls (xEnv rho xs vs)) >>> Just)) >>> purify
+
+mwhere ::  Env -> B -> [D] -> Maybe V
+mwhere rho b [] = mB b rho
+mwhere rho b ds = (wherecls dp b rho) v
+ where
+   wherecls p b rho = (mP p <> (\vs -> mB b (xEnv rho xs vs)))
+                         where xs = fringe p
+   dp = tildefy $ declared ds
+   xs = frD ds
+   decls env = tagtuple $ map (\d -> mD d env) ds
+   v = fix $ ((mP dp) <> 
+               ((\vs -> decls (xEnv rho xs vs)) >>> Just)) >>> purify
+			 	   
+{-
+Translation of function bindings from Haskell98 Report (p. 54):
+
+             x p(1,1) ... p(1,k)  match1
+                      ...
+             x p(n,1) ... p(n,k)  matchn
+
+ is equivalent to
+            x = \x1 ... xn -> case (x1,...,xn) of
+			                            (p(1,1),...,p(1,k)) ->  match1
+                                            ...
+                                        (p(n,1),...,p(n,k)) ->  matchn  
+	        where x1,...,xn are fresh variables.
+			
+The function below, "mD", is constructed similarly, although without any
+variable generation. 
+-}
+
+
+
+--------------------------------------------
+---          semantic functions          ---
+--------------------------------------------
+
+mE  :: E -> Env -> V
+mP  :: P -> V -> Maybe [V]
+mB  :: B -> Env -> Maybe V
+mD :: D -> Env -> V
+
+phugs ds = mE (Let ds (Var "topLevel")) rho0
+
+--(App (Var "odd") (Const 3))
+
+
+rho0 = xEnv rhoNull ["==","-","*","True","False"] [eqZ,minusZ,multZ,tt,ff] 
+    where rhoNull = \msg -> (error ("You're applying the empty env to:"++msg))
+          eqZ = FV $ \ (Z i) -> (FV $ \ (Z j) -> 
+                        if i==j then (Tagged "True" [])
+                                else (Tagged "False" []))
+          minusZ = FV $ \ (Z i) -> (FV $ \ (Z j) -> (Z $ i-j))
+          multZ  = FV $ \ (Z i) -> (FV $ \ (Z j) -> (Z $ i*j))
+          tt     = Tagged "True" []
+          ff     = Tagged "False" []
+
+-----------------------------------------------------------------
+-- The meaning of expressions
+-----------------------------------------------------------------
+
+ifV :: V -> a -> a -> a
+ifV (Tagged "True" []) x y = x
+ifV (Tagged "False" []) x y = y
+
+
+
+mE (Var n) rho        = rho n
+mE (Const i) rho      = (Z i)
+
+mE (TupleExp es) rho  = TV $ map (\e-> mE e rho) es
+mE (Cond e0 e1 e2) rho = ifV (mE e0 rho) (mE e1 rho) (mE e2 rho)
+
+mE (App e1 e2) rho    = app (mE e1 rho) (mE e2 rho)
+mE (Abs [p] e) rho    = FV $ lam p e rho
+mE (Abs ps e) rho     = mE (foldr (\p -> \body -> Abs [p] body) e ps) rho
+
+mE (Let ds e) rho     = letbind rho ds e 
+mE (Case e ml) rho    = mcase rho ml (mE e rho)
+
+mE (ConApp n el) rho  = evalL el rho n [] 
+   where evalL :: [(E,LS)] -> Env -> Name -> [V] -> V
+         evalL [] rho n vs              = Tagged n vs
+         evalL ((e,Strict):es) rho n vs = semseq (mE e rho) 
+		                                         (evalL es rho n (vs ++ [mE e rho]))
+         evalL ((e,Lazy):es) rho n vs   = evalL es rho n (vs ++ [mE e rho])
+
+mE (NewApp n e) rho   = mE e rho
+
+mE Undefined rho      = bottom
+
+mE (Seq e1 e2) rho    = semseq (mE e1 rho) (mE e2 rho)
+mE (Bin op e1 e2) rho = binOp op (mE e1 rho) (mE e2 rho)
+           where binOp Plus (Z i) (Z j)    = Z $ i+j
+                 binOp Mult (Z i) (Z j)    = Z $ i*j
+                 binOp IntEq (Z i) (Z j)   = Tagged (equal i j) []
+                 binOp IntLess (Z i) (Z j) = Tagged (less i j) []
+                 equal i j = if i==j then "True" else "False"
+                 less i j  = if i<j then "True" else "False"
+
+mB (Normal e) rho               = Just (mE e rho)
+mB (Guarded gl) rho             = ite gl rho
+   where ite [] rho         = Nothing   
+         ite ((g,e):gs) rho = ifV (mE g rho) (Just (mE e rho)) (ite gs rho)
+
+{- 
+A pattern p may be viewed as a function of type ::a -> Maybe (b1,...,bn).
+The denotation of a pattern is represented here as a function ::V -> Maybe [V].
+-}
+mP (Pvar x) v                    = Just [v]
+mP (Pconst i) (Z j)              = if i==j then Just [] else Nothing
+mP (Ptuple ps) (TV vs)           = stuple (map mP ps) vs
+mP (Pcondata n ps) (Tagged t vs) = if n==t then
+                                        stuple (map mP ps) vs
+                                   else Nothing
+mP (Pnewdata n p) v              = mP p v
+mP (Ptilde p) v = Just(case mP p v of
+                          Nothing -> replicate (arity p) bottom
+                          Just z -> z) 
+mP Pwildcard v = Just []
+
+stuple :: [V -> Maybe [V]] -> [V] -> Maybe [V]
+stuple [] []         = Just []
+stuple (q:qs) (v:vs) = do v'  <- q v
+                          vs' <- stuple qs vs
+                          Just (v'++vs')
+
+mD (Fun f cs) rho  = sharp lps [] body
+     where 
+       body = mcase rho (map (\(ps,b,ds) -> (ptuple ps, b,ds)) cs)
+       lps  = length ((\(pl,_,_)->pl) (head cs))
+	                              
+mD (Val p b ds) rho = purify $ mwhere rho b ds 
+
+--grunt (Val p b ds) rho 
+--grunt (Val p b ds) rho = fix $ match rho (tildefy p,b,ds) >>> purify 
+
+
+showV :: V -> String
+showV (Z i)            = show i
+showV (FV _)         = "(function value)"
+showV (Tagged n [])    = n
+showV (Tagged n [v])   = "("++n++" ?)"
+showV (Tagged n [v1,v2])   = "("++n++" "++show v1++" "++show v2++")"
+showV (TV [])    = "()"
+showV (TV [v])   = "("++show v++")"
+showV (TV [v1,v2])    = "("++show v1++","++show v2 ++")"
+
+instance Show V where
+  show = showV
+
+{-
+rho0 = (\msg -> error "hey - you're applying the empty env!")
+go e = mE e rho0
+-}
+omegafac n = let fac x = if x==0 then 1 else x * (fac (x-1)) in fac n
+
+omega :: V
+omega = case (fix (\ i -> i) (Z 9)) of 
+                      FV f -> FV f
+
+omega1 :: Integer -> (Integer -> Integer) -> Integer -> Integer
+omega1 x f = if x==0 then f else (omega1 (x-1) f)
+			

+ tools/Phugs/Prop2Stratego.hs view
@@ -0,0 +1,35 @@+{-++Knot-tying definitions for the base+property syntax to Stratego translation.+-}++module Prop2Stratego where+import BaseStruct2Stratego(transP,transD,transE,showId)+import PropStruct2Stratego(transPD,transPA,transPP)+import PropSyntax --hiding (D,P,E) -- recursive base+prop syntax+import PrettyPrint+import SpecialNames+import StrategoAST(D,P,E)++transPat :: PrintableOp i => HsPatI i -> P+transPat (Pat p) = transP showId transPat p++transDecs ds = map transDec ds++transDec :: (IsSpecialName i,PrintableOp i) => HsDeclI i -> D+transDec (Dec d) =+    prop (transD showId transExp transPat transDecs bad bad bad)+         (transPD showId transAssertion transPredicate)+         d++--transExp :: HsExp -> E+transExp (Exp e) = transE showId transExp transPat transDecs bad bad e++transAssertion (PA a) =+   transPA showId transExp bad transAssertion transPredicate+           a++transPredicate (PP p) =+   transPP showId transExp transPat bad transAssertion transPredicate+           p++bad x = error "Base2Stratego: not yet"
+ tools/Phugs/PropStruct2Stratego.hs view
@@ -0,0 +1,22 @@+{-++Reusable functions for translation from the (non-recursive) P-Logic structure+to Stratego.+-}++module PropStruct2Stratego where+import StrategoAST+import HsPropStruct+import HsPropMaps+import PrettyPrint(pp)++transPD trId trPA trPP pd =+  case mapPD trId trPA trPP pd of+    _ -> error ("not yet: "++pp pd)++transPA trId trE trT trPA trPP pa =+  case mapPA trId trE trT trPA trPP pa of+    _ -> error ("not yet: "++pp pa)++transPP trId trE trP trT trPA trPP pred =+  case mapPP trId trE trP trT trPA trPP pred of+    _ -> error ("not yet: "++pp pred)
+ tools/Phugs/StrategoAST.hs view
@@ -0,0 +1,42 @@+module StrategoAST where++type Name = String+data Op = Plus | Mult | IntEq | IntLess+data LS = Lazy | Strict deriving Eq++data P --- Nested Patterns+  = Pconst Integer          -- { 5 }+  | Pvar Name               -- { x }+  | Ptuple [P]              -- { (p1,p2) }+  | Pcondata Name [P]       -- data T1 = C1 t1 t2; {C1 p1 p1} = e +  | Pnewdata Name P         -- newtype T2 = C2 t1;  {C2 p1} = e+  | Ptilde P                -- { ~p }+  | Paspat Name P           -- { x@p }+  | Pwildcard               -- { _ }++data E +  = Var Name             -- { x }+  | Const Integer        -- { 5 }+  | App E E              -- { f x }+  | Abs [P] E            -- { \ p1 p2 -> e }+  | TupleExp [E]         -- { (e1,e2) }+  | ConApp Name [(E,LS)] -- data T1 = C1 t1 t2 \nl p = {C1 e1 e2}+  | NewApp Name E        -- newtype T2 = C2 t1 t2 \nl p = {C2 e1 e2}+  | Seq E E              -- { seq e1 e2 }               +  | Bin Op E E           -- { e1 + e2 }+  | Cond E E E           -- { if e1 then e2 else e3 }+  | Let [D] E            -- { let x=e1 \nl   y=e2 in e3 }+  | Case E [Match]       -- { case e of m1 \nl m2 }++type Match = +      (P, B, [D])        -- case e of { pat -> body where decs } ++data D +  = Fun Name [Clause]    -- { f p1 p2 = b where decs }+  | Val P B [D]          -- { p = b where decs }++type Clause = +      ([P],B,[D])        -- f { p1 p2 = body where decs }+data B+  = Guarded [(E,E)]      -- f p { | e1 = e2 | e3 = e4 } where ds+  | Normal E             -- f p = { e } where ds
+ tools/Phugs/StrategoPretty.hs view
@@ -0,0 +1,91 @@+module StrategoPretty where+import StrategoAST++showB :: B -> String+showB (Normal e) = showE e+showB (Guarded ps) = foldr f "\n" ps+   where f (e1,e2) ans = "| "++(showE e1) ++ " = " ++(showE e2)++ ans++showWhere ds = if null ds then "" else "   where "++showD :: D -> String+showD (Val p body ds) =  " " ++ showP p ++ "=" ++ (showB body) ++ "\n" +++                         (showWhere ds) ++ (showDs ds)+showD (Fun nm xs) = foldr (++) "" (map f xs)+   where f (ps,body,ds) = +           nm ++ " " ++(showPs ps) ++ " = " ++(showB body) ++ "\n" +++           (showWhere ds) ++ (showDs ds)+   ++showDs dcls = foldr (++) "" (map showD dcls)++showOp :: Op -> String+showOp Plus = "+"+showOp Mult = "*"+showOp IntEq = "=="+showOp IntLess = "<"++showP (Pconst i)      = "LitPat("++show i++")"+showP (Pvar n)        = "VarPat(\""++n++"\")"+showP (Pcondata n ns) = "ConstrPat(" ++ n ++ "," ++ (mkSlist ns) ++")"+showP (Paspat n p)    = "AsPattern("++n++","++show p++")"+showP (Pnewdata n x)  = error "no new constructor pattern yet"+showP (Ptilde p)      = error "no tilde pattern yet"+showP (Ptuple ps)     = "TuplePat(" ++ mkSlist ps ++ ")" +showP Pwildcard       = "WildCard"++showPs [] = ""+showPs (p:ps) = (showP p)++" "++(showPs ps)++{- Pretty prints a haskell list expression into a stratego list -}+mkSlist = foldr +             (\ s t -> if t/="Nil" then (show s++","++t) else (show s))+             "Nil" ++{- N.b., the resulting string is Stratego code -}+showE :: E -> String+showE (Var nm)     = "HVar(\""++nm++"\")"+showE (Const i)    = "HLit("++show i++")"+showE (App d d')   = "HApp(" ++ showE d ++ "," ++ showE d' ++ ")"+showE (Abs p d)    = "(\\" ++ (foldr (++) " " (map showP p)) ++ " -> " +                           ++ showE d ++ ")"+showE (TupleExp l) =  "(" ++   +                (foldr (\ s t -> +                            if t/="" then (showE s) ++ "," ++ t+                                     else (showE s)) +                       "" l)+                      ++ ")"+showE (ConApp n l) =  "(" ++ n ++ " " ++  +                (foldr (\ (s,ls) t -> +                            let sa = if (ls == Strict) then "!" else "" +                            in+                                 if t/="" then sa ++ (showE s) ++ "," ++ t+                                     else sa ++ (showE s)) +                        "" l)+                      ++ ")"+showE (NewApp n x)  = "(" ++ n ++ " " ++  (showE x) ++ ")"                     +showE (Seq x y)     = "(seq "++(showE x) ++ " " ++ (showE y) ++ ")"+showE (Bin op d d') = "(" ++ showE d ++ " " ++ showOp op ++ " " ++ +                               showE d' ++ ")"+showE (Cond b e1 e2) = "if "++showE b++" then "++showE e1++" else "++show e2+showE (Let dcls d)   = "let " ++ +                            foldr (++) "" (map showD dcls)+                              ++ " in " ++ showE d+showE (Case e ms) =+      "(case " ++ showE e ++ " of " ++ +           (foldr (++) "" +           (map (\ alt -> "[" ++ (showAlt alt) ++ "]") ms)) ++ ")"+   where showAlt (p,b,ds) = show p ++ " -> " ++ show b ++ "\n" ++ showDs ds+++instance Show D where+  show = showD++instance Show E where+  show = showE++instance Show P where+  show = showP++instance Show B where+  show = showB
+ tools/Phugs/spfe.hs view
@@ -0,0 +1,44 @@++import PPU(getPPopts)+import LexerOptions(lexerOptions,lexerflags0)++import PropParser(parse)+import PropLexer(pLexerPass0)+--import DefinedNamesProp()+import FreeNamesProp()+import ScopeNamesProp()+import NameMapsProp()+import ReAssocProp()+import MapDeclMProp() -- for removing pattern bindings in Pfe3Cmds.+import TiModule() -- instance ValueId PNT+import TiProp()+import RemoveListCompProp()+import SimpPatMatchProp()++import TiPropDecorate(TiDecls) -- to choose result type from the type checker+--import PropSyntax(HsDeclI) -- to choose result type from the type checker+import HsModule++--import Pfe3Cmds(pfe3Cmds)+import Pfe4Cmds(pfe4Cmds)+import PFE4(PFE4Info,runPFE4Cmds)+import PfeHtmlCmds(pfeHtmlCmds)+import PfeChase(pfeChaseCmds)+import ASTCmds++main =+  do (opts,name,args0) <- getPPopts+     --lexerflags1 <- fromMaybe lexerflags0 # readFileMaybe lexerflagsPath+     lexerflags1 <- return lexerflags0 -- grr!+     let (lexerflags,args1) = lexerOptions lexerflags1 args0+     runPFE4Cmds () pfeCmds (pLexerPass0 lexerflags,parse) (opts,name,args1)++pfeCmds = pfe4Cmds tcOutput+++          pfeChaseCmds+++          pfeHtmlCmds+++	  astCmds+++-- The type checker can output (TiDecls i2) or [HsDeclI i2].+tcOutput = id :: I (PFE4Info i2 (TiDecls i2))+type I a = a->a
+ tools/Phugs/tests/Test0.hs view
@@ -0,0 +1,14 @@+module Test0 where++id x = x+const x y = y++--fst (x,y) = x+--snd (x,y) = y++fac 0 = 1+fac n = n*fac(n-1)++one = 1++assert {fac 0} === one
+ tools/README.html view
@@ -0,0 +1,90 @@+<!-- This file included by the web server in the automatically generated+     directory index.+-->+<title>Tools for the Programatica project</title>++<h1>Tools for the Programatica project</h1>++<div>+<p>+This directory contains the sources for (some of) the tools implemented+as part of the Programatica project.+<p>+<strong>This is all work in progress (including this documentation)!</strong>+</div>++<h2 id=what>What tools are provided?</h2>+<div>+<p>+See the+ <a href="features.html"><cite>Features</cite></a>+ and+ <a href="usage.html"><cite>Usage</cite></a>+ pages for documentation of the main tools. There are also some additional+tidbits lying around.+</div>++<h2>How to compile and install the tools</h2>++<div>+<p>+See the <a href="INSTALL.html">INSTALL</a> page.+</div>++<h2>Subdirectories</h2>+<div>++<p>+The code that has been actively developed recently is located in the following+subdirectories, some of which contain additional README files:++<table>+<tr><th>Directory<th>Description+<tr><td><a href="base/"><code>base</code></a>+<td>Extensible Haskell front-end and base language (Haskell 98) tools.+    There is a <a href="base/README.html">README</a> file with further+    details.++<tr><td><a href="pfe/"><code>pfe</code></a>+<td>PFE - the preliminary front-end framework and command-line tools.+    There is a <a href="pfe/README.html">README</a> file with further+    details.++<tr><td><a href="pfe/Browser/"><code>pfe/Browser</code></a>+<td>The Programatica Haskell Browser.++<tr><td><a href="property/"><code>property</code></a>+<td>Extension of the base language with P-logic property declarations,+    including a new parser and an extended type checker.+    (An awful lot of work for a small extension...)++<tr><td><code>hs2html</code>+<td>Haskell to HTML translator. (Little extra work for a potentially useful+    tool.)++<tr><td><a href="hs2alfa/"><code>hs2alfa</code></a>+<td>Haskell to Alfa translator.++<tr><td><a href="hs2stratego/"><code>hs2stratego</code></a>+<td>Haskell to Stratego translator.++<tr><td><code>hsutils</code>+<td>Small spin-off Haskell utility programs.++<tr><td><a href="evman/"><code>evman</code></a>+<td>Files relating to evidence (certificate) management, in particular+    the command line tool <code>cert</code> and the implementation of+    the certificate servers.++<tr><td><code>scripts</code>+<td>Various shell scripts, some of which are used in the build process.++<tr><td><code>bin</code>, <code>lib</code>+<td>There are directores created by the Makefile to hold a template of+    things that get installed by <code>make install</code>.+    (See <a href="INSTALL.html">INSTALL.html</a>).+</table>+</div>+<hr>+<address>Authors: various</address>+<address>Contact: <a href="http://www.cse.ogi.edu/~hallgren/">TH</address>
+ tools/TFF/HuMakefile view
@@ -0,0 +1,2 @@+SRC_DIRS=.:../base:../base/AST:../base/pretty:../base/syntax:../base/lib+GHCFLAGS="-package lang"
+ tools/TFF/Preds.hs view
@@ -0,0 +1,64 @@+module Preds where++import Syntax hiding (lookUp)+import PrettyPrint++import TFFMonad+import TypesTerms+++--------------------------------------------------------------------------------+-- Theorems+--++data Pred+    = Term := Term +    | Pred :=> Pred +    | Pred :/\ Pred +    | Forall Term Pred              -- Term should be a Var term+        deriving (Eq,Show)++instance Printable Pred where+    ppi ((t1,_) := (t2,_))  = ppi t1 <+> text "=" <+> ppi t2+    ppi (p :=> q)           = wrap p <+> text "==>" <+> wrap q+    ppi (p :/\ q)           = wrap p <+> text "/\\" <+> wrap q+    ppi (Forall a p)        = text "!" <> ppTerm a <> text "."+                              $$ nest 4 (ppi p)+++getRel :: Type -> Term -> Term -> FM Pred+getRel (Type ty) t1 t2+    = case ty of++        HsTyCon n -> return (t1 := t2)++        HsTyFun p q -> do+            { x  <- newVar (dom t1) +            ; y  <- newVar (dom t2)+            ; r1 <- getRel p x y    +            ; r2 <- getRel q (applyTerm t1 x) (applyTerm t2 y)+            ; return $ Forall x $ Forall y $ r1 :=> r2+            } +++        HsTyVar a -> do+            { f <- lookUp a +            ; return (t2 := applyTerm f t1)+            }+++getRel (TyAll n t) t1 t2 = do+            { x <- newTVar+            ; y <- newTVar+            ; f <- newVar (mkTyFun x y)+            ; p <- inExtendedEnv n f $+                getRel t (applyType t1 x) (applyType t2 y)+            ; return (Forall f p)+            }+--+--------------------------------------------------------------------------------+++++
+ tools/TFF/TFFMonad.hs view
@@ -0,0 +1,67 @@+module TFFMonad where++import Syntax +import TypesTerms+import Char(chr,ord)++--------------------------------------------------------------------------------+-- The monad+--++type Env        = [(HsName, Term)]+type FreshVars  = (Int, Int, Int)   ++tvarCtr (x,_,_) = x+funCtr  (_,x,_) = x+valCtr  (_,_,x) = x++incTvarCtr (x,y,z)  = (x+1, y, z)+incFunCtr  (x,y,z)  = (x, y+1, z)+incValCtr  (x,y,z)  = (x, y, z+1)++valName fvs     = UnQual $ 'x' : show (valCtr fvs)+funName fvs     = UnQual $ [chr (funCtr fvs + ord 'f')]+tvarName fvs    = UnQual $ [chr (tvarCtr fvs + ord 'A')]+++newtype FM a    = FM ( (FreshVars, Env) -> (a, FreshVars) )++instance Monad FM where+    return x        = FM (\(fvs, e) -> (x, fvs))+    FM f >>= g      = FM bind+        where+        bind (fvs, e) =  +            let (a, fvs')   = f (fvs, e)+                FM h        = g a+            in h (fvs', e)++inExtendedEnv :: HsName -> Term -> FM a -> FM a+inExtendedEnv n t (FM f) = FM (\(fvs, e) -> f (fvs, (n, t):e))++lookUp :: HsName -> FM Term+lookUp n = FM (\(fvs, e) -> (maybe no id (lookup n e), fvs))+    where+    no = error $ "lookUp: " ++ (show n) ++ " not in environment."+++newVar :: Type -> FM Term+newVar t = FM f+    where+    f (fvs, e) = if isFun t+        then ( (hsEVar (funName fvs) ,t) , incFunCtr fvs ) +        else ( (hsEVar (valName fvs) ,t) , incValCtr fvs ) ++newTVar :: FM Type+newTVar = FM f+    where+    f (fvs, e)  = (mkTyVar (tvarName fvs), incTvarCtr fvs)+++run :: FM a -> a+run (FM f) = let (v, _) = f ((0,0,0), []) in v+++--+--------------------------------------------------------------------------------++
+ tools/TFF/Tests.hs view
@@ -0,0 +1,59 @@+module Main where+++import TypesTerms+import Preds+import Syntax+import PrettyPrint+import TFFMonad++import System(getArgs)+++--------------------------------------------------------------------------------+-- Tests+--++free f@(Exp (HsId (HsVar n)) , t) = do+    { putStrLn $ "Theorem for: " ++ pp f+    ; putStrLn . pp . run $ getRel t f f+    }++++a = mkTyVar (UnQual "a")+b = mkTyVar (UnQual "b")+c = mkTyVar (UnQual "c")++tint = mkTyCon (UnQual "Int")+tchar = mkTyCon (UnQual "Char")++(+->) = mkTyFun++fall n t = mkTyAll (UnQual n) t++mkVar = hsEVar . UnQual++t0 = free (mkVar "one", tint)+t1_0 = free (mkVar "succ", (tint +-> tint))+t1 = free (mkVar "succN", (tint +-> tchar +-> tchar))+t2 = free (mkVar "bottom", (fall "a" a))+t3 = free (mkVar "const1", (fall "a" (a +-> tint)))+t4 = free (mkVar "cast",   (fall "a" (fall "b" (a +-> b))))+t5 = free (mkVar "const",   (fall "a" (fall "b" (a +-> (b +-> a)))))++tsts = [t0, t1_0, t1, t2, t3, t4, t5]+++main = do+    a:args <- getArgs+    let x = (read a) :: Int+    tsts !! x+    return ()++++--+--------------------------------------------------------------------------------++
+ tools/TFF/TypesTerms.hs view
@@ -0,0 +1,81 @@+module TypesTerms where++import Syntax+import PrettyPrint+++--------------------------------------------------------------------------------+-- Types+-- ++data Type+    = Type (T Type)+    | TyAll HsName Type+        deriving (Show, Eq)++mkTyVar n       = Type $ HsTyVar n+mkTyCon n       = Type $ HsTyCon n+mkTyApp t1 t2   = Type $ HsTyApp t1 t2+mkTyFun t1 t2   = Type $ HsTyFun t1 t2+mkTyTuple ts    = Type $ HsTyTuple ts+mkTyAll n t     = TyAll n t+++instance Printable Type where+    ppi (Type t)    = ppi t+    ppi (TyAll n t) = text "forall" <+> ppi n <> text "." $$ nest 4 (ppi t)+++++isFun :: Type -> Bool+isFun (Type (HsTyFun _ _))      = True+isFun _                         = False+++applyType :: Term -> Type -> Term+applyType (term, (TyAll a s)) t = (term, substType t a s) +applyType _ _                   = error "applyType: to a non-forall type"+++substType :: Type -> HsName -> Type -> Type+substType t v ty@(TyAll n x)+    | n == v    = ty+    | otherwise = mkTyAll n (substType t v x)+substType t v ty@(Type (HsTyVar n))+    | n == v    = t+    | otherwise = ty+substType t v (Type s) +    = Type $ mapT (substType t v) s+++--+--------------------------------------------------------------------------------++++--------------------------------------------------------------------------------+-- Terms+--++type Term = (HsExp, Type)+++dom :: Term -> Type+dom (_, Type (HsTyFun t _)) = t+dom _                       = error "dom: of a non-function term"+++applyTerm :: Term -> Term -> Term+applyTerm (s, (Type (HsTyFun dom cdom))) (t, ty)+    | dom == ty     = (hsApp s t, cdom)+    | otherwise     = error $ "applyTerm: wrong types" ++ show dom ++ show ty+applyTerm _ _       = error "applyTerm: applying to non-function"+++ppTerm (t,ty)   = ppi t <> text ":" <+> ppi ty++--+--------------------------------------------------------------------------------++
+ tools/TFF/myhugs view
@@ -0,0 +1,1 @@+hugs -98 -P:../base:../base/AST:../base/pretty:../base/syntax:../base/lib $*
+ tools/base/AST/._HsGuardsPretty.hs view
binary file changed (absent → 167 bytes)
+ tools/base/AST/._PrettyPrint2.hs view
binary file changed (absent → 167 bytes)
+ tools/base/AST/._SrcLoc1.hs view
binary file changed (absent → 82 bytes)
+ tools/base/AST/BaseSyntax.hs view
@@ -0,0 +1,13 @@+module BaseSyntax (module BaseSyntax, module B) where++import BaseSyntaxStruct as B+import BaseSyntaxMaps   as B+import BaseSyntaxPretty as B+import BaseSyntaxUtil   as B++import HsModule as B+import HsModuleMaps as B+import HsModulePretty as B+import SrcLoc1   as B+import HsName   as B+import HsAssoc  as B
+ tools/base/AST/BaseSyntaxMaps.hs view
@@ -0,0 +1,8 @@+module BaseSyntaxMaps(module Maps) where+import HsDeclMaps   as Maps+import HsExpMaps    as Maps+import HsFieldsMaps as Maps+import HsGuardsMaps as Maps+import HsKindMaps   as Maps+import HsPatMaps    as Maps+import HsTypeMaps   as Maps
+ tools/base/AST/BaseSyntaxPretty.hs view
@@ -0,0 +1,13 @@+module BaseSyntaxPretty(module Pretty) where+import HsDeclPretty   as Pretty+import HsExpPretty    as Pretty+import HsFieldsPretty as Pretty+import HsGuardsPretty as Pretty+import HsKindPretty   as Pretty+import HsPatPretty    as Pretty+import HsTypePretty   as Pretty++import HsIdentPretty   as Pretty+import HsAssocPretty   as Pretty+import HsLiteralPretty as Pretty+import SrcLocPretty    as Pretty
+ tools/base/AST/BaseSyntaxStruct.hs view
@@ -0,0 +1,15 @@+module BaseSyntaxStruct(module Struct) where+import HsDeclStruct   as Struct+import HsExpStruct    as Struct+import HsFieldsStruct as Struct+import HsGuardsStruct as Struct+import HsKindStruct   as Struct+import HsPatStruct    as Struct+import HsTypeStruct   as Struct+import HsAssocStruct  as Struct++--import HsModule       as Struct+--import HsName	      as Struct(ModuleName(..))++import HsLiteral      as Struct+import HsIdent        as Struct
+ tools/base/AST/BaseSyntaxUtil.hs view
@@ -0,0 +1,8 @@+module BaseSyntaxUtil(module Util) where+import HsDeclUtil   as Util+import HsExpUtil    as Util+--import HsFieldsUtil  as Util+import HsGuardsUtil as Util+import HsKindUtil   as Util+import HsPatUtil    as Util+import HsTypeUtil   as Util
+ tools/base/AST/HEADER.html view
@@ -0,0 +1,19 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!-- This file is included by the web server in the automatically generated+     directory index.+-->+<head>+<title>Programatica Tools, tools/base/AST</title>+<link rel=parent href="../" title="Programatica Tools, base">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../../web/icon1.png">+</head>++<body>+<h1><img align=right src="../../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory base/AST</h2>++The README file is displayed below the directory index.
+ tools/base/AST/HasBaseName.hs view
@@ -0,0 +1,12 @@+module HasBaseName where+import HsName(Id,HsName,ModuleName)+import HsIdent++class HasBaseName ie ib | ie->ib           where getBaseName :: ie -> ib++instance HasBaseName Id     Id             where getBaseName = id+instance HasBaseName HsName HsName         where getBaseName = id+--instance HasBaseName ModuleName ModuleName where getBaseName = id++instance HasBaseName ie ib => HasBaseName (HsIdentI ie) (HsIdentI ib) where+  getBaseName = mapHsIdent getBaseName
+ tools/base/AST/HasBaseStruct.hs view
@@ -0,0 +1,100 @@+module HasBaseStruct where+import BaseSyntaxStruct+import SpecialNames++class HasBaseStruct r base | r->base where+  base :: base -> r++class GetBaseStruct r base | r->base where+  basestruct :: r -> Maybe base+++--instance HasBaseStruct rec base => HasBaseStruct [rec] [base] where+--  base = map base++-- Decl building+hsTypeDecl sloc tp hstype       = base $ HsTypeDecl sloc tp hstype+hsNewTypeDecl sloc c tp consdecl hsnames2+    = base $ HsNewTypeDecl sloc c tp consdecl hsnames2+hsDataDecl sloc c tp condecls names2+    = base $ HsDataDecl sloc c tp condecls names2+hsClassDecl sloc c typ fdeps decls = base $ HsClassDecl sloc c typ fdeps decls+hsInstDecl sloc optn c typ decls   = base $ HsInstDecl  sloc optn c typ decls+hsDefaultDecl sloc typ          = base $ HsDefaultDecl sloc typ+hsTypeSig sloc hsnames c t      = base $ HsTypeSig sloc hsnames c t+hsFunBind sloc hsmatches        = base $ HsFunBind sloc hsmatches+hsPatBind sloc pat rhs decls    = base $ HsPatBind sloc pat rhs decls+hsInfixDecl sloc fixity hsnames = base $ HsInfixDecl sloc fixity hsnames+hsPrimitiveTypeDecl sloc c name = base $ HsPrimitiveTypeDecl sloc c name +hsPrimitiveBind sloc name t     = base $ HsPrimitiveBind sloc name t++hsId n                      = base $ HsId n+hsEVar name                 = base $ HsId $ HsVar name+hsECon name                 = base $ HsId $ HsCon name+hsLit sloc lit              = base $ HsLit sloc lit+hsInfixApp e1 op e2         = base $ HsInfixApp e1 op e2+hsApp e1 e2                 = base $ HsApp e1 e2+hsNegApp s e                = base $ HsNegApp s e+hsLambda pats e             = base $ HsLambda pats e+hsLet decls e               = base $ HsLet decls e+hsIf e1 e2 e3               = base $ HsIf e1 e2 e3+hsCase e alts               = base $ HsCase e alts+hsDo stmts                  = base $ HsDo stmts+hsTuple exps                = base $ HsTuple exps+hsList exps                 = base $ HsList exps+hsParen e                   = base $ HsParen e+hsLeftSection e op          = base $ HsLeftSection  e op+hsRightSection op e         = base $ HsRightSection op e+hsRecConstr sloc name fupds = base $ HsRecConstr sloc name fupds+hsRecUpdate sloc e fupds    = base $ HsRecUpdate sloc e fupds+hsEnumFrom e                = base $ HsEnumFrom e+hsEnumFromTo e1 e2          = base $ HsEnumFromTo e1 e2+hsEnumFromThen e1 e2        = base $ HsEnumFromThen e1 e2+hsEnumFromThenTo e1 e2 e3   = base $ HsEnumFromThenTo e1 e2 e3+hsListComp stms             = base $ HsListComp stms+hsExpTypeSig sloc e c t     = base $ HsExpTypeSig sloc e c t+hsAsPat hname e             = base $ HsAsPat hname e+hsWildCard                  = base  HsWildCard+hsIrrPat e                  = base $ HsIrrPat e++-- Pat building+hsPId n                     = base $ HsPId n+hsPVar n                    = base $ HsPId $ HsVar n+hsPCon n                    = base $ HsPId $ HsCon n+hsPLit sloc lit             = base $ HsPLit sloc lit+hsPNeg sloc lit             = base $ HsPNeg sloc lit+hsPSucc sloc n lit          = base $ HsPSucc sloc n lit+hsPInfixApp p1 op p2        = base $ HsPInfixApp p1 op p2+hsPApp hname pats           = base $ HsPApp hname pats+hsPTuple sloc pats          = base $ HsPTuple sloc pats+hsPList sloc pats           = base $ HsPList sloc pats+hsPParen p                  = base $ HsPParen p+hsPRec hname patfields      = base $ HsPRec hname patfields+hsPAsPat hname p            = base $ HsPAsPat hname p+hsPWildCard                 = base  HsPWildCard+hsPIrrPat p                 = base $ HsPIrrPat p+++-- Kind building+kstar      = base Kstar+kpred      = base Kpred+karrow x y = base (Kfun x y)+kprop      = base Kprop -- P-Logic++-- Type building+hsTyFun t1 t2 = base $ HsTyFun t1 t2+--hsTyTuple ts = base $ HsTyTuple ts+hsTyTuple ts  = foldl hsTyApp (hsTyCon (tuple_tycon_name (length ts-1))) ts+hsTyApp f x   = base $ HsTyApp f x+hsTyVar name  = base $ HsTyVar name+hsTyCon name  = base $ HsTyCon name+hsTyForall xs ps t = base $ HsTyForall xs ps t++hsTyId (HsCon c) = hsTyCon c+hsTyId (HsVar v) = hsTyVar v+++-- Added because of the stupid monomorphism restriction:+hsWildCard   :: HasBaseStruct exp (EI i e p ds t c) => exp+hsPWildCard  :: HasBaseStruct pat (PI i p) => pat+kstar, kpred, kprop :: HasBaseStruct kind (K k) => kind
+ tools/base/AST/HsAssoc.hs view
@@ -0,0 +1,4 @@+module HsAssoc(module A) where+import HsAssocStruct as A+import HsAssocPretty as A+import HsAssocUtil as A
+ tools/base/AST/HsAssocInitEnv.hs view
@@ -0,0 +1,20 @@+module HsAssocInitEnv where+import HsAssoc+import HsName++-- Fixities for an ad hoc selection of operators from the Prelude, for testing.+initEnv =+    foldl extend emptyOE+      [l 6 "+",+       l 7 "*",+       l 6 "-",+       r 0 "$",+       r 5 ":",+       r 5 "++",+       n 6 ":+"]+    where+      nm s = UnQual s+      i a p n = (nm n,HsFixity a p)+      l = i HsAssocLeft+      r = i HsAssocRight+      n = i HsAssocNone
+ tools/base/AST/HsAssocPretty.hs view
@@ -0,0 +1,12 @@+module HsAssocPretty where+import HsAssocStruct+import PrettyPrint++instance Printable HsFixity where+    ppi (HsFixity assoc n) = assoc <+> lit n++instance Printable HsAssoc where+    ppi HsAssocNone  = kw "infix"+    ppi HsAssocLeft  = kw "infixl"+    ppi HsAssocRight = kw "infixr"+
+ tools/base/AST/HsAssocStruct.hs view
@@ -0,0 +1,12 @@+module HsAssocStruct where++import Data.Generics++-- Formerly known as InfixAssoc...+data HsFixity = HsFixity HsAssoc Int deriving (Ord,Eq,Show,Read, Data, Typeable)++data HsAssoc+    = HsAssocNone+    | HsAssocLeft+    | HsAssocRight+      deriving (Ord, Eq, Show, Read, Data, Typeable)
+ tools/base/AST/HsAssocUtil.hs view
@@ -0,0 +1,41 @@+module HsAssocUtil where+import Maybe(fromMaybe)+import HsAssocStruct++{-+class InfixEnv i env | env->i where+    extend :: env -> (i,HsFixity) -> env+    extend2 :: env -> env -> env+    defaultOps :: env -> [i] -> env+    lookUp :: env -> i -> Maybe HsFixity+-}+    +newtype OperatorEnv i = OperatorEnv [(i,HsFixity)] deriving (Show)++unOE (OperatorEnv e) = e+emptyOE = OperatorEnv []++--instance Eq i => InfixEnv i (OperatorEnv i) where+extend (OperatorEnv env) i = OperatorEnv (i: env)+extend2 (OperatorEnv env1) (OperatorEnv env2) = OperatorEnv (env2++env1)+defaultOps (OperatorEnv env) ns =+      OperatorEnv [f|f@(i,_)<-env,i `notElem` ns]+lookUp (OperatorEnv env) n = lookup n env++getFixity env = fromMaybe defaultFixity . lookUp env +defaultFixity = HsFixity HsAssocLeft 9 -- See Haskell 98 Report, Section 4.4.2++-- Dubious functions, should be removed:+--getPrec env name  = case getFixity env name of HsFixity a p->p+--getAssoc env name = case getFixity env name of HsFixity a p->a+{- old verions:+getPrec env name  =+    case (lookUp env name) of +      Just (HsFixity a p) -> p+      Nothing            -> 9 -- See the Report, section 4.4.2++getAssoc env name =+    case lookUp env name of +      Just (HsFixity a p)  -> a+      Nothing             -> HsAssocLeft -- See the Report, section 4.4.2+-}
+ tools/base/AST/HsConstants.hs view
@@ -0,0 +1,63 @@+{-++All of the built-in entities that don't contain any recursive parts (mainly+names). +-}+module HsConstants(module HsConstants,module SpecialNames,HsName) where++import HsName+import HsIdent+import SpecialNames+++-- The module that is implicitly imported in all modules: ----------------------+prelude_mod_name' = "Prelude"+mod_Prelude'      = plainModule prelude_mod_name'+++-- Module names for constructing original names of standard entities: ----------+--{ -+-- For use with PFE libraries:+mod_Prelude      = plainModule "Prelude"+mod_PreludeList  = plainModule "PreludeList"+mod_PreludeText  = plainModule "PreludeText"+mod_Ix	   = plainModule "Ix"+--}++{-+-- For use with Hugs libraries:+mod_Prelude      = plainModule "Hugs.Prelude"+mod_PreludeList  = mod_Prelude+mod_PreludeText  = mod_Prelude+mod_Ix		 = mod_Prelude+--}++--------------------------------------------------------------------------------++--prelude_mod         = mod_Prelude -- retained for backward compatibility++main_mod path       = moduleName path "Main"++--qualify path m v         = Qual (moduleName path m) v+tuple n            = "(" ++ replicate n ',' ++ ")"        ++unit_con_name       = Qual mod_Prelude "()"+tuple_con_name n    = Qual mod_Prelude $ tuple n++main_name           = UnQual "main"++unit_tycon_name     = unit_con_name++instance HasSpecialNames HsName where+  fun_tycon_name      = Qual mod_Prelude "->"+  list_tycon_name     = Qual mod_Prelude "[]"+  char_tycon_name     = Qual mod_Prelude "Char"+  tuple_tycon_name n  = tuple_con_name n++ +instance IsSpecialName HsName where+  is_list_tycon_name  = std_is_list_tycon_name+  is_fun_tycon_name   = std_is_fun_tycon_name+  is_char_tycon_name  = std_is_char_tycon_name+  is_tuple_tycon_name = std_is_tuple_tycon_name++is_unit_tycon_name n = n==unit_tycon_name
+ tools/base/AST/HsDecl.hs view
@@ -0,0 +1,7 @@++module HsDecl(module D) where++import HsDeclStruct as D+import HsDeclPretty as D+import HsDeclMaps as D+import HsDeclUtil as D
+ tools/base/AST/HsDeclMaps.hs view
@@ -0,0 +1,183 @@+-- $Id: HsDeclMaps.hs,v 1.20 2004/01/22 21:21:46 hallgren Exp $++{-++  Maps for the D functor.++-}++module HsDeclMaps where++import HsDeclStruct+--import HsGuardsStruct+import HsGuardsMaps(mapRhs, accRhs, seqRhs)+import AccList(accList)+import HsIdent+import MUtils+++mapDI idf = mapDI2 idf idf++mapDI2 :: (i1 -> i2) ->           -- variable identifier recursion function +          (i1 -> i2) ->           -- constructor identifier recursion function +          (e1 -> e2) ->           -- expression recursion function+          (p1 -> p2) ->           -- pattern recursion function+          (d1 -> d2) ->           -- declaration recursion function+          (t1 -> t2) ->           -- type recursion function+          (c1 -> c2) ->           -- context recursion function+          (tp1 -> tp2) ->         -- type pattern recursion function+          DI i1 e1 p1 d1 t1 c1 tp1 -> -- old declaration structure+          DI i2 e2 p2 d2 t2 c2 tp2    -- new declaration structure+mapDI2 vf cf ef pf df tf ctxf tpf decl =+  case decl of+    HsTypeDecl s tp t              -> HsTypeDecl s (tpf tp) (tf t)+    HsNewTypeDecl s cntxt tp cd ns -> HsNewTypeDecl s (ctxf cntxt) (tpf tp)+                                     (mapConDeclI2 vf cf tf ctxf cd) (map cf ns)+    HsDataDecl s cntxt tp cds ns   -> HsDataDecl s (ctxf cntxt) (tpf tp)+                              (map (mapConDeclI2 vf cf tf ctxf) cds) (map cf ns)+    HsClassDecl s c tp fundeps ds   -> HsClassDecl s (ctxf c) (tpf tp)+				                (mapFunDeps vf fundeps) (df ds)+    HsInstDecl s optn c tp ds       -> HsInstDecl s (fmap vf optn) (ctxf c)+						  (tf tp) (df ds)+    HsDefaultDecl s t               -> HsDefaultDecl s (map tf t) +    HsTypeSig s nms c tp            -> HsTypeSig s (map vf nms) (ctxf c) (tf tp)+    HsFunBind s ms                  -> HsFunBind s +                                            (map (mapMatchI vf ef pf df) ms) +    HsPatBind s p rhs ds            -> HsPatBind s (pf p) (mapRhs ef rhs)+                                                                    (df ds)+    HsInfixDecl s fixity names      -> HsInfixDecl s fixity (map (mapHsIdent2 vf cf) names)+    +    -- Hugs compatibility+    HsPrimitiveTypeDecl s cntxt tp  -> HsPrimitiveTypeDecl s (ctxf cntxt) (tpf tp)+    HsPrimitiveBind s nm tp         -> HsPrimitiveBind s (vf nm) (tf tp)++mapMatch = mapMatchI id+mapMatchI vf ef pf df (HsMatch s nm ps rhs ds)+    = HsMatch s (vf nm) (map pf ps) (mapRhs ef rhs) (df ds)++mapConDecl = mapConDeclI id+mapConDeclI idf = mapConDeclI2 idf idf+mapConDeclI2 vf cf tf ctxf (HsConDecl s is c nm bangts)+    = HsConDecl s (map vf is) (ctxf c) (cf nm) (map (mapBangType tf) bangts)+mapConDeclI2 vf cf tf ctxf (HsRecDecl s is c nm nmbangts)+    = HsRecDecl s (map vf is) (ctxf c) (cf nm) (map f nmbangts)+  where+    f (n,bt)    = (map vf n, mapBangType tf bt)+ +mapBangType tf (HsBangedType x)   = HsBangedType (tf x)+mapBangType tf (HsUnBangedType x) = HsUnBangedType (tf x)+++{-++   Accumulator for the D functor.++-}++accDI ::(i -> b -> b) ->  -- identifier recursion operator+        (e -> b -> b) ->  -- expression recursion operator+        (p -> b -> b) ->  -- pattern recursion operator+        (d -> b -> b) ->  -- declaration recursion operator+        (t -> b -> b) ->  -- type recursion operator+        (c -> b -> b) ->  -- context recursion operator+        (tp -> b -> b) -> -- type pattern recursion operator+	DI i e p d t c tp ->     -- declaration structure+        b ->              -- base case+        b+accDI idf ef pf df tf cf tpf decl =+    case decl of+    HsTypeDecl s tp t                  -> tpf tp . tf t +    HsNewTypeDecl s cntxt tp cd names  -> cf cntxt . tpf tp +                                        . accConDeclI idf tf cf cd +    HsDataDecl s cntxt tp cds names    -> cf cntxt . tpf tp +                                        . accList (accConDeclI idf tf cf) cds +    HsClassDecl s c tp fundeps ds       -> cf c . tpf tp+					. accFunDeps idf fundeps . df ds+    HsInstDecl s optn c tp ds           -> maybe id idf optn . cf c . tf tp . df ds+    HsDefaultDecl s t                   -> accList tf t +    HsTypeSig s nms c tp                -> accList idf nms . cf c . tf tp +    HsFunBind s ms                      -> accList (accMatchI idf ef pf df) ms+    HsPatBind s p rhs ds                -> pf p . accRhs ef rhs . df ds+    HsInfixDecl s fixity ns             -> accList (accHsIdent idf) ns++    -- Hugs compatibility+    HsPrimitiveTypeDecl s cntxt tp      -> cf cntxt . tpf tp+    HsPrimitiveBind s nm tp             -> idf nm . tf tp++accD = accDI (curry snd)+++accMatch = accMatchI (const id)++accMatchI idf ef pf df (HsMatch s nm ps rhs ds) +    = idf nm . accList pf ps . accRhs ef rhs . df ds++accConDecl = accConDeclI (const id)++accConDeclI idf tf ctxf (HsConDecl s is c nm bangts) +    = idf nm . accList idf is . ctxf c . accList (accBangType tf) bangts +accConDeclI idf tf ctxf (HsRecDecl s is c nm nmbangts) +    = idf nm . accList idf is . ctxf c . accList f nmbangts +    where+    f (n,bt) = accList idf n . accBangType tf bt+          +accBangType tf (HsBangedType x) ans   = tf x ans+accBangType tf (HsUnBangedType x) ans = tf x ans        ++++--- in preparation for the D functor monadic trifecta ++seqDI :: (Functor m,Monad m) =>+        -- declaration structure containing computations:+        DI(m i)+          (m e)     --   ... delivering expression recursion+          (m p)     --   ... delivering pattern recursion+          (m d)     --   ... delivering declaration recursion+          (m t)     --   ... delivering type recursion+          (m c)     --   ... delivering context recursion+          (m tp) -> --   ... delivering type pattern recursion+        m (DI i e p d t c tp) -- computation delivering declaration structure+seqDI decl =+    case decl of+    HsTypeDecl s tp t           -> HsTypeDecl s # tp <# t+    HsNewTypeDecl s c tp cd nms ->+        HsNewTypeDecl s # c <# tp <# seqConDecl cd <# sequence nms+    HsDataDecl s c tp cds nms   ->+        HsDataDecl s # c <# tp <# mapM seqConDecl cds <# sequence nms+    HsClassDecl s c tp fundeps ds -> HsClassDecl s # c <# tp <# seqFunDeps fundeps <# ds+    HsInstDecl s optn c tp ds   -> HsInstDecl s # seqMaybe optn <# c <# tp <# ds+    HsDefaultDecl s t            -> HsDefaultDecl s # sequence t+    HsTypeSig s nms c tp         -> HsTypeSig s # sequence nms <# c <# tp+    HsFunBind s ms               -> HsFunBind s # mapM seqMatch ms+    HsPatBind s p rhs ds         -> HsPatBind s # p <# seqRhs rhs <# ds+    HsInfixDecl s fixity names   -> HsInfixDecl s fixity # mapM seqHsIdent names++    HsPrimitiveTypeDecl s c tp   -> HsPrimitiveTypeDecl s # c <# tp+    HsPrimitiveBind s nm tp      -> HsPrimitiveBind s # nm <# tp+            ++seqConDecl (HsConDecl sloc is c name bangtypes) = +  HsConDecl sloc # sequence is <# c <# name <# mapM seqBangType bangtypes+seqConDecl (HsRecDecl sloc is c name fields) = +  HsRecDecl sloc # sequence is <# c <# name <# mapM (sequence >#< seqBangType) fields++--mapSndM seqBangType fields+++seqBangType (HsBangedType t)   = HsBangedType # t+seqBangType (HsUnBangedType t) = HsUnBangedType # t++seqMatch (HsMatch sloc name bs rhs c) = +  HsMatch sloc # name <# sequence bs <# seqRhs rhs <# c+++mapFunDeps = map . mapFunDep+mapFunDep = apBoth . map++accFunDeps = accList . accFunDep++accFunDep tf (ts1,ts2) = accList tf ts1 . accList tf ts2++seqFunDeps fs = mapM seqFunDep fs+seqFunDep fd = sequence>#<sequence $ fd
+ tools/base/AST/HsDeclPretty.hs view
@@ -0,0 +1,88 @@+module HsDeclPretty (ppContext,ppFunDeps) where++import HsDeclStruct+import HsIdentPretty()+import HsAssocPretty()+import PrettySymbols(el,rarrow)+import PrettyPrint+import PrettyUtil(ppWhere,ppContext)+import HsGuardsPretty(ppRhs)+++instance (PrintableOp i,Printable e, Printable p, Printable ds,+	  Printable t, Printable c, Printable tp) =>+         Printable (DI i e p ds t c tp) where+    ppi (HsTypeDecl _ tp t)                  =+        sep [kw "type" <+> tp <+> equals, dataNest t ]+    ppi (HsNewTypeDecl _ c tp t ders)        =+        sep [kw "newtype" <+> (ppContext $ ppis c) <+> tp <+> equals,+	       dataNest $ sep [ppi t, ppDeriving ders] ]+    ppi (HsDataDecl _ c tp summands ders)    =+        sep [kw "data" <+> (ppContext $ ppis c) <+> tp,+               dataNest $ +	         sep [sep (zipWith (<+>) (equals : repeat (kw "|")) summands),+                      ppDeriving ders]]+    ppi (HsClassDecl _ c tp fundeps ds)               =+        sep [kw "class" <+> sep [ppContext $ ppis c, ppi tp, ppFunDeps fundeps],+             nest 2 $ ppWhere (ppis ds)]+    ppi (HsInstDecl _ optn c tp ds)                =+        sep [kw "instance" <+> sep [ppContext $ ppis c, ppi tp],+	     nest 2 $ ppWhere (ppis ds)]+    ppi (HsDefaultDecl _ t)                   =	kw "default" <+> ppiFTuple t+    ppi (HsTypeSig _ ns c t)                  =+	-- If they are printed vertically, every name except the first one+	-- must be indented...+        sep [hcat (punctuate comma (map wrap ns)),+	     letNest $  el <+> ppContext (ppis c) <+> t]+    ppi (HsFunBind _ ms)                      =  vcat ms+    ppi (HsPatBind _ p rhs ds)                =+        sep [wrap p, nest 2 $ sep [ppRhs equals rhs, ppWhere (ppis ds)]]+    ppi (HsInfixDecl _ fixity ops) =+	fixity <+> (fsep $ punctuate comma $ map ppiOp ops)++    ppi (HsPrimitiveTypeDecl _ ctx tp)       =+        kw "data" <+> ppContext (ppis ctx) <+> tp+    ppi (HsPrimitiveBind _ nm tp)            =+        kw "foreign" <+> kw "import" <+> wrap nm <+> el <+> tp++    wrap = ppi+++instance (Printable i,Printable e, Printable p, Printable ds) =>+         Printable (HsMatchI i e p ds) where+    ppi (HsMatch _ f ps rhs ds) +	= sep [wrap f <+> fsep (map wrap ps),+	       nest 2 $ sep [ppRhs equals rhs, ppWhere (ppis ds)]]++    wrap = ppi+++instance (PrintableOp i,Printable t,Printable c)+      => Printable (HsConDeclI i t c) where+    ppi (HsConDecl _ is c n [t1,t2]) | isOp n = ppiBinOp t1 (con (ppiOp n)) t2+    ppi (HsConDecl _ is c n ts) = con (wrap n) <+> (fsep $ map wrap ts)+    ppi (HsRecDecl _ is c n fs)+	= con (wrap n) <+> (braces $ ppiFSeq $ map ppField fs)+	  where ppField (ns, t) = wrapFSeq ns <+> el <+> t++    wrap = ppi+++instance Printable t => Printable (HsBangType t) where+    ppi (HsBangedType t)   = kw '!' <> wrap t+    ppi (HsUnBangedType t) = ppi t++    wrap (HsBangedType t)   = kw '!' <> wrap t+    wrap (HsUnBangedType t) = wrap t+++-- Pretty prints deriving clauses+--ppDeriving :: [HsName] -> Doc+ppDeriving []  = empty+ppDeriving [i] = kw "deriving" <+> tcon i+ppDeriving is  = kw "deriving" <+> ppiFTuple (map tcon is)++ppFunDeps [] = empty+ppFunDeps fs = kw '|' <+> ppiFSeq (map ppFunDep fs)++ppFunDep (ts1,ts2) = fsep ts1<>rarrow<>fsep ts2
+ tools/base/AST/HsDeclStruct.hs view
@@ -0,0 +1,56 @@++-------- Declarations ------------------------------------------------------++module HsDeclStruct where++import SrcLoc1+import HsIdent+import HsGuardsStruct+import HsAssocStruct++import Data.Generics++-- DI+--   i      identifiers+--   e      expression recursion type+--   p      pattern recursion type+--   ds     declaration recursion type+--   t      type recursion type+--   c      context recursion type+--   tp     type pattern recursion type+-- This type seems to be full of awkward inconsistencies... /TH+data DI i e p ds t c tp+    = HsTypeDecl    SrcLoc   tp t+    | HsNewTypeDecl SrcLoc c tp (HsConDeclI i t c) {-deriving-} [i]+    | HsDataDecl    SrcLoc c tp [HsConDeclI i t c] {-deriving-} [i]+    | HsClassDecl   SrcLoc c tp (HsFunDeps i) {-where-} ds+    | HsInstDecl    SrcLoc (Maybe i) c t {-where-} ds -- optionally named+    | HsDefaultDecl SrcLoc [t]+    | HsTypeSig     SrcLoc [i] c t+    | HsFunBind     SrcLoc [HsMatchI i e p ds]+    | HsPatBind     SrcLoc p (HsRhs e) {-where-} ds +    | HsInfixDecl   SrcLoc HsFixity [HsIdentI i] -- Haskell 98++    -- Hugs compatibility:+    | HsPrimitiveTypeDecl SrcLoc c tp -- data T a1 ... an;+    | HsPrimitiveBind     SrcLoc i t -- primitive f :: t+      deriving (Ord,Read, Eq, Show, Data, Typeable)++data HsMatchI i e p ds+    = HsMatch SrcLoc i [p] (HsRhs e) {-where-} ds   +      deriving (Ord,Read, Eq, Show, Data, Typeable)+  +data HsConDeclI i t c +    = HsConDecl SrcLoc [i] c i [HsBangType t]+    | HsRecDecl SrcLoc [i] c i [([i], HsBangType t)]+      deriving (Ord,Read, Eq, Show, Data, Typeable)   +   +data HsBangType t +    = HsBangedType t+    | HsUnBangedType t+      deriving (Ord,Read, Eq, Show, Data, Typeable)   ++type HsFunDeps v = [HsFunDep v] -- ..., a b-> c d,f->g h, ->i, ...+type HsFunDep v = ([v],[v]) -- a b-> c d++
+ tools/base/AST/HsDeclUtil.hs view
@@ -0,0 +1,81 @@+module HsDeclUtil where++import HsDeclStruct+import HsDeclMaps+--import MUtils+--import HsGuardsMaps+import SrcLoc1+import SrcLocPretty+import PrettyPrint(pp)++-- Finds all of the free variables in a D structure.++freeVarsD fvd fve d = +    accD (++) (++) (++) (++) (++) (++) +         (mapDI id fve (const [])+	           (concatMap fvd)+	           (const [])+	           (const [])+	           (const [])+	  d)+	 []+++-- Rewrite expressions inside declarations given fixity information.++rewriteD rwe env d = mapDI id (rwe env) id id id id id d++-- New version: rewrite expressions and patterns,+-- and also recurse into nested declarations.+rewriteAllD rwe rwp rwds = mapDI id rwe rwp rwds id id id++fixitiesD ds =[(n,fixity) | HsInfixDecl _ fixity ns<-ds, n<-ns]+++instance HasSrcLoc (DI i e p ds t c tp) where+  srcLoc d =+    case d of+      HsTypeDecl s tps t                 -> s+      HsNewTypeDecl s cntxt tps cd names -> s+      HsDataDecl s cntxt tps cds names   -> s+      HsClassDecl s c tp fd ds           -> s+      HsInstDecl s optn c tp ds          -> s+      HsDefaultDecl s t                  -> s+      HsTypeSig s nms c tp               -> s+      HsFunBind s matches                -> s+      HsPatBind s p rhs ds               -> s+      HsInfixDecl s fixity names         -> s++      HsPrimitiveBind s nm t             -> s+      HsPrimitiveTypeDecl s cntxt nm     -> s+++instance HasSrcLoc (HsMatchI i e p ds) where+    srcLoc (HsMatch s _ _ _ _) = s++unbang bt = accBangType const bt ()++conargcnt con =+  case con of+    HsConDecl s _ _ c args -> length args+    HsRecDecl s _ _ c fields -> sum (map (length.fst) fields)++conctx con =+  case con of+    HsConDecl s _ ctx c args -> ctx+    HsRecDecl s _ ctx c fields -> ctx++instance HasSrcLoc (HsConDeclI i t c) where+  srcLoc con =+    case con of+      HsConDecl s _ _ c argrs -> s+      HsRecDecl s _ _ c fields -> s++chkNewtype con =+  if conargcnt con==1+  then if null (conctx con)+       then return ()+       else fail $ pp (srcLoc con)+++                   ": existential newtype constructors can't have a context"+  else fail $ pp (srcLoc con)+++	      ": a newtype constructor must have exactly one argument"
+ tools/base/AST/HsExp.hs view
@@ -0,0 +1,7 @@++module HsExp(module E) where++import HsExpStruct as E+import HsExpPretty as E+import HsExpMaps as E+import HsExpUtil as E
+ tools/base/AST/HsExpMaps.hs view
@@ -0,0 +1,149 @@+------- Maps for the E functor.++module HsExpMaps where++import HsExpStruct+import HsIdent+import HsGuardsMaps(mapAlt, accAlt, seqAlt)+import HsFieldsMaps+import AccList(accList)+import MUtils++mapEI idf = mapEI2 idf idf++mapEI2 :: (i1 -> i2) -> +          (i1 -> i2) -> +          (e1 -> e2) ->+          (p1 -> p2) ->+          (d1 -> d2) ->+          (t1 -> t2) ->+          (c1 -> c2) ->+          EI i1 e1 p1 d1 t1 c1 ->+          EI i2 e2 p2 d2 t2 c2+mapEI2 vf cf ef pf df tf ctxf exp =+  case exp of+    HsId n                 -> HsId (mapHsIdent2 vf cf n)+    HsLit s l              -> HsLit s l+    HsInfixApp x op z      -> HsInfixApp (ef x) (mapHsIdent2 vf cf op) (ef z)+    HsApp x y              -> HsApp (ef x) (ef y)+    HsNegApp s x           -> HsNegApp s (ef x)  +    HsLambda ps e          -> HsLambda (map pf ps) (ef e)+    HsLet ds e             -> HsLet (df ds) (ef e)+    HsIf x y z             -> HsIf (ef x) (ef y) (ef z) +    HsCase e alts          -> HsCase (ef e) (map (mapAlt ef pf df) alts) +    HsDo stmts             -> HsDo (mStmt stmts)+    HsTuple xs             -> HsTuple (map ef xs)+    HsList xs              -> HsList (map ef xs)+    HsParen x              -> HsParen (ef x) +    HsLeftSection x op     -> HsLeftSection (ef x) (mapHsIdent2 vf cf op)+    HsRightSection op y    -> HsRightSection (mapHsIdent2 vf cf op) (ef y) +    HsRecConstr s n upds   -> HsRecConstr s (cf n) (mapFieldsI vf ef upds)+    HsRecUpdate s e upds   -> HsRecUpdate s (ef e) (mapFieldsI vf ef upds)+    HsEnumFrom x           -> HsEnumFrom (ef x) +    HsEnumFromTo x y       -> HsEnumFromTo (ef x) (ef y) +    HsEnumFromThen x y     -> HsEnumFromThen (ef x) (ef y) +    HsEnumFromThenTo x y z -> HsEnumFromThenTo (ef x) (ef y) (ef z)+    HsListComp stmts       -> HsListComp (mStmt stmts)+    HsExpTypeSig s e c t   -> HsExpTypeSig s (ef e) (ctxf c) (tf t)+    HsAsPat n e            -> HsAsPat (vf n) (ef e)  -- pattern only+    HsWildCard             -> HsWildCard        -- ditto+    HsIrrPat e             -> HsIrrPat (ef e)   -- ditto+  where+    mStmt = mapStmt ef pf df++mapStmt ef pf df stmt =+  case stmt of+    HsGenerator loc p e s -> HsGenerator loc (pf p) (ef e) (m s)+    HsQualifier e s       -> HsQualifier (ef e) (m s)+    HsLetStmt ds s        -> HsLetStmt (df ds) (m s)+    HsLast e              -> HsLast (ef e)+  where+    m = mapStmt ef pf df++-- Accumulator for the E functor.++accEI ::(i -> b -> b) ->+        (e -> b -> b) ->+        (p -> b -> b) ->+        (d -> b -> b) ->+        (t -> b -> b) ->+        (c -> b -> b) ->+        EI i e p d t c ->+        b ->+        b+accEI idf ef pf df tf cf exp =+    case exp of+    HsId n                 -> accHsIdent idf n +    HsLit s l              -> id+    HsInfixApp x op z      -> ef x . accHsIdent idf op . ef z +    HsApp x y              -> ef x . ef y +    HsNegApp s x           -> ef x  +    HsLambda ps e          -> ef e . accList pf ps +    HsLet ds e             -> ef e . df ds +    HsIf x y z             -> ef x . ef y . ef z +    HsCase e alts          -> ef e . accList (accAlt ef pf df) alts +    HsDo stmts             -> accStmt df ef pf stmts +    HsTuple xs             -> accList ef xs +    HsList xs              -> accList ef xs +    HsParen x              -> ef x  +    HsLeftSection x op     -> ef x . accHsIdent idf op  +    HsRightSection op y    -> accHsIdent idf op . ef y +    HsRecConstr s n upds   -> idf n . accFieldsI idf ef upds +    HsRecUpdate s e upds   -> ef e .  accFieldsI idf ef upds   +    HsEnumFrom x           -> ef x +    HsEnumFromTo x y       -> ef x . ef y  +    HsEnumFromThen x y     -> ef x . ef y  +    HsEnumFromThenTo x y z -> ef x . ef y . ef z +    HsListComp stmts       -> accStmt df ef pf stmts +    HsExpTypeSig s e c t   -> ef e . cf c . tf t ++    HsAsPat n e            -> idf n . ef e  -- pattern only+    HsWildCard             -> id            -- ditto+    HsIrrPat e             -> ef e          -- ditto++accStmt df ef pf (HsGenerator _ p e s)    = pf p . ef e . accStmt df ef pf s+accStmt df ef pf (HsQualifier e s)      = ef e . accStmt df ef pf s+accStmt df ef pf (HsLetStmt ds s)       = df ds . accStmt df ef pf s+accStmt df ef pf (HsLast e)             = ef e ++---------+++seqEI :: (Monad m,Functor m) =>+        EI (m i) (m e) (m p) (m ds) (m t) (m c) ->+        m (EI i e p ds t c)+seqEI exp =+    case exp of+    HsId n                 -> HsId # seqHsIdent n+    HsLit s l              -> return $ HsLit s l+    HsInfixApp x op z      -> HsInfixApp # x <# seqHsIdent op <# z+    HsApp x y              -> HsApp # x <# y+    HsNegApp s x           -> HsNegApp s # x+    HsLambda ps e          -> HsLambda # sequence ps <# e+    HsLet ds e             -> HsLet # ds <# e+    HsIf x y z             -> HsIf # x <# y <# z+    HsCase e alts          -> HsCase # e <# mapM seqAlt alts+    HsDo stmts             -> HsDo # seqStmt stmts +    HsTuple xs             -> HsTuple # sequence xs+    HsList xs              -> HsList # sequence xs+    HsParen x              -> HsParen # x+    HsLeftSection x op     -> HsLeftSection # x <# seqHsIdent op +    HsRightSection op y    -> HsRightSection # seqHsIdent op <# y+    HsRecConstr s n upds   -> HsRecConstr s # n <# seqFieldsI upds+    HsRecUpdate s e upds   -> HsRecUpdate s # e <# seqFieldsI upds+    HsEnumFrom x           -> HsEnumFrom # x+    HsEnumFromTo x y       -> HsEnumFromTo # x <# y+    HsEnumFromThen x y     -> HsEnumFromThen # x <# y+    HsEnumFromThenTo x y z -> HsEnumFromThenTo # x <# y <# z+    HsListComp stmts       -> HsListComp # seqStmt stmts+    HsExpTypeSig s e c t   -> HsExpTypeSig s # e <# c <# t++    HsAsPat n e            -> HsAsPat # n <# e    -- pattern only+    HsWildCard             -> return HsWildCard   -- ditto+    HsIrrPat e             -> HsIrrPat # e        -- ditto+++seqStmt (HsGenerator loc p e s) = HsGenerator loc # p <# e <# seqStmt s+seqStmt (HsQualifier e s)   = HsQualifier # e <# seqStmt s+seqStmt (HsLetStmt ds s)    = HsLetStmt # ds <# seqStmt s+seqStmt (HsLast e)          = HsLast # e
+ tools/base/AST/HsExpPretty.hs view
@@ -0,0 +1,97 @@+-- Pretty printing for the E functor.++module HsExpPretty () where++import HsExpStruct+import HsGuardsPretty()+import HsFieldsPretty()+import HsLiteralPretty()+import HsExpUtil(getStmtList,HsStmtAtom(..))+import HsDeclPretty(ppContext)+import PrettyPrint+import PrettySymbols(lambda,larrow,rarrow,el)+import HsIdent+import HsIdentPretty++instance (PrintableOp i,Printable e, Printable p, Printable ds, Printable t, Printable c) =>+         Printable (EI i e p ds t c) where+  ppi e =+    case e of+      HsId n                 -> ppcon wrap n+      HsLit s l              -> lit l+      HsInfixApp x op z      -> ppiBinOp (wrap x) (ppconop ppiOp op) (wrap z)+--    HsInfixApp x op z      -> parenBinOp x (ppcon ppiOp op) z -- problem?++      -- if x is a lambda it need parens, but the parser preserves parens!+      HsApp x y              -> sep [ ppi x, letNest (wrap y) ]+      HsNegApp s x           -> '-' <> x+      HsLambda ps e          -> sep [ lambda <+> sep (map wrap ps) <+>+					rarrow, letNest e ]+      HsLet ds e             -> sep [kw "let" <+> ds, kw "in" <+> letNest e]+      HsIf x y z             -> sep [kw "if" <+> x,+				     doElseNest (kw "then"<+>y),+				     doElseNest (kw "else"<+>z)]+      HsCase e alts          -> kw "case" <+>  e <+> kw "of"+				 $$ (caseNest $ layout alts)+      HsDo stmts             -> kw "do" <+> (doNotation $ ppi stmts)+      HsTuple xs             -> ppiFTuple xs+      HsList xs              -> ppiList xs+      HsParen x              -> wrap x+      HsLeftSection x op     -> parens $ x <+> ppcon ppiOp op+      HsRightSection op y    -> parens $ ppcon ppiOp op <+> y+--    HsRecConstr s n []     -> ppi n -- "A {}" is NOT the same as "A"!!+      HsRecConstr s n upds   -> con n <+> braces upds+      HsRecUpdate s e []     -> ppi e -- never happens with expressions+				       -- that pass static analysis+      HsRecUpdate s e upds   -> e <+> braces upds+      HsEnumFrom x           -> brackets $ x <+> kw ".."+      HsEnumFromTo x y       -> brackets $ x <+> kw ".." <+> y+      HsEnumFromThen x y     -> brackets $ x <> comma <+> y <+> kw ".."+      HsEnumFromThenTo x y z -> brackets $ x <> comma <+> y <+> kw ".." <+> z+      HsListComp stmts       -> ppiListComp $ map ppi $ getStmtList stmts+	where+	  ppiListComp es =+            brackets $ last es <+> '|' <+> (fsep $ punctuate comma (init es))+      HsExpTypeSig s e c t   -> e <+> kw el <+> (ppContext $ ppis c) <+> t+      HsAsPat n p            -> n <+> kw '@' <+> wrap p+      HsWildCard             -> kw '_'+      HsIrrPat p             -> kw '~' <> wrap p++  wrap e =+    case e of+      HsId n                -> ppcon wrap n+      HsLit s l             -> lit l+      HsTuple xs            -> ppi e+      HsList xs             -> ppi e+      HsParen x             -> wrap x+      HsLeftSection x op    -> ppi e+      HsRightSection op y   -> ppi e+      HsRecConstr s n _     -> ppi e+      HsRecUpdate s e []    -> wrap e -- never happens with expressions+					 -- that pass static analysis+      HsEnumFrom x          -> ppi e+      HsEnumFromTo x y      -> ppi e+      HsEnumFromThen x y    -> ppi e+      HsEnumFromThenTo x y z-> ppi e+      HsListComp stmts      -> ppi e+      HsAsPat n p           -> ppi e+      HsWildCard            -> kw '_'+      _ -> parens e    ++instance (Printable e, Printable p, Printable ds)+         => Printable (HsStmt e p ds) where+    ppi = layout . map ppi . getStmtList+    --ppi = vcat . getStmtList++    wrap (HsLast e) = wrap e+    wrap s          = parens $ ppi s++instance (Printable e, Printable p, Printable ds)+         => Printable (HsStmtAtom e p ds) where+    ppi (HsGeneratorAtom _ p e) = p <+> larrow <+> e+    ppi (HsQualifierAtom e)   = ppi e+    ppi (HsLetStmtAtom ds)    = kw "let" <+> ds+    ppi (HsLastAtom e)        = ppi e++    wrap (HsLastAtom e) = wrap e+    wrap s              = parens s
+ tools/base/AST/HsExpStruct.hs view
@@ -0,0 +1,79 @@+module HsExpStruct where++import SrcLoc1+import HsIdent+import HsLiteral+import HsGuardsStruct(HsAlt)+import HsFieldsStruct++import Data.Generics++-------- Expressions --------------------------------------------------------++data EI i e p ds t c+    = HsId (HsIdentI i) -- collapsing HsVar and HsCon+    | HsLit SrcLoc HsLiteral+    | HsInfixApp e (HsIdentI i) e+    | HsApp e e+    | HsNegApp SrcLoc e+    | HsLambda [p] e+    | HsLet ds e+    | HsIf e e e+    | HsCase e [HsAlt e p ds]+    | HsDo (HsStmt e p ds)+    | HsTuple [e]+    | HsList [e]+    | HsParen e+    | HsLeftSection e (HsIdentI i)+    | HsRightSection (HsIdentI i) e+    | HsRecConstr SrcLoc i (HsFieldsI i e) -- qcon { fbind1, ..., fbindn }+    | HsRecUpdate SrcLoc e (HsFieldsI i e) -- exp_<qcon> { fbind1, ..., fbindn }+    | HsEnumFrom e+    | HsEnumFromTo e e+    | HsEnumFromThen e e+    | HsEnumFromThenTo e  e e+    | HsListComp (HsStmt e p ds)+    | HsExpTypeSig SrcLoc e c t+    --------------------------------+    | HsAsPat i e   -- pattern only+    | HsWildCard         -- ditto+    | HsIrrPat e         -- ditto+      deriving (Read, Show, Data, Typeable, Ord)++instance (Eq i, Eq e, Eq p, Eq ds, Eq t , Eq c) => Eq (EI i e p ds t c) where+  HsId i                == HsId i1                    = i == i1+  HsLit _ l             == HsLit _ l1                 = l == l1+  HsInfixApp x op z     == HsInfixApp x1 op1 z1       = x==x1  && op == op1 && z == z1+  HsApp x y             == HsApp x1 y1                = x == x1 && y == y1+  HsNegApp _ x          == HsNegApp _ x1              = x == x1+  HsLambda ps e         == HsLambda ps1 e1            = ps ==ps1 && e == e1+  HsLet ds e            == HsLet ds1 e1               = ds == ds1 && e == e1+  HsIf x y z            == HsIf x1 y1 z1              = x==x1 && y==y1 && z==z1+  HsCase e alts         == HsCase e1 alts1            = e == e1 && alts == alts1+  HsDo stmts            == HsDo stmts1                = stmts == stmts1+  HsTuple xs            == HsTuple xs1                = xs == xs1+  HsList xs             == HsList xs1                 = xs == xs1+  HsParen x             == HsParen x1                 = x == x1+  HsLeftSection x op    == HsLeftSection x1 op1       = x == x1 && op == op1+  HsRightSection op y   == HsRightSection op1 y1      = op == op1 && y == y1+  HsRecConstr _ n upds    == HsRecConstr _ n1 upds1       = n == n1 && upds == upds1+  HsRecUpdate _ e upds    == HsRecUpdate _ e1 upds1       = e == e1 && upds == upds1+  HsEnumFrom x          == HsEnumFrom x1              = x == x1+  HsEnumFromTo x y      == HsEnumFromTo x1 y1         = x == x1 && y==y1+  HsEnumFromThen x y    == HsEnumFromThen x1 y1       = x == x1 && y==y1+  HsEnumFromThenTo x y z== HsEnumFromThenTo x1 y1 z1  = x == x1 && y==y1 && z==z1+  HsListComp stmts      == HsListComp stmts1          = stmts == stmts1+  HsExpTypeSig _ e c t  == HsExpTypeSig _ e1 c1 t1    = e == e1 && c == c1 && t == t1+  HsAsPat n e           == HsAsPat n1 e1              = n == n1 && e == e1+  HsWildCard            == HsWildCard                 = True+  HsIrrPat e            == HsIrrPat e1                = e == e1+  _                     == _                          = False+ +data HsStmt e p ds+    = HsGenerator SrcLoc p e (HsStmt e p ds)+    | HsQualifier e (HsStmt e p ds)+    | HsLetStmt ds (HsStmt e p ds)+    | HsLast e+      deriving (Ord,Read, Eq, Show, Data, Typeable) ++
+ tools/base/AST/HsExpUtil.hs view
@@ -0,0 +1,107 @@+{-++Auxiliary E structure functions.+-}++module HsExpUtil where++import HsExpStruct+import HsIdent+import SrcLoc1(SrcLoc)+--import HsAssoc+import HsExpMaps(mapEI, accEI)+import MUtils(( # ))++-- Auxiliary type used during parsing&printing, not part of the abstract syntax:+data HsStmtAtom e p ds+    = HsGeneratorAtom SrcLoc p e+    | HsQualifierAtom e+    | HsLetStmtAtom ds+    | HsLastAtom e+      deriving (Eq, Show) ++atoms2Stmt [HsQualifierAtom e]        = return (HsLast e)+atoms2Stmt (HsGeneratorAtom s p e : ss) = HsGenerator s p e # atoms2Stmt ss+atoms2Stmt (HsLetStmtAtom ds : ss)    = HsLetStmt ds # atoms2Stmt ss+atoms2Stmt (HsQualifierAtom e : ss)   = HsQualifier e # atoms2Stmt ss+atoms2Stmt _ = fail "last statement in a 'do' expression must be an expression"++getStmtList (HsGenerator l p e s) = HsGeneratorAtom l p e : getStmtList s+getStmtList (HsQualifier e s)   = HsQualifierAtom e : getStmtList s+getStmtList (HsLetStmt ds s)    = HsLetStmtAtom ds : getStmtList s+getStmtList (HsLast e)          = [HsLastAtom e]++isHsIdVar e =+  case e of+    HsId (HsVar n) -> Just n+    _ -> Nothing++{-+isPatternE iscon isvar pef pe =+  case pe of +    HsId (HsVar n)              -> True+    HsTuple es                  -> all pef es+    HsWildCard                  -> True+    HsApp e1 e2 | iscon e1      -> pef e2+		| isvar e1      -> False+		| otherwise     -> pef e1 && pef e2+    HsList es                   -> all pef es+    HsInfixApp e1 (HsCon op) e2 -> pef e1 && pef e2+    HsParen e                   -> pef e   +    HsAsPat n e                 -> pef e+    HsRecConstr con fields      -> True+    _                           -> False+-}++{-+isFundefLhsE pef fdf pe p =+  case pe of  +    HsParen e                -> fdf e p+    HsId (HsVar n)           -> p+    HsApp l r                -> pef r && fdf l True+    HsInfixApp l (HsVar n) r -> pef l && pef r+    _                        -> False+-}++{-++Finds all of the free variables in an E structure.+-}+{-+freeVarsE fve e = +  case e of +    HsId (HsVar n) -> [n]+    _              -> accEI (const id) (++) (++) (++) (++) (++)+                           (mapEI id fve (const []) (const [])+			             (const []) (const [])+			    e)+		    []+-}++{- Obsolete...+reassociateE isinfix make undo rae rap rads env (HsInfixApp a op1 b) =+    let f  = getHSName op1+        a' = rae env a+    in+        if isinfix a' then+	    let (op2, c, d) = undo a'+                g           = getHSName op2+	    in+                if (getPrec env f) > (getPrec env g) || +		   ((getPrec env f == getPrec env g) && +                     (getAssoc env f == HsAssocRight && +                      getAssoc env g == HsAssocRight))+                then+		    HsInfixApp c op2 (rae env (make d op1 b))+		else+		    HsInfixApp a' op1 (rae env b)+	else+            HsInfixApp a' op1 b+reassociateE isinfix make undo rae rap rads env e =+    mapEI id (rae env) (rap env) (rads env) id id e+-}++{-+removeParensE make rp e = +  case e of +    HsParen e' -> rp e'+    _          -> make $ mapEI id rp id id id id e+-}
+ tools/base/AST/HsFields.hs view
@@ -0,0 +1,5 @@+-- Labelled fields, used in patterns and expressions+module HsFields(module F) where+import HsFieldsStruct as F+import HsFieldsMaps as F+import HsFieldsPretty as F
+ tools/base/AST/HsFieldsMaps.hs view
@@ -0,0 +1,15 @@+-- Labelled fields, used in patterns and expressions+module HsFieldsMaps where+import HsFieldsStruct+import MUtils+import AccList(accList)++--------------------------------------------------------------------------------+accFieldsI vf ef = accList (accFieldI vf ef)+accFieldI vf ef (HsField fnm e)    = vf fnm . ef e -- hmm, vf fnm++mapFieldsI vf ef = map (mapFieldI vf ef)+mapFieldI vf ef (HsField nm e) = HsField (vf nm) (ef e) -- hmm++seqFieldsI fs = mapM seqFieldI fs+seqFieldI (HsField nm e) = HsField # nm <# e
+ tools/base/AST/HsFieldsPretty.hs view
@@ -0,0 +1,8 @@+-- Labelled fields, used in patterns and expressions+module HsFieldsPretty where+import HsFieldsStruct+import PrettyPrint++instance (Printable i,Printable p) => Printable (HsFieldI i p) where+  ppi (HsField n p) = wrap n <+> equals <+> p+  ppiList = fsep . punctuate comma
+ tools/base/AST/HsFieldsStruct.hs view
@@ -0,0 +1,10 @@+-- Labelled fields, used in patterns and expressions+module HsFieldsStruct where++import Data.Generics++type HsFieldsI i e = [HsFieldI i e]++data HsFieldI i e = HsField i e deriving (Read, Eq, Show, Data, Typeable, Ord)   ++fieldName (HsField n _) = n
+ tools/base/AST/HsGuards.hs view
@@ -0,0 +1,7 @@++module HsGuards(module G) where++import HsGuardsStruct as G+import HsGuardsPretty as G+import HsGuardsMaps as G+import HsGuardsUtil as G
+ tools/base/AST/HsGuardsMaps.hs view
@@ -0,0 +1,23 @@+-- $Id: HsGuardsMaps.hs,v 1.7 2001/10/17 19:59:29 diatchki Exp $++module HsGuardsMaps where++import HsGuardsStruct+import AccList(accList)+import MUtils++mapAlt ef pf df (HsAlt s p rhs ds) = HsAlt s (pf p) (mapRhs ef rhs) (df ds)++mapRhs ef (HsBody x)   = HsBody (ef x)+mapRhs ef (HsGuard zs) = HsGuard (map (\(s, x, y) -> (s, ef x, ef y)) zs)+++accAlt ef pf df (HsAlt s p rhs ds) = pf p . accRhs ef rhs . df ds++accRhs ef (HsBody x)    = ef x +accRhs ef (HsGuard zs)  = accList (\(s, x, y)-> ef x . ef y) zs ++seqAlt (HsAlt s p rhs ds) = HsAlt s # p <# seqRhs rhs <# ds++seqRhs (HsBody x)   = HsBody # x+seqRhs (HsGuard zs) = HsGuard # mapM (\(s, x, y) -> (,,) s # x <# y) zs
+ tools/base/AST/HsGuardsPretty.hs view
@@ -0,0 +1,27 @@+module HsGuardsPretty where++import SrcLoc1+import HsGuardsStruct+import PrettySymbols(rarrow)+import PrettyUtil(ppWhere)+import PrettyPrint++-- Pretty printing for HsAlt+instance (Printable e, Printable p, Printable ds) =>+         Printable (HsAlt e p ds) where+    ppi (HsAlt s p rhs ds) =+      sep [ppi p,nest 2 $ sep [ppRhs rarrow rhs,ppWhere (ppis ds)]]+++-- added by cmb21+instance (Printable e) =>+         Printable (HsRhs e) where+   ppi r@(HsBody e) = ppRhs equals r+   ppi r@(HsGuard gs) = ppRhs equals r+++--ppRhs :: Printable e => Doc -> Doc -> HsRhs e -> Doc -> Doc+ppRhs to (HsBody e)   = nest 2 $ sep [ppi to, funNest e]+ppRhs to (HsGuard gs) = vcat $ map ppGuard gs+  where ppGuard (_, guard, body) =+	  nest 2 $ sep [ '|' <+> guard <+> to, funNest body]
+ tools/base/AST/HsGuardsStruct.hs view
@@ -0,0 +1,17 @@+-- $Id: HsGuardsStruct.hs,v 1.1 2001/07/25 01:15:30 moran Exp $++module HsGuardsStruct where++import Data.Generics++import SrcLoc1+++data HsAlt e p ds+    = HsAlt SrcLoc p (HsRhs e) {-where-} ds+      deriving (Ord,Read, Eq, Show, Data, Typeable)++data HsRhs e+    = HsBody e+    | HsGuard [(SrcLoc, e, e)]+      deriving (Ord,Read, Eq, Show, Data, Typeable)
+ tools/base/AST/HsGuardsUtil.hs view
@@ -0,0 +1,9 @@+module HsGuardsUtil() where++import SrcLoc1+import HsGuardsStruct++instance HasSrcLoc (HsAlt e p ds) where+    srcLoc (HsAlt s _ _ _) = s++
+ tools/base/AST/HsIdent.hs view
@@ -0,0 +1,43 @@+module HsIdent where+import SrcLoc1+import Data.Generics++data HsIdentI i+    = HsVar i+    | HsCon i+      deriving (Eq, Ord, Show,Read, Data, Typeable)++-- This is perhaps not a good idea, in case we want to change HsIdentI...+instance Functor HsIdentI where fmap = mapHsIdent++getHSName = accHsIdent id++mapHsIdent nf = mapHsIdent2 nf nf++mapHsIdent2 vf cf = accHsIdent2 (HsVar . vf) (HsCon . cf)++accHsIdent nf = accHsIdent2 nf nf++accHsIdent2 vf cf (HsVar n) = vf n+accHsIdent2 vf cf (HsCon n) = cf n++seqHsIdent (HsVar i)    = fmap HsVar i+seqHsIdent (HsCon i)    = fmap HsCon i++isHsVar (HsVar _) = True+isHsVar  _        = False++isHsCon (HsCon _) = True+isHsCon  _        = False++{- -- not used+hsVarName (HsVar v) = Just v+hsVarName _ = Nothing++hsConName (HsCon c) = Just c+hsConName _ = Nothing+-}++---+instance HasSrcLoc i => HasSrcLoc (HsIdentI i) where+  srcLoc = srcLoc . getHSName
+ tools/base/AST/HsIdentPretty.hs view
@@ -0,0 +1,15 @@+module HsIdentPretty where+import PrettyPrint+import HsIdent++instance Printable i => Printable (HsIdentI i) where+    ppi   = ppi   . getHSName+    wrap  = wrap  . getHSName++instance PrintableOp i => PrintableOp (HsIdentI i) where+    isOp = isOp . getHSName+    ppiOp = ppiOp . getHSName+++ppcon pp = accHsIdent2 (var.pp) (con.pp) -- ppcon is a misleading name...+ppconop pp = accHsIdent2 (varop.pp) (conop.pp) -- ppconop is a misleading name...
+ tools/base/AST/HsKind.hs view
@@ -0,0 +1,7 @@++module HsKind(module K) where++import HsKindStruct as K+import HsKindPretty as K+import HsKindMaps as K+import HsKindUtil as K
+ tools/base/AST/HsKindMaps.hs view
@@ -0,0 +1,21 @@+-- The trifecta for the K functor.++module HsKindMaps where++import HsKindStruct+import MUtils++mapK f Kstar      = Kstar+mapK f (Kfun x y) = Kfun (f x) (f y)+mapK f Kpred      = Kpred+mapK f Kprop      = Kprop++accK acc ans Kstar          = ans+accK acc ans (Kfun x y)     = acc y (acc x ans)+accK acc ans Kpred          = ans+accK acc ans Kprop          = ans++seqK Kstar      = return Kstar+seqK (Kfun x y) = Kfun # x <# y+seqK Kpred      = return Kpred+seqK Kprop      = return Kprop
+ tools/base/AST/HsKindPretty.hs view
@@ -0,0 +1,16 @@+-- Pretty printing for the K functor --++module HsKindPretty where++import PrettyPrint+import HsKindStruct+import PrettySymbols++instance Printable x => Printable (K x) where+    ppi (Kfun k1 k2) = wrap k1 <> rarrow <> k2+    ppi k            = wrap k++    wrap Kstar = star+    wrap Kpred = moon+    wrap Kprop = kw "P"+    wrap k     = parens (ppi k)   
+ tools/base/AST/HsKindStruct.hs view
@@ -0,0 +1,10 @@+module HsKindStruct where++import Data.Generics++data K x +    = Kstar    -- base types+    | Kfun !x !x -- higher kinds -- be strict to avoid a space leak+    | Kpred    -- classes+    | Kprop    -- P-logic assertions  & predicates+      deriving (Ord, Eq, Show, Read, Data, Typeable)
+ tools/base/AST/HsKindUtil.hs view
@@ -0,0 +1,16 @@+-- $Id: HsKindUtil.hs,v 1.2 2005/05/04 06:05:27 hallgren Exp $++module HsKindUtil(matchK)++where++import HsKindStruct+++matchK tx ty =+    case (tx, ty) of+    (Kstar,      Kstar)      -> Just []+    (Kfun x1 x2, Kfun y1 y2) -> Just [(x1, y1), (x2, y2)]+    (Kpred,      Kpred)      -> Just []+    (Kprop,      Kprop)      -> Just []+    (tx,         ty)         -> Nothing 
+ tools/base/AST/HsLiteral.hs view
@@ -0,0 +1,22 @@+module HsLiteral where++import Data.Generics++-- import Ratio+--import PrettyPrint+--import SrcLoc++data HsLiteral+    = HsInt         Integer+    | HsChar        Char+    | HsString      String+    | HsFrac        Rational+    -- GHC unboxed literals:+    | HsCharPrim    Char+    | HsStringPrim  String+    | HsIntPrim     Integer+    | HsFloatPrim   Rational+    | HsDoublePrim  Rational+    -- GHC extension:+    | HsLitLit      String+      deriving (Ord, Read, Eq, Show, Data, Typeable)
+ tools/base/AST/HsLiteralPretty.hs view
@@ -0,0 +1,19 @@+module HsLiteralPretty where+import HsLiteral+import PrettyPrint++instance Printable HsLiteral where+    ppi	(HsInt i)        = ppi i+    ppi	(HsChar c)       = ppi (show c) --litChar c+    ppi	(HsString s)     = ppi (show s) --litString s+    ppi	(HsFrac r)       = ppi r+    -- GHC unboxed literals:+    ppi (HsCharPrim c)   = show c                  <> '#'+    ppi (HsStringPrim s) = show s                  <> '#'+    ppi (HsIntPrim i)    = ppi i                   <> '#'+    ppi (HsFloatPrim r)  = float  (fromRational r) <> '#'+    ppi (HsDoublePrim r) = double (fromRational r) <> "##"+    -- GHC extension:+    ppi (HsLitLit s)     = doubleQuotes s++    wrap = ppi
+ tools/base/AST/HsModule.hs view
@@ -0,0 +1,62 @@+module HsModule(module HsModule,ModuleName(..)) where+import List(sort,nub)+import SrcLoc1+import HsName(ModuleName(..))+import HsIdent(HsIdentI(..))+import HsConstants(mod_Prelude')++import Data.Generics++data HsModuleI m i ds+    = HsModule { hsModSrcLoc  :: SrcLoc,+		 hsModName    :: m,+		 hsModExports :: Maybe [HsExportSpecI m i],+		 hsModImports :: [HsImportDeclI m i],+		 hsModDecls   :: ds }+      deriving (Eq, Show, Data, Typeable)++instance HasSrcLoc (HsModuleI m i ds) where srcLoc = hsModSrcLoc++data HsExportSpecI m i+    = EntE (EntSpec i)          -- only unqualified names allowed for i+    | ModuleE m                 -- module M+    deriving (Eq, Show, Data, Typeable)++data HsImportDeclI m i+    = HsImportDecl SrcLoc m {-qualified-} Bool {-as-} (Maybe m)+                  (Maybe (ImpSpec i))+      deriving (Eq, Show, Data, Typeable)+type ImpSpec i = ({-hiding-}Bool, [EntSpec i])++--hsImpFrom :: HsImportDecl -> ModuleName+hsImpFrom (HsImportDecl _ x _ _ _)  = x+hsModImportsFrom m = sort . nub . map hsImpFrom . hsModImports $ m++type HsImportSpecI i = EntSpec i -- qualified names allowed for i++data EntSpec i+    = Var i                   -- x (a variable identifier)+    | Abs i                   -- T, C (or P-Logic assertion/predicate)+    | AllSubs i               -- T(..), C(..)+    | ListSubs i [HsIdentI i] -- T(C_1, ..., C_n, f_1, ..., f_n)+                              -- C(m_1, ..., m_2)+    deriving (Eq, Show, Data, Typeable)++exportVar = EntE . Var++--------------------------------------------------------------------------------++--Functions for making the implicit import of Prelude explicit:++optAddPrelude sn prel = if prel then addPrelude sn else id++addPrelude sn m@HsModule{hsModImports=is} = m{hsModImports=prelimps++is}+  where+    prelimps = prelqual:if sn mod_Prelude' `elem` map hsImpFrom is+			then []+			else [prelunqual]++    prelqual = prel True+    prelunqual = prel False+    prel qual = HsImportDecl loc0 (sn mod_Prelude') qual Nothing Nothing+    
+ tools/base/AST/HsModuleMaps.hs view
@@ -0,0 +1,56 @@+module HsModuleMaps where+import HsModule+import MUtils+import HsIdent(seqHsIdent)++instance Functor (HsImportDeclI m) where+  fmap f (HsImportDecl s m q as optspec) =+    HsImportDecl s m q as (fmap (apSnd (map (fmap f))) optspec)++instance Functor (HsExportSpecI m) where+  fmap f e =+    case e of+      EntE espec -> EntE (fmap f espec)+      ModuleE mn -> ModuleE mn++instance Functor EntSpec where+  fmap f e =+    case e of+      Var i -> Var (f i)+      Abs i -> Abs (f i)+      AllSubs i -> AllSubs (f i)+      ListSubs i is -> ListSubs (f i) (map (fmap f) is)++--------------------------------------------------------------------------------++mapDecls f (HsModule loc name exps imps ds) = HsModule loc name exps imps (f ds)+seqDecls (HsModule loc name exps imps ds)   = HsModule loc name exps imps # ds++seqImportDecl (HsImportDecl s m q as optspec) =+  HsImportDecl s m q as # seqMaybe (fmap (apSndM (mapM seqEntSpec)) optspec)++seqExportSpec e =+  case e of+    EntE espec -> EntE # seqEntSpec espec+    ModuleE mn -> return (ModuleE mn)++seqEntSpec e =+  case e of+    Var i -> Var # i+    Abs i -> Abs # i+    AllSubs i -> AllSubs # i+    ListSubs i is -> ListSubs # i <# mapM seqHsIdent is++--------------------------------------------------------------------------------++mapModMN f (HsModule loc name exps imps ds) =+  HsModule loc (f name) (mapExpsMN f exps) (mapImpsMN f imps) ds++mapExpsMN f = fmap . map . mapExpMN $ f+mapExpMN f (EntE e) = EntE e+mapExpMN f (ModuleE m) = ModuleE (f m)++mapImpsMN f = map . mapImpMN $ f++mapImpMN f (HsImportDecl loc m q as spec) =+  HsImportDecl loc (f m) q (fmap f as) spec
+ tools/base/AST/HsModulePretty.hs view
@@ -0,0 +1,32 @@+module HsModulePretty where+import HsModule+import HsIdentPretty+import PrettyPrint++instance (Printable m,Printable i,Printable ds)+       => Printable (HsModuleI m i ds) where+    ppi (HsModule s mod exps imps ds) =+	sep [kw "module" <+> modn mod,+	     classNest $ sep [ maybepp ppiFTuple exps, kw "where" ]]+	$$ layout (map ppi imps++map (blankline$) (ppis ds))++	where vspace :: [Doc] -> Doc+	      vspace [] = empty+	      vspace ds = blankline $ vcat ds++instance (Printable m,Printable i) => Printable (HsExportSpecI m i) where+    ppi (EntE e) = ppi e+    ppi (ModuleE m) = kw "module" <+> modn m++instance (Printable m,Printable i) => Printable (HsImportDeclI m i) where+    ppi (HsImportDecl _ m qual m' imps) =+	kw "import" <+> optpp qual (kw "qualified") <+> modn m <+>+        maybepp ((kw "as"<+>).modn) m' <+> maybepp ppImps imps+      where+        ppImps (hiding, imps) = optpp hiding (kw "hiding") <+> ppiFTuple imps++instance Printable i => Printable (EntSpec i) where+    ppi (Var n)         = wrap n+    ppi (Abs n)         = tcon n -- could be a predicate in the P-logic ext+    ppi (AllSubs m)     = tcon m <> "(..)"+    ppi (ListSubs m ns) = tcon m <> ppiFTuple (map (ppcon wrap) ns)
+ tools/base/AST/HsName.hs view
@@ -0,0 +1,139 @@+module HsName where++import Char(isAlpha,isUpper)+import List(intersperse,isPrefixOf,isSuffixOf)+import PrettyPrint++import Data.Generics+++{-++Module Names+============++Modules are identified by their names. But since we want to support projects+containing more than one Main module, the module Main is instead identified+by the path to the file it resides in. (Perhaps there should be two different+types, one for module names, one for unique module identifiers.)+-}++data ModuleName+  = PlainModule String+  | MainModule FilePath+  deriving (Eq, Ord, Show, Read, Data, Typeable)++moduleName path "Main" = MainModule path+moduleName  _   s      = PlainModule s++plainModule s | s/="Main" = PlainModule s ++isMainModule (MainModule _) = True+isMainModule _ = False++isHierarchical (PlainModule s) = '.' `elem` s+isHierarchical _ = False++sameModuleName "Main" (MainModule _)   = True+sameModuleName s      (PlainModule s') = s==s'+sameModuleName _ _ = False++fakeModule = PlainModule+  -- used by the type checker to create unique variables like t.1, t.2, d.1, d.2++noModule = fakeModule "noModule" -- not a valid module name++{-+instance Show ModuleName where+  showsPrec n (Module s) = showsPrec n s+instance Read ModuleName where+  readsPrec n s = [(Module m,r)|(m,r)<-readsPrec n s]+-}++{-+Identifiers+===========+-}+type Id = String+++data HsName+    = Qual ModuleName Id+    | UnQual Id+      deriving (Eq, Ord, Show, Read, Data, Typeable)++hsUnQual = accHsName id++--- Map, Acc & Seq for the HsName functor --------------------------------------++mapHsName idf (Qual q id) = Qual q (idf id)+mapHsName idf (UnQual id) = UnQual (idf id)++accHsName idf (Qual q id) = idf id -- ??+accHsName idf (UnQual id) = idf id++--- Parsing pretty-printed module names ----------------------------------------++parseModuleName m =+    if "Main{-" `isPrefixOf` m && "-}" `isSuffixOf` m+    then MainModule . reverse . drop 2 . reverse . drop 6 $ m+    else PlainModule m++--- Pretty printing for HsName and Module --------------------------------------++instance Printable ModuleName where+    ppi (PlainModule m)   = ppi m+    ppi (MainModule path) = "Main"<>cmnt ("{-"<>path<>"-}")+    wrap                  = ppi++instance Printable HsName where+    ppi (Qual (PlainModule "Prelude") "[]") = ppi "[]" -- hack+    ppi (Qual (PlainModule "Prelude") "()") = ppi "()" -- hack+    ppi (Qual (PlainModule "Prelude") "(,)") = ppi "(,)" -- hack+    ppi (Qual (PlainModule "Prelude") "->") = ppi "(->)" -- hack+    ppi (Qual q id) = q <> '.' <> id+    ppi (UnQual id) = ppi id++    wrap n | isSymbolOp n = parens n+           | otherwise    = ppi n++instance PrintableOp HsName where+    isOp = isSymbolOp+    ppiOp n = if isAlphaOp n+	      then backQuotes n+	      else ppi n++isSymbolOp, isAlphaOp, isConOp :: HsName -> Bool+isSymbolOp = isSymbol . head . hsUnQual+isAlphaOp  = isAlpha  . head . hsUnQual+isConOp    =  (==':') . head . hsUnQual++ppInfixOp n = ppiOp n+ppInfixName n = ppiOp n++isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~"++--- Extra stuff for heirarchical module names ----------------------------------++splitQualName path = uncurry (Qual . moduleName path) . splitQualName'++{-+-- Haskell 98 version:+splitQualName' s = Qual (Module m) n+  where (m,'.':n) = break (=='.') s+-}++-- For the "hierachical module name" extension:+splitQualName' s = (m,n)+  where+    m = concat (intersperse "." (init parts))+    n = last parts+    parts = chop s++    chop "" = []+    chop ('.':s@(c:_)) = if isUpper c+			 then []:chop s+			 else []:[s]+    chop (c:s) = +	  case chop s of+	    [] -> [[c]]+	    s:ss -> (c:s):ss
+ tools/base/AST/HsPat.hs view
@@ -0,0 +1,7 @@++module HsPat(module P) where++import HsPatStruct as P+import HsPatPretty as P+import HsPatMaps as P+import HsPatUtil as P
+ tools/base/AST/HsPatMaps.hs view
@@ -0,0 +1,86 @@+-- $Id: HsPatMaps.hs,v 1.16 2005/05/31 02:25:25 hallgren Exp $++{-+   +   Standard maps for the P functor++-}++module HsPatMaps+where++import HsPatStruct+import HsFieldsMaps+import AccList(accList)+import MUtils+import HsIdent(mapHsIdent2,accHsIdent2,seqHsIdent)++mapPI idf = mapPI2 idf idf++mapPI2 :: (i1 -> i2) ->+          (i1 -> i2) ->+          (p1 -> p2) ->+          PI i1 p1 -> PI i2 p2+mapPI2 vf cf pf pat =+  case pat of+    HsPId n                -> HsPId (mapHsIdent2 vf cf n)+    HsPLit s l             -> HsPLit s l+    HsPNeg s l             -> HsPNeg s l+    HsPSucc s n l          -> HsPSucc s (vf n) l+    HsPInfixApp x op y     -> HsPInfixApp (pf x) (cf op) (pf y)+    HsPApp nm ps           -> HsPApp (cf nm) (map pf ps)+    HsPTuple s ps          -> HsPTuple s (map pf ps)+    HsPList  s ps          -> HsPList s (map pf ps)+    HsPParen p             -> HsPParen (pf p) +    HsPRec nm fields       -> HsPRec (cf nm) (mapFieldsI vf pf fields)+    HsPAsPat nm p          -> HsPAsPat (vf nm) (pf p)+    HsPWildCard            -> HsPWildCard+    HsPIrrPat p            -> HsPIrrPat (pf p)+++accPI idf = accPI2 idf idf++accPI2 :: (i -> b -> b) ->+          (i -> b -> b) ->+          (p -> b -> b) ->+          (PI i p) -> b -> b+accPI2 vf cf pf pat =+    case pat of+    HsPId n                -> accHsIdent2 vf cf n+    HsPLit s l             -> id +    HsPNeg s l             -> id+    HsPSucc s n l          -> vf n+    HsPInfixApp x nm y     -> pf x . cf nm . pf y+    HsPApp nm ps           -> cf nm . accList pf ps+    HsPTuple s ps          -> accList pf ps+    HsPList  s ps          -> accList pf ps+    HsPParen p             -> pf p +    HsPRec nm fields       -> cf nm . accFieldsI vf pf fields +    HsPAsPat nm p          -> vf nm . pf p +    HsPWildCard            -> id +    HsPIrrPat p            -> pf p+++accP :: (p -> b -> b) ->+        b ->+        (PI i p) ->+        b+accP pf = flip $ accPI (curry snd) pf+++seqPI :: (Monad m,Functor m) => PI (m i) (m p) -> m (PI i p) +seqPI pat =+   case pat of+     HsPId n                -> HsPId # seqHsIdent n+     HsPLit s l             -> return $ HsPLit s l+     HsPNeg s l             -> return $ HsPNeg s l+     HsPSucc s n l          -> HsPSucc s # n <# return l+     HsPInfixApp x op y     -> HsPInfixApp # x <# op <# y+     HsPApp nm ps           -> HsPApp # nm <# sequence ps+     HsPTuple s ps          -> HsPTuple s # sequence ps+     HsPList  s ps          -> HsPList s # sequence ps+     HsPParen p             -> HsPParen # p+     HsPRec nm fields       -> HsPRec # nm <# seqFieldsI fields+     HsPAsPat nm p          -> HsPAsPat # nm <# p+     HsPWildCard            -> return HsPWildCard+     HsPIrrPat p            -> HsPIrrPat # p
+ tools/base/AST/HsPatPretty.hs view
@@ -0,0 +1,38 @@+--- Pretty printing for the P functor++module HsPatPretty () where++import HsPatStruct+import HsIdentPretty+import HsFieldsPretty()+import HsLiteralPretty()+import PrettyPrint++instance (PrintableOp i,Printable p) => Printable (PI i p) where+  ppi (HsPId n)            = ppcon wrap n+  ppi (HsPLit s l)         = lit l+  ppi (HsPNeg s l)         = kw "-" <> lit l+  ppi (HsPSucc s n l)      = parenBinOp n (kw "+") l+  ppi (HsPInfixApp x op y) = parenBinOp x (conop (ppiOp op)) y+  ppi (HsPApp n ps)        = con (wrap n) <+> (fsep $ map wrap ps)+  ppi (HsPTuple s ps)      = ppiFTuple ps+  ppi (HsPList  s ps)      = ppiList ps+  ppi (HsPParen p)         = wrap p+  ppi (HsPRec n fs)        = con (wrap n) <> braces fs+  ppi (HsPAsPat n p)       = wrap n <> kw "@" <> wrap p+  ppi (HsPWildCard)        = kw '_'+  ppi (HsPIrrPat p)        = kw "~" <> wrap p++  wrap p =+    case p of+      HsPId n       -> ppcon wrap n+      HsPLit s l    -> lit l+      HsPApp n []   -> con (wrap n)+      HsPTuple s ps -> ppi p+      HsPList  s ps -> ppi p+      HsPParen p    -> parens p+      HsPAsPat n _  -> ppi p+      HsPWildCard   -> kw '_'+      HsPInfixApp{} -> ppi p+      HsPSucc{}     -> ppi p+      _             -> parens p
+ tools/base/AST/HsPatStruct.hs view
@@ -0,0 +1,41 @@+-- $Id: HsPatStruct.hs,v 1.29 2005/05/31 02:25:25 hallgren Exp $++module HsPatStruct where++import SrcLoc1+import HsIdent+import HsLiteral+import HsFieldsStruct++import Data.Generics++data PI i p+    = HsPId (HsIdentI i)         -- Variables and nullary constructors+    | HsPLit SrcLoc HsLiteral    -- Literal+    | HsPNeg SrcLoc HsLiteral    -- only numeric literals can be negated+    | HsPSucc SrcLoc i HsLiteral -- the horrible n+k pattern -- integer literal+    | HsPInfixApp p i p          -- For example fx:xs+    | HsPApp i [p]               -- Constructor applications+    | HsPTuple SrcLoc [p]        -- Tuple pattern, (p_1,...,p_n)+    | HsPList  SrcLoc [p]        -- List pattern, [p_1,...,p_n]+    | HsPParen p                 -- (p)+    | HsPRec i (HsFieldsI i p)   -- C{f_1=p_1,...,f_n=p_n}+    | HsPAsPat i p               -- x@p+    | HsPWildCard                -- _+    | HsPIrrPat p                -- ~p+      deriving (Ord, Read, Eq, Show, Data, Typeable)+      +{- instance (Eq i, Eq p) => Eq (PI i p) where+  HsPId i                == HsPId i1                    = i == i1+  HsPLit _ i             == HsPLit _ i1                 = i == i1+  HsPNeg _ i             == HsPNeg _ i1                 = i == i1+  HsPSucc _ i k          == HsPSucc _ i1 k1             = i == i1 && k == k1+  HsPInfixApp x op z     == HsPInfixApp x1 op1 z1        = x == x1 && op == op1 && z == z1+  HsPApp i xs            == HsPApp i1 xs1               = i == i1 && xs == xs1+  HsPTuple _ xs          == HsPTuple _ xs1              = xs == xs1+  HsPList _ xs           == HsPList _ xs1               = xs == xs1+  HsPParen p             == HsPParen p1                 = p == p1+  HsPRec i ups           == HsPRec i1 ups1              = i == i1 && ups == ups1+  HsPAsPat i p           == HsPAsPat i1 p1              = i == i1 && p == p1+  HsPWildCard            == HsPWildCard                 = True+  HsPIrrPat p            == HsPIrrPat p1                = p == p1 -}
+ tools/base/AST/HsPatUtil.hs view
@@ -0,0 +1,74 @@+module HsPatUtil where++import HsPatStruct+import HsPatMaps(mapPI,accP)+import HsIdent({-getHSName,-}HsIdentI(..))+--import HsAssoc+import HasBaseStruct(basestruct)+import SpecialNames(tuple_name)++-- a generic way to examine patterns+isPVar p =+  case basestruct p of+    Just (HsPId (HsVar x))  -> Just x+    _                       -> Nothing++isIrrPat p =+  case basestruct p of+    Just (HsPIrrPat p)  -> Just p+    _                   -> Nothing+++isWildCardPat p =+  case basestruct p of+    Just HsPWildCard    -> True+    _                   -> False++isAsPat p =+  case basestruct p of+    Just (HsPAsPat i p) -> Just (i,p)+    _                   -> Nothing+++{-+isConPat p = +  case basestruct p of+    Just bp ->+      case bp of+	HsPId (HsCon c) -> Just (c,[])+	HsPInfixApp p1 (HsCon c) p2 -> Just (c,[p1,p2])+	HsPApp c ps -> Just (c,ps)+	HsPTuple ps -> Just (tuple_name (length ps),ps)+        ...+-}+    ++{- Obsolete...+-- Find all of the free identifiers (vars and cons) in an P structure:+freeIdentsP fiP p = +  case p of +    HsPId n -> [n]+    HsPAsPat nm p    -> HsVar nm:fiP p+    _                -> accP (++) [] (mapPI id fiP p)+++reassociateP isinfix make undo rap env (HsPInfixApp a op1 b) =+    let f  = getHSName op1+        a' = rap env a+    in+        if isinfix a' then+	    let (op2, c, d) = undo a'+                g           = getHSName op2+	    in+                if (getPrec env f) > (getPrec env g) || +		   ((getPrec env f == getPrec env g) && +                     (getAssoc env f == HsAssocRight && +                      getAssoc env g == HsAssocRight))+                then+		    HsPInfixApp c op2 (rap env (make d op1 b))+		else+		    HsPInfixApp a' op1 (rap env b)+	else+            HsPInfixApp a' op1 b+reassociateP isinfix make undo rap env p = mapPI id (rap env) p+-}
+ tools/base/AST/HsType.hs view
@@ -0,0 +1,7 @@++module HsType(module T) where++import HsTypeStruct as T+import HsTypePretty as T+import HsTypeMaps as T+import HsTypeUtil as T
+ tools/base/AST/HsTypeMaps.hs view
@@ -0,0 +1,67 @@+-- $Id: HsTypeMaps.hs,v 1.11 2004/12/03 07:49:43 hallgren Exp $++--- Maps for the T functor -----------------------------------------------------+module HsTypeMaps where++import HsTypeStruct+import AccList(accList)+import MUtils+++mapTI idf = mapTI2 idf idf++mapTI2 :: (i1 -> i2) -> +          (i1 -> i2) -> +          (t1 -> t2) -> +          TI i1 t1 -> TI i2 t2+mapTI2 vf cf tf ty =+  case ty of+    HsTyFun x y        -> HsTyFun (tf x) (tf y)+--  HsTyTuple ts       -> HsTyTuple (map tf ts)+    HsTyApp f x        -> HsTyApp (tf f) (tf x)+    HsTyVar nm         -> HsTyVar (vf nm)+    HsTyCon nm         -> HsTyCon (cf nm)+    HsTyForall xs ps t -> HsTyForall (map vf xs) (map tf ps) (tf t)++mapT = mapTI id++crushT tf (HsTyFun x y)  = tf [x, y]+--crushT tf (HsTyTuple ts) = tf ts+crushT tf (HsTyApp f x)  = tf [f, x]+crushT tf (HsTyVar nm)   = tf []+crushT tf (HsTyCon nm)   = tf [] +crushT tf (HsTyForall xs ps t) = tf (ps++[t])   -- not sure if that's right /ISD  /TH+++-- ********** IMPORTANT *************+-- Several functions of typechecking (generalization in particular) depend+-- upon the fact that seqT , accList, and accT visit nodes in order from +-- LEFT-TO-RIGHT, If this is changed several things will not work correctly. +-- YOU HAVE BEEN WARNED !!!++-- After talking to Mark, it seems that it is only important that the order is+-- consistent between application of the various functions to types.++seqTI ty =+  case ty of+    HsTyFun x y        -> HsTyFun # x <# y+--  HsTyTuple ts       -> HsTyTuple # sequence ts+    HsTyApp f x        -> HsTyApp # f <# x+    HsTyVar nm         -> HsTyVar # nm+    HsTyCon nm         -> HsTyCon # nm+    HsTyForall xs ps t -> HsTyForall # sequence xs <# sequence ps <# t++--seqT :: (Functor m, Monad m) => T (m t) -> m (T t)+seqT x = seqTI . mapTI return id $ x+    +accTI idf tf ty =+  case ty of+    HsTyFun x y        -> tf x . tf y      -- LEFT-TO-RIGHT here+--  HsTyTuple ts       -> accList tf ts +    HsTyApp f x        -> tf f . tf x +    HsTyVar nm         -> idf nm +    HsTyCon nm         -> idf nm +    HsTyForall xs ps t -> tf t . accList tf ps . accList idf xs+++accT = accTI (curry snd)
+ tools/base/AST/HsTypePretty.hs view
@@ -0,0 +1,30 @@+--- Pretty printing for the T functor ------------------------------------------++module HsTypePretty where++import HsTypeStruct+--import HsIdent+import PrettySymbols(rarrow,forall')+import PrettyPrint+import PrettyUtil++instance (Printable i,Printable t,PrintableApp t t) => Printable (TI i t) where+    ppi (HsTyFun a b)     = sep [ wrap a <+> rarrow, ppi b ]+    ppi (HsTyApp f x)     = ppiApp f [x]+    ppi (HsTyForall xs ts t) = forall' <+> hsep (map ppi xs) <> kw '.' <+> ppContext ts <+> t+    ppi t                 = wrap t++--  wrap (HsTyTuple ts)   = ppiTuple ts+    wrap (HsTyApp f x)    = wrapApp f [x]+    wrap (HsTyVar v)      = wrap v+    wrap (HsTyCon c)      = tcon (wrap c)+    wrap t                = parens $ ppi t++instance (PrintableApp i t,PrintableApp t t) => PrintableApp (TI i t) t where+  ppiApp (HsTyApp tf ta) ts = ppiApp tf (ta:ts)+  ppiApp (HsTyCon c)     ts = ppiApp c ts+  ppiApp t               ts = wrap t<+>fsep (map wrap ts)++  wrapApp (HsTyApp tf ta) ts = wrapApp tf (ta:ts)+  wrapApp (HsTyCon c)     ts = wrapApp c ts+  wrapApp t               ts = parens (wrap t<+>fsep (map wrap ts))
+ tools/base/AST/HsTypeStruct.hs view
@@ -0,0 +1,14 @@+module HsTypeStruct where++import Data.Generics++-------- Types -----------------------------------------------------------------++data TI i t  +    = HsTyFun t t+--  | HsTyTuple [t]+    | HsTyApp t t+    | HsTyVar i+    | HsTyCon i+    | HsTyForall [i] [t] t -- forall is . Ps => t+      deriving (Ord,Eq,Show,Read, Data, Typeable)
+ tools/base/AST/HsTypeUtil.hs view
@@ -0,0 +1,32 @@+module HsTypeUtil where+import HsTypeStruct++matchT tx ty =+    case (tx, ty) of+    (HsTyFun x1 x2, HsTyFun y1 y2)       -> Just [(x1, y1), (x2, y2)]+--  (HsTyTuple xs, HsTyTuple ys) | length xs == length ys -> Just $ zip xs ys+    (HsTyApp f x, HsTyApp g y)           -> Just [(f, g), (x, y)]+    (HsTyVar n1, HsTyVar n2) | n1 == n2  -> Just []+    (HsTyCon n1, HsTyCon n2) | n1 == n2  -> Just []+    (HsTyForall vs1 ps1 t1,HsTyForall vs2 ps2 t2) | vs1==vs2 && ps1==ps2 -> Just [(t1,t2)] -- hmm+    _                                    -> Nothing++{-+lookupHSNameInType :: TI i t -> Maybe i+lookupHSNameInType (HsTyVar n) = Just n+lookupHSNameInType (HsTyCon n) = Just n+lookupHSNameInType _           = Nothing+-}++{-+tupleToContext make t =+  case t of+    HsTyTuple ts -> ts+    _            -> [make t]+-}+++{-+tyVar2id (HsTyVar x) = x+tyVar2id _           = error "tyVar2id: not a type variable."+-}
+ tools/base/AST/OldBaseSyntax.hs view
@@ -0,0 +1,64 @@+module OldBaseSyntax where+import BaseSyntax++-- For backwards compatibility -------------------------------------------------++type E = EI HsName+type HsField e = HsFieldI HsName e++mapE :: (e1 -> e2) ->+        (p1 -> p2) ->+        (d1 -> d2) ->+        (t1 -> t2) ->+        (c1 -> c2) ->+        EI i e1 p1 d1 t1 c1 ->+        EI i e2 p2 d2 t2 c2+mapE = mapEI id ++seqE :: (Monad m,Functor m) =>+        E (m e) (m p) (m ds) (m t) (m c) ->+        m (E e p ds t c)+seqE = seqEI . mapEI return id id id id id+++accE :: (e -> b -> b) ->+        (p -> b -> b) ->+        (d -> b -> b) ->+        (t -> b -> b) ->+        (c -> b -> b) ->+        EI i e p d t c ->+        b ->+        b+accE = accEI (const id)+    +type P p = PI HsName p++mapP :: (p1 -> p2) ->+        PI i p1 ->+        PI i p2+mapP = mapPI id++seqP :: (Monad m,Functor m) => PI i (m p) -> m (PI i p)+seqP = seqPI . mapPI return id++type D = DI HsName+type HsMatch = HsMatchI HsName+type HsConDecl = HsConDeclI HsName++mapD :: (e1 -> e2) ->           -- expression recursion function+        (p1 -> p2) ->           -- pattern recursion function+        (d1 -> d2) ->           -- declaration recursion function+        (t1 -> t2) ->           -- type recursion function+        (c1 -> c2) ->           -- context recursion function+        (tp1 -> tp2) ->         -- type pattern recursion function+        DI i e1 p1 d1 t1 c1 tp1 -> -- old declaration structure+        DI i e2 p2 d2 t2 c2 tp2    -- new declaration structure+mapD = mapDI id++type T t = TI HsName t++type HsIdent = HsIdentI HsName+type HsModule = HsModuleI HsName+type HsExportSpec = HsExportSpecI HsName+type HsImportDecl = HsImportDeclI HsName+type HsImportSpec =  HsImportSpecI HsName
+ tools/base/AST/PrettyPrint2.hs view
@@ -0,0 +1,234 @@+module PrettyPrint2 where+import qualified PrettyDoc as P(Doc)+import PrettyDoc hiding (Doc)+import PrettyEnv+import TokenTags+import MUtils++type Doc = DocM P.Doc++class Show a => Printable a where+  ppi     :: a   -> Doc    -- Prettyprint Intelligently+  ppiList :: [a] -> Doc    -- Specialized for Char/String+  ppis    :: a   -> [Doc]  -- To allow for cases in which we can generate+                           -- a list of Docs from a given type+  wrap    :: a   -> Doc	   -- for bracketing++  ppi2    :: a   -> Doc    -- added by cmb21 differencing printing+                           -- guards in normal RHS and within alts.++  ppi     = plain++  ppiList = brackets . ppiFSeq+  ppis a  = [ ppi a ]+  wrap    = parens . ppi++-- Essential instances:+instance Show Doc where show (DocM d) = show (d defaultMode) -- useless?+instance Printable Doc  where ppi = id++instance Printable Char where+    ppi	c   = char c+    ppiList = text -- this defines how strings are printed, since String=[Char]+    wrap    = ppi++instance Printable a => Printable [a] where+    ppi  = ppiList+    ppis = map ppi+    wrap = ppi++-- A class to make it easier to print Haskell infix operators correctly:+class Printable a => PrintableOp a where+    isOp :: a -> Bool+    ppiOp :: a -> Doc+{-      How to print operators "mod"   and "+":++	  ppi   should produce "mod"   and "+".+	  wrap  should produce "mod"   and "(+)".+	  ppiOp should produce "`mod`" and "+".      -}++-- A class to make it easier to print type applications like (,) a b and+-- [] Int in the normal way, (a,b) and [Int].+class Printable fun => PrintableApp fun arg where+  wrapApp,ppiApp :: fun -> [arg] -> Doc+++cdoc = DocM . const++-- Hughes/SimonPJ style pretty printing operators:++char   = cdoc . Char+text   = cdoc . Text+empty  = cdoc Empty+group l ds = DocM $ \e->Group l [de|DocM d<-map ppi ds,let de=d e,nonEmpty de]+nest n = fmap (nest' n) . ppi+  where+    nest' n (Nest n' d) = nest' (n+n') d+    nest' n d = Nest n d++-- Eta expansions because of the annying monomorphism restriction!+attr a = fmap (Attr a) . ppi+kw   d = attr Reserved d+var  d = attr Var d+con  d = attr Con d+varop d = attr VarOp d+conop d = attr ConOp d+tcon d = attr TCon d+lit  d = attr Lit d+cmnt d = attr Comment d+modn d = attr ModName d++a<>b = hcat [ppi a,ppi b]+a<+>b = hsep [ppi a,ppi b]+a$$b = vcat [ppi a,ppi b]++hcat ds = group (Horiz Cat) ds+hsep ds = group (Horiz Sep) ds+vcat ds = group Vert ds+cat  ds = group (HorizOrVert Cat) ds+sep  ds = group (HorizOrVert Sep) ds+fcat ds = group (Fill Cat) ds+fsep ds = group (Fill Sep) ds++plain x = text (show x)++punctuate p []     = []+punctuate p (d:ds) = go d ds+    where go d []     = [ppi d]+          go d (e:es) = (d <> p) : go e es++-- Additional pretty printing functions:+{-+ppiSeq :: Printable a => [a] -> Doc+ppiSet :: Printable a => Doc -> [a] -> Doc+ppiSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc+ppiFSeq :: Printable a => [a] -> Doc+ppiFSet :: Printable a => Doc -> [a] -> Doc+ppiTuple :: Printable a => [a] -> Doc+ppiFTuple :: Printable a => [a] -> Doc+wrapTuple :: Printable a => [a] -> Doc+wrapSeq :: Printable a => [a] -> Doc+wrapSet :: Printable a => Doc -> [a] -> Doc+wrapFTuple :: Printable a => [a] -> Doc+wrapFSeq :: Printable a => [a] -> Doc+wrapFSet :: Printable a => Doc -> [a] -> Doc+wrapSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc+-}++ppiSeq ds = ppiSet ',' ds++ppiSet s ds = ppiSep0 sep s ds++ppiSep0 sepOp separator []  = empty+ppiSep0 sepOp separator [d] = ppi d+ppiSep0 sepOp separator ds  = sepOp $ punctuate separator $ map ppi ds++ppiFSeq ds = ppiFSet ',' ds+ppiFSet s ds = ppiSep0 fsep s ds++ppiTuple ds = parens (ppiSeq ds)+ppiFTuple ds = parens (ppiFSeq ds)+wrapTuple ds = parens (wrapSeq ds)+wrapSeq ds = wrapSet ',' ds+wrapSet s ds = wrapSep0 sep s ds+wrapFTuple ds = parens (wrapFSeq ds)+wrapFSeq ds = wrapFSet ',' ds+wrapFSet s ds = wrapSep0 fsep s ds++wrapSep0 sepOp separator []  = empty+wrapSep0 sepOp separator [d] = wrap d+wrapSep0 sepOp separator ds  = sepOp $ punctuate separator $ map wrap ds+++--maybepp :: (a -> Doc) -> Maybe a -> Doc+maybepp pf (Just a) = pf a+maybepp _  Nothing  = empty++optpp b x = if b then ppi x else empty++ppiBinOp lhs op rhs = sep [lhs<+>op,letNest rhs]++parenBinOp x op y = parens (ppiBinOp x op y) -- should consult infixParens!!++-- These are rather pointless, but kept around for backwards compatibility:+lparen = kw '('+rparen = kw ')'+lbrack = kw '['+rbrack = kw ']'+lbrace = kw '{'+rbrace = kw '}'+quote = kw '\''+dquote = kw '"'+bquote = kw '`'+equals = kw '='+comma = kw ','+float = plain :: Float->Doc+double = plain :: Double->Doc+space = ppi ' '++parens d = lparen<>d<>rparen+brackets d = lbrack<>d<>rbrack+braces d = lbrace<>d<>rbrace+doubleQuotes d = dquote<>d<>dquote+backQuotes d = bquote<>d<>bquote+{-+	quotes, charQuotes, backQuotes, doubleQuotes,+        quote, backQuote, doubleQuote, semi, comma, colon, space, equals,++        hang, punctuate,+-}++-- Environment manipulating functions:++withPPEnv :: PPHsMode -> Doc -> Doc+withPPEnv mode d = return $ (unDocM d) mode++updPPEnv f d = do e <- getPPEnv; withPPEnv (f e) d++doNotation :: Doc -> Doc+doNotation = updPPEnv (\e->e { insideDo = True })+++doElseNest d = do e <- getPPEnv+		  if insideDo e then nest (doElseIndent e) (ppi d) else ppi d++ppIfDebug debug = ifM (debugInfo # getPPEnv) (ppi debug) empty+ppIfTypeInfo tinfo = ifM (typeInfo # getPPEnv) (ppi tinfo) empty++ppIfUnicode unicode ascii =+    ifM (useUnicode # getPPEnv)+        (ppi unicode)+        (ppi ascii)++withUnicode d = updPPEnv (\e->e{useUnicode=True}) d+withDebug   d = updPPEnv (\e->e{debugInfo=True}) d++classNest, doNest, caseNest, letNest, funNest, dataNest+  :: Printable a => a -> Doc+classNest = nest' classIndent+doNest    = nest' doIndent+caseNest  = nest' caseIndent+letNest   = nest' letIndent+funNest   = nest' funIndent+dataNest  = nest' dataIndent++nest' p d = do { e <- getPPEnv ; nest (p e) (ppi d) }++blankline :: Doc -> Doc+blankline d = do e <- getPPEnv+		 if spacing e && layoutType e /= PPNoLayout+		     then d+			  $$ space+		     else d++layout ds = do e <- getPPEnv+	       case layoutType e of+		 --PPSemiColon   ->+		 --PPUtrecht     ->+		 PPNoLayout    -> braces . hsep . punctuate ';' $ ds+		 _             -> vcat ds++-- Obsolete:+appParensOn = id+appParensOff = id+
+ tools/base/AST/README.html view
@@ -0,0 +1,54 @@+<h1>Extensible Haskell front-end for the Programatica project</h1>++<h2>What is in this directory (base/AST)</h2>++This directory defines datatypes and associated functions for the+nonrecursive part of the structure of the base abstract syntax. These types+and functions should be reusable in extended versions of the language.++<p>+The modules are factorized according to syntactic category and functionality.+This is illustrated in the following table:++<p>+<table border=1>+<caption>For every x, there is a module called+<code>Hs</code>&lt;<var>category</var>&gt;&lt<var>functionality</var>&gt;+</caption>+<tr><th><th>Decl<th>Exp<th>Fields<th>Guards<th>Kind<th>Pat<th>Type<th>collected+<tr><th>Struct<td>x<td>x<td>x<td>x<td>x<td>x<td>x<td>BaseSyntaxStruct+<tr><th>Maps<td>x<td>x<td>x<td>x<td>x<td>x<td>x<td>BaseSyntaxMaps+<tr><th>Pretty<td>x<td>x<td>x<td>x<td>x<td>x<td>x<td>BaseSyntaxPretty+<tr><th>Util<td>x<td>x<td>-<td>x<td>x<td>x<td>x<td>BaseSyntaxUtil+<tr><th>collected<td>HsDecl<td>HsExp<td>HsFields<td>HsGuards<td>HsKind<td>HsPat<td>HsType<td>BaseSyntax+</table>++<p>+There is also a small number of auxiliary modules.+<p>+The modules in the row and column marked <em>collected</em> just import+and reexport the modules in the respective row or column. The module+<code>BaseSyntax</code> exports everything defined in this directory.+<p>+The modules in the first row (Struct) define the data types and+are self-contained: they do not depend+on any other modules (except some types from the Haskell 98 Prelude).++<p>+The modules in the second row (Maps) define the three operations acc, map+and seq. These modules depend on the modules in the first row+(mostly the ones directly above)+and some auxiliary modules (AccList and MUtils, available in ../lib),+which in turn depend on some Haskell 98 Standrad Library Modules (List and+Monad).++<p>+The modules in the third row (Pretty) define instances in a pretty printing+class, and some auxiliary pretty printing functions.+They depend on a pretty printing library, which is provided in ../pretty,+modules on rows above, and in some cases, modules in the Util row.++<p>+The modules in the fourth row (Util) are more ad-hoc...+<p>+The modules in the last row are not used anymore...
+ tools/base/AST/SpecialNames.hs view
@@ -0,0 +1,26 @@+module SpecialNames where++class HasSpecialNames i where+  list_tycon_name,fun_tycon_name,char_tycon_name :: i -- "[]", "(->)", "Char"+  tuple_tycon_name :: Int-> i -- tuple_tycon_name 2 = "(,,)"++  tuple_name          :: Int -> i++  -- a bit of a hack...+  tuple_name          = tuple_tycon_name+++class Eq i => IsSpecialName i where+  is_list_tycon_name, is_fun_tycon_name, is_char_tycon_name :: i->Bool+  is_tuple_tycon_name :: Int->i->Bool++  is_tuple_name     :: Int -> i -> Bool+  is_tuple_name     = is_tuple_tycon_name+++std_is_list_tycon_name i      = i==list_tycon_name+std_is_fun_tycon_name i       = i==fun_tycon_name+std_is_char_tycon_name i      = i==char_tycon_name+std_is_tuple_tycon_name n i   = i==tuple_tycon_name n++std_is_tuple_name n i         = i==tuple_name n
+ tools/base/AST/SrcLoc1.hs view
@@ -0,0 +1,31 @@+module SrcLoc1(+    SrcLoc(..), -- source location data type+    HasSrcLoc(..), -- source location class+    srcFile,+    loc0)       -- :: SrcLoc, initial dummy location+  where++import Data.Generics++data SrcLoc = SrcLoc {srcPath::FilePath,+		      srcChar,srcLine,srcColumn:: !Int }+  deriving (Eq,Ord, Data, Typeable)++instance Show SrcLoc where+   showsPrec p (SrcLoc f n l c) = showsPrec p (f,n,l,c)++instance Read SrcLoc where+   readsPrec p s = [(SrcLoc f n l c,r)|((f,n,l,c),r)<-readsPrec p s]++class HasSrcLoc syntax where +  srcLoc :: syntax -> SrcLoc++srcFile x = srcPath (srcLoc x)++loc0 = SrcLoc "__unknown__" 0 0 0++instance HasSrcLoc s => HasSrcLoc [s] where+  srcLoc [] = loc0+  srcLoc (x:xs) = srcLoc x++instance HasSrcLoc SrcLoc where srcLoc = id
+ tools/base/AST/SrcLocPretty.hs view
@@ -0,0 +1,9 @@+module SrcLocPretty where+import SrcLoc1+import PrettyPrint++instance Printable SrcLoc where+    ppi (SrcLoc f _ l c) =  f<>":"<>l<>','<>c+    wrap = ppi++shLineCol (SrcLoc _ _ l c) = show l++"_"++show c
+ tools/base/Flags.ghc view
@@ -0,0 +1,1 @@+ParseProgram.hs: -fno-monomorphism-restriction
+ tools/base/HEADER.html view
@@ -0,0 +1,23 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!-- This file is included by the web server in the automatically generated+     directory index.+-->+<head>+<title>Programatica Tools, tools/base</title>+<link rel=parent href="../" title="Programatica Tools">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../web/icon1.png">+</head>++<base>+<h1><img align=right src="../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/base</h2>++The README file is displayed below the directory index.+<!--+<p>+See also <a href="src.cgi">HTML version of the source code for tstTI</a>.+-->
+ tools/base/HuMakefile view
@@ -0,0 +1,36 @@+++BASE=${BASE-.}+B=$BASE++OLD_PARSE_DIRS=$B/parse:$B/parse/extras+NEW_PARSE_DIRS=$B/parse2:$B/parse2/Lexer+NEW_BPARSE_DIRS=$B/parse2/Parser++# PARSE_DIRS=$OLD_PARSE_DIRS+PARSE_DIRS=$NEW_PARSE_DIRS+BPARSE_DIRS=$NEW_BPARSE_DIRS++# Reusable source directories (refer to these defs in other HuMakefiles!):+BASE_DIRS=$B/pretty:$B/AST:$B/syntax:$B/lib:$B/lib/Monads:$B/Modules:$B/defs:$B/TI:$B/defs/tests:$B/transforms:$B/transforms/Deriving+MODSRC_DIRS=$PARSE_DIRS:$BASE_DIRS+ #:$B/tests/HbcLibraries++HS2HTML_DIR=${HS2HTML_DIR-$B/../hs2html}++# All sources needed to compile the test programs in this directory:+SRC_DIRS=$B:$MODSRC_DIRS:$BPARSE_DIRS:$HS2HTML_DIR++#GHCFLAGS="-fno-allow-overlapping-instances -fglasgow-exts -package lang -package data -package text"+GHCFLAGS="-fglasgow-exts -XNoOverlappingInstances" # -fno-th++### Other useful GHC flags:+# -Wall+# -fwarn-incomplete-patterns+# -fwarn-unused-imports.+# -fmax-simplifier-iterations5+# -no-recomp # recomp check is buggy, e.g. if you switch -O on and off+# -optl -static # Static linking, to avoid problems shared lib versions++# Note: GHC flags for use when compiling specific modules are put in files+# called Flags.ghc in the respective directories.
+ tools/base/Main.hs view
@@ -0,0 +1,288 @@+-- $Id: Main.hs,v 1.45 2001/07/30 05:07:23 hallgren Exp $++-- Currently a test harness for the lexer/parser/pretty printer.++--ToDo: Are initial values for SrcLoc/current column correct?++module Main (testLexer, main) where++import IO+import Monad+import Lexer+import ParseMonad+import HsParser+import ParseUtil+import Syntax+import PrettyPrint+import System+import GetOpt+import IOExts+import List+import Rewrite(rewriteModule)+import HsAssoc(initEnv)+import TypeCheckTest +import InferenceMonad+import Components+import Scope as SS+import qualified Scope2 as S2+import SCC+import ExampleScope(testD)+++data Flag = LexOnlyLength          -- print number of tokens only+          | LexOnlyRev             -- print tokens in reverse order+          | LexOnly                -- print tokens+          | ParseLength            -- print number of declarations only+          | ParseInternal          -- print abstract syntax in internal format+          | ParsePretty PPLayout   -- pretty print in this style+          | TestStatic             -- test static checker+          | TestTypeCheck+          | ShowNames+          | Help                   -- give short usage info+          | BindingGroupTest+++usage = "usage: hsparser [option] [filename]"++options =+   [ Option ['n']  ["numtokens"] (NoArg LexOnlyLength)+         "print number of tokens only",+     Option ['r']  ["revtokens"] (NoArg LexOnlyRev)+         "print tokens in reverse order",+     Option ['t']  ["tokens"]    (NoArg LexOnly)+         "print tokens",+     Option ['d']  ["numdecls"]  (NoArg ParseLength)+         "print number of declarations only",+     Option ['a']  ["abstract"]  (NoArg ParseInternal)+         "print abstract syntax in internal format",+     Option ['p']  ["pretty"]    (OptArg style "STYLE")+         "pretty print in STYLE[(o)ffside|(s)emicolon|(u)trecht|(i)nline|\+          \(n)one] (default = offside)",+     Option ['h','?'] ["help"]   (NoArg Help)+         "display this help and exit",+     Option ['s'] ["static"]     (NoArg TestStatic) +         "run static checker",+     Option ['c'] ["typecheck"]  (NoArg TestTypeCheck)+         "run typechecker",+     Option ['m'] ["names"]      (NoArg ShowNames)+         "show all defined names",+     Option ['b'] ["groups"]     (NoArg BindingGroupTest)+         "show binding groups"+   ]++style :: Maybe String -> Flag+style Nothing  = ParsePretty PPOffsideRule+style (Just s) = ParsePretty $+         case s of+         "o"         -> PPOffsideRule+         "offside"   -> PPOffsideRule+         "s"         -> PPSemiColon+         "semicolon" -> PPSemiColon+         "u"         -> PPUtrecht+         "utrecht"   -> PPUtrecht+         "i"         -> PPInLine+         "inline"    -> PPInLine+         "n"         -> PPNoLayout+         "none"      -> PPNoLayout+         _           -> PPOffsideRule++main :: IO ()+main = do cmdline <- getArgs+          mainHugs cmdline++mainHugs :: [String] -> IO ()+mainHugs cmdline =+   case getOpt Permute options cmdline of+      (flags, args, [])    ->+       do (file, inp) <- case args of+             []  -> do inp <- getContents+                       return ("stdio", inp)+             [f] -> do inp <- readFile f+                       return (f, inp)+             _   -> error usage+          putStrLn (handleFlag (getFlag flags) file inp)+      (    _,   _, errors) ->+        error (concat errors ++ usageInfo usage options)++getFlag :: [Flag] -> Flag+getFlag []  = ParsePretty PPOffsideRule+getFlag [f] = f+getFlag _   = error usage++handleFlag :: Flag -> FilePath -> String -> String+handleFlag LexOnlyLength    f = show . numToks . testLexerRev f+handleFlag LexOnlyRev       f = show . testLexerRev f+handleFlag LexOnly          f = show . testLexer f+handleFlag ShowNames        f = show . getAllNames . testParser f+handleFlag ParseLength      f = show . allLengths . testParser f+   where allLengths (HsModule _ _ imp d) =+            length imp + length d+handleFlag ParseInternal    f = show . testParser f+handleFlag TestStatic       f = \s -> +    unsafePerformIO $ +    do { r <- testStatic $ testParser f s ;+         return "Done static checking." }+handleFlag TestTypeCheck    f = \s -> +    unsafePerformIO $ +    do  { let { m = testParser f s } ;+          r <- testStatic m ;+          print $ (typeCheckDecls . (\ (HsModule _ _ _ ds) -> ds)) m;+          return "Done static checking." }+handleFlag (ParsePretty lo) f+    = renderWithMode mode . ppi . testParser f+      where mode = defaultMode { layoutType = lo }++handleFlag BindingGroupTest f = \s -> +          unsafePerformIO (return groups >>= \s ->  return " Done b.g. ")+++handleFlag Help   f+    = const $+      usageInfo+          ("A simple test program for *The Haskell Parser*" ++ usage)       options+++numToks :: ParseResult () [Token] -> Int+numToks (Ok _ toks)  = length toks+numToks (Failed err) = error ("Huh? " ++ err)++testLexerRev :: FilePath -> String -> ParseResult () [Token]+testLexerRev f s =+    (unPM $ loop []) s (SrcLoc f 1 0) 1 (error "Initial environment", []) +    where loop toks =+           lexer (\t -> case t of +                           EOF -> returnPM toks+                           _   -> loop (t:toks))++testLexer :: FilePath -> String -> ParseResult () [Token]+testLexer f s = (unPM $ loop []) s  (SrcLoc f 1 0) 1 ((), [])+  where loop toks =+         lexer (\t -> case t of +              EOF -> returnPM (reverse toks) -- space leak?+              _   -> loop (t:toks))++testParser :: FilePath -> String -> HsModuleR+testParser f s =+    case (unPM parse) s  (SrcLoc f 1 1) 0 ((), []) of+      Ok state mod -> rewriteModule initEnv mod+      Failed err -> error err++testStatic :: HsModuleR -> IO ()+testStatic (HsModule _ _ imp ds) = SS.test ds+++start s = liftM (testParser s) (readFile s)+{-+start s = do contents <- readFile s+             return $ testParser s contents+-}++look s = unsafePerformIO $ start s++myTestTypeCheck f s =+    do { let { m = testParser f s } ;+     r <- testStatic m ;+         return $ (typeCheckDs . (\ (HsModule _ _ _ ds) -> ds)) m+       } ++++t22 x =+    unsafePerformIO $+    do { putStrLn "\nEnter Haskell declarations.  Terminate with :q \+          \on a single line\n" ;+     ls <- getLines [] ;+     myTestTypeCheck "Stdio" ls+       }++t34 x = +    unsafePerformIO $ +    do { putStrLn "\nEnter Haskell declarations.  Terminate with :q \+          \on a single line\n"+       ; text <- getLines []+       ; z @ (v, text, _) <- myTestTypeCheck "Stdio" text+       ; putStrLn "\n\n OUTPUT: \n"+       ; putStrLn text+       ; return v+       }++testFreeV = +    unsafePerformIO $+    do { putStrLn "\nEnter Haskell declarations.  Terminate with :q \+          \on a single line\n"+       ; text <- getLines []+       ; let HsModule _ _ _ ds = testParser "Stdio" text+       ; let (a, b, c) = tfv (SS.freeD ds, map (\x -> SS.freeD [x]) ds)+       ; print ( (map zap  a), map zap b)+       }++tfv ((f1, f2), ds) = (f1 [], f2 [], map (\ (f1, f2) -> (f1 [], f2 [])) ds)++zap (UnQual x) = x++{-+go () = +     let (a,b,c) = tfv(testFreeV ())+         h (x,y) = (map zap x, map zap y)+     in (map zap a, map zap b, map h c)+-}++getLines c = +    do { l <- getLine+       ; if l == ":q" +           then return c+           else getLines (c ++ "\n" ++ l)+       }++z = testGeneral "test2.hs" SCC.tim++testGeneral fname f  = +    do { text <- readFile fname+       ; let HsModule _ _ _ ds = testParser fname text+       ; return $ f ds +       }+          +w = do { testGeneral "test3.hs" SS.test+       ; testGeneral "test3.hs" performTC+       } >>= id++dfree = (testGeneral "test3.hs" (\ ds -> SS.makeSCC ds [])) >>= print++d2 = (testGeneral "test3.hs" (map (\ d -> ff [] d []))) >>= print++{- testD doesn't appear in Scope2 (imported qualified as S2) ...+d3 =  (testGeneral "test3.hs" (map (\ d -> S2.testD [d]))) >>= print++d4 =  (testGeneral "test3.hs" S2.testD) >>= print+-}+++HsModule _ _ _ ds = unsafePerformIO (start "test3.hs")+++Dec(HsDataDecl _ cs1 tp1 t1 _) = ds !! 0+Dec(HsDataDecl _ cs2 tp2 t2 _) = ds !! 1+Dec(HsTypeDecl _ tp3 t3) = ds !! 2+++fr xs y = let (bound,freef1) = SS.scopPatList [] (map SS.freeTP xs)+       in (bound ,SS.freeT y bound)+++groups fname = +    do { (bg,cyclic) <- testGeneral fname SCC.bindingGroups+       ; mapM_ (\ x -> do { putStrLn (pp x)+              ; putStrLn "-----------------"+              })+           bg+       }++-----------------------------------------------------------------+-- testing the free variable analysis++HsModule _ _ _ freeds = unsafePerformIO (start "tests/freeVartests.hs")++test1 d = testD [d]+freetest _ = map test1 freeds++d5 = freeds !! 4
+ tools/base/Makefile view
@@ -0,0 +1,57 @@+### See also README.html++TARGETS=tstModules tstTI++HMAKE=ghumake -batch+HFLAGS=++### Optimization?+OPT=+#OPT=-O2++RM=rm -f++################################################################################+### Rules for compiling the programs++nothing:++all: $(TARGETS)++tstTI::+	cd parse2; make+	$(HMAKE) $(OPT) $(HFLAGS) tstTI++tstModules::+	cd parse2; make+	$(HMAKE) $(OPT) $(HFLAGS) tstModules++################################################################################+### Rule for creating the cross ref info and HTML version of the base sources.+### These assume that tstModules and hs2html have already been compiled and+### installed.++xrefs:: hi/ModuleSourceFiles.txt++hi/ModuleSourceFiles.txt:: tstTI.srclist+	tstModules xrefs `cat tstTI.srclist`++tstTI.srclist:+	echo "$@ has to be created manually (for the time being)."++html: hi/modules+	hs2html all2html++hi/modules: hi/ModuleSourceFiles.txt+	hs2html modules >hi/modules++################################################################################+### Rules for cleaning up++clean:+	cd parse2; make clean+	$(RM) -r $(TARGETS) hi+	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'++cleanrefs:+	$(RM) -f hi/*.refs
+ tools/base/Makefile.ghc-4.08 view
@@ -0,0 +1,115 @@+# $Id: Makefile.ghc-4.08,v 1.3 2001/04/28 01:02:18 moran Exp $++HC = ghc+HC_LOCAL_LIB = ${HOME}/lib+HC_INC = . parse parse/util parse/token pretty lib AST SA TC ${HC_LOCAL_LIB} \+         syntax++HC_DEP = ${HC} -M+HC_INCI = ${addprefix -i,${HC_INC}}+HC_PKGI = ${addprefix -package,${HC_PKG}}+HC_LIBI = ${addprefix -l,${HC_LIBS}}+HC_OPTS = ${$*_HC_OPTS} ${HC_XOPTS} ${HC_INCI} ${HC_PKGI} \+          -recomp -fwarn-incomplete-patterns -H55M \+          -fglasgow-exts -fmax-simplifier-iterations5 \+          -package lang -package concurrent #-Wall ++DEP_OPTS = ${HC_INCI}+HC_LDOPTS = ${HC_OPTS} ${addprefix -L,${HC_INC}} ${HC_LIBI}++HAPPY      = happy+HAPPYFLAGS = # --ghc makes parser unusable for Hugs+RUNTIMEFLAGS = # +RTS -H75M+PRINTER    = lj8+ENSCRIPT   = enscript++RM         = rm -f++HAPPYSRC = parse/HsParser.y+AST_COMMON_SRC = AST/SrcLoc.hs AST/HsLiteral.hs AST/HsName.hs AST/HsModule.hs \+           AST/HsGuards.hs AST/HsExpStruct.hs AST/HsPatStruct.hs \+           AST/HsDeclStruct.hs AST/HsTypeStruct.hs AST/HsAssoc.hs \+	   AST/ListUtil.hs AST/HsConstants.hs AST/BaseSyntaxStruct.hs+PP_SRC   = pretty/PrettyPrint.hs pretty/Pretty.lhs pretty/PrettyM.hs \+	   pretty/PrettyUtil.hs +BASE_AST_SRC = syntax/BaseSyntaxUtil.hs syntax/Rewrite.hs \+           syntax/Syntax.hs syntax/SyntaxStruct.hs syntax/SyntaxRec.hs \+           syntax/SyntaxUtil.hs syntax/Rewrite.hs+PARSE_SRC = parse/Lexer.hs parse/LexUtil.hs parse/ParseMonad.lhs \+            parse/util/ParseUtil.hs parse/token/Token.hs+SA_SRC   = SA/Scope.hs SA/Scope2.hs SA/SCC.hs+TC_SRC   = TC/InferenceMonad.hs TC/TypeGenerics.hs TC/TypeCheck.hs \+	   TC/TypeCheckTest.hs TC/Components.hs+OBS_SRC  = ${HC_LOCAL_LIB}/Observe.lhs+OPT_SRC  = lib/GetOpt.hs +HC_SRC   = ${AST_COMMON_SRC} ${PP_SRC} ${BASE_AST_SRC} ${PARSE_SRC} \+	   ${SA_SRC} ${TC_SRC} ${OBS_SRC} \+	   Syntax.hs SyntaxStruct.hs SyntaxRec.hs SyntaxUtil.hs Rewrite.hs \+	   $(HAPPYSRC:.y=.hs) \+	   ${OPT_SRC} Main.hs++HC_INT1  = $(HC_SRC:.hs=.hi)+HC_INT   = $(HC_INT1:.lhs=.hi)+HC_OBJ   = $(HC_INT:.hi=.o)++MAIN     = hsparse++# trick  :-)+ifeq (.depend,$(wildcard .depend))+all: $(MAIN)+include .depend+else+all: depend $(MAIN)+endif++%.hs: %.y+	$(HAPPY) $(HAPPYFLAGS) $< --info $(RUNTIMEFLAGS) -o $(HAPPYSRC:.y=.hs)++%.o : %.lhs+	${HC} ${HC_OPTS} -c $< -o $@++%.o : %.hs+	${HC} ${HC_OPTS} -c $< -o $@++%.hi : %.o+	@if [ ! -f $@ ] ; then \+	    echo Panic! $< exists, but $@ does not. \+	    exit 1; \+	else exit 0; \+	fi                                                      ++%.ps : %.hs+	${ENSCRIPT} -1 -o $@ -G $<++%.ps : %.lhs +	${ENSCRIPT} -1 -o $@ -G $<+++$(MAIN): ${HC_OBJ}+	${HC} -o $@ ${HC_OPTS} ${HC_OBJ}++$(HAPPYSRC:.y=.o): $(HAPPYSRC:.y=.hs)+	$(RM) $@+	${HC} ${HC_OPTS} -H95M -c $< -o $@++Main.o: Main.hs+	$(RM) $@+	${HC} ${HC_OPTS} -c $< -o $@++clean:+	$(RM) ${HC_OBJ} ${HC_INT} $(MAIN).aux $(MAIN).hp $(MAIN).prof core \+           $(MAIN).ps profile.* *~ .depend* $(HAPPYSRC:.y=.info) ++printsource:+	$(ENSCRIPT) -1 -d $(PRINTER) -G $(HC_SRC)++veryclean: clean+	$(RM) $(MAIN) TAGS $(HAPPYSRC:.y=.hs)++depend: .depend++.depend: ${HC_SRC}+	${HC_DEP} -optdep-f -optdep.depend ${HC_OPTS} ${HC_SRC}++TAGS: ${HC_SRC}+	hstags ${HC_SRC}
+ tools/base/Makefile.old view
@@ -0,0 +1,64 @@+# $Id: Makefile.old,v 1.1 2002/01/30 07:25:23 hallgren Exp $++HC = ghc+HC_LOCAL_LIB = ${HOME}/lib+HC_INC = . parse parse/extras pretty lib AST SA TC ${HC_LOCAL_LIB} syntax +HEAP = -H128M++HC_DEP = ${HC} -M+HC_INCI = ${addprefix -i,${HC_INC}}+HC_PKGI = ${addprefix -package,${HC_PKG}}+HC_LIBI = ${addprefix -l,${HC_LIBS}}+HC_OPTS = ${$*_HC_OPTS} ${HC_XOPTS} ${HC_INCI} ${HC_PKGI} \+          -recomp -fwarn-incomplete-patterns ${HEAP} \+          -fglasgow-exts -fmax-simplifier-iterations5 \+          -package lang -package concurrent -package util #-Wall +#          -fno-monomorphism-restriction \++DEP_OPTS = ${HC_INCI}+HC_LDOPTS = ${HC_OPTS} ${addprefix -L,${HC_INC}} ${HC_LIBI}++HAPPY      = happy+HAPPYFLAGS = # --ghc makes parser unusable for Hugs+RUNTIMEFLAGS = # +RTS -H75M+PRINTER    = lj8+ENSCRIPT   = enscript++HAPPYSRC = parse/extras/HsParser.y++RM         = rm -f++MAIN       = hsparse++%.hs: %.y+	$(HAPPY) $(HAPPYFLAGS) $< --info $(RUNTIMEFLAGS) -o $(HAPPYSRC:.y=.hs)++$(MAIN): $(HAPPYSRC:.y=.hs)+	${HC} --make Parse.hs -o $@ ${HC_OPTS}++parser: parse/extras/HsParser.hs++tstModules: $(HAPPYSRC:.y=.hs)+	${HC} --make tstModules.hs -o $@ ${HC_OPTS} -idefs -iModules++tstTI: $(HAPPYSRC:.y=.hs)+	${HC} --make tstTI.hs -o $@ -iparse -iparse/extras -ipretty -iAST -isyntax -ilib -iTI -H80M -fglasgow-exts -fmax-simplifier-iterations5 -package lang -fallow-undecidable-instances+# -package concurrent -package util+# -fwarn-incomplete-patterns -fno-monomorphism-restriction++tidy:+	$(RM) parse/Lexer.hi+clean:+	$(RM) ${HC_OBJ} $(MAIN).aux $(MAIN).hp $(MAIN).prof core \+           $(MAIN).ps profile.* *~ .depend* $(HAPPYSRC:.y=.info) +	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'++printsource:+	$(ENSCRIPT) -1 -d $(PRINTER) -G $(HC_SRC)++veryclean: clean+	$(RM) $(MAIN) TAGS $(HAPPYSRC:.y=.hs)++TAGS: ${HC_SRC}+	hstags ${HC_SRC}+
+ tools/base/Map60204.hs view
@@ -0,0 +1,47 @@+module Map60204 where+++#if __GLASGOW_HASKELL__ >= 604 ++import qualified Data.Map as M++insertM x t bs = M.insert x t bs ++emptyM = M.empty+lookupM x env = M.lookup x env+keysM env = M.keys env+elemsM env = M.elems env+toListM = M.toList+mapM' f bs = M.map f bs ++addListToM fm key_elt_pairs = addListTo_C (\ old new -> new) fm key_elt_pairs+ where +   addListTo_C combiner fm key_elt_pairs+     = foldl add fm key_elt_pairs	-- foldl adds from the left+     where+      add fmap (key,elt) = M.insertWith combiner key elt fmap++addListTo_CM combiner fm key_elt_pairs+   = foldl add fm key_elt_pairs	 -- foldl adds from the left+   where+   add fmap (key,elt) = M.insertWith combiner key elt fmap++findWithDefaultM a k fm = M.findWithDefault a k fm++#else++import qualified Data.FiniteMap as M++insertM x t bs = M.addToFM bs x t +emptyM = M.emptyFM+lookupM x env = M.lookupFM env x +keysM env = M.keysFM env+elemsM env = M.eltsFM env+toListM = M.fmToList+addListToM fm key_elt_pairs = M.addListToFM fm key_elt_pairs+mapM' f bs  = M.mapFM (const f) bs+addListTo_CM combiner fm key_elt_pairs = M.addListToFM_C combiner fm key_elt_pairs+findWithDefaultM a k fm = M.lookupWithDefaultFM fm  a k++#endif +
+ tools/base/Modules/._TypedIds.hs view
binary file changed (absent → 167 bytes)
+ tools/base/Modules/AST4ModSys.hs view
@@ -0,0 +1,139 @@+module AST4ModSys where++import qualified HsModule as Hs+import HsModuleMaps()+import HsIdent(getHSName)+import qualified Ents (Ent(Ent))+import DefinedNames(DefinedNames(definedNames))+--import TypedIds (NameSpace(..))++import Relations+import Names+import ModSysAST+import HasBaseName++import Products((><))++-- added by Huiqing Li+import UniqueNames+import PNT+import Maybe+import SourceNames+import SrcLoc1+import HsName hiding (ModuleName)+import HsIdent+import PosName+-------------------------++--toMod :: DefinedNames QName ds => Hs.HsModuleI QName ds -> Module+toMod (Hs.HsModule s m exp imps ds) +  = Module {+      modName       = getBaseName m,+      modExpList    = map toExpListEntry `fmap` exp,+      modImports    = toImport `map` imps,+      modDefines    = listToRel (toEnt `map` defs)+    }+    where+    defs            = map (fmap getQualified >< fmap getQualified) +                    $ definedNames ds+    toEnt (x,y)     = (getHSName x,Ents.Ent (getBaseName m) x y)+++-- exports+--toExpListEntry :: Hs.HsExportSpecI QName -> ExpListEntry +toExpListEntry x =+  case x of+    Hs.EntE i -> EntExp (toEnt getQualified i)+    Hs.ModuleE m -> ModuleExp (getBaseName m)+++-- imports +--toImport :: Hs.HsImportDeclI QName -> Import +toImport (Hs.HsImportDecl _ m qualified as spec) +  = Import {+      impSource     = getBaseName m,+      impQualified  = qualified,+      impAs         = getBaseName (maybe m id as),+      impHiding     = hiding,+      impList       = xs+    }+    where+    (hiding, xs) = cvt spec+    cvt Nothing = (True, [])+    cvt (Just (hiding,specs)) = (hiding, toImpListEntry `map` specs)+++--toImpListEntry :: Hs.HsImportSpecI QName -> EntSpec Name+toImpListEntry = toEnt id . fmap f+  where+    f = getQualified -- or perhaps signal an error if something is qualified?++--toEnt :: Hs.EntSpec i -> EntSpec i+toEnt unq x =+  case x of+    Hs.Var i           -> Ent i Nothing+    Hs.Abs i           -> Ent i Nothing+    Hs.AllSubs i       -> Ent i (Just AllSubs)+    Hs.ListSubs i js   -> Ent i (Just $ Subs (map (unq.getHSName) js))++++------- Added by Huiqing Li -----------------++-- imports +toImport' :: Hs.HsImportDeclI ModName PNT -> Import +toImport' (Hs.HsImportDecl _  m qualified as spec) +  = Import {+      impSource     = m,+      impQualified  = qualified,+      impAs         = maybe m id as,+      impHiding     = hiding,+      impList       = xs+    }+    where+    (hiding, xs) = cvt spec+    cvt Nothing = (True, [])+    cvt (Just (hiding,specs)) = (hiding, toImpListEntry' `map` specs)++pNTtoName=hsNameToName.pNTtoHsName++pNTtoHsName::PNT->QName+pNTtoHsName (PNT pn@(PN i orig) _ _)+  = let loc=(fromMaybe loc0 . optLoc') pn+    in (SN i loc)+  where+     optLoc' (PN i o) +      = case o of+         G m n (N optp) -> optp+         --  I m p -> Just p+         S p -> Just p+         D n (N optp) -> optp+         _ -> Nothing++hsNameToName::QName ->Names.Name+hsNameToName (SN (Qual _ id) l) =(SN id l)+hsNameToName (SN (UnQual id) l) =(SN id l) ++hsIdentToHsName (HsVar pnt) =pNTtoHsName pnt +hsIdentToHsName (HsCon pnt) =pNTtoHsName pnt++toImpListEntry' :: Hs.HsImportSpecI PNT -> EntSpec Name+toImpListEntry' = toEnt' pNTtoName. fmap f+  where+    f = getQualified -- or perhaps signal an error if something is qualified?+++--toEnt :: Hs.EntSpec i -> EntSpec i+toEnt' unq x =+  case x of+    Hs.Var i           -> Ent (pNTtoName i) Nothing+    Hs.Abs i           -> Ent (pNTtoName i) Nothing+    Hs.AllSubs i       -> Ent (pNTtoName i) (Just AllSubs)+    Hs.ListSubs i js   -> Ent (pNTtoName i) (Just $ Subs (map (hsNameToName.hsIdentToHsName) js))++toExpListEntry' :: Hs.HsExportSpecI (PosName.ModuleName) PNT ->ExpListEntry+toExpListEntry' x =+  case x of+    Hs.EntE i -> EntExp (toEnt getQualified (fmap pNTtoHsName i))+    Hs.ModuleE (SN m _) -> ModuleExp m+
+ tools/base/Modules/CheckModules.lhs view
@@ -0,0 +1,231 @@+Error Detection+===============+\label{Err}++In the previous section we described how to compute the in-scope and+export relations of mutually recursive modules.  The algorithm produces+a result even for modules containing errors.  +We now examine what properties need to be satisfied by correct solutions,+and how we can detect ``bad'' solutions.++>module CheckModules(ModSysErr(..),chkModule) where+>+>import Relations+>import NamesEntities+>import ModSysAST+> --import Modules+>import List (partition,nub)+>import Maybe(isNothing)++>import Set60204++Even though this specification aims for clarity rather than efficiency+or usability, we believe that it is important not only to detect+invalid solutions, but also to say _why_ they are invalid.   The data type + #ModSysErr# classifies the different kinds of problems which might occur.++>data ModSysErr +>   = UndefinedModuleAlias ModName+>   | UndefinedExport QName+>   | UndefinedSubExport QName Name+>   | AmbiguousExport Name [Entity] +>   | MissingModule ModName+>   | UndefinedImport ModName Name +>   | UndefinedSubImport ModName Name Name +>   deriving Show             ++The meanings of the individual errors are as follows:+    * #UndefinedModuleAlias# means that an export list contained an+      entry of the form #module M#, where #M# is not a valid alias.+    * #UndefinedExport# refers to an entry in an export list, for which+      there is no corresponding entry in the symbol table.+    * #UndefinedSubExport# is similar to #UndefinedExport#, except that it+      also reports the owner of the subordinate name.+    * #AmbiguousExport# reports an exported name, together with all+      the possible entities that it might refer to.+    * #MissingModule# is reported when an import declaration refers to+      a module that is missing.+    * #UndefinedImport# is reported when an import declaration attempts+      to import (or hide) an entity that was not exported by the source+      module.  The name of the source module is part of the error.+    * #UndefinedSubImport# is similar to #UndefinedImport#, except that+      it also reports the owner of the undefined subordinate entity.+      We report the owner specified by the programmer in the import list.++++%We concentrate on checking a single module and, as a result we do not detect+%errors such as an import from an unknown module.  This check could be +%done before the module system analysis is performed, either by an external+%tool, or by a separate phase in the compilation pipeline.  +%The validity of an in-scope relation depends on how the names in a module+%are used.  For example, ambiguous names are allowed,+%as long as they are not used anywhere in the program.  Because we have+%abstracted over such uses (by representing them as just entities) we+%do not check the validity of in-scope relations.++In this section we preset functions to validate the import and export +specifications of a module.  The task of the function #chkModule# is to +ensure that a module is valid from the point of view of the module system.  +To achieve this we need to check: +(1) that the module interface is unambiguous; +(2) that all referenced modules are present, and if so,+     (a) that each import declaration is valid;+     (b) that the export specification is valid.+If some referenced modules are missing, we report that, but skip the remaining+checks, since they might produce bogus error messages.++>chkModule :: +>   (ModName -> Maybe (Rel Name Entity)) ->+>   Rel QName Entity ->+>   Module ->+>     [ModSysErr]+>+>chkModule expsOf inscp mod+>   = chkAmbigExps mod_exports+>     ++ if null missingModules+>        then chkExpSpec inscp mod+>              ++ [err | (imp,Just exps) <- impSources,+>                        err <- chkImport exps imp]+>        else map MissingModule missingModules+>   where+>   Just mod_exports = expsOf (modName mod)+>+>   missingModules =+>     nub [impSource imp|(imp,Nothing)<-impSources]+>   impSources =+>     [(imp,expsOf (impSource imp))|imp<-modImports mod]+++The parameter #expsOf# is a function, which maps module names to their +export relations.+The parameter #inscp# is the in-scope relation of the module we are checking.+The result of #chkModule# is a list of errors detected in the module.++The export specification and the import declarations are checked by+separate functions. #chkModule#+provides the necessary information to each function, and +collects their results in a single list of errors.++A module should not contain ambiguities in its interface.  It is however+possible---in fact quite common---to have the same name refer to +a type constructor and a value constructor.  As we previously discussed,+this is not considered to be an ambiguity as we may determine from the context+which one is meant.++>chkAmbigExps :: Rel Name Entity -> [ModSysErr]+>chkAmbigExps exps = concatMap isAmbig +>                              (elemsS (dom exps))+>   where+>   isAmbig n = +>     let (values,types) = partition isValue (applyRel exps n) +>     in ambig n values ++ ambig n types+>+>   ambig n ents@(_:_:_)    = [AmbiguousExport n ents]+>   ambig n _               = []+ ++The function #chkAmbigExps# detects ambiguities in the export relation of +a module (#exps#). For each name in the domain+of #exps#, we use #applyRel# to compute the list of entities it may refer to.+The function #isAmbig# detects any ambiguities in this list,+considering names in different namespaces separately.  The function+ #isValue# identifies the entities occupying the value namespace.++We have already encountered some similarity between import declaration and+export specifications.  We exploit this again, by using the same function+ #chkEntSpec# to ensure that entries in export and import lists are+defined.  The parameters are essentially the same as in the #mEntSpec#+function of the previous section, but we shall briefly describe them again.+The boolean #isHiding# tells us if we are in the special case of +hiding imports.  The two functions #errUndef# and #errUndefSub# are new,+and are needed so that we can report different errors for the import +and export cases.  Finally, we have the specification we are checking, +and the relation modeling either the exports of the source module, +or the symbol table of the current module.  ++>chkEntSpec :: (Ord j, ToSimple j) =>+>   Bool ->                             -- is it a hiding import?+>   (j -> ModSysErr) ->                 -- report error+>   (j -> Name -> ModSysErr) ->         -- report error+>   EntSpec j ->                        -- the specification+>   Rel j Entity  ->                    -- the relation to check+>   (j->[Entity]) ->                    -- the relation to check+>     [ModSysErr]                       -- detected errors+>+>chkEntSpec isHiding errUndef errUndefSub +>            (Ent x subspec) rel relfun =+>   case xents of+>     []   -> [errUndef x]+>     ents -> concatMap chk ents+>   where+>   xents = filter consider (relfun x)+>+>   chk ent = +>     case subspec of+>       Just (Subs subs) -> +>         map (errUndefSub x)+>             (filter (not . (`memberS` subsInScope)) subs)+>         where+>         subsInScope = +>           mapS toSimple +>             $ dom +>             $ restrictRng (`memberS` owns ent) rel+>       _ -> []+>+>   consider+>     | isHiding && isNothing subspec = const True+>     | otherwise                     = not . isCon++Despite the large number of arguments, the function is quite simple.+We lookup what the name in the specification (#x#) may refer to,+and if nothing was found we report an error.  In case it was defined+we check the subordinate list in two steps.  First we compute +the names of subordinate entities of #ent# which are also in #rel# +(#subsInScope#).  Then we make sure that all listed subordinates are +in #subsInScope#.  We do not consider ambiguities in #chkEntSpec#,+as this is the task of the function #chkAmbigExps#. The predicate+ #consider# has the same role as in #mEntSpec#.++We now describe how to check an export specification. It may+be either implicit or explicit.  Implicit specifications are always correct.+For an explicit specification we need to check all entries in the exports list. +For entries of the form #module M# we need to ensure that #M# is a valid alias+in this module. An alias is+valid, if it is either introduced by an import declaration, or is+the name of the current module.+For other entries we need to check that the entities+they refer to are defined by using the generic #chkEntSpec#. ++>chkExpSpec :: Rel QName Entity -> Module -> [ModSysErr]+>chkExpSpec inscp mod =+>     case modExpList mod of+>       Nothing   -> []+>       Just exps -> concatMap chk exps+>   where+>   aliases = modName mod : impAs `map` modImports mod+>+>   chk (ModuleExp x)+>     | x `elem` aliases = []+>     | otherwise        = [UndefinedModuleAlias x]+>   chk (EntExp spec) = chkEntSpec False +>                UndefinedExport UndefinedSubExport +>                spec inscp (applyRel inscp)++The remaining check we have is the validity of import declarations. +The process is quite similar to the checks of the export specification+and we have already done all the hard work in #chkEntSpec#.  The function+ #chkImport# just uses #chkEntSpec# to ensure the correctness of the entries+in the specification list of the import.++>chkImport :: Rel Name Entity -> Import -> [ModSysErr]+>chkImport exps imp = concatMap chk (impList imp)+>   where+>   src      = impSource imp+>   chk spec = +>     chkEntSpec (impHiding imp)+>       (UndefinedImport src) (UndefinedSubImport src)+>       spec exps (applyRel exps)+++
+ tools/base/Modules/Ents.hs view
@@ -0,0 +1,42 @@+module Ents (module Ents, isValue) where++import TypedIds +import HsIdent+import HsName(ModuleName)+import PosName(Id)++import Set60204+-- interface of the module system to the concrete type of entities++type Entity = Ent Id ++-- The type of entities+data Ent n = Ent ModuleName (HsIdentI n) (IdTy n) deriving (Show,Read)++instance Eq n => Eq (Ent n) where+  Ent m1 i1 t1 == Ent m2 i2 t2 = m1==m2 && i1==i2 && namespace t1==namespace t2++instance Ord n => Ord (Ent n) where+  compare (Ent m1 i1 t1) (Ent m2 i2 t2) =+     compare (m1,i1,namespace t1) (m2,i2,namespace t2)++instance HasNameSpace (Ent n) where namespace = namespace . idTy+instance HasIdTy n (Ent n) where idTy (Ent _ _ ty) = ty++isCon (Ent _ (HsCon _) x) +  | not (isAssertion x)   = namespace x == ValueNames+isCon _                   = False+ +owns (Ent m (HsCon n) (Type tyinfo)) = fromListS $+  map (mkCons . conName) (constructors tyinfo) +++  map mkFields (fields tyinfo)+  where+    mkCons c      = Ent m (HsCon c) (ConstrOf n tyinfo)+    mkFields f    = Ent m (HsVar f) (FieldOf n tyinfo)+ +owns (Ent m (HsCon n) (Class cnt xs)) = fromListS (cvt `map` xs)+  where+  cvt x = Ent m (HsVar x) (MethodOf n cnt xs)++owns _ = emptyS+
+ tools/base/Modules/Flags.ghc view
@@ -0,0 +1,1 @@+PPModules.hs: -cpp
+ tools/base/Modules/HuMakefile view
@@ -0,0 +1,35 @@+++BASE=..+B=$BASE++OLD_PARSE_DIRS=$B/parse:$B/parse/extras+NEW_PARSE_DIRS=$B/parse2:$B/parse2/Lexer+NEW_BPARSE_DIRS=$B/parse2/Parser++# PARSE_DIRS=$OLD_PARSE_DIRS+PARSE_DIRS=$NEW_PARSE_DIRS+BPARSE_DIRS=$NEW_BPARSE_DIRS++# Reusable source directories (refer to these defs in other HuMakefiles!):+BASE_DIRS=$B/pretty:$B/AST:$B/syntax:$B/lib:$B/lib/Monads:$B/Modules:$B/defs:$B/TI:$B/defs/tests:$B/transforms+MODSRC_DIRS=$PARSE_DIRS:$BASE_DIRS+ #:$B/tests/HbcLibraries++HS2HTML_DIR=$B/../hs2html++# All sources needed to compile the test programs in this directory:+SRC_DIRS=$B:$MODSRC_DIRS:$BPARSE_DIRS:$HS2HTML_DIR++GHCFLAGS="-XNoOverlappingInstances -XUndecidableInstances -fglasgow-exts -package lang -package data"++### Other useful GHC flags:+# -Wall+# -fwarn-incomplete-patterns+# -fwarn-unused-imports.+# -fmax-simplifier-iterations5+# -no-recomp # recomp check is buggy, e.g. if you switch -O on and off+# -optl -static # Static linking, to avoid problems shared lib versions++# Note: GHC flags for use when compiling specific modules are put in files+# called Flags.ghc in the respective directories.
+ tools/base/Modules/ModSysAST.lhs view
@@ -0,0 +1,127 @@+> module ModSysAST where+>+> import NamesEntities+> import Relations++Abstract Syntax+===============+\label{AbsSyn}++As described in the Haskell 98 report \cite[Section 5.1]{Haskell98},+a Haskell module consists of a name, an export specification,+a number of import declarations and a number of local definitions.+We use the following data structure to represent modules:++> data Module = Module {+>   modName     :: ModName,+>   modExpList  :: Maybe [ExpListEntry],+>   modImports  :: [Import],+>   modDefines  :: Rel Name Entity }++The concrete syntax of Haskell allows an abbreviated form, where+the module name and the export specification are omitted.+This is an abbreviation for a module with name ``Main'' and an export+specification exporting a single entity named ``main''+\cite[Section 5.1]{Haskell98} and will in our abstract syntax be+represented in its expanded form.++An element of the export specification is+either an entity name or a module name as described by the+data structure #ExpListEntry#.  For entities with subordinate names, +a programmer may also provide a _subordinate export list_.  +This list is modeled by the data structure #SubSpec#.  +It specifies which of the subordinate entities currently in scope +are to be exported.++> data ExpListEntry = EntExp (EntSpec QName) +>                   | ModuleExp ModName+> data EntSpec j    = Ent j (Maybe SubSpec)+> data SubSpec      = AllSubs | Subs [Name] ++\begin{ex}+For the Haskell module:++|  module A (f,C(..),module M) where ...++the field #modExpList# would be:++| Just [EntExp (Ent "f" Nothing),+|       EntExp (Ent "C" (Just AllSubs)),+|       ModuleExp "M"]+\end{ex}++The structure #EntSpec# is used in both import and export lists.+Because qualified names are allowed in export lists,+but not in import lists, we use the parameter #j# to capture the different +types of #EntSpec#.++At first it may seem that we may eliminate #AllSubs# by thinking+of it as just an abbreviation for all the methods/value constructors+of its owner.  This however is not the case, as its meaning depends+on what entities are currently in scope, and this is one of the things+the module system computes.++The lack of an export list is a special form of export specification: +one saying that only---and all---locally defined entities are to be exported +\cite[Section 5.2]{Haskell98}.  It is _not_ an abbreviation for the +empty export list, or the export list containing only #module M# +(where #M# is the current module).  We represent this explicitly by +using the #Maybe# type constructor in the #modExpList# field. ++To make use of entities defined in other modules, programmers have+to supply _import declarations_.  Their purpose it to specify+what entities are to be imported, which module provides the required+entities, and valid ways to refer to the imported entities.++> data Import = Import {+>   impQualified  :: Bool,+>   impSource     :: ModName,+>   impAs         :: ModName,+>   impHiding     :: Bool,+>   impList       :: [EntSpec Name] }++The #impSource# field is the only field that must be specified explicitly+in an import specification.  It specifies the name of the module+from which entities will be imported.  All remaining fields take on+a default value, if not specified explicitly.++There are two flavors of import declarations:+the ones specifying what names are to be imported, and the ones specifying+what names are _not_ to be imported (sometimes called ``hiding'' imports).+The boolean field #impHiding# distinguishes between those two.   ++The field #impList# contains the actual specification, which has+structure similar to the export list of a module.  There are two+differences: there are no ``module'' imports, and+all names in the list must be simple.  To capture this similarity we+reuse the #EntSpec# data type.  If this field is omitted the specification is+assumed to be #[]#, and the #impHiding# field is set to #True#.+This has the effect of importing all exported entities of the source module.++Sometimes it is more convenient to qualify names imported from a+module not using the module name, but some other alias instead.  This is +particularly useful if the name of the source module is quite long and+a programmer needs to refer often to imported entities by their +qualified names.  The field #impAs# stores this alias.  If the alias+is omitted, this field is assumed to have the same value as the+ #impFrom# fields (i.e. we use the module name in qualified names).++Finally in some situations it might be preferable to only import+entities with their qualified names.  This can be done with the so+called _qualified_ imports.  The field #impQualified# distinguishes+qualified from normal imports.++\begin{ex}+The import:+| import Prelude as P hiding (and,Bool(True))+is represented by the data structure:+| Import {impQualified = False,+|         impSource    = "Prelude",+|         impAs        = "P",+|         impHiding    = True,+|         impList      = [Ent "and" Nothing,+|                         Ent "Bool" (Just (Subs ["True"]))]+|        }+\end{ex}++
+ tools/base/Modules/ModSysSem.lhs view
@@ -0,0 +1,62 @@+> module ModSysSem(mProgram) where+>+> import Modules+> import CheckModules+> import ModSysAST+> import NamesEntities+> import Relations(Rel,emptyRel)++The semantics of a Haskell program+==================================+\label{SemProg}++Having defined the meaning of imports and exports, and how to detect errors,+we can now glue everything together and define the meaning of a Haskell+program.++The semantics of a Haskell program (with respect to the module system)+is a mapping from a collection of modules to their corresponding in-scope+and export relations.  It can be given by a function of type:++> mProgram ::+>   [Module] -> Either [[ModSysErr]]+>		       [(Rel QName Entity,Rel Name Entity)]++Given a list of modules, the function either reports a list of+errors found in each module, or returns the in-scope and export+relations of the modules. There is a one-to-one correspondence between+positions in the module list and positions in the resulting lists.++Using the functions defined Sections~\ref{Sem} and \ref{Err},+we define the function #mProgram# as follows:++> mProgram modules+>   | not (all null errs) = Left errs+>   | otherwise           = Right rels+>   where+>   rels = computeInsOuts (const emptyRel) modules+>   errs = zipWith (chkModule expsOf) inscps modules+>+>   (inscps,exps) = unzip rels+>   expsOf m      = lookup m mod_exps+>   mod_exps      = map modName modules `zip` exps+++It is assumed that implicit imports of the Prelude+\cite[Section 5.6.1]{Haskell98} have been made+explicit before #mProgram# is called. It is also assumed that all+modules in the argument list have unique names.++While the function #mProgram# is sufficient to explain the meaning of a+Haskell program, it would probably not be very practical in a Haskell+implementation, since it does not support separate compilation. Instead of+ #mProgram#, we have implemented a more sophisticated function based on the+same key ingredients: the functions #computeInsOuts# (which supports+separate compilation) and #chkModule#, described in sections \ref{rec-mods} +and \ref{Err} respectively.+Our Haskell front-end processes modules one+strongly connected component at a time, caches module interfaces+between runs, and has better error handling.  We omit the+implementation of these practical details from this presentation.++% Section~\ref{rec-mods}
+ tools/base/Modules/Modules.lhs view
@@ -0,0 +1,521 @@+>module Modules(computeInsOuts,inscope,mImp',mExpListEntry) where+>+>import Relations+>import NamesEntities+>import ModSysAST+>import Maybe (isNothing)+>import Set60204+ +The semantics of imports and exports+====================================+\label{Sem}++Now we are ready to present a method for computing the in-scope+and export relations of the modules in a program.  The process+proceeds in two stages.  In this section we compute the relations, ignoring+any errors that might occur (e.g. ambiguous or undefined exports).+In Section~\ref{Err}, we check that each computed relation satisfies a number+of additional requirements and produce appropriate error messages if+any problems are detected.  This approach simplifies the specification+as we can concentrate on a single issue at a time.  It also results in+better error messages being reported to the users of our prototype system,+because the module system analysis can continue, even in the presence+of ambiguities. In Section~\ref{SemProg} we glue everything together.++The computation phase, described in the remainder of this section,+is itself split in three parts: first we describe +how to export/import a single entity, next we present how to combine the +meaning of entity specifications to obtain the meaning of complete import+and export specifications. Finally, we describe how +to handle mutually recursive modules.+++Importing or exporting an entity+--------------------------------++We already noted the similarity in the abstract syntax for exporting+and importing an entity---they both made use of the #EntSpec# data structure.+It is therefore not surprising that those two cases are handled in+essentially the same manner.  Our goal is to determine which+name-entity pairs in an in-scope or export relation satisfy+a certain #EntSpec# specification.  The function #mEntSpec# formalizes +this process.++>mEntSpec :: (Ord j,ToSimple j) => +>   Bool ->           -- is it a hiding import?+>   Rel j Entity ->   -- the original relation+>   EntSpec j         -- the specification+>     -> Rel j Entity -- the subset satisfying the specification+>+>mEntSpec isHiding rel (Ent x subspec) =+>   unionRels [mSpec, mSub]+>   where+>   mSpec   = restrictRng consider (restrictDom (== x) rel)+>   allSubs = owns `unionMapSet` rng mSpec+>   subs    = restrictRng (`memberS` allSubs) rel+>   mSub    = +>     case subspec of+>       Nothing        -> emptyRel+>       Just AllSubs   -> subs+>       Just (Subs xs) -> +>         restrictDom ((`elem` xs) . toSimple) subs+>+>   consider+>     | isHiding && isNothing subspec = const True+>     | otherwise                     = not . isCon++\begin{ex} Before we describe #mEntSpec# in detail,+we present an example of how it is going to be used.  Consider the module:++|  module M (f, M.List(..), Show(showList)) where+|  import A(g)+|  ...++The function #mEntSpec# is applied to each of the three entries +in the export list, to determine the subset of the in-scope relation each of +them matches.  Similarly, it is applied to the entry #g# of the import+list, to determine which of #A#'s exports come in scope.+\end{ex}++The #EntSpec# structure consists of two components:+the ``main'' specification, and possibly a subordinate specification.+The meaning of the entire specification is the union of its components.+The subset of #rel# which matches the ``main'' specification is #mSpec#.+It is computed by restricting the domain of the relation to contain only+names matching the specification.  It turns out we might need to restrict+the range of the relation as well, the reasons for this are discussed shortly.+Typically (but not always!) #mSpec# will be a relation only relating a single+name to an entity, representing the fact that the specification is unambiguous.++Continuing with the example above, #Show# is the ``main'' specification,+and #mSpec# would be:+\begin{align*}+Show              &\mapsto \ent{Show}{Prelude}    +\end{align*}++The meaning of the subordinate specification depends on the meaning+of the ``main'' specification.  The set #allSubs# contains+all subordinate entities of all possible interpretations in #mSpec#.+To compute the subordinates that are in-scope/exported, we restrict #rel#+so that names may only refer to entities in #allSubs# --- the result is #subs#.+In our example #allSubs# would contain the entities of the methods in the+ #Show# class:  +$$+\{ \ent{show}{Prelude}, \ent{showsPrec}{Prelude}, \ent{showList}{Prelude}\}+$$+Now suppose that \ent{showsPrec}{Prelude} is not in scope, perhaps because+the programmer explicitly hid it, when importing the #Prelude#.  +Then #subs# would be:+\begin{align*}+show              &\mapsto \ent{show}{Prelude}     \\+Prelude.show      &\mapsto \ent{show}{Prelude}     \\+showList          &\mapsto \ent{showList}{Prelude} \\+Prelude.showList  &\mapsto \ent{showList}{Prelude}+\end{align*}++Finally, we need to compute what part of #subs# matches the subordinate+specification.  If there was no specification, the result is the empty+relation, if the specification was of the form #AllSubs# we return #subs#,+as by construction it contains all subordinates which are in-scope or exported.+Finally, if a programmer specified an explicit list of subordinates, we need+to restrict #subs# so that it only contains names in the explicitly+provided list.  Since subordinate specifications contain only simple+names (i.e. of type #Name#), and in-scope relations contain possibly+qualified names (i.e. of type #QName#) we first strip any qualifiers+using the method #toSimple#.  This has the effect that a +subordinate will be exported if it is available in scope with either +qualified _or_ unqualified name \cite[Section 5.2]{Haskell98}.+In the ongoing example, we had a subordinate name list, containing one name:+ #``showList''#.  So the restricted #subs# relation will be:+\begin{align*}+showList          &\mapsto \ent{showList}{Prelude} \\+Prelude.showList  &\mapsto \ent{showList}{Prelude}+\end{align*}++Next we describe a quirk in the Haskell module system, which+gives rise to the #isHiding# parameter and the auxiliary predicate+ #consider#.  The entities in Haskell may be grouped in two +non-interchangeable groups: classes and type constructors on the one side,+all other entities on the other.+In the body of a module, it is always possible+to determine which type of entity a name refers to.+A name may refer to two different entities without the risk+of an ambiguity.  A problem occurs with import and export lists, +as they may not provide enough context.++\begin{ex} It is quite common to use the same name for both a type+and a value constructor, as types and values do not mix:++|  module A (Env) where+|  newtype Env a = Env [(String,a)]++There is no context in the export list to indicate if the programmer intended+to export the type constructor #Env#, the value constructor #Env#, +or perhaps both. +\end{ex}++To avoid the potential ambiguity illustrated in the example, Haskell 98+uses the following strategy to decide what is to be imported/exported.++Because only classes and type constructors may ``own'' other+entities, the presence of a subordinate name list indicates that+the programmer is referring to the type or class in scope.+The situation is more complicated if the name does not have a subordinate+list, as then there are two different policies, depending on where+the name occurs.  ++The first policy is that names starting with a capital+letter always refer to types or classes.  It is used for names occurring+in the export list of a module, and in non-hiding imports.  So in particular,+in the above example, only the type constructor #Env# will be exported,+and not the value constructor.  This means that in order to export/import+a value constructor, a programmer has to include it in the subordinate+list of the relevant type constructor.  A consequence of this is that+it is not possible to export just a value constructor without+its type.  In practice this is not a very big problem.++The second policy is used for ``hiding'' imports, and it says that +capital names may refer to _both_ types/classes and value constructors.+One reason for this difference is that it is sometimes useful to _hide_+just a value constructor without hiding its type.  If the first+policy was used for hiding imports this would not be possible.  We note+that if a name refers to both a type and a value constructor, both of+them are hidden.++A (non Haskell 98) alternative to having two separate policies is to +have a single more flexible policy that applies in both cases.  +Later in the paper (Section \ref{conclusions}) we will describe a simple+modification to the first policy to achieve this.++Here is an example illustrating what the policies do.++\begin{ex}+| import A (Env)          -- import only the type +| import A hiding (Env)   -- hide the type and the value+| import A hiding (Env()) -- hide only the type +\end{ex}++To implement this rule we defined the auxiliary predicate #consider#.  The +parameter #isHiding# tells us if we are in a hiding import (the special case).+If we are, then we consider all entities as valid interpretations +for the name in the ``main'' specification.   However if we are using+ #mEntSpec# in an export list or a normal import, then we do not consider value+constructors.++\vspace{6mm}+Export relations+----------------++Now that we know how to handle a single entry in the export list,+we are ready to compute the export relation of a module.   This+is the task of the function #exports#.++>exports :: Module -> Rel QName Entity -> Rel Name Entity+>exports mod inscp = +>   case modExpList mod of+>     Nothing -> modDefines mod+>     Just es -> getQualified `mapDom` unionRels exps+>       where+>       exps = mExpListEntry inscp `map` es++The parameter #inscp# models the in-scope relation of the module.+It is necessary, as the interface of a module is essentially a subset+of #inscp#.  If the programmer omitted the export specification of+a module, we just export the locally defined entities by using the #modDefines#+field of the module under consideration.  Alternatively if an explicit+export list was present,  we take+the union of the meanings of all listed entries.+To obtain a proper export relation we remove all qualifiers.+Note that after removing the qualifiers (or even before that)+we might end up with a relation containing ambiguous names.+This is not valid in Haskell, but we will delay detection of such invalid +solutions until a later pass.++We have already seen that there are two forms of specification+that may appear in an export list.  If we see an entity specification,+we just use #mEntSpec# to determine the subset of #inscp# which matches it.+The other possibility is that we see an export of the form+ #module M#.  In this case, the Haskell 98 report +\cite[Section 5.2, item 5]{Haskell98} states that the result is the subset +of #inscp# containing precisely those entities, +which may be named with _both_ some simple name #x# _and_ +a qualified name #M.x# ++>mExpListEntry :: +>   Rel QName Entity -> ExpListEntry -> Rel QName Entity+>mExpListEntry inscp (EntExp it) = mEntSpec False inscp it+>mExpListEntry inscp (ModuleExp m) = +>   (qual m `mapDom` unqs) `intersectRel` qs+>   where+>   (qs,unqs) = partitionDom isQual inscp++ +In-scope relations+------------------++In this section we specify how to compute the in-scope relation of a module.+This is done by the function #inscope#:  ++>inscope :: Module -> (ModName -> Rel Name Entity) +>                         -> Rel QName Entity+>inscope m expsOf = unionRels [imports, locals]+>   where+>   defEnts = modDefines m+>   locals  = unionRels +>               [mkUnqual `mapDom` defEnts,+>                mkQual (modName m) `mapDom` defEnts]+>+>   imports = +>     unionRels $ map (mImp expsOf) (modImports m)++An entity is in scope if it is either locally defined, +or if it is imported from another module. It is therefore necessary to +know what the exports of other modules are.  The parameter #expsOf# +is a function mapping module names to their exports.++Every locally defined entity may be referred to with at least two names:+the simple name used in its definition, and a qualified name, obtained+by prefixing with the name of the module.  For example if a module #A# +defines an entity with simple name #f#, a programmer may refer to it as +either #f# or #A.f# \cite[Section 5.5.1]{Haskell98}.  The part+of the in-scope relation containing local definitions is #locals#.++Import declarations are cumulative \cite[Section 5.3]{Haskell98}+and so the imported entities +(#imports#) are the union of the entities imported by each declaration.++\begin{ex}+The declarations:+| import A hiding (f)+| import A (f) +import everything from module #A#, as the first one imports everything+but #f#, while the second one imports just #f#.+\end{ex}++The function #mImp# is used to compute what entities come in scope through+a single import declaration.  +\newpage++>mImp :: (ModName -> Rel Name Entity) -> Import ->+>         Rel QName Entity +>mImp expsOf imp+>   | impQualified imp  = qs+>   | otherwise         = unionRels [unqs, qs]+>   where+>   qs      = mkQual (impAs imp) `mapDom` incoming+>   unqs    = mkUnqual `mapDom` incoming+>+>   listed  = unionRels $+>               map (mEntSpec isHiding exps) +>                   (impList imp)+>   incoming+>     | isHiding  = exps `minusRel` listed+>     | otherwise = listed+>+>   isHiding  = impHiding imp+>   exps      = expsOf (impSource imp)++>mImp' :: Rel Name Entity -> Import ->+>            Rel QName Entity +>mImp' exps imp+>   | impQualified imp  = qs+>   | otherwise         = unionRels [unqs, qs]+>   where+>   qs      = mkQual (impAs imp) `mapDom` incoming+>   unqs    = mkUnqual `mapDom` incoming+>+>   listed  = unionRels $+>               map (mEntSpec isHiding exps) +>                   (impList imp)+>   incoming+>     | isHiding  = exps `minusRel` listed+>     | otherwise = listed+>+>   isHiding  = impHiding imp+++First we define the relation #listed#, which contains exported entities +matching _any_ of the entity specifications in the list of the import +declaration.  Next, we compute the subset of the export relation of the +source module, which matches the specification (#incoming#).  If we have+a normal import, #incoming# is exactly #listed#.  If however we are+dealing with a ``hiding'' import, we need to take all those entities+which are exported, but are _not_ in #listed#.++Having computed #incoming#, we now need to convert it to an+in-scope relation.  To do that, we adjust the names of the entities+according to the import declaration.  If we have a ``qualified'' import,+we introduce only qualified names for the imported entities (#qs#), otherwise+we also add the unqualified names.  The qualified names are computed by+simply qualifying all names in #incoming# with the #impAs# specification+of the declaration.++\vspace{6mm}+Recursive modules+-----------------+\label{rec-mods}++The reader might have noticed that to compute the exports of a module we+need to know what is in scope, and to compute what is in scope we need+to know certain exports.  If we allow for mutually recursive modules, then our+equations become mutually recursive.  In this section, we show how they are+solved.++The idea is that the export and in-scope relations for a+group of mutually recursive modules are computed at the same time (as they all+depend on each other).  This means that the compilation unit of a compiler+is not a single module, but a _strongly connected component_ of mutually+recursive modules.  In fact, one could process _all_ modules at once+and still get the same result, but this will not be very practical for+large systems.  For this reason, we will work with strongly connected +components of modules, and assume that they are processed in dependency order.++The function #computeInsOuts# computes the in-scope and export+relations of the modules in a strongly connected component.+The argument #otherExps# is a function mapping module names to export relations.+It needs to be defined only for modules in earlier (dependency-wise)+strongly connected components.+\newpage++>computeInsOuts :: +>   (ModName -> Rel Name Entity) -> [Module] ->+>    [(Rel QName Entity, Rel Name Entity)]+>computeInsOuts otherExps mods = inscps `zip` exps+>   where+>   inscps = computeIs exps+>   exps   = lfpAfter nextExps $ +>             replicate (length mods) emptyRel+>+>   nextExps = computeEs . computeIs+>+>   computeEs is = zipWith exports mods is+>   computeIs es = map (`inscope` toFun es) mods+>+>   toFun es m   = maybe (otherExps m) (es !!) +>                        (lookup m mod_ixs)+>   mod_ixs      = map modName mods `zip` [0..]+>+>lfpAfter f x = if fx == x then fx else lfpAfter f fx+>   where +>   fx = f x++The function #computeInsOuts# starts by assuming that the modules in+the strongly connected component do not export anything.  It then+keeps applying the function #nextExps# to obtain successive approximations+to the exports of each of the modules until a fixed point is reached.+Thus, the export-relations in a strongly connected component are the+least fixed point of the function #nextExps#.  Similarly, the in-scope +relations are the least fixed point of #computeIs . computeEs#, +but using the well known fact that $fix (f . g) = f (fix (g . f))$, +we obtain the definition of #inscps# used above.++The function #nextExps# computes the next approximation to the+exports of each module.  Given the current exports of each module,+it first determines what are the corresponding new in-scope relations,+and based on that computes the new exports.  It makes use of the+helper functions #computeEs# and #computeIs#, which are generalizations of + #exports# and #inscope# respectively, to work with strongly connected+components rather than just single modules.++The functions #computeEs# and #computeIs# work in a similar way: they+apply #exports# (or #inscope# respectively) to all modules in  the strongly+connected component.+The main difference between the two is that the export relation of +a module depends only on the in-scope relation of the same module, +while the in-scope relation depends on the export relations of many modules. +As a result, before mapping #inscope# over the strongly+connected component, we need to compute a function that maps+module names to their respective export relations.  This is done by+ #toFun#.  If the module is in the current strongly connected component,+ the result of #toFun# just projects the appropriate export relation.+ Otherwise, we use the parameter #otherExps# to lookup the exports+of a previously processed module.++\begin{ex}+In this example we consider a module that imports itself,+and use the algorithm above to compute its in-scope and export+relations:+|  module A (B.f) where+|  import A as B+|  f = ...++\newpage+We start with an empty export relation, and +then compute the in-scope relation:  +$$f \mapsto \ent{f}{A}, A.f \mapsto \ent{f}{A}$$ +Note that this contains only the locally defined names, because #A#+imports only from itself, and we have assumed it does not export anything.+Because the in-scope relation does not relate #B.f# to anything, nothing+is exported again, and so we reach a fixed point.+Thus module #A# does not export anything, and it has one entity in-scope:+$\ent{f}{A}$.  This entity may be referred to by either #A.f#, or just #f#.+\end{ex}++\begin{ex}+This example is a slight variation on the previous one, two modules+are involved: #A# and #B#:+|  module A (B.f) where+|  import A as B+|  import qualified B+|  f = ...+| +|  module B where+|  f = ...+The dependencies between those two are: #A# depends on #A# and #B#, +and #B# does not depend on anything, so we first analyze #B#.  Since it+has no export specification, it exports all locally defined names and+nothing else, so we have the following in-scope and export relations:++\begin{tabular}{cc}+in-scope                   & exports     \\ +$f \mapsto \ent{f}{B}, B.f \mapsto \ent{f}{B}$ & $f \mapsto \ent{f}{B}$+\end{tabular}++Next we analyze module #A#. The steps in the fixed point calculation are:++\begin{tabular}{rcc}+   & in-scope                   & exports     \\ +1. &                            & $\emptyset$ \\+2. & $f \mapsto \ent{f}{A}, A.f \mapsto \ent{f}{A}, B.f \mapsto \ent{f}{B}$ +   & $f \mapsto \ent{f}{B}$ \\+3. & $f \mapsto \{ \ent{f}{A}, \ent{f}{B} \}, A.f \mapsto \ent{f}{A}, +    B.f \mapsto \ent{f}{B}$ +   & $f \mapsto \ent{f}{B}$ +\end{tabular}++We start with the empty export relation.  The in-scope relation we+compute contains the locally defined names and also the imports.  In this+case the imports are just $B.f \mapsto \ent{f}{B}$.  On the next iteration,+ $f \mapsto \ent{f}{B}$ gets exported.  So the next in-scope relation contains+more imports: $f \mapsto \ent{f}{B}$, and $B.f \mapsto \ent{f}{B}$, which+came in through the #import A# declaration.  These do not add anything new to+the exports of the module, so we have reached a fixed point.+\end{ex}++We defined the import and export relations of modules in terms+of the least fixed point of a certain function.  To ensure that the+algorithm above terminates, we need to ensure that this least+fixed point exists.  Now we examine this issue in more detail.  ++We used lists to represent the in-scope and export relations of a group +of modules. Since relations may be ordered by inclusion,+we may also order lists (of equal length) of relations by a point-wise+ordering.  In a similar fashion we obtain a lattice structure on the+lists of relations by using the lattice structure of relations point-wise.+The lattice obtained in this way is finite, as each module may only define +finitely many entities and each entity may only have finitely many names.+Names get associated with entities in two ways: by local declaration,+in which case an entity receives two names (qualified and unqualified);+and by import declaration, in which case an entity receives either one or +two names.+Since there are only finitely many local and import declarations,+an entity may only have finitely many names. ++It then follows from the Knaster-Tarski theorem \cite{Alg90}, +that #nextExps# has a least fixed point if it is monotonic with respect to +the above ordering.  The #inscope# and #exports# functions are monotonic+with respect to the relation ordering, as they are essentially filters that+produce larger outputs when given larger inputs.  +The same holds for #computeEs#, #computeIs#, and their composition #nextExps#.++
+ tools/base/Modules/Names.hs view
@@ -0,0 +1,14 @@+module Names (module Names, module QualNames) where++import PosName(Id,HsName)+import HsName(ModuleName)+import QualNames+import SpecialNames()   -- for the instances+++-- Interface of the module system, to the concrete type of names +++type Name     = Id+type ModName  = ModuleName+type QName    = HsName
+ tools/base/Modules/NamesEntities.lhs view
@@ -0,0 +1,129 @@+Names and Entities+==================+\label{NameEnt}++Having described the Haskell module system as a mechanism for+namespace management, it is natural for us to begin its+specification with a discussion about names and entities.++> module NamesEntities (+>   module NamesEntities,+>   module Ents,+>   module Names+> ) where+>+> --import Set+> import Maybe(isJust)+> import Ents(Entity,isCon,isValue,owns)+> import Names(Name,QName,ModName,+>              getQualified, getQualifier, mkQual, mkUnqual)++++Entities+--------++The basic idea is that _names_ in a program refer to _entities_.+Entities get introduced in a program by _declarations_.  For example,+a declaration such as #f x = x + 2# will introduce one entity:+a function named #f#. For the purposes of this paper, we are only interested in+top level entities, as they are manipulated by the module system.+There are at least six varieties of entities in Haskell:+functions, type constructors, value constructors, field labels, classes,+and class methods.  One could perhaps also consider class instances +to be entities as they are also introduced by declarations.+We do not do that here because, in Haskell 98, there is no way to +refer to them by name.++The module system specification is parametrized by the type of entities,+so we represent it using an abstract data type:++| data Entity = ... +| isCon :: Entity -> Bool+| owns  :: Entity -> Set Entity +|+| instance Ord Entity where ...++The function #isCon# is intended to distinguish between value constructors and+other entities, as they need to be handled differently in +``hiding'' imports as opposed to normal imports and exports +(see Section \ref{Sem}).++The function #owns# defines the _subordinate_ relation between entities.+Type constructors ``own'' their value constructors and field labels;+classes ``own'' their methods.++The requirement that entities are in the #Ord# class is stronger than+strictly necessary.  For the module system to work, we only need an equality+operation.  The ordering is required by the implementation of relations+as sets (described in Section \ref{sec-relations}).  ++Entities will be written in a different font, and annotated with the +module where they were originally defined.   +For example \ent{f}{M} refers to the entity #f# originally defined in +module #M#.++++Names+-----++Our specification is also parameterized by the types used to model names.+We distinguish between three different kinds of names:+    * _simple names_ (of type #Name#) are used in+      declarations, and to name entities exported by a module.+    * _program identifiers_ (whose type is #QName#) are used in the main+      text of the program and refer to entities.  They may be either qualified+      or unqualified.+    * _module names_ and _name qualifiers_ (with type #ModName#) are used to +      name modules, in import declarations, in export lists, and in +      qualified names.+We use the type #Name# whenever we want to indicate that only simple (i.e. not +qualified) names are allowed, and #QName# when both simple and qualified names+may be used.  As for entities, the module system only needs equality operations+on names, but to use the #Set# data structure we require the #Ord# instance.++| data Name     = ...+| data ModName  = ...+| data QName    = ...+|+| getQualifier  :: QName -> Maybe ModName+| getQualified  :: QName -> Name+| mkUnqual      :: Name -> QName+| mkQual        :: ModName -> Name -> QName+|+| instance Ord Name where ...+| instance Ord ModName where ...+| instance Ord QName where ...++We define a couple of useful functions to manipulate (possibly qualified) names.+We note that if #qual# is applied to an already qualified name, it will+replace the old qualifier (however in this specification we always apply it+to unqualified names).++> isQual :: QName -> Bool+> isQual = isJust . getQualifier++> qual :: ModName -> QName -> QName+> qual m = mkQual m . getQualified ++It is also convenient to define an overloaded function #toSimple#,+which produces the unqualified part of a name.  It does nothing+on values of type #Name# as they cannot be qualified.  For values of+type #QName# it strips the qualifiers.++> class ToSimple t where+>   toSimple :: t -> Name+>+> instance ToSimple Name where+>   toSimple = id+>+> instance ToSimple QName where+>   toSimple = getQualified++In examples throughout the paper we shall use #String# for #Name#, #ModName#, +and #QName#.  This is not the case in our prototype implementation, as+it defeats the purpose of having three different types in the first place.  +We made this choice to keep the examples readable.++
+ tools/base/Modules/PPModules.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS -cpp #-}+module PPModules where++--import Modules+import CheckModules (ModSysErr(..))+import TypedIds+import HsIdentPretty+import Ents as E+import Relations+import PrettyPrint+++instance Printable NameSpace where+    ppi ValueNames       = ppi "Value"+    ppi ClassOrTypeNames = ppi "TypeOrClass"++instance Printable i => Printable (IdTy i) where+    ppi (FieldOf x _)   = "field of" <+> x+    ppi (MethodOf x _ _)  = "method of" <+> x+    ppi (ConstrOf t tyinfo) = "con of" <+> tcon t -- <+> (constructors tyinfo)+    ppi (Class cnt ms)      = "Class" <+> cnt <+> ms+    ppi (Type tyInfo)   = "Type"  <+> tyInfo+    ppi t               = ppi (show t)++instance Printable i => Printable (TypeInfo i) where+    ppi tyInfo = constructors tyInfo <+> fields tyInfo++instance Printable i => Printable (ConInfo i) where+    ppi conInfo = con (conName conInfo)++instance Printable (ModSysErr) where+    ppi x = case x of+        UndefinedModuleAlias m  -> "Unknwon module alias" <+> "in export list"+        UndefinedExport a       -> "Undefined export entry" <+> a+        UndefinedSubExport x a  +            -> "Undefined subordinate" <+> a <+> "of" <+> x <+> "in export"+        AmbiguousExport a os    -> "Ambiguous export entry" <+> a <> ':' <+> os+        MissingModule m -> "Import from missing module" <+> m+        UndefinedImport m n     -> m <+> "does not export" <+> n+        UndefinedSubImport m x s +            -> m <+> "does not export subordinate" <+> s <+> "of" <+> x+    +++ppRel :: (Printable a, Printable b) => [(a,b)] -> Doc+ppRel = vcat . map f+    where+    f (x,y) = ppi x <+> kw "|->" <+> ppi y++instance (Show a, Show b, Printable a, Printable b) => Printable (Rel a b) where+--  ppi (Rel r) = ppRel r+    ppi r = ppRel (relToList r)++instance Printable n => Printable (Ent n) where+  ppi (E.Ent m n t) = hilite (m<>"."<>n)<>","<+>t+    where+      hilite = case t of+                 ConstrOf{} -> con+		 Type{}     -> tcon+		 Class{}    -> tcon+                 Assertion  -> con+                 Property   -> con+		 _          -> id++showRel r = show (relToList r)+readRel s = listToRel (read s)+++#if __GLASGOW_HASKELL__<604+instance (Show a, Show b) => Show (Rel a b) where+    show r = show (relToList r)+#endif+{-+-- GHC 6.4 provides a Show instance but no Read instance.+-- This Read instance doesn't match the provided Show instance for Set :-(++instance (Ord a, Ord b, Read a, Read b) => Read (Rel a b) where+    readsPrec d s = [ (listToRel xs,a) | (xs,a) <- readsPrec d s ] +-}
+ tools/base/Modules/QualNames.hs view
@@ -0,0 +1,40 @@+module QualNames where++import HsName+import HsIdent+import Maybe(isJust)++class QualNames qn m n | qn -> m n, m n -> qn where+  getQualifier  :: qn -> Maybe m+  getQualified  :: qn -> n+  mkUnqual      :: n -> qn+  mkQual        :: m -> n -> qn++isQual m    = isJust (getQualifier m)+isUnqual m  = not (isQual m)+qual m      = mkQual m . getQualified +unqual m    = mkUnqual (getQualified m)++++instance QualNames HsName ModuleName Id where+    getQualifier (Qual x _) = Just x+    getQualifier _          = Nothing+    +    getQualified (Qual _ x)   = x+    getQualified (UnQual x)   = x+ +    mkUnqual  = UnQual+    mkQual    = Qual+    + +instance QualNames t m n => QualNames (HsIdentI t) m (HsIdentI n) where+    getQualifier                = getQualifier . getHSName+    getQualified                = mapHsIdent getQualified+ +    mkUnqual                    = mapHsIdent mkUnqual+    mkQual m                    = mapHsIdent (mkQual m)++++
+ tools/base/Modules/Relations.lhs view
@@ -0,0 +1,138 @@+>module Relations where++>import qualified Data.Map as M+>import qualified Data.Set as S++>fromListS = S.fromList+>emptyS = S.empty+>map' = S.map+>intersection = S.intersection+>elems = S.elems+>unions = S.unions+>emptyM = M.empty+>difference = S.difference+>addListTo_C combiner fm key_elt_pairs+>   = foldl add fm key_elt_pairs	-- foldl adds from the left+>   where+>   add fmap (key,elt) = M.insertWith combiner key elt fmap++>findWithDefault a k fm = M.findWithDefault a k fm++++Relations+=========+\label{sec-relations}++In this section, we present a number of operators for manipulating+relations.  To represent relations we use the #Set# library provided+with the GHC and Hugs Haskell implementations.+However, the specification in this paper uses only the operators defined here,+so any other representation would do as well.++>type Rel a b = S.Set (a,b)++Next we describe a number of simple operations on relations.  Most of them+require the elements to be in the class #Ord#.  This is due to the+implementation of the #Set# library.  A different representation may+relax or strengthen these requirements.  ++The operations #listToRel# and #relToList# allow us to switch between relations+represented as sets, and relations represented as association lists.++>listToRel :: (Ord a,Ord b) => [(a,b)] -> Rel a b+>listToRel xs = fromListS xs++>relToList :: Rel a b -> [(a,b)]+>relToList r = elems r+ +The empty relation is #emptyRel#. It does not relate any elements at all.++>emptyRel :: Rel a b+>emptyRel = emptyS++The combinators #restrictDom# and #restrictRng# restrict the+domain and range, respectively, of a relation #r#, to the elements satisfying+a predicate #p#. ++>restrictDom :: (Ord a, Ord b) => +>   (a -> Bool) -> Rel a b -> Rel a b+>restrictDom p r = listToRel [(x,y) | (x,y) <- relToList r, p x]++>restrictRng :: (Ord a, Ord b) => +>   (b -> Bool) -> Rel a b -> Rel a b+>restrictRng p r = listToRel [(x,y) | (x,y) <- relToList r, p y]++To access the domain and range of a relation, we use the functions+ #dom# and #rng#, respectively.++>--dom :: Ord a => Rel a b -> S.Set a+>dom r = map' fst r++>--rng :: Ord b => Rel a b -> Set b+>rng r = map' snd r++Sometimes it is useful to apply a function to all elements in the+domain or range of a relation.  This is the task of #mapDom# and+ #mapRng#, respectively.++>--mapDom :: (Ord b, Ord x) => +>--  (a -> x) -> Rel a b -> Rel x b+>mapDom f = map' (\(x,y) -> (f x, y)) ++>--mapRng :: (Ord a, Ord x) => +>--  (b -> x) -> Rel a b -> Rel a x+>mapRng f = map' (\(x,y) -> (x, f y)) ++We also need to be able to compute the intersection and union of relations.+Elements are related by the intersection of two relations, if they are+related by _both_ relations.  They are related by the union of two relations,+if they are related by _either_ one of them.++>intersectRel :: (Ord a, Ord b) => +>  Rel a b -> Rel a b -> Rel a b+>r `intersectRel` s = r `intersection` s++>unionRels :: (Ord a, Ord b) => [Rel a b] -> Rel a b+>unionRels rs = unions rs++The function #minusRel# computes the complement of a relation with+respect to another relation.  The new relation relates all those +elements that are related by #r#, but not by #s#.++>minusRel :: (Ord a, Ord b) => +>  Rel a b -> Rel a b -> Rel a b+>r `minusRel` s = r `difference` s++Given a predicate #p# over the domain of a relation #r#, #partitionDom# +produces two new relations: the first one is the subset of #r# whose +first component satisfies #p#, and the second is the rest of #r#.++>partitionDom :: (Ord a, Ord b) =>+>  (a -> Bool) -> Rel a b -> (Rel a b, Rel a b)+>partitionDom p r = (restrictDom p r, restrictDom (not . p) r)++%\begin{ex}+%If #r = [(1,'a'),(2,'a'),(3,'b')]#, \newline+%then #partitionDom (== 2) r = ([(2,'a')],[(1,'a'),(3,'b')])#.+%\end{ex}++So far we have been thinking of relations as sets of pairs.  An alternative+view is to think of them as functions, which given an element of the+domain, return all related elements in the range.  The function+ #applyRel# converts a relation to a function form.++>applyRel :: (Ord a, Ord b) => Rel a b -> a -> [b]+>--applyRel r a = setToList (rng (restrictDom (== a) r))+>--applyRel r a = [b|(a',b)<-setToList r,a'==a] -- not faster...+>applyRel r k = findWithDefault [] k fm +>  where fm = addListTo_C (++) emptyM [(a,[b])|(a,b)<- elems r]++Finally we define the operation #unionMapSet#, which is the ``bind''+operator of the set monad.  It is not an operation on relations, but +rather on arbitrary sets.  It is missing from the #Set# library, so we define+it here.++>unionMapSet :: Ord b => (a -> S.Set b) -> (S.Set a -> S.Set b)+>unionMapSet f = unions . map f . (elems)+
+ tools/base/Modules/SCMs.hs view
@@ -0,0 +1,22 @@+module SCMs where++import OpTypes+import NewSCC+--import Assoc+import List(find)+--import Maybe(fromMaybe)+import Maybe(mapMaybe)+import HsModule+++++hsModulesToGraph mods   = mods `zip` vals+    where+    vals        = (mapMaybe (lkpInMods . hsImpFrom) . hsModImports) `map` mods+    lkpInMods x = --fromMaybe (error $  "Missing module: "++show x) $+		  find ((== x) . hsModName) mods+++scMods ms = map (map fst) . sccEq (eqBy hsModName) . hsModulesToGraph $ ms+
+ tools/base/Modules/TypedIds.hs view
@@ -0,0 +1,113 @@+module TypedIds where+import Maybe(isJust)+import Data.Generics++{-++Haskell declaration introduce names in two name spaces. Type classes and+types live in one name space. Values (functions, data constructors) live+in another name space.+-}++data NameSpace = ClassOrTypeNames | ValueNames     deriving (Eq,Ord,Show, Data, Typeable)+++{-++Identifiers can denote many different types of entities. It is clear from+the defining occurence of an identifier what type of entity it denotes.++The type #IdTy# can be seen as a refinement of #NameSpace#.+From the use of an identifier, we can tell what name space it refers+to, but not the exact type of entity, hence the need for two different types.+-}++data IdTy i +    = Value +    | FieldOf i (TypeInfo i)+    | MethodOf i Int [i] -- name of class, number of superclasses, names of all methods+    | ConstrOf i (TypeInfo i)+    | Class Int [i] -- number of superclasses, names of all methods+    | Type (TypeInfo i)+    | Assertion -- P-Logic assertion name+    | Property  -- P-Logic property name+        deriving (Eq,Ord,Show,Read, Data, Typeable)+        -- These structures contain a lot of redundancy, so we shouldn't really+	-- use any comparison operations on them.++data ConInfo i = ConInfo +    { conName :: i+    , conArity :: Int+    , conFields :: Maybe [i] -- length agrees with conArity+    } deriving (Eq,Ord,Show,Read, Data, Typeable)++data DefTy     = Newtype | Data | Synonym | Primitive+               deriving (Eq,Ord,Show,Read, Data, Typeable)++data TypeInfo i = TypeInfo+    { defType       :: Maybe DefTy+    , constructors  :: [ConInfo i]+    , fields        :: [i]+    } deriving (Eq,Ord,Show,Read, Data, Typeable)++blankTypeInfo = TypeInfo { defType = Nothing, constructors = [], fields = [] }++++instance Functor ConInfo where+    fmap f c = c { conName = f (conName c),+		   conFields = fmap (map f) (conFields c) }++instance Functor TypeInfo where+    fmap f t = t { constructors = map (fmap f) (constructors t)+                 , fields = map f (fields t)+                 }++instance Functor IdTy where+    fmap f (FieldOf x tyInfo)   = FieldOf (f x) (fmap f tyInfo)+    fmap f (MethodOf x n xs)      = MethodOf (f x) n (map f xs)+    fmap f (ConstrOf t tyInfo)  = ConstrOf (f t) (fmap f tyInfo)+    fmap _ Value                = Value+    fmap f (Class n xs)         = Class n (f `map` xs)+    fmap f (Type tyInfo)        = Type (fmap f tyInfo)+    fmap _ Assertion            = Assertion+    fmap _ Property             = Property++class HasNameSpace t where+    namespace :: t -> NameSpace++instance HasNameSpace (IdTy id) where+    namespace Value         = ValueNames+    namespace (FieldOf {}) = ValueNames+    namespace (MethodOf {}) = ValueNames+    namespace (ConstrOf {}) = ValueNames+    namespace (Class {})    = ClassOrTypeNames+    namespace (Type {})     = ClassOrTypeNames+    namespace Assertion     = ValueNames -- hmm+    namespace Property      = ValueNames -- hmm+++-- owner :: IdTy i -> Maybe i+owner (FieldOf dt  _) = Just dt+owner (MethodOf cl _ _) = Just cl+owner (ConstrOf dt _) = Just dt+owner _               = Nothing+++-- isSubordinate :: IdTy i -> Bool+isSubordinate = isJust . owner++-- belongsTo :: idTy i -> i -> Bool+idty `belongsTo` t = owner idty == Just t++isAssertion Assertion = True+isAssertion Property  = True+isAssertion _         = False++isClassOrType,isValue :: HasNameSpace t => t -> Bool+isClassOrType   = (== ClassOrTypeNames) . namespace+isValue         = (== ValueNames)       . namespace++class HasIdTy i t | t->i where+  idTy :: t -> IdTy i++instance HasIdTy i (IdTy i) where idTy = id+--instance HasNameSpace NameSpace where namespace = id
+ tools/base/Modules/WorkModule.hs view
@@ -0,0 +1,124 @@+module WorkModule(WorkModuleI(..),Ent(..),ExpRel,+		  analyzeModules, -- obsolete+		  mkWM,inscpList,analyzeSCM,readRel,showRel+		  ) where++import Modules+import Maybe(fromMaybe,fromJust)+--import Names+import Ents++import DefinedNames+import Relations+import CheckModules+import SCMs+import ModSysAST+import AST4ModSys(toMod)++import PrettyPrint+import PPModules++import MUtils(mapFst,mapSnd)++#if __GLASGOW_HASKELL__ >= 604 +import qualified Data.Set as S hiding (map)++elemsS = S.elems+#else+import qualified Sets as S++elemsS = S.setToList+#endif+++-- a user of the module system+++type ExpRel n = Rel n (Ent n)++data WorkModuleI i n = WorkModuleI+    { inscpRel      :: Rel i (Ent n)+    , expRel        :: ExpRel n+    , inScope       :: i -> [Ent n]+    , inScopeDom    :: [i]+    , inScopeRng    :: [Ent n]+    , exports       :: [(n, Ent n)]+    }+inscpList = relToList . inscpRel++--instance (Ord i, Ord n, Read i, Read n) => Read (WorkModuleI i n) where+--    readsPrec p xs = [ (mkWM p,ys) | (p,ys) <- readsPrec p xs]++instance (Show i, Show n) => Show (WorkModuleI i n) where+    showsPrec p wm = showsPrec p (inscpRel wm, expRel wm)++mkWM (i,e) = WorkModuleI +        { inscpRel      = i+        , expRel        = e++        , inScope       = applyRel i+        , inScopeDom    = elemsS (dom i)+        , inScopeRng    = elemsS (rng i)+        , exports       = relToList e+        }++instance (Printable i, Printable n) => Printable (WorkModuleI i n) where+    ppi wm  = text "in scope:" +            $$ ppRel ((\x -> (x,inScope wm x)) `map` inScopeDom wm)+            $$ "exports:"+            $$ ppRel (exports wm)+++type ExportRel n = Rel n (Ent n)+{-+analyzeSCM :: +    (QualNames i ModuleName n, DefinedNames i ds, Eq n) => +    [(ModuleName, ExportRel n)] -> +    [HsModuleI i ds] -> +    Either +        [(ModuleName,[ModSysErr i ModuleName n (Ent n)])] +        [(ModuleName,WorkModuleI i n)]+-}+analyzeSCM exports_from_earlier scms +    | not (null errs)   = Left errs+    | otherwise         = Right newwms+    where+    mods        = toMod `map` scms+    newwms'     = mods `zip` map mkWM (computeInsOuts otherExps mods)+    newwms      = mapFst modName newwms'+    otherExps m = fromMaybe emptyRel $ lookup m exports_from_earlier++    all_exports = mapSnd expRel newwms++exports_from_earlier+    expsOf  m   = lookup m all_exports+    errs        = [ (modName m, es) | (m,wm) <- newwms', +                    let es = chkModule expsOf (inscpRel wm) m, not (null es) ]++    --fromJust' = fromMaybe (error "WorkModule.analyzeSCM")++-- obsolete function+analyzeModules ms +    | not $ all null errs   = Left $ reportErrs errs+    | otherwise             = Right (scms, wms)+    where++    scms    = scMods ms+    scmods  = map toMod `map` scms +    +    mods    = concat scmods+    names   = modName `map` mods+++    wms = foldl f [] scmods +        where+        f ws ms = ws ++ zipWith mk ms insouts+            where+            insouts     = computeInsOuts otherExps ms +            otherExps m = maybe emptyRel expRel $ lookup m ws++    mk mod p = (modName mod, mkWM p)+            +    reportErrs  = filter (not . null . snd) . zip names+   +    inscpOf = inscpRel . fromJust . flip lookup wms+    expsOf  = fmap expRel . flip lookup wms +    errs    = (\m -> chkModule expsOf (inscpOf (modName m)) m) `map` mods
+ tools/base/Modules/doc/Description.bib view
@@ -0,0 +1,136 @@++@TechReport{Haskell98old,+  author =       "Simon {Peyton Jones} and John {Hughes (editors)}",+  title =        "Report on the Programming Language {Haskell 98}",+  institution =  "Yale University, CS Dept.",+  type =         "Technical Report",+  number =       "YALEU/DCS/RR-1106",+  month =        feb,+  year =         "1999",+}++@Misc{Haskell98,+    author =    "Simon {Peyton Jones (editor)}",+    title =     "Report on the Programming Language {Haskell~98}",+    howpublished = "\verb!http://research.microsoft.com/! \verb!~simonpj/haskell98-revised/!",+    month =     "March",+    year =      "2002",+}+%%howpublished = "http://research.microsoft.com/$\sim$simonpj/ haskell98-revised/",++@Misc{GHC-ref-man,+    author =    "{The GHC team}",+    title =     "The {Glasgow} {Haskell} {Compiler} User's Guide Version 5.04",+    howpublished = "\verb!http://haskell.org/ghc/!",+    month =     "July",+    year =      "2002",+}++@inproceedings{thih,+ author =       "Mark P. Jones",+ title =        "Typing {Haskell} in {Haskell}",+ booktitle =    "Proceedings of the 3rd {Haskell} Workshop",+ address =      "Paris, France",+ month =        "October",+ year =         "1999"+}+++@Book{ML97,+  author =       "Robin Milner and Mads Tofte and Robert Harper and+                 David MacQueen",+  year =         "1997",+  title =        "The {Definition} of {Standard ML} (Revised)",+  publisher =    "The MIT Press",+  semno =        "D-346",+  puf =          "Bog",+  id =           "Bog",+}++@Book{Alg90,+  author =        "B. A. Davey and H. A. Priestley",+  year =          "1990",+  title =         "Introduction to Lattices and Order",+  publisher =     "Cambridge University Press", +}++@InProceedings{Wad85,+  author =        "Philip Wadler",+  title =         "How to replace failure by a list of successes",+  booktitle =     "In 2'nd International Conference on Functional Programming Languages and Computer Architecture",+  address =       "Nancy,France",+  month =         "September",+  year =          "1985",+  publisher =     "Springer-Verlag",+}++@inproceedings{shields-pj:first-class-modules,+  author = "MB Shields and SL {Peyton~Jones}",+  title = "First class modules for {Haskell}",+  booktitle = "9th International Conference on Foundations of Object-Oriented Languages ({FOOL} 9), Portland, Oregon",+  month = Jan,+  year = 2002,+  pages = "28-40"+}+++@InProceedings{harper+:sharing,+  author =   "Robert Harper and Mark Lillibridge",+  title =    "A Type-Theoretic Approach to Higher-Order Modules with+          Sharing",+  pages =    "123--137",+  booktitle = "Proc. of 1994 ACM Symposium on Principles of Programming Languages",+  year =     1994,+  address =      "Portland, OR",+  month =    "January"+}++@inproceedings{MacQueen:86,+author = "David B. MacQueen",+title = "Using Dependent Types to Express Modular Structure",+booktitle = "Proc. of 1986 ACM Symposium on Principles of Programming Languages",+note = "St. Petersburg",+month = {January},+year = {1986},+pages = "277--286"}++@ARTICLE{Leroy-modular-modules,+  AUTHOR = {Xavier Leroy},+  TITLE = {A modular module system},+  JOURNAL = {Journal of Functional Programming},+  VOLUME = 10,+  NUMBER = 3,+  YEAR = 2000,+  PAGES = {269--303},+  URL = {http://pauillac.inria.fr/~xleroy/publi/modular-modules-jfp.ps.gz},+}+++++++@Unpublished{SPJWad92,+  author = 	 "Simon {Peyton Jones} and Philip Wadler",+  title = 	 "A static semantics for {Haskell}",+  note = 	 "Unpublished draft",+  year =	 1992,+  howpublished = "http://research.microsoft.com/~simonpj/Papers/static-semantics.dvi.gz",+  address = 	 "Department of Computing Science, University of Glasgow"+}++@Article{Faxen02,+  author = 	 {Karl-Filip Faxén},+  title = 	 "{A Static Semantics for Haskell}",+  journal = 	 {Journal of Functional Programming},+  year = 	 2002,+  note =	 {To appear}+}++@misc{hallgren:alfa-homepage,+		  author = {T. Hallgren},+                  year = {1996-2002},+		  title = {{Home Page of the Proof Editor Alfa}},+		  howpublished = {\verb!http://www.cs.chalmers.se/~hallgren/Alfa/!},+                  documentURL = {http://www.cs.chalmers.se/~hallgren/Alfa/}+		  }
+ tools/base/Modules/doc/Description.tex view
@@ -0,0 +1,93 @@+%\documentclass[11pt,a4paper]{article}+%\documentclass[preprint]{sig-alt-full} +\documentclass[preprint]{sigplan-proc}+%\documentclass[acmtocl,acmnow]{acmtrans2m}+%\documentclass{acmtrans2m}+\usepackage{pphs}+\usepackage{amsmath}+\usepackage{latexsym}+\usepackage{isolatin1}++% \linespread{1.6}++%\addtolength{\textwidth}{1cm}++\def\SPACE{\mbox{\ \ \ \ \ }}++\newcommand{\ent}[2]{\ensuremath{\mathsf{{#1}}_{#2}}}+\newcommand{\tent}[2]{\ensuremath{\ent{#1}{#2}}^{\mathrm{type}}}+\newcommand{\cent}[2]{\ensuremath{\ent{#1}{#2}}^{\mathrm{class}}}+\newcommand{\set}[1]{\{{#1}\}}+\newcommand{\pr}[2]{{#1} \mapsto {#2}}++\newenvironment{ex}+{\vspace{3mm}\textbf{Example:}}+{\ensuremath{\Box}}++%\markboth{Diatchki, Jones \& Hallgren}{A Formal Specification for the Haskell 98 Module System}  % left and right page headers++%\title{A Formal Specification of the Haskell 98 Module System}++%\author{Iavor S.~Diatchki \SPACE Mark P.~Jones \SPACE Thomas Hallgren\\%+%	Department of Computer Science and Engineering \\%+%        OGI School of Science and Engineering \\%+%        Oregon Health \& Science University}++%------------------------------------------------------------------------------+\begin{document}+\conferenceinfo{Haskell'02,}{October 3, 2002, Pittsburgh, Pennsylvania, USA.}+\CopyrightYear{2002}+\crdata{1-58113-605-6/02/0010}+\setcounter{page}{17}++\title{A Formal Specification of the Haskell 98 Module System}+%\titlenote{A full version of this paper is available as a tech-report}+++\numberofauthors{1}+\author{\alignauthor Iavor S. Diatchki, Mark P. Jones, Thomas Hallgren\\+           \affaddr{OGI School of Science \& Engineering}\\+           \affaddr{Oregon Health \& Science University}\\+           \affaddr{20000 NW Walker Rd, Beaverton, Oregon, USA}\\+           \email{\{diatchki,mpj,hallgren\}@cse.ogi.edu}\\+%        \alignauthor{Mark P Jones}\\+%           \affaddr{OGI School of Science \& Engineering}\\+%           \affaddr{Oregon Health \& Science University}\\+%           \email{mpj@cse.ogi.edu}\\+%        \alignauthor{Thomas Hallgren}\\+%           \affaddr{OGI School of Science \& Engineering}\\+%           \affaddr{Oregon Health \& Science University}\\+%           \email{hallgren@cse.ogi.edu}\\+  }++% \date{May 24, 2002}+\maketitle+++%\makeatactive++\begin{abstract}+\input{abstract}+\end{abstract}++\category{D.3.1}{Programming Languages}{Formal Definitions and Theory}[semantics, Haskell]+\category{D.3.3}{Programming Languages}{Language Constructs and Features}[Modules, packages, Recursion, Haskell]+\terms{Documentation,Standardization,Languages}+\keywords{Specification, Haskell, module system}++\input{intro}+\input{Relations}+\input{NamesEntities}+\input{ModSysAST}+\input{Modules}+\input{CheckModules}+\input{ModSysSem}+\input{related_work}+\input{conclusion}++\bibliography{Description}+\bibliographystyle{abbrv}+% \bibliographystyle{plain}++\end{document}+
+ tools/base/Modules/doc/Hack view
binary file changed (absent → 586220 bytes)
+ tools/base/Modules/doc/MakeMake.hs view
@@ -0,0 +1,65 @@+import Pretty++src_dir = text ".."+names   = map text ["Modules","NamesEntities","CheckModules","Relations",+		    "ModSysAST","ModSysSem"]++description     = text "Description"+formats         = [".dvi", ".pdf", ".ps"]+main_targets    = (hsep $ map (description <>) $ map text formats) +tex_files       = hsep $ map toTex (names ++ map text +                [ "related_work", "abstract", "conclusion", "intro"])++src_deps        = tex_files <+> text "Description.bbl" <+> text "pphs.sty"+++makefile = text "all:" <+> main_targets ++        $$ text "Description.dvi:" <+> src_deps+        $$ latex <+> description++        $$ text "Description.pdf:" <+> src_deps+        $$ pdflatex <+> description++        $$ text "Description.ps:  Description.dvi"+        $$ dvips <+> text "Description.dvi -o Description.ps"++        $$ text "Description.bbl: Description.tex Description.bib"+        $$ latex <+> description+        $$ bibtex <+> description++        $$ vcat (map target names)++        $$ text "tmp:" +        $$ mkdir <+> text "tmp"++        $$ text "clean:"+        $$ rm <+> main_targets +        $$ rm <+> text "tmp/*"+        $$ rm <+> text "*.log *.aux *.blg"+++toTex n = n <> text ".tex"+toSrc n = src_dir <> char '/' <> n <> text ".lhs"++target n = tex <> char ':' <+> src <+> text "tmp"+        $$ hack <+> src <+> to <+> tex+    where+    src = toSrc n+    tex = toTex n++-- commands++tab         = char '\t'+to          = char '>'+hack        = tab <> text "./Hack"+rm          = tab <> text "-rm"+mkdir       = tab <> text "mkdir"+latex       = tab <> text "latex"+pdflatex    = tab <> text "pdflatex"+dvips       = tab <> text "dvips -t letter"+bibtex      = tab <> text "bibtex"++main = putStrLn $ render makefile++
+ tools/base/Modules/doc/Makefile view
@@ -0,0 +1,28 @@+all: Description.dvi Description.pdf Description.ps+Description.dvi: Modules.tex NamesEntities.tex CheckModules.tex Relations.tex ModSysAST.tex ModSysSem.tex related_work.tex abstract.tex conclusion.tex intro.tex Description.bbl pphs.sty+	latex Description+Description.pdf: Modules.tex NamesEntities.tex CheckModules.tex Relations.tex ModSysAST.tex ModSysSem.tex related_work.tex abstract.tex conclusion.tex intro.tex Description.bbl pphs.sty+	pdflatex Description+Description.ps:  Description.dvi+	dvips -t letter Description.dvi -o Description.ps+Description.bbl: Description.tex Description.bib+	latex Description+	bibtex Description+Modules.tex: ../Modules.lhs tmp+	./Hack ../Modules.lhs > Modules.tex+NamesEntities.tex: ../NamesEntities.lhs tmp+	./Hack ../NamesEntities.lhs > NamesEntities.tex+CheckModules.tex: ../CheckModules.lhs tmp+	./Hack ../CheckModules.lhs > CheckModules.tex+Relations.tex: ../Relations.lhs tmp+	./Hack ../Relations.lhs > Relations.tex+ModSysAST.tex: ../ModSysAST.lhs tmp+	./Hack ../ModSysAST.lhs > ModSysAST.tex+ModSysSem.tex: ../ModSysSem.lhs tmp+	./Hack ../ModSysSem.lhs > ModSysSem.tex+tmp:+	mkdir tmp+clean:+	-rm Description.dvi Description.pdf Description.ps+	-rm tmp/*+	-rm *.log *.aux *.blg
+ tools/base/Modules/doc/README view
@@ -0,0 +1,19 @@+One can use MakeMake.hs to create the makefile.+e.g. runhugs MakeMake.hs > Makefile++To make the most recent versions of the files+type "make".++IMPORTANT NOTES:+    +    * there needs to be a directory named "tmp" in the current directory.+    * might need to make the DVI file twice, to get the references right.+    * the binaries in this directory were made for Mandrake 8.1+      (will probably work on RedHat 7.2 as well, haven't tried)+        * they don't work on turing as there seems to be a missing library+        * a vesrion compiled on turing, which seems to work is available+          at /disk/hopper/users/students/diatchki/bin/Hack+          +          the Makefile has to be changed to make use of it.++
+ tools/base/Modules/doc/TODO.txt view
@@ -0,0 +1,109 @@+Sec 5++Wouldn't a better type for mProgram be:++  ... -> [Either [ModSysErr qn m n ent] (Rel qn ent, Rel n ent)]++or is this impossible?++++References++Are you aware of Cardelli's paper on modules and linking?++  Luca Cardelli. Program fragments, linking, and modularization. Conference+  Record of POPL'97: The 24th ACM SIGPLAN-SIGACT Symposium on Principles of+  Programming Languages, Papers Presented at the Symposium, Paris, France,+  15-17 January 1997. ACM Press, New York, 1997, ISBN 0-89791-853-3. pp+  266-277.+  http://www.luca.demon.co.uk/Bibliography.html++-------------------------------------------------------------------------++   - Section 1.1 The term "interface" is used in a confusing way (many+     of us think of an interface as a file containing information+     about the exports of a module for the compiler).  Here it seems+     to mean the export list, or information derived from it.  It+     might be less confusing to say this earlier.+++-- XXX: don't like this very much.+     "The main use of this feature is to avoid cluttering other+     modules with spurious names":  perhaps instead "The main use of+     this feature is to hide certain names defined in a module from+     other modules which import it".+  ++   - Section 5: "The definition of this function is straightforward":+     then give it!++     "This function should check...":  which function - mProgram,+     computeInsOuts, or chkModule?++   - Section 5.1: the code could perhaps go in a figure, to make it+     easier to refer to while reading the text, and to avoid splitting+     it over two pages.++   - Section 5.3.  The code for mImp is particularly beatiful :-)++   - Section 5.4. "this will not be very practical for large systems".+     Practicality hasn't been addressed at all yet - indeed the+     specification so far has happily ignored questions of efficiency+     in favour of clarity, so it seems strange at this point to make a+     concession to practicality.  If the fixpoint calculation would+     give the same answer without first breaking down the module+     structure into SCCs, then do it that way for clarity and+     consistency, but note also that for efficiency in a real+     implementation one might want to break down the structure into+     SCCs first.++     I would welcome some comments about efficiency too: perhaps+     suggestions for more efficient data structures than the+     ubiquitous Rel: eg. is 'FiniteMap a [b]' a better choice than+     'Rel a b' for some parts of the algorithm?.++--- XXX: we talked about such an approach, but I am not sure where it +--- could be placed in the paper+     Perhaps another way to disambiguation the export/import lists+     would be to use the keywords 'class', 'data', 'newtype' and+     'type' before an entity name.  This would also have the side+     effect of separating the class and type constructor namespaces+     (which may or may not be a good idea).++   - General comments on presentation: I would have preferred the code+     to be typeset in a typewriter font (perhaps with keywords+     emboldened), but that's maybe a personal preference.  ++     "qualified" should be bold (page 18)++     In several places the branches of case expressions need to be+     indented further to the right than the 'case' on the line above.++-------------------------------------------------------------------------++  This paper formally explores the module system, a part of the+  Haskell language which, although it appears simple on the surface,+  actually turns out to have sufficient complexity for many people+  to express occasional surprise.++  The authors present their formalisation as Haskell code, following+  the style of Jones `Typing Haskell in Haskell'.  Algorithms are+  presented which: (1) computes the `in-scope' relation of a single+  module, i.e. resolves imports  (2) computes the `export' relation+  of a single module, and (3) detects errors, i.e. ambiguity or+  missing entities.++  The presentation is solid, and the algorithms straightforward+  to understand.  A highlight is the specification (at last) of+  what recursive modules mean.++  One minor criticism might be the assumption that all modules are+  available to the algorithm - there is not enough discussion of+  how separate compilation might work in this setting.  Of course+  separate compilation does not cope with recursive modules, but+  nevertheless I think there are some potentially interesting angles+  to discover there.++-------------------------------------------------------------------------+
+ tools/base/Modules/doc/abstract.tex view
@@ -0,0 +1,16 @@+Many programming languages provide means to split large programs+into smaller modules.  The module system of a language specifies what+constitutes a module and how modules interact.+%, and what can programmers do with them.  ++This paper presents a formal specification of the module system for+the functional programming language Haskell.  Although many aspects of+Haskell have been subjected to formal analysis, the module system has,+to date, been described only informally as part of the Haskell language+report.  As a result, some aspects of it are not well understood or are+under-specified; this causes difficulties in reasoning about Haskell+programs, and leads to practical problems such as inconsistencies between+different implementations.  One significant aspect of our work is that+the specification is written in Haskell, which means that it can also+be used as an executable test-bed, and as a starting point for Haskell+implementers.
+ tools/base/Modules/doc/acmtrans.bst view
@@ -0,0 +1,1770 @@+% "ACM Transactions" BibTeX style, acmtrans.bst +%  for BibTeX version 0.99c, LaTeX version 3.141+%  Revised 28-MARCH-1996+%  Revised 30-JUNE-1995+%  Revised 15-JAN-1996 +%  $Header: /cvs/programatica/tools/base/Modules/doc/acmtrans.bst,v 1.1 2002/05/23 18:24:12 diatchki Exp $+%+% Hacked by John T. Boyland at University of California, Berkeley+% (with assistance by John R. Hauser)+% Hacked by Andrew W. Appel and Rebecca L. Davies at Princeton University,+% based on a "chicago.bst" by Glenn Paulley at U. Waterloo,+% which was based on "newapa.bst" found at ymir.claremont.edu.+%+%   Citation format: [author-last-name year]+%             [author-last-name and author-last-name year]+%             [author-last-name, author-last-name, and author-last-name year]+%             [author-last-name et al. year]+%             [author-last-name]+%             author-last-name [year]+%             [author-last-name and author-last-name]+%             [author-last-name et al.]+%             [year] or [year,year]+%             year or year,year+%+%   Reference list ordering: alphabetical by author or whatever passes+%    for author in the absence of one.+%+% This BibTeX style has support for abbreviated author lists and for+%    year-only citations.  This is done by having the citations+%    actually look like+%+%    \citeauthoryear{full-author-info}{abbrev-author-info}{year}+%+% The LaTeX style has to have the following (or similar)+%+%     \let\@internalcite\cite+%     \def\fullcite{\def\citeauthoryear##1##2##3{##1, ##3}\@internalcite}+%     \def\fullciteA{\def\citeauthoryear##1##2##3{##1}\@internalcite}+%     \def\shortcite{\def\citeauthoryear##1##2##3{##2, ##3}\@internalcite}+%     \def\shortciteA{\def\citeauthoryear##1##2##3{##2}\@internalcite}+%     \def\citeyear{\def\citeauthoryear##1##2##3{##3}\@internalcite}+%+% These TeX macro definitions are found in acmtrans.sty. Additional+% commands to manipulate different components of a citation can be defined+% so that, for example, you can list author's names without parentheses+% if using a citation as a noun or object in a sentence.+%+% Features of acmtrans.bst:+% ========================+%+% - all authors appear last name first.+% - all pages are listed xx-xx, (no pp.) and are at the end of the reference+% - publishers are identified as publisher, address+% - conferences papers (inproceedings) may give city of conference,+%   date of conference, and journal that the proceedings appear in.+% - months abbreviated to max four letters (eg. Mar.)+% - volume of a series indicated after the title of the series+% - editors appear after edited title and are identified by a trailing "Eds."+%   not in parentheses.  Editor names are not given in small caps.+%   (unless there is no author line)+% - names terminated with a period even if there is no first name.+% - editions are indicated trailing after the work, not in parentheses.+% - "et al." citations have a protected period to avoid bad spacing (jrh)+% - "address" required when publisher given+% - series (roman) and volume are in a sentence separate from (book-)title+%+%+% Features of chicago.bst:+% =======================+%+% - full names used in citations, but abbreviated citations are available+%   (see above)+% - if an entry has a "month", then the month and year are also printed+%   as part of that bibitem.+% - all conjunctions use "and" instead of "\&"+% - major modification from Chicago Manual of Style (13th ed.) is that+%   only the first author in a reference appears last name first-+%   additional authors appear as J. Q. Public.+% - pages are listed as "pp. xx-xx" in all entry types except+%   article entries.+% - book, inbook, and manual use "location: publisher" (or organization)+%   for address and publisher. All other types list publishers separately.+% - "pp." are used to identify page numbers for all entry types except+%   articles.+% - organization is used as a citation label if neither author nor editor+%   is present (for manuals).+% - "et al." is used for long author and editor lists, or when "others"+%   is used.+%+% Modifications and bug fixes from newapa.bst:+% ===========================================+%+%   - added month, year to bib entries if month is present+%   - fixed bug with In proceedings, added necessary comma after title+%   - all conjunctions changed to "and" from "\&"+%   - fixed bug with author labels in my.full.label: "et al." now is+%        generated when "others" is an author name+%   - major modification from Chicago Manual of Style (13th ed.) is that+%     only the first author in a reference appears last name first-+%     additional authors appear as J. Q. Public.+%   - pages are listed as "pp. xx-xx" in all entry types except+%     article entries. Unnecessary (IMHO) "()" around page numbers+%     were removed, and page numbers now don't end with a period.+%   - created chicago.sty for use with this bibstyle (required).+%   - fixed bugs in FUNCTION {format.vol.num.pages} for missing volume,+%     number, and /or pages. Renamed to format.jour.vol.+%   - fixed bug in formatting booktitles: additional period an error if+%     book has a volume.+%   - fixed bug: editors usually given redundant period before next clause+%     (format.editors.dot) removed.+%   - added label support for organizations, if both author and editor+%     are missing (from alpha.bst). If organization is too long, then+%     the key field is used for abbreviated citations.+%   - In proceedings or books of several volumes, no comma was written+%     between the "Volume x" and the page numbers (this was intentional+%     in newapa.bst). Fixed.+%   - Some journals may not have volumes/numbers, only month/year (eg.+%     IEEE Computer). Fixed bug in article style that assumed volume/number+%     was always present.+%+% Original documentation for newapa.sty:+% =====================================+%+% This version was made by modifying the master file made by+% Oren Patashnik (PATASHNIK@SCORE.STANFORD.EDU), and the 'named' BibTeX+% style of Peter F. Patel-Schneider.+%+% Copyright (C) 1985, all rights reserved.+% Copying of this file is authorized only if either+% (1) you make absolutely no changes to your copy, including name, or+% (2) if you do make changes, you name it something other than 'newapa.bst'.+% There are undoubtably bugs in this style.  If you make bug fixes,+% improvements, etc.  please let me know.  My e-mail address is:+%    spencer@cgrg.ohio.state.edu or 71160.3141@compuserve.com+%+% This style was made from 'plain.bst', 'named.bst', and 'apalike.bst',+% with lots of tweaking to make it look like APA style, along with tips+% from Young Ryu and Brian Reiser's modifications of 'apalike.bst'.++ENTRY+  { address+    author+    booktitle+    chapter+    city	% jtb: added+    date	% jtb: added+    edition+    editor+    howpublished+    institution+    journal+    key+    month+    note+    number+    organization+    pages+    publisher+    school+    series+    title+    type+    volume+    year+  }+  {}+  { label.year extra.label sort.year sort.label }++INTEGERS { output.state before.all mid.sentence after.sentence after.block }++FUNCTION {init.state.consts}+{ #0 'before.all :=+  #1 'mid.sentence :=+  #2 'after.sentence :=+  #3 'after.block :=+}++STRINGS { s t u }++FUNCTION {output.nonnull}+{ 's :=+  output.state mid.sentence =+    { ", " * write$ }+    { output.state after.block =+    { add.period$ write$+      newline$+      "\newblock " write$+    }+    { output.state before.all =+        'write$+        { add.period$ " " * write$ }+      if$+    }+      if$+      mid.sentence 'output.state :=+    }+  if$+  s+}++% Use a colon to separate output. Used only for address/publisher+% combination in book/inbook types, address/institution for manuals,+% and organization:publisher for proceedings (inproceedings).+%+FUNCTION {output.nonnull.colon}+{ 's :=+  output.state mid.sentence =+    { ": " * write$ }+    { output.state after.block =+    { add.period$ write$+      newline$+      "\newblock " write$+    }+    { output.state before.all =+        'write$+        { add.period$ " " * write$ }+      if$+    }+      if$+      mid.sentence 'output.state :=+    }+  if$+  s+}++FUNCTION {output}+{ duplicate$ empty$+    'pop$+    'output.nonnull+  if$+}++FUNCTION {output.colon}+{ duplicate$ empty$+    'pop$+    'output.nonnull.colon+  if$+}++FUNCTION {output.check}+{ 't :=+  duplicate$ empty$+    { pop$ "empty " t * " in " * cite$ * warning$ }+    'output.nonnull+  if$+}++FUNCTION {output.check.colon}+{ 't :=+  duplicate$ empty$+    { pop$ "empty " t * " in " * cite$ * warning$ }+    'output.nonnull.colon+  if$+}++FUNCTION {output.year.check}+{ year empty$+     { "empty year in " cite$ * warning$ }+     { write$+        " " year * extra.label *+       mid.sentence 'output.state :=+     }+  if$+}+++FUNCTION {fin.entry}+{ add.period$+  write$+  newline$+}++FUNCTION {new.block}+{ output.state before.all =+    'skip$+    { after.block 'output.state := }+  if$+}++FUNCTION {new.sentence}+{ output.state after.block =+    'skip$+    { output.state before.all =+    'skip$+    { after.sentence 'output.state := }+      if$+    }+  if$+}++FUNCTION {not}+{   { #0 }+    { #1 }+  if$+}++FUNCTION {and}+{   'skip$+    { pop$ #0 }+  if$+}++FUNCTION {or}+{   { pop$ #1 }+    'skip$+  if$+}++FUNCTION {new.block.checka}+{ empty$+    'skip$+    'new.block+  if$+}++FUNCTION {new.block.checkb}+{ empty$+  swap$ empty$+  and+    'skip$+    'new.block+  if$+}++FUNCTION {new.sentence.checka}+{ empty$+    'skip$+    'new.sentence+  if$+}++FUNCTION {new.sentence.checkb}+{ empty$+  swap$ empty$+  and+    'skip$+    'new.sentence+  if$+}++FUNCTION {field.or.null}+{ duplicate$ empty$+    { pop$ "" }+    'skip$+  if$+}++%+% Emphasize the top string on the stack.+%+FUNCTION {emphasize}+{ duplicate$ empty$+    { pop$ "" }+    { "{\em " swap$ * "}" * }+  if$+}++%+% Emphasize the top string on the stack, but add a trailing space.+%+FUNCTION {emphasize.space}+{ duplicate$ empty$+    { pop$ "" }+    { "{\em " swap$ * "\/}" * }+  if$+}++%+% Emphasize the top string on stack, add a trailing comma and space.+%+FUNCTION {emphasize.comma}+{ duplicate$ empty$+    { pop$ "" }+    { "{\em " swap$ * ",\/}" * }+  if$+}++INTEGERS { nameptr namesleft numnames }+%+% Format bibliographical entries with the first author last name first,+% and subsequent authors with initials followed by last name.+% All names are formatted in this routine.+%++FUNCTION {format.names}+{ 's :=+  #1 'nameptr :=               % nameptr = 1;+  s num.names$ 'numnames :=    % numnames = num.name$(s);+  numnames 'namesleft :=+    { namesleft #0 > }++    { nameptr #1 =+        {"{\sc " s nameptr "{vv~}{ll}{, jj}{, f.}" format.name$ * "}" * 't := }+        {"{\sc " s nameptr "{vv~}{ll}{, jj}{, f.}" format.name$ * "}" * 't := }+      if$+      nameptr #1 >+        { namesleft #1 >+              { ", " * t * }+              { numnames #2 >+                  { "," * }+                  'skip$+                if$+                t "{\sc others}" =+                    { " {\sc et~al\mbox{.}}" * } % jrh: avoid spacing problems+                    { " {\sc and} " * t * } % from Chicago Manual of Style+                  if$+               }+               if$+             }+            't+        if$+        nameptr #1 + 'nameptr :=          % nameptr += 1;+        namesleft #1 - 'namesleft :=      % namesleft =- 1;+    }+  while$+}++FUNCTION {my.full.label}+{ 's :=+  #1 'nameptr :=               % nameptr = 1;+  s num.names$ 'numnames :=    % numnames = num.name$(s);+  numnames 'namesleft :=+    { namesleft #0 > }++    { s nameptr "{vv~}{ll}" format.name$ 't :=  % get the next name+      nameptr #1 >+        { namesleft #1 >+              { ", " * t * }+              { numnames #2 >+                  { "," * }+                  'skip$+                if$+                t "others" =+                    { " et~al\mbox{.}" * } % jrh: avoid spacing problems+                    { " and " * t * } % from Chicago Manual of Style+                  if$+               }+               if$+             }+            't+        if$+        nameptr #1 + 'nameptr :=          % nameptr += 1;+        namesleft #1 - 'namesleft :=      % namesleft =- 1;+    }+  while$++}++FUNCTION {format.names.fml}+%+% Format names in "familiar" format, with first initial followed by+% last name. Like format.names, ALL names are formatted.+% jtb: The names are NOT put in small caps+%+{ 's :=+  #1 'nameptr :=               % nameptr = 1;+  s num.names$ 'numnames :=    % numnames = num.name$(s);+  numnames 'namesleft :=+    { namesleft #0 > }++    { "{" s nameptr "{f.~}{vv~}{ll}{, jj}" format.name$ * "}" * 't :=++      nameptr #1 >+        { namesleft #1 >+              { ", " * t * }+               { numnames #2 >+                    { "," * }+                    'skip$+                  if$+                  t "{others}" =+                        { " {et~al\mbox{.}}" * }+                        { " {and} " * t * }+%                       { " {\&} " * t * }+                      if$+                }+               if$+             }+            't+        if$+        nameptr #1 + 'nameptr :=          % nameptr += 1;+        namesleft #1 - 'namesleft :=      % namesleft =- 1;+    }+  while$+}++FUNCTION {format.authors}+{ author empty$+    { "" }+    { author format.names add.period$} % jtb: add period if none before+  if$+}++FUNCTION {format.key}+{ empty$+    { key field.or.null }+    { "" }+  if$+}++%+% Format editor names for use in the "in" types: inbook, incollection,+% inproceedings: first initial, then last names. When editors are the+% LABEL for an entry, then format.editor is used which lists editors+% by last name first.+%+FUNCTION {format.editors.fml}+{ editor empty$+    { "" }+    { editor format.names.fml+      editor num.names$ #1 >+    { ", Eds." * }	% jtb: removed parentheses+    { ", Ed." * }	% jtb: removed parentheses+      if$+    }+  if$+}++%+% Format editor names for use in labels, last names first.+%+FUNCTION {format.editors}+{ editor empty$+    { "" }+    { editor format.names+      editor num.names$ #1 >+    { ", Eds." * }	% jtb: removed parentheses+    { ", Ed." * }	% jtb: removed parentheses+      if$+    }+  if$+}++FUNCTION {format.title}+{ title empty$+    { "" }+    { title "t" change.case$ }+  if$+}++% Note that the APA style requres case changes+% in article titles. The following does not+% change cases. If you perfer it, uncomment the+% following and comment out the above.++%FUNCTION {format.title}+%{ title empty$+%    { "" }+%    { title }+%  if$+%}++FUNCTION {n.dashify}+{ 't :=+  ""+    { t empty$ not }+    { t #1 #1 substring$ "-" =+    { t #1 #2 substring$ "--" = not+        { "--" *+          t #2 global.max$ substring$ 't :=+        }+        {   { t #1 #1 substring$ "-" = }+        { "-" *+          t #2 global.max$ substring$ 't :=+        }+          while$+        }+      if$+    }+    { t #1 #1 substring$ *+      t #2 global.max$ substring$ 't :=+    }+      if$+    }+  while$+}++FUNCTION {format.btitle}+{ edition empty$+  { title emphasize }+  { title empty$+    { title emphasize } % jtb: what is this supposed to do ?!?+    { "{\em " title * "\/}, " * edition * " ed." * } % jtb: no parens for ed.+    if$+  }+  if$+}++FUNCTION {format.emphasize.booktitle}+{ edition empty$+  { booktitle emphasize }+  { booktitle empty$+    { booktitle emphasize } % jtb: what is this supposed to do ?!?+    { "{\em " booktitle * "\/}, " * edition * " ed." * } % jtb: no ()s for ed.+    if$+    }+  if$+  }++% jtb: if the preceding string (the title of the conference) is non-empty,+% jtb: append the location, otherwise leave empty (so as to trigger the+% jtb: error message in output.check+FUNCTION {format.city}+{ duplicate$ empty$+  { }+  { city empty$+     { date empty$+       { }+       { " (" * date * ")" * }+       if$+     }+     { date empty$+       { " (" * city * ")" * }+       { " (" * city * ", " * date * ")" * }+       if$+     }+     if$+  }+  if$+}++FUNCTION {tie.or.space.connect}+{ duplicate$ text.length$ #3 <+    { "~" }+    { " " }+  if$+  swap$ * *+}++FUNCTION {either.or.check}+{ empty$+    'pop$+    { "can't use both " swap$ * " fields in " * cite$ * warning$ }+  if$+}++% jtb: If there is a series, this is added and the volume trails after it.+% jtb: Otherwise, "Vol" is Capitalized.+FUNCTION {format.bvolume}+{ volume empty$+    { "" }+    { series empty$+        { "Vol." volume tie.or.space.connect}+        { series ", " * "vol." volume tie.or.space.connect *}+      if$+      "volume and number" number either.or.check+    }+  if$+}++FUNCTION {format.number.series}+{ volume empty$+    { number empty$+    { series field.or.null }+    { output.state mid.sentence =+        { "Number" } % gnp - changed to mixed case always+        { "Number" }+      if$+      number tie.or.space.connect+      series empty$+        { "there's a number but no series in " cite$ * warning$ }+        { " in " * series * }+      if$+    }+      if$+    }+    { "" }+  if$+}++INTEGERS { multiresult }++FUNCTION {multi.page.check}+{ 't :=+  #0 'multiresult :=+    { multiresult not+      t empty$ not+      and+    }+    { t #1 #1 substring$+      duplicate$ "-" =+      swap$ duplicate$ "," =+      swap$ "+" =+      or or+    { #1 'multiresult := }+    { t #2 global.max$ substring$ 't := }+      if$+    }+  while$+  multiresult+}++FUNCTION {format.pages}+{ pages empty$+  { "" }+  { pages multi.page.check+	{ pages n.dashify } % gnp - removed () % jtb: removed pp.+	{ pages }+    if$+  }+  if$+}++% By Young (and Spencer)+% GNP - fixed bugs with missing volume, number, and/or pages+%+% Format journal, volume, number, pages for article types.+%+FUNCTION {format.jour.vol}+{ journal empty$+    { "no journal in " cite$ * warning$+      "" }+    { journal emphasize.space }+    if$+  number empty$+    { volume empty$+       { "no number and no volume in " cite$ * warning$+         "" * }+       { "~{\em " * Volume * "}" * }+      if$+    }+    { volume empty$+      {"no volume for " cite$ * warning$+       "~" * number * }+      { "~" *+        volume emphasize.comma+        "~" * number * * }+      if$+     month empty$+     {} +     {" (" * month * ")" *} +     if$+    }+  if$+  pages empty$+    {"page numbers missing in " cite$ * warning$+     "" * } % gnp - place a null string on the stack for output+    { duplicate$ empty$+      { pop$ format.pages }+      { ", " *  pages n.dashify * } % gnp - removed pp. for articles+      if$+    }+  if$+}++FUNCTION {format.chapter.pages}+{ chapter empty$+    'format.pages+    { type empty$+        { "Chapter" } % gnp - changed to mixed case+        { type "t" change.case$ }+      if$+      chapter tie.or.space.connect+      pages empty$+        {"page numbers missing in " cite$ * warning$} % gnp - added check+        { ", " * format.pages * }+      if$+    }+  if$+}++% jtb: format for collections or proceedings not appearing in a journal+FUNCTION {format.in.emphasize.booktitle}+{ booktitle empty$+  { "" }+  { "In " format.emphasize.booktitle * }+  if$+}++% jtb: format for proceedings appearing in a journal+FUNCTION {format.in.booktitle}+{ booktitle empty$+  { "" }+  { "In " booktitle * }+  if$+}++FUNCTION {format.in.ed.booktitle}+{ booktitle empty$+  { "" }+  { editor empty$+    { "In " format.emphasize.booktitle * }+		% jtb: swapped editor location+    { "In " format.emphasize.booktitle * ", " * format.editors.fml * }+    if$+  }+  if$+}++FUNCTION {format.thesis.type}+{ type empty$ +    'skip$+%   {pop$+   {{ "" }+   type "t" change.case$}+  if$+}++FUNCTION {format.tr.number}+{ type empty$+    { "Tech. Rep." }+    'type+  if$+  number empty$+    { "t" change.case$ }+    { number tie.or.space.connect }+  if$+}++FUNCTION {format.article.crossref}+{ "See"+  "\citeN{" * crossref * "}" *+}++FUNCTION {format.crossref.editor}+{ editor #1 "{vv~}{ll}" format.name$+  editor num.names$ duplicate$+  #2 >+    { pop$ " et~al\mbox{.}" * }		% jrh: avoid spacing problems+    { #2 <+    'skip$+    { editor #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" =+        { " et~al\mbox{.}" * }		% jrh: avoid spacing problems+        { " and " * editor #2 "{vv~}{ll}" format.name$ * }+      if$+    }+      if$+    }+  if$+}++FUNCTION {format.book.crossref}+{ volume empty$+    { "empty volume in " cite$ * "'s crossref of " * crossref * warning$+      "In "+    }+    { "Volume" volume tie.or.space.connect % gnp - changed to mixed case+      " of " *+    }+  if$+  editor empty$+  editor field.or.null author field.or.null =+  or+    { key empty$+    { series empty$+        { "need editor, key, or series for " cite$ * " to crossref " *+          crossref * warning$+          "" *+        }+        { "{\em " * series * "\/}" * }+      if$+    }+    { key * }+      if$+    }+    { format.crossref.editor * }+  if$+  " \citeN{" * crossref * "}" *+}++FUNCTION {format.incoll.inproc.crossref}+{ "See"+  " \citeN{" * crossref * "}" *+}++% format.lab.names:+%+% determines "short" names for the abbreviated author information.+% "Long" labels are created in calc.label, using the routine my.full.label+% to format author and editor fields.+%+% There are 4 cases for labels.   (n=3 in the example)+% a) one author             Foo+% b) one to n               Foo, Bar and Baz+% c) use of "and others"    Foo, Bar et al.+% d) more than n            Foo et al.+%+FUNCTION {format.lab.names}+{ 's :=+  s num.names$ 'numnames :=+  numnames #2 >    % change number to number of others allowed before+		   % forcing "et al".+    { s #1 "{vv~}{ll}" format.name$ " et~al\mbox{.}" * } % jrh: \mbox{} added+    {+      numnames #1 - 'namesleft :=+      #2 'nameptr :=+      s #1 "{vv~}{ll}" format.name$+	{ namesleft #0 > }+	{ nameptr numnames =+	    { s nameptr "{ff }{vv }{ll}{ jj}" format.name$ "others" =+		{ " et~al\mbox{.}" * }		% jrh: avoid spacing problems+		{ " and " * s nameptr "{vv~}{ll}" format.name$ * }+	      if$+	    }+	    { ", " * s nameptr "{vv~}{ll}" format.name$ * }+	  if$+	  nameptr #1 + 'nameptr :=+	  namesleft #1 - 'namesleft :=+	}+      while$+    }+  if$+}++FUNCTION {author.key.label}+{ author empty$+    { key empty$+          { "no key, author in " cite$ * warning$+            cite$ #1 #3 substring$ }+         'key+      if$+    }+    { author format.lab.names }+  if$+}++FUNCTION {editor.key.label}+{ editor empty$+    { key empty$+          { "no key, editor in " cite$ * warning$+            cite$ #1 #3 substring$ }+          'key+        if$+     }+     { editor format.lab.names }+  if$+}++FUNCTION {author.key.organization.label}+%+% added - gnp. Provide label formatting by organization if author is null.+%+{ author empty$+    { organization empty$+	{ key empty$+	    { "no key, author or organization in " cite$ * warning$+              cite$ #1 #3 substring$ }+	    'key+	  if$+	}+        { organization }+      if$+    }+    { author format.lab.names }+  if$+}++FUNCTION {editor.key.organization.label}+%+% added - gnp. Provide label formatting by organization if editor is null.+%+{ editor empty$+    { organization empty$+	{ key empty$+	    { "no key, editor or organization in " cite$ * warning$+              cite$ #1 #3 substring$ }+	    'key+	  if$+	}+        { organization }+      if$+    }+    { editor format.lab.names }+  if$+}++FUNCTION {author.editor.key.label}+{ author empty$+    { editor empty$+          { key empty$+               { "no key, author, or editor in " cite$ * warning$+                 cite$ #1 #3 substring$ }+             'key+           if$+         }+          { editor format.lab.names }+      if$+    }+    { author format.lab.names }+  if$+}++FUNCTION {calc.label}+%+% Changed - GNP. See also author.organization.sort, editor.organization.sort+% Form label for BibTeX entry. The classification of which fields are used+% for which type of entry (book, inbook, etc.) are taken from alpha.bst.+% The change here from newapa is to also include organization as a+% citation label if author or editor is missing.+%+{ type$ "book" =+  type$ "inbook" =+  or+    'author.editor.key.label+    { type$ "proceedings" =+	'editor.key.organization.label+	{ type$ "manual" =+	    'author.key.organization.label+	    'author.key.label+	  if$+	}+      if$+    }+  if$++  author empty$  % generate the full label citation information.+    { editor empty$+        { organization empty$+           { "no author, editor, or organization in " cite$ * warning$+             "??" }+           { organization }+           if$+        }+        { editor my.full.label }+        if$+    }+    { author my.full.label }+  if$++% leave label on the stack, to be popped when required.++  "}{" * swap$ * "}{" *+%  year field.or.null purify$ #-1 #4 substring$ *+%+% save the year for sort processing afterwards (adding a, b, c, etc.)+%+  year field.or.null purify$ #-1 #4 substring$+  'label.year :=+}++FUNCTION {output.bibitem}+{ newline$++  "\bibitem[\protect\citeauthoryear{" write$+  calc.label write$+  sort.year write$+  "}]{" write$++  cite$ write$+  "}" write$+  newline$+  ""+  before.all 'output.state :=+}++FUNCTION {article}+{ output.bibitem+  format.authors+  "author" output.check+  author format.key output          % added+  output.year.check                 % added+  new.block+  format.title+  "title" output.check+  new.block+  crossref missing$+    { format.jour.vol output+    }+    { format.article.crossref output.nonnull+      format.pages output+    }+  if$+  new.block+  note output+  fin.entry+}++FUNCTION {book}+{ output.bibitem+  author empty$+    { format.editors+	  "author and editor" output.check }+    { format.authors+	  output.nonnull+      crossref missing$+    	{ "author and editor" editor either.or.check }+    	'skip$+      if$+    }+  if$+  output.year.check       % added+  new.block+  format.btitle+  "title" output.check+  crossref missing$+    { new.sentence		% jtb: start a new sentence for series/volume+      format.bvolume output+      new.block+      format.number.series output+      new.sentence+      publisher "publisher" output.check+      address "address" output.check	% jtb: require address+    }+    { new.block+      format.book.crossref output.nonnull+    }+  if$+  new.block+  note output+  fin.entry+}++FUNCTION {booklet}+{ output.bibitem+  format.authors output+  author format.key output          % added+  output.year.check                 % added+  new.block+  format.title+  "title" output.check+  new.block+  howpublished output+  address output+  new.block+  note output+  fin.entry+}++FUNCTION {inbook}+{ output.bibitem+  author empty$+    { format.editors+      "author and editor" output.check+    }+    { format.authors output.nonnull+      crossref missing$+    { "author and editor" editor either.or.check }+    'skip$+      if$+    }+  if$+  output.year.check                 % added+  new.block+  format.btitle+  "title" output.check+  crossref missing$+    { new.sentence		% jtb: start a new sentence for series/volume+      format.bvolume output+      new.block+      format.number.series output+      new.sentence+      publisher "publisher" output.check+      address "address" output.check	% jtb: require address+      format.chapter.pages+      "chapter and pages" output.check	% jtb: moved from before publisher+    }+    { format.chapter.pages "chapter and pages" output.check+      new.block+      format.book.crossref output.nonnull+    }+  if$+  new.block+  note output+  fin.entry+}++FUNCTION {incollection}+{ output.bibitem+  format.authors+  "author" output.check+  author format.key output       % added+  output.year.check              % added+  new.block+  format.title+  "title" output.check+  new.block+  crossref missing$+  { format.in.ed.booktitle+    "booktitle" output.check+    new.sentence		% jtb: start a new sentence for series/volume+    format.bvolume output+    format.number.series output+    new.sentence+    publisher "publisher" output.check+    address "address" output.check	% jtb: require address+    format.chapter.pages output % gnp - was special.output.nonnull+%                                 left out comma before page numbers+				% jtb: moved from before publisher+  }+  { format.incoll.inproc.crossref+	output.nonnull+    format.chapter.pages output+  }+  if$+  new.block+  note output+  fin.entry+}++FUNCTION {inproceedings}+{ output.bibitem+  format.authors+  "author" output.check+  author format.key output            % added+  output.year.check                   % added+  new.block+  format.title+  "title" output.check+  new.block+  crossref missing$+    { journal missing$		% jtb: proceedings appearing in journals+      { format.in.emphasize.booktitle format.city "booktitle" output.check+        format.editors.fml output+        new.sentence		% jtb: start a new sentence for series/volume+        format.bvolume output+        format.number.series output+        new.sentence+        organization output+        publisher "publisher" output.check % jtb: require publisher (?)+        address "address" output.check	% jtb: require address+        format.pages output	% jtb: moved from before publisher+       }+       % jtb: new:+       { format.in.booktitle format.city "booktitle" output.check+         format.editors.fml output+         new.sentence+         format.jour.vol output+       }+       if$+      }+    { format.incoll.inproc.crossref output.nonnull+      format.pages output+    }+  if$+  new.block+  note output+  fin.entry+}++FUNCTION {conference} { inproceedings }++FUNCTION {manual}+{ output.bibitem+  author empty$+    { editor empty$+      { organization "organization" output.check+        organization format.key output }  % if all else fails, use key+      { format.editors "author and editor" output.check }+      if$+    }+    { format.authors output.nonnull }+    if$+  output.year.check                 % added+  new.block+  format.btitle+  "title" output.check+  organization address new.block.checkb+  % jtb: back to normal style: organization, address+  organization "organization" output.check+  address output+  new.block+  note output+  fin.entry+}++FUNCTION {mastersthesis}+{ output.bibitem+  format.authors+  "author" output.check+  author format.key output          % added+  output.year.check                 % added+  new.block+  format.title+  "title" output.check+  new.block+  "M.S.\ thesis" format.thesis.type output.nonnull+  school "school" output.check+  address output+  new.block+  note output+  fin.entry+}++FUNCTION {misc}+{ output.bibitem+  format.authors output+  author format.key output            % added+  output.year.check                   % added+  title howpublished new.block.checkb+  format.title output+  new.block+  howpublished output+  new.block+  note output+  fin.entry+}++FUNCTION {phdthesis}+{ output.bibitem+  format.authors+  "author" output.check+  author format.key output            % added+  output.year.check                   % added+  new.block+  format.title+  "title" output.check+  new.block  +  format.thesis.type "Ph.D. thesis" output.nonnull+  school "school" output.check+  address output+  new.block+  note output+  fin.entry+}++FUNCTION {proceedings}+{ output.bibitem+  editor empty$+    { organization output+      organization format.key output }  % gnp - changed from author format.key+    { format.editors output.nonnull }+  if$+% author format.key output             % gnp - removed (should be either+%                                        editor or organization+  output.year.check                    % added (newapa)+  new.block+  format.btitle format.city "title" output.check	% jtb: added city+  new.sentence+  format.bvolume output+  format.number.series output+  new.sentence+  organization output+  % jtb: normal order: publisher, address+  publisher output+  address output+  new.block+  note output+  fin.entry+}++FUNCTION {techreport}+{ output.bibitem+  format.authors+  "author" output.check+  author format.key output             % added+  output.year.check                    % added+  new.block+  format.title+  "title" output.check+  new.block+  format.tr.number output		% jtb: moved month ...+  institution "institution" output.check+  address output+  new.sentence+  month output				% jtb: ... to here (no parens)+  new.block+  note output+  fin.entry+}++FUNCTION {unpublished}+{ output.bibitem+  format.authors+  "author" output.check+  author format.key output              % added+  output.year.check                      % added+  new.block+  format.title+  "title" output.check+  new.block+  note "note" output.check+  fin.entry+}++FUNCTION {default.type} { misc }++MACRO {jan} {"Jan."}++MACRO {feb} {"Feb."}++MACRO {mar} {"Mar."}		% jtb: corrected: was "March"++MACRO {apr} {"Apr."}		% jtb: corrected: was "April"++MACRO {may} {"May"}++MACRO {jun} {"June"}++MACRO {jul} {"July"}++MACRO {aug} {"Aug."}++MACRO {sep} {"Sept."}++MACRO {oct} {"Oct."}++MACRO {nov} {"Nov."}++MACRO {dec} {"Dec."}++MACRO {acmcs} {"ACM Comput. Surv."}++MACRO {acmlett} {"ACM Lett. Program. Lang. Syst."}++MACRO {acta} {"Acta Inf."}++MACRO {ai} {"Artificial Intelligence"}++MACRO {al} {"Ada Lett."}++MACRO {acr} {"Adv. Comput. Res."}++MACRO {bit} {"Bit"}++MACRO {cacm} {"Commun. ACM"}++MACRO {cj} {"Comput. J."}++MACRO {cn} {"Comput. Netw."}++MACRO {cl} {"Comput. Lang."}++MACRO {ibmjrd} {"IBM J. Res. and Development"}++MACRO {ibmsj} {"IBM Systems Journal"}++MACRO {ict} {"Inf. Contr."}++MACRO {ieebcs} {"IEE/BCS Softw. Eng. J."}++MACRO {ieees} {"IEEE Softw."}++MACRO {ieeese} {"IEEE Trans. Softw. Eng."}++MACRO {ieeetc} {"IEEE Trans. Comput."}++MACRO {ieeetcad}+ {"IEEE Transactions on Computer-Aided Design of Integrated Circuits"}++MACRO {ieeetpds} {"IEEE Trans. Parall. Distrib. Syst."}++MACRO {ieeetit} {"IEEE Trans. Inf. Theory"}++MACRO {ipl} {"Inf. Process. Lett."}++MACRO {icp} {"Inf. Comput."}++MACRO {ist} {"Inf. Softw. Tech."}++MACRO {ijsa} {"Int. J. Supercomput. Appl."}++MACRO {ijpp} {"Int. J. Parallel Program."}++MACRO {jlp} {"J. Logic Program."}++MACRO {jfp} {"J. Funct. Program."}++MACRO {jcss} {"J. Comput. Syst. Sci."}++MACRO {jsmrp} {"J. Softw. Maint. Res. Pract."}++MACRO {jss} {"J. Syst. Softw."}++MACRO {jlc} {"J. Logic and Comput."}++MACRO {jlsc} {"J. Lisp Symb. Comput."}++MACRO {lpls} {"Lett. Program. Lang. Syst."}++MACRO {mor} {"Math. Oper. Res."}++MACRO {mscs} {"Math. Struct. Comput. Sci."}++MACRO {mst} {"Math. Syst. Theor."}	% jtb: was Math. Syst. Theory+				% jtb: (if you ask me, I prefer the old way)+MACRO {ngc} {"New Gen. Comput."}++MACRO {scp} {"Sci. Comput. Program."}++MACRO {sicomp} {"SIAM J. Comput."}++MACRO {spe} {"Softw. Pract. Exper."}++MACRO {tocs} {"ACM Trans. Comput. Syst."}++MACRO {tods} {"ACM Trans. Database Syst."}++MACRO {tog} {"ACM Trans. Graphics"}++MACRO {toms} {"ACM Trans. Math. Softw."}++MACRO {toois} {"ACM Trans. Office Inf. Syst."}++MACRO {toplas} {"ACM Trans. Program. Lang. Syst."}++MACRO {tocl} {"ACM Trans. On Comp. Logic"}++MACRO {tcs} {"Theor. Comput. Sci."}	% jtb: was Theor. Comp. Sci.++MACRO {tr} {"Tech. Rep."}++READ++FUNCTION {sortify}+{ purify$+  "l" change.case$+}++INTEGERS { len }++FUNCTION {chop.word}+{ 's :=+  'len :=+  s #1 len substring$ =+    { s len #1 + global.max$ substring$ }+    's+  if$+}++++FUNCTION {sort.format.names}+{ 's :=+  #1 'nameptr :=+  ""+  s num.names$ 'numnames :=+  numnames 'namesleft :=+    { namesleft #0 > }+    { nameptr #1 >+          { "   " * }+         'skip$+      if$+      s nameptr "{vv{ } }{ll{ }}{  f{ }}{  jj{ }}" format.name$ 't :=+      nameptr numnames = t "others" = and+          { " et~al" * }+          { t sortify * }+      if$+      nameptr #1 + 'nameptr :=+      namesleft #1 - 'namesleft :=+    }+  while$+}++FUNCTION {sort.format.title}+{ 't :=+  "A " #2+    "An " #3+      "The " #4 t chop.word+    chop.word+  chop.word+  sortify+  #1 global.max$ substring$+}++FUNCTION {author.sort}+{ author empty$+    { key empty$+         { "to sort, need author or key in " cite$ * warning$+           "" }+         { key sortify }+      if$+    }+    { author sort.format.names }+  if$+}++FUNCTION {editor.sort}+{ editor empty$+    { key empty$+         { "to sort, need editor or key in " cite$ * warning$+           ""+         }+         { key sortify }+      if$+    }+    { editor sort.format.names }+  if$+}++FUNCTION {author.editor.sort}+{ author empty$+    { "missing author in " cite$ * warning$+      editor empty$+         { key empty$+             { "to sort, need author, editor, or key in " cite$ * warning$+               ""+             }+             { key sortify }+           if$+         }+         { editor sort.format.names }+      if$+    }+    { author sort.format.names }+  if$+}++FUNCTION {author.organization.sort}+%+% added - GNP. Stack author or organization for sorting (from alpha.bst).+% Unlike alpha.bst, we need entire names, not abbreviations+%+{ author empty$+    { organization empty$+	{ key empty$+	    { "to sort, need author, organization, or key in " cite$ * warning$+	      ""+	    }+	    { key sortify }+	  if$+	}+	{ organization sortify }+      if$+    }+    { author sort.format.names }+  if$+}++FUNCTION {editor.organization.sort}+%+% added - GNP. Stack editor or organization for sorting (from alpha.bst).+% Unlike alpha.bst, we need entire names, not abbreviations+%+{ editor empty$+    { organization empty$+	{ key empty$+	    { "to sort, need editor, organization, or key in " cite$ * warning$+	      ""+	    }+	    { key sortify }+	  if$+	}+	{ organization sortify }+      if$+    }+    { editor sort.format.names }+  if$+}++FUNCTION {presort}+%+% Presort creates the bibentry's label via a call to calc.label, and then+% sorts the entries based on entry type. Chicago.bst adds support for+% including organizations as the sort key; the following is stolen from+% alpha.bst.+%+{ calc.label sortify % recalculate bibitem label+  year field.or.null purify$ #-1 #4 substring$ * % add year+  "    "+  *+  type$ "book" =+  type$ "inbook" =+  or+    'author.editor.sort+    { type$ "proceedings" =+	'editor.organization.sort+	{ type$ "manual" =+	    'author.organization.sort+	    'author.sort+	  if$+	}+      if$+    }+  if$+  #1 entry.max$ substring$        % added for newapa+  'sort.label :=                  % added for newapa+  sort.label                      % added for newapa+  *+  "    "+  *+  title field.or.null+  sort.format.title+  *+  #1 entry.max$ substring$+  'sort.key$ :=+}++ITERATE {presort}++SORT             % by label, year, author/editor, title++STRINGS { last.label next.extra }++INTEGERS { last.extra.num }++FUNCTION {initialize.extra.label.stuff}+{ #0 int.to.chr$ 'last.label :=+  "" 'next.extra :=+  #0 'last.extra.num :=+}++FUNCTION {forward.pass}+%+% Pass through all entries, comparing current entry to last one.+% Need to concatenate year to the stack (done by calc.label) to determine+% if two entries are the same (see presort)+%+{ last.label+  calc.label year field.or.null purify$ #-1 #4 substring$ * % add year+  #1 entry.max$ substring$ =     % are they equal?+     { last.extra.num #1 + 'last.extra.num :=+       last.extra.num int.to.chr$ 'extra.label :=+     }+     { "a" chr.to.int$ 'last.extra.num :=+       "" 'extra.label :=+       calc.label year field.or.null purify$ #-1 #4 substring$ * % add year+       #1 entry.max$ substring$ 'last.label := % assign to last.label+     }+  if$+}++FUNCTION {reverse.pass}+{ next.extra "b" =+    { "a" 'extra.label := }+     'skip$+  if$+  label.year extra.label * 'sort.year :=+  extra.label 'next.extra :=+}++EXECUTE {initialize.extra.label.stuff}++ITERATE {forward.pass}++REVERSE {reverse.pass}++FUNCTION {bib.sort.order}+{ sort.label+  "    "+  *+  year field.or.null sortify+  *+  "    "+  *+  title field.or.null+  sort.format.title+  *+  #1 entry.max$ substring$+  'sort.key$ :=+}++ITERATE {bib.sort.order}++SORT             % by sort.label, year, title --- giving final bib. order.++FUNCTION {begin.bib}++{ preamble$ empty$+    'skip$+    { preamble$ write$ newline$ }+  if$+  "\begin{thebibliography}{}" write$ newline$+}+++EXECUTE {begin.bib}++EXECUTE {init.state.consts}++ITERATE {call.type$}++FUNCTION {end.bib}+{ newline$+  "\end{thebibliography}" write$ newline$+}++EXECUTE {end.bib}++++++++++++++
+ tools/base/Modules/doc/acmtrans2m.cls view
@@ -0,0 +1,1460 @@+% latex2e by nr 7/3/96+% acmtrans.cls revised 4/19/96+%              revised again 31-JAN-1996 (see end of file)+%              revised 5-14-1997 :+%                       Don't use sans-serif font in categories and descriptors+%                       include latexsym by default+%                       Define longpage and shortpage+% Adjusted from the acmtrans2e.cls file to the needs of ACM TOCL by+% Marco Aiello on June 14, 2000.+% Further changes made by Frederic Goualard on Sep. 27, 2000+% to take care of the indentation problem in the bibliography +% arising without the use of the hyperref package.+% Modularization to adapt to the needs of JACM, TOCL, +% TODAES, TODS, TOGS, TOMS, AND TOPLAS, by Marco Aiello on +% June 2001.+% Here is the basic framework that is needed to convert your paper +% into ACM Transactions format and bibliographic format.  For a tutorial+% introduction, see ``instructions.tex'' (compile it with LaTeX) that+% accompanies the distribution of this style file.+%+%  -> \documentclass{acmtrans2m}+%  -> \markboth{}{}+%         takes 2 arguments and it is for the left- and right-page headers:+%         the first set of braces is assigned for author's name(s) +%         and+%         the second set of braces is assigned for the title +%             (if the title is too long, contraction may be needed+%  -> \title{}+%         if the title is too long, it can be separated by \\+%  -> \author{}+%         author1 \\ author1 affiliation+%         \and+%         author2 \\ author2 affiliation+%  -> \begin{abstract}+%  -> \end{abstract}+%+%  -> \category{}{}{}+%         takes 3 arguments for the Computing Reviews Classification Scheme.+%         ex: \category{D.3.3}{Programming Languages}{Language Constructs and +%                   Features}[data types and structures]+%                   the last argument, in square brackets, is optional.+%  -> \terms{} (ex: \terms{Human Factors, Languages})+%  -> \keywords{} (in alphabetical order \keywords{document processing, sequences, +%                      string searching, subsequences, substrings})+%  -> \begin{document}+%+%  -> \begin{bottomstuff}+%          similar to \thanks     +%          for authors' addresses; research/grant statements+%  -> \end{bottomstuff}+%  -> \maketitle+%+%     Now you can start the body of the paper; your figures, tables and +%          use all the latex constructs.+%+%  -> \begin{acks}+%          acknowledgements+%  -> \end{acks}+%+%  -> \bibliographystyle{acmtrans}+%  -> \bibliography{mybib_file}+%+%     ****+%     If your paper has been accepted with a separate (electronic only)+%        appendix, you need to add the following control sequence:+%+%+%       body of appendix +%!!!!!! \appendixhead has be cut into two: \appendixhead and \elecappendix+%!!!!!! See end of file. (jtb)+%+%  -> \end{document}+%+% Do not worry about the other definitions in this style file+% Remember to compile: latex, bibtex, latex latex+%+% Bibliographic cite forms needed:+%+%  \cite{key}+%    which produces citations with author list and year.+%    eg. [Brown 1978; Jarke, et al. 1985]+%  \citeA{key}+%    which produces citations with only the author list.+%    eg. [Brown; Jarke, et al.]+%  \citeN{key}+%    which produces citations with the author list and year, but+%    can be used as nouns in a sentence; no brackets appear around+%    the author names, but only around the year.+%      eg. Shneiderman [1978] states that......+%    \citeN should only be used for a single citation.+%    \citeNN{refkey1,refkey2} for author [ref1year; ref2year]+%    \citeyear{key}+%        which produces the year information only, within brackets.+%+% Abbreviated author lists use the ``et al.'' construct.+%+% The above are examples of required ACM bibliographic cite formats needed.+% *******************+% Here is the complete list of cite forms from the chicago bibliographic style+%+%  \cite{key}+%    which produces citations with abbreviated author list and year.+%  \citeNP{key}+%    which produces citations with abbreviated author list and year.+%  \citeA{key}+%    which produces only the abbreviated author list.+%  \citeANP{key}+%    which produces only the abbreviated author list.+%  \citeN{key}+%    which produces the abbreviated author list and year, with only the+%    year in parentheses. Use with only one citation.+%  \citeyear{key}+%    which produces the year information only, within parentheses.+%  \citeyearNP{key}+%    which produces the year information only.+%+% Abbreviated author lists use the ``et al.'' construct.+%+% `NP' means `no parentheses' +%++\NeedsTeXFormat{LaTeX2e}+\ProvidesClass{acmtrans2m} [1996/07/03 ACM Transactions class based on <23 April 96>]+\RequirePackage{latexsym}+%aiellom{+\RequirePackage{url}++% Do not change the following! Use the appropriate acmtocl, acmtods, ... option+\def\@acmVolume{V} %the volume+\def\@acmNumber{N} %the number+\def\@acmYear{YY}  %the last two digits of the year, +\def\@acmMonth{Month}  %the month+\def\@journalName{ACM Journal Name} %the name of the ACM journal+\def\@journalNameShort{jn} %the acronym of the ACM journal+\def\@permissionCodeOne{0000-0000} %the permission code of the ACM journal+\def\@permissionCodeTwo{0000} %the permission code of the ACM journal part 2+\def\@pageCode{\acmPageCode} %the first page of the article in 4 digits+++\newif\if@acmjacm+\newif\if@acmtocl+\newif\if@acmtodaes+\newif\if@acmtods+\newif\if@acmtogs+\newif\if@acmtoms+\newif\if@acmtoplas++\DeclareOption{acmnow}{+  \typeout{}+  \typeout{Directly generating the Month and Year for footers from the clock.}+  \def\@acmYear{\yearTwoDigits}  +  \def\@acmMonth{\monthWord}  +}++\DeclareOption{acmjacm}{+  \typeout{}+  \typeout{Using ACM, JACM's option: 2001/06/01 by Marco Aiello et al.}+  \typeout{}+  %\global\@acmjacmfalse  +  \global\@acmtoclfalse+  \global\@acmtodaesfalse+  \global\@acmtodsfalse+  \global\@acmtogsfalse+  \global\@acmtomsfalse+  \global\@acmtoplasfalse+  \global\@acmjacmtrue+  \def\@journalName{Journal of the ACM}+  \def\@journalNameShort{jacm}        +  \def\@permissionCodeOne{0004-5411} +  \def\@permissionCodeTwo{0100} +}++\DeclareOption{acmtocl}{+  \typeout{}+  \typeout{Using ACM, TOCL's option: 2001/06/01 by Marco Aiello et al.}+  \typeout{}+  \global\@acmjacmfalse  +  \global\@acmtoclfalse+  \global\@acmtodaesfalse+  \global\@acmtodsfalse+  \global\@acmtogsfalse+  \global\@acmtomsfalse+  \global\@acmtoplasfalse+  \global\@acmtocltrue+  \def\@journalName{ACM Transactions on Computational Logic}+  \def\@journalNameShort{tocl}        +  \def\@permissionCodeOne{1529-3785} +  \def\@permissionCodeTwo{0700} +}++\DeclareOption{acmtodaes}{+  \typeout{}+  \typeout{Using ACM, TODAES option: 2001/06/01 by Marco Aiello et al.}+  \typeout{}+  \global\@acmjacmfalse  +  \global\@acmtoclfalse+  %\global\@acmtodaesfalse+  \global\@acmtodsfalse+  \global\@acmtogsfalse+  \global\@acmtomsfalse+  \global\@acmtoplasfalse+  \global\@acmtodaestrue+  \def\@journalName{ACM Transactions on Design Automation of Electronic Systems}+  \def\@journalNameShort{todaes}        +  \def\@permissionCodeOne{1084-4309} +  \def\@permissionCodeTwo{0400} +}++\DeclareOption{acmtods}{+  \typeout{}+  \typeout{Using ACM, TODS's option: 2001/06/01 by Marco Aiello et al.}+  \typeout{}+  \global\@acmjacmfalse  +  \global\@acmtoclfalse+  \global\@acmtodaesfalse+  %\global\@acmtodsfalse+  \global\@acmtogsfalse+  \global\@acmtomsfalse+  \global\@acmtoplasfalse+  \global\@acmtodstrue+  \def\@journalName{ACM Transactions on Database Systems}+  \def\@journalNameShort{tods}        +  \def\@permissionCodeOne{0362-5915} +  \def\@permissionCodeTwo{0300} +}++\DeclareOption{acmtogs}{+  \typeout{}+  \typeout{Using ACM, TOGS's option: 2001/06/01 by Marco Aiello et al.}+  \typeout{}+  \global\@acmjacmfalse  +  \global\@acmtoclfalse+  \global\@acmtodaesfalse+  \global\@acmtodsfalse+  %\global\@acmtogsfalse+  \global\@acmtomsfalse+  \global\@acmtoplasfalse+  \global\@acmtogstrue+  \def\@journalName{ACM Transactions on Graphics}+  \def\@journalNameShort{togs}        +  \def\@permissionCodeOne{0730-0301} +  \def\@permissionCodeTwo{0100} +}++\DeclareOption{acmtoms}{+  \typeout{}+  \typeout{Using ACM, TOMS's option: 2001/06/01 by Marco Aiello et al.}+  \typeout{}+  \global\@acmjacmfalse  +  \global\@acmtoclfalse+  \global\@acmtodaesfalse+  \global\@acmtodsfalse+  \global\@acmtogsfalse+  %\global\@acmtomsfalse+  \global\@acmtoplasfalse+  \global\@acmtomstrue+  \def\@journalName{ACM Transactions on Mathematical Software}+  \def\@journalNameShort{toms}        +  \def\@permissionCodeOne{0098-3500} +  \def\@permissionCodeTwo{1200} +}++\DeclareOption{acmtoplas}{+  \typeout{}+  \typeout{Using ACM, TOPLAS option: 2001/06/01 by Marco Aiello et al.}+  \typeout{}+  \global\@acmjacmfalse  +  \global\@acmtoclfalse+  \global\@acmtodaesfalse+  \global\@acmtodsfalse+  \global\@acmtogsfalse+  \global\@acmtomsfalse+  %\global\@acmtoplasfalse+  \global\@acmtoplastrue+  \def\@journalName{ACM Transactions on Programming Languages and Systems}+  \def\@journalNameShort{toplas}        +  \def\@permissionCodeOne{0164-0925} +  \def\@permissionCodeTwo{0500} +}+%}aiellom++++\if@compatibility\else+\DeclareOption{a4paper}+   {\setlength\paperheight {297mm}%+    \setlength\paperwidth  {210mm}%+    \def\special@paper{210mm,297mm}}+\DeclareOption{a5paper}+   {\setlength\paperheight {210mm}%+    \setlength\paperwidth  {148mm}%+    \def\special@paper{148mm,210mm}}+\DeclareOption{b5paper}+   {\setlength\paperheight {250mm}%+    \setlength\paperwidth  {176mm}%+    \setlength\voffset     {-15mm}%+    \setlength\hoffset     {-20mm}%+    \def\special@paper{176mm,250mm}}+\DeclareOption{letterpaper}+   {\setlength\paperheight {11in}%+    \setlength\paperwidth  {8.5in}%+    \def\special@paper{8.5in,11in}}+\DeclareOption{legalpaper}+   {\setlength\paperheight {14in}%+    \setlength\paperwidth  {8.5in}%+    \def\special@paper{8.5in,14in}}+\DeclareOption{executivepaper}+   {\setlength\paperheight {10.5in}%+    \setlength\paperwidth  {7.25in}%+    \def\special@paper{7.25in,10.5in}}+\DeclareOption{landscape}+   {\setlength\@tempdima   {\paperheight}%+    \setlength\paperheight {\paperwidth}%+    \setlength\paperwidth  {\@tempdima}}+\fi++\DeclareOption{checkMargin}{\setlength\overfullrule{5pt}}+\DeclareOption{final}{\setlength\overfullrule{0pt}}++\DeclareOption{oneside}{\@twosidefalse \@mparswitchfalse}+\DeclareOption{twoside}{\@twosidetrue  \@mparswitchtrue}++\DeclareOption{10pt}{\def\@ptsize{0}} %needed for amssymbols.sty +\DeclareOption{11pt}{\ClassError{acmtrans}{11pt style not supported}+                        {ACM transactions documents can be set in 10pt only}}+\DeclareOption{12pt}{\ClassError{acmtrans}{11pt style not supported}+                        {ACM transactions documents can be set in 10pt only}}+\newif\if@hyperref+\DeclareOption{hyperref}{%+        \def\pages{\pageref{@firstpg}--\pageref{@lastpg}}%+        \def\mypage{\thepage}%+        \def\@getpagenum#1#2#3#4{#2}%+        \def\pdfinfo#1#2{\pdfmark{pdfmark=/DOCINFO,Title=#1,Author=#2}}+        \global\@hyperreftrue+        }+\DeclareOption{nohyperref}{+                \def\pages{\pageref{@firstpg}--\pageref{@lastpg}}%+                \def\@getpagenum#1#2{#2}%+                \def\mypage{\thepage}%+                \def\pdfinfo#1#2{}%+                \def\pdfbookmark#1#2{}%+                \global\@hyperreffalse+                }+\DeclareOption{notfinal}{+                \def\pages{BD}%+                \def\mypage{TBD}%+                \def\@getpagenum#1#2{#2}%+                \def\pdfinfo#1#2{}%+                \def\pdfbookmark#1#2{}%+                }+\DeclareOption{omitline}{\def\@abstractbottom{\relax}}+\DeclareOption{dontomitline}{\def\@abstractbottom{\if@acmjacm\else\hbox{\vrule height .2pt width 30pc}\fi}}+\ExecuteOptions{twoside,notfinal,10pt,dontomitline,nohyperref,letterpaper} % defaults++++\ProcessOptions++%{aiellom to automatize the issue specific data+\def\acmVolume#1{\def\@acmVolume{#1}}+\def\acmNumber#1{\def\@acmNumber{#1}}+\def\acmYear#1{\def\@acmYear{#1}}+\def\acmMonth#1{\def\@acmMonth{#1}}+++% Command to get the year from the system and display the last two digits+\newcommand{\ignoretwo}[2]{}+\newcommand{\yearTwoDigits}{\expandafter\ignoretwo\the\year}+%To transform the month number in its name in English+\newcommand{\monthWord}{\ifnum\the\month=1 January\fi\ifnum\the\month=2 February\fi\ifnum\the\month=3 March\fi\ifnum\the\month=4 April\fi\ifnum\the\month=5 May\fi\ifnum\the\month=6 June\fi\ifnum\the\month=7 July\fi\ifnum\the\month=8 August\fi\ifnum\the\month=9 September\fi\ifnum\the\month=10 October\fi\ifnum\the\month=11 November\fi\ifnum\the\month=12 December\fi}+% overright the \@setref definition, so that if a reference is undefined +% then it returns a number 0 and then the usual double boldface +% question marks ??+% this is necessary for the \acmPageCode command, otherwise it gives an error +% everytime the aux file is not there+\def\@setref#1#2#3{%+  \ifx#1\relax+    \number 0\relax+    \protect\G@refundefinedtrue+    \nfss@text{\reset@font\bfseries ??}%+    \@latex@warning{Reference `#3' on page \thepage \space undefined}%+  \else+    \expandafter#2#1\null+  \fi}+%make the code a four digits string based on the first page number+\newcommand{\acmPageCode}{\bgroup+  \newcount\c@tempo+  \setcounter{tempo}{\number\pageref{@firstpg}}\ifnum \c@tempo<1000 0\fi\ifnum \c@tempo<100 0\fi\ifnum \c@tempo<10 0\fi\ifnum \c@tempo<1 0\fi\pageref{@firstpg}+  \egroup+}+%}aiellom++++\lineskip 1pt \normallineskip 1pt+\def\baselinestretch{1}++\renewcommand\normalsize{%+  \@setfontsize\normalsize\@xpt\@xiipt+  \abovedisplayskip 6pt plus2pt minus1pt\belowdisplayskip \abovedisplayskip+  \abovedisplayshortskip 6pt plus0pt minus 3pt+  \belowdisplayshortskip 6pt plus0pt minus3pt\let\@listi\@listI} ++\newcommand\small{%+  \@setfontsize\small\@ixpt{11pt}%+  \abovedisplayskip 5pt plus 2pt minus 1pt\belowdisplayskip \abovedisplayskip+  \abovedisplayshortskip 5pt plus0pt minus2pt\belowdisplayshortskip 5pt plus0pt+      minus 2pt+  \def\@listi{\leftmargin\leftmargini \topsep 5pt plus 2pt minus 1pt\parsep 0pt+    plus .7pt +  \itemsep 1.6pt plus .8pt}}+\newcommand\footnotesize{%+%   \@setfontsize\footnotesize\@viiipt{10pt}+ \@setsize\footnotesize{10pt}\viiipt\@viiipt+  \abovedisplayskip 4pt plus 1pt minus 0pt\belowdisplayskip \abovedisplayskip+  \abovedisplayshortskip 4pt plus 0pt minus 1pt\belowdisplayshortskip 4pt plus+       0pt minus 1pt+  \def\@listi{\leftmargin\leftmargini \topsep 4pt plus 1pt minus+     0pt\parsep 0pt plus .5pt +     \itemsep 1pt plus .7pt}}++\newcommand\scriptsize{\@setfontsize\scriptsize\@viipt\@viiipt}+\newcommand\tiny{\@setfontsize\tiny\@vpt\@vipt}+\newcommand\large{\@setfontsize\large\@xiipt{14}}+\newcommand\Large{\@setfontsize\Large\@xivpt{18}}+\newcommand\LARGE{\@setfontsize\LARGE\@xviipt{20}}+\newcommand\huge{\@setfontsize\huge\@xxpt{25}}+\newcommand\Huge{\@setfontsize\Huge\@xxvpt{30}}++\normalsize ++ \oddsidemargin .75in \evensidemargin .75in \marginparwidth .5in + \marginparsep .125in + \topmargin .25in \headheight 12pt\headsep 16pt+  %% not in latex2e  \footheight 10pt+  \footskip 15pt ++\textheight 47pc \textwidth 30pc \columnsep 10pt \columnseprule 0pt +% next five lines added by K.R. Apt, March 20, 01+\advance\textheight-2.6pt+\newdimen\normaltextheight+\setlength\normaltextheight{\textheight}+%\renewcommand\rmdefault{pnc}+%\renewcommand\sfdefault{phv}+++\footnotesep 7pt+\skip\footins 15pt plus 4pt minus 3pt +\floatsep 12pt plus 2pt minus 2pt +\textfloatsep \floatsep +\intextsep 1pc plus 1pc +%%% not in 2e %% \@maxsep 1pc +%%% not in 2e %% \@dblmaxsep 20pt +\dblfloatsep 12pt plus 2pt minus 2pt +\dbltextfloatsep 20pt plus 2pt minus 4pt +\@fptop 0pt plus 1fil \@fpsep 1pc plus 2fil \@fpbot 0pt plus 1fil +\@dblfptop 0pt plus 1fil \@dblfpsep 8pt plus 2fil \@dblfpbot 0pt plus 1fil+\marginparpush 6pt ++\parskip 0pt plus .1pt \parindent 10pt \partopsep 0pt +\@lowpenalty 51 \@medpenalty 151 \@highpenalty 301 +\@beginparpenalty -\@lowpenalty \@endparpenalty -\@lowpenalty \@itempenalty+-\@lowpenalty +++\def\part{\@ucheadtrue+ \@startsection{part}{9}{\z@}{-10pt plus -4pt minus + -2pt}{4pt}{\reset@font\normalsize\sffamily}}+\def\section{\@ucheadtrue+ \@startsection{section}{1}{\z@}{-10pt plus -4pt minus + -2pt}{4pt}{\reset@font\normalsize\sffamily}}+\def\subsection{\@ucheadfalse+ \@startsection{subsection}{2}{\z@}{-8pt plus -2pt minus + -1pt}{4pt}{\reset@font\normalsize\sffamily}}+\def\subsubsection{\@ucheadfalse+ \@startsection{subsubsection}{3}{\parindent}{6pt plus +1pt}{-5pt}{\reset@font\normalsize\itshape}}+\def\paragraph{\@ucheadfalse+ \@startsection{paragraph}{3}{\parindent}{6pt plus +1pt}{-5pt}{\reset@font\normalsize\itshape}}++\renewcommand{\@seccntformat}[1]{\textup{\csname the#1\endcsname}}++\gdef\@period{.}+\def\@trivlist{\@topsepadd\topsep+\if@noskipsec \gdef\@period{}\leavevmode\gdef\@period{.}\fi+ \ifvmode \advance\@topsepadd\partopsep \else \unskip\par\fi+ \if@inlabel \@noparitemtrue \@noparlisttrue + \else \@noparlistfalse \@topsep\@topsepadd \fi+ \advance\@topsep \parskip+ \leftskip\z@\rightskip\@rightskip \parfillskip\@flushglue+ \@setpar{\if@newlist\else{\@@par}\fi} \global\@newlisttrue+\@outerparskip\parskip}+++\def\@startsection#1#2#3#4#5#6{%+  \if@noskipsec \leavevmode \fi+  \par+  \@tempskipa #4\relax+  \@afterindenttrue+  \ifdim \@tempskipa <\z@+    \@tempskipa -\@tempskipa \@afterindentfalse+  \fi+  \if@nobreak+    \everypar{}%+  \else+    \addpenalty\@secpenalty\addvspace\@tempskipa+  \fi+  \@ifstar+    {\@ssect{#3}{#4}{#5}{#6}}%+    {\@dblarg{\@sect{#1}{#2}{#3}{#4}{#5}{#6}}}}+\def\@sect#1#2#3#4#5#6[#7]#8{%+  \ifnum #2>\c@secnumdepth+    \let\@svsec\@empty+  \else+    \refstepcounter{#1}%+      \if@uchead%+            \protected@edef\@svsec{\@seccntformat{#1}.\quad\relax}%+        \else%+            \protected@edef\@svsec{\@seccntformat{#1}\quad\relax}%+        \fi%+  \fi+  \@tempskipa #5\relax+  \ifdim \@tempskipa>\z@+    \begingroup+      #6{%+        \@hangfrom{\hskip #3\relax\@svsec}%+          \interlinepenalty \@M \if@uchead\MakeUppercase{#8}\else#8\fi \@@par}%+    \endgroup+    \csname #1mark\endcsname{#7}%+    \addcontentsline{toc}{#1}{%+      \ifnum #2>\c@secnumdepth \else+        \protect\numberline{\csname the#1\endcsname}%+      \fi+      #7}%+  \else+    \def\@svsechd{%+      #6{\hskip #3\relax+      \@svsec \if@uchead\Makeuppercase{#8}\else#8\fi}%+      \csname #1mark\endcsname{#7}%+      \addcontentsline{toc}{#1}{%+        \ifnum #2>\c@secnumdepth \else+          \protect\numberline{\csname the#1\endcsname}%+        \fi+        #7}}%+  \fi+  \@xsect{#5}}++\def\@xsect#1{\@tempskipa #1\relax+ \ifdim \@tempskipa>\z@+ \par \nobreak+ \vskip \@tempskipa+ \@afterheading+ \else \global\@nobreakfalse \global\@noskipsectrue+ \everypar{\if@noskipsec \global\@noskipsecfalse+ \clubpenalty\@M \hskip -\parindent+ \begingroup \@svsechd\@period \endgroup \unskip+ \hskip -#1+ \else \clubpenalty \@clubpenalty+ \everypar{}\fi}\fi\ignorespaces}+\newif\if@uchead\@ucheadfalse+++\setcounter{secnumdepth}{3}+\newcounter{secnumbookdepth}+\setcounter{secnumbookdepth}{3}++\newfont{\apbf}{cmbx9}++\def\@withappendix#1{App--\number #1}++\newcommand{\elecappendix}{+}++\def\appenheader{\global\@topnum\z@ \global\@botroom \textheight \begin{figure}+\newfont{\sc}{cmcsc10}+\parindent\z@+\hbox{}+\vskip -\textfloatsep+\vskip 11pt+\hrule height .2pt width 30pc+\vskip 2pt\rule{0pt}{10pt}\ignorespaces}+\def\endappenheader{\end{figure}\gdef\appendixhead{}}++\def\@appsec{}++\def\appendix{\par+ \setcounter{section}{0}+ \setcounter{subsection}{0}+ \def\@appsec{APPENDIX } +        \def\thesection{\Alph{section}}+        \def\theHsection{\Alph{section}}}++++\labelsep 5pt+\settowidth{\leftmargini}{(9)} \addtolength\leftmargini\labelsep+\settowidth{\leftmarginii}{(b)} \addtolength\leftmarginii\labelsep+\leftmarginiii \leftmarginii+\leftmarginiv \leftmarginii +\leftmarginv \leftmarginii +\leftmarginvi \leftmarginii +\leftmargin\leftmargini+\labelwidth\leftmargini\advance\labelwidth-\labelsep+\def\@listI{\leftmargin\leftmargini \parsep 0pt plus 1pt\topsep 6pt plus 2pt+minus 2pt\itemsep 2pt plus 1pt minus .5pt}+\let\@listi\@listI+\@listi +\def\@listii{\leftmargin\leftmarginii+ \labelwidth\leftmarginii\advance\labelwidth-\labelsep+ \topsep 0pt plus 1pt + \parsep 0pt plus .5pt + \itemsep \parsep}+\def\@listiii{\leftmargin\leftmarginiii+ \labelwidth\leftmarginiii\advance\labelwidth-\labelsep+ \topsep 0pt plus 1pt + \parsep 0pt plus .5pt + \itemsep \parsep}+\def\@listiv{\leftmargin\leftmarginiv+ \labelwidth\leftmarginiv\advance\labelwidth-\labelsep}+\def\@listv{\leftmargin\leftmarginv+ \labelwidth\leftmarginv\advance\labelwidth-\labelsep}+\def\@listvi{\leftmargin\leftmarginvi+ \labelwidth\leftmarginvi\advance\labelwidth-\labelsep}+++++\def\enumerate{\ifnum \@enumdepth >3 \@toodeep\else+ \advance\@enumdepth \@ne + \edef\@enumctr{enum\romannumeral\the\@enumdepth}\list+ {\csname label\@enumctr\endcsname}{\usecounter+ {\@enumctr}\def\makelabel##1{##1\hss}}\fi}+\def\longenum{\ifnum \@enumdepth >3 \@toodeep\else+ \advance\@enumdepth \@ne + \edef\@enumctr{enum\romannumeral\the\@enumdepth}\list+ {\csname label\@enumctr\endcsname}{\usecounter+ {\@enumctr}\labelwidth\z@}\fi}+%\leftmargin\z@ \itemindent\parindent}\fi} - this indents each item in enumerate+\let\endlongenum\endlist+%%--------------------CHANGED: always roman parentheses. dave ---------------%%+\def\labelenumi{{\rm (}\arabic{enumi}\/{\rm )}} +\def\theenumi{\arabic{enumi}} +\def\labelenumii{{\rm (}\alph{enumii}\rm{)}}+\def\theenumii{\alph{enumii}}+\def\p@enumii{\theenumi}+\def\labelenumiii{\roman{enumiii}.}+\def\theenumiii{\roman{enumiii}}+\def\p@enumiii{\theenumi{\rm (}\theenumii{\rm )}}+\def\labelenumiv{\Alph{enumiv}.}+\def\theenumiv{\Alph{enumiv}} +\def\p@enumiv{\p@enumiii\theenumiii}++\def\p@enumiv{\p@enumiii\theenumiii}++\def\itemize{\list{---\hskip -\labelsep}{\settowidth+ {\leftmargin}{---}\labelwidth\leftmargin+ \addtolength{\labelwidth}{-\labelsep}}}+\let\enditemize\endlist+\def\longitem{\list{---}{\labelwidth\z@+ \leftmargin\z@ \itemindent\parindent \advance\itemindent\labelsep}}+\let\endlongitem\endlist+\def\verse{\let\\=\@centercr + \list{}{\leftmargin 2pc + \itemindent -1.5em\listparindent \itemindent + \rightmargin\leftmargin\advance\leftmargin 1.5em}\item[]}+\let\endverse\endlist+\def\quotation{\list{}{\leftmargin 2pc \listparindent .5em+ \itemindent\listparindent+ \rightmargin\leftmargin \parsep 0pt plus 1pt}\item[]}+\let\endquotation=\endlist+\def\quote{\list{}{\leftmargin 2pc \rightmargin\leftmargin}\item[]}+\let\endquote=\endlist++\def\description{\list{}{\listparindent\parindent\labelwidth\z@+ \leftmargin\z@ \itemindent\parindent\advance\itemindent\labelsep+ \def\makelabel##1{\it ##1.}}}+\let\enddescription\endlist++\def\describe#1{\list{}{\listparindent\parindent\settowidth{\labelwidth}{#1}\leftmargin+ \labelwidth\addtolength\leftmargin\labelsep\def\makelabel##1{##1\hfil}}}+\let\enddescribe\endlist++        \def\program{\ifx\@currsize\normalsize\small \else \rm \fi\tabbing}+        \let\endprogram\endtabbing+         \def\@begintheorem#1#2{\trivlist \item[\hskip 10pt\hskip +         \labelsep{\sc{#1}\hskip 5pt\relax #2.}] \itshape}+        % aiellom{: this is what makes the theorem environment with names +        % ABOVE #1 is the word example, corollary, etc.+        %            #2 is the number+        % \def\@opargbegintheorem#1#2#3{\trivlist+        % \item[\hskip 10pt \hskip \labelsep{\sc #1\savebox\@tempboxa{#3}\ifdim +        % \wd\@tempboxa>\z@ \hskip 5pt\relax \box\@tempboxa\fi.}] \itshape}+        %  is been changed to+        % #1 is the word theorem, lemma, etc.+        % #2 is the number+        % #3 is the name of the theorem, lemma, etc.+        \def\@opargbegintheorem#1#2#3{\trivlist+        \item[\hskip 10pt \hskip +\labelsep{\sc{#1}\savebox\@tempboxa{\sc{#3}}\ifdim +        \wd\@tempboxa>\z@ \hskip 5pt\relax \sc{#2}  \box\@tempboxa\fi.}]+\itshape}+        % aiellom} ++++\newif\if@qeded\global\@qededfalse+\def\proof{\global\@qededfalse\@ifnextchar[{\@xproof}{\@proof}}+\def\endproof{\if@qeded\else\qed\fi\endtrivlist}+\def\qed{\unskip\kern 10pt{\unitlength1pt\linethickness{.4pt}\framebox(6,6){}}+\global\@qededtrue}+\def\@proof{\trivlist \item[\hskip 10pt\hskip + \labelsep{\sc Proof.}]\ignorespaces}+\def\@xproof[#1]{\trivlist \item[\hskip 10pt\hskip + \labelsep{\sc Proof #1.}]\ignorespaces}++\def\newdef#1#2{\expandafter\@ifdefinable\csname #1\endcsname+{\@definecounter{#1}\expandafter\xdef\csname+the#1\endcsname{\@thmcounter{#1}}\global+ \@namedef{#1}{\@defthm{#1}{#2}}\global+ \@namedef{end#1}{\@endtheorem}}}+\def\@defthm#1#2{\refstepcounter+ {#1}\@ifnextchar[{\@ydefthm{#1}{#2}}{\@xdefthm{#1}{#2}}}+\def\@xdefthm#1#2{\@begindef{#2}{\csname the#1\endcsname}\ignorespaces}+\def\@ydefthm#1#2[#3]{\trivlist \item[\hskip 10pt\hskip + \labelsep{\it #2\savebox\@tempboxa{#3}\ifdim + \wd\@tempboxa>\z@ \ \box\@tempboxa\fi.}]\ignorespaces}+\def\@begindef#1#2{\trivlist \item[\hskip 10pt\hskip + \labelsep{\it #1\ \rm #2.}]}++\def\theequation{\arabic{equation}}++\def\titlepage{\@restonecolfalse\if@twocolumn\@restonecoltrue\onecolumn+ \else \newpage \fi \thispagestyle{empty}\c@page\z@}+\def\endtitlepage{\if@restonecol\twocolumn \else \newpage \fi}++\arraycolsep 2.5pt \tabcolsep 6pt \arrayrulewidth .4pt \doublerulesep 2pt +\tabbingsep \labelsep ++\skip\@mpfootins = \skip\footins+\fboxsep = 3pt \fboxrule = .4pt ++\newcounter{part}+\newcounter{section}+\newcounter{subsection}[section]+\newcounter{subsubsection}[subsection]+\newcounter{paragraph}[subsubsection]++\def\thepart{\Roman{part}} +\def\thesection {\arabic{section}}+\def\thesubsection {\thesection.\arabic{subsection}}+\def\thesubsubsection {\thesubsection.\arabic{subsubsection}}+\def\theparagraph {\thesubsubsection.\arabic{paragraph}}++\def\@pnumwidth{1.55em}+\def\@tocrmarg {2.55em}+\def\@dotsep{4.5}+\setcounter{tocdepth}{3}++\def\tableofcontents{\section*{Contents\@mkboth{CONTENTS}{CONTENTS}}+ \@starttoc{toc}}+\def\l@part#1#2{\addpenalty{\@secpenalty}+ \addvspace{2.25em plus 1pt} \begingroup+ \@tempdima 3em \parindent \z@ \rightskip \@pnumwidth \parfillskip+-\@pnumwidth + {\large \bf \leavevmode #1\hfil \hbox to\@pnumwidth{\hss #2}}\par+ \nobreak \endgroup}+\def\l@section#1#2{\addpenalty{\@secpenalty} \addvspace{1.0em plus 1pt}+\@tempdima 1.5em \begingroup+ \parindent \z@ \rightskip \@pnumwidth + \parfillskip -\@pnumwidth + \bf \leavevmode #1\hfil \hbox to\@pnumwidth{\hss #2}\par+ \endgroup}+\def\l@subsection{\@dottedtocline{2}{1.5em}{2.3em}}+\def\l@subsubsection{\@dottedtocline{3}{3.8em}{3.2em}}+\def\listoffigures{\section*{List of Figures\@mkboth+ {LIST OF FIGURES}{LIST OF FIGURES}}\@starttoc{lof}}+\def\l@figure{\@dottedtocline{1}{1.5em}{2.3em}}+\def\listoftables{\section*{List of Tables\@mkboth+ {LIST OF TABLES}{LIST OF TABLES}}\@starttoc{lot}}+\let\l@table\l@figure+++\def\thebibliography#1{\par\footnotesize +\@ucheadfalse+\@startsection{subsection}{2}{\z@}{16pt plus 2pt minus +        1pt}{2pt}{\sf}*{REFERENCES}%+\list{\arabic{enumi}.}{%+ \settowidth{\labelwidth}{99.}%+ \leftmargin\labelwidth+ \advance\leftmargin\labelsep \topsep \z@ \parsep 0pt plus .1pt+ \itemsep \parsep + \usecounter{enumi}}%+ \def\newblock{\hskip .11em plus .33em minus .07em}+ \sloppy+ \widowpenalty=4500+ \clubpenalty=4500+ \sfcode`\.=1000\relax}+\let\endthebibliography=\endlist+ ++\newif\if@restonecol+\def\theindex{\@restonecoltrue\if@twocolumn\@restonecolfalse\fi+\columnseprule \z@+\columnsep 35pt\twocolumn[\section*{Index}]+ \@mkboth{INDEX}{INDEX}\thispagestyle{plain}\parindent\z@+ \parskip\z@ plus .3pt\relax\let\item\@idxitem}+\def\@idxitem{\par\hangindent 40pt}+\def\subitem{\par\hangindent 40pt \hspace*{20pt}}+\def\subsubitem{\par\hangindent 40pt \hspace*{30pt}}+\def\endtheindex{\if@restonecol\onecolumn\else\clearpage\fi}+\def\indexspace{\par \vskip 10pt plus 5pt minus 3pt\relax}++\def\footnoterule{\kern-3\p@+ \hrule \@height 0.2\p@ \@width 47\p@ +  \kern 2.6\p@+} ++\long\def\@makefntext#1{\parindent 1em\noindent + $^{\@thefnmark}$#1}+++\setcounter{topnumber}{3}+\def\topfraction{.99}+\setcounter{bottomnumber}{1}+\def\bottomfraction{.5}+\setcounter{totalnumber}{3}+\def\textfraction{.01}+\def\floatpagefraction{.85}+\setcounter{dbltopnumber}{2}+\def\dbltopfraction{.7}+\def\dblfloatpagefraction{.5}++\long\def\@makecaption#1#2{\vskip 1pc \setbox\@tempboxa\hbox{#1.\hskip+1em\relax #2}+ \ifdim \wd\@tempboxa >\hsize #1. #2\par \else \hbox+to\hsize{\hfil\box\@tempboxa\hfil} + \fi}++\def\nocaption{\refstepcounter\@captype \par+ \vskip 1pc \hbox to\hsize{\hfil \footnotesize Figure \thefigure+ \hfil}}+++\newcounter{figure}+\def\thefigure{\@arabic\c@figure}+\def\fps@figure{tbp}+\def\ftype@figure{1}+\def\ext@figure{lof}+\def\fnum@figure{Fig.\ \thefigure}+\def\figure{\let\normalsize\footnotesize \normalsize \@float{figure}}+\let\endfigure\end@float+\@namedef{figure*}{\@dblfloat{figure}}+\@namedef{endfigure*}{\end@dblfloat}++\newcounter{table}+\def\thetable{\@Roman\c@table}+\def\fps@table{tbp}+\def\ftype@table{2}+\def\ext@table{lot}+\def\fnum@table{Table \thetable}+\def\table{\let\normalsize\footnotesize \normalsize\@float{table}}+\let\endtable\end@float+\@namedef{table*}{\@dblfloat{table}}+\@namedef{endtable*}{\end@dblfloat}+\def\acmtable#1{\@narrowfig #1\relax+ \let\caption\@atcap \let\nocaption\@atnocap+ \def\@tmpnf{}\@ifnextchar[{\@xntab}{\@ntab}}+\def\endacmtable{\hbox to \textwidth{\hfil+\vbox{\hsize \@narrowfig+\box\@nfcapbox+{\baselineskip 4pt \hbox{\vrule height .4pt width \hsize}}+\vskip -1pt+\box\@nfigbox\vskip -1pt+{\baselineskip 4pt \hbox{\vrule height .4pt width \hsize}}}\hfil}+\end@float}+\def\@xntab[#1]{\def\@tmpnf{[#1]}\@ntab}+\def\@ntab{\expandafter\table\@tmpnf+ \setbox\@nfigbox\vbox\bgroup+ \hsize \@narrowfig \@parboxrestore}+\def\@atmakecap #1#2{\setbox\@tempboxa\hbox{#1.\hskip 1em\relax #2}+ \ifdim \wd\@tempboxa >\hsize \sloppy #1.\hskip 1em\relax #2 \par \else \hbox+to\hsize{\hfil\box\@tempboxa\hfil}+ \fi}+\def\@atcap{\par\egroup\refstepcounter\@captype + \@dblarg{\@atcapx\@captype}}+\long\def\@atcapx#1[#2]#3{\setbox\@nfcapbox\vbox {\hsize \wd\@nfigbox+ \@parboxrestore+ \@atmakecap{\csname fnum@#1\endcsname}{\ignorespaces #3}\par}}+\def\@atnocap{\egroup \refstepcounter\@captype + \setbox\@nfcapbox\vbox {\hsize \wd\@nfigbox+ \hbox to\hsize{\hfil \footnotesize Table \thetable\hfil}}}++%+%% Narrow figures+%+\def\narrowfig#1{\@narrowfig #1\relax+ \let\caption\@nfcap \let\nocaption\@nfnocap+ \def\@tmpnf{}\@ifnextchar[{\@xnfig}{\@nfig}}+\def\endnarrowfig{\hbox to \textwidth{\if@nfeven+ \box\@nfcapbox\hfil\box\@nfigbox+ \else \box\@nfigbox\hfil\box\@nfcapbox\fi}\end@float}+\def\@xnfig[#1]{\def\@tmpnf{[#1]}\@nfig}+\def\@nfig{\expandafter\figure\@tmpnf+ \setbox\@nfigbox\vbox\bgroup+ \hsize \@narrowfig \@parboxrestore}+\def\@nfmakecap #1#2{\setbox\@tempboxa\hbox{#1.\hskip 1em\relax #2}+ \ifdim \wd\@tempboxa >\hsize \sloppy #1.\hskip 1em\relax #2 \par \else \hbox+to\hsize{\if@nfeven\else\hfil\fi\box\@tempboxa\if@nfeven\hfil\fi}+ \fi}+\def\@nfcap{\par\egroup\refstepcounter\@captype + \@dblarg{\@nfcapx\@captype}}+\long\def\@nfcapx#1[#2]#3{\@seteven+ \setbox\@nfcapbox\vbox to \ht\@nfigbox+ {\hsize \textwidth \advance\hsize -2pc \advance\hsize -\wd\@nfigbox+ \@parboxrestore+ \vfil + \@nfmakecap{\csname fnum@#1\endcsname}{\ignorespaces #3}\par+ \vfil}}+\def\@nfnocap{\egroup \refstepcounter\@captype \@seteven+ \setbox\@nfcapbox\vbox to \ht\@nfigbox+ {\hsize \textwidth \advance\hsize -2pc \advance\hsize -\wd\@nfigbox+ \@parboxrestore+ \vfil + \hbox to\hsize{\if@nfeven\else\hfil\fi + \footnotesize Figure \thefigure+ \if@nfeven\hfil\fi}+ \vfil}}+\def\@seteven{\@nfeventrue +   \@ifundefined{r@@nf\thefigure}{}{%+      \edef\@tmpnf{\csname r@@nf\thefigure\endcsname}%+      \edef\@tmpnf{\expandafter\@getpagenum\@tmpnf}%+      \ifodd\@tmpnf\relax\@nfevenfalse\fi}%+\label{@nf\thefigure}\edef\@tmpnfx{\if@nfeven e\else o\fi}+\edef\@tmpnf{\write\@unused {\noexpand\ifodd \noexpand\c@page + \noexpand\if \@tmpnfx e\noexpand\@nfmsg{\thefigure} \noexpand\fi+ \noexpand\else + \noexpand\if \@tmpnfx o\noexpand\@nfmsg{\thefigure}\noexpand\fi + \noexpand\fi }}\@tmpnf}+\def\@nfmsg#1{Bad narrowfig: Figure #1 on page \thepage}++\newdimen\@narrowfig+\newbox\@nfigbox+\newbox\@nfcapbox+\newif\if@nfeven ++\def\and{\\ and\\}+\def\maketitle{\newpage \thispagestyle{titlepage}\par+ \begingroup \lineskip = \z@\null \vskip -30pt\relax + \parindent\z@ \LARGE {\raggedright \hyphenpenalty\@M+ %\sf \@title \par+  \@title \par+ \global\firstfoot %aiellom+ \global\runningfoot %aiellom+}+\label{@firstpg}+{ \vskip 13.5pt\relax \normalsize \sf %vskip 13.5pt between title and author+ \begingroup \addtolength{\baselineskip}{2pt}+ \@author\par \vskip -2pt + \endgroup }+ {\ifx \@categories\@empty + \else + \baselineskip 17pt\relax+ \if@acmjacm\else\hbox{\vrule height .2pt width 30pc}\fi%to eliminate the lines for jacm+ }+ \vskip 8.5pt \footnotesize \box\@abstract \vskip 4pt\relax %vskip8.5 space above abstract+ {\def\and{\unskip\/{\rm ; }}+ Categories and Subject Descriptors: \@categories \fi}\par\vskip 4pt\relax+ \box\@terms \vskip 4pt\relax+ \box\@keywords \par + {\baselineskip 14pt\relax + \@abstractbottom+ }+ \vskip 23pt\relax+ \endgroup+\let\maketitle\relax+ % \gdef\@author{}\gdef\@title{}+ \gdef\@categories{}}+++\newbox\@abstract+\newbox\@terms+\newbox\@keywords+\def\abstract{\global\setbox\@abstract=\vbox\bgroup \everypar{}+ \footnotesize \hsize 30pc \parindent 10pt \noindent + \rule{0pt}{10pt}\ignorespaces}+\def\endabstract{\egroup}++\def\terms#1{\setbox\@terms=\vbox{\everypar{}+ \footnotesize \hsize 30pc \parindent 0pt \noindent + General Terms: \ignorespaces #1}}+\def\keywords#1{\setbox\@keywords=\vbox{\everypar{}+ \footnotesize \hsize 30pc \parindent 0pt \noindent + Additional Key Words and Phrases: \ignorespaces #1}+}++\def\category#1#2#3{\@ifnextchar+ [{\@category{#1}{#2}{#3}}{\@xcategory{#1}{#2}{#3}}}+\def\@category#1#2#3[#4]{\edef\@tempa{\ifx \@categories\@empty + \else ; \fi}{\def\protect{\noexpand\protect+ \noexpand}\def\and{\noexpand\and}\xdef\@categories{\@categories\@tempa #1+[{\bf #2}]: + #3\kern\z@---\hskip\z@{\it #4}}}}+\def\@xcategory#1#2#3{\edef\@tempa{\ifx \@categories\@empty \else ;+\fi}{\def\protect{\noexpand\protect\noexpand}\def\and{\noexpand+ \and}\xdef\@categories{\@categories\@tempa #1 [{\bf #2}]: #3}}}+\def\@categories{}+\def\bottomstuff{\global\@topnum\z@ \global\@botroom \textheight \begin{figure}+\parindent\z@+\hbox{}+\vskip -\textfloatsep+\vskip 10pt+\hrule height .2pt width 30pc+\vskip 2pt\rule{0pt}{10pt}\ignorespaces}+\def\endbottomstuff{\permission\end{figure}\gdef\permission{}}++\newenvironment{ackslike}[1]+  {\par \footnotesize +   \@ucheadfalse+   \@startsection{subsection}{2}{\z@}{-16pt plus -2pt minus -1pt}{2pt}{\sf}*+   {\uppercase{#1}}\par\normalsize+   \pdfbookmark{Acknowledgments}{Ack}+        }+  {\par}+\newenvironment{acks}{\begin{ackslike}{ACKNOWLEDGMENTS}}{\end{ackslike}}++\def\received{\par\footnotesize\addvspace{18pt plus 0pt minus+4pt}\parindent\z@}+%the line below replaced by the line that follows (K.R. Apt, July 11, 2000+%\def\endreceived{\label{@lastpg}\hskip-2pt\par}+\def\endreceived{\label{@lastpg}\hskip-2pt\par\normalsize}++\mark{{}{}} ++\def\ps@myheadings{\let\@mkboth\@gobbletwo+\def\@oddhead{\hbox{}\hfill \small\sf \rightmark\hskip+19pt{\Large$\cdot$}\hskip 17pt\mypage}+\def\@oddfoot{\hbox{}\hfill\tiny\@runningfoot}+\def\@evenhead{\small\sf\mypage \hskip 17pt{\Large$\cdot$}\hskip 19pt\leftmark\hfill \hbox{}}+\def\@evenfoot{\tiny\@runningfoot\hfill\hbox{}}+\def\sectionmark##1{}\def\subsectionmark##1{}}+\def\@runningfoot{}+\def\runningfoot{\def\@runningfoot{\@journalName, Vol.\ \@acmVolume, No.\ \@acmNumber, \@acmMonth\ 20\@acmYear.}}+\def\@firstfoot{}+\def\firstfoot{\def\@firstfoot{\@journalName, Vol.\ \@acmVolume, No.\ \@acmNumber, \@acmMonth\ 20\@acmYear, Pages \pages.}}+\def\ps@titlepage{\let\@mkboth\@gobbletwo+\def\@oddhead{}\def\@oddfoot{\hbox{}\hfill+\tiny\@firstfoot}\def\@evenhead{}\def\@evenfoot{\tiny\@firstfoot\hfill\hbox{}}}++\def\today{\ifcase\month\or+ January\or February\or March\or April\or May\or June\or+ July\or August\or September\or October\or November\or December\fi+ \space\number\day, \number\year}+\def\@marrayclassiv{\@addtopreamble{$\displaystyle \@nextchar$}}+\def\@marrayclassz{\ifcase \@lastchclass \@acolampacol \or \@ampacol \or+ \or \or \@addamp \or+ \@acolampacol \or \@firstampfalse \@acol \fi+\edef\@preamble{\@preamble+ \ifcase \@chnum + \hfil$\relax\displaystyle\@sharp$\hfil \or $\relax\displaystyle\@sharp$\hfil + \or \hfil$\relax\displaystyle\@sharp$\fi}}+\def\marray{\arraycolsep 2.5pt\let\@acol\@arrayacol \let\@classz\@marrayclassz+ \let\@classiv\@marrayclassiv \let\\\@arraycr\def\@halignto{}\@tabarray}+\def\endmarray{\crcr\egroup\egroup}+++\ps@myheadings \pagenumbering{arabic} \onecolumn ++%-----------------------BIBLIOGRAPHY STUFF-------------------------+% this is adapted (November 1993) by Andrew Appel and Rebecca Davies from+% +%%%     filename        = "chicago.sty",+%%%     version         = "4",  % MODIFIED!+%%%     date            = "31 August 1992",+%%%     time            = "09:42:44 199",+%%%     author          = "Glenn Paulley",+%%%     address         = "Data Structuring Group+%%%                        Department of Computer Science+%%%                        University of Waterloo+%%%                        Waterloo, Ontario, Canada+%%%                        N2L 3G1",+%%%     telephone       = "(519) 885-1211",+%%%     FAX             = "(519) 885-1208",+%%%     email           = "gnpaulle@bluebox.uwaterloo.ca",++%%% ====================================================================+%+% this file: Modification of chicago.sty for new ACM bibliography+% style, which is similar (but not identical) to the ``Chicago'' style.+%+% chicago.sty: Style file for use with bibtex style chicago.bst, for+% bibliographies formatted according to the 13th Edition of the Chicago+% Manual of Style.+%+% 'newapa.bst' was made from 'plain.bst', 'named.bst', and 'apalike.bst',+% with lots of tweaking to make it look like APA style, along with tips+% from Young Ryu and Brian Reiser's modifications of 'apalike.bst'.+% newapa.sty formed the basis of this style, chicago.sty. Author-date+% references in newapa.bst formed the basis for chicago.bst. Chicagoa.bst+% supports annotations.+%+% Version 4 (August, 1992):+% - fixed chicago.bst and chicagoa.bst to handle long author lists in+%   sorting+% - fixed chicago.bst and chicagoa.bst so that missing page numbers in+%   ``article'' entries are handled correctly+% - modified chicago.sty to format entries with 2nd and subsequent lines+%   indented.+%+%   Citation format: (author-last-name year)+%             (author-last-name and author-last-name year)+%             (author-last-name et al. year)+%             (author-last-name)+%             author-last-name+%             author-last-name (year)+%             (author-last-name and author-last-name)+%             (author-last-name et al.)+%             (year) or (year,year)+%             year or year,year+%+%   Reference list ordering: alphabetical by author or whatever passes+%    for author in the absence of one.+%+% This BibTeX style has support for abbreviated author lists and for+%    year-only citations.  This is done by having the citations+%    actually look like+%+%    \citeauthoryear{full-author-info}{abbrev-author-info}{year}+%+% The LaTeX style has to have the following (or similar)+%+%     \let\@internalcite\cite+%     \def\fullcite{\def\citeauthoryear##1##2##3{##1, ##3}\@internalcite}+%     \def\fullciteA{\def\citeauthoryear##1##2##3{##1}\@internalcite}+%     \def\shortcite{\def\citeauthoryear##1##2##3{##2, ##3}\@internalcite}+%     \def\shortciteA{\def\citeauthoryear##1##2##3{##2}\@internalcite}+%     \def\citeyear{\def\citeauthoryear##1##2##3{##3}\@internalcite}+%+%+% -------------------------------------------------------------------------+%+% Citation macros.+%+\let\@internalcite\cite++\def\cite{\def\@citeseppen{-1000}%+    \def\@cite##1##2{[##1\if@tempswa , ##2\fi]}%+    \def\citeauthoryear##1##2##3{##2 ##3}\@internalcite}+\def\citeXNP#1#2{%+  \def\@cite@label{#2}%+  \def\@cite##1##2{##1\if@tempswa , ##2\fi}%+  \def\citeauthoryear##1##2##3{\@cite@label}\@internalcite{#1}}+% \def\@citeseppen{-1000}%+%    \def\@cite@label{#1}+%    \def\@cite##1##2{\if@tempswa ##2\fi}%+%    \def\citeauthoryear##1##2##3{##2 ##3}\@internalcite}+\def\citeNP{\def\@citeseppen{-1000}%+    \def\@cite##1##2{##1\if@tempswa , ##2\fi}%+    \def\citeauthoryear##1##2##3{##2 ##3}\@internalcite}+\def\citeN{\def\@citeseppen{-1000}%+    \def\@cite##1##2{##1\if@tempswa , ##2]\else{]}\fi}%+    \def\citeauthoryear##1##2##3{##2 [##3}\@citedata}+\def\shortcite#1{\citeyear{#1}}+\def\citeS#1{[\citeANP{#1} \citeyearNP{#1}]}+\def\citeNS#1{\citeANP{#1} \citeyear{#1}}+\def\citeNPS#1{\citeANP{#1} \citeyearNP{#1}}+%testing year,year+\def\citeNN{\def\@citeseppen{-1000}%+    \def\@cite##1##2{[##1\if@tempswa , ##2\fi]}%+    \def\citeauthoryear##1##2##3{##3}\@citedata}++\def\citeA{\def\@citeseppen{-1000}%+    \def\@cite##1##2{[##1\if@tempswa , ##2\fi]}%+    \def\citeauthoryear##1##2##3{##2}\@internalcite}+\def\citeANP{\def\@citeseppen{-1000}%+    \def\@cite##1##2{##1\if@tempswa , ##2\fi}%+    \def\citeauthoryear##1##2##3{##2}\@internalcite}++\def\citeyear{\def\@citeseppen{-1000}%+    \def\@cite##1##2{[##1\if@tempswa , ##2\fi]}%+    \def\citeauthoryear##1##2##3{##3}\@citedata}+\def\citeyearNP{\def\@citeseppen{-1000}%+    \def\@cite##1##2{##1\if@tempswa , ##2\fi}%+    \def\citeauthoryear##1##2##3{##3}\@citedata}++%+% \@citedata and \@citedatax:+%+% Place commas in-between citations in the same \citeyear, \citeyearNP,+% or \citeN command.+% Use something like \citeN{ref1,ref2,ref3} and \citeN{ref4} for a list.+%+\def\@citedata{%+        \@ifnextchar [{\@tempswatrue\@citedatax}%+                                  {\@tempswafalse\@citedatax[]}%+}++\def\@citedatax[#1]#2{%+\if@filesw\immediate\write\@auxout{\string\citation{#2}}\fi%+  \def\@citea{}\@cite{\@for\@citeb:=#2\do%+    {\@citea\def\@citea{; }\@ifundefined% by Young+       {b@\@citeb}{{\bf ?}%+       \@warning{Citation `\@citeb' on page \thepage \space undefined}}%+{\csname b@\@citeb\endcsname}}}{#1}}%++% don't box citations, separate with ; and a space+% also, make the penalty between citations negative: a good place to break.+%+\def\@citex[#1]#2{%+\if@filesw\immediate\write\@auxout{\string\citation{#2}}\fi%+  \def\@citea{}\@cite{\@for\@citeb:=#2\do%+    {\@citea\def\@citea{; }\@ifundefined% by Young+       {b@\@citeb}{{\bf ?}%+       \@warning{Citation `\@citeb' on page \thepage \space undefined}}%+{\csname b@\@citeb\endcsname}}}{#1}}%++% (from apalike.sty)+% No labels in the bibliography.+%+\def\@biblabel#1{}++% (from apalike.sty)+% Set length of hanging indentation for bibliography entries.+%+\newlength{\bibhang}+\setlength{\bibhang}{2em}++% Indent second and subsequent lines of bibliographic entries. Stolen+% from openbib.sty: \newblock is set to {}.++\newdimen\bibindent+\bibindent=1em+\@ifundefined{refname}%+   {\@ifundefined{chapter}%+     {\newcommand{\refname}{\footnotesize REFERENCES}}%+     {\newcommand{\refname}{\footnotesize BIBLIOGRAPHY}}%+   }%+   {}%+\@ifundefined{chapter}%+ {\def\thebibliography#1{\footnotesize \section*{\refname\@mkboth +   {\uppercase{\refname}}{\uppercase{\refname}}}\list+   {[\arabic{enumi}]}{+   \settowidth\labelwidth{[#1]}+   \leftmargin\labelwidth+   \advance\leftmargin\labelsep+   \advance\leftmargin\bibindent+   \itemindent -\bibindent+   \listparindent \itemindent+   \parsep \z@+   \usecounter{enumi}}+   \def\newblock{}+   \sloppy+   \sfcode`\.=1000\relax}}+ {\def\thebibliography#1{\footnotesize \chapter*{\refname\@mkboth +   {\uppercase{\refname}}{\uppercase{\refname}}}\list+   {[\arabic{enumi}]}{\settowidth\labelwidth{[#1]}+   \leftmargin\labelwidth+   \advance\leftmargin\labelsep+   \advance\leftmargin\bibindent+   \itemindent -\bibindent+   \listparindent \itemindent+   \parsep \z@+   \usecounter{enumi}}+   \def\newblock{}+   \sloppy+   \sfcode`\.=1000\relax}}++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++% fixes to acm trans macro package+% 31-JAN-1996+% John Tang Boyland++% newdef need to take the optional parameters of newtheorem+\def\newdef#1{\@ifnextchar[{\@xnewdef{#1}}{\@ynewdef{#1}}}+\def\@xnewdef#1[#2]#3{\newtheorem{italic@#1}[#2]{{\em #3}}\@newdef{#1}}+\def\@ynewdef#1#2{\@ifnextchar[{\@xynewdef{#1}{#2}}{\@yynewdef{#1}{#2}}}+\def\@xynewdef#1#2[#3]{\newtheorem{italic@#1}{{\em #2}}[#3]\@newdef{#1}}+\def\@yynewdef#1#2{\newtheorem{italic@#1}{{\em #2}}\@newdef{#1}}+% and now fix up definition, to change body to use roman font:+\def\@newdef#1{\newenvironment{#1}{\@ifnextchar[{\@xstartdef{#1}}{\@ystartdef{#1}}}{\end{italic@#1}}}+%changed by K.R. Apt on Sep. 27, 2000. It was: \def\@xstartdef#1[#2]{\begin{italic@#1}[#2]\rm}+\def\@xstartdef#1[#2]{\begin{italic@#1}[{\em #2}]\rm}+\def\@ystartdef#1{\begin{italic@#1}\rm}++% footers produced too small (vpt), when ACM typsets them at 7.5pt (!).+% A better compromise is viipt.+\def\@oddfoot{\hbox{}\hfill\scriptsize\@runningfoot}+\def\@evenfoot{\scriptsize\@runningfoot\hfill\hbox{}}++% first footer was set to (vpt), when ACM typesets them at 6.5pt (!).+% A better compromise is vipt.+\def\firstfootsize{\@setsize\firstfootsize{7pt}\vipt\@vipt}+\def\ps@titlepage{\let\@mkboth\@gobbletwo+\def\@oddhead{}\def\@oddfoot{\hbox{}\hfill\firstfootsize\@firstfoot}%+\def\@evenhead{}\def\@evenfoot{\firstfootsize\@firstfoot\hfill\hbox{}}}++% new permission statement+\long\def\permission{\par+% linebreaks added to conform to the current style+Permission to make digital/hard copy of all or part of this material without+fee +for personal or classroom use+provided that the copies are not made or distributed for profit+or commercial advantage, the ACM copyright/server notice, the title of the+publication, and its date appear, and notice is given that copying is by+permission of the ACM, Inc.  To copy+otherwise, to republish, to post on servers, or to redistribute to lists+requires prior specific +permission and/or a fee.\par+\copyright\ 20\@acmYear\ +ACM \@permissionCodeOne/20\@acmYear/\@permissionCodeTwo-\@pageCode\$5.00 % aiellom+}++% make sure \permission doesn't get trashed+\def\endbottomstuff{\permission\end{figure}}++% alternate way of using citeyear+%  \def\shortcite#1{\citeyear{#1}+% enumerations and longenums are wrong+% 1. the second line in a paragraph of an enumerations in theorems+%  (or other trivlists) doesn't line up under the first+% 1. the second line of a longenum doesn't properly wrap around+%  back to the left margin.++% the original definition of \@listI doesn't set labelwidth+\def\@listI{\leftmargin\leftmargini+ \labelwidth\leftmargini\advance\labelwidth-\labelsep+ \parsep 0pt plus 1pt+ \topsep 6pt plus 2pt minus 2pt+ \itemsep 2pt plus 1pt minus .5pt}+\let\@listi\@listI+\@listi ++% add set of \labelwidth and \itemindent+\def\longenum{\ifnum \@enumdepth >3 \@toodeep\else+ \advance\@enumdepth \@ne + \edef\@enumctr{enum\romannumeral\the\@enumdepth}\list+ {\csname label\@enumctr\endcsname}{\usecounter+ {\@enumctr}\labelwidth\z@\leftmargin\z@+ \itemindent\parindent \advance\itemindent\labelsep}\fi}++% split electronic appendix into two parts:+++%aiellom{+\def\appendixhead#1{\appendix+\section*{ELECTRONIC APPENDIX}+The electronic appendix for this article can be accessed in+  the ACM Digital Library by visiting the following URL:$\;$ +  \url{http://www.acm.org/pubs/citations/journals/}{\tt \@journalNameShort /20\@acmYear-\@acmVolume-\@acmNumber/p\pageref{@firstpg}-#1}.+% \quad \href{http://www.acm.org/tocl}{{\small http://www.acm.org/tocl} }+}+%aiellom}++\long\def\elecappendix{+\clearpage+\makeatletter+\pagenumbering{withappendix}+\makeatother+\appendix+\par\noindent{\sc This document is the online-only appendix to:}\hfill \vskip 1em+{\vbox{\Large\sf \parindent0pt\@title{}}}\vskip .5em+\vbox{\sf \parindent0pt\@author{}}\vskip .5em\noindent+\vskip 10pt\noindent+{\firstfootsize +\@journalName, Vol.\ \@acmVolume, No.\ \@acmNumber, \@acmMonth\ 20\@acmYear, Pages \pages.}+\vskip 11pt\noindent+\hrule height .2pt+\par+\bottomstuff+\endbottomstuff+}++% provide for a single acknowledgment+\def\ack{ \par \footnotesize +\@ucheadfalse+\@startsection{subsection}{2}{\z@}{-16pt plus -2pt minus + -1pt}{2pt}{\sf}*{ACKNOWLEDGMENT}\par\normalsize+\pdfbookmark{Acknowledgment}{Ack}+}+\def\endack{\par}++% provide both spellings of Acknowledgment(s)+\let\acknowledgments\acks+\let\endacknowledgments\endacks+\let\acknowledgment\ack+\let\endacknowledgment\endack++\newcommand{\longpage}{\enlargethispage{\baselineskip}}+\newcommand{\shortpage}{\enlargethispage{-\baselineskip}}+++% Don't indent bibliography and+% override \refname (which sets fontsize):+\def\thebibliography#1{+  \footnotesize\section*{\footnotesize\sf{REFERENCES}\@mkboth+  {\uppercase{\refname}}{\uppercase{\refname}}}%+   \pdfbookmark{References}{Ref}+   \list+  {\@biblabel{\arabic{enumiv}}}{%+   %\settowidth\labelwidth{[#1]}+   \labelwidth 0pt+   \leftmargin \bibindent+   \labelsep 0pt+   \if@hyperref+     \itemindent -\bibindent+   \fi+   \listparindent -\bibindent+   \labelsep -\bibindent+    \usecounter{enumiv}%+    \let\p@enumiv\@empty+    \def\theenumiv{\arabic{enumiv}}}%+    \def\newblock{\hskip .11em plus.33em minus.07em}%+    \sloppy+    \clubpenalty=4500+    \widowpenalty=4500+    \frenchspacing}+\def\endthebibliography{%+  \def\@noitemerr{\@warning{Empty `thebibliography' environment}}%+  \endlist}+\def\@lbibitem[#1]#2{\item[]\if@filesw+      {\def\protect##1{\string ##1\space}\immediate+       \write\@auxout{\string\bibcite{#2}{#1}}}\fi\hskip-1em\ignorespaces}+% Fix cite so it doesn't repeat author lists in citations:++\def\cite{\def\@citeseppen{-1000}%+    \def\@cite##1##2{[##1\if@tempswa , ##2\fi]}%+    \let\@lastauthor=\@noauthor+    \let\citeauthoryear=\citeauthoryear@no@repeats\@internalcite}+    %\def\citeauthoryear##1##2##3{##2 ##3}\@internalcite++\def\@noauthor={\relax}+\let\@lastauthor=\@noauthor+\let\@currauthor=\@noauthor++\def\citeauthoryear@no@repeats#1#2#3{%+  \def\@currauthor{\csname @author #1\endcsname}%+  \ifx\@lastauthor\@currauthor{#3}\else{#2 #3}\fi%+  \let\@lastauthor=\@currauthor}++\DeclareOldFontCommand{\rm}{\normalfont\rmfamily}{\mathrm}+\DeclareOldFontCommand{\sf}{\normalfont\sffamily}{\mathsf}+\DeclareOldFontCommand{\tt}{\normalfont\ttfamily}{\mathtt}+\DeclareOldFontCommand{\bf}{\normalfont\bfseries}{\mathbf}+\DeclareOldFontCommand{\it}{\normalfont\itshape}{\mathit}+\DeclareOldFontCommand{\sl}{\normalfont\slshape}{\@nomath\sl}+\DeclareOldFontCommand{\sc}{\normalfont\scshape}{\@nomath\sc}+\DeclareRobustCommand*\cal{\@fontswitch\relax\mathcal}+\DeclareRobustCommand*\mit{\@fontswitch\relax\mathnormal}+++\if@hyperref+   \let\pdfbookmark=\relax+   \RequirePackage[pdfmark]{hyperref}+\fi++% \renewcommand{\thefootnote}{\arabic{footnote}\hspace{-3pt}}++
+ tools/base/Modules/doc/conclusion.tex view
@@ -0,0 +1,71 @@+\section{Conclusions and discussion}+\label{conclusions}++We have provided a formal specification of the Haskell 98 module system,+based on the Haskell 98 language report.+The process of writing the specification was valuable as we+identified a number of areas of the report, which were unclear, or +underspecified, and as a result the report has been improved.  In particular, +while the report mentions that mutually recursive modules are +allowed, there is no mention of how they should work.   +Our specification provides a clear semantics for+mutually recursive modules, and as far as we are aware, is the only+implementation of the Haskell module system that supports this feature.+It is possible to compile programs with mutually recursive modules +using GHC \cite[Section 4.9.7]{GHC-ref-man}, but the programmer+has to provide a special interface file, essentially implementing+this aspect of the module system manually. +++The Haskell module system aims at simplicity and has a clear goal---to manage+name uses in a program.  Its design has largely been driven by practical+concerns, which has both positive and negative consequences.  It works in +practice and most of the time it does not place large cognitive+overhead on the programmer.  Our specification is not too complicated,+and the few thorny parts of it point to possibilities for improvements+in the design of the module system.++One of the complications is caused by the+special rules used to distinguish between type and value constructors in +import/export lists. These seem somewhat ad-hoc and are a source of+unnecessary complexity.  Many of the +difficulties arise from the choice of meaning for capitalized names+in import/export lists: +\begin{itemize}+    \item in export lists and ``normal'' imports they refer to types or classes+    \item in ``hiding'' imports they refer to types, classes, or +        value-constructors +\end{itemize}+An alternative choice is to make them always refer to value-constructors.+The presence or absence of a subordinate list may be used to +distinguish types and classes, from value-constructors. Here is a table +summarizing the difference between the current and the alternative +interpretation:++\begin{tabular}{lcc}+what to name: &            current   &  alternative \\+just type or class:     & T or T()   &   T()       \\+just constructor:       & -          &   T +\end{tabular}++As we see, currently there are two different ways to name just a type+or a class, and no way at all to just name a value-constructor.+With our alternative interpretation,+the meaning of an entry does not vary depending on the context (i.e., +no need for special cases for ``hiding'' imports).  This seems like an+attractive idea, but unfortunately it changes the meaning of many Haskell+programs.  As such it is not feasible to introduce in Haskell 98, but+perhaps it can be considered in future revisions of the language.++Haskell turned out to be a very suitable language for writing +executable specifications.  We found its clear syntax to be particularly +valuable, providing a high-level of abstraction.  +The ability to type-check and execute the+specification not only improved our confidence in its correctness, but+also enabled us to compare it against the behaviors of a number of +implementations such as Hugs and GHC.++\section{Acknowledgments}+We would like to thank the participants on the Haskell mailing list,+and in particular Simon Peyton Jones, Simon Marlow, and Malcom Wallace,+for valuable clarifications and discussions.   
+ tools/base/Modules/doc/intro.tex view
@@ -0,0 +1,153 @@+\section{Introduction}+\label{intro}+Many programming languages claim some kind of {\em module system}+as part of their definition.  In each case, the module system is+intended to provide support for modular construction of software+systems, but the precise interpretation of the term can vary quite+significantly from+one language to the next.  In some languages, the module system+provides a powerful mechanism for creating, using, and reusing+{\em programming abstractions}.  Standard ML, for example,+has one of the most powerful module systems of this kind \cite{ML97}.+In other languages, the main purpose of the module system is+to support {\em separate compilation}, motivated by pragmatic+issues that arise during the development of large programs.+In yet other languages, the module system serves primarily+as a mechanism for {\em namespace management}, allowing+programmers to control the visibility of defined +names, either to hide implementation-specific details or to+access parts of the program that would otherwise be out of scope.+Of course, this classification is somewhat subjective, often+depending on emphasis and the issues that are most directly+targeted; some programming language module systems make a good+attempt to serve several of these (or other) goals simultaneously.++The goal of this paper is to provide a formal description for+the module system of Haskell 98, which falls most directly into+the namespace management category that was described above.+Although many aspects of Haskell have been studied previously,+we are not aware of any other attempts to formalize its module+system.   Moreover, as readers of the Haskell mailing list+may confirm, the module system is one of the least understood+aspects of the language, and one in which some of the greatest+variations between different implementations can be found.++In the spirit of the type system specification of Jones \cite{thih},+this paper is a typeset version of a literate Haskell script,+which is an executable specification of the module system.+The number of lines of code in the specification is about 200.++In writing the specification, we have focused more on clarity and+readability than efficiency. Nevertheless, the code presented in this+paper has been developed in the context of a full-scale front-end for+Haskell that works well in practice. For example, we have used the+front-end to parse and process the complete source for the Alfa proof+editor \cite{hallgren:alfa-homepage}+(comprising on the order of 50,000 lines in 500 modules) in+approximately 90 seconds (on a 1.9GHz Pentium 4).++\subsection{Haskell Modules}+\label{HaskMods}++%As described in Section 5 of the Haskell 98 Report \cite{Haskell98},+A Haskell program is a collection of {\em modules}.+A typical module defines a number of {\em entities} (functions, data types,+classes, etc.), imports entities defined in other modules,+and export some of the locally available entities for use by other modules.+Mutual dependencies between modules are allowed.++\subsubsection*{Environments}++Within the context of a particular Haskell module---or,+indeed, at the prompt of an interpreter---there are top-level+{\em environments} (also known as {\em symbol tables}) that+associate names with the entities to which they refer.+One of the main goals of this paper is to+specify and describe how these environments are constructed.+Following conventional wisdom, we might be tempted to use finite+maps as the representation for environments.  For the semantics+of Haskell, however, {\em finite relations} are more appropriate+because they allow us to capture the possibility that a name+has zero, one, or multiple interpretations.  More specifically,+a name $n$ with zero or multiple interpretations causes an error only +if it is actually used in the scope of the environment. Of course, the type+of error that is reported will be different in each case: if+there are no interpretations for the name, then a reference to $n$+indicates a reference to an unbound name; if there are multiple+interpretations, then it indicates an ambiguous reference.  +In our specification we shall often refer to the relation modeling+the symbol table of a module as its {\em in-scope relation}.++By using relations, we could also give a semantics for the renaming+imports found in earlier versions of Haskell. Because we focus on+Haskell 98, we do not pursue this idea further here.++\subsubsection*{Interfaces}++Another important aspect of a module is its {\em interface}.+It defines a set of names (with corresponding entities), which+are made available for other modules to use.  +The main use of this feature is to avoid cluttering other modules +with spurious names.+It also provides a simple abstraction mechanism: by controlling+what names are available to other modules, a programmer can enforce +abstractions.+Because the module interface is essentially a subset of the symbol table+of a module, we also model it as a relation.  We often refer to this+relation as the {\em export relation} of the module.  +++\subsection{Scope and contributions of this paper}++The formal semantics given in this paper captures the semantics of the+Haskell 98 module system in the following sense: given a collection of+Haskell modules, the semantics++\begin{itemize}++\item computes the in-scope and export relations of each module.++\item checks the correctness of all import and export specifications in+      the modules.++\end{itemize}++By using the computed in-scope relations, one can determine+for each name that occurs in the body of a module which+entities (zero, one or more) it refers to.+The local scoping rules within module bodies are+{\em not} part of the presented semantics, however, so it does not+tell you how to detect references to unbound or ambiguous names occurring+in module bodies. That check can be done one module at a time, without further+reference to the module system semantics.++The specification can thus be seen as partitioning the semantics of+Haskell 98 programs into a {\em module system specific part}, and a+{\em module system independent part}.  But apart from determining what+names are in scope, module boundaries affect the meaning of Haskell+programs in two other ways: the scope of a {\iden default} declaration+is limited to the module it occurs in, and type ambiguities caused by+the monomorphism restriction\footnote{More correctly referred to+    as the {\em annoying} monomorphism restriction :-)}+are resolved locally within each module.++The starting point for our work was the original Haskell 98 report+\cite{Haskell98old}.  It has since, in part as a result of+our work, been revised, and the semantics presented in this paper is+intended to be consistent with the current version of section 5 of the+report \cite{Haskell98}.  One feature that is not yet covered by our+semantics, is the visibility of instances, as described in Section 5.4+of the report.++\subsection{Outline of the paper}+The rest of paper is organized as follows:+Section~\ref{sec-relations} introduces relations and operations on them; +Section~\ref{NameEnt} gives definitions dealing with names and entities; +Section~\ref{AbsSyn} presents an abstract syntax for the module system; +Section~\ref{Sem} describes the semantics of Haskell modules, i.e., the+meaning of import and export declarations; +Section~\ref{Err} states criteria for the detection of invalid modules.+Section~\ref{SemProg} glues everything together and discusses some practical+issues, such as separate compilation.+Related work is discussed briefly in Section~\ref{related}.+Conclusions and further discussion appear in Section~\ref{conclusions}.
+ tools/base/Modules/doc/pphs view
binary file changed (absent → 42227 bytes)
+ tools/base/Modules/doc/pphs.sty view
@@ -0,0 +1,38 @@+% =========================================+% Definitions for use with the pphs program+% =========================================++\typeout{For use with the pphs program}++% Definitions of commands used by pphs++\newbox\foo+\def\skipover#1{\setbox\foo\hbox{#1}\hskip\wd\foo}+\def\plusplus{\hbox{$+\mkern-7.5mu+$}}+\def\xspa#1{\hskip#1ex}+\def\bareq{\setbox\foo\hbox{$=$}\makebox[\wd\foo]{$|$}}++% User-redefinable commands - typefaces++\font\bi = cmmib10+\def\keyword{\bf}  +% \def\keyword{\bf\underline}            %% <-- if you like the underlining+\def\sfun{\it}+\def\scon{\it}+\def\styp{\it}+\def\scla{\sl}+\def\iden{\it}+\def\stri{\rm}+\def\com{\it}+\def\numb{\rm}+++% short for Arrows+\def\ra{\rightarrow}+\def\la{\leftarrow}+\def\Ra{\Rightarrow}++% User-redefinable commands - quote marks++\def\forquo{\hbox{\rm '}}+\def\escquo{\hbox{\rm '}}
+ tools/base/Modules/doc/related_work.tex view
@@ -0,0 +1,28 @@+\section{Related work}+\label{related}++We are aware of at least two attempts to formalize the static semantics+of Haskell, but neither of them fully specifies the module system.  In+the static semantics by Peyton Jones and Wadler \cite{SPJWad92}, the +specification of imports was left as future work.  The authors rated it as+one of the highest-priority items on their todo list.  More recently,+Faxén also worked on the static semantics of Haskell \cite{Faxen02}.  +In this work, he gave semantics to some parts of the module system, +but also deviated from the report, opting for what he considered to be a+simpler (although non Haskell 98 compatible) specification +(Section 4.2, \cite{Faxen02}).  Faxén's work is consistent with the+report in that it does not specify how to treat mutually recursive+modules.++Our specification of the Haskell module system is relatively independent+of Haskell itself.  In this respect it is similar to Leroy's work +on ML's module system \cite{Leroy-modular-modules}.+There have been numerous studies on advanced module systems, and the use +of type theory to formalize them \cite{harper+:sharing,MacQueen:86}.+In the same spirit, there has recently been a proposal+for a replacement of the Haskell module system by Shields and Peyton Jones+\cite{shields-pj:first-class-modules}.++++
+ tools/base/Modules/doc/sig-alt-full.cls view
@@ -0,0 +1,1350 @@+% SIG-ALT-FULL.CLS - VERSION 1.0+% "COMPATIBLE" WITH THE "ACM_PROC_ARTICLE-SP.CLS" V2.01SP+% PRODUCES A 'TIGHTER' PAPER AND DOES INCLUDE THE PERMISSION BLOCK+% Gerald Murray December 6 2000+%+% ---- Start of 'updates'  ----+%+% Allowance made to switch default fonts between those systems using+% METAFONT and those using 'Type 1' or 'Truetype' fonts.+% See LINE NUMBER 232 for details.+% Also provided for enumerated/annotated Corollaries 'surrounded' by+% enumerated Theorems (line 790).+% Gerry November 11th. 1999+%+% Made the Permission Statement / Conference Info / Copyright Info+% 'user definable' in the source .tex file OR automatic if+% not specified.+%+% ---- End of 'updates' ----+%+\def\fileversion{v1.0}          % for ACM's tracking purposes+\def\filedate{December 6, 2000}    % Gerry Murray's tracking data+\def\docdate {Wednesday 6th. December 2000} % Gerry Murray (with deltas to doc}+\usepackage{epsfig}+\usepackage{amssymb}+\usepackage{amsmath}+\usepackage{amsfonts}+%+% SIG-ALT-FULL DOCUMENT STYLE+% G.K.M. Tobin August-October 1999+%    adapted from ARTICLE document style by Ken Traub, Olin Shivers+%    also using elements of esub2acm.cls+% HEAVILY MODIFIED, SUBSEQUENTLY, BY GERRY MURRAY 2000+% ARTICLE DOCUMENT STYLE -- Released 16 March 1988+%    for LaTeX version 2.09+% Copyright (C) 1988 by Leslie Lamport+%+%+%%% sig-alt-full.cls is an 'ALTERNATE FULL' document style for producing+%%% two-column camera-ready pages for ACM conferences.+%%% THIS FILE DOES NOT STRICTLY ADHERE TO THE SIGS (BOARD-ENDORSED)+%%% PROCEEDINGS STYLE. It has been designed to produce a 'tighter'+%%% paper in response to concerns over page budgets.+%%% The main features of this style are:+%%%+%%% 1)  Two columns.+%%% 2)  Side and top margins of 4.5pc, bottom margin of 6pc, column gutter of+%%%     2pc, hence columns are 20pc wide and 55.5pc tall.  (6pc =3D 1in, approx)+%%% 3)  First page has title information, and an extra 6pc of space at the+%%%     bottom of the first column for the ACM copyright notice.+%%% 4)  Text is 9pt on 10pt baselines; titles (except main) are 9pt bold.+%%%+%%%+%%% There are a few restrictions you must observe:+%%%+%%% 1)  You cannot change the font size; ACM wants you to use 9pt.+%%% 3)  You must start your paper with the \maketitle command.  Prior to the+%%%     \maketitle you must have \title and \author commands.  If you have a+%%%     \date command it will be ignored; no date appears on the paper, since+%%%     the proceedings will have a date on the front cover.+%%% 4)  Marginal paragraphs, tables of contents, lists of figures and tables,+%%%     and page headings are all forbidden.+%%% 5)  The `figure' environment will produce a figure one column wide; if you+%%%     want one that is two columns wide, use `figure*'.+%%%+%+%%% Copyright Space:+%%% This style automatically reserves 1" blank space at the bottom of page 1/+%%% column 1.  This space can optionally be filled with some text using the+%%% \toappear{...} command.  If used, this command must be BEFORE the \maketitle+%%% command.  If this command is defined AND [preprint] is on, then the+%%% space is filled with the {...} text (at the bottom); otherwise, it is+%%% blank.  If you use \toappearbox{...} instead of \toappear{...} then a+%%% box will be drawn around the text (if [preprint] is on).+%%%+%%% A typical usage looks like this:+%%%     \toappear{To appear in the Ninth AES Conference on Medievil Lithuanian+%%%               Embalming Technique, June 1991, Alfaretta, Georgia.}+%%% This will be included in the preprint, and left out of the conference+%%% version.+%%%+%%% WARNING:+%%% Some dvi-ps converters heuristically allow chars to drift from their+%%% true positions a few pixels. This may be noticeable with the 9pt sans-serif+%%% bold font used for section headers.+%%% You may turn this hackery off via the -e option:+%%%     dvips -e 0 foo.dvi >foo.ps+%%%+\typeout{Document Class 'sig-alt-full' <6th. December '00>.  Modified by G.K.M. Tobin/Gerry Murray}+\typeout{Based in part upon document Style `acmconf' <22 May 89>. Hacked 4/91 by}+\typeout{shivers@cs.cmu.edu, 4/93 by theobald@cs.mcgill.ca}+\typeout{Excerpts were taken from (Journal Style) 'esub2acm.cls'.}+\typeout{****** Bugs/comments/suggestions/technicalities to Gerry Murray -- murray@hq.acm.org ******}+\typeout{Questions on the style, SIGS policies, etc. to Julie Goetz goetz@acm.org or Adrienne Griscti griscti@acm.org}+\oddsidemargin 4.5pc+\evensidemargin 4.5pc+\advance\oddsidemargin by -1in  % Correct for LaTeX gratuitousness+\advance\evensidemargin by -1in % Correct for LaTeX gratuitousness+\marginparwidth 0pt             % Margin pars are not allowed.+\marginparsep 11pt              % Horizontal space between outer margin and+                                % marginal note++                                % Top of page:+\topmargin 4.5pc                % Nominal distance from top of page to top of+                                % box containing running head.+\advance\topmargin by -1in      % Correct for LaTeX gratuitousness+\headheight 0pt                 % Height of box containing running head.+\headsep 0pt                    % Space between running head and text.+                                % Bottom of page:+\footskip 30pt                  % Distance from baseline of box containing foot+                                % to baseline of last line of text.+\@ifundefined{footheight}{\newdimen\footheight}{}% this is for LaTeX2e+\footheight 12pt                % Height of box containing running foot.++%% Must redefine the top margin so there's room for headers and+%% page numbers if you are using the preprint option. Footers+%% are OK as is. Olin.+\advance\topmargin by -37pt     % Leave 37pt above text for headers+\headheight 12pt                % Height of box containing running head.+\headsep 25pt                   % Space between running head and text.++\textheight 666pt       % 9 1/4 column height+\textwidth 42pc         % Width of text line.+                        % For two-column mode:+\columnsep 2pc          %    Space between columns+\columnseprule 0pt      %    Width of rule between columns.+\hfuzz 1pt              % Allow some variation in column width, otherwise it's+                        % too hard to typeset in narrow columns.++\footnotesep 5.6pt      % Height of strut placed at the beginning of every+                        % footnote =3D height of normal \footnotesize strut,+                        % so no extra space between footnotes.++\skip\footins 8.1pt plus 4pt minus 2pt  % Space between last line of text and+                                        % top of first footnote.+\floatsep 11pt plus 2pt minus 2pt       % Space between adjacent floats moved+                                        % to top or bottom of text page.+\textfloatsep 18pt plus 2pt minus 4pt   % Space between main text and floats+                                        % at top or bottom of page.+\intextsep 11pt plus 2pt minus 2pt      % Space between in-text figures and+                                        % text.+\@ifundefined{@maxsep}{\newdimen\@maxsep}{}% this is for LaTeX2e+\@maxsep 18pt                           % The maximum of \floatsep,+                                        % \textfloatsep and \intextsep (minus+                                        % the stretch and shrink).+\dblfloatsep 11pt plus 2pt minus 2pt    % Same as \floatsep for double-column+                                        % figures in two-column mode.+\dbltextfloatsep 18pt plus 2pt minus 4pt% \textfloatsep for double-column+                                        % floats.+\@ifundefined{@dblmaxsep}{\newdimen\@dblmaxsep}{}% this is for LaTeX2e+\@dblmaxsep 18pt                        % The maximum of \dblfloatsep and+                                        % \dbltexfloatsep.+\@fptop 0pt plus 1fil    % Stretch at top of float page/column. (Must be+                         % 0pt plus ...)+\@fpsep 8pt plus 2fil    % Space between floats on float page/column.+\@fpbot 0pt plus 1fil    % Stretch at bottom of float page/column. (Must be+                         % 0pt plus ... )+\@dblfptop 0pt plus 1fil % Stretch at top of float page. (Must be 0pt plus ...)+\@dblfpsep 8pt plus 2fil % Space between floats on float page.+\@dblfpbot 0pt plus 1fil % Stretch at bottom of float page. (Must be+                         % 0pt plus ... )+\marginparpush 5pt       % Minimum vertical separation between two marginal+                         % notes.++\parskip 0pt plus 1pt            % Extra vertical space between paragraphs.+\parindent 9pt  % GM July 2000 / was 0pt - width of paragraph indentation.+\partopsep 2pt plus 1pt minus 1pt% Extra vertical space, in addition to+                                 % \parskip and \topsep, added when user+                                 % leaves blank line before environment.++\@lowpenalty   51       % Produced by \nopagebreak[1] or \nolinebreak[1]+\@medpenalty  151       % Produced by \nopagebreak[2] or \nolinebreak[2]+\@highpenalty 301       % Produced by \nopagebreak[3] or \nolinebreak[3]++\@beginparpenalty -\@lowpenalty % Before a list or paragraph environment.+\@endparpenalty   -\@lowpenalty % After a list or paragraph environment.+\@itempenalty     -\@lowpenalty % Between list items.++\@namedef{ds@10pt}{\@latexerr{The `10pt' option is not allowed in the `acmconf'+  document style.}\@eha}+\@namedef{ds@11pt}{\@latexerr{The `11pt' option is not allowed in the `acmconf'+  document style.}\@eha}+\@namedef{ds@12pt}{\@latexerr{The `12pt' option is not allowed in the `acmconf'+  document style.}\@eha}++\@options++\lineskip 2pt           % \lineskip is 1pt for all font sizes.+\normallineskip 2pt+\def\baselinestretch{1}++\abovedisplayskip 9pt plus2pt minus4.5pt%+\belowdisplayskip \abovedisplayskip+\abovedisplayshortskip  \z@ plus3pt%+\belowdisplayshortskip  5.4pt plus3pt minus3pt%+\let\@listi\@listI     % Setting of \@listi added 9 Jun 87++\def\small{\@setsize\small{9pt}\viiipt\@viiipt+\abovedisplayskip 7.6pt plus 3pt minus 4pt%+\belowdisplayskip \abovedisplayskip+\abovedisplayshortskip \z@ plus2pt%+\belowdisplayshortskip 3.6pt plus2pt minus 2pt+\def\@listi{\leftmargin\leftmargini %% Added 22 Dec 87+\topsep 4pt plus 2pt minus 2pt\parsep 2pt plus 1pt minus 1pt+\itemsep \parsep}}++\def\footnotesize{\@setsize\footnotesize{9pt}\ixpt\@ixpt+\abovedisplayskip 6.4pt plus 2pt minus 4pt%+\belowdisplayskip \abovedisplayskip+\abovedisplayshortskip \z@ plus 1pt%+\belowdisplayshortskip 2.7pt plus 1pt minus 2pt+\def\@listi{\leftmargin\leftmargini %% Added 22 Dec 87+\topsep 3pt plus 1pt minus 1pt\parsep 2pt plus 1pt minus 1pt+\itemsep \parsep}}++\newcount\aucount+\newcount\originalaucount+\newdimen\auwidth+\auwidth=\textwidth+\newdimen\auskip+\newcount\auskipcount+\newdimen\auskip+\global\auskip=1pc+\newdimen\allauboxes+\allauboxes=\auwidth+\newtoks\addauthors+\newcount\addauflag+\global\addauflag=0 %Haven't shown additional authors yet++\newtoks\subtitletext+\gdef\subtitle#1{\subtitletext={#1}}++\gdef\additionalauthors#1{\addauthors={#1}}++\gdef\numberofauthors#1{\global\aucount=#1+\ifnum\aucount>3\global\originalaucount=\aucount \global\aucount=3\fi %g}+\global\auskipcount=\aucount\global\advance\auskipcount by 1+\global\multiply\auskipcount by 2+\global\multiply\auskip by \auskipcount+\global\advance\auwidth by -\auskip+\global\divide\auwidth by \aucount}++% \and was modified to count the number of authors.  GKMT 12 Aug 1999+\def\alignauthor{%                  % \begin{tabular}+\end{tabular}%+  \begin{tabular}[t]{p{\auwidth}}\centering}%++%  *** NOTE *** NOTE *** NOTE *** NOTE ***+%  If you have 'font problems' then you may need+%  to change these, e.g. 'arialb' instead of "arialbd".+%  Gerry Murray 11/11/1999+%  *** OR ** comment out block A and activate block B or vice versa.+% **********************************************+%+%  -- Start of block A -- (Type 1 or Truetype fonts)+%\newfont{\secfnt}{timesbd at 12pt} % was timenrb originally - now is timesbd+%\newfont{\secit}{timesbi at 12pt}   %13 Jan 00 gkmt+%\newfont{\subsecfnt}{timesi at 11pt} % was timenrri originally - now is timesi+%\newfont{\subsecit}{timesbi at 11pt} % 13 Jan 00 gkmt -- was times changed to timesbi gm 2/4/2000+%                         % because "normal" is italic, "italic" is Roman+%\newfont{\ttlfnt}{arialbd at 18pt} % was arialb originally - now is arialbd+%\newfont{\ttlit}{arialbi at 18pt}    % 13 Jan 00 gkmt+%\newfont{\subttlfnt}{arial at 14pt} % was arialr originally - now is arial+%\newfont{\subttlit}{ariali at 14pt} % 13 Jan 00 gkmt+%\newfont{\subttlbf}{arialbd at 14pt}  % 13 Jan 00 gkmt+%\newfont{\aufnt}{arial at 12pt} % was arialr originally - now is arial+%\newfont{\auit}{ariali at 12pt} % 13 Jan 00 gkmt+%\newfont{\affaddr}{arial at 10pt} % was arialr originally - now is arial+%\newfont{\affaddrit}{ariali at 10pt} %13 Jan 00 gkmt+%\newfont{\eaddfnt}{arial at 12pt} % was arialr originally - now is arial+%\newfont{\ixpt}{times at 9pt} % was timenrr originally - now is times+%\newfont{\confname}{timesi at 8pt} % was timenrri - now is timesi+%\newfont{\crnotice}{times at 8pt} % was timenrr originally - now is times+%\newfont{\ninept}{times at 9pt} % was timenrr originally - now is times++% *********************************************+%  -- End of block A --+%+%+% -- Start of block B -- METAFONT+% ++++++++++++++++++++++++++++++++++++++++++++++% Next (default) block for those using Metafont+% Gerry Murray 11/11/1999+% *** THIS BLOCK FOR THOSE USING METAFONT *****+% *********************************************+\newfont{\secfnt}{ptmb at 12pt}+\newfont{\secit}{ptmbi at 12pt}    %13 Jan 00 gkmt+\newfont{\subsecfnt}{ptmri at 11pt}+\newfont{\subsecit}{ptmbi at 11pt}  % 13 Jan 00 gkmt -- was ptmr changed to ptmbi gm 2/4/2000+                         % because "normal" is italic, "italic" is Roman+\newfont{\ttlfnt}{phvb at 18pt}+\newfont{\ttlit}{phvbo at 18pt}    % GM 2/4/2000+\newfont{\subttlfnt}{phvr at 14pt}+\newfont{\subttlit}{phvro at 14pt} % GM 2/4/2000+\newfont{\subttlbf}{phvb at 14pt}  % 13 Jan 00 gkmt+\newfont{\aufnt}{phvr at 12pt}+\newfont{\auit}{phvro at 12pt}     % GM 2/4/2000+\newfont{\affaddr}{phvr at 10pt}+\newfont{\affaddrit}{phvro at 10pt} % GM 2/4/2000+\newfont{\eaddfnt}{phvr at 12pt}+\newfont{\ixpt}{ptmr at 9pt}+\newfont{\confname}{ptmri at 8pt}+\newfont{\crnotice}{ptmr at 8pt}+\newfont{\ninept}{ptmr at 9pt}+% ++++++++++++++++++++++++++++++++++++++++++++++% -- End of block B --++\def\email#1{{{\eaddfnt{\vskip 4pt#1}}}}++\def\addauthorsection{\ifnum\originalaucount>3+    \section{Additional Authors}\the\addauthors+  \fi}++\newcount\savesection+\newcount\sectioncntr+\global\sectioncntr=1++\setcounter{secnumdepth}{3}++\def\appendix{\par+\section*{APPENDIX}+\setcounter{section}{0}+ \setcounter{subsection}{0}+ \def\thesection{\Alph{section}} }++\leftmargini 22.5pt+\leftmarginii 19.8pt    % > \labelsep + width of '(m)'+\leftmarginiii 16.8pt   % > \labelsep + width of 'vii.'+\leftmarginiv 15.3pt    % > \labelsep + width of 'M.'+\leftmarginv 9pt+\leftmarginvi 9pt++\leftmargin\leftmargini+\labelsep 4.5pt+\labelwidth\leftmargini\advance\labelwidth-\labelsep++\def\@listI{\leftmargin\leftmargini \parsep 3.6pt plus 2pt minus 1pt%+\topsep 7.2pt plus 2pt minus 4pt%+\itemsep 3.6pt plus 2pt minus 1pt}++\let\@listi\@listI+\@listi++\def\@listii{\leftmargin\leftmarginii+   \labelwidth\leftmarginii\advance\labelwidth-\labelsep+   \topsep 3.6pt plus 2pt minus 1pt+   \parsep 1.8pt plus 0.9pt minus 0.9pt+   \itemsep \parsep}++\def\@listiii{\leftmargin\leftmarginiii+    \labelwidth\leftmarginiii\advance\labelwidth-\labelsep+    \topsep 1.8pt plus 0.9pt minus 0.9pt+    \parsep \z@ \partopsep 1pt plus 0pt minus 1pt+    \itemsep \topsep}++\def\@listiv{\leftmargin\leftmarginiv+     \labelwidth\leftmarginiv\advance\labelwidth-\labelsep}++\def\@listv{\leftmargin\leftmarginv+     \labelwidth\leftmarginv\advance\labelwidth-\labelsep}++\def\@listvi{\leftmargin\leftmarginvi+     \labelwidth\leftmarginvi\advance\labelwidth-\labelsep}++\def\labelenumi{\theenumi.}+\def\theenumi{\arabic{enumi}}++\def\labelenumii{(\theenumii)}+\def\theenumii{\alph{enumii}}+\def\p@enumii{\theenumi}++\def\labelenumiii{\theenumiii.}+\def\theenumiii{\roman{enumiii}}+\def\p@enumiii{\theenumi(\theenumii)}++\def\labelenumiv{\theenumiv.}+\def\theenumiv{\Alph{enumiv}}+\def\p@enumiv{\p@enumiii\theenumiii}++\def\labelitemi{$\bullet$}+\def\labelitemii{\bf --}+\def\labelitemiii{$\ast$}+\def\labelitemiv{$\cdot$}++\def\verse{\let\\=\@centercr+  \list{}{\itemsep\z@ \itemindent -1.5em\listparindent \itemindent+          \rightmargin\leftmargin\advance\leftmargin 1.5em}\item[]}+\let\endverse\endlist++\def\quotation{\list{}{\listparindent 1.5em+    \itemindent\listparindent+    \rightmargin\leftmargin \parsep 0pt plus 1pt}\item[]}+\let\endquotation=\endlist++\def\quote{\list{}{\rightmargin\leftmargin}\item[]}+\let\endquote=\endlist++\def\descriptionlabel#1{\hspace\labelsep \bf #1}+\def\description{\list{}{\labelwidth\z@ \itemindent-\leftmargin+       \let\makelabel\descriptionlabel}}++\let\enddescription\endlist++\def\theequation{\arabic{equation}}++\arraycolsep 4.5pt   % Half the space between columns in an array environment.+\tabcolsep 5.4pt    % Half the space between columns in a tabular environment.+\arrayrulewidth .4pt % Width of rules in array and tabular environment.+\doublerulesep 1.8pt % Space between adjacent rules in array or tabular env.++\tabbingsep \labelsep   % Space used by the \' command.  (See LaTeX manual.)++\skip\@mpfootins =\skip\footins++\fboxsep =2.7pt      % Space left between box and text by \fbox and \framebox.+\fboxrule =.4pt      % Width of rules in box made by \fbox and \framebox.++\def\thepart{\Roman{part}} % Roman numeral part numbers.+\def\thesection       {\arabic{section}}+\def\thesubsection    {\thesection.\arabic{subsection}}+\def\thesubsubsection {\thesubsection.\arabic{subsubsection}}+\def\theparagraph     {\thesubsubsection.\arabic{paragraph}}+\def\thesubparagraph  {\theparagraph.\arabic{subparagraph}}++\def\@pnumwidth{1.55em}+\def\@tocrmarg {2.55em}+\def\@dotsep{4.5}+\setcounter{tocdepth}{3}++\def\tableofcontents{\@latexerr{\tableofcontents: Tables of contents are not+  allowed in the `acmconf' document style.}\@eha}++\def\l@part#1#2{\addpenalty{\@secpenalty}+   \addvspace{2.25em plus 1pt}  % space above part line+   \begingroup+   \@tempdima 3em       % width of box holding part number, used by+     \parindent \z@ \rightskip \@pnumwidth      %% \numberline+     \parfillskip -\@pnumwidth+     {\large \bf        % set line in \large boldface+     \leavevmode        % TeX command to enter horizontal mode.+     #1\hfil \hbox to\@pnumwidth{\hss #2}}\par+     \nobreak           % Never break after part entry+   \endgroup}++\def\l@section#1#2{\addpenalty{\@secpenalty} % good place for page break+   \addvspace{1.0em plus 1pt}   % space above toc entry+   \@tempdima 1.5em             % width of box holding section number+   \begingroup+    \parindent  \z@ \rightskip \@pnumwidth+     \parfillskip -\@pnumwidth+     \bf                        % Boldface.+     \leavevmode                % TeX command to enter horizontal mode.+      \advance\leftskip\@tempdima %% added 5 Feb 88 to conform to+      \hskip -\leftskip           %% 25 Jan 88 change to \numberline+     #1\nobreak\hfil \nobreak\hbox to\@pnumwidth{\hss #2}\par+   \endgroup}+++\def\l@subsection{\@dottedtocline{2}{1.5em}{2.3em}}+\def\l@subsubsection{\@dottedtocline{3}{3.8em}{3.2em}}+\def\l@paragraph{\@dottedtocline{4}{7.0em}{4.1em}}+\def\l@subparagraph{\@dottedtocline{5}{10em}{5em}}++\def\listoffigures{\@latexerr{\listoffigures: Lists of figures are not+  allowed in the `acmconf' document style.}\@eha}++\def\l@figure{\@dottedtocline{1}{1.5em}{2.3em}}++\def\listoftables{\@latexerr{\listoftables: Lists of tables are not+  allowed in the `acmconf' document style.}\@eha}+\let\l@table\l@figure++\def\footnoterule{\kern-3\p@+  \hrule width .4\columnwidth+  \kern 2.6\p@}                 % The \hrule has default height of .4pt .+\long\def\@makefntext#1{\noindent+\hbox to .5em{\hss$^{\@thefnmark}$}#1}++\long\def\@maketntext#1{\noindent+#1}++\long\def\@maketitlenotetext#1#2{\noindent+            \hbox to 1.8em{\hss$^{#1}$}#2}++\setcounter{topnumber}{2}+\def\topfraction{.7}+\setcounter{bottomnumber}{1}+\def\bottomfraction{.3}+\setcounter{totalnumber}{3}+\def\textfraction{.2}+\def\floatpagefraction{.5}+\setcounter{dbltopnumber}{2}+\def\dbltopfraction{.7}+\def\dblfloatpagefraction{.5}++%+\long\def\@makecaption#1#2{+   \vskip \baselineskip+   \setbox\@tempboxa\hbox{\textbf{#1: #2}}+   \ifdim \wd\@tempboxa >\hsize % IF longer than one line:+       \textbf{#1: #2}\par               %   THEN set as ordinary paragraph.+     \else                      %   ELSE  center.+       \hbox to\hsize{\hfil\box\@tempboxa\hfil}\par+   \fi}++%++\long\def\@makecaption#1#2{+   \vskip 10pt+   \setbox\@tempboxa\hbox{\textbf{#1: #2}}+   \ifdim \wd\@tempboxa >\hsize % IF longer than one line:+       \textbf{#1: #2}\par                %   THEN set as ordinary paragraph.+     \else                      %   ELSE  center.+       \hbox to\hsize{\hfil\box\@tempboxa\hfil}+   \fi}++\@ifundefined{figure}{\newcounter {figure}} % this is for LaTeX2e++\def\fps@figure{tbp}+\def\ftype@figure{1}+\def\ext@figure{lof}+\def\fnum@figure{Figure \thefigure}+\def\figure{\@float{figure}}+\let\endfigure\end@float+\@namedef{figure*}{\@dblfloat{figure}}+\@namedef{endfigure*}{\end@dblfloat}++\@ifundefined{table}{\newcounter {table}} % this is for LaTeX2e++\def\fps@table{tbp}+\def\ftype@table{2}+\def\ext@table{lot}+\def\fnum@table{Table \thetable}+\def\table{\@float{table}}+\let\endtable\end@float+\@namedef{table*}{\@dblfloat{table}}+\@namedef{endtable*}{\end@dblfloat}++\newtoks\titleboxnotes+\newcount\titleboxnoteflag++\def\maketitle{\par+ \begingroup+   \def\thefootnote{\fnsymbol{footnote}}+   \def\@makefnmark{\hbox+       to 0pt{$^{\@thefnmark}$\hss}}+     \twocolumn[\@maketitle]+\@thanks+ \endgroup+ \setcounter{footnote}{0}+ \let\maketitle\relax+ \let\@maketitle\relax+ \gdef\@thanks{}\gdef\@author{}\gdef\@title{}\gdef\@subtitle{}\let\thanks\relax+ \@copyrightspace}++%% CHANGES ON NEXT LINES+\newif\if@ll % to record which version of LaTeX is in use++\expandafter\ifx\csname LaTeXe\endcsname\relax % LaTeX2.09 is used+\else% LaTeX2e is used, so set ll to true+\global\@lltrue+\fi++\if@ll+  \NeedsTeXFormat{LaTeX2e}+  \ProvidesClass{sig-alt-full} [2000/12/06 - V1.0 - based on acmproc.cls V1.3 <Nov. 30 '99>]+  \RequirePackage{latexsym}% QUERY: are these two really needed?+  \let\dooptions\ProcessOptions+\else+  \let\dooptions\@options+\fi+%% END CHANGES++\def\@height{height}+\def\@width{width}+\def\@minus{minus}+\def\@plus{plus}+\def\hb@xt@{\hbox to}+\newif\if@faircopy+\@faircopyfalse+\def\ds@faircopy{\@faircopytrue}++\def\ds@preprint{\@faircopyfalse}++\@twosidetrue+\@mparswitchtrue+\def\ds@draft{\overfullrule 5\p@}+%% CHANGE ON NEXT LINE+\dooptions++\lineskip \p@+\normallineskip \p@+\def\baselinestretch{1}+\def\@ptsize{0} %needed for amssymbols.sty++%% CHANGES ON NEXT LINES+\if@ll% allow use of old-style font change commands in LaTeX2e+\@maxdepth\maxdepth+%+\DeclareOldFontCommand{\rm}{\ninept\rmfamily}{\mathrm}+\DeclareOldFontCommand{\sf}{\normalfont\sffamily}{\mathsf}+\DeclareOldFontCommand{\tt}{\normalfont\ttfamily}{\mathtt}+\DeclareOldFontCommand{\bf}{\normalfont\bfseries}{\mathbf}+\DeclareOldFontCommand{\it}{\normalfont\itshape}{\mathit}+\DeclareOldFontCommand{\sl}{\normalfont\slshape}{\@nomath\sl}+\DeclareOldFontCommand{\sc}{\normalfont\scshape}{\@nomath\sc}+\DeclareRobustCommand*{\cal}{\@fontswitch{\relax}{\mathcal}}+\DeclareRobustCommand*{\mit}{\@fontswitch{\relax}{\mathnormal}}+\fi+%+\if@ll+ \renewcommand{\rmdefault}{cmr}  % was 'ttm'+% Note! I have also found 'mvr' to work ESPECIALLY well.+% Gerry - October 1999+% You may need to change your LV1times.fd file so that sc is+% mapped to cmcsc - -for smallcaps -- that is if you decide+% to change {cmr} to {times} above. (Not recommended)+  \renewcommand{\@ptsize}{}+  \renewcommand{\normalsize}{%+    \@setfontsize\normalsize\@ixpt{10.5\p@}%\ninept%+    \abovedisplayskip 6\p@ \@plus2\p@ \@minus\p@+    \belowdisplayskip \abovedisplayskip+    \abovedisplayshortskip 6\p@ \@minus 3\p@+    \belowdisplayshortskip 6\p@ \@minus 3\p@+    \let\@listi\@listI+  }+\else+  \def\@normalsize{%changed next to 9 from 10+    \@setsize\normalsize{9\p@}\ixpt\@ixpt+   \abovedisplayskip 6\p@ \@plus2\p@ \@minus\p@+    \belowdisplayskip \abovedisplayskip+    \abovedisplayshortskip 6\p@ \@minus 3\p@+    \belowdisplayshortskip 6\p@ \@minus 3\p@+    \let\@listi\@listI+  }%+\fi+\if@ll+  \newcommand\scriptsize{\@setfontsize\scriptsize\@viipt{8\p@}}+  \newcommand\tiny{\@setfontsize\tiny\@vpt{6\p@}}+  \newcommand\large{\@setfontsize\large\@xiipt{14\p@}}+  \newcommand\Large{\@setfontsize\Large\@xivpt{18\p@}}+  \newcommand\LARGE{\@setfontsize\LARGE\@xviipt{20\p@}}+  \newcommand\huge{\@setfontsize\huge\@xxpt{25\p@}}+  \newcommand\Huge{\@setfontsize\Huge\@xxvpt{30\p@}}+\else+  \def\scriptsize{\@setsize\scriptsize{8\p@}\viipt\@viipt}+  \def\tiny{\@setsize\tiny{6\p@}\vpt\@vpt}+  \def\large{\@setsize\large{14\p@}\xiipt\@xiipt}+  \def\Large{\@setsize\Large{18\p@}\xivpt\@xivpt}+  \def\LARGE{\@setsize\LARGE{20\p@}\xviipt\@xviipt}+  \def\huge{\@setsize\huge{25\p@}\xxpt\@xxpt}+  \def\Huge{\@setsize\Huge{30\p@}\xxvpt\@xxvpt}+\fi+\normalsize++% make aubox hsize/number of authors up to 3, less gutter+% then showbox gutter showbox gutter showbox -- GKMT Aug 99+\newbox\@acmtitlebox+\def\@maketitle{\newpage+ \null+ \setbox\@acmtitlebox\vbox{%+\baselineskip 20pt+\vskip 2em                   % Vertical space above title.+   \begin{center}+    {\ttlfnt \@title\par}       % Title set in 18pt Helvetica (Arial) bold size.+    \vskip 1.5em                % Vertical space after title.+%This should be the subtitle.+{\subttlfnt \the\subtitletext\par}\vskip 1.25em%\fi+    {\baselineskip 16pt\aufnt   % each author set in \12 pt Arial, in a+     \lineskip .5em             % tabular environment+     \begin{tabular}[t]{c}\@author+     \end{tabular}\par}+    \vskip 1.5em               % Vertical space after author.+   \end{center}}+ \dimen0=\ht\@acmtitlebox+ \advance\dimen0 by -12.75pc\relax % Increased space for title box -- KBT+ \unvbox\@acmtitlebox+ \ifdim\dimen0<0.0pt\relax\vskip-\dimen0\fi}+++\newcount\titlenotecount+\global\titlenotecount=0+\newtoks\tntoks+\newtoks\tntokstwo+\newtoks\tntoksthree+\newtoks\tntoksfour+\newtoks\tntoksfive++\def\abstract{+\ifnum\titlenotecount>0 % was =1+    \insert\footins{%+    \reset@font\footnotesize+        \interlinepenalty\interfootnotelinepenalty+        \splittopskip\footnotesep+        \splitmaxdepth \dp\strutbox \floatingpenalty \@MM+        \hsize\columnwidth \@parboxrestore+        \protected@edef\@currentlabel{%+        }%+        \color@begingroup+\ifnum\titlenotecount=1+      \@maketntext{%+         \raisebox{4pt}{$\ast$}\rule\z@\footnotesep\ignorespaces\the\tntoks\@finalstrut\strutbox}%+\fi+\ifnum\titlenotecount=2+      \@maketntext{%+      \raisebox{4pt}{$\ast$}\rule\z@\footnotesep\ignorespaces\the\tntoks\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\dagger$}\rule\z@\footnotesep\ignorespaces\the\tntokstwo\@finalstrut\strutbox}%+\fi+\ifnum\titlenotecount=3+      \@maketntext{%+         \raisebox{4pt}{$\ast$}\rule\z@\footnotesep\ignorespaces\the\tntoks\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\dagger$}\rule\z@\footnotesep\ignorespaces\the\tntokstwo\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\ddagger$}\rule\z@\footnotesep\ignorespaces\the\tntoksthree\@finalstrut\strutbox}%+\fi+\ifnum\titlenotecount=4+      \@maketntext{%+         \raisebox{4pt}{$\ast$}\rule\z@\footnotesep\ignorespaces\the\tntoks\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\dagger$}\rule\z@\footnotesep\ignorespaces\the\tntokstwo\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\ddagger$}\rule\z@\footnotesep\ignorespaces\the\tntoksthree\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\S$}\rule\z@\footnotesep\ignorespaces\the\tntoksfour\@finalstrut\strutbox}%+\fi+\ifnum\titlenotecount=5+      \@maketntext{%+         \raisebox{4pt}{$\ast$}\rule\z@\footnotesep\ignorespaces\the\tntoks\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\dagger$}\rule\z@\footnotesep\ignorespaces\the\tntokstwo\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\ddagger$}\rule\z@\footnotesep\ignorespaces\the\tntoksthree\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\S$}\rule\z@\footnotesep\ignorespaces\the\tntoksfour\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\P$}\rule\z@\footnotesep\ignorespaces\the\tntoksfive\@finalstrut\strutbox}%+\fi+   \color@endgroup} %g}+\fi+\setcounter{footnote}{0}+\section*{ABSTRACT}\normalsize%\ninept+}++\def\endabstract{\if@twocolumn\else\endquotation\fi}++\def\keywords{\if@twocolumn+\section*{Keywords}+\else \small+\quotation+\fi}++\def\terms{\if@twocolumn+\section*{General Terms}+\else \small+\quotation+\fi}++% -- Classification needs to be a bit smart due to optionals - Gerry/Georgia November 2nd. 1999+\newcount\catcount+\global\catcount=1++\def\category#1#2#3{%+\ifnum\catcount=1+\section*{Categories and Subject Descriptors}+\advance\catcount by 1\else{\unskip; }\fi+    \@ifnextchar [{\@category{#1}{#2}{#3}}{\@category{#1}{#2}{#3}[]}%+}++\def\@category#1#2#3[#4]{%+    \begingroup+        \let\and\relax+            #1 [\textbf{#2}]%+            \if!#4!%+                \if!#3!\else : #3\fi+            \else+                :\space+                \if!#3!\else #3\kern\z@---\hskip\z@\fi+                \textit{#4}%+            \fi+    \endgroup+}+%++%%% This section (written by KBT) handles the 1" box in the lower left+%%% corner of the left column of the first page by creating a picture,+%%% and inserting the predefined string at the bottom (with a negative+%%% displacement to offset the space allocated for a non-existent+%%% caption).+%%%+\newtoks\copyrightnotice+\def\ftype@copyrightbox{8}+\def\@copyrightspace{+\@float{copyrightbox}[b]+\begin{center}+\setlength{\unitlength}{1pc}+\begin{picture}(20,6) %Space for copyright notice+\put(0,-0.95){\crnotice{\@toappear}}+\end{picture}+\end{center}+\end@float}++\def\@toappear{} % Default setting blank - commands below change this.+\long\def\toappear#1{\def\@toappear{\parbox[b]{20pc}{\baselineskip 9pt#1}}}+\def\toappearbox#1{\def\@toappear{\raisebox{5pt}{\framebox[20pc]{\parbox[b]{19pc}{#1}}}}}++\newtoks\conf+\newtoks\confinfo+\def\conferenceinfo#1#2{\global\conf={#1}\global\confinfo{#2}}+++\def\marginpar{\@latexerr{The \marginpar command is not allowed in the+  `acmconf' document style.}\@eha}++\mark{{}{}}     % Initializes TeX's marks++\def\today{\ifcase\month\or+  January\or February\or March\or April\or May\or June\or+  July\or August\or September\or October\or November\or December\fi+  \space\number\day, \number\year}++\def\@begintheorem#1#2{%+    \parskip 0pt % GM July 2000 (for tighter spacing)+    \trivlist+    \item[%+        \hskip 10\p@+        \hskip \labelsep+        {{\sc #1}\hskip 5\p@\relax#2.}%+    ]+    \it+}+\def\@opargbegintheorem#1#2#3{%+    \parskip 0pt % GM July 2000 (for tighter spacing)+    \trivlist+    \item[%+        \hskip 10\p@+        \hskip \labelsep+        {\sc #1\ #2\             % This mod by Gerry to enumerate corollaries+   \setbox\@tempboxa\hbox{(#3)}  % and bracket the 'corollary title'+        \ifdim \wd\@tempboxa>\z@ % and retain the correct numbering of e.g. theorems+            \hskip 5\p@\relax    % if they occur 'around' said corollaries.+            \box\@tempboxa       % Gerry - Nov. 1999.+        \fi.}%+    ]+    \it+}+\newif\if@qeded+\global\@qededfalse+\def\proof{%+  \vspace{-\parskip} % GM July 2000 (for tighter spacing)+    \global\@qededfalse+    \@ifnextchar[{\@xproof}{\@proof}%+}++\def\endproof{%+    \if@qeded\else\qed\fi+    \endtrivlist+}+\def\@proof{%+    \trivlist+    \item[%+        \hskip 10\p@+        \hskip \labelsep+        {\sc Proof.}%+    ]+    \ignorespaces+}+\def\@xproof[#1]{%+    \trivlist+    \item[\hskip 10\p@\hskip \labelsep{\sc Proof #1.}]%+    \ignorespaces+}+\def\qed{%+    \unskip+    \kern 10\p@+    \begingroup+        \unitlength\p@+        \linethickness{.4\p@}%+        \framebox(6,6){}%+    \endgroup+    \global\@qededtrue+}++\def\newdef#1#2{%+    \expandafter\@ifdefinable\csname #1\endcsname+        {\@definecounter{#1}%+         \expandafter\xdef\csname the#1\endcsname{\@thmcounter{#1}}%+         \global\@namedef{#1}{\@defthm{#1}{#2}}%+         \global\@namedef{end#1}{\@endtheorem}%+    }%+}+\def\@defthm#1#2{%+    \refstepcounter{#1}%+    \@ifnextchar[{\@ydefthm{#1}{#2}}{\@xdefthm{#1}{#2}}%+}+\def\@xdefthm#1#2{%+    \@begindef{#2}{\csname the#1\endcsname}%+    \ignorespaces+}+\def\@ydefthm#1#2[#3]{%+    \trivlist+    \item[%+        \hskip 10\p@+        \hskip \labelsep+        {\it #2%+         \savebox\@tempboxa{#3}%+         \ifdim \wd\@tempboxa>\z@+            \ \box\@tempboxa+         \fi.%+        }]%+    \ignorespaces+}+\def\@begindef#1#2{%+    \trivlist+    \item[%+        \hskip 10\p@+        \hskip \labelsep+        {\it #1\ \rm #2.}%+    ]%+}+\def\theequation{\arabic{equation}}++\newcounter{part}+\newcounter{section}+\newcounter{subsection}[section]+\newcounter{subsubsection}[subsection]+\newcounter{paragraph}[subsubsection]+\def\thepart{\Roman{part}}+\def\thesection{\arabic{section}}+\def\thesubsection{\thesection.\arabic{subsection}}+\def\thesubsubsection{{\subsecfnt\thesubsection.\arabic{subsubsection}}}+\def\theparagraph{{\subsecfnt\thesubsubsection.\arabic{paragraph}}}+\newif\if@uchead+\@ucheadfalse++%% CHANGES: NEW NOTE+%% NOTE: OK to use old-style font commands below, since they were+%% suitably redefined for LaTeX2e+%% END CHANGES+\setcounter{secnumdepth}{3}+\def\part{%+    \@startsection{part}{9}{\z@}{-10\p@ \@plus -4\p@ \@minus -2\p@}+        {4\p@}{\normalsize\@ucheadtrue}%+}+\def\section{%+    \@startsection{section}{1}{\z@}{-10\p@ \@plus -4\p@ \@minus -2\p@}% GM+    {4\p@}{\baselineskip 14pt\secfnt\@ucheadtrue}%+}++\def\subsection{%+    \@startsection{subsection}{2}{\z@}{-8\p@ \@plus -2\p@ \@minus -\p@}+    {4\p@}{\secfnt}%+}+\def\subsubsection{%+    \@startsection{subsubsection}{3}{\z@}{-8\p@ \@plus -2\p@ \@minus -\p@}%+    {4\p@}{\subsecfnt}%+}+\def\paragraph{%+    \vskip 12pt\@startsection{paragraph}{3}{\z@}{6\p@ \@plus \p@}%+    {-5\p@}{\subsecfnt}%+}+\let\@period=.+\def\@startsection#1#2#3#4#5#6{%+        \if@noskipsec  %gkmt, 11 aug 99+        \global\let\@period\@empty+        \leavevmode+        \global\let\@period.%+    \fi+      \par %+    \@tempskipa #4\relax+    \@afterindenttrue+    \ifdim \@tempskipa <\z@+        \@tempskipa -\@tempskipa+        \@afterindentfalse+    \fi+    \if@nobreak+    \everypar{}%+    \else+        \addpenalty\@secpenalty+        \addvspace\@tempskipa+    \fi+% removed by SLPJ!+% \parskip=0pt % GM July 2000 (non numbered) section heads+    \@ifstar+        {\@ssect{#3}{#4}{#5}{#6}}+        {\@dblarg{\@sect{#1}{#2}{#3}{#4}{#5}{#6}}}%+}+\def\@sect#1#2#3#4#5#6[#7]#8{%+    \ifnum #2>\c@secnumdepth+        \let\@svsec\@empty+    \else+        \refstepcounter{#1}%+        \edef\@svsec{%+            \begingroup+                \ifnum#2>2 \noexpand\rm \fi+                \csname the#1\endcsname+            \endgroup+            \ifnum #2=1\relax .\fi+            \hskip 1em+        }%+    \fi+    \@tempskipa #5\relax+    \ifdim \@tempskipa>\z@+        \begingroup+            #6\relax+            \@hangfrom{\hskip #3\relax\@svsec}%+            \begingroup+                \interlinepenalty \@M+                \if@uchead+                    \uppercase{#8}%+                \else+                    #8%+                \fi+                \par+            \endgroup+        \endgroup+        \csname #1mark\endcsname{#7}%+        \vskip -12pt  %gkmt, 11 aug 99 and GM July 2000 (was -14) - numbered section head spacing+\addcontentsline{toc}{#1}{%+            \ifnum #2>\c@secnumdepth \else+                \protect\numberline{\csname the#1\endcsname}%+            \fi+            #7%+        }%+    \else+        \def\@svsechd{%+            #6%+            \hskip #3\relax+            \@svsec+            \if@uchead+                \uppercase{#8}%+            \else+                #8%+            \fi+            \csname #1mark\endcsname{#7}%+            \addcontentsline{toc}{#1}{%+                \ifnum #2>\c@secnumdepth \else+                    \protect\numberline{\csname the#1\endcsname}%+                \fi+                #7%+            }%+        }%+    \fi+    \@xsect{#5}\hskip 1pt+    \par+}+\def\@xsect#1{%+    \@tempskipa #1\relax+    \ifdim \@tempskipa>\z@+        \par+        \nobreak+        \vskip \@tempskipa+        \@afterheading+    \else+        \global\@nobreakfalse+        \global\@noskipsectrue+        \everypar{%+            \if@noskipsec+                \global\@noskipsecfalse+                \clubpenalty\@M+                \hskip -\parindent+                \begingroup+                    \@svsechd+                    \@period+                \endgroup+                \unskip+                \@tempskipa #1\relax+                \hskip -\@tempskipa+            \else+                \clubpenalty \@clubpenalty+                \everypar{}%+            \fi+        }%+    \fi+    \ignorespaces+}+\def\@trivlist{%+    \@topsepadd\topsep+    \if@noskipsec+        \global\let\@period\@empty+        \leavevmode+        \global\let\@period.%+    \fi+    \ifvmode+        \advance\@topsepadd\partopsep+    \else+        \unskip+        \par+    \fi+    \if@inlabel+        \@noparitemtrue+        \@noparlisttrue+    \else+        \@noparlistfalse+        \@topsep\@topsepadd+    \fi+    \advance\@topsep \parskip+    \leftskip\z@skip+    \rightskip\@rightskip+    \parfillskip\@flushglue+    \@setpar{\if@newlist\else{\@@par}\fi}+    \global\@newlisttrue+    \@outerparskip\parskip+}++%%% Actually, 'abbrev' works just fine as the default+%%% Bibliography style.++\typeout{Using 'Abbrev' bibliography style}+\newcommand\bibyear[2]{%+    \unskip\quad\ignorespaces#1\unskip+    \if#2..\quad \else \quad#2 \fi+}+\newcommand{\bibemph}[1]{{\em#1}}+\newcommand{\bibemphic}[1]{{\em#1\/}}+\newcommand{\bibsc}[1]{{\sc#1}}+\def\@normalcite{%+    \def\@cite##1##2{[##1\if@tempswa , ##2\fi]}%+}+\def\@citeNB{%+    \def\@cite##1##2{##1\if@tempswa , ##2\fi}%+}+\def\@citeRB{%+    \def\@cite##1##2{##1\if@tempswa , ##2\fi]}%+}+\def\start@cite#1#2{%+    \edef\citeauthoryear##1##2##3{%+        ###1%+        \ifnum#2=\z@ \else\ ###2\fi+    }%+    \ifnum#1=\thr@@+        \let\@@cite\@citeyear+    \else+        \let\@@cite\@citenormal+    \fi+    \@ifstar{\@citeNB\@@cite}{\@normalcite\@@cite}%+}+\def\cite{\start@cite23}+\def\citeNP{\cite*}+\def\citeA{\start@cite10}+\def\citeANP{\citeA*}+\def\shortcite{\start@cite23}+\def\shortciteNP{\shortcite*}+\def\shortciteA{\start@cite20}+\def\shortciteANP{\shortciteA*}+\def\citeyear{\start@cite30}+\def\citeyearNP{\citeyear*}+\def\citeN{%+    \@citeRB+    \def\citeauthoryear##1##2##3{##1\ [##3%+        \def\reserved@a{##1}%+        \def\citeauthoryear####1####2####3{%+            \def\reserved@b{####1}%+            \ifx\reserved@a\reserved@b+                ####3%+            \else+                \errmessage{Package acmart Error: author mismatch+                         in \string\citeN^^J^^J%+                    See the acmart package documentation for explanation}%+            \fi+        }%+    }%+    \@ifstar\@citeyear\@citeyear+}+\def\shortciteN{%+    \@citeRB+    \def\citeauthoryear##1##2##3{##2\ [##3%+        \def\reserved@a{##2}%+        \def\citeauthoryear####1####2####3{%+            \def\reserved@b{####2}%+            \ifx\reserved@a\reserved@b+                ####3%+            \else+                \errmessage{Package acmart Error: author mismatch+                         in \string\shortciteN^^J^^J%+                    See the acmart package documentation for explanation}%+            \fi+        }%+    }%+    \@ifstar\@citeyear\@citeyear  % GM July 2000+}+\def\@citenormal{%+    \@ifnextchar [{\@tempswatrue\@citex;}+                  {\@tempswafalse\@citex,[]}% % GM July 2000+}+\def\@citeyear{%+    \@ifnextchar [{\@tempswatrue\@citex,}%+                  {\@tempswafalse\@citex,[]}%+}+\def\@citex#1[#2]#3{%+    \let\@citea\@empty+    \@cite{%+        \@for\@citeb:=#3\do{%+            \@citea+            \def\@citea{#1 }%+            \edef\@citeb{\expandafter\@iden\@citeb}%+            \if@filesw+                \immediate\write\@auxout{\string\citation{\@citeb}}%+            \fi+            \@ifundefined{b@\@citeb}{%+                {\bf ?}%+                \@warning{%+                    Citation `\@citeb' on page \thepage\space undefined%+                }%+            }%+            {\csname b@\@citeb\endcsname}%+        }%+    }{#2}%+}+\let\@biblabel\@gobble+\newdimen\bibindent+\setcounter{enumi}{1}+\bibindent=0em+\def\thebibliography#1{%+\ifnum\addauflag=0\addauthorsection\global\addauflag=1\fi+    \section{%+       {REFERENCES}+         \vskip -9pt  % GM July 2000 (for tighter spacing)+        \@mkboth{{\refname}}{{\refname}}%+    }%+    \list{[\arabic{enumi}]}{%+        \settowidth\labelwidth{[#1]}%+        \leftmargin\labelwidth+        \advance\leftmargin\labelsep+        \advance\leftmargin\bibindent+        \parsep=0pt\itemsep=1pt % GM July 2000+        \itemindent -\bibindent+        \listparindent \itemindent+        \usecounter{enumi}+    }%+    \let\newblock\@empty+    \raggedright % GM July 2000+    \sloppy+    \sfcode`\.=1000\relax+}+++\gdef\balancecolumns+{\vfill\eject+\global\@colht=\textheight+\global\ht\@cclv=\textheight+}++\newcount\colcntr+\global\colcntr=0+\newbox\savebox++\gdef \@makecol {%+\global\advance\colcntr by 1+\ifnum\colcntr>2 \global\colcntr=1\fi+   \ifvoid\footins+     \setbox\@outputbox \box\@cclv+   \else+     \setbox\@outputbox \vbox{%+\boxmaxdepth \@maxdepth+       \@tempdima\dp\@cclv+       \unvbox \@cclv+       \vskip-\@tempdima+       \vskip \skip\footins+       \color@begingroup+         \normalcolor+         \footnoterule+         \unvbox \footins+       \color@endgroup+       }%+   \fi+   \xdef\@freelist{\@freelist\@midlist}%+   \global \let \@midlist \@empty+   \@combinefloats+   \ifvbox\@kludgeins+     \@makespecialcolbox+   \else+     \setbox\@outputbox \vbox to\@colht {%+\@texttop+       \dimen@ \dp\@outputbox+       \unvbox \@outputbox+   \vskip -\dimen@+       \@textbottom+       }%+   \fi+   \global \maxdepth \@maxdepth+}+\def\titlenote{\@ifnextchar[\@xtitlenote{\stepcounter\@mpfn+\global\advance\titlenotecount by 1+\ifnum\titlenotecount=1+    \raisebox{9pt}{$\ast$}+\fi+\ifnum\titlenotecount=2+    \raisebox{9pt}{$\dagger$}+\fi+\ifnum\titlenotecount=3+    \raisebox{9pt}{$\ddagger$}+\fi+\ifnum\titlenotecount=4+\raisebox{9pt}{$\S$}+\fi+\ifnum\titlenotecount=5+\raisebox{9pt}{$\P$}+\fi+         \@titlenotetext+}}++\long\def\@titlenotetext#1{\insert\footins{%+\ifnum\titlenotecount=1\global\tntoks={#1}\fi+\ifnum\titlenotecount=2\global\tntokstwo={#1}\fi+\ifnum\titlenotecount=3\global\tntoksthree={#1}\fi+\ifnum\titlenotecount=4\global\tntoksfour={#1}\fi+\ifnum\titlenotecount=5\global\tntoksfive={#1}\fi+    \reset@font\footnotesize+    \interlinepenalty\interfootnotelinepenalty+    \splittopskip\footnotesep+    \splitmaxdepth \dp\strutbox \floatingpenalty \@MM+    \hsize\columnwidth \@parboxrestore+    \protected@edef\@currentlabel{%+    }%+    \color@begingroup+   \color@endgroup}}++%%%%%%%%%%%%%%%%%%%%%%%%%+\ps@plain+\baselineskip=11pt+\let\thepage\relax % For NO page numbers - GM Nov. 30th. 1999 and July 2000+\def\setpagenumber#1{\global\setcounter{page}{#1}}+%\pagenumbering{arabic}  % Arabic page numbers GM July 2000+\twocolumn             % Double column.+\flushbottom           % Even bottom -- alas, does not balance columns at end of document+\pagestyle{plain}++% Need Copyright Year and Copyright Data to be user definable (in .tex file).+% Gerry Nov. 30th. 1999+\newtoks\copyrtyr+\newtoks\acmcopyr+\newtoks\boilerplate+\global\acmcopyr={0-89791-88-6/97/05}  % Default+\global\copyrtyr={2001}                % Default - 12/4/2000 *** Gerry+\def\CopyrightYear#1{\global\copyrtyr{#1}}+\def\crdata#1{\global\acmcopyr{#1}}+\def\permission#1{\global\boilerplate{#1}}+%+\global\boilerplate={Permission to make digital or hard copies of all or part of this work for personal or classroom use is granted without fee provided that copies are not made or distributed for profit or commercial advantage and that copies bear this notice and the full citation on the first page.  To copy otherwise, to republish, to post on servers or to redistribute to lists, requires prior specific permission and/or a fee.}+\newtoks\copyrightetc+\global\copyrightetc{Copyright \the\copyrtyr\ ACM \the\acmcopyr\ ...\$5.00}++\toappear{\the\boilerplate\par+{\confname{\the\conf}} \the\confinfo\par \the\copyrightetc.}+%+%% End of sig-alt-full.cls -- V1.0 - 12/6/2000 --+%% Gerry Murray -- Wednesday December 6th. 2000+
+ tools/base/Modules/doc/sigplan-proc.cls view
@@ -0,0 +1,662 @@+\NeedsTeXFormat{LaTeX2e}[1995/12/01]+\ProvidesClass{sigplan-proc}+              [2002/06/21 v1.4+               Document Class]++% This file has a long and troubled history:++% The original (LaTeX 2.09) document style for this purpose was by+% Olin Shivers (1991).+% Ken Traub and Kevin Theobald added some new features in 1993.+% Back then, it was called acmconf.sty.+% Mike Sperber converted it to an LaTeX2e document class called+% acmconf.cls in 1994.+% From 1999 on, G.K.M. Tobin and Gerry Murray took Traub's style,+% and modified it extensively.  +% This version was called acm_proc_article-sp.cls, V2.01SP+% In 2002, Mike Sperber <sperber@informatik.uni-tuebingen.de>+% wrote this file, intended to be compatible with+% acm_proc_article-sp.cls V2.01SP, but with layout parameters+% matching ACM's guidelines at+% http://www.acm.org/sig_volunteer_info/conference_manual/6-5PROC.HTM+% It contains code from all previous versions, but is much shortened+% to avoid redundancies with the standard LaTeX2e styles.++% Here are the main changes to acm_proc_article-sp.cls, as far as the+% interface is concerned:++% It doesn't load any of the utility packages, specifically, it+% doesn't load epsfig, amssymb, amsmath, and amsfont.++% It depends on David Carlisle's pslatex package, found on any CTAN+% host, say at+% ftp://ftp.dante.de/tex-archive/macros/latex/contrib/supported/pslatex/++% There's once again a preprint document-class option.  (Just like in+% Olin's original style file.)  Unlike Olin's style, it has no+% influence whether the \toappear information is printed.  It only+% switches off explicitly doing \pagestyle{empty}, allowing you to+% have page numbers, for example.++% There's also a nocopyrightspace document-class option which prevents+% the reservation of space at the bottom left of the title page for+% the copyright notice.++% It conforms to LaTeX2e's NFSS2, so there aren't any silly+% font-changing commands specific to section headers, like \secit{}+% etc.++\DeclareOption{a5paper}+    {\ClassError{proc}{Option `a5paper' not supported}{}}+\DeclareOption{b5paper}+    {\ClassError{proc}{Option `b5paper' not supported}{}}+\DeclareOption{10pt}+    {\ClassError{proc}{Option `10pt' not supported}{}}+\DeclareOption{11pt}+    {\ClassError{proc}{Option `11pt' not supported}{}}+\DeclareOption{12pt}+    {\ClassError{proc}{Option `12pt' not supported}{}}+\DeclareOption{onecolumn}%+    {\ClassError{proc}{Option `onecolumn' not supported}{}}+\DeclareOption{titlepage}%+    {\ClassError{proc}{Option `titlepage' not supported}{}}+\newif\ifpreprint+\preprintfalse+\DeclareOption{preprint}{\preprinttrue}+\newif\ifnocopyrightspace+\nocopyrightspacefalse+\DeclareOption{nocopyrightspace}{\nocopyrightspacetrue}+\PassOptionsToClass{twocolumn}{article}+\DeclareOption*{\PassOptionsToClass{\CurrentOption}{article}}+\ProcessOptions+\LoadClass{article}++\def\tableofcontents{\@latexerr{\tableofcontents: Tables of contents are not+  allowed in the `sigplan-proc' document style.}\@eha}++\RequirePackage{pslatex}++% Page parameters+% ===============++\setlength{\marginparwidth}{0pt}+\setlength{\marginparsep}{11pt}+\setlength{\marginparpush}{5pt}+\setlength{\topmargin}{0pt}+\addtolength{\topmargin}{-\headsep}+\addtolength{\topmargin}{-\headheight}++\setlength{\textheight}{9in}++\setlength{\textwidth}{7in}+\setlength{\columnsep}{.33in}+\setlength{\hoffset}{0pt}+% 1 inch gets added by LaTeX+\setlength{\evensidemargin}{-0.25in}+\setlength{\oddsidemargin}{-0.25in}++% Utility macro from original Sheridan class++\newcommand{\balancecolumns}{%+  \vfill\eject+  \global\@colht=\textheight+  \global\ht\@cclv=\textheight}++\setlength{\parskip}{10pt}+\setlength{\parindent}{0pt}+\setlength{\topsep}{-0.5ex}+\setlength{\parsep}{1ex}+\setlength{\itemsep}{0pt}++\setlength{\footnotesep}{5.6pt}+\setlength{\skip\footins}{8.1pt plus 4pt minus 2pt}++% Page Style+% ==========++\ifpreprint+  \if@twoside+      \def\ps@headings{+          \def\@oddfoot{}+          \def\@evenfoot{}+          \def\@evenhead{\textnormal{\thepage}\hfil \textnormal{\textsl{\leftmark}}}+          \def\@oddhead{\hbox{}\textnormal{\textsl{\rightmark}}+                        \hfil+                        \textnormal\textrm{\thepage}}+          \def\sectionmark##1{\markboth {\uppercase{\ifnum\c@secnumdepth>\z@+                              \thesection \hskip 1em\relax \fi ##1}}{}}+          \def\subsectionmark##1+              {\markright {\ifnum \c@secnumdepth >\@ne \thesubsection+                    \hskip 1em\relax \fi ##1}}}++  \else+      \def\ps@headings{+          \def\@oddfoot{}+          \def\@evenfoot{}+          \def\@oddhead{\hbox{}\textnormal{\textsl{\rightmark}}+                        \hfil+                        \textnormal{\textrm{\thepage}}}+          \def\sectionmark##1{\markright{\uppercase{\ifnum \c@secnumdepth >\z@+                                         \thesection\hskip 1em\relax \fi ##1}}}}+  \fi++  \def\ps@myheadings{\def\@oddhead{\hbox{}\textnormal{\textsl{\rightmark}}+                                   \hfil+                                   \textnormal{\textrm{\thepage}}}%+                     \def \@evenhead{\textnormal{\textrm{\thepage}}+                                     \hfil+                                     \textnormal{\textsl{\leftmark}}\hbox{}}%+                     \def\@oddfoot{}%+                     \def\@evenfoot{}%+                     \def\sectionmark##1{}%+                     \def\subsectionmark##1{}}++\else % preprint off -- all \pagestyle commands ==> \pagestyle{empty}.+  \let\ps@plain\ps@empty+  \let\ps@headings\ps@empty+  \let\ps@myheadings\ps@empty+  \ps@empty+\fi++% Text Body+% =========++% We need to redefine those because the LaTeX versions+% set the various \*sep's to fixed values.++\def\@listi{\leftmargin\leftmargini}+\let\@listI=\@listi+\def\@listii {\leftmargin\leftmarginii+              \labelwidth\leftmarginii+              \advance\labelwidth-\labelsep}+\def\@listiii{\leftmargin\leftmarginiii+              \labelwidth\leftmarginiii+              \advance\labelwidth-\labelsep}+\def\@listiv {\leftmargin\leftmarginiv+              \labelwidth\leftmarginiv+              \advance\labelwidth-\labelsep}+\def\@listv  {\leftmargin\leftmarginv+              \labelwidth\leftmarginv+              \advance\labelwidth-\labelsep}+\def\@listvi {\leftmargin\leftmarginvi+              \labelwidth\leftmarginvi+              \advance\labelwidth-\labelsep}++% Fonts and Sizes+% ===============++\renewcommand{\normalsize}{%+  \@setfontsize\normalsize\@ixpt{10\p@}+  \abovedisplayskip 6\p@ \@plus2\p@ \@minus\p@+  \belowdisplayskip \abovedisplayskip+  \abovedisplayshortskip 6\p@ \@minus 3\p@+  \belowdisplayshortskip 6\p@ \@minus 3\p@+}++\renewcommand{\scriptsize}{\@setfontsize\scriptsize\@viipt{8\p@}}+\renewcommand{\tiny}{\@setfontsize\tiny\@vpt{6\p@}}+\renewcommand{\large}{\@setfontsize\large\@xiipt{14\p@}}+\renewcommand{\Large}{\@setfontsize\Large\@xivpt{18\p@}}+\renewcommand{\LARGE}{\@setfontsize\LARGE\@xviipt{20\p@}}+\renewcommand{\huge}{\@setfontsize\huge\@xxpt{25\p@}}+\renewcommand{\Huge}{\@setfontsize\Huge\@xxvpt{30\p@}}+\def\small{\@setsize\small{9pt}\viiipt\@viiipt+\abovedisplayskip 7.6pt plus 3pt minus 4pt%+\belowdisplayskip \abovedisplayskip+\abovedisplayshortskip \z@ plus2pt%+\belowdisplayshortskip 3.6pt plus2pt minus 2pt}++\def\footnotesize{\@setsize\footnotesize{10pt}\ixpt\@ixpt+\abovedisplayskip 6.4pt plus 2pt minus 4pt%+\belowdisplayskip \abovedisplayskip+\abovedisplayshortskip \z@ plus 1pt%+\belowdisplayshortskip 2.7pt plus 1pt minus 2pt}++% Section Headers+% ===============++\setcounter{secnumdepth}{4}++\renewcommand{\section}{\@startsection%+  {section}%+  {1}%+  {\z@}%+  {1\p@ \@plus 4\p@}%+  {0.1pt}%+  {\normalfont\fontsize{12\p@}{12\p@}\bfseries\selectfont}%+}++\renewcommand{\subsection}{\@startsection%+  {subsection}%+  {2}%+  {\z@}%+  {1\p@ \@plus 4\p@}%+  {0.1pt}%+  {\normalfont\fontsize{12\p@}{12\p@}\bfseries\selectfont}%+}++\renewcommand{\subsubsection}{\@startsection%+  {subsubsection}%+  {3}%+  {\z@}%+  {1\p@ \@plus 4\p@}%+  {0.1pt}%+  {\normalfont\fontsize{11\p@}{11\p@}\itshape\selectfont}%+}++\renewcommand{\paragraph}{\@startsection%+  {paragraph}%+  {4}%+  {\z@}%+  {1\p@ \@plus 4\p@}%+  {0.1pt}%+  {\normalfont\fontsize{11\p@}{11\p@}\itshape\selectfont}%+}++% Captions+% ========++\long\def\@makecaption#1#2{+   \setbox\@tempboxa\hbox{\textbf{#1. #2}}+   \ifdim \wd\@tempboxa >\hsize % IF longer than one line:+       \textbf{#1. #2}\par               %   THEN set as ordinary paragraph.+     \else                      %   ELSE  center.+       \hbox to\hsize{\hfil\box\@tempboxa\hfil}\par+   \fi}+++% Title Page+% ==========++\newcount\aucount+\newcount\originalaucount+\newdimen\auwidth+\auwidth=\textwidth+\newdimen\auskip+\newcount\auskipcount+\newdimen\auskip+\global\auskip=1pc+\newdimen\allauboxes+\allauboxes=\auwidth+\newtoks\addauthors+\newcount\addauflag+\global\addauflag=0 %Haven't shown additional authors yet++\newtoks\subtitletext+\gdef\subtitle#1{\subtitletext={#1}}++\gdef\additionalauthors#1{\addauthors={#1}}++\gdef\numberofauthors#1{\global\aucount=#1+  \ifnum\aucount>3\global\originalaucount=\aucount \global\aucount=3\fi+  \global\auskipcount=\aucount\global\advance\auskipcount by 1+  \global\multiply\auskipcount by 2+  \global\multiply\auskip by \auskipcount+  \global\advance\auwidth by -\auskip+  \global\divide\auwidth by \aucount}++% \and was modified to count the number of authors.  GKMT 12 Aug 1999+\def\alignauthor{%                  % \begin{tabular}+\end{tabular}%+  \begin{tabular}[t]{p{\auwidth}}\centering}%++\newcommand{\email}[1]{{\vspace{4pt}\sffamily\fontsize{12\p@}{12\p@}\selectfont #1}}++\newcommand{\affaddr}{\normalfont\sffamily\fontsize{10\p@}{10\p@}\selectfont}++\def\addauthorsection{\ifnum\originalaucount>3+    \section{Additional Authors}\the\addauthors+  \fi}++\newtoks\titleboxnotes+\newcount\titleboxnoteflag++\def\maketitle{\par+ \begingroup+   \def\thefootnote{\fnsymbol{footnote}}+   \def\@makefnmark{\hbox+       to 0pt{$^{\@thefnmark}$\hss}}+     \twocolumn[\@maketitle]+\@thanks+ \endgroup+ \setcounter{footnote}{0}+ \let\maketitle\relax+ \let\@maketitle\relax+ \gdef\@thanks{}\gdef\@author{}\gdef\@title{}\gdef\@subtitle{}\let\thanks\relax+ \ifnocopyrightspace\else\@copyrightspace\fi+ }++% make aubox hsize/number of authors up to 3, less gutter+% then showbox gutter showbox gutter showbox -- GKMT Aug 99+\newbox\@acmtitlebox+\def\@maketitle{\newpage+ \null+ \setbox\@acmtitlebox\vbox{%+\baselineskip 20pt+\vskip 2em                   % Vertical space above title.+   \begin{center}+    {\normalfont\sffamily\bfseries\fontsize{18\p@}{18\p@}\selectfont+     \@title\par}       % Title set in 18pt Helvetica (Arial) bold size.+    \vskip 1.5em                % Vertical space after title.+    {\normalfont\sffamily\fontsize{14\p@}{14\p@}\selectfont+      \the\subtitletext\par}\vskip 1.25em%\fi+    { \normalfont\sffamily\fontsize{12\p@}{12\p@}\selectfont+      \lineskip .5em             % tabular environment+      \begin{tabular}[t]{c}+        \@author+      \end{tabular}+      \par}+    \vskip 1.5em               % Vertical space after author.+   \end{center}}+ \dimen0=\ht\@acmtitlebox+ \advance\dimen0 by -12.75pc\relax % Increased space for title box -- KBT+ \unvbox\@acmtitlebox+ \ifdim\dimen0<0.0pt\relax\vskip-\dimen0\fi}++\long\def\@maketntext#1{\noindent #1}++\long\def\@maketitlenotetext#1#2{\noindent+            \hbox to 1.8em{\hss$^{#1}$}#2}++\newcount\titlenotecount+\global\titlenotecount=0+\newtoks\tntoks+\newtoks\tntokstwo+\newtoks\tntoksthree+\newtoks\tntoksfour+\newtoks\tntoksfive++\def\titlenote{\@ifnextchar[\@xtitlenote{\stepcounter\@mpfn+\global\advance\titlenotecount by 1+\ifnum\titlenotecount=1+    \raisebox{9pt}{$\ast$}+\fi+\ifnum\titlenotecount=2+    \raisebox{9pt}{$\dagger$}+\fi+\ifnum\titlenotecount=3+    \raisebox{9pt}{$\ddagger$}+\fi+\ifnum\titlenotecount=4+\raisebox{9pt}{$\S$}+\fi+\ifnum\titlenotecount=5+\raisebox{9pt}{$\P$}+\fi+         \@titlenotetext+}}++\long\def\@titlenotetext#1{\insert\footins{%+\ifnum\titlenotecount=1\global\tntoks={#1}\fi+\ifnum\titlenotecount=2\global\tntokstwo={#1}\fi+\ifnum\titlenotecount=3\global\tntoksthree={#1}\fi+\ifnum\titlenotecount=4\global\tntoksfour={#1}\fi+\ifnum\titlenotecount=5\global\tntoksfive={#1}\fi+    \reset@font\footnotesize+    \interlinepenalty\interfootnotelinepenalty+    \splittopskip\footnotesep+    \splitmaxdepth \dp\strutbox \floatingpenalty \@MM+    \hsize\columnwidth \@parboxrestore+    \protected@edef\@currentlabel{%+    }%+    \color@begingroup+   \color@endgroup}}++\renewenvironment{abstract}{+\ifnum\titlenotecount>0 % was =1+    \insert\footins{%+    \reset@font\footnotesize+        \interlinepenalty\interfootnotelinepenalty+        \splittopskip\footnotesep+        \splitmaxdepth \dp\strutbox \floatingpenalty \@MM+        \hsize\columnwidth \@parboxrestore+        \protected@edef\@currentlabel{%+        }%+        \color@begingroup+\ifnum\titlenotecount=1+      \@maketntext{%+         \raisebox{4pt}{$\ast$}\rule\z@\footnotesep\ignorespaces\the\tntoks\@finalstrut\strutbox}%+\fi+\ifnum\titlenotecount=2+      \@maketntext{%+      \raisebox{4pt}{$\ast$}\rule\z@\footnotesep\ignorespaces\the\tntoks\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\dagger$}\rule\z@\footnotesep\ignorespaces\the\tntokstwo\@finalstrut\strutbox}%+\fi+\ifnum\titlenotecount=3+      \@maketntext{%+         \raisebox{4pt}{$\ast$}\rule\z@\footnotesep\ignorespaces\the\tntoks\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\dagger$}\rule\z@\footnotesep\ignorespaces\the\tntokstwo\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\ddagger$}\rule\z@\footnotesep\ignorespaces\the\tntoksthree\@finalstrut\strutbox}%+\fi+\ifnum\titlenotecount=4+      \@maketntext{%+         \raisebox{4pt}{$\ast$}\rule\z@\footnotesep\ignorespaces\the\tntoks\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\dagger$}\rule\z@\footnotesep\ignorespaces\the\tntokstwo\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\ddagger$}\rule\z@\footnotesep\ignorespaces\the\tntoksthree\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\S$}\rule\z@\footnotesep\ignorespaces\the\tntoksfour\@finalstrut\strutbox}%+\fi+\ifnum\titlenotecount=5+      \@maketntext{%+         \raisebox{4pt}{$\ast$}\rule\z@\footnotesep\ignorespaces\the\tntoks\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\dagger$}\rule\z@\footnotesep\ignorespaces\the\tntokstwo\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\ddagger$}\rule\z@\footnotesep\ignorespaces\the\tntoksthree\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\S$}\rule\z@\footnotesep\ignorespaces\the\tntoksfour\par\@finalstrut\strutbox}%+\@maketntext{%+         \raisebox{4pt}{$\P$}\rule\z@\footnotesep\ignorespaces\the\tntoksfive\@finalstrut\strutbox}%+\fi+   \color@endgroup}+\fi+\setcounter{footnote}{0}+\section*{Abstract}\normalsize+}{}++\newcommand{\keywords}{\section*{Keywords}}++\newcommand{\terms}{\section*{General Terms}}++\newcount\catcount+\global\catcount=1++\newcommand{\category}[3]{%+  \ifnum\catcount=1+  \section*{Categories and Subject Descriptors}+  \advance\catcount by 1\else{\unskip; }\fi+  \@ifnextchar [{\@category{#1}{#2}{#3}}{\@category{#1}{#2}{#3}[]}%+}++\def\@category#1#2#3[#4]{%+    \begingroup+        \let\and\relax+            #1 [\textbf{#2}]%+            \if!#4!%+                \if!#3!\else : #3\fi+            \else+                :\space+                \if!#3!\else #3\kern\z@---\hskip\z@\fi+                \textit{#4}%+            \fi+    \endgroup+}++% Copyright space on title page+% =============================++%%% This section (written by KBT) handles the 1" box in the lower left+%%% corner of the left column of the first page by creating a picture,+%%% and inserting the predefined string at the bottom (with a negative+%%% displacement to offset the space allocated for a non-existent+%%% caption).+%%%++\newtoks\copyrightnotice+\def\ftype@copyrightbox{8}+\def\@copyrightspace{+  \@float{copyrightbox}[b]+  \begin{center}+    \setlength{\unitlength}{1in}+    \begin{picture}(3.33,1.25) % Space for copyright notice+      \put(0,0){\normalfont\fontsize{8\p@}{8\p@}\selectfont%+                {\@toappear}}+    \end{picture}+  \end{center}+  \end@float}+\def\@toappear{} % Default setting blank - commands below change this.+\long\def\toappear#1{\def\@toappear{\parbox[b]{20pc}{\baselineskip 9pt#1}}}+\def\toappearbox#1{\def\@toappear{\raisebox{5pt}{\framebox[20pc]{\parbox[b]{19pc}{#1}}}}}++\def\conferenceinfo#1#2{\gdef\@conferencename{#1}\gdef\@conferenceinfo{#2}}+\def\@conferencename{}+\def\@conferenceinfo{}++\def\CopyrightYear#1{\gdef\@CopyrightYear{#1}}+\def\@CopyrightYear{}+\def\@yourmail{}+\def\crdata#1{\gdef\@crdata{#1}}+\def\@crdata{}+\def\permission#1{\gdef\@permission{#1}}+\def\@permission{Permission to make digital or hard copies of all or+  part of this work for personal or classroom use is granted without+  fee provided that copies are not made or distributed for profit or+  commercial advantage and that copies bear this notice and the full+  citation on the first page.  To copy otherwise, to republish, to+  post on servers or to redistribute to lists, requires prior specific+  permission and/or a fee.}+\def\crdata#1{\gdef\@crdata{#1}}+\def\@crdata{}++\def\@copyrightinfo{%+  \ifx\@CopyrightYear\@empty+  \else+  Copyright \@CopyrightYear\ ACM \@crdata\ ...\$5.00+  \fi}++\toappear{\scriptsize\@permission\par+\textsl{\@conferencename} \@conferenceinfo\par\@copyrightinfo}+++% Theorems+% ========++\def\@begintheorem#1#2{%+    \trivlist+    \item[\hskip\labelsep\textsc{#1\hskip 5\p@\relax#2.}]+    \itshape\selectfont+}+\def\@opargbegintheorem#1#2#3{%+    \trivlist+    \item[%+        \hskip\labelsep+        \textsc{#1\ #2\             % This mod by Gerry to enumerate corollaries+   \setbox\@tempboxa\hbox{(#3)}  % and bracket the 'corollary title'+        \ifdim \wd\@tempboxa>\z@ % and retain the correct numbering of e.g. theorems+            \hskip 5\p@\relax    % if they occur 'around' said corollaries.+            \box\@tempboxa       % Gerry - Nov. 1999.+        \fi.}%+    ]+    \itshape\selectfont+}+\newif\if@qeded+\global\@qededfalse+\def\proof{%+    \global\@qededfalse+    \@ifnextchar[{\@xproof}{\@proof}%+}++\def\endproof{%+    \if@qeded\else\qed\fi+    \endtrivlist+}+\def\@proof{%+    \trivlist+    \item[\hskip\labelsep\textsc{Proof.}]+    \ignorespaces+}+\def\@xproof[#1]{%+    \trivlist+    \item[\hskip\labelsep\textsc{Proof #1.}]%+    \ignorespaces+}+\def\qed{%+    \unskip+    \kern 10\p@+    \begingroup+        \unitlength\p@+        \linethickness{.4\p@}%+        \framebox(6,6){}%+    \endgroup+    \global\@qededtrue+}++\def\newdef#1#2{%+    \expandafter\@ifdefinable\csname #1\endcsname+        {\@definecounter{#1}%+         \expandafter\xdef\csname the#1\endcsname{\@thmcounter{#1}}%+         \global\@namedef{#1}{\@defthm{#1}{#2}}%+         \global\@namedef{end#1}{\@endtheorem}%+    }%+}+\def\@defthm#1#2{%+    \refstepcounter{#1}%+    \@ifnextchar[{\@ydefthm{#1}{#2}}{\@xdefthm{#1}{#2}}%+}+\def\@xdefthm#1#2{%+    \@begindef{#2}{\csname the#1\endcsname}%+    \ignorespaces+}+\def\@ydefthm#1#2[#3]{%+    \trivlist+    \item[%+        \hskip\labelsep+        \itshape{#2%+         \savebox\@tempboxa{#3}%+         \ifdim \wd\@tempboxa>\z@+            \ \box\@tempboxa+         \fi.%+        }]%+    \ignorespaces+}+\def\@begindef#1#2{%+    \trivlist+    \item[\hskip\labelsep\textit{#1\ #2.}]%+}+\def\theequation{\arabic{equation}}++% Bibliography+% ============++% This is identical to the code in article.cls except for the first+% line and \section instead of \section*.++\renewenvironment{thebibliography}[1]+     {\ifnum\addauflag=0\addauthorsection\global\addauflag=1\fi+      \section{\refname+        \@mkboth{\MakeUppercase\refname}{\MakeUppercase\refname}}%+      \list{\@biblabel{\@arabic\c@enumiv}}%+           {\settowidth\labelwidth{\@biblabel{#1}}%+            \leftmargin\labelwidth+            \advance\leftmargin\labelsep+            \@openbib@code+            \usecounter{enumiv}%+            \let\p@enumiv\@empty+            \renewcommand\theenumiv{\@arabic\c@enumiv}}%+      \sloppy+      \clubpenalty4000+      \@clubpenalty \clubpenalty+      \widowpenalty4000%+      \sfcode`\.\@m}+     {\def\@noitemerr+       {\@latex@warning{Empty `thebibliography' environment}}%+      \endlist}++\endinput+%%+%% End of file `sigplan-proc.cls'.
+ tools/base/Modules/spec/Examples.txt view
@@ -0,0 +1,223 @@+Overview+========++The view taken in this description of the module system is+that a program consists of a number of modules.  Each module+provides (exports) some entities to be used by other modules.+The entities exported by a module may either be defined in the+module, or imported from another module.  ++The task of the module system is to keep track of the relations between+names and the entities they refer to.  Examples of the kinds of questions+one might expect the module system to answer are: which entity does a+name refer to, what names are in scope, what entities are exported by a module.+The module system is fairly independent of the rest of Haskell.  In fact,+it is possible to convert a program consisting of multiple modules into+a program consisting of a single module by concatenating the modules and+replacing each name in the program with a unique name identifying the entity+to which it refers.  There are a few technicalities about such a conversion+related to the defaulting mechanism of Haskell, but this is not +relevant to our discussion (REPORT REFERENCE).   ++++Entities+--------++_Entities_ are introduced in a program by declarations.  They are+the "building blocks" for other objects in a program.  Programmers+use _names_ to refer to entities.  For example, the declaration:++> f x = x + 2++introduces one entity - a function named #f#. We only consider top+level declarations as those are the ones which may be exported+for use by other modules. ++Another slightly more complicated (but nevertheless common in practice) example:++> data List a = EmptyList | List { hd :: a, tl :: List a }++There are five entities introduced by this declaration:+    * a type constructor named #List#+    * two value constructors named #Nil# and #List# respectively+    * two field selectors - #hd# and #tl#++We note that it is possible to have different entities with the same+name (e.g. the two #List# entities above).  +++There are six varieties of entities:+    * functions+    * type constructors+    * value constructors+    * field selectors+    * classes+    * class methods++One could perhaps also consider class instances to be entities as they+are also introduced by declarations, but since in Haskell 98 there is +no way to name them (and hence refer to them directly in a program)+we choose not to. The varieties of entities are not very essential as the+Haskell module system is reasonably uniform in the sense that all entities+(with one exception to be discussed later) are treated in the same way. ++Other examples of non-entities are expressions, types and patterns.+There is a subtle distinction we make between types and type constructors - +types are made out of type constructors, so even though #List# and #Int#+are entities #List Int# is not.  Furthermore we distinguish between +#Int# as a nullary type constructor and #Int# as a type (i.e. the application+of the type constructor to no arguments).++++Subordinate entities+--------------------++As the reader might have noticed there are relations between some entities.+If we look at the #List# example above, we note that the +value constructors #List# and #EmptyList#, and the filed selectors+#hd# and #tl# "belong" to the type constructor #List#.  Such entities+are called _subordinate_ entities.  Another example of subordinate entities+are the methods of a class (as they belong to the class).  The Haskell+module system provides special mechanism to control which of those +subordinate entities are to be imported/exported from a module.+++TODO: Where to put this?++A module defines a type:++| data T = A | B | C++To export the type T and just the A value constructor:+| module A ( T(A) ) where++To export the type T and all its constructors:+| module A (T(..)) where++To export just the type T:+| module A (T) where+or+| module a (T()) where++There is no way to export just a constructor without the type, while+the situation is slightly different when dealing with classes.  For+details of the semantics see the functions bellow.++++Quick tour of Haskell module system+===================================++The basic unit of a program is the _module_.  Every module has a +name used to identify the module.  This name is used when a programmer+needs to _import_ a module, i.e. specify that she will be using (some of)+the entities defined in the module.  ++To refer to entities programmers use names.  Most of the time simple names+(plain old identifiers) are sufficient, but sometimes if two entities happen+to have the same name one may use a _qualified name_ to disambiguate which +one is meant.+++Exports+-------++To reduce the number of name clashes in programs, a programmer may+restrict which entities (or rather names of entities) may be used by other+modules (i.e. are _exported_ by the module) and which are just local "helper"+entities.  This+is done with the module's export specification.  If the programmer wishes+to export just the locally defined names of a module no export specification+needs to be provided, however if a finer control over the exports of a module+is desired an explicit export specification has to be written.+It consists of an enumeration of the entities to be export, plus a few +ways to abbreviate whole groups of entities are available.  For example:++| module A where+| f = True++is a module (with a name #A#) which will just export the locally defined+entity #f#.   However:++| module A(g) where+| f = True+| g = 'a'++will only export the entity #g#, while #f# may not be named in other modules.++So far in out description we have been somewhat informal, freely mixing the+notions of _names_ and _entities_.  It is however important to be careful and+keep in mind that those are different.   Just because an entity is not exported+by a module does not mean it may not be used by other modules.  However+there will be no way for a programmer to directly name this entity.  For+example if a type constructor defined in a module is not exported,+programmers won't be able to write type signatures involving this type+constructor in other modules,  however they might still be able to create +values of types made out of the type constructor.  Similarly, +if a function uses another function in its definition, but the+second function is not in exported, in other modules programmers may use the+first function but not the second.+++Imports+-------++In the large majority of modules, programmers make use of entities+defined in other modules - either libraries or components of the project+being designed.  To achieve this, a programmer needs to first import +the entities using an _import declaration_, which specifies a module and +some entities to be imported from it.++Entities are exported with just a simple name.  When they are imported+one may typically refer to them either using the simple name or+by qualifying the name with the name of the module from which the+entity was imported (to avoid an ambiguity if there+are two entities with the same simple name, or for readability purposes).+For example suppose module #A# exports an entity with a name #f#, then++| import A+|+| p = f       -- use the unqualified name+| q = A.f     -- use the qualified name++Sometimes however, it is more convenient to qualify the entity names+not using the module name, but rather some other name.  To achieve+this one may use the #as# clause of an import declaration. For example:++| import A_Module_With_A_Long_Name as M+| +| p = f                               -- use the unqualified name+| q = M.f                             -- use the qualified name+| +| -- r = A_Module_With_A_Long_Name.f     error++Another use of the #as# clause is to "combine" imports.  For example+if module #A# exports #f#, and module #B# exports #g#, then:++| import A as M+| import B as M+| +| p = f               --  use unqualified name+| q = g               --  use unqualified name+| r = M.f             --  use qualified name+| s = M.g             --  use qualified name +| -- t = A.f              error+| -- u = B.f              error++Finally in some situations it is more convenient not to have unqualified+names at all, i.e. a programmer might want to ensure that she always +refers to entities using the qualified names.  This is achieved using+the #qualified# clause in an import.  If module #A# exports #f#:++| import qualified A+| +| -- p = f               error, the unqualified name is not available+| q = A.f             -- use the qualified names++One may also combine those clauses.   TODO...++++
+ tools/base/Modules/spec/Modules.lhs view
@@ -0,0 +1,497 @@+> module Modules where++> import List (partition, nub)+> import Maybe (fromJust)++> -- implementation only+> import QualNames++++Module system parameters+========================++The module system is parametrized on four type parameters:++    * The type of identifiers used in the source code of a program (#qn#).+      Those may be qualified or unqualified names.+    +    * The type of module names and name qualifiers (#m#).+      These are used to name modules, in import declarations, export lists,+      and qualified names.++    * The type of simple names (#n#).  Those are used+      to name entities in definitions or when exported.++    * The type of entities (#ent#).  These are the objects referred to by +      identifiers in the program and are introduced by declarations +      (functions, type constructors, value constructors, field selectors,+      classes, class methods).+++The parameters are not completely arbitrary, in fact there is a close relation+between the first three.  To capture this, we use the class #QualNames#:++| class QualNames qn m n | qn -> m n, m n -> qn where+|   -- observers+|   isQual          :: qn -> Bool+|   getQualifier    :: qn -> m+|   getQualified    :: qn -> n+| +|   -- constructors+|   mkUnqual        :: n -> qn +|   mkQual          :: m -> n -> qn ++In order for the types to be suited for the purposes of the module system,+we require that they be related by the #QualNames# class.+This essentially forces #i# to be a type similar to the following:++| data Name m n = Unqualified n | Qualified m n+++We also require that there be a special element in #m#, which we shall+call "Main", and a special element in #qn# which shall be denoted as "main".+++For the type of entities, we require that there is a way to identify value+constructors,  and that we know the the ownership relation between+entities (e.g. a type constructor may "own" a number of value constructors).+Formally this is captured by the requirement that the type #ent#+be an instance of the following class:++| class Entity ent where+|   isCon   :: ent -> Bool+|   owns    :: ent -> [ent]+++Finally, all four types should be in the #Eq# class, i.e. values of the+appropriate types should be comparable for equality. ++++The abstract syntax+===================+++A Haskell module consists of a name, an export specification, a number+of import declarations and a number of local declarations.  This +suggests the following data structure:++> data Mod qn m n ent = Mod+>     { modName       :: m+>     , modExport     :: Maybe [ExpListEntry qn m]+>     , modImports    :: [Import m n]+>     , modDefines    :: Rel n ent+>     }                                                 ++In the concrete syntax of Haskell, it is valid to just have the module body+(imports and declarations).  This is considered to be an abbreviation for +a module with name "Main" (i.e. the special element of the #m# type),+and export specification exporting a single entity named "main"+(the special element of the #qn# type).  (sect 5.1. of report)++It is also valid to omit just the export specification (sect 5.2 of report),+but this is not considered to be an abbreviation.  Instead it is a special+kind of specification, one saying that only (and all) locally defined+entities are to be exported.  ++> data ExpListEntry qn m    = Ent (EntSpec qn) | ModuleExp m++In an export list a programmer may write two kinds of things - either+the name of an entity with (perhaps) some subordinate names (here modeled+by an #EntSpec#), or the so called "module" export, which in concrete+Haskell syntax is written as #module M# (where #M# is a module alias).++An #EntSpec# consists of the name of an entity, with possibly the+names of some subordinate names.  An explicit list of subordinate names+is modeled with the #Some# component of the #SubSpec# data type,+while a request for all available subordinate names (the #(..)# notation+of Haskell) is modeled using #All#.++> data EntSpec j          = EntSpec j (Maybe (SubSpec j)) deriving Eq+> data SubSpec j          = All | Some [j]                deriving Eq++The #EntSpec# type is in fact shared between export lists and import+declarations, as they are structurally the same.  The only difference +between the two is the types used to name entities (i.e. the #j# parameter+above).  In the case of an export list we use #qn# (the type of program+identifiers - qualified or not), while in the case of import declarations+we use #n# (the type of simple names).++We note that our abstract syntax is slightly more permissive than Haskell's+as one may add subordinate names to any name, while in Haskell+it is syntactically invalid to add subordinate names to lower case+identifiers.  ++This brings us to the data structure used to model import declarations:++> data Import m n     = Import+>     { impQualified  :: Bool+>     , impFrom       :: m +>     , impAs         :: m+>     , impSpec       :: (ImpMethod, [EntSpec n])+>     }                  +>+> data ImpMethod = Importing | Hiding++An import may be qualified (or not), contains the name of the module from which +entities are to be imported, an alias to be used in qualified names for entities+which came through this import, and finally a specification of which entities +are to be imported.  In concrete Haskell terms, the only required field is+the name of the source module, but the omissions of any of the other fields+are considered to be abbreviations as follows:++    * The value of #impQualified# is #False# unless the #qualified#+    keyword was present in the source code, in which case it is #True#.++    * If the #as# clause of a module is omitted, this field gets the same+    value as the #impFrom# field, i.e. the name of the source module+    is used to qualify names.++    * If the import specification is omitted, it is assumed to be+    #(Hiding, [])# (or #hide ()# in Haskell syntax), essentially saying that+    all entities are to be imported.+    +++Semantics+=========++The abstract syntax above was nicely structured in the sense that bigger +pieces were made out of smaller ones.  It would be nice to be able to+give meanings of the bigger pieces in terms of the meanings of the smaller+ones and this is the approach we take.  Each piece of the abstract syntax+is modeled as a relation transformer, i.e. given a relation it+produces a new relation. To put the whole idea in perspective+we first need a brief digression to relations.+++Relations+---------++We use relations to model the association between names and entities.+This seems like a natural choice as in a single framework we may+represent undefined names (i.e. names which refer to no entities),+ambiguous names (names referring to more than one entity) and proper+names (referring to exactly one entity).  It is not enough to restrict+ourselves to just using proper names, as there are valid Haskell+programs containing ambiguous names in scope (report section 5.5.2),+of course there is the requirement that such names are not used.+Furthermore, one may use the information provided by the relation to+generate useful error messages.  We model relations as lists of pairs:++> type Rel a b = [(a,b)]++The exports of a module are modeled by a relation between simple names+and entities (i.e. #Rel n ent#), while the names in scope of a module+are modeled as a relation between identifiers and entities (i.e. #Rel qn ent#).+Ultimately our goal is for each module to come up with two relations:++    * the "export" relation of type #Rel n ent#+    * the "in scope" relation of type #Rel qn ent#+++Functions used to compute both "exports" and "in scope" relations+-----------------------------------------------------------------++From the structure of a module we know what entities it defines.  Now+we need to consider how may a programmer refer to those entities+(i.e. what is the relation between names and entities defined in a module).+This is specified by the #locals# function, which computes a part+of the "in scope" relation of a module.  When an entity is defined in+a module one may refer to it by either using its simple name +or by qualifying it with the name of the module +(report section 5.5.1).  Formally this is:++| locals :: ...+|   => Mod qn m n ent +|   -> Rel qn ent++> locals mod = [ (mkUnqual n, e) | (n,e) <- defEnts ]+>           ++ [ (mkQual m n, e) | (n,e) <- defEnts ]+>   where+>   m       = modName mod+>   defEnts = modDefines mod++This function is also used to give semantics to modules without an+export specifications.+++As we saw above, there is a certain commonality between the structure of+export lists and import declarations, in the sense that they both made+use of the #EntSpec# data type.  It is nice that we (nearly) have this+commonality at the semantic level as well.  When occurring in an export+list and a non-hiding import declaration, #EntSpec#s have essentially the same+meaning.  A difference occurs in the #hiding# case of an import declaration,+in which case it was decided that ambiguities are not important and +the semantics is slightly more permissive.++The design choice made in Haskell was that the exports of a module should+be unambiguous in the sense that all exported entities have distinct+(simple) names.  The one exception to this rule is that a type and+a data constructor may have the same name.  The reason for this is+practical - although two different entities have the same name, one+may determine from the context which entity is meant, so the ambiguity+is not crucial (as types and data constructors are never interchangeable).+The only situation in which one may not distinguish between such+entities from the context is in an export lists and import declarations.+So in Haskell a different disambiguating mechanism is used in such cases -+the only way to export (or import) a value constructor is as a subordinate +name.  Unfortunately this is not the case in #hiding# imports, where+if a name refers to more than one entity, all of them are hidden (i.e.+not imported).++To model this asymmetry in Haskell, we add+an additional parameter to the meaning function of #EntSpec#s, namely a+predicate over entities.  As we shall see later this predicate would+either be #not . isCon# (i.e. ignore constructors), or #const True#+for the #hiding# imports case, where everything is treated in the same way.++| mEntSpec :: ...+|   => (ent -> Bool) -> EntSpec j+|   -> Rel j ent -> Rel j ent+ +> mEntSpec p (EntSpec x spec) r = xents ++ xsubs+>   where+>   xents       = [ (y,e) | (y,e) <- r, y == x, p e ]+>+>   xsubs = case spec of +>       Nothing         -> []+>       Just All        -> allxsubs+>       Just (Some xs)  -> [ (y,e) | (y,e) <- allxsubs, y `elem` xs ]+>+>   allxsubs    = [ (y,e) | (_,xe) <- xents, s <- owns xe, (y,e) <- r, e == s ]++It is not important if the relation passed as a parameter to #mEntSpec# is+an "export" or an "in scope" one.  The idea is that we take all entities+which may be named #x# (#xents#), and then we add+all subordinate entities belonging to entities in #xent# and+satisfy #spec# (#xsubs#).+If there was no specification, then we add no entities,+if the #(..)# specification was used, then we add all the subordinate entities+in scope (#allxsubs#) and finally if an explicit list of entities was provided+we only consider elements of #allxsubs# which conform to the specification.++++Export relations+----------------++To compute the exported entities of a module, we need to know what is the +relation between names and entities in scope of the module (#inscp#).++| exports :: ...+|   => Mod qn m n ent+|   -> Rel qn ent -> Rel n ent++> exports m inscp = [ (getQualified qn, e) | (qn,e) <- exps ]+>   where+>   exps = case modExport m of+>     Nothing   -> locals m+>     Just es   -> concat [ mExpListEntry e inscp | e <- es ]++If the programmer omitted the export specification, we just export the +locally defined entities using the #locals# function.+Alternatively if an explicit export list was present,  we take+the union of the meanings of all entries in the list.+Finally to obtain an "export" relation, we remove all qualifiers.+Note that after removing the qualifiers (or even before that)+we might end up with a relation containing ambiguous names.+This is not valid in Haskell (except for the special case mentioned in+the previous section), but we choose to handle this and all other error+related issues at a later stage.++There are two different kinds of entries which may occur in an export list are:++    * export entity by qualifier (the so called "module" export).  The+    meaning of such an export specification is described in the report +    as follows (report 5.2 - item 5 in list):++The form "module M" abbreviates the set of all entities whose unqualified name, e, is in scope, and for which the qualified name M.e is also in scope and refers to the same entity as e.++    * export entity by name, i.e. when the programmer uses the name of an+    entity in the export list with perhaps some subordinate names.  We already+    have a function to handle such situations - #mEntSpec#.  Since a data+    constructors may not be exported on its own (report 5.2 - item 2 in list)+    we pass #not . isCon# as the additional parameter to #mEntSpec#.++| mExpListEntry :: ...+|   => ExpListEntry qn m   +|   -> Rel qn ent -> Rel qn ent++> mExpListEntry (ModuleExp m) inscp =+>               [ (x,ent) | (x,ent) <- unqs, (qual m x,ent) `elem` qs ]+>   where+>   (qs,unqs) = partition (isQual . fst) inscp+>+> mExpListEntry (Ent ispec) inscp = mEntSpec (not . isCon) ispec inscp++ +In scope relations+------------------++To compute what names are in scope within a module, we need to know the+exports of all imported modules.  The parameter #expsOf# is a function+mapping module names to their exports.  +Simply put, the entities in scope of a module are all locally+defined entities and the union of all entities imported through an import+declaration:++| inscope :: ...+|   => Module qn m n ent+|   -> (m -> Rel n ent) -> Rel qn ent +  +> inscope m expsOf = imports ++ locals m +>   where+>   imports = concat [ mImp imp (expsOf (impFrom imp)) | imp <- modImports m ]+++The meaning of an import declaration is a relation transformer, which +changes "export" relations to "in scope" ones:++| mImp :: ...+|   => Import m n+|   -> Rel n ent -> Rel qn ent+ +> mImp imp exps +>   | impQualified imp  = qs+>   | otherwise         = unqs ++ qs+>   where+>   m           = impAs imp+>   qs          = [ (mkQual m n, e) | (n,e) <- incoming ]+>   unqs        = [ (mkUnqual n, e) | (n,e) <- incoming ]+>   incoming    = mImpSpec (impSpec imp) exps++We use the semantic function for import specifications to compute what entities+come in scope (#incoming#), and then we adjust their names appropriately.+In the case of a #qualified# import, we only consider qualified names (#qs#),+otherwise we also add unqualified names (#unqs#).+++The meaning of import specifications is computed by #mImpSpec#, which is+essentially a "front end" to the #mEntSpec# function.+We have two cases to consider - "importing" and #hiding# specifications.+In the first case we take the union of the relations corresponding to +the entity specifications.  We ignore data constructors, as those may+only be imported as subordinate names (#not . isCon#).+For #hiding# specifications we essentially take the complement of+the non-hiding case, except now we do not ignore data constructors.++| mImpSpec :: ...+|   => ImpSpec m n +|   -> Rel n ent -> Rel n ent+ +> mImpSpec (method, specs) exps = case method of+>   Importing   -> ents (not . isCon)+>   Hiding      -> [ exp | exp <- exps, exp `notElem` ents (const True) ]+>   where+>   ents p = [ x | spec <- specs, x <- mEntSpec p spec exps ]++++Iteration+---------++The reader might have noticed that to compute the exports of a module we+need to know what is in scope, and to compute what is in scope we need+to know certain exports.  If we allow for mutually recursive modules, our+equations become mutually recursive and care needs to be taken when+solving them.  The idea is that the "export" and "in scope" relations for a+group of mutually recursive modules are computed at the same time (as they all+depend on each other).  In fact one could process _all_ modules in a +program together, which is less efficient from an implementation point+of view, but simplifies this presentation as we need not supply the code+for computing groups of mutually recursive modules and dependencies between+those (a standard graph algorithm, followed by a topological sort).++To represent the "in scope" and "exports" relations of a group of modules+we use lists.  Since relations may in general be ordered by inclusion,+we may also order lists (of equal length) of relations as follows:++> (<<=) :: (Eq a, Eq b) => [Rel a b] -> [Rel a b] -> Bool+> xss <<= yss = and (zipWith subEq xss yss)+>   where+>   xs `subEq` ys   = all (`elem` ys) xs ++Note that this order is different from the one usually used in Haskell and+is only well defined on finite lists.  Since Haskell programs only have+finitely many modules this is not a problem.  In fact the lists we deal+with all have the same length, namely the number of modules in the program,+so one could think of them as tuples of relations.++We not only have an ordering structure on the lists of relations, we also+have a lattice structure which is directly inherited from the lattice structure+on the relations (operations defined element-wise as in the ordering above).+The lattice we deal with is finite, as each module may only define finitely+many entities and each entity may only have finitely many names.+Names get associated with entities in two ways:++    * by local declaration, in which case an entity receives two names+    (qualified and unqualified)++    * by import declaration, in which case an entity receives either one or+    two names.++Since there are only finitely many local and import declarations,+an entity may only have finitely many names. +++| computeInsOuts :: ...         +|   => [Mod qn m n ent]       +|   -> [(Rel qn ent, Rel n ent)]++> computeInsOuts otherExps mods = inscps `zip` exps+>   where+>   inscps          = nub `map` computeIs exps +>   exps            = lfpAfter nextExps (repeat [])+>+>   nextExps        = computeEs . computeIs +>+>   computeEs is    = zipWith (\m -> nub . exports m) mods is+>   computeIs es    = (\m -> inscope m (toFun es)) `map` mods+> +>   toFun es m = maybe (otherExps m) (es !!) $ lookup m mod_ixs+>   -- toFun es m = let Just pos = lookup m mod_ixs in es !! pos+>   mod_ixs     = (modName `map` mods) `zip` [0 .. ] ++> lfpAfter :: Eq a => (a -> a) -> (a -> a) +> lfpAfter f x = let fx = f x in if fx == x then x else lfpAfter f fx++The semantic functions #exports# and #inscope# deal with only one module+at a time, but it is easy to generalize them to work on multiple modules.+Given a list of modules and a list of "in scope" relations we may +apply #exports# in "parallel" to compute a list of "export" relations+(#computeEs#).++If we are given a list of "export" relations, we may convert it to+a function associating each module with its exports (#toFun#). This+is achieved with the aid of the association list #mod_ixs#, which +relates modules to their positions in the list (tuple) of modules.+Now that we have a function relating modules to their exports,+we may apply #inscope# to compute the "in scope" relations of the modules+(#computeIs#).++We observe that both #exports# and #inscope# are monotonic with respect to the+relation ordering.  This follows essentially from the monotonicity of+ #mEntSpec# and the definition of "module exports" (the first case+of #mExpListEntry#).  But then #computeEs# and #computeIs# are also monotonic+when lists are ordered as described above, and hence their composition+is monotonic.  Since we work in a finite lattice this is enough to conclude+that the function #nextExps# has a least fixed point.++We may than define the exports of the argument list of modules as the least+fixed point of #nextExps#.  Intuitively, given a list of "export" relations+ #nextExps# will compute what should be in scope in each module, and then based+on that compute a better approximation of what should be exported.+Similarly, the "inscope" relations of the modules may be defined as the+least fixed point of #computeIs . computeEs#, but using the well known+fact $fix (f . g) = f (fix (g . f))$ we obtain the alternative definition+used above.++++++++
+ tools/base/Modules/tests/1/A.hs view
@@ -0,0 +1,5 @@+module A (B.f) where++import A as B++f = f
+ tools/base/Modules/tests/2/A.hs view
@@ -0,0 +1,6 @@+module A (B.f) where++import A as B+import B++f = f
+ tools/base/Modules/tests/2/B.hs view
@@ -0,0 +1,3 @@+module B where ++f = f
+ tools/base/Modules/tests/3/A.hs view
@@ -0,0 +1,4 @@+module A (module B) where++import qualified B+import C
+ tools/base/Modules/tests/3/B.hs view
@@ -0,0 +1,2 @@+module B(f) where+import C
+ tools/base/Modules/tests/3/C.hs view
@@ -0,0 +1,3 @@+module C where++f = f
+ tools/base/Modules/tests/4/A.hs view
@@ -0,0 +1,3 @@+module A (T(..))  where++data T = T
+ tools/base/Modules/tests/4/B.hs view
@@ -0,0 +1,5 @@+module B where ++import A(T)++g = T
+ tools/base/Modules/tests/5/A.hs view
@@ -0,0 +1,7 @@+module A (A.f) where+import B as A++class C where+    f :: a -> a++
+ tools/base/Modules/tests/5/B.hs view
@@ -0,0 +1,2 @@+module B (f) where+f = f
+ tools/base/Modules/tests/6/A.hs view
@@ -0,0 +1,3 @@+module A (module A) where++f = f
+ tools/base/Modules/tests/8/A.hs view
@@ -0,0 +1,2 @@+module A where+import B
+ tools/base/ParseHaskellProgram.hs view
@@ -0,0 +1,26 @@+module ParseHaskellProgram where+import ParseProgram(parseProgram)+import HsParser(parse)+import DefinedNamesBase() -- instances+import ReAssocBase()      -- instances+import ParsedSyntax(HsModuleR,ModuleName,Id,HsName)+import WorkModule(WorkModuleI)++{-++This is a function to parse a plain Haskell program. Given a list of files+containing the modules of a Haskell program, it returns a list of strongly+connected components of modules, and an association list giving information+for each module what is in scope and what is exported.+-}+parseHaskellProgram:: +    [FilePath] -> IO ([[HsModuleR]], [(ModuleName, WorkModuleI HsName Id)])+parseHaskellProgram = parseProgram parse++{-++The function is constructed from the reusable function parseProgram,+which takes a module parser as an argument. This allows it to be used+for variants of Haskell, e.g. where there are new forms of+declarations or expressions. For this to work, there must be instances+in some classes for the type of declarations.  See the module+ParseProgram for details.+-}
+ tools/base/ParseOld.hs view
@@ -0,0 +1,280 @@+-- $Id: ParseOld.hs,v 1.4 2001/11/09 00:47:50 hallgren Exp $++-- Currently a test harness for the lexer/parser/pretty printer.++--ToDo: Are initial values for SrcLoc/current column correct?++import IO+import Monad+import Lexer+import ParseMonad+import HsParser+import ParseUtil+import Syntax+import PrettyPrint+import System+import GetOpt+import IOExts+import List+--import Rewrite(rewriteModule)+--import HsAssoc(initEnv, OperatorEnv)+import HsAssocInitEnv+++data Flag = LexOnlyLength          -- print number of tokens only+          | LexOnlyRev             -- print tokens in reverse order+          | LexOnly                -- print tokens+          | ParseLength            -- print number of declarations only+          | ParseInternal          -- print abstract syntax in internal format+          | ParsePretty PPLayout   -- pretty print in this style+--        | TestStatic             -- test static checker+--        | TestTypeCheck+--        | ShowNames+          | Help                   -- give short usage info+--        | BindingGroupTest+++usage = "usage: hsparser [option] [filename]"++options =+   [ Option ['n']  ["numtokens"] (NoArg LexOnlyLength)+         "print number of tokens only",+     Option ['r']  ["revtokens"] (NoArg LexOnlyRev)+         "print tokens in reverse order",+     Option ['t']  ["tokens"]    (NoArg LexOnly)+         "print tokens",+     Option ['d']  ["numdecls"]  (NoArg ParseLength)+         "print number of declarations only",+     Option ['a']  ["abstract"]  (NoArg ParseInternal)+         "print abstract syntax in internal format",+     Option ['p']  ["pretty"]    (OptArg style "STYLE")+         "pretty print in STYLE[(o)ffside|(s)emicolon|(u)trecht|(i)nline|\+          \(n)one] (default = offside)",+     Option ['h','?'] ["help"]   (NoArg Help)+         "display this help and exit"+--   Option ['s'] ["static"]     (NoArg TestStatic) +--       "run stattic checker",+--   Option ['c'] ["typecheck"]  (NoArg TestTypeCheck)+--       "run typechecker",+--   Option ['m'] ["names"]      (NoArg ShowNames)+--       "show all defined names"+--   Option ['b'] ["groups"]     (NoArg BindingGroupTest)+--       "show binding groups"+   ]++style :: Maybe String -> Flag+style Nothing  = ParsePretty PPOffsideRule+style (Just s) = ParsePretty $+         case s of+         "o"         -> PPOffsideRule+         "offside"   -> PPOffsideRule+         "s"         -> PPSemiColon+         "semicolon" -> PPSemiColon+         "u"         -> PPUtrecht+         "utrecht"   -> PPUtrecht+         "i"         -> PPInLine+         "inline"    -> PPInLine+         "n"         -> PPNoLayout+         "none"      -> PPNoLayout+         _           -> PPOffsideRule++main :: IO ()+main = do cmdline <- getArgs+          mainHugs cmdline++mainHugs :: [String] -> IO ()+mainHugs cmdline =+   case getOpt Permute options cmdline of+      (flags, args, [])    ->+       do (file, inp) <- case args of+             []  -> do inp <- getContents+                       return ("stdio", inp)+             [f] -> do inp <- readFile f+                       return (f, inp)+             _   -> error usage+          putStrLn (handleFlag (getFlag flags) file inp)+      (    _,   _, errors) ->+        error (concat errors ++ usageInfo usage options)++getFlag :: [Flag] -> Flag+getFlag []  = ParsePretty PPOffsideRule+getFlag [f] = f+getFlag _   = error usage++handleFlag :: Flag -> FilePath -> String -> String+handleFlag LexOnlyLength    f = show . numToks . testLexerRev f+handleFlag LexOnlyRev       f = show . testLexerRev f+handleFlag LexOnly          f = show . testLexer f+--handleFlag ShowNames        f = show . getAllNames . testParser f+handleFlag ParseLength      f = show . allLengths . testParser f+   where allLengths (HsModule _ _ imp ds) = length imp + length ds+handleFlag ParseInternal    f = show . testParser f+{-+handleFlag TestStatic       f = \s -> +    unsafePerformIO $ +    do { r <- testStatic $ testParser f s ;+         return "Done static checking." }+handleFlag TestTypeCheck    f = \s -> +    unsafePerformIO $ +    do  { let { m = testParser f s } ;+          r <- testStatic m ;+          print $ (typeCheckDecls . (\ (HsModule _ _ _ _ ds) -> ds)) m;+          return "Done static checking." }+-}+handleFlag (ParsePretty lo) f+    = renderWithMode mode . ppi . testParser f+      where mode = defaultMode { layoutType = lo }+{-+handleFlag BindingGroupTest f = \s -> +          unsafePerformIO (return groups >>= \s ->  return " Done b.g. ")+-}++handleFlag Help   f+    = const $+      usageInfo+          ("A simple test program for *The Haskell Parser*" ++ usage)+          options+++numToks :: ParseResult [Token] -> Int+numToks (Ok _ toks)  = length toks+numToks (Failed err) = error ("Huh? " ++ err)++testLexerRev :: FilePath -> String -> ParseResult [Token]+testLexerRev f s =+    (unPM $ loop []) s (SrcLoc f 1 0) 1 []+    where loop toks =+           lexer (\t -> case t of +                           EOF -> returnPM toks+                           _   -> loop (t:toks))++testLexer :: FilePath -> String -> ParseResult [Token]+testLexer f s = (unPM $ loop []) s  (SrcLoc f 1 0) 1 []+  where loop toks =+         lexer (\t -> case t of +              EOF -> returnPM (reverse toks) -- space leak?+              _   -> loop (t:toks))++testParser :: FilePath -> String -> HsModuleR+testParser f s =+    case parseFile parse f s of+      Right mod -> {-rewriteModule initEnv-} mod+      Left err -> error err++start s = liftM (testParser s) (readFile s)++{-+start s = do contents <- readFile s+             return $ testParser s contents+-}++look s = unsafePerformIO $ start s+{-+myTestTypeCheck f s =+    do { let { m = testParser f s } ;+     r <- testStatic m ;+         return $ (typeCheckDs . (\ (HsModule _ _ _ _ ds) -> ds)) m+       } ++++t22 x =+    unsafePerformIO $+    do { putStrLn "\nEnter Haskell declarations.  Terminate with :q \+          \on a single line\n" ;+     ls <- getLines [] ;+     myTestTypeCheck "Stdio" ls+       }++t34 x = +    unsafePerformIO $ +    do { putStrLn "\nEnter Haskell declarations.  Terminate with :q \+          \on a single line\n"+       ; text <- getLines []+       ; z @ (v, text, _) <- myTestTypeCheck "Stdio" text+       ; putStrLn "\n\n OUTPUT: \n"+       ; putStrLn text+       ; return v+       }++testFreeV = +    unsafePerformIO $+    do { putStrLn "\nEnter Haskell declarations.  Terminate with :q \+          \on a single line\n"+       ; text <- getLines []+       ; let HsModule _ _ _ _ ds = testParser "Stdio" text+       ; let (a, b, c) = tfv (SS.freeD ds, map (\x -> SS.freeD [x]) ds)+       ; print ( (map zap  a), map zap b)+       }++tfv ((f1, f2), ds) = (f1 [], f2 [], map (\ (f1, f2) -> (f1 [], f2 [])) ds)++zap (UnQual x) = x+-}+{-+go () = +     let (a,b,c) = tfv(testFreeV ())+         h (x,y) = (map zap x, map zap y)+     in (map zap a, map zap b, map h c)+++getLines c = +    do { l <- getLine+       ; if l == ":q" +           then return c+           else getLines (c ++ "\n" ++ l)+       }++z = testGeneral "test2.hs" SCC.tim++testGeneral fname f  = +    do { text <- readFile fname+       ; let HsModule _ _ _ _ ds = testParser fname text+       ; return $ f ds +       }+          +w = do { testGeneral "test3.hs" test+       ; testGeneral "test3.hs" performTC+       } >>= id++dfree = (testGeneral "test3.hs" (\ ds -> SS.makeSCC ds [])) >>= print++d2 = (testGeneral "test3.hs" (map (\ d -> ff [] d []))) >>= print+-}+{- testD doesn't appear in Scope2 (imported qualified as S2) ...+d3 =  (testGeneral "test3.hs" (map (\ d -> S2.testD [d]))) >>= print++d4 =  (testGeneral "test3.hs" S2.testD) >>= print+-}++{-+HsModule _ _ _ _ ds = unsafePerformIO (start "test3.hs")+++Dec(HsDataDecl _ cs1 tp1 t1 _) = ds !! 0+Dec(HsDataDecl _ cs2 tp2 t2 _) = ds !! 1+Dec(HsTypeDecl _ tp3 t3) = ds !! 2+++fr xs y = let (bound,freef1) = SS.scopPatList [] (map SS.freeTP xs)+       in (bound ,SS.freeT y bound)+++groups fname = +    do { (bg,cyclic) <- testGeneral fname SCC.bindingGroups+       ; mapM_ (\ x -> do { putStrLn (pp x)+              ; putStrLn "-----------------"+              })+           bg+       }++-----------------------------------------------------------------+-- testing the free variable analysis++HsModule _ _ _ _ freeds = unsafePerformIO (start "tests/freeVartests.hs")++test1 d = testD [d]+freetest _ = map test1 freeds++d5 = freeds !! 4+-}
+ tools/base/ParseProgram.hs view
@@ -0,0 +1,50 @@+module ParseProgram where++import HsModule+import HsConstants(prelude_mod)+import SrcLoc(loc0)+--import HsName+import NamesEntities+import ParseMonad(parseFile)+import Unlit(readHaskellFile)+import ParserOptions++import WorkModule(analyzeModules,WorkModuleI(..))+import PPModules+import TypedIds(NameSpace(..),IdTy(..),namespace)++import ReAssoc(getInfixes)+import ReAssocModule+--import ReAssocBaseStruct -- instance for HsModule++import MUtils((@@),( # ), mapFst)+import Lift++-- Parse a program, analyze module dependencies and adjust infix+-- applications in accordance with operator precedences:+-- parseProgram :: ... => PM (HsModule ds) -> [FilePath] ->+--                        ([[HsModule ds]],[(Module,WorkModule)])+parseProgram files = parseProgram' flags0 files+parseProgram' flags parseMod files =+  rewriteProgram # analyzeFiles' flags parseMod files++analyzeFiles parseMod = analyzeFiles' flags0 parseMod+analyzeFiles' flags parseMod =+  lift . analyzeModules'' (prel flags) @@ parseSourceFiles (cpp flags) parseMod++analyzeModules' x = analyzeModules'' True x+analyzeModules'' prel x = analyzeModules . map (optAddPrelude prel)  $x++parseSourceFiles cpp parseMod = mapM (parseSourceFile cpp parseMod)++parseSourceFile cpp parseMod path =+    parseFile parseMod path =<< readHaskellFile cpp path++rewriteProgram (modss,wms) =+    ((map.map) reAssocMod modss,wms)+  where+    origOps = (concatMap.map) infixDecls modss+    infixDecls mod = (hsModName mod,mapFst getQualified (getInfixes mod))++    reAssocMod mod = reAssocModule wm origOps mod+       where Just wm = lookup (hsModName mod) wms
+ tools/base/README.html view
@@ -0,0 +1,102 @@+<title>Extensible Haskell front-end for the Programatica project -+        directory base</title>++<h1>Extensible Haskell front-end for the Programatica project</h1>++<h2>What is in this directory (base)</h2>++<p>+This directory contains the code that deals with the base language, i.e.,+more or less Haskell 98. It is structured to allow most of the code to+be reused without changes in extended versions of the language.++<!--+<h3>Test applications to run</h3>++Things are still rather transient, but here is what's available at the moment.++<dl>+<dt><code>tstModules</code> <var>options</var> <var>command</var> <var>modules</var>+<dd>Various tests of the front-end code, including production of cross+    reference info used by <code>hs2html</code>.+    Depending on the <var>command</var>, output+    appears on stdout or in files in the subdirectory <code>hi</code>.+<dt><code>tstTI</code> <var>options</var> <var>modules</var>+<dd>Tests the type checker. Pretty-prints a decorated syntax tree on stdout.+</dl>++More detailed descriptions are available on request.+<p>+There are also some additional, obsolete test programs.+-->++<h3>Obsolete subdirectories</h3>++<p>+<code>parse</code>, <code>SA</code>, <code>TC</code>++<h3>Active subdirectories</h3>++<dl>+<dt><a href="AST/"><code>AST</code></a>+<dd>nonrecursive data structures for the abstract syntax+    (reusable in extensions),++<dt><code>syntax</code>+<dd>knot-tying recursive definitions for the base language+    (not reusable in extensions),++<dt><a href="parse2/"><code>parse2</code></a>+<dd>Happy parser (not reusable), lexer, lexer generator.+    The lexer is described in+    <a href="http://www.cse.ogi.edu/~hallgren/Talks/LHiH/">A Lexer for+     Haskell in Haskell</a>.+<dt><a href="Modules/"><code>Modules</code></a>+<dd>implementation of Haskell's module system, as described in the+    paper <a href="/~diatchki/hsmod/"><cite>A Formal Specification for the+    Haskell&nbsp;98 Module System</cite></a>,++<dt><a href="defs/"><code>defs</code></a>+<dd>defined names, free names, mapping over names, scoping information,+    infix operator reassociation+    (both reusable parts and knot-tying parts for the base language),++<dt><a href="TI/"><code>TI</code></a>+<dd>type checker (both reusable parts and knot-tying parts for the base language),++<dt><code>pretty</code>+<dd>library of pretty printing combinators,++<dt><a href="lib/"><code>lib</code></a>+<dd>general library modules (does not depend on anything else here),++<dt><a href="transforms/"><code>transforms</code></a>+<dd>Source level transformations (e.g., pattern match simplification).+    Generation of code for derived instances.++<dt><code>tests</code>+<dd>test input,+<dt><a href="tests/HaskellLibraries"><code>tests/HaskellLibraries</code></a>+<dd>Haskell 98 Prelude and Standard Libraries, with some minor changes to+    make them go through our type checker. (This is now an important part+    of our tools and doesn't belong in the test subdirectory anymore!)++</dl>+<!--+<h3>A test run</h3>++When you have compiled <code>tstTI</code>, you can try+<pre>+  cd tests/HaskellLibraries+  ../../tstTI . +RTS -K5M+</pre>++This will type check the Prelude and the standard libraries, and output+annotated code on stdout. This takes about 40s on turing, 20s on kokotni.+<small>+(The flags <code>+RTS -K5M</code> prevents the pretty printer from running out+of stack space...)</small>+-->+<hr>+<address>Authors: various</address>+<address>Contact: <a href="http://www.cse.ogi.edu/~hallgren/">TH</address>
+ tools/base/SA/ExampleScope.hs view
@@ -0,0 +1,141 @@+-- $Id: ExampleScope.hs,v 1.2 2001/04/25 17:38:00 moran Exp $++module ExampleScope where++import Syntax+import List(find, nub, nubBy, (\\), sortBy, groupBy, union)+import Maybe+import SyntaxUtil(getTyName)            +import Scope(Senv(..),patBound,allNames,allTypNames+            ,instPatToParts,typePatToParts,boundInP+            ,fst3,fst4,env0,freeT,freeC,restrictTvar)+import Scope2+++-------------------------------------------------------------------------+-- free variable example++join (x,y) (a,b) = (x++a,y++b)++extFree :: Bind -> ([HsName],[HsName]) -> ([HsName],[HsName])+extFree (Bpat loc pat) (ev,tv) = (boundInP pat ev,tv)+extFree (Bpats loc ps) (ev,tv) = (foldr boundInP ev ps,tv)+extFree (Bname loc nm) (ev,tv) = (nm:ev,tv)+extFree (Bdecls ds) (ev,tv) = +    let v = allNames ds env0+    in (map fst (varNames v) ++ map fst3 (constrNames v) ++ ev+       ,map fst4 (classNames v) ++ (tvarNames v) ++ map fst4 (tconstrNames v) ++ tv)+extFree (Btypat tag tp) (ev,tv) = +    let (tvs, cs)     = allTypNames tp ([], [])             +    in (ev,cs ++ tvs ++ tv)+extFree (Btypats tag tps) (ev,tv) = +    let (tvs,cs) = allTypNames (hsTyTuple tps) ([],[])+    in (ev,cs ++ tvs ++ tv)+extFree (Btyvar nm) (ev,tv) = (ev,nm : tv)++freelib = Sc extFree id++-----------------------------------------------------------------------+-- When computing free variables type-patterns usually act like binding+-- occurences, so their are no free type-vars in a type-pattern. There+-- is one excpetion and that is in the declarations which make up the+-- where clause of a class definition, then the type patterns inside a+-- type-signature play a different role. The type variables in these+-- type-signatures are not binding, but are in the scope of the type+-- variables introduced by the type-pattern declaring the class.+--+-- class T x where                 <- x is bound here+--    f :: Int -> y -> x           <- vars here are free, so y is free+--    g x = x + h 1 +--        where h :: x -> x        <- these x's are binding+--              h z = z+--+-- This is tricky to handle correctly, since default declarations, may+-- have internal type-signatures which don't obey these special rules+-- but obey the normal rules for type patterns. So we'll parameterize+-- freeD by a boolean that tells if we're immediately inside a Class+-- and make a special mapD function to propogate that information++mapD2 ef pf df tf cf tpf decl =+  case decl of+    HsClassDecl s c tp ds -> HsClassDecl s (cf c) (tpf tp) (df True ds)+    y -> mapD ef pf (df False) tf cf tpf y+    ++---------------------------------------------------------- +freeE :: HsExp -> ([HsName],[HsName]) -> ([HsName],[HsName])++freeE (Exp x) (env @ (ev,tv)) = +  case x of +    HsId(HsVar s) -> if elem s ev then ([],[]) else ([s],[])+    x -> accE join join join join join +           (scopeE freelib env (mapE freeE freeP (freeD False) freeT2 freeC2 x)) +           ([],[])++freeP :: HsPat -> (HsPat,([HsName],[HsName]) -> ([HsName],[HsName]))+freeP p = (p,const ([],[]))++freeD :: Bool -> [HsDecl] -> ([HsDecl],([HsName],[HsName])->([HsName],[HsName]))  +freeD inClass ds = (ds,free)+  where free env = let v0 = extFree (Bdecls ds) env+                   in (foldr (eachd v0) ([],[]) ds)+        needSpecialRule (HsTypeSig loc nms c t) = inClass+        needSpecialRule other = False+        eachd env (Dec d) ans = +           if needSpecialRule d+              then let (HsTypeSig loc nms c t) = d+                   in (freeC2 c env) `join` (freeT2 t env) `join` ans+              else accD join join join join join join+                      (scopeD freelib env +                           (mapD2 freeE freeP freeD freeT2 freeC2 freeTP d))+                      ans    + +instance Show (a -> b) where+   show g = "<fun>"+                        +freeTP :: HsType -> (HsType,([HsName],[HsName]) -> ([HsName],[HsName]))+freeTP tp = (tp,free)+  where free (ev,tv) = ([],[])+ +freeT2 :: HsType -> ([HsName],[HsName]) -> ([HsName],[HsName])+freeT2 t (ev,tv) = ([],freeT t tv)++freeC2 :: [HsType] -> ([HsName],[HsName]) -> ([HsName],[HsName])+freeC2 cs (ev,tv) = ([],freeC cs tv)+ +testD ds = let (_,f) = freeD False ds in f (extFree (Bdecls ds) ([],[]))++ +-------------------------------------------------------------------------+-- Example extend function for the static env Senv of the static checker+++extTvar nm env = env {tvarNames = (nm) : tvarNames env}  + +extend :: Bind -> Senv -> Senv+extend (Bpat loc pat) env = foldr extName env uniqueNames+        where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])+              extName nm env = env {varNames = (nm,loc) : varNames env}+extend (Bpats loc ps) env = foldr extend env (map (Bpat loc) ps)+extend (Bdecls ds) env = allNames ds env+extend (Bname loc nm) env = env {varNames = (nm,loc) : varNames env}+extend (Btypat tag tp) env = +  case tag of+        ClassTag ->  -- (Env e x)         -- expects (C v1 ... vn)+          let (constr, tvs) = typePatToParts tp+          in foldr extTvar env tvs +        InstTag  ->  -- (Env [Int] Bool)  -- expects (C t1 ... tn)+          let (classname, ts) = instPatToParts tp+              (tvs, cs) = foldr allTypNames ([], []) ts+          in foldr extTvar env tvs +        SigTag   ->  -- (e : typ) +          let (tvs, cs)     = allTypNames tp ([], [])             +          in foldr extTvar env tvs+extend (Btypats tag (tps @ (constr : args))) env = +   case tag of+     DataTPS -> foldr (\ t e -> extTvar (getTyName t) e) env tps+     TypeTPS -> foldr (\ t e -> extTvar (getTyName t) e) env args+    +staticlib = Sc extend restrictTvar    ++getd = freeD
+ tools/base/SA/GenSym.hs view
@@ -0,0 +1,24 @@+-- $Id: GenSym.hs,v 1.1 2001/07/24 17:39:10 moran Exp $++{-++   Horribly hacked up gensym.++-}++module GenSym (newName) where++import IOExts++count :: IORef Int+count = unsafePerformIO $+    newIORef 0++incCount :: Int+incCount = unsafePerformIO $+    do c <- readIORef count+       writeIORef count $! (c + 1)+       return c++newName :: String+newName = show incCount
+ tools/base/SA/SCC.hs view
@@ -0,0 +1,214 @@+-- $Id: SCC.hs,v 1.10 2001/07/30 19:02:20 moran Exp $++module SCC where++import Scope(freeD)+import ST+import List+import qualified Array as A+import Syntax++subgraph nodes g =+  let es = edges g+      f (x,y) = elem x nodes && elem y nodes+      es' = filter f es+      n = (length nodes) - 1+      bounds = (0,n)+      pairs = zip nodes [0..]+      encode x = case find (\ (a,b) -> a==x) pairs of Just(a,b) -> b+      decode x = case find (\ (a,b) -> b==x) pairs of Just(a,b) -> a+      trans (x,y) = (encode x, encode y)+      g' = buildG bounds (map trans es')+  in g'+  +hascycle nodes g =+  any (\ x -> length x >1) (scc2 (subgraph nodes g))++---------------------------------------------+bindingGroups :: [HsDecl] -> ([[HsDecl]],Bool)+bindingGroups ds = +   let graph = makeGraph ds+       topsort = SCC.scc2 graph+       f group = map (\x -> ds!!x) group+       groups = map f topsort+       +       isSynonym (Dec (HsTypeDecl _ _ _)) = True+       isSynonym _ = False+       bs = map isSynonym ds+       isSyn n = bs !! n+       nodes = filter isSyn (indices graph)+       syngraph = subgraph nodes graph+   in (groups,hascycle nodes syngraph)++++tim = bindingGroups       +------------------------------------------+-- f x = 2 + (g x)+-- g y = (f y) - y+-- z = t+-- t = t+-- qq  = y+-- m = (t,n) + (g n, t n)++makeGraph ds =+  let (boundf,_) = freeD ds  +      +      get x = let (boundf,freef) = freeD [x]+                +              in (boundf [],        -- names defined in each d+                  nub(freef []))    -- d depends upon these+      freelist = map get ds        +      bound = nub(boundf [])        -- [f,g,z,t,qq,m]+      restrict (defined,free) = (defined,intersect free bound) +      pairs = map restrict freelist -- [([f],[g]),([g],[f]),([z],[t]),+                                    --  ([t],[]),([qq],[]),([m],[t,g])] +      loc x = loc' x pairs 0+      loc' x ((def,f):xs) n = if elem x def then n else loc' x xs (n+1)+      edge (def,free) n = (n,n) : (map (\ f -> (n,loc f)) free)+      edges = concat (zipWith edge pairs [0..])+      bounds = (0,(length ds) - 1)+  in (buildG bounds edges)++vars ds = zip (map (\ (f1,f2) -> (f1 [], f2 [])) $ map (\x -> freeD [x]) ds) [0..]++boundIn :: HsName -> [( ([HsName],[HsName]), Int)] -> Int+boundIn n [] =  -1 --error ("Variable " ++ (show n) ++ " not bound anywhere!!!")+boundIn n ( ((bounds,frees),dnum) : rest) = +        if n `elem` bounds +           then dnum+           else boundIn n rest++buildGraph ::  [(([HsName],[HsName]),Int)] ->  [(([HsName],[HsName]),Int)] -> [(Int,Int)]+buildGraph ds [] = []+buildGraph ds (((bounds,frees),bnum):rest) =+    (bnum,bnum) : [ (bnum,x ) | x <- map (\n -> boundIn n ds) frees ] ++ (buildGraph ds rest)++depgraph ds = +   (buildG (-1, (length ds) - 1) $ +         ((reverse (buildGraph (vars ds) (vars ds) ))) )+++++type Vertex  = Int++-- Representing graphs:++type Table a = A.Array Vertex a -- [(Vertex, a)]+type Graph   = Table [Vertex]++vertices :: Graph -> [Vertex]+vertices graph  = A.indices graph -- (map fst . A.assocs) graph++type Edge = (Vertex, Vertex)++--aat tab v = case List.find (\ (x,y) -> x == v) (A.assocs tab) of Just (_,r) -> r+aat tab v = tab A.! v+indices tab = A.indices tab++edges    :: Graph -> [Edge]+edges g   = [ (v, w) | v <- vertices g, w <- g `aat` v ]++mapTr    :: (Vertex -> a -> b) -> Table a -> Table b+mapTr f t = A.array (A.bounds t) [ (v, f v (t `aat` v)) | v <- indices t ]++type Bounds = (Vertex, Vertex)++outdegree :: Graph -> Table Int+outdegree  = mapTr numEdges+             where numEdges v ws = length ws++buildG :: Bounds -> [Edge] -> Graph+--buildG _ [] = []+--buildG _ (x:xs) =  []+buildG bnds edges = A.accumArray (flip (:)) [] bnds edges+++graph = buildG (1,10)+         (reverse+          [ (1, 2),  (1, 6),  (2, 3),+            (2, 5),  (3, 1),  (3, 4),+            (5, 4),  (7, 8),  (7, 10),+            (8, 6),  (8, 9),  (8, 10) ]+         )+         +-- Depth-first search++-- Specification and implementation of depth-first search:++data Tree a   = Node a (Forest a) -- deriving Show+type Forest a = [Tree a]++instance Show a => Show (Tree a) where+   show (Node a []) = (show a)+   show (Node a as) = (show a) ++ "" ++ (showList as "") ++ ""+++nodesTree (Node a f) ans = nodesForest f (a:ans)+nodesForest [] ans = ans+nodesForest (t : f) ans = nodesTree t (nodesForest f ans)++dff          :: Graph -> Forest Vertex+dff g         = dfs g (vertices g)++dfs          :: Graph -> [Vertex] -> Forest Vertex+dfs g vs      = prune (A.bounds g) (map (generate g) vs)++generate     :: Graph -> Vertex -> Tree Vertex+generate g v  = Node v (map (generate g) (g `aat` v))+++type Set s    = STArray s Vertex Bool++mkEmpty      :: Bounds -> ST s (Set s)+mkEmpty bnds  = newSTArray bnds False++contains     :: Set s -> Vertex -> ST s Bool+contains m v  = readSTArray m v++include      :: Set s -> Vertex -> ST s ()+include m v   = writeSTArray m v True++prune        :: Bounds -> Forest Vertex -> Forest Vertex+prune bnds ts = runST (mkEmpty bnds >>= \m ->+                       chop m ts)++chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)+chop m []     = return []+chop m (Node v ts : us)+              = contains m v >>= \visited ->+                if visited then+                  chop m us+                else+                  include m v >>= \_  ->+                  chop m ts   >>= \as ->+                  chop m us   >>= \bs ->+                  return (Node v as : bs)+         +-- Algorithm 2: topological sorting++postorder :: Tree a -> [a]+postorder (Node a ts) = postorderF ts ++ [a]++postorderF   :: Forest a -> [a]+postorderF ts = concat (map postorder ts)++postOrd      :: Graph -> [Vertex]+postOrd       = postorderF . dff++--topSort      :: Graph -> [Vertex]+--topSort       = reverse . postOrd   ++-- Algorithm 4: strongly connected components++reverseE    :: Graph -> [Edge]+reverseE g   = [ (w, v) | (v, w) <- edges g ]++transposeG  :: Graph -> Graph+transposeG g = buildG (A.bounds g) (reverseE g)++scc          :: Graph -> Forest Vertex+scc g         = dfs (transposeG g) (reverse (postOrd g))+ +scc2 g = reverse (map (\ t -> nodesTree t []) (scc g))
+ tools/base/SA/Scope.hs view
@@ -0,0 +1,1209 @@+-- $Id: Scope.hs,v 1.18 2001/08/21 00:13:36 hallgren Exp $++-- This module implements the static checker, and is way too big and really+-- must be split up some day.++module Scope(Senv(..),+             patBound,+             names,+             allNames,+             allTypNames,+             instPatToParts,+             typePatToParts,+             boundInP,+             fst3,+             fst4,+             env0,+             freeT,+             freeC,+             freeD,+             restrictTvar,+             runScope)+where ++import Syntax+import List(find, nub, nubBy, (\\), sortBy, groupBy, union)+--import Observe+import PrettyPrint+import Maybe+import IOExts+import SyntaxUtil(isTyVar, getTyName)+import Scope2+import GenSym(newName)++------------------------------------------------------------------+-- Environments+------------------------------------------------------------------++-- What kind of names are introduced by a declaration? +-- Classes, Types, Data Constructors, Variables, Signatures, and Modules+-- So we define an abstract class for environments, which has an empty+-- environment, env0, and extension functions for each kind of name.++type Arity = Int+data KindOfName   = Var | Cons | TyVar | TyCons | Class | Mod | Sig+data KindOfTyCons = DataDef | NewTypeDef | TypeDef++class Env env where+  extClass   :: HsName -> SrcLoc -> Arity  -> [HsName] -> env -> env+  extTconstr :: HsName -> SrcLoc -> Arity  -> Bool     -> env -> env+  extTvar    :: HsName                                 -> env -> env+  extConstr  :: HsName -> SrcLoc -> Arity              -> env -> env+  extVar     :: HsName -> SrcLoc                       -> env -> env+  extSig     :: HsName -> SrcLoc                       -> env -> env+  extMod     :: HsName                                 -> env -> env+  env0       :: env+  restrictTvar :: env    -> env++-------------------------------------------------------------------------------+-- A concrete class for environments appropriate for static Checking++type Error = (SrcLoc,String)++locations :: KindOfName -> Senv -> [(HsName,SrcLoc)]+locations k env =+  case k of+    Var   -> varNames env+    Sig   -> sigNames env+    Cons  -> map (\(nm,loc,arity)       -> (nm,loc)) $ constrNames env+    Class -> map (\(nm,loc,arity,nms)   -> (nm,loc)) $ classNames env+    TyCons-> map (\(nm,loc,arity,issyn) -> (nm,loc)) $ tconstrNames env+    other -> error "no locations available "+++data Senv = S { classNames   :: [(HsName,SrcLoc,Arity,[HsName])]+              , tconstrNames :: [(HsName,SrcLoc,Arity,Bool)]+              , tvarNames    :: [HsName]+              , constrNames  :: [(HsName,SrcLoc,Arity)]+              , varNames     :: [(HsName,SrcLoc)]+              , sigNames     :: [(HsName,SrcLoc)]+              , moduleNames  :: [HsName]+              } deriving Show++instance Env Senv where + extClass   nm l a nms env = env {classNames   = (nm,l,a,nms): classNames   env}+ extTconstr nm l a syn env = env {tconstrNames = (nm,l,a,syn): tconstrNames env}+ extTvar    nm         env = env {tvarNames    = (nm)        : tvarNames    env}+ extConstr  nm l a     env = env {constrNames  = (nm,l,a)    : constrNames  env}+ extVar     nm l       env = env {varNames     = (nm,l)      : varNames     env}+ extSig     nm l       env = env {sigNames     = (nm,l)      : sigNames     env}+ extMod     nm         env = env {moduleNames  = nm          : moduleNames  env}+ env0 =  let e = (S [] [] [] [] [] [] [])+         in  e + restrictTvar env = env {tvarNames    = []}++concatEnv :: Senv -> Senv -> Senv+concatEnv (S a b c d e f g) (S a' b' c' d' e' f' g') = +        S (a++a') (b++b') (c++c') (d++d') (e++e') (f++f') (g ++ g')++fst3 (a,b,c) = a+snd3 (a,b,c) = b+thd3 (a,b,c) = c++fst4 (a,b,c,d) = a+snd4 (a,b,c,d) = b+thd4 (a,b,c,d) = c+fth4 (a,b,c,d) = d++varDefined   s env = any (==s) $ map fst  $ varNames env+classDefined s env = any (==s) $ map fst4 $ classNames env+tvarDefined  s env = any (==s)            $ tvarNames env+tconDefined  s env = (any (==s) $ map fst4 $ tconstrNames env) +                     || (any (==s) [Qual (Module "Prelude") "()", Qual (Module "Prelude") "[]"])++sigExists    s env = any (==s) $ map fst  $ sigNames env++isMethod nm c env = case classMethods c env of+                    Just nms -> nm  `elem` nms+                    Nothing  -> False++classMethods :: HsName -> Senv -> Maybe [HsName]+classMethods nm env = fmap fth4 (List.find match (classNames env))+   where match (name,_,_,nms)  = name==nm+         match _               = False++synArity :: HsName -> Senv -> Maybe Int+synArity nm env = fmap thd4 (List.find match (tconstrNames env))+   where match (name,_,_,True) = name==nm+         match _               = False+   ++cArity :: HsName -> Senv -> Maybe Int+cArity (UnQual ":") _ = Just 2+cArity (Qual (Module "Prelude") ":") _ = Just 2+cArity (UnQual "()") _ = Just 0+cArity (Qual (Module "Prelude") "()" ) _ = Just 0+cArity c env = fmap thd3 (List.find match (constrNames env))+   where match (name,_,_) = name == c++-- expects C x*+typePatToParts t = extractConArgs t []+  where extractConArgs (Typ (HsTyCon c))                   acc = (c, acc)+        extractConArgs (Typ (HsTyApp f (Typ (HsTyVar x)))) acc =+           extractConArgs f (x:acc)+        extractConArgs t                                   acc =+           (UnQual newName, acc)++--expects C t*+instPatToParts t = extractInstArgs t []+  where extractInstArgs (Typ (HsTyApp (Typ(HsTyCon c)) x)) acc = (c, acc)+        extractInstArgs (Typ (HsTyApp f x))                acc =+           extractInstArgs f (x:acc)+        extractInstArgs _                                  acc =+            error ("ill formed instance pattern:\n\n" ++ pp t)++------------------------------------------------------------------+-- Given a list of mutually recursive declarations, what names are+-- introduced in the scope of those declarations?++names :: HsDecl -> Senv+names (Dec d) =+ case d of+  HsTypeDecl s (nm:args) body ->+      env0 { tconstrNames = [(getTyName nm, s, length args, True)] }+  HsNewTypeDecl s cntxt (c:args) body der ->+    env0 { tconstrNames   = [(getTyName c, s, length args, False)] +         , constrNames = [dataName body]+         , varNames    = recordName body+         }+  HsDataDecl s cntxt (c:args) constrs der -> +    let f x xs = (dataName x) : xs+        g x xs = (recordName x) ++ xs+    in  env0 { tconstrNames   = [(getTyName c, s, length args, False)]+             , constrNames = foldr f [] constrs+             , varNames    = foldr g [] constrs+             }+  HsClassDecl s c tp ds ->+    let (con, args) = typePatToParts tp+        members  = sigNames $ allNames ds env0+    in  env0 { varNames    = members+             , classNames  = [(con, s, length args, map fst members)]+             }+  HsInstDecl s c tp ds -> env0+  HsDefaultDecl s t -> env0+  HsTypeSig s nms c t -> env0 {sigNames = map (\nm -> (nm,s)) nms}+  HsFunBind s ((HsMatch s2 nm ps rhs ds):_) -> env0 {varNames = [(nm,s2)]}+  HsPatBind s p rhs ds -> env0 {varNames = map (\nm -> (nm,s)) $ boundInP p []}+  HsPrimitiveTypeDecl s c nm ->  +     env0 { tconstrNames = [(nm,s,0,False)] }+  HsPrimitiveBind s nm typ ->+    env0 { varNames = [(nm,s)] }       +  other -> env0+++dataName (HsConDecl s nm slots) = (nm,s,length slots)+dataName (HsRecDecl s nm slots) = (nm,s,length slots)++recordName :: HsConDecl t -> [(HsName,SrcLoc)] +recordName (HsConDecl s nm slots) = []+recordName (HsRecDecl s nm slots) = foldr f [] slots+    where f (names,domain) xs = map (\nm -> (nm,s)) names ++ xs+  +allNames :: [HsDecl] -> Senv -> Senv  +allNames ds initial = foldr acc initial ds+  where acc d env = concatEnv (names d) env +++----------------------------------------------------------------------         +-- Generic Static checking functions++duplicates :: Eq a => [a] -> [a]+duplicates [] = []+duplicates (x:xs) = +  if elem x xs then x : (duplicates (filter (/=x) xs)) else (duplicates xs)++collect_duplicate_info :: ([a] -> [b]) -> (a -> a -> Ordering) -> [a] -> [b]+collect_duplicate_info infof compare = +  concat . (map infof) . (groupBy (lift compare)) . (List.sortBy compare)+    where lift g x y = case g x y of { EQ -> True; _ -> False }++dupErrs :: (Show a, Show b) => b -> [(a,SrcLoc)] -> [Error]+dupErrs sort [] = []+dupErrs sort [x] =[]+dupErrs sort xs@((nm,loc):_) = chk loc True (duplicate_things sort nm (map snd xs))++dupTvErr srcloc [x]    = []+dupTvErr srcloc (x:xs) = [(srcloc, duplicate_type_vars x)]++chk:: SrcLoc -> Bool -> String -> [Error]+chk loc test message = if test then [(loc,message)] else []++unique :: Eq a => [(a,b)] -> [(a,b)]+unique = nubBy (\(a,_) (b,_) -> a==b)+++------------------------------------------------------------------------------+-- Scope checking +------------------------------------------------------------------------------+nmConflict :: Senv -> [Error]+nmConflict env = +    let ts = tconstrNames env +        cs = classNames env+        sameName (tn,tloc,_,_) errs =+          case List.find (\(a,_,_,_) -> a==tn) cs of +            Nothing           -> errs+            Just (_,cloc,_,_) -> (tloc, type_class_conflict tn [tloc,cloc]) : errs+    in  foldr sameName [] ts++classMethodErr :: Senv -> [Error]+classMethodErr env = +   let ss = sigNames env+       vs = varNames env+       sigExists (vn,vloc) errs =+         case List.find (\(a,_) -> a==vn) ss of+           Nothing      -> (vloc, method_without_signature vn) : errs+           Just _       -> errs+   in  foldr sigExists [] vs++type_class_conflict tn cloc = +  "Type name " ++ pp tn ++ " is used as class name "++ pp cloc +method_without_signature vn = +  "Definition of " ++ pp vn  ++ " without declaration"++++getClass (Typ (HsTyApp x _)) = getClass x+getClass (Typ (HsTyCon c))   = Just c+getClass _                   = Nothing+++allTypNames (Typ (HsTyVar v)) (vs, cs) = (v : vs, cs)+allTypNames (Typ (HsTyCon c)) (vs, cs) = (vs,     c : cs)+allTypNames (Typ t)           ans      = accT allTypNames t ans++isTyConApp (Typ (HsTyCon _))   = True+isTyConApp (Typ (HsTyApp f _)) = isTyConApp f+isTyConApp _                   = False++getTyAppArgs (Typ (HsTyCon _))   args = args+getTyAppArgs (Typ (HsTyApp f x)) args = getTyAppArgs f (x:args)++-- Well formed type expression: C x*+wfTp :: SrcLoc -> TPContext -> HsType -> [Error] -> [Error]+wfTp srcloc c t errs =+    if isTyConApp t && all isTyVar (getTyAppArgs t []) then+        errs+    else+        (srcloc, type_former_is_not_constructor t c) : errs++-- well formed simple class specification: C x++wfSclass :: SrcLoc -> HsType -> [Error] -> [Error]+wfSclass loc t errs =+    if isTyConApp t && not (null args) && all isTyVar args then+        errs+    else+        (loc, illformed_sclass t) : errs+    where args = getTyAppArgs t []++ ++-------------------------------------------------------------------------++srcloc (HsTypeDecl          loc  _ _     ) = loc+srcloc (HsNewTypeDecl       loc  _ _ _ _ ) = loc+srcloc (HsDataDecl          loc  _ _ _ _ ) = loc+srcloc (HsClassDecl         loc  _ _ _   ) = loc+srcloc (HsInstDecl          loc  _ _ _   ) = loc+srcloc (HsDefaultDecl       loc  _       ) = loc+srcloc (HsTypeSig           loc  _ _ _   ) = loc+srcloc (HsFunBind           loc  _       ) = loc+srcloc (HsPatBind           loc  _ _ _   ) = loc+srcloc (HsPrimitiveTypeDecl loc  _ _     ) = loc+srcloc (HsPrimitiveBind     loc  _ _     ) = loc++whatIs (HsTypeDecl          _  _ _     ) = "type declaration"+whatIs (HsNewTypeDecl       _  _ _ _ _ ) = "newtype declaration"+whatIs (HsDataDecl          _  _ _ _ _ ) = "data declaration"+whatIs (HsClassDecl         _  _ _ _   ) = "class declaration"+whatIs (HsInstDecl          _  _ _ _   ) = "instance declaration"+whatIs (HsDefaultDecl       _  _       ) = "declaration"+whatIs (HsTypeSig           _  _ _ _   ) = "type signature"+whatIs (HsFunBind           _  _       ) = "function binding"+whatIs (HsPatBind           _  _ _ _   ) = "pattern binding"+whatIs (HsPrimitiveTypeDecl _  _ _     ) = "declaration"+whatIs (HsPrimitiveBind     _  _ _     ) = "declaration"+++--------------------------------------------------------------+-- The first kind of scoping and its combinators+--------------------------------------------------------------++scopE :: v -> E (v -> e) (v->v,v -> p) (v->v,v -> ds) (v -> t) (v -> c) -> E e p ds t c+scopE env x =+  case x of+    HsLet (envtrans,f) e -> let env2 = envtrans env +                            in  HsLet (f env2) (e env2)+    HsLambda ps e        -> let (env2,ps') = scopPatList env ps  +                            in  HsLambda ps' (e env2)+    HsCase e alts        -> HsCase (e env) (map (scopAlt env) alts)+    HsDo stmt            -> HsDo (scopStmt env stmt)+    HsListComp stmt      -> HsListComp (scopStmt env stmt)+    +    z -> mapE (\ f -> f env) (error "missing HsExp case") +              (error "missing HsDecl case") (\ f -> f env) (\ f -> f env) z++scopAlt :: v -> HsAlt (v -> e) (v->v,v -> p) (v->v,v -> ds) -> HsAlt e p ds+scopAlt env (HsAlt s (f,pf) rhs (g,dsf)) = +    let env2 = g (f env)+    in  (HsAlt s (pf env) (scopRhs env2 rhs) (dsf env2))++scopRhs :: v -> HsRhs (v -> e) -> HsRhs e+scopRhs env x = mapRhs (\ f -> f env) x++scopStmt :: v -> HsStmt (v -> e) (v->v,v -> p) (v->v,v -> ds) -> HsStmt e p ds+scopStmt env (HsGenerator (tr,pf) e s) = +   let env2 = tr env in HsGenerator (pf env) (e env2) (scopStmt env2 s)+scopStmt env (HsQualifier e s) = HsQualifier (e env) (scopStmt env s)+scopStmt env (HsLetStmt (tf,dsf) s) = +   let env2 = tf env in HsLetStmt (dsf env2) (scopStmt env2 s)+scopStmt env (HsLast e) = HsLast (e env)   ++scopPatList :: v -> [(v -> v,v -> p)] -> (v,[p])+scopPatList env ps = (foldr (\ (tf,_ ) e -> tf e) env ps,+                      map (\ (_ ,pf)   -> pf env) ps)++--------------------------------------------------------------------------+-- Then for the declaration sub-language++scopD :: Env v => v -> +         D (v -> e)+         (v -> v, v -> p)+         (v -> v, v -> ds)+         (v -> t)+         (v -> c)+         (v -> v, v -> tp) -> +         D e p ds t c tp +scopD env x =+  let scopConDecl env = mapConDecl (\f -> f env) +      extendWithTvs env tvs = foldr extTvar env tvs+      scopMatch env (HsMatch loc nm ps rhs (dectrans,ds)) = +        let (env2,ps') = scopPatList env ps+            env3 = dectrans (extVar nm loc env2)+        in HsMatch loc nm ps' (scopRhs env3 rhs) (ds env3)+  in+  case x of+    HsPatBind loc (pattrans,pf) rhs (dectrans,dsf) ->+        let env2 = dectrans (pattrans env)+        in+        HsPatBind loc (pf env) (scopRhs env2 rhs) (dsf env2)+    HsFunBind loc matches -> HsFunBind loc (map (scopMatch env) matches)+    HsTypeDecl loc (transtpfs @ ((ctrans,cmaker):fs)) tf -> +        let env2 = ctrans env+            constr = cmaker env+            (env3,args) = scopPatList env fs+        in HsTypeDecl loc (constr:args) (tf env3)+        +    HsNewTypeDecl loc contxtf transtpfs condecl derivs ->+          let (env2,args) = scopPatList env transtpfs+              (env3,_) = scopPatList (restrictTvar env) (tail transtpfs)+          in  HsNewTypeDecl loc (contxtf env3) args  (scopConDecl env2 condecl) derivs+    +    HsDataDecl loc contxtf transtpfs condecls derivs ->+         let (env2,args) = scopPatList env transtpfs+             (env3,_) = scopPatList (restrictTvar env) (tail transtpfs)+         in  HsDataDecl loc (contxtf env3) args (map (scopConDecl env2) condecls) derivs+    +    HsClassDecl loc contxtf (trans,tpf) (dectrans,dsf) ->    +         let env1 = trans (restrictTvar env) +         in HsClassDecl loc (contxtf env1) (tpf env) (dsf $ dectrans env1) +    HsInstDecl loc contxtf (trans,tpf) (dectrans,dsf) ->    +         let env1 = trans (restrictTvar env) +         in HsInstDecl loc (contxtf env1) (tpf env) (dsf $ dectrans env1) +    HsTypeSig loc nms contxtf (transf, tpf)  ->+         HsTypeSig loc nms (contxtf (transf env)) (tpf env)+    z -> mapD (\ f -> f env) h h (\ f -> f env) (\ f -> f env) (error "type pattern") z+         where h (trans,f) = f (trans env) +++--------------------------------------------------------------------------+-- Then for the type sub-language++scopT :: v -> T (v -> t) -> T t+scopT env t = mapT (\f -> f env) t ++--------------------------------------------------------------------------+-- Computing Things about patterns+--------------------------------------------------------------------------++boundInP :: HsPat -> [HsName] -> [HsName]+boundInP (Pat(HsPId(HsVar s))) ans = s:ans+boundInP (Pat(HsPAsPat n p)) ans = boundInP p (n:ans)+boundInP (Pat x) ans = accP boundInP ans x+++------------------------------------------------------------------------+    -- patBound: Compute three things while visiting each pattern sub-node.+    -- 1) A list of unique names bound by the pattern+    -- 2) A list of names that appear more than once. +    --    These are errors because we allow only linear patterns+    -- 3) A list of every construtor and the arity at which it was used.+    --    These are potential errors if the arites do not match++patBound :: HsPat -> ([HsName], [HsName], [(HsName, Int)]) -> +                     ([HsName], [HsName], [(HsName, Int)])+patBound (Pat p) ans =+    case p of+    HsPId(HsVar n)      -> add n ans+    HsPAsPat n p        -> patBound p (add n ans) +    HsPApp c ps         -> cadd c (length ps) ans'+    HsPInfixApp p1 c p2 -> cadd (getHSName c) 2 ans'+    _                   -> ans'++    where add x (a, b, c) = +               if elem x a +                  then if elem x b +                          then (a, b, c)+                          else (a, x:b, c)  +                  else (x:a, b, c)+          cadd c n (x, y, z) = (x, y, (c, n):z)+          ans' = accP patBound ans p+++------------------------------------------------------------------------------+-- Static Check for Expressions++chE :: SrcLoc -> HsExp -> Senv -> [Error]+chE loc (exp @ (Exp x)) env =+  case scopE env (mapE (chE loc) (chP loc)+               (chDs WhereLikeDecl) (chT loc ) (error "ctxt")  x) of+    HsId (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsInfixApp x (HsVar n) y -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsLeftSection x (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsRightSection (HsVar n) x -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsLambda ps e -> e ++ (chPatList loc env ps)+  +    z -> accE (++) (\ (ns,errs) a -> errs++a) (++) (++) (++) z []+    +--------------------------------------------+-- Static checks for individual patterns++chP :: SrcLoc -> HsPat -> (Senv -> Senv,Senv -> ([HsName],[Error]))+chP loc (pat @ (Pat x)) = (envTrans, f)+  where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])+        envTrans env = foldr extName env uniqueNames+        extName nm = extVar nm loc+        duperr = chk loc (not (null dups)) (duplicate_vars_in_pattern dups)+        f env = (uniqueNames,allErrors env)+        allErrors env = foldr arityCheck duperr constrArities+          where arityCheck (c,n) ans = check c n (cArity c env) ++ ans+                check c n Nothing  = [(loc,undefined_constr c)]+                check c n (Just m) = chk loc (m /=n) (constr_wrong_arity n c)++-----------------------------------------------------------------------------+-- When language constructs have a list of patterns like : (\ p1 ... pn -> e)+-- or (case x of { C p1 ... pn -> e }), Haskell has the rule that no variable+-- should appear more than once in the list. We can't check this, pattern by+-- pattern, but have to observe the complete list. If we map (chP env) over a+-- list of patterns we get [([unique_names],[error_messages])], from this we+-- can compute additional error_messages dealing with duplicates.++chPatList :: SrcLoc -> Senv -> [([HsName],[Error])] -> [Error]      +chPatList loc env ps =+ let accumulate (ns,errs) (names,errors) = (ns++names,errs++errors)+     (allbound,internalerr) = foldr accumulate ([],[]) ps+     dups = duplicates allbound+     duperr = chk loc (not (null dups)) (repeated_pattern_variables dups)+ in internalerr ++ duperr++--------------------------------------------------------------------------+-- static checks for a list of Decls+++chDs :: DeclContext -> [HsDecl] -> (Senv->Senv,Senv -> [Error] )+chDs contxt ds = (envtrans,errorfun)+  where env      = allNames ds env0+        envtrans = concatEnv env+        errorfun env = foldr (\ d ans -> (check env d) ++ ans) allErrors ds+        sameName (x,y) (a,b) = compare x a+        contextErrors = catMaybes $ map (legal contxt) ds+        dupErr k message = collect_duplicate_info (dupErrs message) sameName (locations k env)+        dupValErrors  = dupErr Var    "value definitions"+        dupSigErrors  = dupErr Sig    "type signatures"+        dupClsErrors  = dupErr Class  "class definitions"+        dupTypErrors  = dupErr TyCons "type definitions"+        dupConsErrors = dupErr Cons   "constructor functions"++        allErrors = contextErrors++dupValErrors++dupSigErrors++dupClsErrors+                    ++ dupTypErrors ++ dupConsErrors ++ nmConflict env ++ clsMethodErr+        sigerr loc name = chk loc ((not $ elem name (map fst (varNames env))) && contxt/=ClassDecl)+                                  (signature_without_definition name)+        methodErr c (nm,loc) = chk loc (not $ isMethod nm c env) (not_a_method nm c)+        clsMethodErr = case contxt of +                       ClassDecl -> classMethodErr env+                       other     -> []+        check env (Dec x) =+          let loc = srcloc x+              methodErrs (HsInstDecl loc c tp ds) = +                let nms = varNames $ allNames ds env0+                in  case getClass tp of+                     Nothing -> []+                     Just c  -> concat $ map (methodErr c) nms+          in+           case scopD env (mapD' (chE loc) (chP loc) (chDs) (chT loc) (chCntxt loc) (chTp loc) x) of+             HsTypeSig loc nms c t  -> (concat $ map (sigerr loc) nms)++c++t+             HsInstDecl loc c tp ds -> methodErrs x ++ c ++ tp ++ ds+             z -> accD (++) (\ (ns,errs) a -> (errs)++a) (++) (++) (++) (++) z []++    +    +---------------------------------------------------------------------------++chT :: SrcLoc -> HsType -> Senv -> [Error]+chT loc (typ @ (Typ t)) env = +  case t of +   HsTyVar nm -> chk loc (not (tvarDefined nm env)) (undefined_tvar nm)+   HsTyCon nm -> chk loc (not (tconDefined nm env)) (undefined_tcon nm)+   HsTyApp (Typ f) x -> synCheck (chT loc) loc env f x 1+   z -> accT (++) (scopT env (mapT (chT loc)  z)) []++synCheck chf loc env (HsTyCon c) arg n = +    case synArity c env of+    Nothing -> chk loc (not (tconDefined c env)) (undefined_tcon c) +++               chf arg env +    Just m  -> chk loc (m/=n) (tysynonym_not_fully_applied c) ++ chf arg env+synCheck chf loc env (HsTyApp (Typ f) x) arg n =+    synCheck chf loc env f x (n+1) ++ chf arg env+synCheck chf loc env t arg n = chf (Typ t) env ++ chf arg env++-----------------------------------------------------------------------------+-- Static checks for contexts++chCntxt :: SrcLoc ->  DeclContext -> [HsType] -> (Senv -> [Error])+chCntxt loc c ts env = foldr (check c) [] ts+  where inscope (Typ (HsTyVar x)) ans = +            chk loc (not $ tvarDefined x env) (undefined_tvar_in_context x) ++ ans+        inscope (Typ (HsTyCon c)) ans = +            chk loc (not $ classDefined c env) (undefined_class_in_context c) ++ ans +        inscope (Typ x) ans  = accT inscope x ans ++        -- class: C (x t*)++        wfClass t (Typ (HsTyApp (Typ (HsTyCon c)) x )) xs =+           wfClassArg x x xs+        wfClass t (Typ (HsTyApp x y ))                 xs =+           wfClass t x $ wfClassArg x x xs+        wfClass t (Typ x)                              xs =+           (loc, illformed_class t) : xs++        -- class arg: x t*+        wfClassArg t (Typ (HsTyVar y))   xs = xs+        wfClassArg t (Typ (HsTyApp x _)) xs = wfClassArg t x xs +        wfClassArg t (Typ x)             xs = (loc, illformed_class_arg t) : xs++        check ClassDecl x ans = wfSclass loc x (inscope x ans)+        check InstDecl  x ans = wfSclass loc x (inscope x ans)+        check _         x ans = wfClass  x x   (inscope x ans)++-----------------------------------------------------------------------------+-- Static checks for type patterns+++chTp :: SrcLoc ->  TPContext -> HsType -> (Senv -> Senv, Senv -> [Error])+chTp srcloc InstTP x =+  let errors = wf x []+      -- well formed instance: C (C x*)+++      wf (Typ(HsTyApp (Typ(HsTyCon c)) arg)) xs =+         wfTp srcloc InstTP arg xs+      wf (Typ(HsTyCon c)) xs                 =+         (srcloc, instance_required c) : xs +      wf (Typ(HsTyApp y arg)) xs             =+         wf y (wfTp srcloc InstTP arg xs)+      wf tp xs                               =+         (srcloc, instance_not_class_app tp) : xs++      (classname, ts) = instPatToParts x+      (tvs, cs) = foldr allTypNames ([], []) ts+      trans env = if null errors then foldr extTvar env tvs else env+      clsError env = chk srcloc (not $ classDefined classname env) +                                (undefined_class_in_instance classname)+      cdef env c ans = +         if tconDefined c env +         then case synArity c env of+              Nothing   -> ans+              Just _    -> (srcloc, synonym_illegal_in_instance c):ans+         else (srcloc,undefined_tcon_in_instance c):ans+      dupErrs = collect_duplicate_info (dupTvErr srcloc) compare tvs+      tpf env = if null errors+                then foldr (cdef env) (dupErrs ++ clsError env) cs+                else errors+  in (trans, tpf)                ++chTp srcloc SigTP x =+  let (tvs, cs)     = allTypNames x ([], [])+      trans env    = foldr extTvar env tvs+      cdef env c ans = +         if tconDefined c env +         then ans+         else (srcloc, undefined_tcon_in_signature c):ans+      tpf env = foldr (cdef env) [] cs+  in  (trans, tpf)++chTp srcloc cntxt x =+  let (constr, tvs) = typePatToParts x+      errors = case cntxt of DataLikeTP ->  wfTp     srcloc cntxt x []+                             ClassTP    ->  wfSclass srcloc       x []+      trans env = if null errors then foldr extTvar env tvs else env+      tpf env   = if null errors +                  then collect_duplicate_info (dupTvErr srcloc) compare tvs+                  else errors+  in (trans, tpf)++++-------------------------------------------------------------------------+-- Error Message Strings are computed here+-------------------------------------------------------------------------++undefined_variable nm = "Undefined variable: "++ pp nm+duplicate_vars_in_pattern dups =+  "Variables appear more than once in single pattern: " ++ pp dups+undefined_constr c =+  "Undefined Constructor in pattern: " ++ pp c+constr_wrong_arity n c =+  "Constructor "++ pp c++ " must have exactly "++ pp n ++ " arguments."+repeated_pattern_variables dups =+  "Repeated variables in pattern list: " ++ pp dups+duplicate_things sort name locs =+  "Duplicate " ++ show sort ++ " of " ++ show name +++  " at locations: " ++ pp locs+signature_without_definition name =+  "Signature for "++pp name++" without matching definition."++undefined_class_in_instance classname =+  "Class name in instance: " ++ pp classname ++ "  is not defined"+undefined_tcon_in_instance c =+  "Type constructor " ++ pp c ++ " in instance is not defined"+synonym_illegal_in_instance c =+  "Type synonym " ++ pp c ++ " in instance"++undefined_tcon_in_signature c =+  "Type constructor " ++ pp c ++ " in signature is not defined"+  +undefined_class_in_context clsname =+  "Class name " ++ pp clsname ++ " in context is not defined"+undefined_tvar_in_context tvarname =+  "Type variable " ++ pp tvarname ++ " in context is not defined"+undefined_tvar tvarname =+  "Type variable " ++ pp tvarname ++ "  is not defined"+undefined_tcon tconname =+  "Type constructor " ++ pp tconname ++ "  is not defined"+tysynonym_not_fully_applied tyconname =+  "Type synonym " ++ pp tyconname ++ "  is not fully applied"+duplicate_type_vars x =+  "Duplicate type variables in definition: " ++ pp x++non_tyvar_arg_in_pattern a c =+  "Argument in Type Pattern in " ++ show c ++ " is not a variable: "++ pp a+type_former_is_not_constructor x c = +  "Type pattern in " ++ show c ++ " is not an application of a type constructor: "++ pp x+instance_required tp =+  "Instance of class " ++ pp tp ++ " required"+instance_not_class_app tp = +  "Instance is not an application of a class constructor: "++pp tp++illformed_sclass t=+  "ill formed class "++pp t+illformed_class t=+  "ill formed class in context "++pp t+illformed_class_arg t=+  "ill formed argument " ++ pp t ++ " to class in context "++not_a_method nm c =+  pp nm ++ " is not a method of class " ++ pp c++run env prog = errF (envF env) where (envF, errF) = chDs TopDecl prog++runScope = run env0++{-++showAst === pp++showAst :: Printable a => a -> String+showAst = render . ppi+-}++{-+testDs :: (String,[HsDecl]) -> IO ()+testDs (s, ds) = +         do { putStr "\n==============================================\n"+            ; putStr s+            ; putStr "\n--- test code----------\n"+            ; sh ds+            ; putStr "\n--- errors ------------\n"+            ; (putStr . unlines . map showErr . run env0) ds+            }++tests ts = sequence_ $ map testDs ts+-}++-----------------------------------------------------------------------------+-- computing free variables+-- Computing free variables is a tricky computation, because the same variable+-- may be free in one spot and bound in another. We need an environment to+-- determine what variables are bound at any particular point. We use a list+-- of HsName as the environment++-- Given an expression and an environment telling what vars are bound+-- determine the free variables in the expression.++freeE :: HsExp -> [HsName] -> [HsName]+freeE (Exp x) env = +  case scopE env (mapE freeE freeP freeD freeT freeC x) of+    HsId(HsVar s) -> if elem s env then [] else [s]+    HsInfixApp x (HsVar s) y -> if elem s env then [] else [s]+    HsLeftSection x (HsVar s) -> if elem s env then [] else [s]+    HsRightSection (HsVar s) x -> if elem s env then [] else [s]+    x -> accE (++) (++) (++) (++) (++) x []+            ++-- Return a pair of functions. The first is an env transformer, adding+-- the vars in the pattern, the second is a function given an env, which+-- determines the free vars in the pattern. The second is the constant []+-- function since patterns only introduce variables, they only have binding+-- occurences.++freeP :: HsPat -> ([HsName]->[HsName],[HsName]->[HsName])+freeP p = ((vs++),const [])+  where vs = boundInP p []+        +-- Return a pair of functions. The first is an env transformer, adding+-- the vars declared by the list of Decls, the second is a function which+-- when given an env, determines the free vars in the Decls ++freeD :: [HsDecl] -> ([HsName]->[HsName],[HsName]->[HsName])+freeD ds = (ext,free)+  where bound = foldr add [] ds+        ext env = bound ++ env +        add (Dec (HsPatBind s p rhs ds)) env = boundInP p env+        add (Dec (HsFunBind s ((HsMatch s2 nm ps rhs ds):_))) env  = nm : env+        add (Dec (HsDataDecl s ctx typats condecls derivings)) env =+           getTyName (head typats) : env+        add (Dec (HsTypeDecl s typats t)) env = getTyName (head typats) : env+        add d env = env+        getNameOfTypat (Typ x) = +             case x of +               HsTyApp l _ -> getNameOfTypat l+               HsTyCon n   -> n+               HsTyVar n   -> n +               _           -> error "getNameOfTypat "+        free env = (foldr (f env) [] ds) \\ bound +        f env (Dec d) ans = +          accD (++)(++)(++)(++)(++)(++)+               (scopD env (mapD (\ x -> ( (freeE x))) freeP freeD freeT freeC freeTP d)) ans+ff env (Dec d) ans = +          accD (++)(++)(++)(++)(++)(++)+               (scopD env (mapD (\ x -> ( (freeE x))) freeP freeD freeT freeC freeTP d)) ans          +++instance Env [HsName] where+  extClass n l a args env = env+  extTconstr n l a b  env = n:env+  extTvar n           env = n:env+  extConstr n l a     env = n:env+  extVar n l          env = n:env+  extSig n l          env = env+  extMod n            env = env+  env0 = []+  restrictTvar env = env+++-- Given an environment holding bound variables, return the +-- free variables in the HsType++freeT :: HsType -> [HsName] -> [HsName]+freeT (Typ x) env = +  case scopT env (mapT freeT x) of+    HsTyCon n -> if elem n env then [] else [n]    +    HsTyVar n -> if elem n env then [] else [n]+    x         -> accT (union) x []++allFree :: HsType -> [HsName] -> [HsName]+allFree (Typ x) ans = +  case x of+    HsTyCon n -> union [n] ans+    HsTyVar n -> union [n] ans+    x         -> accT allFree x ans+++-- compute the free variables in a context.++freeC :: [HsType] -> [HsName] -> [HsName]+freeC x env = concat (map (\z -> freeT z env) x)++-- Type patterns are HsTYpes which act as binding occurences. Hence+-- they return a pair. First an env transformer, and Second a function+-- that given an env, computes the TypePatterns free variables. Like patterns+-- this always returns []++freeTP :: HsType -> ([HsName] -> [HsName],[HsName] -> [HsName])+freeTP x = (allFree x,const [])++{-+makeSCC ds env =+  let (envtrans,_) = freeD ds +      bound = envtrans []+      oneD d = let (_,free) = freeD [d] in free env+      oneBind d = let (envt,_) = freeD [d] in envt []+      allFree  = map oneD ds+      allBound = map oneBind ds +  in (allFree,allBound)+-}+--------------------------------------------------------------------------+-- Contexts+--------------------------------------------------------------------------++-- type patterns appear in 4 different contexts++data TPContext = DataLikeTP | ClassTP | InstTP | SigTP+instance Show TPContext where+  show DataLikeTP = "type, data, or newtype declaration"+  show ClassTP    = "class declaration"+  show InstTP     = "instance declaration"+  show SigTP      = "type signature" +++-----------------------------------------------------------------+-- Lists of declarations can appear in four different contexts+-- Only certain kinds of declarations are legal in some of these.++data DeclContext = TopDecl | ClassDecl | InstDecl | WhereLikeDecl deriving (Eq)+instance Show DeclContext where+  show TopDecl       = "top level"+  show ClassDecl     = "class declaration"+  show InstDecl      = "class declaration"+  show WhereLikeDecl = "local declaration"++legal :: DeclContext -> HsDecl -> Maybe Error+legal context (d @ (Dec x)) =+  let err context x = Just (srcloc x,+                "Illegal "++ whatIs x ++" in " ++ show context)+  in  case (context,x) of+      (TopDecl,   any)                             -> Nothing+      (ClassDecl, HsTypeSig _ _ _ _)               -> Nothing+      (ClassDecl, HsFunBind _ _)                   -> Nothing+      (ClassDecl, HsPatBind _ (Pat(HsPId(HsVar _))) _ _) -> Nothing+      (ClassDecl, any)                             -> err context x+      (InstDecl,  HsFunBind _ _)                   -> Nothing+      (InstDecl,  HsPatBind _ (Pat(HsPId(HsVar _))) _ _) -> Nothing+      (InstDecl,  any)                             -> err context x+      (WhereLikeDecl, HsTypeSig _ _ _ _)           -> Nothing+      (WhereLikeDecl, HsFunBind _ _)               -> Nothing+      (WhereLikeDecl, HsPatBind _ _ _ _)           -> Nothing+      (WhereLikeDecl, any)                         -> err context x++-----------------------------------------------------------------------+-- MapD' is like mapD, except it know what kind of contexts are+-- appropriate and passes this information downwards++mapD' :: (a -> b) -> (c -> d) -> (DeclContext -> e -> f) -> (g -> h) -> (DeclContext -> i -> j)+                  -> (TPContext -> k -> l) -> D a c e g i k -> D b d f h j l+mapD' ef pf df tf cf tpf decl =+   case decl of+    HsTypeDecl s tps t -> +        HsTypeDecl s (map (tpf DataLikeTP) tps) (tf t)+    HsNewTypeDecl s cntxt tps cd names ->+        HsNewTypeDecl s (cf TopDecl cntxt)+              (map (tpf DataLikeTP) tps) (mapConDecl tf cd) names+    HsDataDecl s cntxt tps cds names   ->+        HsDataDecl s (cf TopDecl cntxt)+               (map (tpf DataLikeTP) tps)+               (map (mapConDecl tf) cds) names+    HsClassDecl s c tp ds                   ->+        HsClassDecl s (cf ClassDecl c) (tpf ClassTP tp) (df ClassDecl ds)+    HsInstDecl s c tp ds                    ->+        HsInstDecl s (cf InstDecl c) (tpf InstTP tp) (df InstDecl ds)+    HsDefaultDecl s t -> +        HsDefaultDecl s (tf t)+    HsTypeSig s nms c t                  ->+        HsTypeSig s nms (cf TopDecl c) (tpf SigTP t)+    HsFunBind s matches                   ->+        HsFunBind s (map (mapMatch ef pf (df WhereLikeDecl)) matches)+    HsPatBind s p rhs ds                  ->+        HsPatBind s (pf p) (mapRhs ef rhs) (df WhereLikeDecl ds)+    HsPrimitiveTypeDecl s cntxt nm        -> +        HsPrimitiveTypeDecl s (cf TopDecl cntxt) nm+    HsPrimitiveBind s nm t                ->+        HsPrimitiveBind s nm (tf t) -- Hugs compatibility+++{-+-------------------------------------------------------------------+-------------------------------------------------------------------+-- Static Checking using Bind based scoping++-------------------------------------------------------------------------+-- Example extend function for the static env Senv of the static checker+++-- extTvar nm env = env {tvarNames = (nm) : tvarNames env}  + +extend :: Bind -> Senv -> Senv+extend (Bpat loc pat) env = foldr extName env uniqueNames+        where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])+              extName nm env = env {varNames = (nm,loc) : varNames env}+extend (Bpats loc ps) env = foldr extend env (map (Bpat loc) ps)+extend (Bdecls ds) env = allNames ds env+extend (Bname loc nm) env = env {varNames = (nm,loc) : varNames env}+extend (Btypat tag tp) env = +  case tag of+        ClassTag ->  -- (Env e x)         -- expects (C v1 ... vn)+          let (constr, tvs) = typePatToParts tp+          in foldr extTvar env tvs +        InstTag  ->  -- (Env [Int] Bool)  -- expects (C t1 ... tn)+          let (classname, ts) = instPatToParts tp+              (tvs, cs) = foldr allTypNames ([], []) ts+          in foldr extTvar env tvs +        SigTag   ->  -- (e : typ) +          let (tvs, cs)     = allTypNames tp ([], [])             +          in foldr extTvar env tvs+extend (Btypats tag (tps @ (constr : args))) env = +   case tag of+     DataTPS -> foldr (\ t e -> extTvar (getTyName t) e) env tps+     TypeTPS -> foldr (\ t e -> extTvar (getTyName t) e) env args+    +staticlib = Sc extend restrictTvar    ++------------------------------------------------------------------+-- Static checks for expressions ++checkE :: SrcLoc -> HsExp -> Senv -> [Error]+checkE loc (exp @ (Exp x)) env =+  case scopeE staticlib env +         (mapE (checkE loc) (checkP loc)+               (checkDs WhereLikeDecl) (checkT loc) (checkCnxt loc WhereLikeDecl)  x) of+    HsId (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsInfixApp x (HsVar n) y -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsLeftSection x (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsRightSection (HsVar n) x -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsLambda ps e -> e ++ (checkPList loc env ps)+    z -> accE (++) (\ (nm,err) a -> err ++ a) (++) (++) (++) z []+    +-----------------------------------------------------------------------------+-- When language constructs have a list of patterns like : (\ p1 ... pn -> e)+-- or (case x of { C p1 ... pn -> e }), Haskell has the rule that no variable+-- should appear more than once in the list. We can't check this, pattern by+-- pattern, but have to observe the complete list. If we map (chP env) over a+-- list of patterns we get [([unique_names],[error_messages])], from this we+-- can compute additional error_messages dealing with duplicates.++checkPList :: SrcLoc -> Senv -> [([HsName],[Error])] -> [Error]      +checkPList loc env ps =+ let accumulate (ns,errs) (names,errors) = (ns++names,errs++errors)+     (allbound,internalerr) = foldr accumulate ([],[]) ps+     dups = duplicates allbound+     duperr = chk loc (not (null dups)) (repeated_pattern_variables dups)+ in internalerr ++ duperr++--------------------------------------------+-- Static checks for individual patterns++checkP ::  SrcLoc -> HsPat -> (HsPat, Senv -> ([HsName],[Error]))+checkP loc (pat @ (Pat x)) = (pat, f)+  where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])+        duperr = chk loc (not (null dups)) (duplicate_vars_in_pattern dups)+        f env = (uniqueNames,allErrors env)+        allErrors env = foldr arityCheck duperr constrArities+          where arityCheck (c,n) ans = check c n (cArity c env) ++ ans+                check c n Nothing  = [(loc,undefined_constr c)]+                check c n (Just m) = chk loc (m /=n) (constr_wrong_arity n c)+++------------------------------------------------------------------------------+-- Static Check for Expressions++-- checkDs assumes that all the names in the [Decl] have already been added+-- to the environment which is passed to checkDs result function.+-- e.g. in scopeE for HsLet we say:+--    HsLet (ds,f) e -> +--       let env2 = ext (Bdecls ds) env +--       in  HsLet (f env2) (e env2)+-- note how we compute the new env, and pass it to both the ds and the f++checkDs ::  DeclContext -> [HsDecl] -> ([HsDecl],Senv -> [Error])+checkDs contxt ds = (ds,errorfun)+  where env      = allNames ds env0+        errorfun env = foldr (\ d ans -> (check env d) ++ ans) allErrors ds+        sameName (x,y) (a,b) = compare x a+        contextErrors = catMaybes $ map (legal contxt) ds+        dupErr k message = collect_duplicate_info (dupErrs message) sameName (locations k env)+        dupValErrors  = dupErr Var    "value definitions"+        dupSigErrors  = dupErr Sig    "type signatures"+        dupClsErrors  = dupErr Class  "class definitions"+        dupTypErrors  = dupErr TyCons "type definitions"+        dupConsErrors = dupErr Cons   "constructor functions"++        allErrors = contextErrors++dupValErrors++dupSigErrors++dupClsErrors+                    ++ dupTypErrors ++ dupConsErrors ++ nmConflict env ++ clsMethodErr+        sigerr loc name = chk loc ((not $ elem name (map fst (varNames env))) && contxt/=ClassDecl)+                                  (signature_without_definition name)+        methodErr c (nm,loc) = chk loc (not $ isMethod nm c env) (not_a_method nm c)+        clsMethodErr = case contxt of +                       ClassDecl -> classMethodErr env+                       other     -> []+        check env (Dec x) =+          let loc = srcloc x+              methodErrs (HsInstDecl loc c tp ds) = +                let nms = varNames $ allNames ds env0+                in  case getClass tp of+                     Nothing -> []+                     Just c  -> concat $ map (methodErr c) nms+          in+           case scopeD staticlib env +                  (mapD' (checkE loc) (checkP loc) (checkDs) +                         (checkT loc) (checkCnxt loc) (checkTp loc) x) of+             HsTypeSig loc nms c t  -> (concat $ map (sigerr loc) nms)++c++t+             HsInstDecl loc c tp ds -> methodErrs x ++ c ++ tp ++ ds+             z -> accD (++) (\ (ns,errs) a -> (errs)++a) (++) (++) (++) (++) z []++---------------------------------------------------------------------------+-- static checks for types++checkT ::  SrcLoc -> HsType -> Senv -> [Error]+checkT loc (typ @ (Typ t)) env = +  case t of +   HsTyVar nm -> chk loc (not (tvarDefined nm env)) (undefined_tvar nm)+   HsTyCon nm -> chk loc (not (tconDefined nm env)) (undefined_tcon nm)+   HsTyApp (y @ (Typ f)) x -> synArityCheck (checkT loc) env f x 1+   z -> accT (++) (scopeT env (mapT (checkT loc)  z)) []++synArityCheck chf env typ arg n = +  case typ of+    (HsTyCon c) -> +       case synArity c env of+         Nothing -> chk loc (not (tconDefined c env)) (undefined_tcon c) ++ chf arg env +         Just m  -> chk loc (m/=n) (tysynonym_not_fully_applied c) ++ chf arg env+    (HsTyApp (Typ f) x) -> synArityCheck chf env f x (n+1) ++ chf arg env+    t -> chf (Typ t) env ++ chf arg env+   +----------------------------------------------------------------------+-- Static Checking for contexts++checkCnxt :: SrcLoc -> DeclContext -> [HsType] -> Senv -> [Error]++checkCnxt loc c ts env = foldr (check c) [] ts+  where inscope (Typ (HsTyVar x)) ans = +            chk loc (not $ tvarDefined x env) (undefined_tvar_in_context x) ++ ans+        inscope (Typ (HsTyCon c)) ans = +            chk loc (not $ classDefined c env) (undefined_class_in_context c) ++ ans +        inscope (Typ x) ans  = accT inscope x ans ++        -- class: C (x t*)++        wfClass t (Typ (HsTyApp (Typ (HsTyCon c)) x )) xs =+           wfClassArg x x xs+        wfClass t (Typ (HsTyApp x y ))                 xs =+           wfClass t x $ wfClassArg x x xs+        wfClass t (Typ x)                              xs =+           (loc, illformed_class t) : xs++        -- class arg: x t*+        wfClassArg t (Typ (HsTyVar y))   xs = xs+        wfClassArg t (Typ (HsTyApp x _)) xs = wfClassArg t x xs +        wfClassArg t (Typ x)             xs = (loc, illformed_class_arg t) : xs++        check ClassDecl x ans = wfSclass loc x (inscope x ans)+        check InstDecl  x ans = wfSclass loc x (inscope x ans)+        check _         x ans = wfClass  x x   (inscope x ans)+++---------------------------------------------------------------------+-- Static checks for type-patterns++--checkTp ::  SrcLoc -> TPContext -> HsType -> (HsType,Senv -> [Error])+checkTp :: SrcLoc ->  TPContext -> HsType -> (HsType, Senv -> [Error])++checkTp srcloc InstTP x =+  let errors = wf x []+      -- well formed instance: C (C x*)+++      wf (Typ(HsTyApp (Typ(HsTyCon c)) arg)) xs =+         wfTp srcloc InstTP arg xs+      wf (Typ(HsTyCon c)) xs                 =+         (srcloc, instance_required c) : xs +      wf (Typ(HsTyApp y arg)) xs             =+         wf y (wfTp srcloc InstTP arg xs)+      wf tp xs                               =+         (srcloc, instance_not_class_app tp) : xs++      (classname, ts) = instPatToParts x+      (tvs, cs) = foldr allTypNames ([], []) ts+      clsError env = chk srcloc (not $ classDefined classname env) +                                (undefined_class_in_instance classname)+      cdef env c ans = +         if tconDefined c env +         then case synArity c env of+              Nothing   -> ans+              Just _    -> (srcloc, synonym_illegal_in_instance c):ans+         else (srcloc,undefined_tcon_in_instance c):ans+      dupErrs = collect_duplicate_info (dupTvErr srcloc) compare tvs+      tpf env = if null errors+                then foldr (cdef env) (dupErrs ++ clsError env) cs+                else errors+  in (x, tpf)                ++checkTp srcloc SigTP x =+  let (_, cs)     = allTypNames x ([], [])+      cdef env c ans = +         if tconDefined c env +         then ans+         else (srcloc, undefined_tcon_in_signature c):ans+      tpf env = foldr (cdef env) [] cs+  in  (x, tpf)++checkTp srcloc cntxt x =+  let (_, tvs) = typePatToParts x+      errors = case cntxt of DataLikeTP ->  wfTp     srcloc cntxt x []+                             ClassTP    ->  wfSclass srcloc       x []+      tpf env   = if null errors +                  then collect_duplicate_info (dupTvErr srcloc) compare tvs+                  else errors+  in (x, tpf)++-----------------------------------------------------------------+-- Running the basic tests++run2 env prog  = let (ds,f) = checkDs TopDecl prog in (f (allNames ds env))++new (_,x) = run2 env0 x+old (_,x) = run env0 x++test2 :: (String,[HsDecl]) -> IO ()+test2 (s, ds) = +         do { putStr "\n==============================================\n"+            ; putStr s+            ; putStr "\n--- test code----------\n"+            ; sh ds+            ; putStr "\n--- errors ------------\n"+            ; (putStr . unlines . map showErr . run2 env0) ds+            }++tests2 ts = sequence_ (map test2 ts)++errors1 ts = map (run2 env0) (map snd ts) +errors2 ts = map (run env0) (map snd ts)        +             +new1 = errors1 insts       +old1 = errors2 insts++oks = zipWith (==) old1 new1+++[x0,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11] = insts++gg x = concat(map (\ (y,_,_,_) -> show y) (classNames x))+------------------------------------------------------------------+-- extra stuff++++-- supply a unique integer string+count :: IORef Int+count = unsafePerformIO $ newIORef 0+initCount = writeIORef count 10+incCount a = unsafePerformIO $ do { c <- readIORef count+                                  ; writeIORef count $! (c+1)+                                  ; return c+                                  }++uniqueStr a = show $ incCount ()+-}
+ tools/base/SA/Scope2.hs view
@@ -0,0 +1,174 @@+module Scope2(TPtag(..),+              TPStag(..),+              Bind(..),+              Scope(..),+              prop,+              scopeD,+              scopeE,+              scopeT)+where++import Syntax+import List(find, nub, nubBy, (\\), sortBy, groupBy, union)+import Maybe+import SyntaxUtil(isTyVar, getTyName)++------------------------------------------------------------------+-- This module is supposed to capture the details of scoping in Haskell+-- The idea is you supply a bunch of functions with type:+--    pat -> env -> a+-- Since the [Decls] in Haskell are mutually recursive+-- one has to decide who should+-- to the environment which is passed to checkDs result function.+-- e.g. in scopeE for HsLet we say:+--    HsLet (ds,f) e -> +--       let env2 = ext (Bdecls ds) env +--       in  HsLet (f env2) (e env2)+-- note how we compute the new env, and pass it to both the ds and the f++++data Scope v = Sc (Bind -> v -> v) (v -> v)++data TPtag + = ClassTag-- (Env e x)         -- expects (C v1 ... vn)+ | InstTag -- (Env [Int] Bool)  -- expects (C t1 ... tn)+ | SigTag  -- (e : typ)         -- Any type allowed + +data TPStag+ = TypeTPS  -- type tp = t+ | DataTPS  -- data tp = C ts | ... | Cn ts  --OR-- newtype tp = C t++data Bind + = Bpat SrcLoc HsPat+ | Bpats SrcLoc [ HsPat ]+ | Bdecls [ HsDecl ]+ | Bname SrcLoc HsName+ | Btypat TPtag HsType+ | Btypats TPStag [ HsType ]+ | Btyvar HsName++-----------------------------------------------+-- Whenever we have a list of binding things, like HsPat or typePat+-- we end up with a list of pairs. The first thing in the pair is a+-- binding thing, and the second is the result-producer. What we really+-- want is to build a list of things, and one big result-producer that+-- produces a list of results.++extPairs :: [(b,v->r)] -> ([b],v->[r])    ++extPairs [] = ([],const [])+extPairs ((p,g):xs) = (p:ps,h)+   where (ps,g2) = extPairs xs+         h env = (g env) : (g2 env)++prop env f = f env++----------------------------------------    +scopeE :: +   (Scope v) -> v -> +   E (v -> e) (HsPat,v -> p) ([HsDecl],v -> ds) (v -> t) (v -> c) -> +   E e p ds t c++scopeE (lib @ (Sc ext restrict)) env x =+  case x of+    HsLet (ds,f) e -> +       let env2 = ext (Bdecls ds) env +       in  HsLet (f env2) (e env2)+    HsLambda pairs e -> +       let (ps,psf) = extPairs pairs +           env2 = ext (Bpats loc0 ps) env+       in HsLambda (psf env) (e env2)+    HsCase e alts -> HsCase (e env) (map (scopeAlt lib env) alts)+    HsDo stmt -> HsDo (scopeStmt lib env stmt)+    HsListComp stmt -> HsListComp (scopeStmt lib env stmt)+    other -> mapE (prop env) (prop env . snd) (prop env . snd) (prop env) (prop env) other+                           +----------------------------------------+scopeStmt :: +  (Scope v) -> v -> +  HsStmt (v -> e) (HsPat,v -> p) ([HsDecl],v -> ds) ->+  HsStmt e p ds+  +scopeStmt (lib @ (Sc ext restrict)) env x =+  case x of +   (HsGenerator (p,pf) e s) ->+      let env2 = ext (Bpat loc0 p) env +      in HsGenerator (pf env) (e env2) (scopeStmt lib env2 s)+   (HsQualifier e s) -> HsQualifier (e env) (scopeStmt lib env s)+   (HsLetStmt (ds,dsf) s) ->+      let env2 = ext (Bdecls ds) env +      in HsLetStmt (dsf env2) (scopeStmt lib env2 s)+   (HsLast e) -> HsLast (e env)   ++----------------------------------------+scopeAlt :: +   (Scope v) -> v -> +   HsAlt (v -> e) (HsPat,v -> p) ([HsDecl],v -> ds) ->+   HsAlt e p ds++scopeAlt (Sc ext restrict) env (HsAlt s (p,pf) rhs (ds,dsf)) = +    let env2 = ext (Bpat s p) env+        env3 = ext (Bdecls ds) env2+    in  (HsAlt s (pf env) (scopeRhs env3 rhs) (dsf env3))++-----------------------------------------+scopeRhs :: v -> HsRhs (v -> e) -> HsRhs e+scopeRhs env x = mapRhs (prop env) x+++--------------------------------------------+scopeD :: +    (Scope v) -> v -> +    D (v -> e) (HsPat, v -> p) ([HsDecl], v -> ds) (v -> t) (v -> c) (HsType, v -> tp) -> +    D e p ds t c tp ++scopeD (lib @ (Sc ext restrict)) env x =+  let scopConDecl env = mapConDecl (prop env) +      extendWithTvs env tvs = foldr (\ nm v -> ext (Btyvar nm) v) env tvs+      scopMatch env (HsMatch loc nm pairs rhs (ds,df)) = +        let (ps,psf) = extPairs pairs +            env2 = ext (Bpats loc ps) env+            env3 = ext (Bdecls ds) (ext (Bname loc nm) env2)+        in HsMatch loc nm (psf env) (scopeRhs env3 rhs) (df env3)+  in+  case x of+    HsPatBind loc (p,pf) rhs (ds,dsf) ->+        let env1 = ext (Bpat loc p) env+            env2 = ext (Bdecls ds)  env1+        in HsPatBind loc (pf env) (scopeRhs env2 rhs) (dsf env2)+    HsFunBind loc matches -> HsFunBind loc (map (scopMatch env) matches)+    HsTypeDecl loc pairs tf -> +        let (ts,tsf) = extPairs pairs +            env2 = ext (Btypats TypeTPS ts) env+        in HsTypeDecl loc (tsf env) (tf env2)   +    HsNewTypeDecl loc contxtf pairs condecl derivs ->+        let (ts,tsf) = extPairs pairs +            env2 = ext (Btypats DataTPS ts) env+            env3 = ext (Btypats TypeTPS ts ) (restrict env)+        in  HsNewTypeDecl loc (contxtf env3) (tsf env) (scopConDecl env2 condecl) derivs      +    HsDataDecl loc contxtf pairs condecls derivs ->+        let (ts,tsf) = extPairs pairs +            env2 = ext (Btypats DataTPS ts) env+            env3 = ext (Btypats TypeTPS ts ) (restrict env)+        in  HsDataDecl loc (contxtf env3) (tsf env) (map (scopConDecl env2) condecls) derivs +    HsClassDecl loc contxtf (tp,tpf) (ds,dsf) ->    +         let env1 = ext (Btypat ClassTag tp) (restrict env)+             env2 = ext (Btypat ClassTag tp) env+         in HsClassDecl loc (contxtf env1) (tpf env1) (dsf env2) +    HsInstDecl loc contxtf (tp,tpf) (ds,dsf) ->    +         let env1 = ext (Btypat InstTag tp) (restrict env)+             env2 = ext (Btypat InstTag tp) env+         in HsInstDecl loc (contxtf env1) (tpf env1) (dsf env2) +    HsTypeSig loc nms contxtf (tp, tpf)  ->+         let env1 = ext (Btypat SigTag tp) env+         in HsTypeSig loc nms (contxtf env1) (tpf env)+    z -> mapD (prop env) h h (prop env) (prop env) h z+         where h (x,f) = error "Binding case in scopeD not handled"      ++--------------------------------------------------------------------------+-- Then for the type sub-language++scopeT :: v -> T (v -> t) -> T t+scopeT env t = mapT (\f -> f env) t       + 
+ tools/base/SA/ScopeRec.hs view
@@ -0,0 +1,1194 @@+-- $Id: ScopeRec.hs,v 1.1 2001/07/24 17:39:10 moran Exp $++module ScopeRec where ++import Syntax+import List(find, nub, nubBy, (\\), sortBy, groupBy, union)+--import Observe+import PrettyPrint+import Maybe+import IOExts+import SyntaxUtil(isTyVar, getTyName)+import Scope2+import HsConstants+import ScopeStruct++names :: HsDecl -> Senv+names (Dec d) = namesD d++dataName (HsConDecl s nm slots) = (nm, s, length slots)+dataName (HsRecDecl s nm slots) = (nm, s, length slots)++recordName :: HsConDecl t -> [(HsName, SrcLoc)] +recordName (HsConDecl s nm slots) = []+recordName (HsRecDecl s nm slots) = foldr f [] slots+    where f (names,domain) xs = map (\nm -> (nm,s)) names ++ xs+  +allNames :: [HsDecl] -> Senv -> Senv  +allNames ds initial = foldr acc initial ds+  where acc d env = concatEnv (names d) env +++----------------------------------------------------------------------         +-- Generic Static checking functions++duplicates :: Eq a => [a] -> [a]+duplicates [] = []+duplicates (x:xs) = +  if elem x xs then x : (duplicates (filter (/=x) xs)) else (duplicates xs)++collect_duplicate_info :: ([a] -> [b]) -> (a -> a -> Ordering) -> [a] -> [b]+collect_duplicate_info infof compare = +  concat . (map infof) . (groupBy (lift compare)) . (sortBy compare)+    where lift g x y = case g x y of { EQ -> True; _ -> False }++dupErrs :: (Show a, Show b) => b -> [(a,SrcLoc)] -> [Error]+dupErrs sort [] = []+dupErrs sort [x] =[]+dupErrs sort xs@((nm,loc):_) = chk loc True (duplicate_things sort nm (map snd xs))++dupTvErr srcloc [x]    = []+dupTvErr srcloc (x:xs) = [(srcloc, duplicate_type_vars x)]++chk:: SrcLoc -> Bool -> String -> [Error]+chk loc test message = if test then [(loc,message)] else []++unique :: Eq a => [(a,b)] -> [(a,b)]+unique = nubBy (\(a,_) (b,_) -> a==b)+++------------------------------------------------------------------------------+-- Scope checking +------------------------------------------------------------------------------+nmConflict :: Senv -> [Error]+nmConflict env = +    let ts = tconstrNames env +        cs = classNames env+        sameName (tn,tloc,_,_) errs =+          case find (\(a,_,_,_) -> a==tn) cs of +            Nothing           -> errs+            Just (_,cloc,_,_) -> (tloc, type_class_conflict tn [tloc,cloc]) : errs+    in  foldr sameName [] ts++classMethodErr :: Senv -> [Error]+classMethodErr env = +   let ss = sigNames env+       vs = varNames env+       sigExists (vn,vloc) errs =+         case find (\(a,_) -> a==vn) ss of+           Nothing      -> (vloc, method_without_signature vn) : errs+           Just _       -> errs+   in  foldr sigExists [] vs++type_class_conflict tn cloc = +  "Type name " ++ pp tn ++ " is used as class name "++ pp cloc +method_without_signature vn = +  "Definition of " ++ pp vn  ++ " without declaration"++++getClass (Typ (HsTyApp x _)) = getClass x+getClass (Typ (HsTyCon c))   = Just c+getClass _                   = Nothing+++allTypNames (Typ (HsTyVar v)) (vs, cs) = (v : vs, cs)+allTypNames (Typ (HsTyCon c)) (vs, cs) = (vs,     c : cs)+allTypNames (Typ t)           ans      = accT allTypNames t ans++isTyConApp (Typ (HsTyCon _))   = True+isTyConApp (Typ (HsTyApp f _)) = isTyConApp f+isTyConApp _                   = False++getTyAppArgs (Typ (HsTyCon _))   args = args+getTyAppArgs (Typ (HsTyApp f x)) args = getTyAppArgs f (x:args)++-- Well formed type expression: C x*+wfTp :: SrcLoc -> TPContext -> HsType -> [Error] -> [Error]+wfTp srcloc c t errs =+    if isTyConApp t && all isTyVar (getTyAppArgs t []) then+        errs+    else+        (srcloc, type_former_is_not_constructor t c) : errs++-- well formed simple class specification: C x++wfSclass :: SrcLoc -> HsType -> [Error] -> [Error]+wfSclass loc t errs =+    if isTyConApp t && not (null args) && all isTyVar args then+        errs+    else+        (loc, illformed_sclass t) : errs+    where args = getTyAppArgs t []++ ++-------------------------------------------------------------------------++srcloc (HsTypeDecl          loc  _ _     ) = loc+srcloc (HsNewTypeDecl       loc  _ _ _ _ ) = loc+srcloc (HsDataDecl          loc  _ _ _ _ ) = loc+srcloc (HsClassDecl         loc  _ _ _   ) = loc+srcloc (HsInstDecl          loc  _ _ _   ) = loc+srcloc (HsDefaultDecl       loc  _       ) = loc+srcloc (HsTypeSig           loc  _ _ _   ) = loc+srcloc (HsFunBind           loc  _       ) = loc+srcloc (HsPatBind           loc  _ _ _   ) = loc+srcloc (HsPrimitiveTypeDecl loc  _ _     ) = loc+srcloc (HsPrimitiveBind     loc  _ _     ) = loc++whatIs (HsTypeDecl          _  _ _     ) = "type declaration"+whatIs (HsNewTypeDecl       _  _ _ _ _ ) = "newtype declaration"+whatIs (HsDataDecl          _  _ _ _ _ ) = "data declaration"+whatIs (HsClassDecl         _  _ _ _   ) = "class declaration"+whatIs (HsInstDecl          _  _ _ _   ) = "instance declaration"+whatIs (HsDefaultDecl       _  _       ) = "declaration"+whatIs (HsTypeSig           _  _ _ _   ) = "type signature"+whatIs (HsFunBind           _  _       ) = "function binding"+whatIs (HsPatBind           _  _ _ _   ) = "pattern binding"+whatIs (HsPrimitiveTypeDecl _  _ _     ) = "declaration"+whatIs (HsPrimitiveBind     _  _ _     ) = "declaration"+++--------------------------------------------------------------+-- The first kind of scoping and its combinators+--------------------------------------------------------------++scopE :: v -> E (v -> e) (v->v,v -> p) (v->v,v -> ds) (v -> t) (v -> c) -> E e p ds t c+scopE env x =+  case x of+    HsLet (envtrans,f) e -> let env2 = envtrans env +                            in  HsLet (f env2) (e env2)+    HsLambda ps e        -> let (env2,ps') = scopPatList env ps  +                            in  HsLambda ps' (e env2)+    HsCase e alts        -> HsCase (e env) (map (scopAlt env) alts)+    HsDo stmt            -> HsDo (scopStmt env stmt)+    HsListComp stmt      -> HsListComp (scopStmt env stmt)+    +    z -> mapE (\ f -> f env) (error "missing HsExp case") +              (error "missing HsDecl case") (\ f -> f env) (\ f -> f env) z++scopAlt :: v -> HsAlt (v -> e) (v->v,v -> p) (v->v,v -> ds) -> HsAlt e p ds+scopAlt env (HsAlt s (f,pf) rhs (g,dsf)) = +    let env2 = g (f env)+    in  (HsAlt s (pf env) (scopRhs env2 rhs) (dsf env2))++scopRhs :: v -> HsRhs (v -> e) -> HsRhs e+scopRhs env x = mapRhs (\ f -> f env) x++scopStmt :: v -> HsStmt (v -> e) (v->v,v -> p) (v->v,v -> ds) -> HsStmt e p ds+scopStmt env (HsGenerator (tr,pf) e s) = +   let env2 = tr env in HsGenerator (pf env) (e env2) (scopStmt env2 s)+scopStmt env (HsQualifier e s) = HsQualifier (e env) (scopStmt env s)+scopStmt env (HsLetStmt (tf,dsf) s) = +   let env2 = tf env in HsLetStmt (dsf env2) (scopStmt env2 s)+scopStmt env (HsLast e) = HsLast (e env)   ++scopPatList :: v -> [(v -> v,v -> p)] -> (v,[p])+scopPatList env ps = (foldr (\ (tf,_ ) e -> tf e) env ps,+                      map (\ (_ ,pf)   -> pf env) ps)++--------------------------------------------------------------------------+-- Then for the declaration sub-language++scopD :: Env v => v -> +         D (v -> e)+         (v -> v, v -> p)+         (v -> v, v -> ds)+         (v -> t)+         (v -> c)+         (v -> v, v -> tp) -> +         D e p ds t c tp +scopD env x =+  let scopConDecl env = mapConDecl (\f -> f env) +      extendWithTvs env tvs = foldr extTvar env tvs+      scopMatch env (HsMatch loc nm ps rhs (dectrans,ds)) = +        let (env2,ps') = scopPatList env ps+            env3 = dectrans (extVar nm loc env2)+        in HsMatch loc nm ps' (scopRhs env3 rhs) (ds env3)+  in+  case x of+    HsPatBind loc (pattrans,pf) rhs (dectrans,dsf) ->+        let env2 = dectrans (pattrans env)+        in+        HsPatBind loc (pf env) (scopRhs env2 rhs) (dsf env2)+    HsFunBind loc matches -> HsFunBind loc (map (scopMatch env) matches)+    HsTypeDecl loc (transtpfs @ ((ctrans,cmaker):fs)) tf -> +        let env2 = ctrans env+            constr = cmaker env+            (env3,args) = scopPatList env fs+        in HsTypeDecl loc (constr:args) (tf env3)+        +    HsNewTypeDecl loc contxtf transtpfs condecl derivs ->+          let (env2,args) = scopPatList env transtpfs+              (env3,_) = scopPatList (restrictTvar env) (tail transtpfs)+          in  HsNewTypeDecl loc (contxtf env3) args  (scopConDecl env2 condecl) derivs+    +    HsDataDecl loc contxtf transtpfs condecls derivs ->+         let (env2,args) = scopPatList env transtpfs+             (env3,_) = scopPatList (restrictTvar env) (tail transtpfs)+         in  HsDataDecl loc (contxtf env3) args (map (scopConDecl env2) condecls) derivs+    +    HsClassDecl loc contxtf (trans,tpf) (dectrans,dsf) ->    +         let env1 = trans (restrictTvar env) +         in HsClassDecl loc (contxtf env1) (tpf env) (dsf $ dectrans env1) +    HsInstDecl loc contxtf (trans,tpf) (dectrans,dsf) ->    +         let env1 = trans (restrictTvar env) +         in HsInstDecl loc (contxtf env1) (tpf env) (dsf $ dectrans env1) +    HsTypeSig loc nms contxtf (transf, tpf)  ->+         HsTypeSig loc nms (contxtf (transf env)) (tpf env)+    z -> mapD (\ f -> f env) h h (\ f -> f env) (\ f -> f env) (error "type pattern") z+         where h (trans,f) = f (trans env) +++--------------------------------------------------------------------------+-- Then for the type sub-language++scopT :: v -> T (v -> t) -> T t+scopT env t = mapT (\f -> f env) t ++--------------------------------------------------------------------------+-- Computing Things about patterns+--------------------------------------------------------------------------++boundInP :: HsPat -> [HsName] -> [HsName]+boundInP (Pat(HsPId(HsVar s))) ans = s:ans+boundInP (Pat(HsPAsPat n p)) ans = boundInP p (n:ans)+boundInP (Pat x) ans = accP boundInP ans x+++------------------------------------------------------------------------+    -- patBound: Compute three things while visiting each pattern sub-node.+    -- 1) A list of unique names bound by the pattern+    -- 2) A list of names that appear more than once. +    --    These are errors because we allow only linear patterns+    -- 3) A list of every construtor and the arity at which it was used.+    --    These are potential errors if the arites do not match++patBound :: HsPat -> ([HsName], [HsName], [(HsName, Int)]) -> +                     ([HsName], [HsName], [(HsName, Int)])+patBound (Pat p) ans =+    case p of+    HsPId(HsVar n)      -> add n ans+    HsPAsPat n p        -> patBound p (add n ans) +    HsPApp c ps         -> cadd c (length ps) ans'+    HsPInfixApp p1 c p2 -> cadd (getHSName c) 2 ans'+    _                   -> ans'++    where add x (a, b, c) = +               if elem x a +                  then if elem x b +                          then (a, b, c)+                          else (a, x:b, c)  +                  else (x:a, b, c)+          cadd c n (x, y, z) = (x, y, (c, n):z)+          ans' = accP patBound ans p+++------------------------------------------------------------------------------+-- Static Check for Expressions++chE :: SrcLoc -> HsExp -> Senv -> [Error]+chE loc (exp @ (Exp x)) env =+  case scopE env (mapE (chE loc) (chP loc)+               (chDs WhereLikeDecl) (chT loc ) (error "ctxt")  x) of+    HsId (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsInfixApp x (HsVar n) y -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsLeftSection x (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsRightSection (HsVar n) x -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsLambda ps e -> e ++ (chPatList loc env ps)+  +    z -> accE (++) (\ (ns,errs) a -> errs++a) (++) (++) (++) z []+    +--------------------------------------------+-- Static checks for individual patterns++chP :: SrcLoc -> HsPat -> (Senv -> Senv,Senv -> ([HsName],[Error]))+chP loc (pat @ (Pat x)) = (envTrans, f)+  where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])+        envTrans env = foldr extName env uniqueNames+        extName nm = extVar nm loc+        duperr = chk loc (not (null dups)) (duplicate_vars_in_pattern dups)+        f env = (uniqueNames,allErrors env)+        allErrors env = foldr arityCheck duperr constrArities+          where arityCheck (c,n) ans = check c n (cArity c env) ++ ans+                check c n Nothing  = [(loc,undefined_constr c)]+                check c n (Just m) = chk loc (m /=n) (constr_wrong_arity n c)++-----------------------------------------------------------------------------+-- When language constructs have a list of patterns like : (\ p1 ... pn -> e)+-- or (case x of { C p1 ... pn -> e }), Haskell has the rule that no variable+-- should appear more than once in the list. We can't check this, pattern by+-- pattern, but have to observe the complete list. If we map (chP env) over a+-- list of patterns we get [([unique_names],[error_messages])], from this we+-- can compute additional error_messages dealing with duplicates.++chPatList :: SrcLoc -> Senv -> [([HsName],[Error])] -> [Error]      +chPatList loc env ps =+ let accumulate (ns,errs) (names,errors) = (ns++names,errs++errors)+     (allbound,internalerr) = foldr accumulate ([],[]) ps+     dups = duplicates allbound+     duperr = chk loc (not (null dups)) (repeated_pattern_variables dups)+ in internalerr ++ duperr++--------------------------------------------------------------------------+-- static checks for a list of Decls+++chDs :: DeclContext -> [HsDecl] -> (Senv->Senv,Senv -> [Error] )+chDs contxt ds = (envtrans,errorfun)+  where env      = allNames ds env0+        envtrans = concatEnv env+        errorfun env = foldr (\ d ans -> (check env d) ++ ans) allErrors ds+        sameName (x,y) (a,b) = compare x a+        contextErrors = catMaybes $ map (legal contxt) ds+        dupErr k message = collect_duplicate_info (dupErrs message) sameName (locations k env)+        dupValErrors  = dupErr Var    "value definitions"+        dupSigErrors  = dupErr Sig    "type signatures"+        dupClsErrors  = dupErr Class  "class definitions"+        dupTypErrors  = dupErr TyCons "type definitions"+        dupConsErrors = dupErr Cons   "constructor functions"++        allErrors = contextErrors++dupValErrors++dupSigErrors++dupClsErrors+                    ++ dupTypErrors ++ dupConsErrors ++ nmConflict env ++ clsMethodErr+        sigerr loc name = chk loc ((not $ elem name (map fst (varNames env))) && contxt/=ClassDecl)+                                  (signature_without_definition name)+        methodErr c (nm,loc) = chk loc (not $ isMethod nm c env) (not_a_method nm c)+        clsMethodErr = case contxt of +                       ClassDecl -> classMethodErr env+                       other     -> []+        check env (Dec x) =+          let loc = srcloc x+              methodErrs (HsInstDecl loc c tp ds) = +                let nms = varNames $ allNames ds env0+                in  case getClass tp of+                     Nothing -> []+                     Just c  -> concat $ map (methodErr c) nms+          in+           case scopD env (mapD' (chE loc) (chP loc) (chDs) (chT loc) (chCntxt loc) (chTp loc) x) of+             HsTypeSig loc nms c t  -> (concat $ map (sigerr loc) nms)++c++t+             HsInstDecl loc c tp ds -> methodErrs x ++ c ++ tp ++ ds+             z -> accD (++) (\ (ns,errs) a -> (errs)++a) (++) (++) (++) (++) z []++    +    +---------------------------------------------------------------------------++chT :: SrcLoc -> HsType -> Senv -> [Error]+chT loc (typ @ (Typ t)) env = +  case t of +   HsTyVar nm -> chk loc (not (tvarDefined nm env)) (undefined_tvar nm)+   HsTyCon nm -> chk loc (not (tconDefined nm env)) (undefined_tcon nm)+   HsTyApp (Typ f) x -> synCheck (chT loc) env f x 1+   z -> accT (++) (scopT env (mapT (chT loc)  z)) []++synCheck chf env (HsTyCon c) arg n = +    case synArity c env of+    Nothing -> chk loc (not (tconDefined c env)) (undefined_tcon c) ++ chf arg env +    Just m  -> chk loc (m/=n) (tysynonym_not_fully_applied c) ++ chf arg env+synCheck chf env (HsTyApp (Typ f) x) arg n =+    synCheck chf env f x (n+1) ++ chf arg env+synCheck chf env t arg n = chf (Typ t) env ++ chf arg env++-----------------------------------------------------------------------------+-- Static checks for contexts++chCntxt :: SrcLoc ->  DeclContext -> [HsType] -> (Senv -> [Error])+chCntxt loc c ts env = foldr (check c) [] ts+  where inscope (Typ (HsTyVar x)) ans = +            chk loc (not $ tvarDefined x env) (undefined_tvar_in_context x) ++ ans+        inscope (Typ (HsTyCon c)) ans = +            chk loc (not $ classDefined c env) (undefined_class_in_context c) ++ ans +        inscope (Typ x) ans  = accT inscope x ans ++        -- class: C (x t*)++        wfClass t (Typ (HsTyApp (Typ (HsTyCon c)) x )) xs =+           wfClassArg x x xs+        wfClass t (Typ (HsTyApp x y ))                 xs =+           wfClass t x $ wfClassArg x x xs+        wfClass t (Typ x)                              xs =+           (loc, illformed_class t) : xs++        -- class arg: x t*+        wfClassArg t (Typ (HsTyVar y))   xs = xs+        wfClassArg t (Typ (HsTyApp x _)) xs = wfClassArg t x xs +        wfClassArg t (Typ x)             xs = (loc, illformed_class_arg t) : xs++        check ClassDecl x ans = wfSclass loc x (inscope x ans)+        check InstDecl  x ans = wfSclass loc x (inscope x ans)+        check _         x ans = wfClass  x x   (inscope x ans)++-----------------------------------------------------------------------------+-- Static checks for type patterns+++chTp :: SrcLoc ->  TPContext -> HsType -> (Senv -> Senv, Senv -> [Error])+chTp srcloc InstTP x =+  let errors = wf x []+      -- well formed instance: C (C x*)+++      wf (Typ(HsTyApp (Typ(HsTyCon c)) arg)) xs =+         wfTp srcloc InstTP arg xs+      wf (Typ(HsTyCon c)) xs                 =+         (srcloc, instance_required c) : xs +      wf (Typ(HsTyApp y arg)) xs             =+         wf y (wfTp srcloc InstTP arg xs)+      wf tp xs                               =+         (srcloc, instance_not_class_app tp) : xs++      (classname, ts) = instPatToParts x+      (tvs, cs) = foldr allTypNames ([], []) ts+      trans env = if null errors then foldr extTvar env tvs else env+      clsError env = chk srcloc (not $ classDefined classname env) +                                (undefined_class_in_instance classname)+      cdef env c ans = +         if tconDefined c env +         then case synArity c env of+              Nothing   -> ans+              Just _    -> (srcloc, synonym_illegal_in_instance c):ans+         else (srcloc,undefined_tcon_in_instance c):ans+      dupErrs = collect_duplicate_info (dupTvErr srcloc) compare tvs+      tpf env = if null errors+                then foldr (cdef env) (dupErrs ++ clsError env) cs+                else errors+  in (trans, tpf)                ++chTp srcloc SigTP x =+  let (tvs, cs)     = allTypNames x ([], [])+      trans env    = foldr extTvar env tvs+      cdef env c ans = +         if tconDefined c env +         then ans+         else (srcloc, undefined_tcon_in_signature c):ans+      tpf env = foldr (cdef env) [] cs+  in  (trans, tpf)++chTp srcloc cntxt x =+  let (constr, tvs) = typePatToParts x+      errors = case cntxt of DataLikeTP ->  wfTp     srcloc cntxt x []+                             ClassTP    ->  wfSclass srcloc       x []+      trans env = if null errors then foldr extTvar env tvs else env+      tpf env   = if null errors +                  then collect_duplicate_info (dupTvErr srcloc) compare tvs+                  else errors+  in (trans, tpf)++++-------------------------------------------------------------------------+-- Error Message Strings are computed here+-------------------------------------------------------------------------++undefined_variable nm = "Undefined variable: "++ pp nm+duplicate_vars_in_pattern dups =+  "Variables appear more than once in single pattern: " ++ pp dups+undefined_constr c =+  "Undefined Constructor in pattern: " ++ pp c+constr_wrong_arity n c =+  "Constructor "++ pp c++ " must have exactly "++ pp n ++ " arguments."+repeated_pattern_variables dups =+  "Repeated variables in pattern list: " ++ pp dups+duplicate_things sort name locs =+  "Duplicate " ++ show sort ++ " of " ++ show name +++  " at locations: " ++ pp locs+signature_without_definition name =+  "Signature for "++pp name++" without matching definition."++undefined_class_in_instance classname =+  "Class name in instance: " ++ pp classname ++ "  is not defined"+undefined_tcon_in_instance c =+  "Type constructor " ++ pp c ++ " in instance is not defined"+synonym_illegal_in_instance c =+  "Type synonym " ++ pp c ++ " in instance"++undefined_tcon_in_signature c =+  "Type constructor " ++ pp c ++ " in signature is not defined"+  +undefined_class_in_context clsname =+  "Class name " ++ pp clsname ++ " in context is not defined"+undefined_tvar_in_context tvarname =+  "Type variable " ++ pp tvarname ++ " in context is not defined"+undefined_tvar tvarname =+  "Type variable " ++ pp tvarname ++ "  is not defined"+undefined_tcon tconname =+  "Type constructor " ++ pp tconname ++ "  is not defined"+tysynonym_not_fully_applied tyconname =+  "Type synonym " ++ pp tyconname ++ "  is not fully applied"+duplicate_type_vars x =+  "Duplicate type variables in definition: " ++ pp x++non_tyvar_arg_in_pattern a c =+  "Argument in Type Pattern in " ++ show c ++ " is not a variable: "++ pp a+type_former_is_not_constructor x c = +  "Type pattern in " ++ show c ++ " is not an application of a type constructor: "++ pp x+instance_required tp =+  "Instance of class " ++ pp tp ++ " required"+instance_not_class_app tp = +  "Instance is not an application of a class constructor: "++pp tp++illformed_sclass t=+  "ill formed class "++pp t+illformed_class t=+  "ill formed class in context "++pp t+illformed_class_arg t=+  "ill formed argument " ++ pp t ++ " to class in context "++not_a_method nm c =+  pp nm ++ " is not a method of class " ++ pp c++{-++showAst === pp++showAst :: Printable a => a -> String+showAst = render . ppi+-}++----------------------------------------------------------------------------------+-- some tests++sh :: Printable b => b -> IO ()+sh = putStr . render . ppi++loc = SrcLoc "Scope tests" 0 0++names2 @ [fn,gn,hn,kn,xn,yn,zn] = map UnQual ["f","g","h","k","x","y","z"]+names3 @ [an,bn,cn,dn,en,tn,sn] = map UnQual ["A","B","C","D","E","T","S"]++exps @  [fe,ge,he,ke,xe,ye,ze] = map hsEVar  names2+pats @  [fp,gp,hp,kp,xp,yp,zp] = map hsPVar  names2+typs @  [ft,gt,ht,kt,xt,yt,zt] = map hsTyVar names2++cons @  [ac,bc,cc,dc,ec,tc,sc] = map hsECon  names3+tcons @ [at,bt,ct,dt,et,tt,st] = map hsTyCon names3++ap2 [x] = x+ap2 (x:y:xs) = ap2((hsApp x y):xs)++apt [x] = x+apt (x:y:xs) = apt((hsTyApp x y):xs)++arr = hsTyFun+++class1 = hsClassDecl loc [] (apt [ct,xt])+           [ hsTypeSig loc [fn] [] (xt `arr` xt) ]+class2 = hsClassDecl loc [apt[ct,yt]] (apt [dt,yt])+           [ hsTypeSig loc [gn] [] (yt `arr` yt) ]+class3 = hsClassDecl loc [apt[at,yt,xt]] (apt [et,yt,yt])+           [ hsTypeSig loc [zn] [] (yt `arr` yt) ]         ++inst0 = hsInstDecl loc [] (ct) []+inst0'= hsInstDecl loc [] (xt) []+inst1 = hsInstDecl loc [] (apt [ct,xt]) []+inst2 = hsInstDecl loc [] (apt [ct,apt [dt,xt,xt]]) []+inst3 = hsInstDecl loc [] (apt [ct,apt [dt,at]]) []+inst4 = hsInstDecl loc [apt [dt,xt]] (apt [ct,tt]) []+inst5 = hsInstDecl loc [] (apt [ct,at]) []+inst6 = hsInstDecl loc [] (yt `arr` yt) []++data1 = hsDataDecl loc [] [tt] [HsConDecl loc cn []] []+data2 = hsDataDecl loc [] [tt,xt] [] []+data3 = hsDataDecl loc [] [tt] [HsConDecl loc cn [HsBangedType yt]+                             ,HsConDecl loc dn [HsUnBangedType at]+                             ,HsConDecl loc dn []+                             ] []+data4 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType st]] []+data5 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType (apt [st,xt])]] []+data6 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType (apt [st,xt,yt])]] []+data7 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType (apt [st,xt,yt,yt])]] []++type1 = hsTypeDecl loc [st,xt,yt] (hsTyTuple [xt,yt])+sig1  = hsTypeSig loc [zn] [] (apt [st,xt])++p0 = [class1,class2,class3,inst1,inst2,inst3]+p1 = [inst2]+p2 = [class1,class1,data1,data2,inst4,inst5]++run env prog  = let (f,x) = chDs TopDecl prog in x(f env)+ss  = run env0 ++showErr (SrcLoc f n m, s) = "(" ++ show n ++ ", " ++ show m ++ ") " ++ s++sck ds = (putStr . unlines . map showErr . ss) ds+        +test prog = do {sh prog; putStr "\n------------\n"; sck prog}++testDs :: (String,[HsDecl]) -> IO ()+testDs (s, ds) = +         do { putStr "\n==============================================\n"+            ; putStr s+            ; putStr "\n--- test code----------\n"+            ; sh ds+            ; putStr "\n--- errors ------------\n"+            ; (putStr . unlines . map showErr . run env0) ds+            }++tests ts = sequence_ $ map testDs ts++insts :: [(String, [HsDecl])]+insts = [ ("Ill formed instance type", [ hsInstDecl loc [] (ct) [] ] )+        , ("Ill formed instance type", [ hsInstDecl loc [] (xt) [] ])+        , ("Ill formed instance type", [hsInstDecl loc [] (apt [ct,xt]) []])+        , ("Undefined class & type" , [hsInstDecl loc [] (apt [ct,dt]) []])+        , ("Duplicate type vars", +                [ hsDataDecl  loc [] [dt] [] []+                , hsClassDecl loc [] (apt [ct,xt]) []+                , hsInstDecl loc [] (apt [ct,apt [dt,xt,xt]]) []])+        , ("Argument to TyCon must be tyvar", [hsInstDecl loc [] (apt [ct,apt [dt,at]]) []])+        , ("Many undefined", [hsInstDecl loc [apt [dt,xt]] (apt [ct,tt]) []])+        , ("Type synonym illegal",   +                 [ hsTypeDecl  loc [at] bt+                 , hsDataDecl  loc [] [bt] [] []+                 , hsClassDecl loc [] (apt [ct,xt]) []+                 , hsInstDecl  loc [] (apt [ct,at]) []+                 ])+        , ("Context errors", +                [ hsDataDecl  loc [] [at] [] []+                , hsDataDecl  loc [] [bt,xt] [] []+                , hsClassDecl loc [] (apt [ct,xt]) []+                , hsClassDecl loc [] (apt [dt,xt]) []+                , hsInstDecl  loc [xt] (apt [ct,at]) []+                , hsInstDecl  loc [dt] (apt [ct,at]) []+                , hsInstDecl  loc [apt[dt,apt[xt,yt]]] (apt [ct,apt [bt,xt]]) []+                ])+        , ("",+                [ hsDataDecl  loc [] [at] [] []+                , hsClassDecl loc [] (apt [ct,xt]) [ hsTypeSig loc [fn] [] (xt `arr` xt) ]+                , hsInstDecl  loc [] (apt [ct,at]) +                        [ hsTypeSig loc [fn] [] (xt `arr` xt) +                        , hsFunBind loc [HsMatch loc fn [xp] (HsBody(hsEVar xn)) []] +                        , hsFunBind loc [HsMatch loc gn [xp] (HsBody(hsEVar yn)) []] +                        ]+                ])+        , ("OK", [ hsDataDecl  loc [] [at] [] []+                 , hsDataDecl  loc [] [bt,xt] [] []+                 , hsClassDecl loc [] (apt [ct,xt]) []+                 , hsClassDecl loc [] (apt [dt,xt]) []+                 , hsInstDecl  loc [] (apt [ct,at]) []+                 , hsInstDecl  loc [apt [dt,xt]] (apt [ct,apt [bt,xt]]) []+                 ])+        , ("class/type name conflict", +                 [ hsDataDecl  loc [] [at] [] []+                 , hsDataDecl  loc [] [bt] [] []+                 , hsInstDecl loc [] (apt [at,bt]) []+                 , hsInstDecl loc [] (apt [ct,bt]) []+                 ] )+                           +        ]++dts  = [ ("", [ hsDataDecl  loc [] [at,bt] [] [] ] )+       , ("", [ hsDataDecl  loc [] [xt,yt] [] [] ] )+       ]++clss = [ ("OK", [hsClassDecl loc [] (apt [ct,xt]) []])+       , ("ill formed class specification", [hsClassDecl loc [] (ct) []])+       , ("ill formed class specification", [hsClassDecl loc [] (xt) []])+       , ("class/type name conflict", +                [ hsDataDecl  loc [] [at] [] []+                , hsDataDecl  loc [] [bt] [] []+                , hsClassDecl loc [] (apt [at,xt]) []+                , hsClassDecl loc [] (apt [bt,xt]) []+                ] )+       , ("ill formed class specification", +                [  hsClassDecl loc [] (apt [ct,at]) []+                ] )+       , ("ill formed class specification", +                [  hsClassDecl loc [] (apt [ct,at]) []+                ,  hsClassDecl loc [] (apt [dt,at]) []+                ] )+       , ("ill formed class specification", +                [ hsDataDecl  loc [] [at] [] []+                , hsClassDecl loc [] (apt [ct,at]) []+                ] )+       , ("",+                [  hsClassDecl loc [] (apt [ct,xt])+                   [ hsTypeSig loc [fn] [] (arr xt xt)+                   , hsPatBind loc fp (HsBody (hsLambda [xp] xe)) []+                   , hsPatBind loc gp (HsBody (hsLambda [xp] xe)) []+                   ]+                ] )+       ]+      +patBind p e = hsPatBind loc p (HsBody e) []++d1 = [patBind fp (hsLambda [xp] xe), patBind fp (hsLambda [xp] (xe))]+{-+p2 = [hsTypeSig loc [zn] (TypeUnQual$ hsTyCon (UnQual "Int"))]+p3 = [hsTypeSig loc [yn,yn] (TypeUnQual $ Typ $ HsTyCon (UnQual "Int"))]+p4 = [patBind fp (hsLet [patBind xp ye] xe)]+p5 = [patBind fp (hsLambda [xp] (ye))]+p6 = [patBind fp (hsLambda [hsPTuple [xp, xp], xp] ye)]+p7 = [patBind fp (hsLambda [hsPTuple [xp, xp, xp], xp] ye)]++runP p = let (envt,f) = chP loc p in f (envt env0)+-}++-----------------------------------------------------------------------------+-- computing free variables+-- Computing free variables is a tricky computation, because the same variable+-- may be free in one spot and bound in another. We need an environment to+-- determine what variables are bound at any particular point. We use a list+-- of HsName as the environment++-- Given an expression and an environment telling what vars are bound+-- determine the free variables in the expression.++freeE :: HsExp -> [HsName] -> [HsName]+freeE (Exp x) env = +  case scopE env (mapE freeE freeP freeD freeT freeC x) of+    HsId(HsVar s) -> if elem s env then [] else [s]+    HsInfixApp x (HsVar s) y -> if elem s env then [] else [s]+    HsLeftSection x (HsVar s) -> if elem s env then [] else [s]+    HsRightSection (HsVar s) x -> if elem s env then [] else [s]+    x -> accE (++) (++) (++) (++) (++) x []+            ++-- Return a pair of functions. The first is an env transformer, adding+-- the vars in the pattern, the second is a function given an env, which+-- determines the free vars in the pattern. The second is the constant []+-- function since patterns only introduce variables, they only have binding+-- occurences.++freeP :: HsPat -> ([HsName]->[HsName],[HsName]->[HsName])+freeP p = ((vs++),const [])+  where vs = boundInP p []+        +-- Return a pair of functions. The first is an env transformer, adding+-- the vars declared by the list of Decls, the second is a function which+-- when given an env, determines the free vars in the Decls ++freeD :: [HsDecl] -> ([HsName]->[HsName],[HsName]->[HsName])+freeD ds = (ext,free)+  where bound = foldr add [] ds+        ext env = bound ++ env +        add (Dec (HsPatBind s p rhs ds)) env = boundInP p env+        add (Dec (HsFunBind s ((HsMatch s2 nm ps rhs ds):_))) env  = nm : env+        add (Dec (HsDataDecl s ctx typats condecls derivings)) env =+           getTyName (head typats) : env+        add (Dec (HsTypeDecl s typats t)) env = getTyName (head typats) : env+        add d env = env+        getNameOfTypat (Typ x) = +             case x of +               HsTyApp l _ -> getNameOfTypat l+               HsTyCon n   -> n+               HsTyVar n   -> n +               _           -> error "getNameOfTypat "+        free env = (foldr (f env) [] ds) \\ bound +        f env (Dec d) ans = +          accD (++)(++)(++)(++)(++)(++)+               (scopD env (mapD (\ x -> ( (freeE x))) freeP freeD freeT freeC freeTP d)) ans+ff env (Dec d) ans = +          accD (++)(++)(++)(++)(++)(++)+               (scopD env (mapD (\ x -> ( (freeE x))) freeP freeD freeT freeC freeTP d)) ans          +++instance Env [HsName] where+  extClass n l a args env = env+  extTconstr n l a b  env = n:env+  extTvar n           env = n:env+  extConstr n l a     env = n:env+  extVar n l          env = n:env+  extSig n l          env = env+  extMod n            env = env+  env0 = []+  restrictTvar env = env+++-- Given an environment holding bound variables, return the +-- free variables in the HsType++freeT :: HsType -> [HsName] -> [HsName]+freeT (Typ x) env = +  case scopT env (mapT freeT x) of+    HsTyCon n -> if elem n env then [] else [n]    +    HsTyVar n -> if elem n env then [] else [n]+    x         -> accT (union) x []++allFree :: HsType -> [HsName] -> [HsName]+allFree (Typ x) ans = +  case x of+    HsTyCon n -> union [n] ans+    HsTyVar n -> union [n] ans+    x         -> accT allFree x ans+++-- compute the free variables in a context.++freeC :: [HsType] -> [HsName] -> [HsName]+freeC x env = concat (map (\z -> freeT z env) x)++-- Type patterns are HsTYpes which act as binding occurences. Hence+-- they return a pair. First an env transformer, and Second a function+-- that given an env, computes the TypePatterns free variables. Like patterns+-- this always returns []++freeTP :: HsType -> ([HsName] -> [HsName],[HsName] -> [HsName])+freeTP x = (allFree x,const [])+++makeSCC ds env =+  let (envtrans,_) = freeD ds +      bound = envtrans []+      oneD d = let (_,free) = freeD [d] in free env+      oneBind d = let (envt,_) = freeD [d] in envt []+      allFree  = map oneD ds+      allBound = map oneBind ds +  in (allFree,allBound)++--------------------------------------------------------------------------+-- Contexts+--------------------------------------------------------------------------++-- type patterns appear in 4 different contexts++data TPContext = DataLikeTP | ClassTP | InstTP | SigTP+instance Show TPContext where+  show DataLikeTP = "type, data, or newtype declaration"+  show ClassTP    = "class declaration"+  show InstTP     = "instance declaration"+  show SigTP      = "type signature" +++-----------------------------------------------------------------+-- Lists of declarations can appear in four different contexts+-- Only certain kinds of declarations are legal in some of these.++data DeclContext = TopDecl | ClassDecl | InstDecl | WhereLikeDecl deriving (Eq)+instance Show DeclContext where+  show TopDecl       = "top level"+  show ClassDecl     = "class declaration"+  show InstDecl      = "class declaration"+  show WhereLikeDecl = "local declaration"++legal :: DeclContext -> HsDecl -> Maybe Error+legal context (d @ (Dec x)) =+  let err context x = Just (srcloc x,+                "Illegal "++ whatIs x ++" in " ++ show context)+  in  case (context,x) of+      (TopDecl,   any)                             -> Nothing+      (ClassDecl, HsTypeSig _ _ _ _)               -> Nothing+      (ClassDecl, HsFunBind _ _)                   -> Nothing+      (ClassDecl, HsPatBind _ (Pat(HsPId(HsVar _))) _ _) -> Nothing+      (ClassDecl, any)                             -> err context x+      (InstDecl,  HsFunBind _ _)                   -> Nothing+      (InstDecl,  HsPatBind _ (Pat(HsPId(HsVar _))) _ _) -> Nothing+      (InstDecl,  any)                             -> err context x+      (WhereLikeDecl, HsTypeSig _ _ _ _)           -> Nothing+      (WhereLikeDecl, HsFunBind _ _)               -> Nothing+      (WhereLikeDecl, HsPatBind _ _ _ _)           -> Nothing+      (WhereLikeDecl, any)                         -> err context x++-----------------------------------------------------------------------+-- MapD' is like mapD, except it know what kind of contexts are+-- appropriate and passes this information downwards++mapD' :: (a -> b) -> (c -> d) -> (DeclContext -> e -> f) -> (g -> h) -> (DeclContext -> i -> j)+                  -> (TPContext -> k -> l) -> D a c e g i k -> D b d f h j l+mapD' ef pf df tf cf tpf decl =+   case decl of+    HsTypeDecl s tps t -> +        HsTypeDecl s (map (tpf DataLikeTP) tps) (tf t)+    HsNewTypeDecl s cntxt tps cd names ->+        HsNewTypeDecl s (cf TopDecl cntxt)+              (map (tpf DataLikeTP) tps) (mapConDecl tf cd) names+    HsDataDecl s cntxt tps cds names   ->+        HsDataDecl s (cf TopDecl cntxt)+               (map (tpf DataLikeTP) tps)+               (map (mapConDecl tf) cds) names+    HsClassDecl s c tp ds                   ->+        HsClassDecl s (cf ClassDecl c) (tpf ClassTP tp) (df ClassDecl ds)+    HsInstDecl s c tp ds                    ->+        HsInstDecl s (cf InstDecl c) (tpf InstTP tp) (df InstDecl ds)+    HsDefaultDecl s t -> +        HsDefaultDecl s (tf t)+    HsTypeSig s nms c t                  ->+        HsTypeSig s nms (cf TopDecl c) (tpf SigTP t)+    HsFunBind s matches                   ->+        HsFunBind s (map (mapMatch ef pf (df WhereLikeDecl)) matches)+    HsPatBind s p rhs ds                  ->+        HsPatBind s (pf p) (mapRhs ef rhs) (df WhereLikeDecl ds)+    HsPrimitiveTypeDecl s cntxt nm        -> +        HsPrimitiveTypeDecl s (cf TopDecl cntxt) nm+    HsPrimitiveBind s nm t                ->+        HsPrimitiveBind s nm (tf t) -- Hugs compatibility+++ +-------------------------------------------------------------------+-------------------------------------------------------------------+-- Static Checking using Bind based scoping++-------------------------------------------------------------------------+-- Example extend function for the static env Senv of the static checker+++-- extTvar nm env = env {tvarNames = (nm) : tvarNames env}  + +extend :: Bind -> Senv -> Senv+extend (Bpat loc pat) env = foldr extName env uniqueNames+        where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])+              extName nm env = env {varNames = (nm,loc) : varNames env}+extend (Bpats loc ps) env = foldr extend env (map (Bpat loc) ps)+extend (Bdecls ds) env = allNames ds env+extend (Bname loc nm) env = env {varNames = (nm,loc) : varNames env}+extend (Btypat tag tp) env = +  case tag of+        ClassTag ->  -- (Env e x)         -- expects (C v1 ... vn)+          let (constr, tvs) = typePatToParts tp+          in foldr extTvar env tvs +        InstTag  ->  -- (Env [Int] Bool)  -- expects (C t1 ... tn)+          let (classname, ts) = instPatToParts tp+              (tvs, cs) = foldr allTypNames ([], []) ts+          in foldr extTvar env tvs +        SigTag   ->  -- (e : typ) +          let (tvs, cs)     = allTypNames tp ([], [])             +          in foldr extTvar env tvs+extend (Btypats tag (tps @ (constr : args))) env = +   case tag of+     DataTPS -> foldr (\ t e -> extTvar (getTyName t) e) env tps+     TypeTPS -> foldr (\ t e -> extTvar (getTyName t) e) env args+    +staticlib = Sc extend restrictTvar    ++------------------------------------------------------------------+-- Static checks for expressions ++checkE :: SrcLoc -> HsExp -> Senv -> [Error]+checkE loc (exp @ (Exp x)) env =+  case scopeE staticlib env +         (mapE (checkE loc) (checkP loc)+               (checkDs WhereLikeDecl) (checkT loc) (checkCnxt loc WhereLikeDecl)  x) of+    HsId (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsInfixApp x (HsVar n) y -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsLeftSection x (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsRightSection (HsVar n) x -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsLambda ps e -> e ++ (checkPList loc env ps)+    z -> accE (++) (\ (nm,err) a -> err ++ a) (++) (++) (++) z []+    +-----------------------------------------------------------------------------+-- When language constructs have a list of patterns like : (\ p1 ... pn -> e)+-- or (case x of { C p1 ... pn -> e }), Haskell has the rule that no variable+-- should appear more than once in the list. We can't check this, pattern by+-- pattern, but have to observe the complete list. If we map (chP env) over a+-- list of patterns we get [([unique_names],[error_messages])], from this we+-- can compute additional error_messages dealing with duplicates.++checkPList :: SrcLoc -> Senv -> [([HsName],[Error])] -> [Error]      +checkPList loc env ps =+ let accumulate (ns,errs) (names,errors) = (ns++names,errs++errors)+     (allbound,internalerr) = foldr accumulate ([],[]) ps+     dups = duplicates allbound+     duperr = chk loc (not (null dups)) (repeated_pattern_variables dups)+ in internalerr ++ duperr++--------------------------------------------+-- Static checks for individual patterns++checkP ::  SrcLoc -> HsPat -> (HsPat, Senv -> ([HsName],[Error]))+checkP loc (pat @ (Pat x)) = (pat, f)+  where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])+        duperr = chk loc (not (null dups)) (duplicate_vars_in_pattern dups)+        f env = (uniqueNames,allErrors env)+        allErrors env = foldr arityCheck duperr constrArities+          where arityCheck (c,n) ans = check c n (cArity c env) ++ ans+                check c n Nothing  = [(loc,undefined_constr c)]+                check c n (Just m) = chk loc (m /=n) (constr_wrong_arity n c)+++------------------------------------------------------------------------------+-- Static Check for Expressions++-- checkDs assumes that all the names in the [Decl] have already been added+-- to the environment which is passed to checkDs result function.+-- e.g. in scopeE for HsLet we say:+--    HsLet (ds,f) e -> +--       let env2 = ext (Bdecls ds) env +--       in  HsLet (f env2) (e env2)+-- note how we compute the new env, and pass it to both the ds and the f++checkDs ::  DeclContext -> [HsDecl] -> ([HsDecl],Senv -> [Error])+checkDs contxt ds = (ds,errorfun)+  where env      = allNames ds env0+        errorfun env = foldr (\ d ans -> (check env d) ++ ans) allErrors ds+        sameName (x,y) (a,b) = compare x a+        contextErrors = catMaybes $ map (legal contxt) ds+        dupErr k message = collect_duplicate_info (dupErrs message) sameName (locations k env)+        dupValErrors  = dupErr Var    "value definitions"+        dupSigErrors  = dupErr Sig    "type signatures"+        dupClsErrors  = dupErr Class  "class definitions"+        dupTypErrors  = dupErr TyCons "type definitions"+        dupConsErrors = dupErr Cons   "constructor functions"++        allErrors = contextErrors++dupValErrors++dupSigErrors++dupClsErrors+                    ++ dupTypErrors ++ dupConsErrors ++ nmConflict env ++ clsMethodErr+        sigerr loc name = chk loc ((not $ elem name (map fst (varNames env))) && contxt/=ClassDecl)+                                  (signature_without_definition name)+        methodErr c (nm,loc) = chk loc (not $ isMethod nm c env) (not_a_method nm c)+        clsMethodErr = case contxt of +                       ClassDecl -> classMethodErr env+                       other     -> []+        check env (Dec x) =+          let loc = srcloc x+              methodErrs (HsInstDecl loc c tp ds) = +                let nms = varNames $ allNames ds env0+                in  case getClass tp of+                     Nothing -> []+                     Just c  -> concat $ map (methodErr c) nms+          in+           case scopeD staticlib env +                  (mapD' (checkE loc) (checkP loc) (checkDs) +                         (checkT loc) (checkCnxt loc) (checkTp loc) x) of+             HsTypeSig loc nms c t  -> (concat $ map (sigerr loc) nms)++c++t+             HsInstDecl loc c tp ds -> methodErrs x ++ c ++ tp ++ ds+             z -> accD (++) (\ (ns,errs) a -> (errs)++a) (++) (++) (++) (++) z []++---------------------------------------------------------------------------+-- static checks for types++checkT ::  SrcLoc -> HsType -> Senv -> [Error]+checkT loc (typ @ (Typ t)) env = +  case t of +   HsTyVar nm -> chk loc (not (tvarDefined nm env)) (undefined_tvar nm)+   HsTyCon nm -> chk loc (not (tconDefined nm env)) (undefined_tcon nm)+   HsTyApp (y @ (Typ f)) x -> synArityCheck (checkT loc) env f x 1+   z -> accT (++) (scopeT env (mapT (checkT loc)  z)) []++synArityCheck chf env typ arg n = +  case typ of+    (HsTyCon c) -> +       case synArity c env of+         Nothing -> chk loc (not (tconDefined c env)) (undefined_tcon c) ++ chf arg env +         Just m  -> chk loc (m/=n) (tysynonym_not_fully_applied c) ++ chf arg env+    (HsTyApp (Typ f) x) -> synArityCheck chf env f x (n+1) ++ chf arg env+    t -> chf (Typ t) env ++ chf arg env+   +----------------------------------------------------------------------+-- Static Checking for contexts++checkCnxt :: SrcLoc -> DeclContext -> [HsType] -> Senv -> [Error]++checkCnxt loc c ts env = foldr (check c) [] ts+  where inscope (Typ (HsTyVar x)) ans = +            chk loc (not $ tvarDefined x env) (undefined_tvar_in_context x) ++ ans+        inscope (Typ (HsTyCon c)) ans = +            chk loc (not $ classDefined c env) (undefined_class_in_context c) ++ ans +        inscope (Typ x) ans  = accT inscope x ans ++        -- class: C (x t*)++        wfClass t (Typ (HsTyApp (Typ (HsTyCon c)) x )) xs =+           wfClassArg x x xs+        wfClass t (Typ (HsTyApp x y ))                 xs =+           wfClass t x $ wfClassArg x x xs+        wfClass t (Typ x)                              xs =+           (loc, illformed_class t) : xs++        -- class arg: x t*+        wfClassArg t (Typ (HsTyVar y))   xs = xs+        wfClassArg t (Typ (HsTyApp x _)) xs = wfClassArg t x xs +        wfClassArg t (Typ x)             xs = (loc, illformed_class_arg t) : xs++        check ClassDecl x ans = wfSclass loc x (inscope x ans)+        check InstDecl  x ans = wfSclass loc x (inscope x ans)+        check _         x ans = wfClass  x x   (inscope x ans)+++---------------------------------------------------------------------+-- Static checks for type-patterns++--checkTp ::  SrcLoc -> TPContext -> HsType -> (HsType,Senv -> [Error])+checkTp :: SrcLoc ->  TPContext -> HsType -> (HsType, Senv -> [Error])++checkTp srcloc InstTP x =+  let errors = wf x []+      -- well formed instance: C (C x*)+++      wf (Typ(HsTyApp (Typ(HsTyCon c)) arg)) xs =+         wfTp srcloc InstTP arg xs+      wf (Typ(HsTyCon c)) xs                 =+         (srcloc, instance_required c) : xs +      wf (Typ(HsTyApp y arg)) xs             =+         wf y (wfTp srcloc InstTP arg xs)+      wf tp xs                               =+         (srcloc, instance_not_class_app tp) : xs++      (classname, ts) = instPatToParts x+      (tvs, cs) = foldr allTypNames ([], []) ts+      clsError env = chk srcloc (not $ classDefined classname env) +                                (undefined_class_in_instance classname)+      cdef env c ans = +         if tconDefined c env +         then case synArity c env of+              Nothing   -> ans+              Just _    -> (srcloc, synonym_illegal_in_instance c):ans+         else (srcloc,undefined_tcon_in_instance c):ans+      dupErrs = collect_duplicate_info (dupTvErr srcloc) compare tvs+      tpf env = if null errors+                then foldr (cdef env) (dupErrs ++ clsError env) cs+                else errors+  in (x, tpf)                ++checkTp srcloc SigTP x =+  let (_, cs)     = allTypNames x ([], [])+      cdef env c ans = +         if tconDefined c env +         then ans+         else (srcloc, undefined_tcon_in_signature c):ans+      tpf env = foldr (cdef env) [] cs+  in  (x, tpf)++checkTp srcloc cntxt x =+  let (_, tvs) = typePatToParts x+      errors = case cntxt of DataLikeTP ->  wfTp     srcloc cntxt x []+                             ClassTP    ->  wfSclass srcloc       x []+      tpf env   = if null errors +                  then collect_duplicate_info (dupTvErr srcloc) compare tvs+                  else errors+  in (x, tpf)++-----------------------------------------------------------------+-- Running the basic tests++run2 env prog  = let (ds,f) = checkDs TopDecl prog in (f (allNames ds env))++new (_,x) = run2 env0 x+old (_,x) = run env0 x++test2 :: (String,[HsDecl]) -> IO ()+test2 (s, ds) = +         do { putStr "\n==============================================\n"+            ; putStr s+            ; putStr "\n--- test code----------\n"+            ; sh ds+            ; putStr "\n--- errors ------------\n"+            ; (putStr . unlines . map showErr . run2 env0) ds+            }++tests2 ts = sequence_ (map test2 ts)++errors1 ts = map (run2 env0) (map snd ts) +errors2 ts = map (run env0) (map snd ts)        +             +new1 = errors1 insts       +old1 = errors2 insts++oks = zipWith (==) old1 new1+++[x0,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11] = insts++gg x = concat(map (\ (y,_,_,_) -> show y) (classNames x))+------------------------------------------------------------------+-- extra stuff++++-- supply a unique integer string+count :: IORef Int+count = unsafePerformIO $ newIORef 0+initCount = writeIORef count 10+incCount a = unsafePerformIO $ do { c <- readIORef count+                                  ; writeIORef count $! (c+1)+                                  ; return c+                                  }++uniqueStr a = show $ incCount ()
+ tools/base/SA/ScopeStruct.hs view
@@ -0,0 +1,1040 @@+-- $Id: ScopeStruct.hs,v 1.4 2001/10/22 23:33:49 hallgren Exp $++-- This module implements the static checker, and is way too big and really+-- must be split up some day.++module Scope(Senv(..),+             patBound,+             names,+             allNames,+             allTypNames,+             instPatToParts,+             typePatToParts,+             boundInP,+             fst3,+             fst4,+             env0,+             freeT,+             freeC,+             freeD,+             restrictTvar,+             test)+where ++import Syntax+import List(find, nub, nubBy, (\\), sortBy, groupBy, union)+--import Observe+import PrettyPrint+import Maybe+import SyntaxUtil(isTyVar, getTyName)+import Scope2+import HsConstants+import GenSym(newName)+++fst3 (a, _, _) = a+snd3 (_, b, _) = b+thd3 (_, _, c) = c++fst4 (a, _, _, _) = a+snd4 (_, b, _, _) = b+thd4 (_, _, c, _) = c+fth4 (_, _, _, d) = d++------------------------------------------------------------------+-- Environments+------------------------------------------------------------------++-- What kind of names are introduced by a declaration? +-- Classes, Types, Data Constructors, Variables, Signatures, and Modules+-- So we define an abstract class for environments, which has an empty+-- environment, env0, and extension functions for each kind of name.++type Arity = Int++data KindOfName+    = Var+    | Cons+    | TyVar+    | TyCons+    | Class+    | Mod+    | Sig++data KindOfTyCons+    = DataDef+    | NewTypeDef+    | TypeDef++class Env env where+    extClass     :: HsName -> SrcLoc -> Arity  -> [HsName] -> env -> env+    extTconstr   :: HsName -> SrcLoc -> Arity  -> Bool     -> env -> env+    extTvar      :: HsName                                 -> env -> env+    extConstr    :: HsName -> SrcLoc -> Arity              -> env -> env+    extVar       :: HsName -> SrcLoc                       -> env -> env+    extSig       :: HsName -> SrcLoc                       -> env -> env+    extMod       :: HsName                                 -> env -> env+    env0         :: env+    restrictTvar :: env    -> env++-------------------------------------------------------------------------------+-- A concrete class for environments appropriate for static Checking++type Error = (SrcLoc, String)++locations :: KindOfName -> Senv -> [(HsName, SrcLoc)]+locations k env =+    case k of+    Var    -> varNames env+    Sig    -> sigNames env+    Cons   -> map (\(nm, loc, arity)        -> (nm, loc)) $ constrNames  env+    Class  -> map (\(nm, loc, arity, nms)   -> (nm, loc)) $ classNames   env+    TyCons -> map (\(nm, loc, arity, issyn) -> (nm, loc)) $ tconstrNames env+    other  -> error "ScopeStruct.locations: no locations available"++data Senv+    = S { classNames   :: [(HsName, SrcLoc, Arity, [HsName])],+          tconstrNames :: [(HsName, SrcLoc, Arity, Bool)],+          tvarNames    :: [HsName],+          constrNames  :: [(HsName, SrcLoc, Arity)],+          varNames     :: [(HsName, SrcLoc)],+          sigNames     :: [(HsName, SrcLoc)],+          moduleNames  :: [HsName]+        }+      deriving Show++instance Env Senv where +    extClass nm l a nms env =+        env { classNames = (nm, l, a, nms) : classNames env }   ++    extTconstr nm l a syn env =+        env { tconstrNames = (nm, l, a, syn) : tconstrNames env }+ +    extTvar nm env = env { tvarNames = nm : tvarNames env }++    extConstr nm l a env = env { constrNames  = (nm, l, a) : constrNames env }++    extVar nm l env = env { varNames = (nm, l) : varNames env }++    extSig nm l env = env { sigNames = (nm, l) : sigNames env }+ +    extMod nm env = env { moduleNames = nm : moduleNames  env }++    env0 = S [] [] [] [] [] [] []++    restrictTvar env = env { tvarNames = [] }+++concatEnv :: Senv -> Senv -> Senv+concatEnv (S a b c d e f g) (S a' b' c' d' e' f' g') = +        S (a ++ a') (b ++ b') (c ++ c') (d ++ d') (e ++ e') (f ++ f') (g ++ g')++varDefined   s env = any (== s) $ map fst  $ varNames env+classDefined s env = any (== s) $ map fst4 $ classNames env+tvarDefined  s env = any (== s)            $ tvarNames env+tconDefined  s env =+    (any (== s) $ map fst4 $ tconstrNames env) ||+    (any (== s) [unit_con_name, list_tycon_name])++sigExists s env = any (==s) $ map fst $ sigNames env++isMethod nm c env = case classMethods c env of+                    Just nms -> nm  `elem` nms+                    Nothing  -> False++classMethods :: HsName -> Senv -> Maybe [HsName]+classMethods nm env = fmap fth4 (find match (classNames env))+   where match (name, _, _, _) = name == nm+         match _               = False++synArity :: HsName -> Senv -> Maybe Int+synArity nm env = fmap thd4 (find match (tconstrNames env))+   where match (name, _, _, True) = name == nm+         match _                  = False+   ++cArity :: HsName -> Senv -> Maybe Int+-- cArity (UnQual ":")                    _ = Just 2 -- shouldn't appear unqaul+cArity (Qual (Module "Prelude") ":")   _ = Just 2+-- cArity (UnQual "()")                   _ = Just 0 -- shouldn't appear unqaul+cArity (Qual (Module "Prelude") "()" ) _ = Just 0+cArity c env = fmap thd3 (find match (constrNames env))+   where match (name, _, _) = name == c++-- expects C x*+typePatToParts t = extractConArgs t []+  where extractConArgs (Typ (HsTyCon c))                   acc = (c, acc)+        extractConArgs (Typ (HsTyApp f (Typ (HsTyVar x)))) acc =+            extractConArgs f (x:acc)+        extractConArgs t                                   acc =+            (UnQual newName, acc)++--expects C t*+instPatToParts t = extractInstArgs t []+  where extractInstArgs (Typ (HsTyApp (Typ(HsTyCon c)) x)) acc = (c, acc)+        extractInstArgs (Typ (HsTyApp f x))                acc =+            extractInstArgs f (x:acc)+        extractInstArgs _                                  acc =+            error ("ill formed instance pattern:\n\n" ++ pp t)++------------------------------------------------------------------+-- Given a list of mutually recursive declarations, what names are+-- introduced in the scope of those declarations?++namesD d =+    case d of+    HsTypeDecl s (nm:args) body ->+        env0 { tconstrNames = [(getTyName nm, s, length args, True)] }++    HsNewTypeDecl s cntxt (c:args) body der ->+        env0 { tconstrNames   = [(getTyName c, s, length args, False)] +             , constrNames = [dataName body]+             , varNames    = recordName body+             }++    HsDataDecl s cntxt (c:args) constrs der -> +        let addConstr x xs = (dataName x) : xs+            addVar    x xs = (recordName x) ++ xs+        in+            env0 { tconstrNames = [(getTyName c, s, length args, False)]+                 , constrNames  = foldr addConstr [] constrs+                 , varNames     = foldr addVar    [] constrs+                 }++    HsClassDecl s c tp ds ->+        let (con, args) = typePatToParts tp+            members  = sigNames $ allNames ds env0+        in+            env0 { varNames    = members+                 , classNames  = [(con, s, length args, map fst members)]+                 }++    HsInstDecl s c tp ds -> env0++    HsDefaultDecl s t -> env0++    HsTypeSig s nms c t -> env0 { sigNames = map (\nm -> (nm, s)) nms }++    HsFunBind _ ((HsMatch s nm ps rhs ds):_) -> env0 { varNames = [(nm, s)]}+    HsPatBind s p rhs ds ->+        env0 { varNames = map (\nm -> (nm, s)) $ boundInPat p [] }++    HsPrimitiveTypeDecl s c nm ->  +        env0 { tconstrNames = [(nm, s, 0, False)] }++    HsPrimitiveBind s nm typ -> env0 { varNames = [(nm, s)] }       ++    _ -> env0++dataName (HsConDecl s nm slots) = (nm, s, length slots)+dataName (HsRecDecl s nm slots) = (nm, s, length slots)++recordName :: HsConDecl t -> [(HsName, SrcLoc)] +recordName (HsConDecl s nm slots) = []+recordName (HsRecDecl s nm slots) = foldr addField [] slots+    where addField (names, domain) xs = map (\nm -> (nm, s)) names ++ xs+  +allNames :: [HsDecl] -> Senv -> Senv  +allNames ds initial = foldr addDecl initial ds+  where addDecl d env = concatEnv (names d) env ++----------------------------------------------------------------------         +-- Generic Static checking functions++duplicates :: Eq a => [a] -> [a]+duplicates []     = []+duplicates (x:xs) = +  if elem x xs+  then x : duplicates (filter (/= x) xs)+  else duplicates xs++collect_duplicate_info :: ([a] -> [b]) -> (a -> a -> Ordering) -> [a] -> [b]+collect_duplicate_info infof compare = +    concat . map infof . groupBy (lift compare) . sortBy compare+    where lift f x y = f x y == EQ++dupErrs :: (Show a, Show b) => b -> [(a, SrcLoc)] -> [Error]+dupErrs sort []  = []+dupErrs sort [x] = []+dupErrs sort xs@((nm, loc):_) =+    chk loc True (duplicate_things sort nm (map snd xs))++dupTvErr srcloc [x]    = []+dupTvErr srcloc (x:xs) = [(srcloc, duplicate_type_vars x)]++chk:: SrcLoc -> Bool -> String -> [Error]+chk loc test message = if test then [(loc, message)] else []++unique :: Eq a => [(a, b)] -> [(a, b)]+unique = nubBy (\(a, _) (b, _) -> a == b)+++------------------------------------------------------------------------------+-- Scope checking +------------------------------------------------------------------------------+nmConflict :: Senv -> [Error]+nmConflict env = +    let sameName (tn, tloc, _, _) errs =+            case find ((== tn) . fst4) (classNames env) of +            Nothing              -> errs+            Just (_, cloc, _, _) ->+                (tloc, type_class_conflict tn [tloc, cloc]) : errs+    in+        foldr sameName [] (tconstrNames env)++classMethodErr :: Senv -> [Error]+classMethodErr env = +   let sigExists (vn, vloc) errs =+         case find ((== vn) . fst) (sigNames env) of+           Nothing      -> (vloc, method_without_signature vn) : errs+           Just _       -> errs+   in+       foldr sigExists [] (varNames env)++type_class_conflict tn cloc = +    "Type name " ++ pp tn ++ " is used as class name "++ pp cloc ++method_without_signature vn = +    "Definition of " ++ pp vn  ++ " without declaration"++getClass (Typ (HsTyApp x _)) = getClass x+getClass (Typ (HsTyCon c))   = Just c+getClass _                   = Nothing++allTypNames (Typ (HsTyVar v)) (vs, cs) = (v : vs, cs)+allTypNames (Typ (HsTyCon c)) (vs, cs) = (vs,     c : cs)+allTypNames (Typ t)           ans      = accT allTypNames t ans++isTyConApp (Typ (HsTyCon _))   = True+isTyConApp (Typ (HsTyApp f _)) = isTyConApp f+isTyConApp _                   = False++getTyAppArgs (Typ (HsTyCon _))   args = args+getTyAppArgs (Typ (HsTyApp f x)) args = getTyAppArgs f (x:args)++-- Well formed type expression: C x*+wfTp :: SrcLoc -> TPContext -> HsType -> [Error] -> [Error]+wfTp srcloc c t errs =+    if isTyConApp t && all isTyVar (getTyAppArgs t []) then+        errs+    else+        (srcloc, type_former_is_not_constructor t c) : errs++-- well formed simple class specification: C x++wfSclass :: SrcLoc -> HsType -> [Error] -> [Error]+wfSclass loc t errs =+    if isTyConApp t && not (null args) && all isTyVar args then+        errs+    else+        (loc, illformed_sclass t) : errs+    where args = getTyAppArgs t []++ ++-------------------------------------------------------------------------++srcloc (HsTypeDecl          loc  _ _     ) = loc+srcloc (HsNewTypeDecl       loc  _ _ _ _ ) = loc+srcloc (HsDataDecl          loc  _ _ _ _ ) = loc+srcloc (HsClassDecl         loc  _ _ _   ) = loc+srcloc (HsInstDecl          loc  _ _ _   ) = loc+srcloc (HsDefaultDecl       loc  _       ) = loc+srcloc (HsTypeSig           loc  _ _ _   ) = loc+srcloc (HsFunBind           loc  _       ) = loc+srcloc (HsPatBind           loc  _ _ _   ) = loc+srcloc (HsPrimitiveTypeDecl loc  _ _     ) = loc+srcloc (HsPrimitiveBind     loc  _ _     ) = loc++whatIs (HsTypeDecl          _  _ _     ) = "type declaration"+whatIs (HsNewTypeDecl       _  _ _ _ _ ) = "newtype declaration"+whatIs (HsDataDecl          _  _ _ _ _ ) = "data declaration"+whatIs (HsClassDecl         _  _ _ _   ) = "class declaration"+whatIs (HsInstDecl          _  _ _ _   ) = "instance declaration"+whatIs (HsDefaultDecl       _  _       ) = "declaration"+whatIs (HsTypeSig           _  _ _ _   ) = "type signature"+whatIs (HsFunBind           _  _       ) = "function binding"+whatIs (HsPatBind           _  _ _ _   ) = "pattern binding"+whatIs (HsPrimitiveTypeDecl _  _ _     ) = "declaration"+whatIs (HsPrimitiveBind     _  _ _     ) = "declaration"+++--------------------------------------------------------------+-- The first kind of scoping and its combinators+--------------------------------------------------------------++scopE :: v ->+         E (v -> e)          -- env to expression+           (v -> v, v -> p)  -- env transformer and env to pattern+           (v -> v, v -> ds) -- env transformer and env to declaration+           (v -> t)          -- env to type+           (v -> c) ->       -- env to class+         E e p ds t c+scopE env e =+    case e of+    HsLet (envtrans, ds) b ->+        let env' = envtrans env +        in+            HsLet (ds env') (b env')++    HsLambda ps b ->+        let (env', ps') = scopPatList env ps  +        in+            HsLambda ps' (e env')++    HsCase c alts        -> HsCase (c env) (map (scopAlt env) alts)++    HsDo stmt            -> HsDo (scopStmt env stmt)++    HsListComp stmt      -> HsListComp (scopStmt env stmt)+    +    _ -> mapE (\ f -> f env)+              (error "missing HsExp case")  -- Isn't this the pattern one?+              (error "missing HsDecl case")+              (\ f -> f env)+              (\ f -> f env)+              e++scopAlt :: v ->+           HsAlt (v -> e)+                 (v -> v, v -> p)+                 (v -> v, v -> ds) ->+           HsAlt e p ds+scopAlt env (HsAlt s (pf, p) rhs (dsf, ds)) = +    let env' = dsf (pf env)+    in+        HsAlt s (p env) (scopRhs env' rhs) (ds env')++scopRhs :: v -> HsRhs (v -> e) -> HsRhs e+scopRhs env e = mapRhs (\ f -> f env) e++scopStmt :: v ->+            HsStmt (v -> e)+                   (v -> v, v -> p)+                   (v -> v, v -> ds) ->+            HsStmt e p ds+scopStmt env (HsGenerator (pf, p) e s) = +   let env' = pf env+   in+       HsGenerator (p env) (e env') (scopStmt env' s)+scopStmt env (HsQualifier e s) = HsQualifier (e env) (scopStmt env s)+scopStmt env (HsLetStmt (dsf, ds) s) = +   let env' = dsf env in HsLetStmt (ds env') (scopStmt env' s)+scopStmt env (HsLast e) = HsLast (e env)   ++scopPatList :: v -> [(v -> v, v -> p)] -> (v, [p])+scopPatList env ps = (foldr (\ (pf, _) e -> pf e) env ps,+                      map (\ (_, p) -> p env) ps)++--------------------------------------------------------------------------+-- Then for the declaration sub-language++scopD :: Env v => v -> +         D (v -> e)+           (v -> v, v -> p)+           (v -> v, v -> ds)+           (v -> t)+           (v -> c)+           (v -> v, v -> tp) -> +         D e p ds t c tp +scopD env d =+    let scopConDecl env = mapConDecl (\f -> f env) +        extendWithTvs env tvs = foldr extTvar env tvs+        scopMatch env (HsMatch loc nm ps rhs (dsf, ds)) = +            let (env', ps') = scopPatList env ps+                env'' = dsf $ extVar nm loc env'+            in +                HsMatch loc nm ps' (scopRhs env'' rhs) (ds env'')+    in +      case d of+        HsPatBind loc (pattrans, pf) rhs (dectrans, dsf) ->+         let env' = dectrans (pattrans env)+         in+             HsPatBind loc (pf env) (scopRhs env' rhs) (dsf env')++        HsFunBind loc matches -> HsFunBind loc (map (scopMatch env) matches)+    +        HsTypeDecl loc (transtpfs @ ((ctrans, cmaker):fs)) tf -> +         let env' = ctrans env+             constr = cmaker env+             (env'', args) = scopPatList env fs+         in+            HsTypeDecl loc (constr:args) (tf env'')+        +        HsNewTypeDecl loc contxtf transtpfs condecl derivs ->+         let (env', args) = scopPatList env transtpfs+             (env'', _) = scopPatList (restrictTvar env) (tail transtpfs)+         in+            HsNewTypeDecl+                loc (contxtf env'') args (scopConDecl env' condecl) derivs+    +        HsDataDecl loc contxtf transtpfs condecls derivs ->+         let (env', args) = scopPatList env transtpfs+             (env'', _) = scopPatList (restrictTvar env) (tail transtpfs)+         in+             HsDataDecl loc (contxtf env'') args+                            (map (scopConDecl env') condecls) derivs+    +        HsClassDecl loc contxtf (trans,tpf) (dectrans,dsf) ->    +         let env' = trans (restrictTvar env) +         in+             HsClassDecl loc (contxtf env') (tpf env) (dsf $ dectrans env') ++        HsInstDecl loc contxtf (trans, tpf) (dectrans, dsf) ->    +         let env' = trans (restrictTvar env) +         in+             HsInstDecl loc (contxtf env') (tpf env) (dsf $ dectrans env')++        HsTypeSig loc nms contxtf (transf, tpf)  ->+          HsTypeSig loc nms (contxtf (transf env)) (tpf env)+    +        _ -> mapD (\ f -> f env)+                  revApp+                  revApp+                  (\ f -> f env)+                  (\ f -> f env)+                  (error "type pattern")+                  d+             where revApp (trans, f) = f (trans env) +++--------------------------------------------------------------------------+-- Then for the type sub-language++scopT :: v -> T (v -> t) -> T t+scopT env t = mapT (\f -> f env) t ++--------------------------------------------------------------------------+-- Computing Things about patterns+--------------------------------------------------------------------------++boundInP bpat (HsPId (HsVar s)) ans = s:ans+boundInP bpat (HsPAsPat n p)    ans = bpat p (n:ans)+boundInP bpat p                 ans = accP bpat ans p++boundInP :: HsPat -> [HsName] -> [HsName]+boundInPat (Pat p) ans = boundInP boundInPat p ans+++------------------------------------------------------------------------+    -- patBound: Compute three things while visiting each pattern sub-node.+    -- 1) A list of unique names bound by the pattern+    -- 2) A list of names that appear more than once. +    --    These are errors because we allow only linear patterns+    -- 3) A list of every construtor and the arity at which it was used.+    --    These are potential errors if the arites do not match++pBound patB p ans =+    case p of+    HsPId (HsVar n)     -> add n ans+    HsPAsPat n p        -> patG p (add n ans) +    HsPApp c ps         -> cadd c (length ps) ans'+    HsPInfixApp p1 c p2 -> cadd (getHSName c) 2 ans'+    _                   -> ans'++    where add x (a, b, c) = +               if elem x a +                  then if elem x b +                          then (a, b, c)+                          else (a, x:b, c)  +                  else (x:a, b, c)+          cadd c n (x, y, z) = (x, y, (c, n):z)+          ans' = accP patB ans p++patBound :: HsPat -> ([HsName], [HsName], [(HsName, Int)]) -> +                     ([HsName], [HsName], [(HsName, Int)])+patBound (Pat p) ans = pBound patBound p ans+++------------------------------------------------------------------------------+-- Static Check for Expressions++chE :: (SrcLoc -> HsExp -> Senv -> [Error]) ->+       (SrcLoc -> HsPat -> (Senv -> Senv, Senv -> ([HsName], [Error]))) ->+       (DeclContext -> [HsDecl] -> (Senv -> Senv, Senv -> [Error])) ->+       (SrcLoc -> HsType -> Senv -> [Error]) ->+       SrcLoc -> E e p ds t c -> Senv -> [Error]+chE chexp chpat chdecls chtype loc e env =+    case scopE env (mapE (chexp loc)+                         (chpat loc)+                         (chdecls WhereLikeDecl)+                         (chtype loc)+                         (error "ctxt")+                         e) of+    HsId (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)+    HsInfixApp x (HsVar n) y -> chk loc (not (varDefined n env))+                                        (undefined_variable n)+    HsLeftSection x (HsVar n) -> chk loc (not (varDefined n env))+                                         (undefined_variable n)+    HsRightSection (HsVar n) x -> chk loc (not (varDefined n env))+                                          (undefined_variable n)+    HsLambda ps e -> e ++ chPatList loc env ps+  +    _ -> accE (++) (\ (_, errs) a -> errs ++ a) (++) (++) (++) e []+    +chExp loc (Exp e) env = chE chExp loc e env+++--------------------------------------------+-- Static checks for individual patterns++chP :: SrcLoc -> HsPat -> (Senv -> Senv,Senv -> ([HsName],[Error]))+chP loc (pat @ (Pat x)) = (envTrans, f)+  where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])+        envTrans env = foldr extName env uniqueNames+        extName nm = extVar nm loc+        duperr = chk loc (not (null dups)) (duplicate_vars_in_pattern dups)+        f env = (uniqueNames,allErrors env)+        allErrors env = foldr arityCheck duperr constrArities+          where arityCheck (c,n) ans = check c n (cArity c env) ++ ans+                check c n Nothing  = [(loc,undefined_constr c)]+                check c n (Just m) = chk loc (m /=n) (constr_wrong_arity n c)++-----------------------------------------------------------------------------+-- When language constructs have a list of patterns like : (\ p1 ... pn -> e)+-- or (case x of { C p1 ... pn -> e }), Haskell has the rule that no variable+-- should appear more than once in the list. We can't check this, pattern by+-- pattern, but have to observe the complete list. If we map (chP env) over a+-- list of patterns we get [([unique_names],[error_messages])], from this we+-- can compute additional error_messages dealing with duplicates.++chPatList :: SrcLoc -> Senv -> [([HsName],[Error])] -> [Error]      +chPatList loc env ps =+ let accumulate (ns,errs) (names,errors) = (ns++names,errs++errors)+     (allbound,internalerr) = foldr accumulate ([],[]) ps+     dups = duplicates allbound+     duperr = chk loc (not (null dups)) (repeated_pattern_variables dups)+ in internalerr ++ duperr++--------------------------------------------------------------------------+-- static checks for a list of Decls+++chDs :: DeclContext -> [HsDecl] -> (Senv->Senv,Senv -> [Error] )+chDs contxt ds = (envtrans,errorfun)+  where env      = allNames ds env0+        envtrans = concatEnv env+        errorfun env = foldr (\ d ans -> (check env d) ++ ans) allErrors ds+        sameName (x,y) (a,b) = compare x a+        contextErrors = catMaybes $ map (legal contxt) ds+        dupErr k message = collect_duplicate_info (dupErrs message) sameName (locations k env)+        dupValErrors  = dupErr Var    "value definitions"+        dupSigErrors  = dupErr Sig    "type signatures"+        dupClsErrors  = dupErr Class  "class definitions"+        dupTypErrors  = dupErr TyCons "type definitions"+        dupConsErrors = dupErr Cons   "constructor functions"++        allErrors = contextErrors++dupValErrors++dupSigErrors++dupClsErrors+                    ++ dupTypErrors ++ dupConsErrors ++ nmConflict env ++ clsMethodErr+        sigerr loc name = chk loc ((not $ elem name (map fst (varNames env))) && contxt/=ClassDecl)+                                  (signature_without_definition name)+        methodErr c (nm,loc) = chk loc (not $ isMethod nm c env) (not_a_method nm c)+        clsMethodErr = case contxt of +                       ClassDecl -> classMethodErr env+                       other     -> []+        check env (Dec x) =+          let loc = srcloc x+              methodErrs (HsInstDecl loc c tp ds) = +                let nms = varNames $ allNames ds env0+                in  case getClass tp of+                     Nothing -> []+                     Just c  -> concat $ map (methodErr c) nms+          in+           case scopD env (mapD' (chE loc) (chP loc) (chDs) (chT loc) (chCntxt loc) (chTp loc) x) of+             HsTypeSig loc nms c t  -> (concat $ map (sigerr loc) nms)++c++t+             HsInstDecl loc c tp ds -> methodErrs x ++ c ++ tp ++ ds+             z -> accD (++) (\ (ns,errs) a -> (errs)++a) (++) (++) (++) (++) z []++    +    +---------------------------------------------------------------------------++chT :: SrcLoc -> HsType -> Senv -> [Error]+chT loc (typ @ (Typ t)) env = +  case t of +   HsTyVar nm -> chk loc (not (tvarDefined nm env)) (undefined_tvar nm)+   HsTyCon nm -> chk loc (not (tconDefined nm env)) (undefined_tcon nm)+   HsTyApp (Typ f) x -> synCheck (chT loc) env f x 1+   z -> accT (++) (scopT env (mapT (chT loc)  z)) []++synCheck chf env (HsTyCon c) arg n = +    case synArity c env of+    Nothing -> chk loc (not (tconDefined c env)) (undefined_tcon c) ++ chf arg env +    Just m  -> chk loc (m/=n) (tysynonym_not_fully_applied c) ++ chf arg env+synCheck chf env (HsTyApp (Typ f) x) arg n =+    synCheck chf env f x (n+1) ++ chf arg env+synCheck chf env t arg n = chf (Typ t) env ++ chf arg env++-----------------------------------------------------------------------------+-- Static checks for contexts++chCntxt :: SrcLoc ->  DeclContext -> [HsType] -> (Senv -> [Error])+chCntxt loc c ts env = foldr (check c) [] ts+  where inscope (Typ (HsTyVar x)) ans = +            chk loc (not $ tvarDefined x env) (undefined_tvar_in_context x) ++ ans+        inscope (Typ (HsTyCon c)) ans = +            chk loc (not $ classDefined c env) (undefined_class_in_context c) ++ ans +        inscope (Typ x) ans  = accT inscope x ans ++        -- class: C (x t*)++        wfClass t (Typ (HsTyApp (Typ (HsTyCon c)) x )) xs =+           wfClassArg x x xs+        wfClass t (Typ (HsTyApp x y ))                 xs =+           wfClass t x $ wfClassArg x x xs+        wfClass t (Typ x)                              xs =+           (loc, illformed_class t) : xs++        -- class arg: x t*+        wfClassArg t (Typ (HsTyVar y))   xs = xs+        wfClassArg t (Typ (HsTyApp x _)) xs = wfClassArg t x xs +        wfClassArg t (Typ x)             xs = (loc, illformed_class_arg t) : xs++        check ClassDecl x ans = wfSclass loc x (inscope x ans)+        check InstDecl  x ans = wfSclass loc x (inscope x ans)+        check _         x ans = wfClass  x x   (inscope x ans)++-----------------------------------------------------------------------------+-- Static checks for type patterns+++chTp :: SrcLoc ->  TPContext -> HsType -> (Senv -> Senv, Senv -> [Error])+chTp srcloc InstTP x =+  let errors = wf x []+      -- well formed instance: C (C x*)+++      wf (Typ(HsTyApp (Typ(HsTyCon c)) arg)) xs =+         wfTp srcloc InstTP arg xs+      wf (Typ(HsTyCon c)) xs                 =+         (srcloc, instance_required c) : xs +      wf (Typ(HsTyApp y arg)) xs             =+         wf y (wfTp srcloc InstTP arg xs)+      wf tp xs                               =+         (srcloc, instance_not_class_app tp) : xs++      (classname, ts) = instPatToParts x+      (tvs, cs) = foldr allTypNames ([], []) ts+      trans env = if null errors then foldr extTvar env tvs else env+      clsError env = chk srcloc (not $ classDefined classname env) +                                (undefined_class_in_instance classname)+      cdef env c ans = +         if tconDefined c env +         then case synArity c env of+              Nothing   -> ans+              Just _    -> (srcloc, synonym_illegal_in_instance c):ans+         else (srcloc,undefined_tcon_in_instance c):ans+      dupErrs = collect_duplicate_info (dupTvErr srcloc) compare tvs+      tpf env = if null errors+                then foldr (cdef env) (dupErrs ++ clsError env) cs+                else errors+  in (trans, tpf)                ++chTp srcloc SigTP x =+  let (tvs, cs)     = allTypNames x ([], [])+      trans env    = foldr extTvar env tvs+      cdef env c ans = +         if tconDefined c env +         then ans+         else (srcloc, undefined_tcon_in_signature c):ans+      tpf env = foldr (cdef env) [] cs+  in  (trans, tpf)++chTp srcloc cntxt x =+  let (constr, tvs) = typePatToParts x+      errors = case cntxt of DataLikeTP ->  wfTp     srcloc cntxt x []+                             ClassTP    ->  wfSclass srcloc       x []+      trans env = if null errors then foldr extTvar env tvs else env+      tpf env   = if null errors +                  then collect_duplicate_info (dupTvErr srcloc) compare tvs+                  else errors+  in (trans, tpf)++++-------------------------------------------------------------------------+-- Error Message Strings are computed here+-------------------------------------------------------------------------++undefined_variable nm = "Undefined variable: "++ pp nm+duplicate_vars_in_pattern dups =+  "Variables appear more than once in single pattern: " ++ pp dups+undefined_constr c =+  "Undefined Constructor in pattern: " ++ pp c+constr_wrong_arity n c =+  "Constructor "++ pp c++ " must have exactly "++ pp n ++ " arguments."+repeated_pattern_variables dups =+  "Repeated variables in pattern list: " ++ pp dups+duplicate_things sort name locs =+  "Duplicate " ++ show sort ++ " of " ++ show name +++  " at locations: " ++ pp locs+signature_without_definition name =+  "Signature for "++pp name++" without matching definition."++undefined_class_in_instance classname =+  "Class name in instance: " ++ pp classname ++ "  is not defined"+undefined_tcon_in_instance c =+  "Type constructor " ++ pp c ++ " in instance is not defined"+synonym_illegal_in_instance c =+  "Type synonym " ++ pp c ++ " in instance"++undefined_tcon_in_signature c =+  "Type constructor " ++ pp c ++ " in signature is not defined"+  +undefined_class_in_context clsname =+  "Class name " ++ pp clsname ++ " in context is not defined"+undefined_tvar_in_context tvarname =+  "Type variable " ++ pp tvarname ++ " in context is not defined"+undefined_tvar tvarname =+  "Type variable " ++ pp tvarname ++ "  is not defined"+undefined_tcon tconname =+  "Type constructor " ++ pp tconname ++ "  is not defined"+tysynonym_not_fully_applied tyconname =+  "Type synonym " ++ pp tyconname ++ "  is not fully applied"+duplicate_type_vars x =+  "Duplicate type variables in definition: " ++ pp x++non_tyvar_arg_in_pattern a c =+  "Argument in Type Pattern in " ++ show c ++ " is not a variable: "++ pp a+type_former_is_not_constructor x c = +  "Type pattern in " ++ show c ++ " is not an application of a type constructor: "++ pp x+instance_required tp =+  "Instance of class " ++ pp tp ++ " required"+instance_not_class_app tp = +  "Instance is not an application of a class constructor: "++pp tp++illformed_sclass t=+  "ill formed class "++pp t+illformed_class t=+  "ill formed class in context "++pp t+illformed_class_arg t=+  "ill formed argument " ++ pp t ++ " to class in context "++not_a_method nm c =+  pp nm ++ " is not a method of class " ++ pp c+++-----------------------------------------------------------------------------+-- computing free variables+-- Computing free variables is a tricky computation, because the same variable+-- may be free in one spot and bound in another. We need an environment to+-- determine what variables are bound at any particular point. We use a list+-- of HsName as the environment++-- Given an expression and an environment telling what vars are bound+-- determine the free variables in the expression.++freeE :: HsExp -> [HsName] -> [HsName]+freeE (Exp x) env = +  case scopE env (mapE freeE freeP freeD freeT freeC x) of+    HsId(HsVar s) -> if elem s env then [] else [s]+    HsInfixApp x (HsVar s) y -> if elem s env then [] else [s]+    HsLeftSection x (HsVar s) -> if elem s env then [] else [s]+    HsRightSection (HsVar s) x -> if elem s env then [] else [s]+    x -> accE (++) (++) (++) (++) (++) x []+            ++-- Return a pair of functions. The first is an env transformer, adding+-- the vars in the pattern, the second is a function given an env, which+-- determines the free vars in the pattern. The second is the constant []+-- function since patterns only introduce variables, they only have binding+-- occurences.++freeP :: HsPat -> ([HsName]->[HsName],[HsName]->[HsName])+freeP p = ((vs++),const [])+  where vs = boundInPat p []+        +-- Return a pair of functions. The first is an env transformer, adding+-- the vars declared by the list of Decls, the second is a function which+-- when given an env, determines the free vars in the Decls ++freeD :: [HsDecl] -> ([HsName]->[HsName],[HsName]->[HsName])+freeD ds = (ext,free)+  where bound = foldr add [] ds+        ext env = bound ++ env +        add (Dec (HsPatBind s p rhs ds)) env = boundInPat p env+        add (Dec (HsFunBind s ((HsMatch s2 nm ps rhs ds):_))) env  = nm : env+        add (Dec (HsDataDecl s ctx typats condecls derivings)) env =+           getTyName (head typats) : env+        add (Dec (HsTypeDecl s typats t)) env = getTyName (head typats) : env+        add d env = env+        getNameOfTypat (Typ x) = +             case x of +               HsTyApp l _ -> getNameOfTypat l+               HsTyCon n   -> n+               HsTyVar n   -> n +               _           -> error "getNameOfTypat "+        free env = (foldr (f env) [] ds) \\ bound +        f env (Dec d) ans = +          accD (++)(++)(++)(++)(++)(++)+               (scopD env (mapD (\ x -> ( (freeE x))) freeP freeD freeT freeC freeTP d)) ans+ff env (Dec d) ans = +          accD (++)(++)(++)(++)(++)(++)+               (scopD env (mapD (\ x -> ( (freeE x))) freeP freeD freeT freeC freeTP d)) ans          +++instance Env [HsName] where+  extClass n l a args env = env+  extTconstr n l a b  env = n:env+  extTvar n           env = n:env+  extConstr n l a     env = n:env+  extVar n l          env = n:env+  extSig n l          env = env+  extMod n            env = env+  env0 = []+  restrictTvar env = env+++-- Given an environment holding bound variables, return the +-- free variables in the HsType++freeT :: HsType -> [HsName] -> [HsName]+freeT (Typ x) env = +  case scopT env (mapT freeT x) of+    HsTyCon n -> if elem n env then [] else [n]    +    HsTyVar n -> if elem n env then [] else [n]+    x         -> accT (union) x []++allFree :: HsType -> [HsName] -> [HsName]+allFree (Typ x) ans = +  case x of+    HsTyCon n -> union [n] ans+    HsTyVar n -> union [n] ans+    x         -> accT allFree x ans+++-- compute the free variables in a context.++freeC :: [HsType] -> [HsName] -> [HsName]+freeC x env = concat (map (\z -> freeT z env) x)++-- Type patterns are HsTYpes which act as binding occurences. Hence+-- they return a pair. First an env transformer, and Second a function+-- that given an env, computes the TypePatterns free variables. Like patterns+-- this always returns []++freeTP :: HsType -> ([HsName] -> [HsName],[HsName] -> [HsName])+freeTP x = (allFree x, const [])+++makeSCC ds env =+  let (envtrans,_) = freeD ds +      bound = envtrans []+      oneD d = let (_,free) = freeD [d] in free env+      oneBind d = let (envt,_) = freeD [d] in envt []+      allFree  = map oneD ds+      allBound = map oneBind ds +  in (allFree,allBound)++--------------------------------------------------------------------------+-- Contexts+--------------------------------------------------------------------------++-- type patterns appear in 4 different contexts++data TPContext = DataLikeTP | ClassTP | InstTP | SigTP+instance Show TPContext where+  show DataLikeTP = "type, data, or newtype declaration"+  show ClassTP    = "class declaration"+  show InstTP     = "instance declaration"+  show SigTP      = "type signature" +++-----------------------------------------------------------------+-- Lists of declarations can appear in four different contexts+-- Only certain kinds of declarations are legal in some of these.++data DeclContext = TopDecl | ClassDecl | InstDecl | WhereLikeDecl deriving (Eq)+instance Show DeclContext where+  show TopDecl       = "top level"+  show ClassDecl     = "class declaration"+  show InstDecl      = "class declaration"+  show WhereLikeDecl = "local declaration"++legal :: DeclContext -> HsDecl -> Maybe Error+legal context (d @ (Dec x)) =+  let err context x = Just (srcloc x,+                "Illegal "++ whatIs x ++" in " ++ show context)+  in+      case (context, x) of+      (TopDecl,   any)                             -> Nothing+      (ClassDecl, HsTypeSig _ _ _ _)               -> Nothing+      (ClassDecl, HsFunBind _ _)                   -> Nothing+      (ClassDecl, HsPatBind _ (Pat(HsPId(HsVar _))) _ _) -> Nothing+      (ClassDecl, any)                             -> err context x+      (InstDecl,  HsFunBind _ _)                   -> Nothing+      (InstDecl,  HsPatBind _ (Pat(HsPId(HsVar _))) _ _) -> Nothing+      (InstDecl,  any)                             -> err context x+      (WhereLikeDecl, HsTypeSig _ _ _ _)           -> Nothing+      (WhereLikeDecl, HsFunBind _ _)               -> Nothing+      (WhereLikeDecl, HsPatBind _ _ _ _)           -> Nothing+      (WhereLikeDecl, any)                         -> err context x++-----------------------------------------------------------------------+-- MapD' is like mapD, except it know what kind of contexts are+-- appropriate and passes this information downwards++mapD' :: (a -> b) -> (c -> d) -> (DeclContext -> e -> f) -> (g -> h) -> (DeclContext -> i -> j)+                  -> (TPContext -> k -> l) -> D a c e g i k -> D b d f h j l+mapD' ef pf df tf cf tpf decl =+   case decl of+    HsTypeDecl s tps t -> +        HsTypeDecl s (map (tpf DataLikeTP) tps) (tf t)+    HsNewTypeDecl s cntxt tps cd names ->+        HsNewTypeDecl s (cf TopDecl cntxt)+              (map (tpf DataLikeTP) tps) (mapConDecl tf cd) names+    HsDataDecl s cntxt tps cds names   ->+        HsDataDecl s (cf TopDecl cntxt)+               (map (tpf DataLikeTP) tps)+               (map (mapConDecl tf) cds) names+    HsClassDecl s c tp ds                   ->+        HsClassDecl s (cf ClassDecl c) (tpf ClassTP tp) (df ClassDecl ds)+    HsInstDecl s c tp ds                    ->+        HsInstDecl s (cf InstDecl c) (tpf InstTP tp) (df InstDecl ds)+    HsDefaultDecl s t -> +        HsDefaultDecl s (tf t)+    HsTypeSig s nms c t                  ->+        HsTypeSig s nms (cf TopDecl c) (tpf SigTP t)+    HsFunBind s matches                   ->+        HsFunBind s (map (mapMatch ef pf (df WhereLikeDecl)) matches)+    HsPatBind s p rhs ds                  ->+        HsPatBind s (pf p) (mapRhs ef rhs) (df WhereLikeDecl ds)+    HsPrimitiveTypeDecl s cntxt nm        -> +        HsPrimitiveTypeDecl s (cf TopDecl cntxt) nm+    HsPrimitiveBind s nm t                ->+        HsPrimitiveBind s nm (tf t) -- Hugs compatibility+++ +-------------------------------------------------------------------+-------------------------------------------------------------------+-- Static Checking using Bind based scoping++-------------------------------------------------------------------------+-- Example extend function for the static env Senv of the static checker+++-- extTvar nm env = env {tvarNames = (nm) : tvarNames env}  + +extend :: Bind -> Senv -> Senv+extend (Bpat loc pat) env = foldr extName env uniqueNames+        where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])+              extName nm env = env {varNames = (nm,loc) : varNames env}+extend (Bpats loc ps) env = foldr extend env (map (Bpat loc) ps)+extend (Bdecls ds) env = allNames ds env+extend (Bname loc nm) env = env {varNames = (nm,loc) : varNames env}+extend (Btypat tag tp) env = +  case tag of+        ClassTag ->  -- (Env e x)         -- expects (C v1 ... vn)+          let (constr, tvs) = typePatToParts tp+          in foldr extTvar env tvs +        InstTag  ->  -- (Env [Int] Bool)  -- expects (C t1 ... tn)+          let (classname, ts) = instPatToParts tp+              (tvs, cs) = foldr allTypNames ([], []) ts+          in foldr extTvar env tvs +        SigTag   ->  -- (e : typ) +          let (tvs, cs)     = allTypNames tp ([], [])             +          in foldr extTvar env tvs+extend (Btypats tag (tps @ (constr : args))) env = +   case tag of+     DataTPS -> foldr (\ t e -> extTvar (getTyName t) e) env tps+     TypeTPS -> foldr (\ t e -> extTvar (getTyName t) e) env args+    +staticlib = Sc extend restrictTvar    
+ tools/base/SA/ScopeTests.hs view
@@ -0,0 +1,160 @@++module ScopeTests++where+------------------------------------------------------------------------------+-- some tests++loc = SrcLoc "Scope tests" 0 0++names2 @ [fn,gn,hn,kn,xn,yn,zn] = map UnQual ["f","g","h","k","x","y","z"]+names3 @ [an,bn,cn,dn,en,tn,sn] = map UnQual ["A","B","C","D","E","T","S"]++exps @  [fe,ge,he,ke,xe,ye,ze] = map hsEVar  names2+pats @  [fp,gp,hp,kp,xp,yp,zp] = map hsPVar  names2+typs @  [ft,gt,ht,kt,xt,yt,zt] = map hsTyVar names2++cons @  [ac,bc,cc,dc,ec,tc,sc] = map hsECon  names3+tcons @ [at,bt,ct,dt,et,tt,st] = map hsTyCon names3++ap2 [x] = x+ap2 (x:y:xs) = ap2((hsApp x y):xs)++apt [x] = x+apt (x:y:xs) = apt((hsTyApp x y):xs)++arr = hsTyFun+++class1 = hsClassDecl loc [] (apt [ct,xt])+           [ hsTypeSig loc [fn] [] (xt `arr` xt) ]+class2 = hsClassDecl loc [apt[ct,yt]] (apt [dt,yt])+           [ hsTypeSig loc [gn] [] (yt `arr` yt) ]+class3 = hsClassDecl loc [apt[at,yt,xt]] (apt [et,yt,yt])+           [ hsTypeSig loc [zn] [] (yt `arr` yt) ]         ++inst0 = hsInstDecl loc [] (ct) []+inst0'= hsInstDecl loc [] (xt) []+inst1 = hsInstDecl loc [] (apt [ct,xt]) []+inst2 = hsInstDecl loc [] (apt [ct,apt [dt,xt,xt]]) []+inst3 = hsInstDecl loc [] (apt [ct,apt [dt,at]]) []+inst4 = hsInstDecl loc [apt [dt,xt]] (apt [ct,tt]) []+inst5 = hsInstDecl loc [] (apt [ct,at]) []+inst6 = hsInstDecl loc [] (yt `arr` yt) []++data1 = hsDataDecl loc [] [tt] [HsConDecl loc cn []] []+data2 = hsDataDecl loc [] [tt,xt] [] []+data3 = hsDataDecl loc [] [tt] [HsConDecl loc cn [HsBangedType yt]+                             ,HsConDecl loc dn [HsUnBangedType at]+                             ,HsConDecl loc dn []+                             ] []+data4 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType st]] []+data5 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType (apt [st,xt])]] []+data6 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType (apt [st,xt,yt])]] []+data7 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType (apt [st,xt,yt,yt])]] []++type1 = hsTypeDecl loc [st,xt,yt] (hsTyTuple [xt,yt])+sig1  = hsTypeSig loc [zn] [] (apt [st,xt])++p0 = [class1,class2,class3,inst1,inst2,inst3]+p1 = [inst2]+p2 = [class1,class1,data1,data2,inst4,inst5]+++insts :: [(String, [HsDecl])]+insts = [ ("Ill formed instance type", [ hsInstDecl loc [] (ct) [] ] )+        , ("Ill formed instance type", [ hsInstDecl loc [] (xt) [] ])+        , ("Ill formed instance type", [hsInstDecl loc [] (apt [ct,xt]) []])+        , ("Undefined class & type" , [hsInstDecl loc [] (apt [ct,dt]) []])+        , ("Duplicate type vars", +                [ hsDataDecl  loc [] [dt] [] []+                , hsClassDecl loc [] (apt [ct,xt]) []+                , hsInstDecl loc [] (apt [ct,apt [dt,xt,xt]]) []])+        , ("Argument to TyCon must be tyvar", [hsInstDecl loc [] (apt [ct,apt [dt,at]]) []])+        , ("Many undefined", [hsInstDecl loc [apt [dt,xt]] (apt [ct,tt]) []])+        , ("Type synonym illegal",   +                 [ hsTypeDecl  loc [at] bt+                 , hsDataDecl  loc [] [bt] [] []+                 , hsClassDecl loc [] (apt [ct,xt]) []+                 , hsInstDecl  loc [] (apt [ct,at]) []+                 ])+        , ("Context errors", +                [ hsDataDecl  loc [] [at] [] []+                , hsDataDecl  loc [] [bt,xt] [] []+                , hsClassDecl loc [] (apt [ct,xt]) []+                , hsClassDecl loc [] (apt [dt,xt]) []+                , hsInstDecl  loc [xt] (apt [ct,at]) []+                , hsInstDecl  loc [dt] (apt [ct,at]) []+                , hsInstDecl  loc [apt[dt,apt[xt,yt]]] (apt [ct,apt [bt,xt]]) []+                ])+        , ("",+                [ hsDataDecl  loc [] [at] [] []+                , hsClassDecl loc [] (apt [ct,xt]) [ hsTypeSig loc [fn] [] (xt `arr` xt) ]+                , hsInstDecl  loc [] (apt [ct,at]) +                        [ hsTypeSig loc [fn] [] (xt `arr` xt) +                        , hsFunBind loc [HsMatch loc fn [xp] (HsBody(hsEVar xn)) []] +                        , hsFunBind loc [HsMatch loc gn [xp] (HsBody(hsEVar yn)) []] +                        ]+                ])+        , ("OK", [ hsDataDecl  loc [] [at] [] []+                 , hsDataDecl  loc [] [bt,xt] [] []+                 , hsClassDecl loc [] (apt [ct,xt]) []+                 , hsClassDecl loc [] (apt [dt,xt]) []+                 , hsInstDecl  loc [] (apt [ct,at]) []+                 , hsInstDecl  loc [apt [dt,xt]] (apt [ct,apt [bt,xt]]) []+                 ])+        , ("class/type name conflict", +                 [ hsDataDecl  loc [] [at] [] []+                 , hsDataDecl  loc [] [bt] [] []+                 , hsInstDecl loc [] (apt [at,bt]) []+                 , hsInstDecl loc [] (apt [ct,bt]) []+                 ] )+                           +        ]++dts  = [ ("", [ hsDataDecl  loc [] [at,bt] [] [] ] )+       , ("", [ hsDataDecl  loc [] [xt,yt] [] [] ] )+       ]++clss = [ ("OK", [hsClassDecl loc [] (apt [ct,xt]) []])+       , ("ill formed class specification", [hsClassDecl loc [] (ct) []])+       , ("ill formed class specification", [hsClassDecl loc [] (xt) []])+       , ("class/type name conflict", +                [ hsDataDecl  loc [] [at] [] []+                , hsDataDecl  loc [] [bt] [] []+                , hsClassDecl loc [] (apt [at,xt]) []+                , hsClassDecl loc [] (apt [bt,xt]) []+                ] )+       , ("ill formed class specification", +                [  hsClassDecl loc [] (apt [ct,at]) []+                ] )+       , ("ill formed class specification", +                [  hsClassDecl loc [] (apt [ct,at]) []+                ,  hsClassDecl loc [] (apt [dt,at]) []+                ] )+       , ("ill formed class specification", +                [ hsDataDecl  loc [] [at] [] []+                , hsClassDecl loc [] (apt [ct,at]) []+                ] )+       , ("",+                [  hsClassDecl loc [] (apt [ct,xt])+                   [ hsTypeSig loc [fn] [] (arr xt xt)+                   , hsPatBind loc fp (HsBody (hsLambda [xp] xe)) []+                   , hsPatBind loc gp (HsBody (hsLambda [xp] xe)) []+                   ]+                ] )+       ]+      +patBind p e = hsPatBind loc p (HsBody e) []++d1 = [patBind fp (hsLambda [xp] xe), patBind fp (hsLambda [xp] (xe))]+{-+p2 = [hsTypeSig loc [zn] (TypeUnQual$ hsTyCon (UnQual "Int"))]+p3 = [hsTypeSig loc [yn,yn] (TypeUnQual $ Typ $ HsTyCon (UnQual "Int"))]+p4 = [patBind fp (hsLet [patBind xp ye] xe)]+p5 = [patBind fp (hsLambda [xp] (ye))]+p6 = [patBind fp (hsLambda [hsPTuple [xp, xp], xp] ye)]+p7 = [patBind fp (hsLambda [hsPTuple [xp, xp, xp], xp] ye)]++runP p = let (envt,f) = chP loc p in f (envt env0)+-}
+ tools/base/ScopeHaskellProgram.hs view
@@ -0,0 +1,15 @@+module ScopeHaskellProgram where+import ScopeProgram(scopeProgram)+import ScopeNamesBase()+import NameMapsBase()++import ParsedSyntax(Src)+import Syntax+import WorkModule+import ScopeProgram++scopeHaskellProgram = scopeProgram+  :: (Mss (Src HsName),WMs) -> IO (Mss (PN HsName),WMs)++type Mss i =[[HsModuleI (Src HsName) [HsDeclI i]]]+type WMs = [(ModuleName,WorkModuleI (Src HsName) (Src Id))]
+ tools/base/ScopeProgram.hs view
@@ -0,0 +1,33 @@+module ScopeProgram(scopeProgram,scopeProgram',PNT(..)) where++import ScopeModule+import PNT(PNT(..))+import PrettyPrint+import OutputM+import HsModule(hsModName)++scopeProgram (mss0,wms) =+    if null errors+    then return (mss,wms)+    else fail (pp $ vcat errors)+  where+    (mss,mrefs) = scopeProgram' (mss0,wms)++    errors = [m<>": "<>msg | (m,refs)<-mrefs, (sp,i,os)<-refs, msg<-err i os]++    err i [] = [not_in_scope i]+    err i [o] = []+    err i os = [ambiguous i os]++    not_in_scope i = "Not in scope: "<>i+    ambiguous i os = "Ambiguous: "<>i<>": "<>os+++scopeProgram' (mss,wms) = listOutput $ mapM (mapM scopeMod) mss+  where+    -- Hmm. scopeModule outputs exactly one element+    scopeMod mod = p (scopeModule wm mod)+      where+        Just wm = lookup m wms+        m = hsModName mod+	p (x,refs) = output (m,refs) >> return x
+ tools/base/Set60204.hs view
@@ -0,0 +1,25 @@+module Set60204 where++#if __GLASGOW_HASKELL__ >= 604 +import qualified Data.Set as S+differenceS = S.difference+unionsS = S.unions+intersectionS = S.intersection +fromListS = S.fromList+emptyS = S.empty+memberS = S.member+mapS = S.map+elemsS = S.elems+unionS = S.union+#else+import qualified Sets as S+difference = S.minusSet+unionsS = S.unionManySets+intersectionS=S.intersect+fromListS = S.mkSet+emptyS = S.emptySet+memberS = S.elementOf+mapS = S.mapSet+elemsS = S.setToList+unionS = S.union+#endif
+ tools/base/TC/BaseTypeCheck.hs view
@@ -0,0 +1,8 @@+-- $Id: BaseTypeCheck.hs,v 1.1 2000/12/08 02:21:03 moran Exp $++module BaseTypeCheck(module BaseTypeCheckStruct,+		     module BaseTypeCheckRec)+where++import BaseTypeCheckStruct+import BaseTypeCheckRec
+ tools/base/TC/BaseTypeCheckRec.hs view
@@ -0,0 +1,590 @@+-- $Id: BaseTypeCheckRec.hs,v 1.2 2001/09/29 00:08:23 diatchki Exp $++module BaseTypeCheckRec where++import BaseSyntaxStruct+import TypeGenerics+import List(nub)++--------------------------------------------------------------------+++type Type a   = U a Kind T+type NGV a    = [(HsName, U a Kind T)]+type Env a    = [(HsName, Scheme Kind (U a Kind T))]+type Genfun a = String -> Im a Error HsName+type Alt      = HsAlt HsDecl HsExp HsPat+type Stmt     = HsStmt HsDecl HsExp HsPat+++type EnvNew a = [Assump HsName Kind (U a Kind T)]++data GEnv a = GEnv [(HsName,Class a)] (NGV a) [Assump HsName Kind (U a Kind T)]++data Class a = Class HsName [Class a] [Inst a] +type Inst a  = ([Pred (U a Kind T)], (Pred (U a Kind T)))++name  (GEnv cs ngv ass) x = let Class nm sup inst = look cs x in nm+super (GEnv cs ngv ass) x = let Class nm sup inst = look cs x in sup+insts (GEnv cs ngv ass) x = let Class nm sup inst = look cs x in ass +++------------------------------------------------------------------------+-- Instance declaration to make the T functor from HsSyn.hs appropriate+-- for doing type checking ala Hmx.hs++instance G T where+  seqG = seqT+  mapG = mapT+  accG = accT+  +instance Name T HsName where+  isName (HsTyVar s) = Just s+  isName _ = Nothing+  fromName s = HsTyVar s+  +instance Gensym a HsName where+  newGensym  =+    do { seed <- newRef (1::Int)+       ; let gensym s = do { n <- readVar seed+                           ; writeVar seed (n+1)+                           ; return (UnQual (s ++ (show n)))+                           }+         in return gensym+       } +       +  gensym s = do { n <- nextN   +                ; return (UnQual (s ++ (show n)))+                }++data Error +    = MatchError String (Vis T) (Vis T)+    | KErr String (Vis K) (Vis K)   +   +instance TypeError Error T Kind where +  hmxError s x y = +    do { (nms,[x',y']) <- visible (generic []) [x,y]+       ; raise (MatchError s x' y')+       }++-----------------------------------------------------------++type NGVars a = [(HsName,U a Kind T)]++emptyNGVars :: NGVars a+emptyNGVars = []++extendNGVars :: HsName -> U a Kind T -> NGVars a -> NGVars a+extendNGVars s t ngvars = (s,t):ngvars++generic :: NGVars a -> U a Kind T -> Im a e Bool +generic ngvars v = do { b <- occursInList v ngvars; return (not b) }+     where occursInList v l =+            do { (TVar v') <- prune v+               ; bools <- mapM (\ (a,b) -> occursIn v' b) l+               ; return (or bools)+               }+       +--------- Show Instances ----------------------------------+                             +instance Show(U a k T) where +  showsPrec n (S x) = shows x+  showsPrec n (TGen m) = showString "%" . shows m+  showsPrec n (TVar _) = showString "?"++instance Show(Vis T) where +  showsPrec n (VN a) = showString a+  showsPrec n (VS x) = shows x  +  ++instance Show a => Show(Pred a) where+  show (IsIn n ts) = "(" ++ n ++ " " ++ (show ts) ++ ")"++instance Show a => Show (Scheme Kind a) where+  show (Sch x p t) = "(all " ++ (show x) ++"." ++ (show p) ++ " => " ++ (show t) ++ ")"  +++----------------------- Instantiate unification ------------------------------++unifyShape unify ( x @ (S tx)) (y @ (S ty)) =+  case (tx,ty) of+   (HsTyFun x1 x2,HsTyFun y1 y2) ->+      do { xs <- unify x1 y1 +         ; ys <- unify x2 y2 +         ; return (xs++ys) }     +   (HsTyTuple xs,HsTyTuple ys) ->+      if (length xs) == (length ys)  +         then do { xss <- mapM (uncurry unify) (zip xs ys)+                 ; return (concat xss)+                 }+         else hmxError "TupleLengthMatch" x y+   (HsTyApp x1 x2,HsTyApp y1 y2) ->+      do { xs <- unify x1 y1 +         ; ys <- unify x2 y2 +         ; return (xs++ys) }   +   (HsTyVar n1,HsTyVar n2) ->+      if n1 == n2 +         then return []+         else hmxError "NameMatch" x y +   (HsTyCon n1,HsTyCon n2) ->+      if n1 == n2 +         then return []+         else hmxError "NameMatch" x y          +   (tx,ty) -> hmxError "ShapeMatch"  x y+      ++unify :: (U a Kind T) -> (U a Kind T) ->  Im a Error [p]+unify = unifier (hmxError "OccursCheck") unifyShape+     +     +------------------ Kind inference -----------------------+data Sort = Sort+type Knd a = U a Sort K++instance G K where+  mapG = mapK+  seqG = seqK+  accG f = flip (accK f)++instance TypeError Error K Sort where+  hmxError s x y = +    do { (nms,[x',y']) <- visible (\ x -> return False) [x,y]+       ; raise (KErr s x' y')+       }++unifyK unify ( x @ (S tx)) (y @ (S ty)) =+  case (tx,ty) of+   (Kstar,Kstar) -> return []+   (Kfun x1 x2,Kfun y1 y2) ->+      do { xs <- unify x1 y1 +         ; ys <- unify x2 y2 +         ; return (xs++ys) }   +   (tx,ty) -> hmxError "KindShapeMatch"  x y+      +unifyKind :: (U a Sort K) -> (U a Sort K) ->  Im a Error [p]+unifyKind = unifier (hmxError "OccursCheck") unifyK++star = S Kstar ++inferK :: (HsName -> U a Sort K) -> U a Sort K -> HsType -> Im a Error (U a Sort K)+inferK env hint (Typ typ) =+  case typ of+    (HsTyFun x y) ->+       do { x' <- inferK env star x+          ; y' <- inferK env star y+          ; unifyKind hint star+          ; return hint+          }+    (HsTyTuple ts) ->+       do { sequence (map (inferK env star) ts)+          ; unifyKind hint star+          ; return star+          }+    (HsTyApp x y) ->+       do { a <- newVar Sort+          ; b <- newVar Sort+          ; x' <- inferK env (S(Kfun a hint)) x+          ; y' <- inferK env a y+          ; return hint+          }+    (HsTyVar nm) ->+       do { unifyKind hint (env nm)+          ; return hint+          }+    (HsTyCon nm) ->  +       do { unifyKind hint (env nm)+          ; return hint+          }++kindOf :: (HsName -> U a Sort K) -> HsType -> Im a Error Kind+kindOf envf x = do { hint <- newVar Sort+                   ; inferK envf hint x+                   ; k <- uaSortK_to_Kind hint+                   ; return k+                   }+       +----------------------------------------------------------------------------+-- After Kind inference some of the Kind Vars may still be un-instantiated+-- Since we do not have a "polymorphic" Kind system we must instantiate+-- these Kind vars. We fix them to kind "Knd Kstar", and then turn the +-- resulting (U a Sort K)  thing into a "Kind" type.++uaSortK_to_Kind :: (U a Sort K) -> Im a e Kind+uaSortK_to_Kind (S x) = do { x' <- seqG(mapG uaSortK_to_Kind x); return (Knd x')}+uaSortK_to_Kind (TGen m) = error "no TGen in kinds"+uaSortK_to_Kind (t @ (TVar x)) = follow finish uaSortK_to_Kind t+    where finish :: (Tyvar a Sort K) -> Im a e Kind+          finish (Tyvar ref s) = do { writeVar ref (Just star)+                                    ; return (Knd Kstar) }+                 +     +--------------- Environment function and types --------------------------+++extend f s t = (s,t) : f++lambdaExt :: [(name,Scheme a c)] -> name -> c -> [(name,Scheme a c)]+lambdaExt env vname vtyp = extend env vname (Sch [] [] vtyp)++envf [] s = error ("variable not found: "++(show s)++"\n")+envf ((x,t):m) s = if x==s then t else envf m s++-------- Type constructors and types of literal constants ------------++tArrow x y = S(HsTyFun x y)+tTuple ts = S(HsTyTuple ts)+tInteger = S(HsTyCon (UnQual "Integer"))+tChar = S(HsTyCon (UnQual "Char"))+tString = tlist tChar+tRational = S(HsTyCon (UnQual "Rational"))+tBool = S(HsTyCon (UnQual "Bool"))++tStringHash = S(HsTyCon (UnQual "stringHash"))+tCharHash = S(HsTyCon (UnQual "CharHash"))+tIntHash = S(HsTyCon (UnQual "IntHash"))+tRationalHash = S(HsTyCon (UnQual "RationalHash"))+tlist x =  S(HsTyApp tlistCon x)+tlistCon = (S(HsTyCon (UnQual "[]")))++tcode x =  S(HsTyApp tcodeCon x)+tcodeCon = (S(HsTyCon (UnQual "Code")))++litTyp (HsInt _)        = tInteger+litTyp (HsChar _)       = tChar+litTyp (HsString _)     = tString+litTyp (HsFrac _)       = tRational+litTyp (HsCharPrim _)   = tCharHash+litTyp (HsStringPrim _) = tStringHash+litTyp (HsIntPrim _)    = tIntHash+litTyp (HsFloatPrim _)  = tRationalHash+litTyp (HsDoublePrim _) = tRationalHash++------------------------ Predefined Class predicates ----------------++num x = IsIn "Num" [x] +monad x = IsIn "Monad" [x]+enum x = IsIn "Enum" [x]++-------------------------------------------------------------------------+-- unArrow [p1,p2,p3] (t1 -> t2 -> t3 -> t4) ---> (t4,[(p1,t1),(p2,t2),(p3,t3)])++unArrow :: [HsPat] -> Type a -> Im a Error (Type a,[(HsPat,Type a)])+unArrow ps t = do { t' <- col t; flat ps t' }+  where flat (p:ps) (S(HsTyFun dom rng)) = +          do { (t,ts) <- (flat ps rng) ; return (t,(p,dom) : ts) }+        flat [] t = return (t,[])+        flat (p:ps) t = error "Too many arguments to pattern"+++patExtTup [] env = return ([],[],[])+patExtTup ((p,t):m) env = +    do { (t1,e1,c1) <- patExt p t env+       ; (ts,e2,cs) <- patExtTup m env +       ; return(t1:ts,e1++e2,c1 ++ cs)+       }++patExtList []    elemtyp env cs = return (tlist elemtyp,[],cs)+patExtList (p:m) elemtyp env cs = +    do { (t1,e1,c1) <- patExt p elemtyp env+       ; (listOfelem,e2,cs) <- patExtList m elemtyp env c1+       ; return(listOfelem,e1 ++ e2,c1++cs)+       }+++patExt :: HsPat -> Type a -> Env a -> Im a Error (Type a,NGV a,[Pred (Type a)])+patExt (Pat p) typ env =+  case p of+   (HsPVar name) -> return (typ,[(name,typ)],[])+   (HsPLit l) -> +      do { let t = litTyp l+         ; cs <- unify t typ+         ; return (t,[],cs)+         }+   (HsPNeg x) -> error "whats this?"+   (HsPInfixApp x n y) -> patExt (Pat(HsPApp n [x,y])) typ env +   (HsPApp nm ps) -> +      do { (cs1 :=> ctyp) <- instan (envf env nm) +         ; (t,patTypeList) <- unArrow ps ctyp+         ; cs2 <- unify t typ+         ; (ts2,env2,cs3) <- patExtTup patTypeList env +         ; return (t,env2,cs1 ++ cs2 ++ cs3)+         }+   (HsPTuple ps) ->+      do { ts <- sequence (map (\ x -> (newVar kstar)) ps)+         ; cs2 <- unify (tTuple ts) typ+         ; (ts,ngv3,cs3) <- patExtTup (zip ps ts) env+         ; return (tTuple ts,ngv3,cs2 ++ cs3)+         }         +   (HsPList ps ) -> +      do { elemtyp <- newVar kstar+         ; (listtyp,ngv2,cs) <- patExtList ps elemtyp env []+         ; cs2 <- unify listtyp (tlist elemtyp)+         ; return (listtyp,ngv2,cs ++ cs2)+         }        +   (HsPParen x) -> patExt x typ env+   (HsPRec n pairs) -> error "not yet"+   (HsPRecUpdate nm pairs) -> error "not yet"+   (HsPAsPat name x) ->+      do { (t,ngv1,cs1) <- patExt x typ env+         ; return (t,(name,t):ngv1,cs1)+         }+   (HsPWildCard) -> do { t <- newVar kstar ; return (t,[],[]) }+   (HsPIrrPat x) -> patExt x typ env++inferPats :: [HsPat] -> NGV a -> Env a ->  +               Im a Error ([Type a],NGV a,Env a,[Pred (Type a)])+inferPats ps ngvars env =+  do { pairs <- sequence (map (\ p -> do { t <- newVar kstar; return (p,t) }) ps)+     ; (t1,ngv1,cs1) <- patExtTup pairs env+     ; return (t1,ngv1 ++ ngvars,g ngv1 env,cs1)+     }  where g [] env = env+              g ((v,t):more) env = lambdaExt (g more env) v t+  +inferPat p ngvars env hint =+  do { (_,ngv1,cs1) <- patExt p hint env+     ; return (ngv1 ++ ngvars,g ngv1 env,cs1)+     }  where g [] env = env+              g ((v,t):more) env = lambdaExt (g more env) v t+    +-------------------------------------------------------------+    ++infer :: Genfun a -> NGV a -> Env a -> Type a ->+            HsExp -> Im a Error (Type a,[Pred (Type a)])            +infer gensym ngvars env hint (exp @ (Exp e)) =+  let check env hint x = infer gensym ngvars env hint x +  in+  case e of+    HsVar nm -> +      do { (cs :=> t) <- instan (envf env nm)+         ; cs2 <- unify t hint+         ; return (t,cs ++ cs2)+         }+    HsCon nm -> +      do { (cs :=> t) <- instan (envf env nm)+         ; cs2 <- unify t hint+         ; return (t,cs++cs2)+         }+    HsLit n -> +      do { let t = litTyp n+         ; cs <- unify t hint+         ; return (t,cs)+         }         +    HsInfixApp x f y -> check env hint (Exp(HsApp (Exp (HsApp f x)) y))+    HsApp f x ->+      do { xtyp <- newVar kstar+         ; let ftyp = tArrow xtyp hint   +         ; (_,cs2) <- check env xtyp x+         ; (_,cs3) <- check env ftyp f+         ; return (hint,cs2++cs3)+         }+    HsNegApp x ->+      do { (t,cs) <- check env hint x+         ; return (t,num t : cs)+         }+    HsLambda ps x ->+      do { (ptyps,ngv2,env2,cs) <- inferPats ps ngvars env+         ; result <- newVar kstar+           -- f [t1,t2,t3] r --> (t1 -> t2 -> t3 -> r)+         ; let f [] rng = rng+               f (t:ts) rng = tArrow t (f ts rng)+         ; (_,cs2) <- infer gensym ngv2 env2 result x+         ; return (f ptyps result,cs ++ cs2)+         }  +    HsLet ds e -> +      do { (ngv2,env2,cs2) <- inferDecls gensym ngvars env ds+         ; infer gensym  ngv2 env2 hint e+         }+    HsIf x y z -> +      do { t <- newVar kstar+         ; (_,cs1) <- check env tBool x+         ; (_,cs2) <- check env t y+         ; (_,cs3) <- check env t z+         ; return (t,cs1 ++ cs2 ++ cs3)+         }    +    HsCase e alts -> +      do { argtyp <- newVar kstar+         ; (ptyp,cs1) <- check env argtyp e+         ; csAll <- mapM (inferAlt gensym ngvars env ptyp hint) alts+         ; return (hint, cs1 ++ concat csAll)+         }+    HsDo stmt -> +      do { mtyp <- newVar (karrow kstar kstar)+         ; let m x =  (S(HsTyApp mtyp x))+         ; a <- newVar kstar+         ; cs2 <- unify hint (m a)+         ; cs3 <- inferStmt gensym ngvars env mtyp (m a) False stmt+         ; return (hint,(monad mtyp) : cs2 ++ cs3)+         }+    HsTuple xs -> +      do { pairs <- sequence (map (\ x -> do { t <- newVar kstar; return (t,x) }) xs)+         ; let tupletyp = tTuple(map fst pairs)+         ; cs1 <- unify hint tupletyp+         ; ts <- mapM (uncurry (check env)) pairs+         ; return (hint,foldr (\ (t,c) cs -> c ++ cs) cs1 ts)+         }+    HsList xs -> +      do { elemtyp <- newVar kstar+         ; cs1 <- unify hint (tlist elemtyp)+         ; pairs <- mapM (check env elemtyp) xs+         ; return (hint,foldr (\ (t,c) cs -> c ++ cs) cs1 pairs)+         }+    HsParen x -> check env hint x+    HsRightSection oper arg ->  -- i.e.  (+ 3) }+      do { ltyp <- newVar kstar+         ; rtyp <- newVar kstar+         ; anstyp <- newVar kstar+         ; cs1 <- unify (tArrow ltyp anstyp) hint+         ; (_,cs2) <- check env (tArrow ltyp (tArrow rtyp anstyp)) oper+         ; (_,cs3) <- check env rtyp arg+         ; return (hint,cs1 ++ cs2 ++ cs3)+         }+    HsLeftSection arg oper ->  -- i.e. (3 +)+      do { ltyp <- newVar kstar+         ; rtyp <- newVar kstar+         ; anstyp <- newVar kstar+         ; cs1 <- unify (tArrow rtyp anstyp) hint+         ; (_,cs2) <- check env (tArrow ltyp (tArrow rtyp anstyp)) oper+         ; (_,cs3) <- check env ltyp arg+         ; return (hint,cs1 ++ cs2 ++ cs3)+         }+    HsRecConstr name fields -> error "not yet"+    HsRecUpdate arg fields -> error "not yet" +    HsEnumFrom x ->                     -- [x ..] :: Enum a => [a]+      do { a <- newVar kstar+         ; cs1 <- unify hint (tlist a)+         ; (_,cs2) <- check env a x+         ; return (hint,(enum a) : cs1 ++ cs2)+         }+    HsEnumFromTo x y ->                 -- [x .. y] :: Enum a => a -> a -> [a]+      do { a <- newVar kstar+         ; cs0 <- unify hint (tlist a)+         ; (_,cs1) <- check env a x+         ; (_,cs2) <- check env a y+         ; return (hint,(enum a) : cs0 ++ cs1 ++ cs2)+         }+    HsEnumFromThen x y ->              -- [x, y ..] :  Enum a => a -> a -> [a] +      do { a <- newVar kstar+         ; cs0 <- unify hint (tlist a)+         ; (_,cs1) <- check env a x+         ; (_,cs2) <- check env a y+         ; return (hint,(enum a) : cs0 ++ cs1 ++ cs2)+         }+    HsEnumFromThenTo x y z ->          -- [x,y .. z] :: Enum a => a -> a -> a -> [a] +      do { a <- newVar kstar+         ; cs0 <- unify hint (tlist a)+         ; (_,cs1) <- check env a x+         ; (_,cs2) <- check env a y+         ; (_,cs3) <- check env a z+         ; return (hint,(enum a) : cs0 ++ cs1 ++ cs2 ++ cs3)+         }+    HsListComp stmt -> +      do { let mtyp = tlistCon+         ; let m x = (S(HsTyApp mtyp x))+         ; a <- newVar kstar+         ; cs2 <- unify hint (m a)+         ; cs3 <- inferStmt gensym ngvars env mtyp a True stmt+         ; return (hint,cs2 ++ cs3)+         }+    HsExpTypeSig loc e qt -> +      do { s <-  hsQual2Sch qt+         ; (cs1 :=> typ) <- instan s+         ; cs2 <- unify typ hint+         ; (_,cs3) <- check env typ e+         ; return (typ,cs1 ++ cs2 ++ cs3)+         }+    HsAsPat nm e -> error "pattern only"+    HsWildCard -> error "pattern only"+    HsIrrPat e -> error "pattern only"+    HsMetaBracket e ->  --  MetaHUGS extension <| exp |> +      do { a <- newVar kstar+         ; cs1 <- unify hint (tcode a)+         ; (_,cs2) <- check env a e+         ; return (hint,cs1 ++ cs2)+         }+    HsMetaEscape e ->   --  MetaHUGS extansion ^exp +      do { (_,cs1) <- check env (tcode hint) e+         ; return (hint,cs1)+         }+++----------------------------------------------------------------------------------+-- inferStmt is used to infer the type of both Do stmts and list comprehensions+-- [ A | p <- e ; f ]  has the same structure as (do { P <- e; f ; A })+-- but the type rules differ slightly for both "A" and "f". We've parameterized+-- inferStmt to handle this++inferStmt :: Genfun a -> NGV a -> Env a -> Type a -> Type a -> Bool ->+           Stmt -> Im a Error [Pred (Type a)]+inferStmt gensym ngvars env mtyp lasttyp isListComp stmt = +  let m x = (S(HsTyApp mtyp x)) in+  case stmt of+    HsGenerator p e next ->  --    p <- e ; next+      do { ptyp <- newVar kstar+         ; (_,cs2) <- infer gensym ngvars env (m ptyp) e+         ; (ngv2,env2,cs3) <- inferPat p ngvars env ptyp+         ; cs4 <- inferStmt gensym ngv2 env2 mtyp lasttyp isListComp next+         ; return (cs2 ++ cs3 ++ cs4)+         }        +    HsQualifier e next ->   --  e ; next+      do { typ <- if isListComp then return tBool else fmap m (newVar kstar)+         ; (_,cs2) <- infer gensym ngvars env typ e+         ; return cs2+         }+    HsLetStmt ds next ->   -- let ds ; next+      do { (ngv2,env2,cs2) <- inferDecls gensym ngvars env ds+         ; cs3 <- inferStmt gensym ngv2 env2 mtyp lasttyp isListComp next+         ; return (cs2 ++ cs3)+         }+    HsLast e -> do { (_,cs) <- infer gensym ngvars env lasttyp e; return cs }++ +inferAlt :: Genfun a -> NGV a -> Env a -> Type a -> Type a ->+           Alt -> Im a Error [Pred (Type a)]+inferAlt gensym ngvars env pathint bodyhint (HsAlt s p rhs ds) =+  do { (ngv2,env2,cs2) <- inferPat p ngvars env pathint+     ; (ngv3,env3,cs3) <- inferDecls gensym ngv2 env2 ds+     ; (_,cs4) <- +          case rhs of+            (HsBody e) -> infer gensym ngv3 env3 bodyhint e+            (HsGuard ms) -> g ms+                where g [] = return (bodyhint,[])+                      g ((s,guard,e):ws) =+                          do { (_,cs4) <- infer gensym ngv3 env3 tBool guard+                             ; (t,cs5) <- infer gensym ngv3 env3 bodyhint e+                             ; (_,cs6) <- g ws+                             ; return (t,cs4 ++ cs5 ++ cs6)+                             }+     ; return (cs2 ++ cs3 ++ cs4)+     }+++         +inferDecls :: Genfun a -> NGV a -> Env a -> +            [HsDecl] -> Im a Error (NGV a,Env a,[Pred (Type a)])+inferDecls gensym ngvars env ds = return (ngvars,env,[])            ++ +---------------------------------------------------------------------+-- The Parser produces HsQualType data structures, we must turn these+-- into Scheme data structures, while doing to we should kind-check+-- all the type information.++hsQual2Sch (HsQualType preds x) = scheme preds x+hsQual2Sch (HsUnQualType t) = scheme [] t++scheme :: [(HsName,HsName)] -> HsType -> Im a Error (Scheme Kind (U a Kind T))+scheme preds t = +   do { newks <- sequence(map (const (newVar Sort)) names)+              -- A new Kind var for each of the free type variables in "t"+      ; let env = zip names newks -- Map each Type Var to its kind Var+      ; mainK <- kindOf (look env) t+      ; argKs <- sequence (map uaSortK_to_Kind newks)+      ; return (Sch argKs (map transPred preds) (trans sub t))+      }           +  where names = namesT t  -- All the free Type Variables in "t"+        sub = zipWith (\ t n -> (t,TGen n)) names [0..]+        trans sub (Typ (HsTyVar nm)) = look sub nm+        trans sub (Typ z) = (S(mapT (trans sub) z))+        transPred (cla,arg) = IsIn (show cla) [trans sub (Typ(HsTyVar arg))]+
+ tools/base/TC/BaseTypeCheckStruct.hs view
@@ -0,0 +1,644 @@+-- $Id: BaseTypeCheckStruct.hs,v 1.5 2001/09/29 00:08:23 diatchki Exp $++module BaseTypeCheckStruct where++import BaseSyntaxStruct+import TypeGenerics+import List(nub)++--------------------------------------------------------------------+++type Type a = U a K T+type NGV a  = [(HsName, U a K T)]+type Env a  = [(HsName, Scheme K (U a K T))]++data Error +    = MatchError String (Vis T) (Vis T)+    | KindErrror String (Vis K) (Vis K)   +   +type GenFun a = GenSymFun HsName a Error++type EnvNew a = [Assump HsName K (U a K T)]++data GEnv a = GEnv [(HsName, Class a)] (NGV a) [Assump HsName K (U a K T)]++data Class a = Class HsName [Class a] [Inst a] ++type Inst a  = ([Pred (U a K T)], (Pred (U a K T)))++name  (GEnv cs ngv ass) x = let Class nm sup inst = look cs x in nm+super (GEnv cs ngv ass) x = let Class nm sup inst = look cs x in sup+insts (GEnv cs ngv ass) x = let Class nm sup inst = look cs x in ass +++------------------------------------------------------------------------+-- Instance declaration to make the T functor from HsSyn.hs appropriate+-- for doing type checking ala TypeGenerics.hs++instance G T where+    seqG = seqT+    mapG = mapT+    accG = accT++instance Name T HsName where+    isName (HsTyVar s) = Just s+    isName _           = Nothing++    fromName s = HsTyVar s++instance Gensym a HsName where+    newGensym  =+	do { seed <- newRef (1::Int)+	   ; let gensym s = do { n <- readVar seed+                               ; writeVar seed (n+1)+                               ; return $ UnQual (s ++ (show n))+                               }+             in return gensym+	   } ++    gensym s = do { n <- nextN   +                  ; return $ UnQual (s ++ (show n))+                  }++instance TypeError Error T K where +    typeError s x y = +	do { (nms, [x', y']) <- visible (generic []) [x, y]+	   ; raise (MatchError s x' y')+	   }+++-----------------------------------------------------------++type NGVars a = [(HsName, U a K T)]++emptyNGVars :: NGVars a+emptyNGVars = []++extendNGVars :: HsName -> U a K T -> NGVars a -> NGVars a+extendNGVars s t ngvars = (s, t) : ngvars++generic :: NGVars a -> U a K T -> IM a e Bool +generic ngvars v = do { b <- occursInList v ngvars+		      ; return $ not b+		      }+     where occursInList v l =+               do { TVar v' <- prune v+		  ; bools <- mapM (\ (a, b) -> occursIn v' b) l+		  ; return $ or bools+		  }+       +--------- Show Instances ----------------------------------++-- To be turned into Printable instances+                             +instance Show(U a k T) where +  showsPrec n (S x) = shows x+  showsPrec n (TGen m) = showString "%" . shows m+  showsPrec n (TVar _) = showString "?"++instance Show(Vis T) where +  showsPrec n (VN a) = showString a+  showsPrec n (VS x) = shows x  +  ++instance Show a => Show(Pred a) where+  show (IsIn n ts) = "(" ++ n ++ " " ++ (show ts) ++ ")"++instance Show a => Show (Scheme K a) where+  show (Sch x p t) = "(all " ++ (show x) ++"." ++ (show p) +++		     " => " ++ (show t) ++ ")"  +++----------------------- Instantiate unification ------------------------------++unifyShape unify (x @ (S tx)) (y @ (S ty)) =+  case (tx, ty) of+   (HsTyFun x1 x2, HsTyFun y1 y2) ->+      do { xs <- unify x1 y1 +         ; ys <- unify x2 y2 +         ; return $ xs ++ ys+	 }     ++   (HsTyTuple xs, HsTyTuple ys) ->+      if (length xs) == (length ys) then+	  do { xss <- mapM (uncurry unify) (zip xs ys)+             ; return $ concat xss+             }+      else+          typeError "TupleLengthMatch" x y++   (HsTyApp x1 x2, HsTyApp y1 y2) ->+      do { xs <- unify x1 y1 +         ; ys <- unify x2 y2 +         ; return $ xs ++ ys+	 }   ++   (HsTyVar n1, HsTyVar n2) ->+      if n1 == n2 then+	  return []+      else+          typeError "NameMatch" x y ++   (HsTyCon n1, HsTyCon n2) ->+      if n1 == n2 then+	  return []+      else+          typeError "NameMatch" x y          ++   _ -> typeError "ShapeMatch" x y+      ++unify :: U a K T -> U a K T ->  IM a Error [p]+unify = unifier (typeError "OccursCheck") unifyShape+     +     +------------------ K inference -----------------------+data Sort = Sort+type Kind a = U a Sort K++instance G K where+  mapG = mapK+  seqG = seqK+  accG f = flip (accK f)++instance TypeError Error K Sort where+  typeError s x y = +    do { (nms, [x', y']) <- visible (\ x -> return False) [x,y]+       ; raise (KindError s x' y')+       }++unifyK unify (x @ (S tx)) (y @ (S ty)) =+  case (tx,ty) of+   (Kstar, Kstar) -> return []++   (Kfun x1 x2, Kfun y1 y2) ->+      do { xs <- unify x1 y1 +         ; ys <- unify x2 y2 +         ; return $ xs ++ ys+	 }   ++   _ -> typeError "KindShapeMatch"  x y+      +unifyKind :: (U a Sort K) -> (U a Sort K) ->  IM a Error [p]+unifyKind = unifier (typeError "OccursCheck") unifyK++star = S Kstar ++inferK :: (HsName -> U a Sort K) -> U a Sort K -> HsType+          -> IM a Error (U a Sort K)+inferK env hint (Typ typ) =+  case typ of+    (HsTyFun x y) ->+       do { x' <- inferK env star x+          ; y' <- inferK env star y+          ; unifyKind hint star+          ; return hint+          }++    (HsTyTuple ts) ->+       do { sequence (map (inferK env star) ts)+          ; unifyKind hint star+          ; return star+          }++    (HsTyApp x y) ->+       do { a <- newVar Sort+          ; b <- newVar Sort+          ; x' <- inferK env (S (Kfun a hint)) x+          ; y' <- inferK env a y+          ; return hint+          }++    (HsTyVar nm) ->+       do { unifyKind hint (env nm)+          ; return hint+          }++    (HsTyCon nm) ->  +       do { unifyKind hint (env nm)+          ; return hint+          }++kindOf :: (HsName -> U a Sort K) -> HsType -> IM a Error K+kindOf envf x = do { hint <- newVar Sort+                   ; inferK envf hint x+                   ; k <- uaSortK_to_Kind hint+                   ; return k+                   }+       +----------------------------------------------------------------------------+-- After Kind inference some of the Kind Vars may still be un-instantiated+-- Since we do not have a "polymorphic" Kind system we must instantiate+-- these Kind vars. We fix them to kind "Knd Kstar", and then turn the +-- resulting (U a Sort K)  thing into a "Kind" type.++uaSortK_to_Kind :: (U a Sort K) -> IM a e K+uaSortK_to_Kind (S x) = do { x' <- seqMapG uaSortK_to_Kind x+			   ; return x'+			   }+uaSortK_to_Kind (TGen m) = error "no TGen in kinds"+uaSortK_to_Kind (t @ (TVar x)) = follow finish uaSortK_to_Kind t+    where finish :: (Tyvar a Sort K) -> IM a e K+          finish (Tyvar ref s) = do { writeVar ref (Just star)+                                    ; return Kstar+				    }+                 +     +--------------- Environment function and types --------------------------+++extend f s t = (s, t) : f++lambdaExt :: [(name, Scheme a c)] -> name -> c -> [(name, Scheme a c)]+lambdaExt env vname vtyp = extend env vname (Sch [] [] vtyp)++envf [] s = error ("variable not found: " ++ (show s) ++ "\n")+envf ((x, t):m) s = if x == s then t else envf m s++-------- Type constructors and types of literal constants ------------++tArrow x y = S $ HsTyFun x y+tTuple ts  = S $ HsTyTuple ts+tInteger   = S $ HsTyCon (UnQual "Integer")+tChar      = S $ HsTyCon (UnQual "Char")+tString    = tlist tChar+tRational  = S $ HsTyCon (UnQual "Rational")+tBool      = S $ HsTyCon (UnQual "Bool")++tStringHash   = S $ HsTyCon (UnQual "stringHash")+tCharHash     = S $ HsTyCon (UnQual "CharHash")+tIntHash      = S $ HsTyCon (UnQual "IntHash")+tRationalHash = S $ HsTyCon (UnQual "RationalHash")+tlist x       = S $ HsTyApp tlistCon x+tlistCon      = S $ HsTyCon (UnQual "[]")++tcode x  = S $ HsTyApp tcodeCon x+tcodeCon = S $ HsTyCon (UnQual "Code")++litTyp (HsInt _)        = tInteger+litTyp (HsChar _)       = tChar+litTyp (HsString _)     = tString+litTyp (HsFrac _)       = tRational+litTyp (HsCharPrim _)   = tCharHash+litTyp (HsStringPrim _) = tStringHash+litTyp (HsIntPrim _)    = tIntHash+litTyp (HsFloatPrim _)  = tRationalHash+litTyp (HsDoublePrim _) = tRationalHash++------------------------ Predefined Class predicates ----------------++num x   = IsIn "Num" [x] +monad x = IsIn "Monad" [x]+enum x  = IsIn "Enum" [x]++-------------------------------------------------------------------------+-- unArrow [p1,p2,p3] (t1 -> t2 -> t3 -> t4) --->+--         (t4, [(p1, t1), (p2, t2), (p3, t3)])++unArrow :: [P] -> Type a -> IM a Error (Type a, [(P, Type a)])+unArrow ps t = do { t' <- col t+		  ; flat ps t'+		  }+  where flat (p:ps) (S (HsTyFun dom rng)) = +            do { (t, ts) <- (flat ps rng)+	       ; return (t, (p, dom) : ts)+	       }+        flat [] t = return (t, [])+        flat (p:ps) t = error "Too many arguments to pattern"+++patExtTup [] env = return ([], [], [])+patExtTup ((p, t):m) env = +    do { (t1, e1, c1) <- patExt p t env+       ; (ts, e2, cs) <- patExtTup m env +       ; return (t1:ts, e1 ++ e2, c1 ++ cs)+       }++patExtList []    elemtyp env cs = return (tlist elemtyp, [], cs)+patExtList (p:m) elemtyp env cs = +    do { (t1, e1, c1) <- patExt p elemtyp env+       ; (listOfelem, e2, cs) <- patExtList m elemtyp env c1+       ; return (listOfelem, e1 ++ e2, c1 ++ cs)+       }++patExt :: P -> Type a -> Env a+          -> IM a Error (Type a, NGV a, [Pred (Type a)])+patExt p typ env =+  case p of+   (HsPVar name) -> return (typ, [(name, typ)], [])+   (HsPLit l) -> +      do { let t = litTyp l+         ; cs <- unify t typ+         ; return (t, [], cs)+         }+   (HsPNeg x) -> error "whats this?"+   (HsPInfixApp x n y) -> patExt (Pat(HsPApp n [x, y])) typ env +   (HsPApp nm ps) -> +      do { (cs1 :=> ctyp) <- instan (envf env nm) +         ; (t, patTypeList) <- unArrow ps ctyp+         ; cs2 <- unify t typ+         ; (ts2, env2, cs3) <- patExtTup patTypeList env +         ; return (t, env2, cs1 ++ cs2 ++ cs3)+         }+   (HsPTuple ps) ->+      do { ts <- sequence (map (\ x -> (newVar kstar)) ps)+         ; cs2 <- unify (tTuple ts) typ+         ; (ts, ngv3, cs3) <- patExtTup (zip ps ts) env+         ; return (tTuple ts, ngv3, cs2 ++ cs3)+         }         +   (HsPList ps ) -> +      do { elemtyp <- newVar kstar+         ; (listtyp, ngv2, cs) <- patExtList ps elemtyp env []+         ; cs2 <- unify listtyp (tlist elemtyp)+         ; return (listtyp, ngv2, cs ++ cs2)+         }        +   (HsPParen x) -> patExt x typ env+   (HsPRec n pairs) -> error "not yet"+   (HsPRecUpdate nm pairs) -> error "not yet"+   (HsPAsPat name x) ->+      do { (t, ngv1, cs1) <- patExt x typ env+         ; return (t, (name, t):ngv1, cs1)+         }+   (HsPWildCard) -> do { t <- newVar kstar+		       ; return (t, [], [])+		       }+   (HsPIrrPat x) -> patExt x typ env++inferPats :: [HsPat] -> NGV a -> Env a+	     -> IM a Error ([Type a], NGV a, Env a, [Pred (Type a)])+inferPats ps ngvars env =+    do { pairs <- sequence $ map (\ p -> do { t <- newVar kstar+					    ; return (p, t)+					    })+                                 ps+       ; (t1, ngv1, cs1) <- patExtTup pairs env+       ; return (t1, ngv1 ++ ngvars, g ngv1 env, cs1)+       }+    where g [] env            = env+          g ((v, t):more) env = lambdaExt (g more env) v t+  +inferPat p ngvars env hint =+    do { (_, ngv1, cs1) <- patExt p hint env+       ; return (ngv1 ++ ngvars, g ngv1 env, cs1)+       } +    where g [] env            = env+          g ((v, t):more) env = lambdaExt (g more env) v t+    +-------------------------------------------------------------+    +type Infer a s = GenFun a -> NGV a -> Env a -> Type a -> s+                 -> IM a Error (Type a, [Pred (Type a)])+{-+inferE :: GenFun a -> NGV a+	  -> Infer d -> Infer t -> Infer e -> Infer p+	  -> (E d t e p -> e)+	  -> Env a -> Type a+	  -> E d t e p+          -> IM a Error (Type a, [Pred (Type a)])+-}+inferE gensym ngvars ec di ti ei pi env hint e =+    let checkD = di gensym ngvars+	checkE = ei gensym ngvars+	checkP = pi gensym ngvars+    in   +        case e of+	HsVar nm -> +	    do { (cs :=> t) <- instan (envf env nm)+               ; cs2 <- unify t hint+               ; return (t, cs ++ cs2)+               }+	HsCon nm -> +	    do { (cs :=> t) <- instan (envf env nm)+               ; cs2 <- unify t hint+               ; return (t, cs ++ cs2)+               }+	HsLit n -> +	    do { let t = litTyp n+               ; cs <- unify t hint+               ; return (t, cs)+               }         +	HsInfixApp x f y -> checkE env hint (ec (HsApp (ec (HsApp f x)) y))+	HsApp f x ->+	    do { xtyp <- newVar kstar+               ; let ftyp = tArrow xtyp hint   +               ; (_, cs2) <- checkE env xtyp x+               ; (_, cs3) <- checkE env ftyp f+               ; return (hint, cs2 ++ cs3)+               }+	HsNegApp x ->+	    do { (t, cs) <- checkE env hint x+               ; return (t, num t : cs)+               }+	HsLambda ps x ->+	    do { (ptyps, ngv2, env2, cs) <- checkP ngvars env ps+               ; result <- newVar kstar+		 -- f [t1,t2,t3] r --> (t1 -> t2 -> t3 -> r)+               ; let f []     rng = rng+		     f (t:ts) rng = tArrow t (f ts rng)+               ; (_, cs2) <- infer gensym ngv2 env2 result x+               ; return (f ptyps result, cs ++ cs2)+               }  +	HsLet ds e -> +	    do { (ngv2, env2, cs2) <- di gensym ngvars env ds+               ; infer gensym  ngv2 env2 hint e+               } +	HsIf x y z -> +	    do { t <- newVar kstar+               ; (_, cs1) <- checkE env tBool x+               ; (_, cs2) <- checkE env t y+               ; (_, cs3) <- checkE env t z+               ; return (t, cs1 ++ cs2 ++ cs3)+               }    +	HsCase e alts -> +	    do { argtyp <- newVar kstar+               ; (ptyp, cs1) <- checkE env argtyp e+               ; csAll <- mapM (inferAlt gensym ngvars env ptyp hint) alts+               ; return (hint, cs1 ++ concat csAll)+               }+	HsDo stmt -> +	    do { mtyp <- newVar (karrow kstar kstar)+               ; let m x = S (HsTyApp mtyp x)+               ; a <- newVar kstar+               ; cs2 <- unify hint (m a)+               ; cs3 <- inferStmt gensym ngvars env mtyp (m a) False stmt+               ; return (hint, (monad mtyp) : cs2 ++ cs3)+               }+	HsTuple xs -> +	    do { pairs <- sequence $ map (\ x -> do { t <- newVar kstar+						    ; return (t, x)+						    })+		                     xs+               ; let tupletyp = tTuple (map fst pairs)+               ; cs1 <- unify hint tupletyp+               ; ts <- mapM (uncurry (check env)) pairs+               ; return (hint, foldr (\ (t, c) cs -> c ++ cs) cs1 ts)+               }+	HsList xs -> +	    do { elemtyp <- newVar kstar+               ; cs1 <- unify hint (tlist elemtyp)+               ; pairs <- mapM (check env elemtyp) xs+               ; return (hint, foldr (\ (t, c) cs -> c ++ cs) cs1 pairs)+               }+	HsParen x -> check env hint x+	HsRightSection oper arg ->     -- i.e.  (+ 3) }+            do { ltyp <- newVar kstar+               ; rtyp <- newVar kstar+	       ; anstyp <- newVar kstar+	       ; cs1 <- unify (tArrow ltyp anstyp) hint+	       ; (_, cs2) <- check env (tArrow ltyp (tArrow rtyp anstyp)) oper+	       ; (_, cs3) <- check env rtyp arg+	       ; return (hint, cs1 ++ cs2 ++ cs3)+	       }     +	HsLeftSection arg oper ->      -- i.e. (3 +)+	    do { ltyp <- newVar kstar+	       ; rtyp <- newVar kstar+	       ; anstyp <- newVar kstar+	       ; cs1 <- unify (tArrow rtyp anstyp) hint+	       ; (_, cs2) <- check env (tArrow ltyp (tArrow rtyp anstyp)) oper+	       ; (_, cs3) <- check env ltyp arg+	       ; return (hint, cs1 ++ cs2 ++ cs3)+	       }  +	HsRecConstr name fields -> error "not yet"+	HsRecUpdate arg fields -> error "not yet" +	HsEnumFrom x ->                -- [x ..] :: Enum a => [a]+	    do { a <- newVar k star+               ; cs1 <- unify hint (tlist a)+	       ; (_, cs2) <- check env a x+	       ; return (hint, (enum a) : cs1 ++ cs2)+	       }+	HsEnumFromTo x y ->            -- [x .. y] :: Enum a => a -> a -> [a]+	    do { a <- newVar kstar+               ; cs0 <- unify hint (tlist a)+	       ; (_, cs1) <- check env a x+	       ; (_, cs2) <- check env a y+	       ; return (hint, (enum a) : cs0 ++ cs1 ++ cs2)+	       }  +	HsEnumFromThen x y ->          -- [x, y ..] :  Enum a => a -> a -> [a] +            do { a <- newVar kstar+               ; cs0 <- unify hint (tlist a)+	       ; (_, cs1) <- check env a x+	       ; (_, cs2) <- check env a y+	       ; return (hint, (enum a) : cs0 ++ cs1 ++ cs2)+	       } +	HsEnumFromThenTo x y z -> -- [x,y .. z] :: Enum a => a -> a -> a -> [a]+            do { a <- newVar kstar+	       ; cs0 <- unify hint (tlist a)+	       ; (_, cs1) <- check env a x+	       ; (_, cs2) <- check env a y+	       ; (_, cs3) <- check env a z+	       ; return (hint, (enum a) : cs0 ++ cs1 ++ cs2 ++ cs3)+               }+	HsListComp stmt -> +            do { let mtyp = tlistCon+	       ; let m x = (S(HsTyApp mtyp x))+	       ; a <- newVar kstar+	       ; cs2 <- unify hint (m a)+	       ; cs3 <- inferStmt gensym ngvars env mtyp a True stmt+	       ; return (hint, cs2 ++ cs3)+	       }  +	HsExpTypeSig loc e qt -> +	    do { s <-  hsQual2Sch qt+               ; (cs1 :=> typ) <- instan s+	       ; cs2 <- unify typ hint+	       ; (_, cs3) <- check env typ e+	       ; return (typ, cs1 ++ cs2 ++ cs3)+               }+	HsAsPat nm e -> error "pattern only"+	HsWildCard -> error "pattern only"+	HsIrrPat e -> error "pattern only"+++-------------------------------------------------------------------------------+-- inferStmt is used to infer the type of both Do stmts and list comprehensions+-- [ A | p <- e ; f ]  has the same structure as (do { P <- e; f ; A })+-- but the type rules differ slightly for both "A" and "f". We've parameterized+-- inferStmt to handle this++{-+inferStmt :: GenFun a -> NGV a -> Env a -> Type a -> Type a -> Bool ->+           Stmt -> IM a Error [Pred (Type a)]+-}+inferStmt gensym di ei pi ngvars env mtyp lasttyp isListComp stmt = +    let m x = S (HsTyApp mtyp x)+	check = inferStmt gensym di ei pi+    in+        case stmt of+	HsGenerator p e next ->  --    p <- e ; next+            do { ptyp <- newVar kstar+               ; (_, cs2) <- ei gensym ngvars env (m ptyp) e+               ; (ngv2, env2, cs3) <- pi p ngvars env ptyp+               ; cs4 <- check ngv2 env2 mtyp lasttyp isListComp next+               ; return $ cs2 ++ cs3 ++ cs4+               }        +        HsQualifier e next ->   --  e ; next+            do { typ <- if isListComp then+		            return tBool+		        else+		            fmap m (newVar kstar)+               ; (_, cs2) <- ei gensym ngvars env typ e+               ; return cs2+               }+        HsLetStmt ds next ->   -- let ds ; next+            do { (ngv2, env2, cs2) <- di gensym ngvars env ds+               ; cs3 <- check ngv2 env2 mtyp lasttyp isListComp next+               ; return $ cs2 ++ cs3+               }+        HsLast e ->+            do { (_, cs) <- ei gensym ngvars env lasttyp e+               ; return cs+               }++{-+inferAlt :: GenFun a -> NGV a -> Env a -> Type a -> Type a -> Alt+            -> IM a Error [Pred (Type a)]+-}+inferAlt gensym di ei pi ngvars env pathint bodyhint (HsAlt s p rhs ds) =+    do { (ngv2, env2, cs2) <- pi p ngvars env pathint+       ; (ngv3, env3, cs3) <- di gensym ngv2 env2 ds+       ; (_, cs4) <- +         case rhs of+         HsBody e -> ei gensym ngv3 env3 bodyhint e+         HsGuard ms ->+	     g ms+             where g []                 = return (bodyhint, [])+                   g ((s, guard, e):ws) =+                       do { (_, cs4) <- ei gensym ngv3 env3 tBool guard+                          ; (t, cs5) <- ei gensym ngv3 env3 bodyhint e+                          ; (_, cs6) <- g ws+                          ; return (t, cs4 ++ cs5 ++ cs6)+                          }+       ; return $ cs2 ++ cs3 ++ cs4+       }+++inferDecls :: GenFun a -> NGV a -> Env a -> [HsDecl]+              -> IM a Error (NGV a, Env a, [Pred (Type a)])+inferDecls gensym ngvars env ds = return (ngvars, env, [])            ++ +---------------------------------------------------------------------+-- The Parser produces HsQualType data structures, we must turn these+-- into Scheme data structures, while doing so we should kind-check+-- all the type information.++hsQual2Sch (HsQualType preds x) = scheme preds x+hsQual2Sch (HsUnQualType t)     = scheme [] t++scheme :: [(HsName, HsName)] -> HsType -> IM a Error (Scheme Kind (U a Kind T))+scheme preds t = +    do { newks <- sequence(map (const (newVar Sort)) names)+               -- A new Kind var for each of the free type variables in "t"+       ; let env = zip names newks -- Map each Type Var to its kind Var+       ; mainK <- kindOf (look env) t+       ; argKs <- sequence $ map uaSortK_to_Kind newks+       ; return $ Sch argKs (map transPred preds) (trans sub t)+       }           +    where names = namesT t  -- All the free Type Variables in "t"+	  sub = zipWith (\ t n -> (t, TGen n)) names [0..]++	  trans sub (Typ (HsTyVar nm)) = look sub nm+	  trans sub (Typ z) = (S(mapT (trans sub) z))++          transPred (cla, arg) =+	      IsIn (show cla) [trans sub (Typ (HsTyVar arg))]
+ tools/base/TC/Components.hs view
@@ -0,0 +1,139 @@+module Components where++import Syntax+import Scope+import List((\\))+-- import LazyST++getAllNames (HsModule _ _ _ ds) = +    let boundNames = map (map fst . varNames) (map names ds)+	fvNames    = map freeVarsDecl ds+    in+        (boundNames, fvNames, zipWith (\\) fvNames boundNames)+++freeVarsExp (Exp e) = freeVarsE freeVarsExp e++freeVarsDecl (Dec d) = freeVarsD freeVarsDecl freeVarsExp d++-- dif === (\\), provided the argument lists don't contain duplicates.+{-+dif [] _ = []+dif (x:xs) ys = if (x `elem` ys) then dif xs ys else x : (dif xs ys)+-}++{-+type Vertex  = Int++-- Representing graphs:++type Table a = [(Vertex, a)]+type Graph   = Table [Vertex]++vertices :: Graph -> [Vertex]+vertices  = map fst graph++type Edge = (Vertex, Vertex)++aat tab v = case List.find (\ (x,y) -> x == v) tab of Just (_,r) -> r+indices tab = map fst tab++edges    :: Graph -> [Edge]+edges g   = [ (v, w) | v <- vertices g, w <- g `aat` v ]++mapTr    :: (Vertex -> a -> b) -> Table a -> Table b+mapTr f t = [ (v, f v (t `aat` v)) | v <- indices t ]++type Bounds = (Vertex, Vertex)++outdegree :: Graph -> Table Int+outdegree  = mapTr numEdges+             where numEdges v ws = length ws++buildG :: Bounds -> [Edge] -> Graph+buildG _ [] = []+buildG _ (x:xs) = ++graph = buildG (1,10)+         (reverse+          [ (1, 2),  (1, 6),  (2, 3),+            (2, 5),  (3, 1),  (3, 4),+            (5, 4),  (7, 8),  (7, 10),+            (8, 6),  (8, 9),  (8, 10) ]+         )+         +-- Depth-first search++-- Specification and implementation of depth-first search:++data Tree a   = Node a (Forest a) deriving Show+type Forest a = [Tree a]++nodesTree (Node a f) ans = nodesForest f (a:ans)+nodesForest [] ans = ans+nodesForest (t : f) ans = nodesTree t (nodesForest f ans)++dff          :: Graph -> Forest Vertex+dff g         = dfs g (vertices g)++dfs          :: Graph -> [Vertex] -> Forest Vertex+dfs g vs      = prune (bounds g) (map (generate g) vs)++generate     :: Graph -> Vertex -> Tree Vertex+generate g v  = Node v (map (generate g) (g `aat` v))+++type Set s    = STArray s Vertex Bool++mkEmpty      :: Bounds -> ST s (Set s)+mkEmpty bnds  = newSTArray bnds False++contains     :: Set s -> Vertex -> ST s Bool+contains m v  = readSTArray m v++include      :: Set s -> Vertex -> ST s ()+include m v   = writeSTArray m v True++prune        :: Bounds -> Forest Vertex -> Forest Vertex+prune bnds ts = runST (mkEmpty bnds >>= \m ->+                       chop m ts)++chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)+chop m []     = return []+chop m (Node v ts : us)+              = contains m v >>= \visited ->+                if visited then+                  chop m us+                else+                  include m v >>= \_  ->+                  chop m ts   >>= \as ->+                  chop m us   >>= \bs ->+                  return (Node v as : bs)+         +-- Algorithm 2: topological sorting++postorder :: Tree a -> [a]+postorder (Node a ts) = postorderF ts ++ [a]++postorderF   :: Forest a -> [a]+postorderF ts = concat (map postorder ts)++postOrd      :: Graph -> [Vertex]+postOrd       = postorderF . dff++--topSort      :: Graph -> [Vertex]+--topSort       = reverse . postOrd   ++-- Algorithm 4: strongly connected components++reverseE    :: Graph -> [Edge]+reverseE g   = [ (w, v) | (v, w) <- edges g ]++transposeG  :: Graph -> Graph+transposeG g = buildG (bounds g) (reverseE g)++scc          :: Graph -> Forest Vertex+scc g         = dfs (transposeG g) (reverse (postOrd g))+ +scc2 g = reverse (map (\ t -> nodesTree t []) (scc graph))+-}
+ tools/base/TC/InferenceMonad.hs view
@@ -0,0 +1,105 @@+-- $Id: InferenceMonad.hs,v 1.6 2001/03/28 22:08:56 sheard Exp $++module InferenceMonad where++import ST++data Value g b = Good g | Bad b deriving (Show, Eq)++newtype IM a e x = Ck (Int -> (ST a (Value x e, String, Int)))++instance Functor (IM a e) where+  fmap f (Ck g) = Ck h+      where h n = do { (x, out, n') <- g n+                     ; case x of +                       Good a -> return (Good (f a), out, n')+                       Bad  w -> return (Bad w,      out, n')+                     }+                   +instance Monad (IM a t) where +  return x = Ck h+      where h n = return (Good x, "", n)+  (Ck g) >>= f = Ck ff+      where ff n = do { (x, out1, n1) <- g n+                      ; case x of +                        Good a -> let (Ck h) = f a+                                  in do { (y, out2, n2) <- h n1+                                        ; return (y, out1 ++ out2, n2)+                                        }+                        Bad b  -> return (Bad b, out1, n1)+                      }++---- Non standard morphisms for IM monad ----------------++----- First Mutable vars ----------------------                      +                      +readVar  :: STRef a b -> IM a c b+newRef   :: a -> IM b c (STRef b a)+writeVar :: STRef a b -> b -> IM a c ()+                       +readVar ref = Ck f +    where f n = do { z <- readSTRef ref+                   ; return (Good z, "", n)+                   }+                 +newRef init = Ck f+    where f n = do { z <- newSTRef init+                   ; return (Good z, "", n)+                   }+                 +writeVar ref value = Ck f+    where f n = do { z <- writeSTRef ref value+                   ; return (Good z, "", n)+                   } ++nextN = Ck f+    where f n = return (Good n, "", n+1)++------------- Then printing and error handling -----------++printS s = Ck f+    where f n = return (Good (), s, n)++pr :: Show a => [Char] -> a -> IM b c ()+pr s x = printS (s ++ (show x) ++ " -\n")++raise :: a -> IM b a c+raise err = Ck f+    where f n = return (Bad err, "", n)++handle :: IM a b c -> (b -> IM a b c) -> IM a b c+handle (Ck m) f = Ck h+    where h n = do { (x, out1, n') <- m n+                   ; case x of+                     Good y -> return (x, out1, n')+                     Bad y  -> let Ck a = f y+                               in do { (b, out2, m) <- a n'+                     ; return (b, out1 ++ out2, m) +                     }+                   }++-------------- Finally the run function for the monad --------------  ++runIM :: (forall a . IM a e c) -> Int -> (Value c e,String,Int)+runIM w n = let (Ck f) = w in runST (f n)+  +  +force :: (forall a . IM a e c) -> c+force w =+    case (runIM w) 0 of+    (Good x, _, _) -> x+    (Bad x,  s, _) -> error ("error in Inference monad: " ++ s)+     ++display :: Show c => (forall a . IM a e c) -> String+display a =+    case (runIM (do { x <- a ; pr "" x })) 0 of+    (_, s, _) -> s++perform :: Show a => (forall c. IM c a String) -> IO ()+perform x =+  case runIM x 0 of+    (Good x,message,n) -> do { putStrLn ("Good\n"++message); putStrLn"\n--------------\n"+                             ; putStrLn x }+    (Bad y, message,n) -> do { putStrLn ("Bad\n"++message); putStrLn"\n--------------\n"+                             ; putStrLn (show y) }
+ tools/base/TC/TypeCheck.hs view
@@ -0,0 +1,1401 @@+-- $Id: TypeCheck.hs,v 1.39 2001/09/29 00:08:23 diatchki Exp $++module TypeCheck where++import TypeGenerics+import Monad(mapM, foldM)+import HsName+import HsTypeStruct+import Syntax+import InferenceMonad+import List(nub, find, intersect, (\\), lookup, union)+import ST+import SCC(bindingGroups)+import qualified Scope+import SyntaxUtil(getTyName)+------------------------------------------------------+infix 9 |->+infixr 3 +:++type Kind a    = GT K Sort (STRef a)+type Type a    = GT T (Kind a) (STRef a)+type NGV a     = [(HsName, Type a)]+type Env a     = [(HsName, Scheme a)]+type Constrs a = [Pred a]+type Ref a = (Int,STRef a (Maybe(Type a)))+type Ptr2 a = STRef a (Maybe(Type a))+type Genfun a = String -> IM a Error HsName +type KindEnv a = [(HsName, GT K Sort (STRef a))]++data Pred a = IsIn HsName [Type a]+data Scheme a = Sch [Kind a] [Pred a] (Type a)+data Qual a x = [Pred a] :=> x+data Assump name a =  name :>: Scheme a+++data Error = TCerror String++instance Show Error where+  show (TCerror s) = s++fails :: String -> IM a Error x+fails s = raise    (TCerror s)++unifyErr x y z = fails ((show x) ++"error in unification " ++ (show y)++", "++(show z))++instance Show (STRef a b) where+  show x = "?"+--------------------------------------------------------+newGensym :: IM a Error (Genfun a)+newGensym  =+    do { seed <- newRef (1::Int)+       ; let gensym s = do { n <- readVar seed+                           ; writeVar seed (n+1)+                           ; return (UnQual (s ++ (show n)))+                           }+         in return gensym+       }+       +  {-gensym s = do { n <- nextN   +                ; return (UnQual (s ++ (show n)))+                }+-}++------------------ Kind inference -----------------------++data Sort = Sort deriving Eq++kindA :: A K Sort () (STRef a) (IM a Error)+kindA =+    A { sameVarA = refEq+      , writeVarA = writeVar+      , readVarA = readVar+      , newVarA = newRef+      , nextA = nextN+      , zeroA = ()+      , unionA = const ()+      , genErrA = unifyErr+      , seqA = seqK+      , mapA = mapK+      , accA f = flip (accK f)+      , matchA = matchK+      , kindofA = const(return Sort)+      , samekindA = (==)+      }++refEq :: STRef a b -> STRef a b -> Bool+refEq x y = x==y++eqK :: Kind a -> Kind a -> Bool ++B{ unifyGT = unifyKind+ , equalGT = eqK+ , freshGT = newVarK + , pruneGT = pruneK+ , substGT = substK+ , genGT = genK } = makeUnify kindA++star = S Kstar+arrowK x y = S(Kfun x y)+predicate = S Kpred+++instance Eq (Kind a) where+  (==) = eqK++-- Works on HSTypes while inferK2 works on (Type a)+inferK ::  [(HsName,Kind a)] -> Kind a ->  HsType -> IM a Error (Kind a)+inferK kenv k t =+  do { let f (nm,k) = do { v <- newVar k; return (nm,v)}+           h :: [(HsName,Type a)] -> HsType -> Type a+           h pairs (Typ (HsTyVar x)) = look pairs x+           h pairs (Typ x) = S(mapT (h pairs) x)+     ; pairs <- mapM f kenv+     ; inferK2 kenv k (h pairs t) +     }+++inferK2 :: [(HsName, Kind a)] -> Kind a -> (Type a) -> IM a Error (Kind a)         +inferK2 env hint t =+  do { t' <- prune t+     ; case t' of+         (TVar r k) -> return k+         (TGen n) -> return hint+         (S typ) ->+          case typ of+            (HsTyFun x y) ->+               do { x' <- inferK2 env star x+                  ; y' <- inferK2 env star y+                  ; unifyKind hint star+                  ; return hint+                  }+            (HsTyTuple ts) ->+               do { sequence (map (inferK2 env star) ts)+                  ; unifyKind hint star+                  ; return star+                  }+            (HsTyApp f x) ->+               do { a <- newVarK Sort+                  ; inferK2 env (S(Kfun a hint)) f+                  ; inferK2 env a x+                  ; return hint+                  }+            (HsTyVar nm) ->+               do { unifyKind hint (lookUpEnv env nm)+                  ; return hint+                  }+            (HsTyCon nm) ->  +               do { unifyKind hint (lookUpEnv env nm)+                  ; return hint+                  } }+                  +kindOf2 :: [(HsName,Kind a)] -> Type a -> IM a Error (Kind a)+kindOf2 envf x = do { hint <- newVarK Sort+                    ; inferK2 envf hint x+                    ; (ks,ts,x') <- genK (\ x -> return True) hint+                    ; k' <- substK (repeat star) x'+                    ; return k'+                    }+                    +getkind :: Type a -> IM a Error (Kind a)                    +getkind t = kindOf2 kenv0 t+  +  +--------------------------------------------------------------+typeA :: A T (Kind c) [Pred c] (STRef c) (IM c Error) +typeA =+    A { sameVarA = refEq+      , writeVarA = writeVar+      , readVarA = readVar+      , newVarA = newRef+      , nextA = nextN+      , zeroA = []+      , unionA = concat+      , genErrA = unifyErr+      , seqA = seqT+      , mapA = mapT+      , accA = accT+      , matchA = matchT+      , kindofA = getkind+      , samekindA = eqK+      }+   +prune :: Type a -> IM a Error (Type a)+unify :: Type a -> Type a -> IM a Error [Pred a]+subst :: [Type a] -> Type a -> IM a Error (Type a)+B{ unifyGT = unify+ , matchGT = matchType+ , equalGT = teq+ , freshGT = newVar+ , colGT = col+ , occursGT = occursIn+ , pruneGT = prune+ , substGT = subst+ , genmapGT = gen+ } = makeUnify typeA    + +++match :: Type a -> Type a -> IM a Error Bool+match x y = (do { matchType x y; return True}) `handle` (\ _ -> return False)+  +    +unifyList xs ys =     + if (length xs) == (length ys)  +    then do { xss <- mapM (uncurry unify) (zip xs ys)+            ; return (concat xss)+            }+    else fails "Lists not same length"+     +---------------------------------------------------------------++class Types t a where+  tv :: t -> IM a Error [Ref a]+  collapse :: t -> IM a Error t++  +instance Types (Type a) a where+    tv t = do { t' <- prune t+              ; case t' of+                 (TVar r k) -> return [r]+                 (S x) -> do { sh <- seqT (mapT tv x)+                            ; return $ nub (accT (++) sh [])+                            }+                 (TGen i) -> return []} +    collapse t = col t+   +    +instance Types x a => Types [x] a where+  tv xs = do { xs' <- mapM tv xs; return(concat xs') }+  collapse ts = mapM collapse ts+  ++instance Types (Pred a) a where+  tv (IsIn nm xs) = tv xs+  collapse (IsIn nm xs) = do {xs' <- collapse xs; return(IsIn nm xs')}+  +instance Types(Scheme a) a where+  tv (Sch ks ps t) = do {ps' <- tv ps; t' <- tv t; return(union ps' t')}+  collapse (Sch ks ps t) = +     do {ps' <- collapse ps; t' <- collapse t; return(Sch ks ps' t')}++instance Types y a => Types (x,y) a where+  tv (x,y) = tv y+  collapse (x,y) = do {y' <- collapse y; return (x,y') }+  +----------------------------------------------------------------- +  +class Instantiate x a where+  inst :: [Type a] -> x -> IM a Error x++instance Instantiate (Pred a) a where+  inst ts (IsIn nm xs) = do { xs' <- mapM (inst ts) xs; return (IsIn nm xs') }++instance Instantiate x a => Instantiate [x] a where+  inst ts xs = mapM (inst ts) xs++instance Instantiate (Type a) a where+  inst = subst    ++--------------------------------------------------++class Template x a where+  fresh :: x -> IM a Error x++instance Template (Scheme a) a where+  fresh (Sch free cs t) =+    do { sub <- mapM newVar free+       ; t' <-  inst sub t +       ; cs' <- sequence (map (inst sub) cs)+       ; return $ Sch free cs' t'+       }++instance Template (Inst a) a where+  fresh (Inst free ps p) =+    do { sub <- mapM newVar free+       ; p' <-  inst sub p +       ; ps' <- sequence (map (inst sub) ps)+       ; return $ Inst free ps' p'+       }++--------------- Environment function and types --------------------------+++extend f s t = (s,t) : f++lambdaExt :: [(name,Scheme a)] -> name -> Type a -> [(name,Scheme a)]+lambdaExt env vname vtyp = extend env vname (Sch [] [] vtyp)++lambdaExtTCE env vname vtyp  = extTrm vname (Sch [] [] vtyp) env+++envf [] s = error ("variable not found: "++(show s)++"\n")+envf ((x,t):m) s = if x==s then t else envf m s++-------- Type constructors and types of literal constants ------------++starKind = S(Kstar)+arrowKind x y =S(Kfun x y)+predKind = S Kpred++tArrow x y = S(HsTyFun x y)+tTuple ts = S(HsTyTuple ts)+tInteger = S(HsTyCon (UnQual "Integer"))+tInt = S(HsTyCon (UnQual "Int"))+tChar = S(HsTyCon (UnQual "Char"))+tString = tlist tChar+tRational = S(HsTyCon (UnQual "Rational"))+tBool = S(HsTyCon (UnQual "Bool"))+tDouble = S(HsTyCon (UnQual "Double"))++tStringHash = S(HsTyCon (UnQual "stringHash"))+tCharHash = S(HsTyCon (UnQual "CharHash"))+tIntHash = S(HsTyCon (UnQual "IntHash"))+tRationalHash = S(HsTyCon (UnQual "RationalHash"))+tlist x =  S(HsTyApp tlistCon x)+tlistCon = (S(HsTyCon (UnQual "[]")))++tcode x =  S(HsTyApp tcodeCon x)+tcodeCon = (S(HsTyCon (UnQual "Code")))++litTyp (HsInt _)        = tInteger+litTyp (HsChar _)       = tChar+litTyp (HsString _)     = tString+litTyp (HsFrac _)       = tRational+litTyp (HsCharPrim _)   = tCharHash+litTyp (HsStringPrim _) = tStringHash+litTyp (HsIntPrim _)    = tIntHash+litTyp (HsFloatPrim _)  = tRationalHash+litTyp (HsDoublePrim _) = tRationalHash+++---------------------------------------------------+-- Kind environment stuff++funkify [] env = env+funkify ((a,b):rest) env =  (a,b) +: (funkify rest env)++++hsname |-> knd = (hsname,knd)++--(x,y) +: env =  \t -> if x == t then y else lookUpEnv env t+(x,y) +: env = (x,y) : env++--emptyKEnv x = error $ "unknown kinnd variable: " ++ (show x)+emptyKEnv  = []++lookUpEnv env t = +  case List.lookup t env of+       Just b -> b+       Nothing -> error $ "Kind environment: " ++ (show t) ++ "not found!"+++kenv0 = + (UnQual "Integer") |-> star +:+ (UnQual "Int") |-> star +: + (UnQual "Char") |-> star +: + (UnQual "Rational") |-> star +: + (UnQual "Bool") |-> star +: + (UnQual "Double") |-> star +:+ (UnQual "stringHash") |-> star +:+ (UnQual "CharHash") |-> star +:+ (UnQual "IntHash") |-> star  +:+ (UnQual "RationalHash") |-> star +:+ (UnQual "[]") |-> arrowK star star +:+ (UnQual "Q") |-> arrowK star star +:+ (UnQual "X") |-> arrowK star star +:+ (UnQual "W") |-> arrowK star star +:+ (UnQual "Num") |-> arrowK star predicate +: emptyKEnv + ++++------------------------ Predefined Class predicates ----------------++num x =   IsIn   (UnQual "Num")   [x] +monad x = IsIn (UnQual "Monad")   [x]+enum x =  IsIn  (UnQual "Enum")   [x]+++-----------------------------------------------------------------------------+-- This mimics the "Class Environments" Section (7.2) of Typing Haskell in +-- Haskell. The differences are:+--  1) Class environments are lists rather than partial functions+--  1) Many functions are in the (IM a Error) Monad instead of the Maybe Monad+--  2) instead of Inst = Qual Pred+--     data INST a = INST [Kind] [Pred a] (Pred a)     +--     An instance is like a (Sch ks ps t), a fresh copy of an instance+--     can be made by applying the method "inst". this is usefull for +--     determining if we have overlapping instances. We make fresh copies, +--     and then we unify. Also like Schemes, things of type (Inst a) have a+--     normal form, because of this, and because (Inst a) should be TVar free+--     they can be compared for equality.++data Class a = Class HsName [HsName] [Inst a] +  +data ClassEnv a  = ClassEnv { classList  :: [(HsName, Class a)]+                            , defaults :: [Type a] +                            }+                            +data Inst a = Inst [Kind a] [Pred a] (Pred a)++instance Instantiate (Inst a) a where+  inst ts (Inst ks ps p) = +     do { ps' <- (inst ts ps) +        ; p' <- (inst ts p)+        ; return (Inst ks ps' p')+        }+++instance Eq (Inst a) where+  (Inst ks1 ps1 p1) == (Inst ks2 ps2 p2) =+        listEq (==) ks1 ks2 && listEq (==) ps1 ps2 && p1 == p2+     +instance Eq (Pred a) where+  (IsIn c ts) == (IsIn d xs) = c==d && listEq teq ts xs+           +listEq eqf [] [] = True+listEq eqf (x:xs) (y :ys) = eqf x y && listEq eqf xs ys+listEq eqf _ _ = False+++-----------------------------------------------------------------------++classes :: ClassEnv a -> HsName -> Maybe (Class a)+classes ce i = +  case find ( \ (x,y) -> x==i) (classList ce) of+    Just (name,cl) -> Just cl+    Nothing -> Nothing++super :: ClassEnv a -> HsName -> [HsName]+super ce i = case classes ce i of Just (Class name sup insts) -> sup++insts :: ClassEnv a -> HsName -> [Inst a]+insts ce i = case classes ce i of Just (Class name sup its) -> its++defined :: Maybe a -> Bool+defined (Just _) = True+defined Nothing  = False++modify :: ClassEnv a -> HsName -> Class a -> ClassEnv a+modify ce i c = ce {classList =  (i,c)  :  classList ce }++initialEnv :: ClassEnv a+initialEnv = ClassEnv { classList  = [], defaults = [tInteger,tDouble] }   ++type EnvTransformer a = ClassEnv a -> IM a Error (ClassEnv a)++infixr 5 <:>+(<:>) :: EnvTransformer a -> EnvTransformer a -> EnvTransformer a+(f <:> g) ce = do { ce' <- f ce; g ce' } ++                               {- ClassEnv a -> Maybe (ClassEnv a) -}     +addClass :: String -> [String] -> EnvTransformer a +addClass i is ce +  | defined (classes ce (UnQual i)) = +      fails ("Adding class: "++(show i)+++            " to class environment failed. Class already defined. ") +  | any (not . defined . (classes ce)) (map UnQual is) =  +      fails("Adding class: "++(show i)+++           " to class environment failed. Superclass not defined. ") +  | otherwise = return (modify ce (UnQual i) (Class (UnQual i) (map UnQual is) [] ))++addCoreClasses :: EnvTransformer a+addCoreClasses + =   addClass "Eq" []+ <:> addClass "Ord" ["Eq"]+ <:> addClass "Show" []+ <:> addClass "Read" []+ <:> addClass "Bounded" []+ <:> addClass "Enum" []+ <:> addClass "Functor" []+ <:> addClass "Monad" []++addNumClasses :: EnvTransformer a+addNumClasses + =   addClass "Num" ["Eq","Show"]+ <:> addClass "Real" ["Num","Ord"]+ <:> addClass "Fractional" ["Num"]+ <:> addClass "Integral" ["Real","Enum"]+ <:> addClass "RealFract" ["Real","Fractional"]+ <:> addClass "Floating" ["Fractional"]+ <:> addClass "RealFloat" ["RealFract","Floating"]+ + <:> addInst (Inst [] [] (IsIn (UnQual "Num") [tInteger]))++ce0 = (addCoreClasses <:> addNumClasses) initialEnv++------------------------------------------------------------------+++overlap :: Pred a -> Pred a -> IM a Error Bool+overlap (IsIn c ts1) (IsIn d ts2) = +  if c==d+     then (do { unifyList ts1 ts2; return True}) `handle` (\ _ -> return False)+     else return False++addInst :: Inst a -> EnvTransformer a+addInst (x @ (Inst ks ps (p @ (IsIn i _)))) ce+  | not (defined (classes ce i)) = fails ("No class: "++(show i)++", for instance")+  | otherwise = do { Inst _ _ p' <- fresh x+                   ; qs <- sequence (map getPred its)  -- the predicates (without qualifiers)+                   ; lap <- fmap or (sequence (map (overlap p') qs))+                   ; if lap+                        then fails ("Overlapping instance for: "++(show i)++".")+                        else return(modify ce i c)+                   }+ where its = insts ce i                    -- the instances of i+       getPred (x @(Inst ks ps q)) = do { Inst _ _ q' <- fresh x; return q' }+       c = Class i (super ce i) (x:its)    -- the new class with additional instance+      +bySuper :: ClassEnv a -> Pred a -> [Pred a]+bySuper ce (p @ (IsIn cname ts)) =+  p : concat[bySuper ce (IsIn c' ts) | c' <- super ce cname]+++lift :: (Type a -> Type b -> IM c Error d) -> Pred a -> Pred b -> IM c Error [d]+lift m (IsIn c1 ts1) (IsIn c2 ts2) =+  if (c1==c2) && (length ts1) ==(length ts2)+     then sequence (zipWith m ts1 ts2)+     else fails "classes do not match"++matchPred :: Pred a -> Pred a -> IM a Error Bool+matchPred x y = fmap and (lift match x y)++byInst :: Pred a -> Inst a -> IM a Error (Maybe [Pred a])+byInst p (x @ (Inst ks ps h)) =+  do { Inst _ ps' h' <- fresh x+     ; b <- matchPred h' p+     ; if b+          then return (Just ps')+          else return Nothing+     }++reducePred :: ClassEnv a -> Pred a -> IM a Error (Maybe [Pred a])+reducePred ce (p @ (IsIn c ts)) =+  let instances = (insts ce c)+      first [] = return Nothing+      first (i:is) = +           do { m <- byInst p i+              ; case m of+                  Just ps -> return(Just ps)+                  Nothing -> first is }+  in first instances+ +anyM p xs = fmap or (sequence (map p xs))+ ++entail :: ClassEnv a -> [Pred a] -> Pred a -> IM a Error Bool+entail ce ps p =+  do { let preconditions = (map (bySuper ce) ps)  -- all possible preds => by ps+           alreadythere = (any (p `elem`) preconditions)+     ; if alreadythere+          then return True+          else do { m <- reducePred ce p+                  ; case m of+                      Nothing -> return False+                      Just qs -> do { bs <- sequence (map (entail ce ps) qs)+                                    ; return (and bs)+                                    } } }+                                    +                                    +inHnf (IsIn c ts) = all hnf ts+  where hnf (TVar _ _) = True+        hnf (S(HsTyApp x _)) = hnf x+        hnf (S _) = False+        hnf (TGen n) = False++toHnf :: ClassEnv a -> Pred a -> IM a Error [Pred a]+toHnf ce p =+  if inHnf p+     then return [p]+     else do { m <- reducePred ce p+             ; case m of+                 Nothing -> fails "context reduction"+                 Just ps -> toHnfs ce ps+             }+             +toHnfs ce ps = fmap concat (mapM (toHnf ce) ps)++simplify :: ClassEnv a -> [Pred a] -> [Pred a] -> [Pred a] +simplify ce rs [] = rs+simplify ce rs (p:ps) = simplify ce (p:(rs \\ qs)) (ps \\ qs)+  where qs = bySuper ce p+        rs \\ qs = [ r | r <- rs, r `notElem` qs]+        ++numClasses :: [HsName]       +numClasses = + map UnQual ["Num","Integral","Floating","Fractional","Real","RealFloat","RealFrac"]++stdClasses :: [HsName]       +stdClasses = + map UnQual ["Eq","Ord","Show","Read","Bounded","Enum","Ix","Functor"+            ,"Monad","MonadPlus"] +++ numClasses+ + +defs     :: ClassEnv a -> Ref a -> [Pred a] -> IM a Error [Type a]+defs ce v qs =+   if (all (same v) ts) &&+      (all (`elem` stdClasses) clnames) &&+      (any (`elem` numClasses) clnames)+      then fmap concat(sequence (zipWith f (defaults ce) (repeat clnames)))+      else return []+ where clnames = [ c | (IsIn c t) <- qs ]+       ts = [ t | (IsIn c [t]) <- qs ] -- DON"T KNOW if this translates to MPTC+       same (n,v) (TVar (m,u) k) = v==u+       same v _ = False+       f t [] = return []+       f t (c:cs) = do { b <- entail ce [] (IsIn c [t])+                       ; if b then do { ts <- f t cs; return(t:ts) }+                              else f t cs+                       }++++ambig :: ClassEnv a -> [Ref a] -> [Pred a] -> IM a Error [(Ref a,[Pred a],[Type a])]+ambig ce vs ps =+  do { psvss <- sequence(map tv ps) -- [[ vars ]]+     ; let psvs = concat psvss      -- [ vars ] all of them in any of the ps+           ambigvs = psvs \\ vs     -- vars in ps but not in vs+           getqs v [] = []+           getqs v ((free,p):xs) = if elem v free then p:(getqs v xs) else getqs v xs+           f v = let qs = getqs v (zip psvss ps)+                 in do { ts <- (defs ce v qs)+                       ; ts' <- mapM collapse ts+                       ; return (v,qs,ts') }+     ; sequence (map f ambigvs)+     }++useDefaults :: String -> ClassEnv a -> [Ref a] -> [Pred a] -> IM a Error [Pred a]+useDefaults names ce vs ps =+  do { ams <- ambig ce vs ps+     -- [(v,ps,ts)]  "v" can be resolved to any of the "ts", which then cancels the "ps"+     ; let tss = [ts | (v,qs,ts) <- ams]      +           ps' = [p | (v,qs,ts) <- ams, p <- qs]+           fix ((n,v),ps,ts) = writeVar v (Just (head ts))   +     ; if any null tss -- if any "v" can't be resolved by some "t" we have to fail+          then fails "ambiguity"+          else do { cs <- mapM fix ams+                  ; newps <- collapse ((ps \\ ps'))+                  ; return newps -- subtract the cancelled ps+                  }+     }+     ++partitionM p xs = select xs +  where select [] = return ([],[])+        select (x:xs) = +           do { (ys,zs) <- select xs+              ; b <- p x+              ; if b then return (x:ys,zs) else return (ys,x:zs)+              }++split :: ClassEnv a -> [Ref a] -> [Pred a] -> IM a Error ([Pred a],[Pred a])+split ce fs ps =+  do { ps2 <- toHnfs ce ps+     ; let ps3 = simplify ce [] ps2+     ; partitionM p ps3+     }+  where p ps = do { free <- tv ps; return(all (`elem` fs) free) }++reduce :: String -> ClassEnv a -> [Ref a] -> [Ref a] -> [Pred a] +          -> IM a Error ([Pred a],[Pred a])  +reduce names ce fs gs ps = +  do { (ds,rs) <- split ce fs ps+     ; rs' <- useDefaults names ce (fs ++ gs) rs+     ; return(ds,rs')+     }+     +----------------------------------------------------------------------------+++type NGVars a = [(HsName,Type a)]++emptyNGVars :: NGVars a+emptyNGVars = []++extendNGVars :: HsName -> Type a -> NGVars a -> NGVars a+extendNGVars s t ngvars = (s,t):ngvars++generic :: NGVars a -> Ref a  -> IM a Error Bool +generic ngvars (_,v) = do { b <- occursInList v ngvars; return (not b) }+     where occursInList v l =+            do { bools <- mapM (\ (a,b) -> occursIn v b) l+               ; return (or bools)+               }+       ++-------------------------------------------------------------------------++-- unArrow [p1,p2,p3] (t1 -> t2 -> t3 -> t4) ---> (t4,[(p1,t1),(p2,t2),(p3,t3)])+unArrow :: [HsPat] -> Type a -> IM a Error (Type a,[(HsPat,Type a)])+unArrow ps t = do { t' <- col t; flat ps t' }+  where flat (p:ps) (S(HsTyFun dom rng)) = +          do { (t,ts) <- (flat ps rng) ; return (t,(p,dom) : ts) }+        flat [] t = return (t,[])+        flat (p:ps) t = error "Too many arguments to pattern"+++patExtTup [] env = return ([],[],[])+patExtTup ((p,t):m) env = +    do { (t1,e1,c1) <- patExt p t env+       ; (ts,e2,cs) <- patExtTup m env +       ; return(t1:ts,e1++e2,c1 ++ cs)+       }+++patExtList []    elemtyp env cs = return (tlist elemtyp,[],cs)+patExtList (p:m) elemtyp env cs = +    do { (t1,e1,c1) <- patExt p elemtyp env+       ; (listOfelem,e2,cs) <- patExtList m elemtyp env c1+       ; return(listOfelem,e1 ++ e2,c1++cs)+       }+++patExt :: HsPat -> Type a ->TEnv a -> IM a Error (Type a,NGV a,[Pred a])+patExt (Pat p) typ env =+  case p of+   HsPId(HsVar name) -> return (typ,[(name,typ)],[])+   HsPId(HsCon name) ->+       case lookTrmOpt env name of+            Nothing -> fails $ "Data constructor " ++ (show name) ++ " not defined!!!"+            Just (scheme @ (Sch tvars preds typ)) -> +                   do { newVars <- mapM (\k -> newVar k) tvars+                      ; t' <- inst newVars typ+                      ; ps <- mapM (inst newVars) preds+                      ; return (t',[],ps) }+   (HsPLit (HsInt _)) ->  +      do   { nv <- newVar starKind+           ; cs <- unify nv typ+           ; return (nv, [], [(num nv)]++cs) }+   (HsPLit l) -> +      do { let t = litTyp l+         ; cs <- unify t typ+         ; return (t,[],cs) +         }+   (HsPNeg x) -> error "whats this?"+   (HsPInfixApp x n y) -> patExt (Pat(HsPApp (getHSName n) [x,y])) typ env +   (HsPApp nm ps) -> +      do { Sch _ cs1 ctyp <- fresh (lookTrm env nm)+         ; (t,patTypeList) <- unArrow ps ctyp+         ; cs2 <- unify t typ+         ; (ts2,env2,cs3) <- patExtTup patTypeList env +         ; return (t,env2,cs1 ++ cs2 ++ cs3)+         }+   (HsPTuple ps) ->+      do { ts <- sequence (map (\ x -> (newVar starKind)) ps)+         ; cs2 <- unify (tTuple ts) typ+         ; (ts,ngv3,cs3) <- patExtTup (zip ps ts) env+         ; return (tTuple ts,ngv3,cs2 ++ cs3)+         }         +   (HsPList ps ) -> +      do { elemtyp <- newVar starKind+         ; (listtyp,ngv2,cs) <- patExtList ps elemtyp env []+         ; cs2 <- unify listtyp (tlist elemtyp)+         ; cs3 <- unify typ listtyp+         ; return (listtyp,ngv2,cs ++ cs2++ cs3)+         }        +   (HsPParen x) -> patExt x typ env+   (HsPRec n pairs) -> error "not yet"+   (HsPRecUpdate nm pairs) -> error "not yet"+   (HsPAsPat name x) ->+      do { (t,ngv1,cs1) <- patExt x typ env+         ; return (t,(name,t):ngv1,cs1)+         }+   (HsPWildCard) -> do { t <- newVar starKind +                       ; cs <- unify typ t+                       ; return (t,[],cs) }+   (HsPIrrPat x) -> patExt x typ env++inferPats :: [HsPat] -> NGV a -> TEnv a ->  +               IM a Error ([Type a],NGV a,TEnv a,[Pred a])+inferPats ps ngvars env =+  do { pairs <- sequence (map (\ p -> do { t <- newVar starKind; return (p,t) }) ps)+     ; (t1,ngv1,cs1) <- patExtTup pairs env+     ; return (t1,ngv1 ++ ngvars,g ngv1 env,cs1)+     }  where g [] env = env+              g ((v,t):more) env = lambdaExtTCE (g more env) v t +  +inferPat p ngvars env hint =+  do { (t,ngv1,cs1) <- patExt p hint env+     ; unify t hint+     ; return (ngv1 ++ ngvars,g ngv1 env,cs1)+     }  where g [] env = env+              g ((v,t):more) env = lambdaExtTCE (g more env) v t+++-------------------------------------------------------------++infer :: Genfun a -> NGV a -> TEnv a -> Type a ->+            HsExp -> IM a Error (Type a,[Pred a])            +infer gensym ngvars env hint (exp @ (Exp e)) =+  let check env hint x = infer gensym ngvars env hint x +  in+  case e of+    HsId(HsVar nm) -> +      do { Sch _ cs t <- fresh (lookTrm env nm)+         ; cs2 <- unify t hint+         ; return (t,cs ++ cs2)+         }+    HsId(HsCon nm) -> +      do { Sch _ cs t <- fresh (lookTrm env nm)+         ; cs2 <- unify t hint+         ; return (t,cs++cs2)+         }+    HsLit (HsInt _) -> +      do { nt <- newVar starKind+         ; unify nt hint+         ; return (nt, [num nt]) }+    HsLit n -> +      do { let t = litTyp n+         ; cs <- unify t hint+         ; return (t,cs)+         }         +    HsInfixApp x (HsVar f) y -> check env hint (hsApp (hsApp (hsEVar f)  x) y)+    HsInfixApp x (HsCon f) y -> check env hint (hsApp (hsApp (hsECon f)  x) y)+    HsApp f x ->+      do { xtyp <- newVar starKind+         ; let ftyp = tArrow xtyp hint   +         ; (_,cs2) <- check env xtyp x+         ; (_,cs3) <- check env ftyp f+         ; return (hint,cs2++cs3)+         }+    HsNegApp x ->+      do { (t,cs) <- check env hint x+         ; return (t,num t : cs)+         }+    HsLambda ps x ->+      do { (ptyps,ngv2,env2,cs) <- inferPats ps ngvars env+         ; result <- newVar starKind+           -- f [t1,t2,t3] r --> (t1 -> t2 -> t3 -> r)+         ; let f [] rng = rng+               f (t:ts) rng = tArrow t (f ts rng)+               ans = f ptyps result+         ; (_,cs2) <- infer gensym ngv2 env2 result x+         ; cs3 <- unify ans hint+         ; return (ans,cs ++ cs2 ++ cs3)+         }  +    HsLet ds e -> +      do { (ngv2,env2,cs2) <- inferDs gensym ngvars env ds+         ; (etyp,cs3)  <- infer gensym  ngv2 env2 hint e+         ; return (etyp,cs2++cs3)+         }+    HsIf x y z -> +      do { t <- newVar starKind+         ; (_,cs1) <- check env tBool x+         ; (_,cs2) <- check env t y+         ; (_,cs3) <- check env t z+         ; unify t hint+         ; return (t,cs1 ++ cs2 ++ cs3)+         }    +{-    HsCase e alts -> +      do { argtyp <- newVar starKind+         ; (ptyp,cs1) <- check env argtyp e+         ; csAll <- mapM (inferAlt gensym ngvars env ptyp hint) alts+         ; return (hint, cs1 ++ concat csAll)+         } +-}++    HsDo stmt -> +      do { mtyp <- newVar (arrowKind starKind starKind)+         ; let m x =  (S(HsTyApp mtyp x))+         ; a <- newVar starKind+         ; cs2 <- unify hint (m a)+         ; cs3 <- inferStmt gensym ngvars env mtyp (m a) False stmt+         ; return (hint,(monad mtyp) : cs2 ++ cs3)+         }+    HsTuple xs -> +      do { pairs <- sequence (map (\ x -> do { t <- newVar starKind; return (t,x) }) xs)+         ; let tupletyp = tTuple(map fst pairs)+         ; cs1 <- unify hint tupletyp+         ; ts <- mapM (uncurry (check env)) pairs+         ; return (hint,foldr (\ (t,c) cs -> c ++ cs) cs1 ts)+         }+    HsList xs -> +      do { elemtyp <- newVar starKind+         ; cs1 <- unify hint (tlist elemtyp)+         ; pairs <- mapM (check env elemtyp) xs+         ; return (hint,foldr (\ (t,c) cs -> c ++ cs) cs1 pairs)+         }+    HsParen x -> check env hint x+    HsRightSection op arg ->  -- i.e.  (+ 3) }+      do { ltyp <- newVar starKind+         ; rtyp <- newVar starKind+         ; anstyp <- newVar starKind+         ; cs1 <- unify (tArrow ltyp anstyp) hint+         ; (_,cs2) <- check env (tArrow ltyp (tArrow rtyp anstyp)) (hsId op)+         ; (_,cs3) <- check env rtyp arg+         ; return (hint,cs1 ++ cs2 ++ cs3)+         }+    HsLeftSection arg op ->  -- i.e. (3 +)+      do { ltyp <- newVar starKind+         ; rtyp <- newVar starKind+         ; anstyp <- newVar starKind+         ; cs1 <- unify (tArrow rtyp anstyp) hint+         ; (_,cs2) <- check env (tArrow ltyp (tArrow rtyp anstyp)) (hsId op)+         ; (_,cs3) <- check env ltyp arg+         ; return (hint,cs1 ++ cs2 ++ cs3)+         }+    HsRecConstr name fields -> error "not yet"+    HsRecUpdate arg fields -> error "not yet" +    HsEnumFrom x ->                     -- [x ..] :: Enum a => [a]+      do { a <- newVar starKind+         ; cs1 <- unify hint (tlist a)+         ; (_,cs2) <- check env a x+         ; return (hint,(enum a) : cs1 ++ cs2)+         }+    HsEnumFromTo x y ->                 -- [x .. y] :: Enum a => a -> a -> [a]+      do { a <- newVar starKind+         ; cs0 <- unify hint (tlist a)+         ; (_,cs1) <- check env a x+         ; (_,cs2) <- check env a y+         ; return (hint,(enum a) : cs0 ++ cs1 ++ cs2)+         }+    HsEnumFromThen x y ->              -- [x, y ..] :  Enum a => a -> a -> [a] +      do { a <- newVar starKind+         ; cs0 <- unify hint (tlist a)+         ; (_,cs1) <- check env a x+         ; (_,cs2) <- check env a y+         ; return (hint,(enum a) : cs0 ++ cs1 ++ cs2)+         }+    HsEnumFromThenTo x y z ->          -- [x,y .. z] :: Enum a => a -> a -> a -> [a] +      do { a <- newVar starKind+         ; cs0 <- unify hint (tlist a)+         ; (_,cs1) <- check env a x+         ; (_,cs2) <- check env a y+         ; (_,cs3) <- check env a z+         ; return (hint,(enum a) : cs0 ++ cs1 ++ cs2 ++ cs3)+         }+    HsListComp stmt -> +      do { let mtyp = tlistCon+         ; let m x = (S(HsTyApp mtyp x))+         ; a <- newVar starKind+         ; cs2 <- unify hint (m a)+         ; cs3 <- inferStmt gensym ngvars env mtyp a True stmt+         ; return (hint,cs2 ++ cs3)+         }+    HsExpTypeSig loc e qt -> +      do { Sch _ cs1 typ <-  hsQual2freshSch qt+         ; cs2 <- unify typ hint+         ; (_,cs3) <- check env typ e+         ; return (typ,cs1 ++ cs2 ++ cs3)+         }+    HsAsPat nm e -> error "pattern only"+    HsWildCard -> error "pattern only"+    HsIrrPat e -> error "pattern only"+    {-+    HsMetaBracket e ->  --  MetaHUGS extension <<| exp |> +      do { a <- newVar starKind+         ; cs1 <- unify hint (tcode a)+         ; (_,cs2) <- check env a e+         ; return (hint,cs1 ++ cs2)+         }+    HsMetaEscape e ->   --  MetaHUGS extansion ^exp +      do { (_,cs1) <- check env (tcode hint) e+         ; return (hint,cs1)+         }+    -}+++isValueDecl (Dec d) =  + case d of +      HsPatBind _ _ _ _ -> True+      HsFunBind _ _     -> True+      _                 -> False++isTypeDecl (Dec d) = + case d of +    HsTypeDecl _ _ _ -> True+    HsDataDecl _ _ _ _ _ -> True+    HsPrimitiveTypeDecl _ _ _ -> True+    _                         -> False++isClassInstDecl (Dec d) = +  case d of +   HsClassDecl _ _ _ _ -> True+   HsInstDecl _ _ _ _  -> True+   HsDefaultDecl _ _   -> True+   _                   -> False+++--------------------------------------------------------------------+-- InferDs, first breaks the [HsDecl] into strongly connected binding+-- groups, then types each set separately using inferBG+inferDs :: Genfun a -> NGV a -> TEnv a -> [HsDecl] -> IM a Error (NGV a,TEnv a, Constrs a)+inferDs gensym ngv env ds = + let valueDs = filter isValueDecl ds+     typeDs  = filter isTypeDecl  ds+     (groups,_)  = bindingGroups valueDs+     (typeGroups,cyclicSynonyms) =  bindingGroups typeDs+     f (ngv,env,cs) ds = do { (n,e,c) <- inferBG gensym ngv env ds; return(n,e,c++cs)}+     g (env)   ds = do {  env' <- inferDataTypes gensym env ds+                       ; return env' }+ in do { if cyclicSynonyms then fails "Cyclic type synonyms" else return ()+       ; e <- (foldM g env typeGroups)+       ; foldM f (ngv,e,[]) groups+       }++------------------------------------------------------------------+-- Section 4.5.2 of the Haskell report states that all constraints+-- resulting from typing a single binding group are collected together+-- to form the context of the type for each name bound in the binding+-- group. Thus given a binding group we should construct a delta env+-- with a binding for each name, and a common set of contraints.++pr2 s x = do { x' <- x; pr s x'}++dataTypeName sloc (Typ t) = + case t of +    HsTyVar n   -> return n+    HsTyApp a b -> dataTypeName sloc a+    HsTyCon n   -> return n+    _  -> fails $ show sloc ++ "Error in type pattern: ill formed. "++dataTypeArgs sloc (Typ t) = + case t of +     HsTyVar n   -> return [n]+     HsTyApp a b -> dataTypeArgs sloc b+     HsTyCon _   -> return []+     _  -> fails $ show sloc ++ "Error in type pattern: ill formed. "+++inferDataTypes gensym env []  = return env+inferDataTypes gensym env ds = +  do  { let (freef, envf) = Scope.freeD ds+            freeVars = freef []+      ; vs <- mapM (\_ -> newVarK Sort) freeVars +      ; pr "In binding group; type constructors" freeVars+      ; env' <- return $ foldr (.) id (zipWith extTconstr freeVars vs) env0+      ; r <- mapM (inferDataType gensym  env') ds+      ; return (foldr (+|+) env r ) +      }++     ++-- data (Q x, P y) => T x y = C x y | D [y] x+--  tpat = T x y+--  ctxt = [Q x,P y]+--  C :: Sch [*,*] (Q #0,P #1) (#0 -> #1 -> T #0 #1)+--  D :: Sch [*,*] (Q #1,P #0) ([#0] -> #1 -> T #1 #0)+inferDataType gensym env (Dec d) = + case d of +   HsDataDecl sloc ctxt (tcon:targs) consdecls derivs  -> +    do { pr "In Infer Data with " ((show tcon)++" -- "++(show targs))+       ; let { tpat  = foldl hsTyApp tcon targs }+       ; pairs <- mapM (\ nm -> do { k <- newVarK Sort; return(nm,k)}) +                   (map getTyName targs)+       ; pr "pairs" pairs+       ; envd <- return $ (foldr (.) id (map (\ (nm,k) -> extTconstr nm k ) pairs)) env+       ; let kindCheck k x = (pr "in kindcheck " (show x)) >> inferK (getKindEnv envd) k x+             constrs (HsConDecl sloc consname btypes) =+               do { let types = (map unBang btypes)+                  ; pr "constr is " ((show consname) ++" with "++(show (length types)))+                  ; pr ("constr arity for" ++ (show consname)++": ") (length types)+                  ; mapM (kindCheck star) types+                  ; return (consname, foldr hsTyFun tpat types)+                  }+       ; kindCheck star tpat+       ; mapM_ (kindCheck predicate) ctxt+       ; delta <- mapM constrs consdecls+       ; pr "delta" delta+       ; let delta2 = foldr (.) id (map (\ (nm,sch) -> extTrm nm sch) (map (hsType2Scheme (lookTconstr envd) ctxt) delta)) env0+       ; return (delta2 +|+ env)+       }+   HsTypeDecl sloc (constr : args) body -> return(env)+   other -> error "not implemented yet"+         +hsType2Scheme kenvd ps (nm,t) =+  let free (Typ (HsTyVar nm)) ans = union [nm] ans+      free (Typ t) ans = accT free t ans+      vars = free t []+      sigma = zipWith (\ n nm -> (nm,TGen n)) [0..] vars+      t' = rebuild sigma t+      ps' = map (type2pred (rebuild sigma)) ps+  in (nm,Sch (map kenvd vars) ps' t')+  ++unBang (HsBangedType a) = a+unBang (HsUnBangedType a)  =a + + +------------------------------------------------------------------------------ +extBGmono :: [HsDecl] -> IM a Error (NGV a,TEnv a,Constrs a,[(Type a,HsDecl)])+extBGmono ds = foldM extB ([],env0,[],[]) ds +  where extB (ngvars,env,cs,tds) (dec @ (Dec d)) =+          case d of+            HsPatBind s pat e ds ->+               do { ptype <- newVar starKind+                  ; (ngv2,env2,cs2) <- inferPat pat ngvars env ptype+                  ; return(ngv2,env2,cs2++cs,(ptype,dec):tds)+                }+            HsFunBind s matches ->+               do { let getname ((HsMatch sloc name ps rhs ds):_)  = name+                        name = getname matches+                  ; ftype <- newVar starKind+                  ; let env2 = lambdaExtTCE env name ftype+                  ; return((name,ftype):ngvars,env2,cs,(ftype,dec):tds)+                  }++    +inferBG :: Genfun a -> NGV a -> TEnv a -> [HsDecl] -> IM a Error (NGV a,TEnv a, Constrs a)+inferBG gensym ngv env [] = return(ngv,env,[])++inferBG gensym ngv env ds =+  do { (ngvDelta,envDelta,cs,tds) <- extBGmono ds +     ; let names = showl (map show (map fst  ngvDelta))  ""+     ; cs2 <- foldM    (inferEach gensym (ngvDelta++ngv) (envDelta +|+ env)) cs tds+     ; ps' <- sequence (map collapse cs2)+     ; ts' <- mapM collapse (map snd ( ngvDelta))+     ; fs <- fmap concat (sequence (map (\ (name,t) -> tv t) ngv))+     ; vss <- mapM tv ts'+     ; let inEveryT = foldr1 intersect vss+           gs = (foldr List.union [] vss) \\ fs  -- In infered types, but not env+       -- at this point ps' holds all the constraints resulting from typing+       -- the whole binding group. envDelta holds an env with monomorphic types for+       -- just the names bound by the binding group, and ngvDelta pairs just those+       -- names with their types.+     ; ce <- ce0 +     ; (deferred,retained) <- reduce names ce fs inEveryT ps'+     ; let generic x = return True --(x `elem` gs) +           genSch (name,t) = do { sch <- quant generic (retained :=> t)+                             ; return (name,sch) }+           getngv (x,Sch ks ps t) = (x,t)+     ; d2 <- mapM genSch ngvDelta +     ; delta2 <- return $ (foldr (.) id (map (uncurry extTrm) d2) (E [] [] []))+     ; return (map getngv (getTermEnv delta2) ++ ngv,delta2 +|+ env,deferred)+     } +++quant :: (Ptr2 a -> IM a Error Bool) -> Qual a (Type a) -> IM a Error (Scheme a)+quant generic (x @ (preds :=> typ)) =+  do { free <- newRef []+     ; z <- col typ+     ; let genPred (IsIn c ts) =+             do {ts' <- mapM (gen generic free) ts+                ; return (IsIn c ts') }+     ; typ' <- gen generic free typ+     ; preds' <- mapM genPred preds+     ; theta <- readVar free+     ; x <- col typ'+     ; return $ Sch (map (\ (t,_,k) -> k) (reverse theta)) preds' x+     }+          ++inferEach gensym ngv env cs (t,Dec d) =+   do { +        case d of+         HsPatBind s pat rhs ds -> +            do { (ngv1,env1,cs1) <- inferDs gensym ngv env ds+               ; cs2 <- inferRhs ngv1 env1 t rhs+               ; return(cs1++cs2)+               }+         HsFunBind s matches -> foldM (infermatch t) cs matches+         other -> error "Only PatBind and FunBind allowed in inferEach"+      }+ where inferRhs ngv env hint (HsGuard gs) = foldM (inferGuard ngv env hint) cs gs+       inferRhs ngv env hint (HsBody e) = +         do { (etyp,cs2) <- infer gensym ngv env hint e+            ; return(cs2++cs) }     +       inferGuard ngv env hint cs (srloc,guard,body) =+         do { (_,cs2) <- infer gensym ngv env tBool guard+            ; (_,cs3) <- infer gensym ngv env hint body+            ; return (cs3++cs2++cs) }+       infermatch hint cs (HsMatch sloc name ps rhs ds) = +         do { (ts,ngv1,env1,cs1) <- inferPats ps ngv env+            ; (ngv2,env2,cs2) <- inferDs gensym ngv1 env1 ds+            ; range <- newVar starKind+            ; cs3 <- unify hint (foldr tArrow range ts)+            ; cs4 <- inferRhs ngv2 env2 range rhs+            ; return(cs4++cs3++cs2++cs1++cs)+            }+++------------------------------------------------------------------+----------------------------------------------------------------------------------+-- inferStmt is used to infer the type of both Do stmts and list comprehensions+-- [ A | p <- e ; f ]  has the same structure as (do { P <- e; f ; A })+-- but the type rules differ slightly for both "A" and "f". We've parameterized+-- inferStmt to handle this++inferStmt :: Genfun a -> NGV a -> TEnv a -> Type a -> Type a -> Bool ->+           HsStmtR -> IM a Error [Pred a]+inferStmt gensym ngvars env mtyp lasttyp isListComp stmt = +  let m x = (S(HsTyApp mtyp x)) in+  case stmt of+    HsGenerator p e next ->  --    p <- e ; next+      do { ptyp <- newVar starKind+         ; (_,cs2) <- infer gensym ngvars env (m ptyp) e+         ; (ngv2,env2,cs3) <- inferPat p ngvars env ptyp+         ; cs4 <- inferStmt gensym ngv2 env2 mtyp lasttyp isListComp next+         ; return (cs2 ++ cs3 ++ cs4)+         }        +    HsQualifier e next ->   --  e ; next+      do { typ <- if isListComp then return tBool else fmap m (newVar starKind)+         ; (_,cs2) <- infer gensym ngvars env typ e+         ; return cs2+         }+    HsLetStmt ds next ->   -- let ds ; next+      do { (ngv2,env2,cs2) <- inferDs gensym ngvars env ds+         ; cs3 <- inferStmt gensym ngv2 env2 mtyp lasttyp isListComp next+         ; return (cs2 ++ cs3)+         }+    HsLast e -> do { (_,cs) <- infer gensym ngvars env lasttyp e; return cs }++ +---------------------------------------------------------------------+-- The Parser produces HsQualType data structures, we must turn these+-- into Scheme data structures, while doing to we should kind-check+-- all the type information.++hstype2Type :: HsType -> Type a+hstype2Type (Typ x) = S(mapT hstype2Type x) ++-- Takes [ HsType ] representing qualifying predicates and a (HsType)+-- and produces fresh Scheme for that annotation. used like+-- ( x :: (P,Q) => t )++hsQual2freshSch:: HsTypeId HsType [HsType] -> IM a Error (Scheme a)+hsQual2freshSch x = f (preds x) (types x)+  where preds (TypeQual ps x) = ps+        preds (TypeUnQual x) = []+        types (TypeQual ps x) = x+        types (TypeUnQual x) = x+        f preds x =+          do { let names = freeNames [] x+             ; let g x = do { v <- newVar starKind; return(x,v) }+             ; sub <- mapM g names+             ; let x' = rebuild sub x+                   preds' = map (type2pred (rebuild sub)) preds+             ; return(Sch [] preds' x')+             }+++-----------------------------------------------------------------+-- Helper functions for turning HsType into (Type a) and (Pred a)++type2pred :: (HsType -> Type a) -> HsType -> Pred a+type2pred g (Typ(HsTyApp (Typ(HsTyVar f)) x)) = IsIn f [g x]+type2pred g (Typ(HsTyApp (Typ(HsTyCon f)) x)) = IsIn f [g x]+type2pred g (Typ(HsTyApp f x)) = IsIn h ((g x): ys)+     where IsIn h ys = type2pred g f+type2pred g x = error ("type2pred dies: " ++(show x))+   +freeNames :: [HsName] -> HsType -> [HsName]+freeNames bound (Typ x) =+  case x of+    HsTyVar n -> if elem n bound then [] else [n]+    x -> accT f x []+       where f x ans = union (freeNames bound x) ans++rebuild :: [(HsName,Type a)] -> HsType -> Type a+rebuild sub (Typ x) =+  case x of+    HsTyVar n -> case find (\ (x,y) -> x==n) sub of+                   Just(_,v) -> v+                   Nothing -> error "unknown type variable in signature"+    x -> S(mapT (rebuild sub) x)++   +look ((y, e):ys) x = if x == y then e else look ys x+look [] x = error  "empty list in look"++--------- Show Instances ----------------------------------+ +                             +instance Show(Type a) where +  showsPrec n (S x) = shows x+  showsPrec n (TGen m) = showString "%" . shows m+  showsPrec n (TVar (m,r) k) = showString ("("++(show m)++",?)")++instance Show(Pred a) where+  showsPrec m (IsIn n ts) = +     showString "(" . showsPrec m n . showString " " . shl ts . showString ")" +   ++shl [] ss = ss+shl [x] ss = (showsPrec 0 x . showString " ") ss+shl (x:xs) ss = showsPrec 0 x ( showString ", " (shl xs ss))+++showl [] ss = ss+showl [x] ss = showString (x++" ") ss+showl (x:xs) ss = showString (x++", ") (showl xs ss)++instance Show (Scheme a) where+  --show (Sch x p t) = "(all " ++ (showString (showList (nums x)"") "") ++"." ++ (show p) ++ " => " ++ (show t) ++ ")"  +  showsPrec n (Sch x p t) =  +        showString "(all " . showl (nums x) . showString "." .+                   showsPrec n p .  showString " => " . showsPrec n t . showString ")"  +     where nums xs = ["%"++(show n) | n <- [0 .. (length xs - 1)]]+           ++toVis map (S x)    = VS(map (toVis map) x)+toVis map (TGen n) = VN("v" ++ (show n))+toVis map (TVar _ _) = VN "?"+ +visKind = toVis mapK+visType = toVis mapT++data Vis s+    = VS (s (Vis s))+    | VN String+ +instance Show (Vis T) where+      show (VN gen)       = gen +      show (VS tstruct)   = show tstruct++instance Show (Vis K) where+      show (VN gen) = gen+      show (VS tstruct) = show tstruct++instance Show (Kind a) where+  show t = show(visKind t)++ +---------------------------------------------++a:b:c:d:_ = [ TGen i | i <- [0..] ]++simpleEnv =+  [(UnQual "+",Sch[star] [num a] (tArrow a (tArrow a a)))+  ,(UnQual "*",Sch[star] [num a] (tArrow a (tArrow a a)))+  ,(UnQual "-",Sch[star] [num a] (tArrow a (tArrow a a)))+  ,(UnQual ":",Sch[star,star] [] (tArrow a (tArrow (tlist a) (tlist a))))+  ,(UnQual "True",Sch[] [] tBool)+  ,(UnQual "False",Sch[] [] tBool)+  ]+++---------------------------------------------------------------+-- a declaration like+--    type T a b = (a,b -> Int)+-- is stored in an environment with type  [(HsName,([HsName],HsType))]+-- e.g.   (T,([a,b],(a,b -> Int))) :: more+-- expandType walks over a type. At every application it tests if that application+-- matches some fully applied instance of (T a b). Suppose it does and looks like+-- (T Int String). Then we build a substitution [(a,Int),(b,String)] and apply+-- it to (a,b -> Int). If it doesn't, we just recursively expand the sub-types.++expandType :: [(HsName,([HsName],HsType))] -> HsType -> Type a+expandType env (x @ (Typ(HsTyApp f a))) = +    case matchApp env x of+      Nothing -> S(HsTyApp (expandType env f) (expandType env a))+expandType env (Typ x) = S(mapT (expandType env) x)      + +matchApp :: [(HsName,([HsName],HsType))] -> HsType -> Maybe (Type a)+matchApp env t = walkSpine t []+  where walkSpine (Typ(HsTyApp x y)) ts = walkSpine x (expandType env y : ts)+        walkSpine (Typ(HsTyCon nm)) ts = applySub nm env ts+        walkSpine _ ts = Nothing+        applySub nm env ts = +           case lookup nm env of+             Nothing -> Nothing+             Just(vs,t) -> if length vs == length ts+                              then Just(rebuild (zip vs ts) t)+                              else Nothing+  +--------------------------------------------------------+class TCEnv env   where+  extTconstr  :: HsName -> GT K Sort (STRef a) -> env a -> env a+  extTySyn    :: HsName -> [HsName] -> Type a  -> env a -> env a+  extTrm      :: HsName -> Scheme a -> env a -> env a+  lookTconstr :: env a -> HsName -> GT K Sort (STRef a)+  lookTySyn   :: env a -> HsName -> ([HsName],Type a)+  lookTrm     :: env a -> HsName -> Scheme a+  lookTconstrOpt    :: env a -> HsName -> Maybe (GT K Sort (STRef a))+  lookTySynOpt      :: env a -> HsName -> Maybe ([HsName],Type a)+  lookTrmOpt        :: env a -> HsName -> Maybe (Scheme a)+  getKindEnv  :: env a -> [(HsName, GT K Sort (STRef a))]+  getTermEnv  :: env a -> [(HsName, Scheme a)]+  env0        :: env a++++data TEnv a = E { typeSyns   :: [(HsName, ([HsName], Type a))]+                , termEnv    :: [(HsName, Scheme a)] +                , kindEnv    :: [(HsName,GT K Sort (STRef a))] }+                           deriving Show++++(E a b c) +|+ (E d e f)  = E (a++d) (b++e) (c++f)+instance TCEnv TEnv where+   env0 = E [] [] []  +   extTconstr  n t env     = env { kindEnv = (n,t) : kindEnv env }+   extTySyn    n ns t env  = env { typeSyns = (n, (ns,t)) : typeSyns env }+   extTrm      n sch env   = env { termEnv =  (n,sch)    : termEnv env}+   lookTconstr env  n      = case lookup n (kindEnv env) of  +                                  Just x  -> x+                                  Nothing -> error $ "Not found: "++(show n)+   lookTySyn   env n       = case lookup n (typeSyns env) of+                                  Just x  -> x+                                  Nothing -> error $ "Not found: type synonym " ++ (show n)+   lookTrm     env n       = case lookup n (termEnv env) of +                                  Just x    -> x+                                  Nothing   -> error $ "Not found: no type for " ++ (show n)+   getKindEnv env         = kindEnv env+   getTermEnv env         = termEnv env+---------------------------------------------------------
+ tools/base/TC/TypeCheckTest.hs view
@@ -0,0 +1,53 @@+-- $Id: TypeCheckTest.hs,v 1.10 2001/04/19 17:36:08 pasalic Exp $++module TypeCheckTest where++import TypeCheck+import TypeGenerics+import Syntax+import HsName+import HsLiteral+import InferenceMonad++tst e = do { f <- newGensym ; +             t <- newVar starKind ;+             (tr,cs) <- infer f [] env0 t e ; +              return (visType tr, show cs)+       }++e1 = hsLambda [hsPVar (UnQual "x")] +     (hsLambda [hsPVar (UnQual "y")] +      (hsApp (hsEVar (UnQual "y")) (hsEVar (UnQual "x"))))++e2 = hsLambda [hsPVar (UnQual "x")] $+     hsApp (hsEVar (UnQual "x")) (hsLit (HsInt 4))++e3 = hsTuple [hsLit (HsInt 1), hsLit (HsInt 2)]++typeCheckDecls ds = runIM+    (do { f <- newGensym ;+          r <- inferDs f [] env0 ds ;+          return $ show r+    }) 0+                    +             +--visSch (Sch ks ps t) = (map visKind ks,map (map visType) ps, visType t)+--visPred (IsIn x ts) = (x,map visType ts)+             +typeCheckDs ds = runIM+    (do { f <- newGensym ;+          (ngv, env, ps) <- inferDs f [] env0 ds ;+          return (show env, show ps)+        }) 0++showEnv (x,a) = (show x)++" :: "++(show a)++"\n"+++colEnv (x,a) = do { a' <- collapse a; return(x,a') }++performTC ds = +  perform  (do { f <- newGensym +               ; (ngv, env, ps) <- inferDs f [] (env0 {termEnv = simpleEnv}) ds+               ; env' <- mapM colEnv (take (length (getTermEnv env) - length simpleEnv) (getTermEnv env))+               ; return (concat (map showEnv env') ++ show ps)+               })
+ tools/base/TC/TypeGenerics.hs view
@@ -0,0 +1,187 @@+module TypeGenerics where++data GT s k r+  = S (s (GT s k r))+  | TVar (Int,r (Maybe (GT s k r))) k+  | TGen Int++data GErrType = MatchErr | OccursErr | ShapeErr | KindErr | GenErr+    deriving Show++type Map s k r = r[(Int,(Int,Ptr s k r),k)]+type Ptr s k r = (r(Maybe(GT s k r)))++++data A s k a r m =+  A { sameVarA :: forall x . r x -> r x -> Bool+    , writeVarA :: forall x . r x -> x -> m()+    , readVarA :: forall x . r x -> m x+    , newVarA :: forall x . x -> m(r x)+    , nextA :: m Int+    , zeroA :: a+    , unionA :: [ a ] -> a+    , genErrA :: forall x. GErrType -> GT s k r -> GT s k r -> m x+    , seqA :: forall x . s(m x) -> m(s x)+    , mapA :: forall x y . (x -> y) -> s x -> s y+    , accA :: forall x y . (x -> y -> y) -> s x -> y -> y+    , matchA :: forall x . s x -> s x -> Maybe[(x,x)]+    , kindofA :: GT s k r -> m k+    , samekindA :: k -> k -> Bool+    }++data B s k a r m =+  B { unifyGT :: GT s k r -> GT s k r -> m a+    , matchGT :: GT s k r -> GT s k r -> m()+    , equalGT :: GT s k r -> GT s k r -> Bool+    , freshGT :: k -> m (GT s k r)+    , occursGT :: Ptr s k r -> GT s k r -> m Bool+    , colGT :: GT s k r -> m(GT s k r)+    , pruneGT :: GT s k r -> m(GT s k r)+    , substGT :: [GT s k r] -> GT s k r -> m(GT s k r)+    , genmapGT :: (Ptr s k r -> m Bool) -> Map s k r ->+                  GT s k r -> m(GT s k r)+    , genAnyGT :: forall x . (Map s k r -> x -> m x) -> x -> m([k],[GT s k r],x)+    , genGT :: (Ptr s k r -> m Bool) -> GT s k r -> m([k],[GT s k r],GT s k r)+    }++makeUnify :: Monad m => A s k a r m -> B s k a r m -- x+makeUnify lib =+  B { unifyGT = genericUnify+    , matchGT = match+    , equalGT = equal+    , freshGT = freshVar+    , occursGT = occursIn+    , colGT = col+    , pruneGT = prune+    , substGT = inst+    , genmapGT = tvar2tgen+    , genAnyGT = genAny+    , genGT = \ generic -> genAny (tvar2tgen generic)+    }+  where freshVar k = do { r <- newVarA lib Nothing+                        ; n <- nextA lib +                        ; return (TVar (n,r) k) }+        prune (typ @ (TVar (n,ref) k)) =+          do { m <- readVarA lib ref+             ; case m of+                 Just t -> do { newt <- prune t+                              ; writeVarA lib ref (Just newt)+                              ; return newt }+                 Nothing -> return typ}+        prune x = return x+        col x =+          do { x' <- prune x+             ; case x' of+                (S y) -> do { t <- seqA lib (mapA lib col y)+                            ; return (S t)}+                (TVar (n,r) k) -> return(TVar (n,r) k)+                (TGen n) -> return(TGen n)}+        occursIn v t =+          do { t2 <- prune t+             ; case t2 of+                 S w -> do { s <- seqA lib (mapA lib (occursIn v) w)+                           ; return $ accA lib (||) s False }+                 TVar (m,z) k2 -> return $ sameVarA lib v z+                 TGen n    -> return False }+        varBind (r1 @ (n,r)) k1 t2 =+          do { b <- occursIn r t2+             ; k2 <- kindofA lib t2+             ; if b+                  then genErrA lib OccursErr (TVar r1 k1) t2+                  else if not(samekindA lib k1 k2)+                          then genErrA lib KindErr (TVar r1 k1) t2+                          else do { writeVarA lib r (Just t2); return (zeroA lib)}}+        genericUnify tA tB =+          do { t1 <- prune tA+             ; t2 <- prune tB+             ; case (t1,t2) of+                (TVar (n,r1) k1,TVar (m,r2) k2) ->   -- Both are Variables+                  if sameVarA lib r1 r2+                     then return (zeroA lib)+                     else do { writeVarA lib r1 (Just t2); return (zeroA lib)}+                (TVar r1 k1,_) -> varBind r1 k1 t2+                (_,TVar r2 k2) -> genericUnify t2 t1+                (TGen n,TGen m) -> if n==m then return(zeroA lib)+                                      else genErrA lib GenErr t1 t2+                (S x,S y) ->+                  case matchA lib x y of+                    Nothing -> genErrA lib MatchErr t1 t2+                    Just pairs -> do { cs <- mapM (uncurry genericUnify) pairs+                                     ; return (unionA lib cs)+                                     }+                (_,_) -> genErrA lib ShapeErr t1 t2                         +             }+        match tA tB =+          do { t1 <- prune tA+             ; t2 <- prune tB+             ; case (t1,t2) of+                 (TVar (n,r1) k1,_) ->+                    do { k2 <- kindofA lib t2+                       ; if samekindA lib k1 k2+                            then genErrA lib KindErr t1 t2+                            else do { writeVarA lib r1 (Just t2); return ()}++                       }+                 (TGen n,TGen m) -> if n==m then return()+                                      else genErrA lib GenErr t1 t2+                 (S x,S y) ->+                    case matchA lib x y of+                      Nothing -> genErrA lib ShapeErr t1 t2+                      Just pairs -> do { mapM_ (uncurry match) pairs+                                       ; return ()+                                       }+                 (_,_) -> genErrA lib ShapeErr t1 t2+             }+        equal x y =+          case (x,y) of+            (TVar (n,r1) k1,TVar (m,r2) k2) -> sameVarA lib r1 r2+            (TGen n,TGen m) -> m==n+            (S x,S y) -> case matchA lib x y of+                          Nothing -> False+                          Just pairs -> all (uncurry equal) pairs+            (_,_) -> False+        inst sub x =+          do { x' <- prune x+             ; case x' of+                 TVar r k -> return(TVar r k)+                 TGen n -> return (sub !! n)+                 S x -> do { x' <- seqA lib (mapA lib (inst sub) x)+                           ; return (S x')+             }             }+        findFresh nextN ((new, (n,oldvar),k2):rest) (m,ref) k env =+          if sameVarA lib ref oldvar+             then return (TGen new)+             else findFresh nextN rest (m,ref) k env+        findFresh nextN [] ref k env =+          do { old <- readVarA lib env+             ; writeVarA lib env ((nextN,ref,k):old)+             ; return (TGen nextN)+             }+        tvar2tgen generic env t =+          do { t2 <- prune t+             ; case t2 of+                 S x    -> do { x' <- seqA lib (mapA lib (tvar2tgen generic env) x)+                              ; return(S x') }+                 TGen n -> return t2+                 TVar (n,r) k -> -- Because of prune, "r" is NEVER of+                                 -- the form (TyVar (ref (Just t)) k)+                    do { b <- generic r+                       ; if b then (do { env' <- readVarA lib env+                                       ; findFresh (length env') env' (n,r) k env })+                              else return t2+                       }+             }+        genAny gen x =+            do { free <- newVarA lib []+               ; x' <- gen free x+               ; theta <- readVarA lib free+               ; let three (n,r,k) = k+                     g(n,r,k) = TVar r k+               ; return (map three theta,map g theta, x')+               }+++++           
+ tools/base/TI/Flags.ghc view
@@ -0,0 +1,18 @@+TiFields.hs: -fallow-undecidable-instances+TiRhs.hs: -fallow-undecidable-instances+TiFree.hs: -fallow-undecidable-instances+TiE.hs: -fallow-undecidable-instances+TiD.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+TiDinst.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+TiDs.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+TiDkc.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+TiClassInst.hs: -fno-monomorphism-restriction+TiClassInst2.hs: -fno-monomorphism-restriction+TiT.hs: -fallow-undecidable-instances+TiUtil.hs: -fno-monomorphism-restriction++TiPrelude.hs: -fno-monomorphism-restriction+TiDerivedInstances.hs: -fno-monomorphism-restriction+TiModule.hs: -fno-monomorphism-restriction+TiBase.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+TiDecorate.hs: -fallow-undecidable-instances -fno-monomorphism-restriction
+ tools/base/TI/HEADER.html view
@@ -0,0 +1,23 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!-- This file is included by the web server in the automatically generated+     directory index.+-->+<head>+<title>Programatica Tools, tools/base/TI</title>+<link rel=parent href="../" title="Programatica Tools, tools/base">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../../web/icon1.png">+</head>++<base>+<h1><img align=right src="../../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/base/TI</h2>++The README file is displayed below the directory index.+<!--+<p>+See also <a href="src.cgi">HTML version of the source code for tstTI</a>.+-->
+ tools/base/TI/NameMapsDecorate.hs view
@@ -0,0 +1,110 @@+module NameMapsDecorate where+import NameMaps+import TiDecorate+import TiTypes+import TiKinds+--import NameMapsBase(bothtype,bothval)+import HsIdent(mapHsIdent2)+import HsDeclMaps(mapFunDeps)+import MapDeclM+import MapDeclMBaseStruct()+import MUtils++instance AccNames i (TiDecls i) where+  accNames f (Decs ds (ks,ts)) = accNames f ds . accNames f ts -- hmm, ks?++instance AccNames i (TiDecl i) where+  accNames f (Dec d) = accNames f d++instance AccNames i (TiExp i) where+  accNames f (Exp e) = accNames f e+  accNames f (TiSpec i _ ts) = accNames f i . accNames f ts+  accNames f (TiTyped e t) = a e . a t+    where a x = accNames f x++instance AccNames i (TiPat i) where+  accNames f (Pat p) = accNames f p+  accNames f (TiPApp p1 p2) = accNames f p1 . accNames f p2+  accNames f (TiPSpec i _ ts) = accNames f i . accNames f ts+  accNames f (TiPTyped p t) = accNames f p . accNames f t++instance AccNames i t => AccNames i (Typing x t) where+  accNames f (x:>:t) = accNames f t -- hmm, x?++instance AccNames i (Scheme i) where+  accNames f (Forall _ _ qt) = accNames f qt++instance AccNames i t => AccNames i (Qual i t) where+  accNames f (ps:=>t) = accNames f ps . accNames f t+--------------------------------------------------------------------------------++instance MapNames i1 (TiDecls i1) i2 (TiDecls i2) where+  mapNames2 c f (Decs ds (ks,ts)) = Decs (m ds) (mks ks,mts c f ts)+    where+      m x = mapNames2 c f x+      mks = map mk+      mk (i:>:(k,ti)) = bothtype mapHsIdent2 f i:>:(k,m ti)++instance MapNames i1 (TiDecl i1) i2 (TiDecl i2) where+  mapNames2 c f (Dec d) = Dec (mapNames2 c f d)++instance MapNames i1 (TiExp i1) i2 (TiExp i2) where+  mapNames2 c f (Exp e) = Exp (mapNames2 c f e)+  mapNames2 c f (TiSpec i sc ts)= TiSpec (bothval mapHsIdent2 f i) (m sc) (m ts)+    where m x = mapNames2 c f x+  mapNames2 c f (TiTyped e t) = TiTyped (m e) (m t)+    where m x = mapNames2 c f x++instance MapNames i1 (TiPat i1) i2 (TiPat i2) where+  mapNames2 c f (Pat p) = Pat (mapNames2 c f p)+  mapNames2 c f (TiPApp p1 p2) = TiPApp (mapNames2 c f p1) (mapNames2 c f p2)+  mapNames2 c f (TiPSpec i sc ts) =+      TiPSpec (bothval mapHsIdent2 f i) (mapNames2 c f sc) (mapNames2 c f ts)+  mapNames2 c f (TiPTyped p t) = TiPTyped (mapNames2 c f p) (mapNames2 c f t)++instance MapNames i1 (Scheme i1) i2 (Scheme i2) where+  mapNames2 c f (Forall as vs qt) =+      Forall (mktvs f as) (mktvs f vs) (mapNames2 c f qt)++mtvs (vf,_) = map (vf (Def Local,ClassOrTypeNames))+mktvs (vf,_) = map (emap (vf (Def Local,ClassOrTypeNames)))++mts c f = map mt+  where mt (i:>:t) = bothval mapHsIdent2 f i:>:mapNames2 c f t++instance MapNames i1 (TypeInfo i1) i2 (TypeInfo i2) where+  mapNames2 c f ti =+      case ti of+        Data -> Data+        Newtype -> Newtype+        Class ps vs fdeps as ->+          Class (m ps) (mktvs f vs) ({-mapFunDeps tvarf-} fdeps) (mts c f as)+        Synonym vs t -> Synonym (mtvs f vs) (m t)+        Tyvar -> Tyvar+    where+      m x = mapNames2 c f x+      tvarf = fst f usetype+++instance MapNames i1 t1 i2 t2+      => MapNames i1 (Qual i1 t1) i2 (Qual i2 t2) where+  mapNames2 c f (ps:=>t) = m ps:=>m t+    where m x = mapNames2 c f x++{-+instance MapNames i1 Kind i2 Kind where+  mapNames2 c f k = k+  mapNames f k = k+-}+--------------------------------------------------------------------------------++instance MapDeclM (TiDecls i) (TiDecls i) where+  mapDeclM f (Decs ds dt) = flip Decs dt # mapDeclM f ds++instance MapDeclM (TiDecl i) (TiDecls i) where mapDeclM  = std_mapDeclM++instance MapDeclM (TiExp i) (TiDecls i) where+  mapDeclM f (Exp e) = Exp # mapDeclM f e+  mapDeclM f (TiTyped e t) = flip TiTyped t # mapDeclM f e+  mapDeclM f e@(TiSpec{}) = return e+
+ tools/base/TI/NewTiMonad.hs view
@@ -0,0 +1,124 @@+module NewTiMonad(+   IM,--TI,KI,+   KEnv,+   getEnv,getTEnv,getKEnv,getIEnv,getModule,getDefaults,+   extendts,extend,extend1,extendkts,extendEnv,extendIEnv,inModule,inEnv,+   env,kenv,sch,kindOf,constrain,getConstraints,+   (>:),errmap,freshInt+  ) where+import HsIdent(HsIdentI)+import HsName(ModuleName(..))+import TiTypes+--import TiKinds(Kind,TypeInfo{-,KindConstraint-})+import TiEnv(lookup,extenv1,extenv)+import qualified TiEnv(Env,empty)+import TiInstanceDB(IDB,emptyIdb,extendIdb)+import TiConstraints(Constraints,empty,single,merge)+import MUtils+import Lift+import PrettyPrint(pp)++import MT(MT(..))+import OutputMT+import StateMT+import EnvMT+import ExceptM++import qualified Tree++type TEnv i = TiEnv.Env (HsIdentI i) (Scheme i) -- type of value identifiers+type KEnv i = TiEnv.Env (HsIdentI i) (Kind,TypeInfo i)   -- kind of type identifiers++data TiEnv i  = Env { inMod::FilePath->ModuleName,+		      monomorph::Bool, -- use the monomorpism restriction?+		      defaults::[[Type i]], -- from all default(t1,...,t2)+		      kenv::KEnv i,+		      tenv::TEnv i,+		      idb::IDB i }++emptyEnv = Env (const (Module "nomodule")) True [] TiEnv.empty TiEnv.empty emptyIdb++-- IM should really be an abstract type!+type IM i c = WithOutput c +            ( WithEnv (TiEnv i) +            ( WithState Unique+            ( ExceptM Error ))) ++--type TI i   = IM i (TypeConstraint i)+--type KI i   = IM i KindConstraint+type Error  = String+type Unique = [Int]+++errmap f m = do e <- getEnv+                s <- getSt+                case withStS s (withEnv e (removeOutput m)) of+                  Left x -> raise (f x)+                  Right ((a,t),s) -> setSt_ s >> outputTree t >> return a++run :: TiEnv i -> IM i c a -> Either Error a+run env = removeExcept . withSt [1..] . withEnv env . fmap fst . removeOutput++instance Monad m => Lift (IM i c) m where+  lift = either fail return . run emptyEnv++getConstraints :: IM i c a -> IM i d (a, Tree.T c)+getConstraints m = MT.lift (removeOutput m)++typeError :: Error -> IM i c a+typeError err = raise err++constrain :: c -> IM i c ()+constrain c = output c++modEnv :: (TiEnv i -> TiEnv i) -> IM i c a -> IM i c a+modEnv f  = inModEnv f+modTEnv f = modEnv (\env@Env{tenv=e}->env{tenv=f e})+modKEnv f = modEnv (\env@Env{kenv=e}->env{kenv=f e})+modIEnv f = modEnv (\env@Env{idb=e}->env{idb=f e})++getTEnv :: IM i c (TEnv i)+getTEnv = tenv # getEnv++getKEnv :: IM i c (KEnv i)+getKEnv = kenv # getEnv++getIEnv :: IM i c (IDB i)+getIEnv = idb # getEnv++getModule :: IM i c (FilePath->ModuleName)+getModule = inMod # getEnv++getDefaults :: IM i c [[Type i]]+getDefaults = defaults # getEnv++extend1 x t = modTEnv (extenv1 x t)+extend x    = modTEnv (extenv x)+extendts ts = extend [(x,t)|x:>:t<-ts]++extendk1 x t  = modKEnv (extenv1 x t)+extendk x     = modKEnv (extenv x)+extendkts ts  = extendk [(x,t)|x:>:t<-ts]++extendEnv (ks, ts) = extendkts ks . extendts ts+extendEnv' (ks, ts) = extendk ks . extend ts++extendIEnv x  = modIEnv (extendIdb x)++inModule m d = modEnv (\env->env{inMod=m,defaults=d})++env proj x =+  do env <- getEnv+     case TiEnv.lookup (proj env) x of+       Nothing -> typeError ("Not in scope: "++pp x{-++" in "++show (proj env)-})+       Just sch -> return sch++sch x = env tenv x+kindOf x = fst # env kenv x++freshInt :: IM i c Int+freshInt = head # updSt tail++infix 4 >:+(>:) :: e -> t -> IM i c (Typing e t)+e >: t = return (e :>: t)
+ tools/base/TI/OrigTiMonad.hs view
@@ -0,0 +1,170 @@+module OrigTiMonad(+   IM,run,--TI,KI,+   KEnv,+   getEnv,getTEnv,getKEnv,getIEnv,getModule,getDefaults,getStdNames,+   extendts,extend,extend1,extendkts,extendEnv,extendIEnv,+   inModule,inEnv,withStdNames,+   env,kenv,sch,kindOf,stdName,stdSch,constrain,getConstraints,monomorphism,+   monomorphismRestriction,+   errorContext,errorContext',posContext,posContext',declContext,moduleContext,+   (>:),freshInt+  ) where+import Prelude hiding (lookup) -- for Hugs+import Monad(MonadPlus(..))+import HsIdent(HsIdentI)+import HsName(ModuleName,Id,noModule)+import TiTypes+import TiKEnv(KEnv,lookup,extenv1,extenv)+import qualified TiKEnv(empty)+import TiTEnv(TEnv)+import qualified TiTEnv(lookup,extenv1,extenv,empty)+import TiInstanceDB(IDB,emptyIdb,extendIdb)+import TiConstraints(Constraints,empty,single,merge)+import DefinedNamesBase(NameSpace)+import TiError+import MUtils+import ExceptM()+import Lift+import PrettyPrint(Printable,pp,(<+>),(<>),ppi,vcat)++--type TEnv i = TiEnv.Env (HsIdentI i) (Scheme i) -- type of value identifiers+--type KEnv i = TiEnv.Env (HsIdentI i) (Kind,TypeInfo i) -- kind of type identifiers++data TiEnv i  = Env { inMod::FilePath->ModuleName,+		      stdNames::NameSpace->(ModuleName,Id)->Either String (HsIdentI i),+		      monomorphism::Bool, -- use the monomorpism restriction?+		      defaults::[[Type i]], -- from all default(t1,...,t2)+		      kenv::KEnv i,+		      tenv::TEnv i,+		      idb::IDB i }++emptyEnv = Env (const noModule) noStdNames+	       True [] TiKEnv.empty TiTEnv.empty emptyIdb+  where+    noStdNames ns (m,n) =+      fail $ pp $+        "Bug: no standard entities provided to the type checker:"<+>m<>"."<>n++newtype IM i c ans = IM { unIM::TiEnv i->Unique->Err i (Out c ans) }+--type TI i = IM i (TypeConstraint i)+--type KI i = IM i KindConstraint++type Err i ans = Either (Error (HsIdentI i)) ans++data Out c ans = Out ans (Unique,Constraints c)+type Unique = [Int]++instance Functor (Out i) where+  fmap f (Out ans out) = Out (f ans) out++instance Functor (IM i c) where+  fmap f (IM m) = IM $ \ env ids -> fmap (fmap f) (m env ids)++instance Monad (IM i c) where+  return ans = IM $ \ env ids -> Right (Out ans (ids,empty))+ +  IM m1 >>= xm2 =+     IM $ \ env ids0 ->+     case m1 env ids0 of+       Left err -> Left err+       Right (Out x (ids1,out1)) ->+         case unIM (xm2 x) env ids1 of+	   Left err -> Left err+	   Right (Out y (ids2,out2)) -> Right (Out y (ids2,merge out1 out2))++  fail = typeError . Other . vcat . lines++instance MonadPlus (IM i c) where+  mzero = fail "No error message provided (PFE programmer used mzero or msum)"+  IM m1 `mplus` IM m2 =+     IM $ \ env ids0 ->+     case m1 env ids0 of+       Left _ -> m2 env ids0+       r -> r++errmap f (IM m) =+  IM $ \ env ids ->+  case m env ids of+    Left err -> Left (f err)+    Right y -> Right y++inContext       ctx = errmap (InContext ctx)+errorContext'   txt locs = inContext (OtherCtx (ppi txt) locs)+errorContext    txt = errorContext' txt []+posContext  loc     = inContext (AtPos loc Nothing)+posContext' loc txt = inContext (AtPos loc (Just (ppi txt)))+moduleContext   ms  = inContext (ModuleCtx ms)+declContext     is  = inContext (DeclCtx is)++run (IM m) =+  case m emptyEnv [1..] of+    Left err -> Left err+    Right (Out ans (_,cs)) -> Right ans++instance (Printable i,Monad m) => Lift (IM i c) m where+  lift = lift . run++getConstraints (IM m) =+ IM $ \ env ids ->+ case m env ids of+   Left err -> Left err+   Right (Out ans (ids,cs)) -> Right (Out (ans,cs) (ids,empty))++typeError err = IM $ \ env ids -> Left err++constrain c = IM $ \ env vs -> Right (Out () (vs,single c))++modEnv f (IM m) = IM $ m . f+modTEnv f = modEnv (\env@Env{tenv=e}->env{tenv=f e})+modKEnv f = modEnv (\env@Env{kenv=e}->env{kenv=f e})+modIEnv f = modEnv (\env@Env{idb=e}->env{idb=f e})+monomorphismRestriction on = modEnv (\env->env{monomorphism=on})++getEnv = IM $ \ env ids -> Right (Out env (ids,empty))+getTEnv = tenv # getEnv+getKEnv = kenv # getEnv+getIEnv = idb # getEnv+getModule = inMod # getEnv+getStdNames = stdNames # getEnv+getDefaults = defaults # getEnv++extend1 x t = modTEnv (TiTEnv.extenv1 x t)+extend bs = modTEnv (TiTEnv.extenv bs)+extendts ts = extend [(x,t)|x:>:t<-ts]++extendk1 x t = modKEnv (extenv1 x t)+extendk bs = modKEnv (extenv bs)+extendkts ts = extendk [(x,t)|x:>:t<-ts]++extendEnv (ks, ts) = extendkts ks . extendts ts+--extendEnv' (ks, ts) = extendk ks . extend ts++extendIEnv env = modIEnv . extendIdb $ env++--inEnv env = modEnv (const env)+inEnv env (IM m) = IM $ \ _ -> m env++inModule m d = modEnv (\env->env{inMod=m,defaults=d})+withStdNames stdNames = modEnv (\env->env{stdNames=stdNames})++env' lookup x =+  do env <- getEnv+     case lookup env x of+       Nothing -> fail ("Not in scope: "++pp x{-++" in "++show (proj env)-})+       Just sch -> return sch++env proj = env' (TiKEnv.lookup . proj)++stdName ns o = do f <- getStdNames+	          lift (f ns o)++stdSch ns = sch @@ stdName ns++sch x = env' (TiTEnv.lookup . tenv) x+kindOf x = fst # env kenv x++freshInt = IM $ \ env (id:ids) -> Right (Out id (ids,empty))++infix 4 >:+(>:) :: e -> t -> IM i c (Typing e t)+e >: t = return (e :>: t)
+ tools/base/TI/README.html view
@@ -0,0 +1,98 @@+<h1>Extensible Haskell front-end for the Programatica project</h1>++<h2>What is in this directory (base/TI)</h2>++This directory contains a type checker for the base+language (i.e., more or less Haskell 98). It is structured to allow large+parts to be reusable in extended versions of the language.+<p>+At present,+the type inference monad is fixed, and the AST for inferred types is fixed,+but it might be possible to factor out these aspects too.++<p>+Although various details differ, this type checker is influenced by++<ul>+<li>Mark Jones'+    <a href="http://www.cse.ogi.edu/~mpj/thih/"><cite>Typing Haskell in+    Haskell</cite></a> (general guidance, some naming conventions, the class+    <code>Types</code> and operations on substitutions, ...),+<li>one of Johan Nordlander's type checkers for+    <a href="http://www.cs.chalmers.se/~nordland/ohaskell/">O'Haskell</a>+    (that avoids both threading an accumulating substitution and+    applying substitutions to the environment),+<li>and also somewhat by the type checker in+    <a href="http://www.cs.chalmers.se/~augustss/hbc/hbc.html">HBC</a>.+   (HBC serves as a proof that you don't need to resort to imperative+   unification to implement efficient type inference, nor do you need+   to sweep things under the carpet with a monad to make a purely+   functional type checker readable.)+</ul>++<h3>Modules for the basic type inference machinery</h3>++<ul>+<li>TiMonad (NewTiMonad or OrigTiMonad),+TiClasses,+TiConstraints,+TiEnv,+TiFresh,+TiKinds,+TiSolve,+TiTypes,+TiUtil,+TI,+TiPretty,+TiNames,+Unification.++</ul>+++<h3>Instances and context reduction</h3>++<ul>+<li>+TiBySuper,+TiContextReduction,+TiDefault,+TiDerivedInstances,+TiInstanceDB.+</ul>+++<h3>Type inference for the base language structure</h3>+These should be reusable in extended versions of the language.++<ul>+<li>Declarations: TiD, TiClassInst, TiDkc,+<li>Expressions, patterns, etc: TiE, TiFields, TiLit,TiP, TiRhs,+<li>Kinds inference for type expressions: TiT,+<li>Modules: TiModule,+<li>Collects everything: TiBaseStruct.++</ul>++<h3>Knot-tying definitions for the base language</h3>++<ul>+<li>TiBase, TiDecorate, NameMapsDecorate+</ul>++<h3>Type inference for sequences of declarations</h3>+<ul>+<li>TiDs.+</ul>++<h3>Interfaces to other pieces of reusable code</h3>++<ul>+<li>TiSCC, TiDefinedNames, TiFreeNames.+</ul>++<h3>Other modules</h3>+<ul>+<li>+TiPrelude, TiHsName+</ul>
+ tools/base/TI/TI.hs view
@@ -0,0 +1,15 @@+-- This module collects the basic type inference machinery+module TI(module Ti) where+import TiClasses as Ti+import TiDefinedNames as Ti+import TiFreeNames  as Ti+import TiKinds as Ti+import TiMonad as Ti+import TiNames as Ti+import TiPretty as Ti+import TiTypes as Ti+import TiUtil as Ti+import TiGeneralize as Ti+import TiFresh as Ti+import PNT as Ti(PId)+-- more?
+ tools/base/TI/TiBase.hs view
@@ -0,0 +1,92 @@+{-+This module provides type inference for the base syntax.+Here, you will find only the knot-tying top-level definitions.+-}+module TiBase(Typing,Scheme{-,GetSigs(..),DeclInfo(..)-}) where+import Syntax hiding (extend)+import SubstituteBase()+import NameMapsBase() -- instance AccNames i (HsDeclI i)+import TI+--import QualNames+import TiBaseStruct+--import TiModule(tcModule)+import TiDs()+--import MUtils+import PrettyPrint+import List(partition)+--import Maybe(mapMaybe)++--tstTcModule kbs tbs =+--  run emptyEnv . extendk kbs . extend tbs . getSubst . tcModule++instance (TypeId i,ValueId i,PrintableOp i,Fresh i,HasSrcLoc i,TypedId PId i)+      => TypeCheckDecl i (HsDeclI i) [HsDeclI i] where+  tcDecl bs = tcD bs . struct++instance Eq i => CheckRecursion i (HsDeclI i) where+    checkRecursion ds = checkTypeSynRec ds >> checkClassRec ds++instance HasMethodSigs [HsDeclI i] where+  splitMethodSigs = partition isSig+    where+      isSig (Dec (HsTypeSig {})) = True+      isSig _                    = False+{-+instance GetSigs i [Pred i] (Type i) [HsDeclI i] where+  getSigs = mapMaybe getSig+    where+      getSig (Dec (HsTypeSig s is c tp)) = Just (s,is,c,tp)+      getSig _                           = Nothing+-}+instance (Fresh i,TypeId i,ValueId i,PrintableOp i,HasSrcLoc i,TypedId PId i)+      => TypeCheck i (HsExpI i) (Typed i (HsExpI i)) where tc (Exp e) = tcE e+instance (Fresh i,TypeId i,ValueId i)+      => TypeCheck i (HsPatI i) (Typed i (HsPatI i)) where tc (Pat p) = tcP p++instance (ValueId i,TypeVar i) => DeclInfo i (HsDeclI i) where+  --explicitlyTyped m c = explicitlyTyped m c . struct+  explicitlyTyped ks tinfo c = explicitlyTyped ks tinfo c . struct+  --isTypeDecl = isTypeDecl . struct+  isUnrestricted expl = isUnrestricted expl . struct++instance HasAbstr i (HsDeclI i) where abstract xs = mapRec (abstract xs)+instance HasAbstr i (HsExpI i)  where abstract xs = mapRec (abstract xs)+instance Eq i => HasLocalDef i (HsExpI i) (HsDeclI i) where letvar x e = mapRec (letvar x e)+--instance ({-ValueId i,-}TypeVar i) => KindCheck i (HsDeclI i) () where kc = kc . struct+instance TypeVar i => KindCheck i (HsDeclI i) () where kc = kc . struct++instance HasId i (HsPatI i) where ident = r . ident; isId = isId . struct+instance HasId i (HsExpI i) where ident = r . ident; isId = isId . struct++--instance HasLit (SrcLoc->HsExpI i) where lit = flip hsLit+--instance HasLit (SrcLoc->HsPatI i) where lit = flip hsPLit++instance HasCoreSyntax i (HsPatI i) where+  app (Pat p1) p2 = r $ pApp p1 p2+  tuple = hsPTuple loc0 -- !! loc0+  list = hsPList loc0 -- !! loc0+--paren = hsPParen+++instance HasCoreSyntax i (HsExpI i) where+  app = hsApp+  tuple = hsTuple+  list = hsList+--paren = hsParen++instance HasTypeApp i (HsExpI i) --where spec x sc ts = ident x+instance HasTypeApp i (HsPatI i) --where spec x sc ts = ident x++instance HasTypeAnnot i (HsExpI i)+instance HasTypeAnnot i (HsPatI i)++instance HasDef [HsDeclI i] (HsDeclI i) where+  nullDef = null+  consDef = (:); noDef = []; appendDef = (++); toDefs = id+  filterDefs = filter++instance TypeVar i => Types i (HsDeclI i) where+  tmap f = id+  tv d = []++instance AddDeclsType i [HsDeclI i] where addDeclsType dt = id
+ tools/base/TI/TiBaseStruct.hs view
@@ -0,0 +1,12 @@+{-++This module collects type inference for the base syntax structure,+which is intended to be reuseable in extensions of the base syntax.+The knot-tying definitions for the recursive base syntax is in TiBase.+-}+module TiBaseStruct(module Ti) where+import TiD as Ti+import TiE as Ti+import TiP as Ti+import TiT as Ti+import TiLit as Ti+-- more?
+ tools/base/TI/TiBySuper.hs view
@@ -0,0 +1,54 @@+module TiBySuper where+import Prelude hiding (lookup)+import TiKinds+import TiKEnv(lookup)+import TiTypes+import TiNames+import TiClasses+import TiDefinedNames+import PrettyPrint+import MUtils+import TiSolve(matches,expandSynonyms)+import DefinedNamesBase()++-- Context reduction by using the superclass hierarchy.++{-+Dictionaries are transformed under the assumption that a dictionary for a+superclass can be obtained by applying a selector to the dictionary for+the subclass.++For example if we have d1::Ord a, then we can get d2::Eq a by d2=super1_Ord d1.+-}++bySuper env d@(de:>:dt) =+    (d:) #+    if null cs+    then return [] -- ill formed predicate (accepted as an exerimental feature)+    else case snd # lookup env c of+	   Just (Class [] ps _ ms) -> return [] -- speed hack, can be eliminated+	   Just (Class ctx0 ps _ ms) ->+	     do s <- dt `matches` st $ env+		concatMapM (bySuper env) (zipWith (sel s) [1..] ctx)+	     where+               ctx = map (expandSynonyms env) ctx0+                   -- Better to expand synonyms before adding class to env!!+	       st = tpat c (tdom ps)+               sel s n sup = (sne `app` de):>:supdt+	         where+	           supdt = apply s sup+		   sn = superName cn n+		   --sne = var sn -- without type annotations+		   sne = spec (HsVar sn) ssc (apply s (map tyvar (tdom ps)))+		   ssc = forall' ps ([]:=>funT [st,sup])+				    +  +	   Just i -> fail $ pp $ "Not a class:"<+>c<+>"in"<+>dt $$ show i+	   _      -> fail $ pp $ "Unknown class:"<+>c<+>"in"<+>dt+                               -- $$ "Env:"<+>env+  where+    c@(HsCon cn) = head cs+    tpat c vs = appT (ty c:map tyvar vs)++    cs = definedTypeNames dt+    
+ tools/base/TI/TiClassInst.hs view
@@ -0,0 +1,89 @@+-- Type checking for class and instances declarations.+module TiClassInst where+import List((\\))+import Maybe(fromMaybe)++import HasBaseStruct(hsClassDecl,hsInstDecl,hsId,hsLit,hsApp,hsPId,hsPatBind)+import HsLiteral+import HsGuardsStruct+--import TiPrelude(prelError)+--import SrcLoc(SrcLoc,srcLoc)+import TI+--import TiDkc(Dinst)+--import TiSolve(matches)+import PrettyPrint+import MUtils+import TiClassInst2(tcInstOrClassDecl'')++tcClassDecl src ctx cl fdeps ds = -- a quick hack...+  do mnames <- methodNames cl -- or extract mnames from msigs...+     prelError <- prelValue "error"+     let (msigs,defaults) = splitMethodSigs ds+	 lacksDefault = mnames \\ definedValueNames ds+         defaultDefaults = toDefs (map (defaultDefault prelError) lacksDefault)+	 defds = defaults `appendDef` defaultDefaults+     ds' <- mapDefinedNames defaultName # tcClassDecl' src [cl] cl defds+     msigs':>:_ <- tcLocalDecls msigs -- kind check + type conversion+     return $+       hsClassDecl src ctx cl fdeps (rmDeclsType msigs') `consDef` ds'+  where+    defaultDefault prelError m = hsPatBind src (hsPId m) (HsBody body) noDef+       where+         body = hsId prelError `hsApp`+                hsLit src (HsString ("No default for method "++pp m))++tcInstDecl src optn ictx inst ds =+  do mnames <- methodNames inst+     let lacksDef = mnames \\ definedValueNames ds+         defds = toDefs (map useDefault lacksDef)+	 mds = ds `appendDef` defds+     ds' <- tcInstDecl' src ictx inst mds+     modmap <- getModule+     let n = fromMaybe (instName' modmap src inst) optn+     return $ oneDef $ hsInstDecl src (Just n) ictx inst ds'+  where+    useDefault m@(HsVar v) = hsPatBind src (hsPId m) (HsBody (hsId dm)) noDef+      where dm = HsVar (defaultName v)++methodNames cl =+  do Class _ _ _ ms <- snd # env kenv (definedType cl)+     let mnames:>:_ = unzipTyped ms+     return mnames++tcInstDecl' = tcInstOrClassDecl' False+tcClassDecl' = tcInstOrClassDecl' True++{-+tcInstOrClassDecl'+  :: (TypeId i,Printable i,Fresh i,+      Printable dsin, DefinedNames i dsin,+      TypeCheckDecls i dsin dsout)+  => Bool -> SrcLoc -> [Pred i] -> Type i -> dsin -> TI i dsout+-}+tcInstOrClassDecl' isClass src ictx inst ds =+  snd # tcInstOrClassDecl'' isClass src ictx inst ds+{-+tcInstOrClassDecl' isClass src ictx inst ds =+  do let cname = definedType inst+     (k,Class super0 cvs0 fundeps0 ms0) <- env kenv cname+     let cl0 = appT (ty cname:map tyvar cvs0)+     (cl,ms) <- allfresh (cl0,ms0) --since `matches` requires disjoint vars+     let ims = definedValueNames ds+	 ns:>:_ = unzipTyped ms+     case ims \\ ns of+       badms@(_:_) ->+         fail ("Extra bindings in "++dkind++" declaration: "++pp badms)+       [] -> errmap (("In "++dkind++" "++pp inst++"\n")++) $+             do s <- inst `matches` cl =<< getKEnv+		let mts = (map.fmap) (addctx (apply s ictx))+			             (apply s ms)+		ds' <-+		  --errmap (("Method signatures:\n"++pp mSigs++"\n")++) $+		  tcInstDecls mts ds -- (toDefs mSigs `appendDef` ds)+	        return ds'+  where+    dkind = if isClass then "class" else "instance"+    addctx ictx (Forall vs (ctx:=>t)) = uscheme ((ictx++ctx):=>t)+--  mSig m@(HsVar n) = do Forall vs (ctx:=>t) <- sch m+--		          return $ hsTypeSig src [n] (ictx++ctx) t+-}
+ tools/base/TI/TiClassInst2.hs view
@@ -0,0 +1,214 @@+{-++This module contains experimental stuff to complete the dictionary translation+by translating class declarations to record types and instance declaration+to record values. Doing this while staying within the source abstract syntax+is a bit clumbsy, unfortunately.++The default methods in class declarations are placed+in a "default instance", i.e. a record of the same type as an instance,+from with the default methods are selected by the translation of instance+declarations.++Apart from fields corresponding to methods, the record types also contain+fields corresponding to superclasses. The context reduction function refers+to these functions.++Most of this is not used at the moment.+-}+module TiClassInst2({-tcClassDecl,tcInstDecl,-}tcInstOrClassDecl'') where+import List((\\))++--import HasBaseStruct(HasBaseStruct(..),hsTypeSig,hsClassDecl,hsInstDecl)+import HasBaseStruct+import BaseSyntax hiding (TI)+--import SrcLoc(SrcLoc,srcLoc)+import TI+import qualified TiKEnv(lookup)+import TiDkc(Dinst{-,Einst-})+import TiDinst(hsSimpleBind{-,hsSimpleBind',tcSelFns-})+import TiSolve(matches)+--import MUtils+import PrettyPrint++{-+tcClassDecl d src ctx cl fdeps ds =+  do let (msigs,defaults) = splitMethodSigs ds+     (ms,ds') <- tcClassDecl' src [cl] cl defaults+     msigs':>:_ <- tcLocalDecls msigs -- kind check + type conversion+     hsClassDecl2 d {-bs-} ms src ctx cl fdeps msigs' ds'+++tcInstDecl src ictx inst ds =+  do (ns,ds') <- tcInstDecl' src ictx inst ds+     modmap <- getModule+     let n = instName' modmap src+     -- return $ hsInstDecl0 n ns src ictx inst ds'+     hsInstDecl2 n ns src ictx inst ds'+-}+--------------------------------------------------------------------------------+{-+hsClassDecl2 ::+  (Printable i,ValueId i,Eq i,TypeVar i,+   HasBaseStruct d2 (Dinst i e2 p2 ds2),+   HasBaseStruct e2 (Einst i e2 p2 ds2),HasId i e2,+   DeclInfo i (Dinst i e2 p2 ds2),+   HasId i p2,+   HasDef ds2 d2,+   --GetSigs i [Pred i] (Pred i) ds2,+   HasAbstr i d2,AddDeclsType i ds2,+   HasBaseStruct e1 (Einst i e1 p1 ds1),HasBaseStruct p1 (PI i p1),+   HasDef ds1 d1,TypeCheckDecl i (Dinst i e1 p1 ds1) ds2+  ) =>+  (Dinst i e1 p1 ds1) -> MethodInfo i -> SrcLoc -> [Pred i] -> Pred i -> HsFunDeps i ->+  ds2 -> ds2 -> TI i ds2+hsClassDecl2 d1 {-bs-} mi@(ms,_,_) src ctx cl fdeps msigs ds =+    do defaultInst <- hsDefaultMethods dn mi src ctx cl ds+       --m <- getModule+       let fields =+	     [HsRecDecl src cn +		 (supers+++		 [([i],unb (hsTyForall' vs (funT (c++[t]))))+                  | HsVar i:>:Forall vs (c:=>t)<-ms])]+       dictdata <- return $ HsDataDecl src [] cl fields []+       let dts = explicitlyTyped {-m-} [] dictdata+       selfns <- extendts dts $ tcSelFns [d1] []{-bs-} fields+       return $ addDeclsType ([],[HsVar dn:>:upscheme (funT [cl,cl])]) $+	        base dictdata+		`consDef` defaultInst+		`consDef` selfns+  where+    dn = defaultName cn+    c@(HsCon cn) = definedType cl+    supers = [([superName cn n],unb c)|(n,c)<-zip [1..] ctx]+    unb = HsUnBangedType++hsTyForall' [] t = t+hsTyForall' vs t = hsTyForall vs t++hsDefaultMethods ::+  (HasDef ds2 d2,HasBaseStruct d2 (Dinst i e p ds2),+   HasId i e,HasId i p,Eq i,ValueId i,Printable i,+   HasAbstr i d2,AddDeclsType i ds2,+   HasBaseStruct e (Einst i e p ds2))+  => i -> MethodInfo i -> SrcLoc -> [Pred i] -> Pred i -> ds2 -> TI i d2+hsDefaultMethods dn (ms,ims,_) src ctx cl ds =+    do darg <- dictName # fresh+       return $ abstract [darg] $ hsSimpleBind' src dn (body [darg]) ds+  where+    c@(HsCon cn) = definedType cl++    body dns = hsRecConstr cn (superDefs++methodDefs)+      where+        methodDefs = map methodDef ms++        superDefs = [HsField n (noDefault n)|n<-take (length ctx) superns]+           where superns = map (superName cn) [1..]++	methodDef (i@(HsVar v):>:_) =+	  HsField v $ if i `elem` ims+		      then apps (ident i:map var dns)+		      else noDefault i++	noDefault i = hsApp (var (prelVal "error"))+			    (hsLit$HsString$pp$src<>": no default for:"<+>i)++    apps = foldl1 hsApp+-}+--------------------------------------------------------------------------------++type MethodInfo i = ([Assump i],[HsIdentI i],[i])++tcInstDecl' = tcInstOrClassDecl'' False+tcClassDecl' = tcInstOrClassDecl'' True+tcInstOrClassDecl'' ::+  (TypeId i,Printable i,Fresh i,Printable dsin,+   DefinedNames i dsin,HasBaseStruct din (Dinst i e p dsin),+   HasDef dsin din,HasId i p,ValueId i,HasId i e,+   TypeCheckDecls i dsin dsout,+   HasDef dsout dout,HasBaseStruct dout (Dinst i e2 p2 dsout))+  => Bool -> SrcLoc -> [Pred i] -> Pred i -> dsin+  -> TI i (MethodInfo i,dsout)+tcInstOrClassDecl'' isClass src ictx inst ds0 =+  do let cname@(HsCon cn) = definedType inst+     (k,Class super0 cvs0 fundeps0 ms0) <- env kenv cname+     let cl0 = appT (ty cname:map tyvar (tdom cvs0))+     (cl,ms,super) <- return (cl0,ms0,super0) -- names are already unique+     --(cl,ms,super) <- allfresh (cl0,ms0,super0) --since `matches` requires disjoint vars+     supdns <- if isClass then return []+               --else map dictName # freshlist (length super)+	       else return $ map (superName cn) [1..length super]+     let ds = toDefs (map superMethod supdns) `appendDef` ds0+         ims = definedValueNames ds0 -- names of implemented methods+	 ns:>:_ = unzipTyped ms -- names of the methods of this class+	 supms = zipTyped (map HsVar supdns:>:map mono super)+     case ims \\ ns of+       badms@(_:_) ->+         fail ("Extra bindings in "++dkind++" declaration: "++pp badms)+       [] -> errorContext (pp$"In"<+>dkind<+>inst) $+             do kenv <- getKEnv+                s <- (inst `matches` cl) kenv+		let mts = (map.fmap) (addctx kenv (apply s ictx))+			             (apply s (ms++supms))+		ds' <-+		  --errmap (("Method signatures:\n"++pp mSigs++"\n")++) $+		  --errorContext ("Methods:\n"++pp ds) $+	          extendts [superVar:>:superType] $+		  tcInstDecls mts ds+	        return ((ms,ims,supdns),ds')+  where+    dkind = if isClass then "class" else "instance"+    addctx kenv ictx (Forall vs' vs (ctx:=>t)) = Forall vs' (ivs++vs) ((ictx++ctx):=>t)+       where+         ivs0 = tv (ictx,ctx,t) \\ tdom vs+	 ivs = [v:>:kind v|v<-ivs0]+	 kind = maybe err fst . TiKEnv.lookup kenv . HsVar+	 err = error "Bug in TiClassInst2: missing kind for a type variable"++--    mSig m@(HsVar n) = do Forall vs (ctx:=>t) <- sch m+--		          return $ hsTypeSig src [n] (ictx++ctx) t+    superMethod n = hsSimpleBind src n (ident superVar)++    superVar = HsVar (prelVal "super")+    superType = forall' [av:>:kpred] ([a]:=>a)+      where a = tyvar av+	    av = tvar 1++--------------------------------------------------------------------------------+{-+hsInstDecl2 ::+  (Eq i,ValueId i,+   HasDef ds2 d2,AddDeclsType i ds2,+   HasId i e2,HasId i p2,HasAbstr i ds2,+   HasBaseStruct e2 (Einst i e2 p2 ds2),+   HasBaseStruct d2 (Dinst i e2 p2 ds2))+  => i -> MethodInfo i -> SrcLoc -> [Pred i] -> Pred i -> ds2 -> TI i ds2+hsInstDecl2 n (ms,ims,supsels) src ctx inst ds =+    do self:dns <- map dictName # freshlist (1+length ctx)+       let selfbody = body self dns+       return $ abstract dns $+         let ds' = addDeclsType ([],[HsVar self:>:mono inst]) $+	           consDef selfdef ds+             selfdef = hsSimpleBind src self selfbody+         in oneDef $ hsSimpleBind' src n (var self) ds'+  where+    c@(HsCon cn) = definedType inst+    dn = defaultName cn++    body self dns = hsRecConstr cn (superDefs++methodDefs)+      where+        methodDefs = map methodDef ms++        superDefs = zipWith methodDef' superns (map HsVar supsels)+           where superns = map (superName cn) [1..]++	methodDef (i@(HsVar v):>:_) =+	  HsField v $ if i `elem` ims+		      then apps (ident i:map var dns)+		      else useDefault i++	methodDef' v i = HsField v $ apps (ident i:map var dns)++	useDefault i = ident i `hsApp` (var dn `hsApp` (var self))++    apps = foldl1 hsApp+-}
+ tools/base/TI/TiClasses.hs view
@@ -0,0 +1,161 @@+{-++This module defined various classes and auxiliary types that are used+throughout the type checker.+-}+module TiClasses where+import TiMonad(IM,KEnv)+import TiSolve(TypeConstraint)+import TiTypes+import HsLiteral(HsLiteral)+--import HasBaseStruct(hsIf)+--import DefinedNames(DefinedNames)+import TiKinds(KindConstraint)+import TiInstanceDB(Instance)+--import List(nub)+import MUtils+import AccList+--import Substitute+--import SrcLoc++type TypedDecls i ds = Typing ds (DeclsType i)+type TypedTopDecls i ds = Typing ds ([Instance i],DeclsType i)+type DeclsType i = ([TAssump i],[Assump i])++type TAssump i = Typing (HsIdentI i) (Kind,TypeInfo i)++nilDeclsType = ([],[]) -- ::DeclsType i++--(+++) :: DeclsType i->DeclsType i->DeclsType i+(xs1,ys1)+++(xs2,ys2) = (xs1++xs2,ys1++ys2)+concDeclsType = foldr (+++) nilDeclsType++class AddDeclsType i d | d->i where+  addDeclsType :: DeclsType i -> d -> d+  rmDeclsType :: d -> d++  addDeclsType _ d = d+  rmDeclsType = id++{-+Although their syntax are different, and they are type checked differently,+the base syntax uses *the same* type for, top level declarations,+local declarations, declarations in class definitions and declarations+in instance definitions. Obviously we can't use the same overloaded function+for type checking all of them...+-}+type CheckDecls i s r = s -> TI i (TypedDecls i r)+type CheckTopDecls i s r = s -> TI i (TypedTopDecls i r)+type CheckInstDecls i s r = [Assump i] -> s -> TI i r++class TypeCheckDecls i s r {-| s->r-} where+  tcTopDecls :: (s->s) -> CheckTopDecls i s r+  tcInstDecls :: CheckInstDecls i s r+   --,tcLocalDecls' --, tcClassDecls++  --tcLocalDecls' = tcTopDecls+tcLocalDecls ds = fmap (snd.snd) # tcTopDecls id ds+   -- discard instance db and kind env++class TypeCheckDecl i s r where+  tcDecl :: [Typed i (HsIdentI i)] -> s -> TI i r++class CheckRecursion i d where checkRecursion :: [d] -> TI i ()++type TI i = IM i (TypeConstraint i)+type KI i = IM i KindConstraint+class TypeCheck i s r {-| s->r-} where tc :: s -> TI i r+class KindCheck i t r | t->r where kc :: t -> KI i r++class DeclInfo i d | d->i where+  explicitlyTyped :: [Kinded (HsIdentI i)] -> [Typing (HsIdentI i) (TypeInfo i)] -> [Pred i] -> d -> DeclsType i+--isTypeDecl :: d -> Bool+  isUnrestricted :: Bool -> d -> Bool+  keepAmbigTypes :: d -> Bool++  keepAmbigTypes d = False++class HasMethodSigs ds where splitMethodSigs :: ds -> (ds,ds)+{-+class GetSigs i c tp ds | ds->i c tp where+  getSigs :: ds -> [(SrcLoc,[i],c,tp)]+-}+{-+instance KindCheck t r=> KindCheck [t] [r] where+  kc = mapM kc+  +instance (KindCheck t1 r1,+	  KindCheck t2 r2) => KindCheck (t1,t2) (r1,r2) where+  kc (t1,t2) = (,) # kc t1 <# kc t2+-}+--instance TypeCheck i s r => TypeCheck i [s] [r] where tc = mapM tc++class HasId i e | e->i where+  ident :: HsIdentI i -> e+  isId :: e -> Maybe (HsIdentI i)++var x = ident (HsVar x)+con c = ident (HsCon c)++isVar e = do HsVar x <- isId e+	     return x++--class HasLit e where lit :: HsLiteral -> e++class HasId i e => HasCoreSyntax i e | e->i where+  app :: e -> e -> e+  tuple,list :: [e] -> e+--paren :: e -> e++class HasTypeAnnot i e | e->i where+  typeAnnot :: e -> Type i -> e+  typeAnnot e t = e -- default: no decoration++--typedIf t cnd thn els = typeAnnot (hsIf cnd thn els) t++class HasCoreSyntax i e => HasTypeApp i e | e->i where+  spec :: HsIdentI i -> Scheme i -> [Type i] -> e+  spec x sc ts = ident x -- default: no decoration++class HasAbstr i e | e->i where+  abstract :: [i] -> e -> e++class (HasAbstr i s) => HasLocalDef i e s | s->e i where+  letvar :: Typing i (Type i) -> e -> s -> s+{-+smartLetvar x@(i:>:_) e =+    case isId e of+      Just _ -> esubst1 var e i+      _ -> letvar x e+-}+--letvar x e1 e2 = abstract [x] e2 `app` e1++instance HasAbstr i e => HasAbstr i [e] where+  abstract = map . abstract++instance HasLocalDef i e s => HasLocalDef i e [s] where+  letvar x e1 = map (letvar x e1)++infixr 5 `consDef`+class HasDef ds d | ds->d where+  nullDef :: ds -> Bool+  noDef :: ds+  consDef :: d -> ds -> ds+  appendDef :: ds -> ds -> ds+  filterDefs :: (d->Bool) -> ds -> ds+  toDefs :: [d] -> ds++  toDefs = foldr consDef noDef++concatDefs ds = foldr appendDef noDef ds+oneDef d = consDef d noDef++class HasDefs ds d | ds->d where fromDefs :: ds -> [d]+instance HasDefs [d] d where fromDefs = id++--class Decorate s i where decorate :: i -> s -> s++class EnvFrom ds env | ds->env where accEnv :: ds -> env -> env++envFrom ds = accEnv ds nilDeclsType++instance EnvFrom d env => EnvFrom [d] env where accEnv = accList accEnv
+ tools/base/TI/TiConstraints.hs view
@@ -0,0 +1,8 @@+-- Collecting constraints efficiently...+module TiConstraints(Constraints,empty,single,Tree.merge,Tree.toList) where+import qualified Tree++type Constraints c = Tree.Tree c++empty = Tree.Empty+single = Tree.Single
+ tools/base/TI/TiContextReduction.hs view
@@ -0,0 +1,204 @@+module TiContextReduction(entails,contextReduction,contextReduction'') where+import TiInstanceDB+import TiClasses+import TiMonad+import TiTypes+import TiBySuper+import TiFresh+import TiFunDeps(improvements)+import TiNames(TypeId,ValueId,dictName)+import TiSCC(sccD')+import TiFreeNames(freeVars)+import TiSolve(expandSynonyms)+import TiUtil(freshen',freshvars)+import SrcLoc1+import PrettyPrint hiding (var)+import List(partition,(\\))+import Monad(msum,mplus)+import MUtils+import Debug.Trace(trace) -- debug+import TiPretty() -- debug++--type Ctx = [Typing QId Pred]++--contextReduction, rmByInst :: HasLocalDef e => IDB -> Ctx -> IM i (Ctx,e->e)+++type Dict v = Typing v (Type v)+type Ctx v = [Dict v]++type DDefs v = [(Dict v,DExp v)] -- dictionary definitions+type DictsF v = DDefs v->DDefs v++contextReduction ds = contextReduction' True ds+contextReduction' delayIfOverlap ds =+    apSnd returnLets # contextReduction1' delayIfOverlap ds++contextReduction1 ds = contextReduction1' True ds++contextReduction1' delayIfOverlap ds =+ do idb <- getIEnv+    tenv <- getKEnv+    --trace (pp $ caller<+>"contextReduction1 tenv=" $$ nest 2 tenv) done+    contextReduction2 delayIfOverlap idb tenv ds++contextReduction2+  :: (TypeId v,ValueId v,HasSrcLoc v,Fresh v)+  => Bool -> IDB v -> KEnv v -> Ctx v -> TI v (Ctx v, DictsF v)+contextReduction2 delayIfOverlap idb env =+    rmDupCtx & rmBySuper & rmDupCtx & rmByInst delayIfOverlap env idb & rmDupCtx+  where+    (&) red1 red2 ds =+      do (ds1,r1) <- red1 ds+	 (ds2,r2) <- red2 ds1+	 return (ds2,r2 . r1)++    rmDupCtx = return . rmDupCtx'+    rmDupCtx' ds =+      case ds of+	[] -> ([],id)+	(d@(dn:>:dt):ds) ->+	   case partition (sameInstance d) ds of+	     (same,other) -> (d:ds',r')+	       where+		 r' = foldr l r same+		 l d' = (letvar' d' dne .)+		 dne = var dn+	    	 (ds',r) = rmDupCtx' other++    rmBySuper ds =+      do let addSuper (dn:>:dt) = tail # bySuper env (var dn:>:dt)+         supds <- concatMapM addSuper ds+	 let rm ds1 r [] = (reverse ds1,r)+	     rm ds1 r (d:ds2) =+		 case filter (sameInstance d) supds of+		   [] -> rm (d:ds1) r ds2+		   (supde:>:_):_ -> rm ds1 r' ds2+		     where r' = letvar' d supde . r+	 return (rm [] id ds)++superClosure eds env = concatMapM (bySuper env) (map (emap var) eds)++entails eds ids env = +    do availds <- superClosure eds env+       is <- let _:>:ectx = unzipTyped availds+	         _:>:ictx = unzipTyped ids+             in improvements (ectx++ictx) -- need to skolemize vars in ectx?+       let availds' = apply is availds+	   ids' = apply is ids+	   _:>:actx = unzipTyped availds'+       r <- errorContext ("Given context:"<+>ectx $$+			  "Should entail:"<+>ictx $$+			  "Improving substitution:"<+>is) $+	    returnLets . foldr (.) id # entails' availds' env ids'+       return (is,r)+{-+    `mplus` fail (pp $ fsep [ppi "contexts don't match:",+			     ppiFTuple ectx,ppi "vs",ppiFTuple ictx])+-}+  where+    _:>:ectx = unzipTyped eds+    _:>:ictx = unzipTyped ids++entails' availds env = mapM entails0+  where+    entails0 d@(_:>:dt) =+        entails1 d `mplus` (fail $ pp $ "Can not justify:"<+>dt)++    entails1 d@(_:>:dt) =+       case filter (sameInstance d) availds of+         [] -> msum . map entails2 =<< reduceInstOneStep d+	 (supde:>:_):_ -> return (letvar' d supde)++    reduceInstOneStep d@(dn:>:inst) =+      do idb <- getIEnv+	 mapM (use1Inst d) (findInst' False idb (expandSynonyms env inst))++    entails2 (ids2,r) = foldr (.) r # mapM entails1 ids2+    +sameInstance (_:>:t1) (_:>:t2) = t1==t2+++rmByInst delayIfOverlap env idb ds =+  --stpp ds $+  case ds of+    [] -> return ([],id)+    (d@(dn:>:inst):ds) ->+      case findInst' delayIfOverlap idb (expandSynonyms env inst) of+	[] -> {-(if null (tv inst)+	       then trace (pp $ fsep [ppi (srcLoc dn)<>":",+				      ppi "No instance: ",+				      ppi inst{-,+				      ppi "in",+				      ppi idb-}])+	       else id) $-}+	      preserve+	[i] -> if True -- null (tv inst) -- delay reduction, ...+               then useInst i+	       else trace (pp $ "Delaying"<+>d<+>srcLoc dn) $+                    preserve -- ... experiment for overlapping instances+	is -> trace msg preserve -- experiment+	      --fail msg -- normal+          where msg = pp $ sep [ppi "Ambiguous instances", "("<>map fst is<>")",+		                "for"<+>inst]+      where+        preserve = apFst (d:) # rmByInst delayIfOverlap env idb ds++	useInst inst =+            do (ids,r1) <- use1Inst d inst+	       (ds2,r2) <- rmByInst delayIfOverlap env idb (ids++ds)+	       return (ds2,r2 . r1)++use1Inst d ((idn,ips0),((gs,ip),s)) =+    do idns <- map dictName # freshlist (length ips0)+       let lgs = [g|g@(v:>:_)<-gs,v `elem` d]+             where d = tv ips0 \\ tv ip+       lvs <- freshvars lgs+       (ips,ts0) <- return $ freshen' lvs (tdom lgs) (ips0,map tyvar (tdom gs))+       let dt = funT (ips++[ip])+           ids = zipWith (:>:) idns ips+	   --Forall gs _ = sc+	   sc = mono dt -- fake, ok since it isn't used+	   ts = apply s ts0+	   --idne = var idn -- without type annotations+	   idne = DSpec (HsVar idn) sc ts -- with type annotations+	   d' = foldl1 DApp (idne:map var idns)+	   r1 = letvar' d d'+       --trace (pp ((s,gs,ips0:=>ip),(lgs,lvs,ips:=>ip))) $ done+       return (ids,r1)++letvar' v e = ((v,e):)++-- Sort dictionary definitions in dependency order and return a nested let.+returnLets r = \s -> foldr (uncurry letvar . apSnd dconv) s (order (r []))+  where+    order = concat . sccD' names+    names (d:>:_,e) = ([HsVar d],dfree e)++--------------------------------------------------------------------------------++-- To avoid an ambiguity when you only want the resulting predicates and+-- not the dictionary rewriting function:++contextReduction'' ds = fst # contextReduction1 ds++data DExp i+  = DId (HsIdentI i)+  | DApp (DExp i) (DExp i)+  | DSpec (HsIdentI i) (Scheme i) [Type i]++dconv de =+  case de of+    DId i -> ident i+    DApp e1 e2 -> app (dconv e1) (dconv e2)+    DSpec i sc t -> spec i sc t++instance HasId i (DExp i) where ident = DId+instance HasCoreSyntax i (DExp i) where app = DApp -- ; ...+instance HasTypeApp i (DExp i) where spec = DSpec++dfree de =+    case de of+      DId   i     -> [i]+      DSpec i _ _ -> [i]+      DApp  e1 e2 -> dfree e1++dfree e2
+ tools/base/TI/TiD.hs view
@@ -0,0 +1,197 @@+--Type checking base language declarations (the D structure)+module TiD where+import Maybe(isJust)+import Monad(unless)++import HsDeclStruct+import HsDeclUtil(unbang)+import SrcLoc1(srcLoc)+import HasBaseStruct+import TI hiding (Subst)+import TiDkc+--import TiDinst(tcSelFns)+import TiE(tcDsLambda')+import TiClassInst -- preserves class and instance declarations+--import TiClassInst2(tcInstDecl) -- translates class and instance declarations++--import HsExpStruct(EI)+import HsPatStruct(PI)+import HsIdent(mapHsIdent2)++import MUtils(apFst,( # ))+import SimpleGraphs(reachable')+import PrettyPrint(Printable,pp)++-- For debugging only:+--import IOExts(trace)+--mtrace s = trace s $ done+++mapVars f = map $ emap $ mapHsIdent2 f id++instance (TypeVar i,ValueId i,DefinedNames i p,HasId i p,DeclInfo i ds)+         => DeclInfo i (Dinst i e p ds) where+  isUnrestricted expl d =+      case d of+	HsPatBind s p rhs ds -> expl && isJust (isVar p)+	_ -> True+{-+  isTypeDecl d =+      case d of+        HsTypeDecl    {} -> True+        HsNewTypeDecl {} -> True+        HsDataDecl    {} -> True+        HsClassDecl   {} -> True+        HsPrimitiveTypeDecl {} -> True+	_ -> False+-}+  explicitlyTyped kenv tinfo ctx d =+      apFst (map addKind) $+      case d of+	HsTypeDecl s tp t             -> (tiType tp t,[])+	HsNewTypeDecl s ctx tp cd drv -> (tiNewtype ctx tp,+			                  constrTypes ctx tp cd)+	HsDataDecl s ctx tp cds drv   -> (tiData ctx tp,+					  concatMap (constrTypes ctx tp) cds)+	HsClassDecl s c tp fdeps ds   -> (tiClass kenv tinfo c tp fdeps ds,ms++dms)+           where+            ms =snd (explicitlyTyped kenv tinfo [tp] ds)+	    dms = mapVars defaultName ms+	HsInstDecl s optn c tp ds     -> ([],[])+	HsDefaultDecl s t             -> ([],[])+	HsTypeSig s nms c t    -> ([],[HsVar n:>:kuscheme kenv ((ctx++c):=>t)|n<-nms])+	HsFunBind s matches           -> ([],[])+	HsPatBind s p rhs ds          -> ([],[])+	HsInfixDecl   s fixity names  -> ([],[])++        HsPrimitiveTypeDecl s ctx tp  -> (tiData ctx tp,[])+        HsPrimitiveBind s nm tp       -> ([],[HsVar nm:>:kupscheme kenv tp])+--	_ -> []+    where+      addKind (c:>:tinfo) = c:>:(kind,tinfo)+        where [kind] = [k|c':>:k<-kenv,c'==c]++      constrTypes ctx tp con =+	  case con of+	    HsConDecl s evs ectx c bangts -> -- !!!+	       [HsCon c :>: conT ectx (map unbang bangts)]+	    HsRecDecl s evs ectx c fields -> -- !!!+	       (HsCon c :>: conT ectx args):+	       [HsVar f :>: kupscheme kenv (lhsT `hsTyFun` t)|(f,t)<-fs]+	     where+               fs = [(f,t)|(fs,bt)<-fields,let t=unbang bt,f<-fs]+	       args = map snd fs+	where+	  conT ectx args = kuscheme kenv (ectx:=>funT (args++[lhsT]))+	  lhsT = tp+{-+instance (Fresh i,TypeId i,Printable i,+	  TypeCheck i e1 (Typed i e2),+	  DefinedNames i p1,TypeCheck i p1 (Typed i p2),+	  DefinedNames i ds1,Printable ds1,TypeCheckDecls i ds1 ds2,+          HasMethodSigs ds1,HasTypeAnnot i e2,+          HasBaseStruct d2 (Dinst i e2 p2 ds2),HasDef ds2 d2,++          -- Extra stuff for constructing field selector functions:+	  HasDef ds1 d1,HasBaseStruct p1 (PI i p1),+	  HasBaseStruct e1 (Einst i e1 p1 ds1),++          -- Extra stuff for translating class and instance declarations+          -- (using module TiClassInst2):+          ValueId i,HasId i e1,HasId i p1,+	  HasBaseStruct d1 (Dinst i e1 p1 ds1),Printable d1,+	  HasId i e2,HasId i p2,HasAbstr i d2,HasAbstr i ds2,+	  HasBaseStruct e2 (Einst i e2 p2 ds2),DefinedNames i p2,+	  --GetSigs i [Pred i] (Pred i) ds2,DeclInfo i ds2,+	  MapDefinedNames i ds2,+	  AddDeclsType i ds2)+      => TypeCheckDecl i (Dinst i e1 p1 ds1) ds2 where tcDecl = tcD+-}+tcD bs d =+  posContext' (srcLoc d) "(type check)" $+  case d of+    HsTypeDecl s tp t             -> retOne (hsTypeDecl s tp t)+    HsNewTypeDecl s ctx tp cd drv -> retOne (hsNewTypeDecl s ctx tp cd drv)+    HsDataDecl s ctx tp cds drv   -> tcDataDecl d bs s ctx tp cds drv+    HsClassDecl s c tp fdeps ds   -> tcClassDecl s c tp fdeps ds+    HsInstDecl s optn c tp ds     -> tcInstDecl s optn c tp ds+    HsDefaultDecl s t             -> retOne (hsDefaultDecl s t)+    HsTypeSig s nms c tp          -> retOne (hsTypeSig s nms c tp)+    HsFunBind s matches           -> oneDef # tcFunBind bs s matches+    HsPatBind s p rhs ds          -> oneDef # tcPatBind bs s p rhs ds+    HsInfixDecl   s fixity names  -> retOne (hsInfixDecl s fixity names)++    HsPrimitiveTypeDecl s ctx tp  -> retOne (hsPrimitiveTypeDecl s ctx tp)+    HsPrimitiveBind s nm tp       -> oneDef # tcPrimBind bs s nm tp++retOne = return . oneDef++tcDataDecl d bs s ctx tp cds drv =+    retOne (hsDataDecl s ctx tp cds drv)+{-+    do selfns <- tcSelFns [d] bs cds+       return (hsDataDecl s ctx tp cds drv `consDef` selfns)+-}++tcPrimBind bs s nm t =+  do t' <- varinst' bs nm+     t'=:=t+     return $ hsPrimitiveBind s nm t++tcFunBind bs s matches@(HsMatch _ n _ _ _:_) =+  do ms :>: ts <- unzipTyped # mapM tcMatch matches+     t <- varinst' bs n+     mapM_ (t=:=) ts+     return $ hsFunBind s ms++varinst' bs n =+  case [ t |HsVar x:>:t<-bs,x==n] of+    t:_ -> return t+    _ -> tfresh -- needed for selector functions generated in tcSelFns...+	 --fail$"Type checker bug: no type introduced for: "++pp n++tcMatch (HsMatch s n ps rhs ds) =+  do (ps',ds',rhs'):>:t <- tcDsLambda' ps ds rhs+     HsMatch s n ps' rhs' ds' >: t++tcPatBind bs s p rhs ds =+  do p':>:tp <- extendts ((map (fmap mono) bs)) (tc p)+     (ds',rhs'):>:trhs <- tcDsRhs ds rhs+     tp=:=trhs+     return (hsPatBind s p' rhs' ds')++tcDsRhs ds rhs =+  do ds':>:bs <- tcLocalDecls ds+     rhs':>:trhs <- extendts bs (tc rhs)+     (ds',rhs')>:trhs+++{-++Type synonyms may not be recursive (H98 report, section 4.2.2).+This check has to be made before type checking, since recursive type+synonyms can cause the current implementation of the type checker to loop!+-}+checkTypeSynRec ds =+    unless (null recsyns) $ +      declContext recsyns $+        fail "Recursive type synonym"+  where+    recsyns = [syn|(syn,_)<-g,syn `elem` reachable' g [syn]]+    g = [(i,free) | Just d@(HsTypeDecl s tp t)<-map basestruct ds,+	            let free=freeTypeNames t,+	            i<-definedTypeNames tp]++{-++The superclass relation must be not be cyclic (H98 report, section 4.3.1).+This check has to be made before type checking, since a cyclic superclass+relation can cause the current implementation of the type checker to loop!+-}+checkClassRec ds =+    unless (null recclasses) $ +      declContext recclasses $+        fail "The superclass relation must be not be cyclic"+  where+    recclasses = [c|(c,_)<-g,c `elem` reachable' g [c]]+    g = [(i,free) | Just d@(HsClassDecl s ctx tp fdeps ds)<-map basestruct ds,+	            let free=freeTypeNames ctx,+	            i<-definedTypeNames tp]
+ tools/base/TI/TiDecorate.hs view
@@ -0,0 +1,339 @@+{-++This module provides type inference for the base syntax.+This type checker outputs an abstract syntax tree where all declaration lists+have been decorated with the kinds and types of the entities defined in+the list, and all applications of polymorphic functions have been decorated+with the instantiation of the quantified variables.+-}+module TiDecorate where+import BaseSyntax+import HasBaseStruct+import Substitute+import SubstituteBaseStruct(substE') --hmm+import FreeNames+import DefinedNames+import Syntax(HsPatI,HsTypeI,HsDeclI,HsExpI,Rec(..))+import qualified Syntax as S+import PrettyPrint+import PrettySymbols+import TI hiding (Subst)+import TiBase()+import TiBaseStruct(tcE,tcP,tcD)+import List(nub)+--import Maybe(mapMaybe)+--import QualNames+import MUtils(apSnd)+--import IOExts(trace)++--------------------------------------------------------------------------------+--type TiModule i = HsModuleI i (TiDecls i)+data TiDecls i = Decs [TiDecl i] (DeclsType i) deriving Show++type DStruct i = DI i (TiExp i) (TiPat i) (TiDecls i) (HsTypeI i) [HsTypeI i] (HsTypeI i)+type EStruct i = EI i (TiExp i) (TiPat i) (TiDecls i) (HsTypeI i) [HsTypeI i]+type PStruct i = PI i (TiPat i)++newtype TiDecl i = Dec (DStruct i) deriving Show++data TiExp i+  = Exp (EStruct i)+  | TiSpec (HsIdentI i) (Scheme i) [HsTypeI i] -- specialize a polymorphic identifier+  | TiTyped (TiExp i) (HsTypeI i)+  deriving Show++data TiPat i+  = Pat (PStruct i)+  | TiPApp (TiPat i) (TiPat i) -- for fromInteger & fromRational & n+k+  | TiPSpec (HsIdentI i) (Scheme i) [HsTypeI i] -- specialize a polymorphic identifier+  | TiPTyped (TiPat i) (HsTypeI i)+  deriving Show++--------------------------------------------------------------------------------+instance MapExp (TiExp i) (TiDecls i) where+  mapExp f (Decs ds dt) = Decs (mapExp f ds) dt++instance MapExp (TiExp i) (TiDecl i) where mapExp = mapExpRec++instance Subst i (TiExp i) where+  subst s e =+    case e of+      Exp be -> substE' Exp s be+      TiTyped e t -> TiTyped (subst s e) t+      TiSpec (HsVar x) sc ts ->+          case isId sx of+            Just y -> TiSpec y sc ts+	    _ -> sx -- type annotation is lost!+	where sx = s x+      _ -> e +--------------------------------------------------------------------------------++instance (PrintableOp i,ValueId i,TypeId i,Fresh i,HasSrcLoc i,TypedId PId i)+      => TypeCheckDecl i (HsDeclI i) (TiDecls i) where+  tcDecl bs = tcD bs . struct++instance AddDeclsType i (TiDecls i) where+  addDeclsType dt1 (Decs ds dt2) = Decs ds (dt1+++dt2)+  rmDeclsType (Decs ds dt) = Decs ds ([],[])++instance (PrintableOp i,ValueId i,TypeId i,Fresh i,HasSrcLoc i,TypedId PId i)+      =>  TypeCheck i (HsExpI i) (Typed i (TiExp i)) where tc (S.Exp e) = tcE e++instance (Printable i,ValueId i,TypeId i,Fresh i)+      =>  TypeCheck i (HsPatI i) (Typed i (TiPat i)) where tc (S.Pat e) = tcP e+{-+instance GetSigs i [Pred i] (Type i) (TiDecls i) where+  getSigs (Decs ds _) = mapMaybe getSig ds+    where+      getSig (Dec (HsTypeSig s is c tp)) = Just (s,is,c,tp)+      getSig _                    = Nothing++instance (TypeVar i,ValueId i) => DeclInfo i (TiDecl i) where+  explicitlyTyped {-m-} bs = explicitlyTyped {-m-} bs . struct+  isUnrestricted b = isUnrestricted b . struct++instance DeclInfo i (TiDecls i)+-}+--------------------------------------------------------------------------------++type DeclsUseType i = ([TAssump i],[UAssump i])+type UAssump i = Typing (HsIdentI i) (Scheme i,Maybe (Type i))++instance EnvFrom ds env => EnvFrom (HsModuleI m i ds) env where+  accEnv = accEnv . hsModDecls++instance TypeVar i => EnvFrom (TiDecls i) (DeclsUseType i) where+  accEnv (Decs ds dt) = (no_use dt+++) . accEnv ds++no_use = apSnd ((map.fmap) (flip (,) Nothing))+drop_use = apSnd ((map.fmap) fst)++instance TypeVar i => EnvFrom (TiDecl i) (DeclsUseType i) where+  accEnv = accEnv . struct++instance (EnvFrom e env,EnvFrom p env,EnvFrom ds env)+      => EnvFrom (DI i e p ds t c tp) env where+  accEnv = accDI ignore accEnv accEnv accEnv ignore ignore ignore++instance TypeVar i => EnvFrom (TiPat i) (DeclsUseType i) where+  accEnv (Pat p) = accEnv p+  accEnv (TiPSpec v@(HsVar _) t as) = (([],[v:>:(t,specType t as)])+++)+  accEnv (TiPApp (TiPSpec {}) p2) = accEnv p2+  accEnv (TiPApp p1 p2) = accEnv p1 . accEnv p2+  accEnv (TiPTyped p t) = accEnv p+  accEnv _ = id++instance EnvFrom p env => EnvFrom (PI i p) env where+  accEnv = accPI ignore accEnv++instance TypeVar i => EnvFrom (TiExp i) (DeclsUseType i) where+  accEnv (Exp e) = accEnv e+  accEnv (TiSpec v@(HsVar _) t as) = (([],[v:>:(t,specType t as)])+++)+  accEnv (TiTyped e t) = accEnv e+  accEnv _ = id++specType (Forall _ kgs (_:=>t)) as =+    if map tyvar gs==as+    then Nothing+    else Just (apply s t)+  where s = S (zip gs as)+        gs = tdom kgs++instance (EnvFrom e env,EnvFrom p env,EnvFrom ds env)+      => EnvFrom (EI i e p ds t c) env where+  accEnv = accEI ignore accEnv accEnv accEnv ignore ignore++ignore = const id++--------------------------------------------------------------------------------+instance HasBaseStruct (TiDecls i) [TiDecl i] where base ds = Decs ds ([],[])+instance HasBaseStruct (TiDecl i) (DStruct i) where base    = Dec+instance HasBaseStruct (TiExp i) (EStruct i)  where base    = Exp+instance HasBaseStruct (TiPat i) (PStruct i)  where base    = Pat++instance Rec (TiDecl i) (DStruct i) where r = base; struct (Dec d) = d+instance GetBaseStruct (TiDecl i) (DStruct i) where basestruct = Just . struct++instance HasId i (TiExp i) where+  ident = Exp . ident+  isId (Exp e) = isId e+  isId (TiSpec x _ []) = Just x+  isId _ = Nothing --hmm++instance HasId i (TiPat i) where+  ident = Pat . ident+  isId (Pat e) = isId e+  isId (TiPSpec x _ []) = Just x+  isId _ = Nothing --hmm++--instance HasLit (TiExp i) where lit = hsLit loc0+--instance HasLit (TiPat i) where lit = hsPLit loc0++instance HasCoreSyntax i (TiExp i) where+  app = hsApp+  tuple = hsTuple+  list = hsList+--paren = hsParen++instance HasCoreSyntax i (TiPat i) where+  app = TiPApp+  tuple = hsPTuple loc0 -- !!+  list = hsPList loc0 -- !!+--paren = hsParen++instance HasTypeApp i (TiExp i) where spec=TiSpec+instance HasTypeApp i (TiPat i) where spec=TiPSpec++instance HasTypeAnnot i (TiExp i) where typeAnnot=TiTyped+instance HasTypeAnnot i (TiPat i) where typeAnnot=TiPTyped++instance HasDef (TiDecls i) (TiDecl i) where+  nullDef (Decs ds _) = null ds+  noDef = Decs [] ([],[])+  consDef d (Decs ds ts) = Decs (d:ds) ts+  toDefs ds = Decs ds ([],[])+  appendDef (Decs ds1 ts1) (Decs ds2 ts2) = Decs (ds1++ds2) (ts1+++ts2)+  filterDefs p (Decs ds ts) = Decs (filter p ds) ts -- keep all type info?!++instance HasDefs (TiDecls i) (TiDecl i) where+  fromDefs (Decs ds _) = ds++instance HasSrcLoc (TiDecl i) where srcLoc (Dec d) = srcLoc d++instance HasAbstr i (TiDecl i) where abstract xs (Dec d)      = Dec (abstract xs d)+instance HasAbstr i (TiDecls i) where abstract xs (Decs ds ti) = Decs (abstract xs ds) ti+--------------------------------------------------------------------------------+instance DefinedNames i (TiDecls i) where definedNames (Decs ds ti) = definedNames ds+instance ClassMethods i (TiDecls i) where classMethods i cnt (Decs ds ti) = classMethods i cnt ds+instance MapDefinedNames i (TiDecls i) where+   mapDefinedNames f (Decs ds ti) = mapTiDeclsNames Decs f ds ti++mapTiDeclsNames decs f ds (ks,ts) =+      decs (mapDefinedNames f ds) (ks,mapVars f ts)+   where mapVars f = map $ emap $ mapHsIdent2 f id++instance DefinedNames i (TiDecl i) where definedNames = definedNamesRec+instance ClassMethods i (TiDecl i) where classMethods = classMethodsRec+instance AddName i (TiDecl i)++instance MapDefinedNames i (TiDecl i) where+   mapDefinedNames = mapDefinedNamesRec++instance DefinedNames i (TiPat i) where+  definedNames (Pat p) = definedNames p+  definedNames (TiPSpec (HsVar x) sc ts) = [value x]+  definedNames (TiPSpec _ sc ts) = []+  definedNames (TiPTyped p t) = definedNames p+  definedNames (TiPApp p1 p2) = appDef p1 [p2]+    where+      appDef (TiPApp p1 p2) ps = appDef p1 (p2:ps)+      appDef (TiPSpec c@(HsCon _) sc ts) ps = definedNames ps+      appDef (TiPSpec x sc ts) ps = [] -- overloaded literal, binds nothing++instance MapDefinedNames i (TiPat i) where+  mapDefinedNames f p =+    case p of+      Pat p -> Pat (m p)+      TiPSpec (HsVar x) sc ts -> TiPSpec (HsVar (f x)) sc ts+      TiPTyped p t -> TiPTyped (m p) t+      TiPApp p1 p2 -> mApp p1 [p2]+    where+      m x = mapDefinedNames f x++      mApp (TiPApp p1 p2) ps = mApp p1 (p2:ps)+      mApp p@(TiPSpec c@(HsCon _) _ _) ps = apps (p:m ps)+      mApp p ps = apps (p:ps) -- overloaded literal, binds nothing++      apps = foldl1 TiPApp++instance Eq i => FreeNames i (TiDecl i) where freeNames = freeNamesRec+instance Eq i => FreeNames i (TiDecls i) where freeNames (Decs ds ti) = freeNames ds+instance Eq i => FreeNames i (TiExp i) where+  freeNames (Exp e) = freeNames e+  freeNames (TiSpec x sc ts) = [val x] -- hmm+  freeNames (TiTyped e t) = freeNames e -- hmm++instance (Eq i) => FreeNames i (TiPat i) where+  freeNames (Pat p) = freeNames p+  freeNames (TiPSpec (HsCon c) sc ts) = [FreeNames.con c]+  freeNames (TiPSpec _ sc ts) = []+  freeNames (TiPTyped p t) = freeNames p -- hmm+  freeNames p@(TiPApp p1 p2) = appFree p1 [p2]+    where+      {- An application is either+           1. A construtor applied to a number of subpatterns, or+           2. fromInteger/fromRational/negate, applied to a dictionary+              and a literal. -}+      appFree (TiPApp p1 p2) ps = appFree p1 (p2:ps)+      appFree (TiPSpec (HsCon c) sc ts) ps = nub (FreeNames.con c:freeNames ps)+      appFree (TiPSpec x sc ts) ps = nub (val x:concatMap argFree ps)+	   -- x must be negate, fromInteger or fromRational+      appFree (Pat (HsPId x@(HsVar _))) [] = [] -- dictionary bound in where clause+      appFree (Pat (HsPId _)) ps = error "Bug: TiDecorate.appFree (Pat (HsPId _))"+      appFree (Pat p) ps = error ("Bug: TiDecorate.appFree (Pat _)")+      appFree p ps = error ("Bug: TiDecorate.appFree p ps")++      argFree (Pat (HsPLit _ _)) = []+      argFree p = appFree p []++--------------------------------------------------------------------------------+instance Eq i => HasLocalDef i (TiExp i) (TiDecl i) where+   --letvar x e (Dec d) = Dec (letvar x e d)+    letvar x e = mapRec (letvar x e)++instance Eq i => HasLocalDef i (TiExp i) (TiDecls i) where+   letvar x e (Decs ds ts) = Decs (letvar x e ds) ts++-- For these instances, tmap f should apply f to all types inserted during+-- type checking, since they might contain type variables that have been+-- instantiated later.+instance TypeVar i => Types i (TiDecl i) where+  tmap f (Dec d) = Dec (tmap f d)+--tv = ...++instance TypeVar i => Types i (TiDecls i) where+  tmap f (Decs ds (ks,ts)) = Decs (tmap f ds) (ks,tmap f ts)+--tv = ...++instance TypeVar i => Types i (TiExp i) where+  tmap f (Exp e) = Exp (mapEI id (tmap f) (tmap f) (tmap f) id id e)+  tmap f (TiSpec x sc ts) = TiSpec x (tmap f sc) (tmap f ts)+  tmap f (TiTyped e t) = TiTyped (tmap f e) (f t)+--tv = ...++instance TypeVar i => Types i (TiPat i) where+  tmap f (Pat p) = Pat (mapPI id (tmap f) p)+  tmap f (TiPApp p1 p2) = TiPApp (tmap f p1) (tmap f p2)+  tmap f (TiPSpec x sc ts) = TiPSpec x (tmap f sc) (tmap f ts)+  tmap f (TiPTyped e t) = TiPTyped (tmap f e) (f t)+--tv = ...+--------------------------------------------------------------------------------+instance (TypeId i,ValueId i,PrintableOp i) => Printable (TiDecl i) where+  ppi (Dec d)      = ppi d+instance (TypeId i,ValueId i,PrintableOp i) => Printable (TiDecls i) where+  ppi (Decs ds (ks,ts)) = vcat ds $$+			  ppIfTypeInfo (sep [ppi "{-",ppi ks,ppi ts,ppi "-}"])+  ppis (Decs ds ([],[])) = ppis ds+  ppis (Decs ds (ks,ts)) = ppis ds +++                           map ppIfTypeInfo [ppi "{-",ppi ks,ppi ts,ppi "-}"]++instance (TypeId i,ValueId i,PrintableOp i) => Printable (TiExp i) where+   ppi (Exp e)      = ppi e+   ppi (TiSpec x sc []) = wrap x <> ppIfDebug ("{-"<>sc<>"-}")+   ppi (TiSpec x sc ts) = wrap x <>+                          ppIfDebug ("{-"<>sc<>"@"<>fsep (map wrap ts)<>"-}")+   ppi (TiTyped e t) = e <> ppIfDebug ("{-"<>el<>t<>"-}")++   wrap (Exp e) = wrap e+   wrap e = ppi e+++instance (TypeId i,ValueId i,PrintableOp i) => Printable (TiPat i) where+   ppi (Pat e)      = ppi e+   ppi (TiPSpec x sc []) = wrap x <> ppIfDebug ("{-"<>sc<>"-}")+   ppi (TiPSpec x sc ts) = wrap x <> ppIfTypeInfo ("{-"<>ppIfDebug (sc<>"@")<>fsep (map wrap ts)<>"-}")+   ppi (TiPApp p1 p2) = fsep [ ppi p1, letNest (wrap p2) ]+   ppi (TiPTyped p t) = p<>ppIfDebug ("{-"<>el<>t<>"-}")++   wrap (Pat e) = wrap e+   wrap p@(TiPApp {}) = parens (ppi p)+   wrap p = ppi p
+ tools/base/TI/TiDefault.hs view
@@ -0,0 +1,79 @@+module TiDefault where+import TiTypes+import TiMonad+import TiContextReduction+import TiSolve(expandSynonyms)+import TiFunDeps(closure)+import SrcLoc1+import Lists(partition,(\\\),nubBy)+import OpTypes(eqBy)+import MUtils+import PrettyPrint+import Monad(msum,unless)++resolveToplevelAmbiguities ps = resolveAmbiguities' (tv ps) ps+ +resolveAmbiguities fdeps ngvs ps ts =+    (,) unambigps # resolveAmbiguities' avs ambigps+  where (avs,(ambigps,unambigps)) = ambiguities fdeps ngvs ps ts++--ambiguities :: (Types v p,Types v (f (Type v))) => [v] -> [p] -> f (Type v) -> ([v],([p],[p]))++-- Partition predicates into ambiguous and unambiguous predicates:+ambiguities fdeps ngvs ps ts = (avs,partition (any (`elem` avs).tv) ps)+  where+    avs = tv (tmap ambigvs ts) -- ambiguous variables+    pvs = tv ps -- restricted variables++    ambigvs t = tyvarsAsType (pvs\\\known)+         where known=closure fdeps (tv t)++ngvs -- "known" variables+     -- Note: with functional dependencies, variables in pvs that are+     -- determined (by variables in tv t or ngvs), should also be regarded+     -- as "known"++    -- A hack to represent a set of tyvars as a type+    -- (and later get the set back with tv):+    tyvarsAsType = tupleT . map tyvar++resolveAmbiguities' avs ps =+    do let ambigs = [(av,[ p | p<-ps,av `elem` tv p])|av<-avs]+       dss <- getDefaults+       s <- S # mapM (solveAlternatives dss) ambigs+       (ds,r) <- contextReduction (apply s ps)+       unless (null ds) $+         errorContext' "Overloading" [(ppi p,srcLoc d)|d:>:p<-ds] $+         fail "Unresolved"+       return (s,r)+  where+    -- We allow multiple, possibly conflicting, default declarations,+    -- and report an error only if they produce different results.+    solveAlternatives dss ambig =+	errorContext' "Failed to resolve ambiguous overloading:"+		      [(ppi p,srcLoc d)|d:>:p<-snd ambig] $+	do env <- getKEnv+	   checkConflict env =<< mapM (solve1 ambig) dss+      where+	checkConflict env solutions =+	    case nubBy eq solutions of+	      [Just solution] -> return solution+	      [Nothing]       -> fail "Found no suitable default"+	      []              -> if null dss+				 then fail "Hmm. No defaults available?" -- bug!+				 else fail.pp $ "Hmm."<+>dss --serious bug!+	      _               -> fail "Conflicting default declarations"+	  where+	    syn = expandSynonyms env+	    eq = eqBy (fmap (syn.snd))++    solve1 ambig ds = msum # mapM (try1 ambig) ds+      where  +	try1 (v,ps) t =+	  do ds <- contextReduction'' (apply (v+->t) ps)+	     return $ if null ds+		      then Just (v,t)+		      else Nothing+{-+ppDicts dicts = vcat (map msg dicts)+  where+    msg (d:>:p) = sep [ppi p,nest 2 ("from"<+>srcLoc d)]+-}
+ tools/base/TI/TiDefinedNames.hs view
@@ -0,0 +1,69 @@+module TiDefinedNames(+  module TiDefinedNames,DefinedNames(..),MapDefinedNames(..))+where+import DefinedNames hiding (definedType)+import Maybe(mapMaybe,listToMaybe)+import HsIdent+import MUtils(( # ))++-- Defined to minic the instances of the deprecated class DefinedVars...+valueNames = mapMaybe valueName+valueName (n,t) =+  case t of+    Value      -> Just n+    Property   -> Just n+    Assertion  -> Just n+    _          -> Nothing++valuesNames' = mapMaybe valueName'+valueName' (n,t) =+  case t of+    Value       -> Just n+    Property   -> Just n+    Assertion  -> Just n+    ConstrOf {} -> Just n+    FieldOf  {} -> Just n+    MethodOf {} -> Just n+    _           -> Nothing++valueIdent (n,t) =+  case t of+    Value       -> Just (HsVar n)+    Property   -> Just (HsCon n)+    Assertion  -> Just (HsCon n)+    ConstrOf {} -> Just (HsCon n)+    FieldOf  {} -> Just (HsVar n)+    MethodOf {} -> Just (HsVar n)+    _           -> Nothing++typeNames = mapMaybe typeName+typeName (n,t) =+  case t of+    Class {} -> Just n+    Type {} -> Just n+    _       -> Nothing++typeIdent (n,t) =+  case t of+    Class {} -> Just (HsCon n)+    Type {} -> Just (HsCon n)+    _       -> Nothing++definedValueNames x = valueNames . definedNames $ x+definedTypeNames  x = typeNames  . definedNames $ x++definedType x = maybe err id (optDefinedType x)+  where err = error ("definedType "++show x)++optDefinedType x = listToMaybe . definedTypeNames $ x -- hmm++definedTypeName t = tn where HsCon tn = definedType t++optDefinedTypeName t = unCon # optDefinedType t+  where+    unCon (HsCon tn) = tn++definedNamesSplit x = (typeNames ns,valueNames ns)+  where ns = definedNames x++patternVars p = filter isHsVar (definedValueNames p)
+ tools/base/TI/TiDerivedInstances.hs view
@@ -0,0 +1,122 @@+module TiDerivedInstances(derivedInstances) where+import HasBaseStruct+import HsDecl+import TI+import TiSolve(expandSynonyms)+import TiContextReduction(contextReduction'')+import TiInstanceDB(addInstKind)+import TiSCC(sccD)+import SrcLoc1++import Deriving(derive)+import FreeNamesBase()++import Maybe(mapMaybe)+import List(nub,partition)+import MUtils+import PrettyPrint++--import IOExts(trace) -- debugging++-- Figuring out what the derived instances are, without generating the+-- derived code.++derivedInstances ks stdnames modmap env ds =+     reduceInsts .+     map inst0 .+     concatMap (collectByFst.concatMap drv.mapMaybe basestruct) .+     sccD . filter isBaseTypeDec $ ds+  where+    inst0 (cn,is) = [(n,((c t,map c ts),(s,code t)))|(n,(t,ts))<-is]+      where c=app cn+	    s=srcLoc cn+	    code t=derive stdnames cn (definedTypeName t)+    drv d =+	case d of+	  HsNewTypeDecl s ctx t c  cls -> drv' cls t [c]+	  HsDataDecl    s ctx t cs cls -> drv' cls t cs+	  HsTypeDecl    {}             -> []+      where+	drv' cls t cons =+            [(cl,(derivedInstName' modmap cl tn,(t,syn (conArgTypes=<<cons))))+             |cl<-cls]+	  where tn=definedTypeName t++	conArgTypes con =+	  case con of+	    HsConDecl s _ _ c bangts -> map unbang bangts -- !!!+	    HsRecDecl s _ _ c fields -> map (unbang.snd) fields -- !!!++    app c t = hsTyCon c `hsTyApp` t+    syn = tmap (expandSynonyms env)++    isBaseTypeDec = maybe False isTypeDec . basestruct+    isTypeDec d =+	case d of+	  HsNewTypeDecl {} -> True+	  HsDataDecl    {} -> True+	  HsTypeDecl    {} -> True+	  _ -> False++     -- TODO: need fixed point interation for mutually recursive types!!+    reduceInsts [] = return []+    reduceInsts ([i]:is) =+      do i' <- reduce1 i+	 is' <- extendIEnv' [(fst i')] $ reduceInsts is+	 return (i':is')+    reduceInsts (is1:is) =+      do is1' <- mapM declare =<< instContext (instContext0 is1)+	 is' <- extendIEnv' (map fst is1') $ reduceInsts is+	 return (is1'++is')++{- old:+    reduceInsts (is1:is) =+      if all (null.freeTyvars.fst.fst.snd) is1+      then reduceInsts ([[i]|i<-is1]++is)+      else+      fail.pp$+        sep [ppi "Deriving for mutually recursive types with parameters not implemented yet:",+	     nest 4 $ ppiFSeq (map (fst.fst.snd) is1)]+-}+    reduce1 (n,((p,ps),(s,mcode))) =+      do _:>:ps' <- extendIEnv' [(p,(n,[]))] $ simplify s ps+	 --trace (pp (ps$$ps')) $ do+	 declare ((p,(n,ps')),(ps,(s,mcode)))++    declare (i@(p,(n,ps')),(_,(s,mcode))) =+      do methods <- posContext s mcode+	 let d = hsInstDecl s (Just n) ps' p (toDefs methods)+	 return (i,d)++    simplify s ps =+      do ns <- map (flip dictName' (Just s)) # freshlist (length ps)+         unzipTyped # contextReduction'' (zipTyped (ns:>:ps))++   --In progress: fix point iteration for mutually recursive types:+    instContext is =+       do is' <- mapM (instContext1 (map fst is)) is+	  if and (zipWith eqinst is is')+            then return is+	    else instContext is'++    instContext1 is (i@(p,(n,ctx)),j@(ps,(s,c))) =+       do _:>:ctx' <- extendIEnv' is $ simplify s ps+	  return ((p,(n,ctx')),j)++    instContext0 is = [((p,(n,[])),(ps,c))|(n,((p,ps),c))<-is]++    extendIEnv' = extendIEnv . map (addInstKind ks)++    {-++    If there was an Ord instance for predicates, we could just nub and sort+    and compare for equality. Since we only have Eq, it's a bit more clumpsy...+    -}+    eqinst i1 i2 = eqctx (ctx i1) (ctx i2)+      where+        ctx ((_,(_,c)),_) = nub c+	+	eqctx [] ps2 = null ps2+	eqctx (p1:ps1) ps2 =+          case partition (==p1) ps2 of+            ([p2],ps2') -> eqctx ps1 ps2'+	    _ -> False
+ tools/base/TI/TiDinst.hs view
@@ -0,0 +1,78 @@+{-++Some definitions to support type annotations and+the dictionary translation for base language declarations (the D structure).+-}+module TiDinst where+import Maybe(isJust)++import HsDeclStruct+import HsDeclMaps(mapDI)+import HsGuardsStruct(HsRhs(..))+import HasBaseStruct+import SubstituteBaseStruct+import Substitute+import TI hiding (Subst)+import TiDkc(Dinst)+import MUtils(( # ))++instance (Types i e,Types i p,Types i ds)+      => Types i (Dinst i e p ds) where+  tmap f  = mapDI id (tmap f) (tmap f) (tmap f) f (map f) id++instance (HasId i p,HasCoreSyntax i p) => HasAbstr i (Dinst i e p ds) where+  abstract [] d = d+  abstract xs d =+    case d of+      HsFunBind s matches  -> HsFunBind s (abstract xs matches)+      HsPatBind s p rhs ds ->+        case isVar p of+	  Just x -> HsFunBind s [abstract xs (HsMatch s x [] rhs ds)]+	  _ -> error (show s++": Bug in TiD.hs: tried to overload a pattern binding.")+      _ -> d+  --  HsPrimitiveTypeDecl s cntxt nm   ->+  --  HsPrimitiveBind s nm t           ->++instance (HasBaseStruct d (Dinst i e p ds),HasCoreSyntax i p,HasDef ds d,+	  Eq i,FreeNames i e,FreeNames i ds,FreeNames i p,+	  HasId i e,MapExp e ds,Subst i e,+	  AddDeclsType i ds)+         => HasLocalDef i e (Dinst i e p ds) where+  letvar x@(i:>:_) e d =+    case d of+      HsFunBind s matches  -> HsFunBind s (letvar x e matches)+      HsPatBind s p rhs ds ->+	  if in_p || HsVar i `elem` freeVars (rhs,ds)+          then if in_p || not is_id+	       then -- No substitution in patterns yet (for overloaded literals)+                    HsPatBind s p rhs (appendDef (letvarD s x e) ds)+	       else esubst1 var e i d+	  else d+	where+	  in_p = HsVar i `elem` freeVars p+	  is_id = isJust (isId e)+      _ -> d -- !!++instance HasCoreSyntax i p => HasAbstr i (HsMatchI i e p ds) where+  abstract xs (HsMatch s n ps rhs ds) = HsMatch s n (map var xs++ps) rhs ds++instance (HasBaseStruct d (Dinst i e p ds),HasCoreSyntax i p,HasDef ds d,+	  Eq i,FreeNames i e,FreeNames i ds,FreeNames i p,+	  HasId i e,MapExp e ds,Subst i e,+	  AddDeclsType i ds)+          => HasLocalDef i e (HsMatchI i e p ds) where+  letvar x@(i:>:_) e m@(HsMatch s n ps rhs ds) =+      if in_p || HsVar i `elem` freeVars (rhs,ds)+      then if in_p || not is_id+           then m' -- No substitution in patterns yet (for overloaded literals)+           else esubst1 var e i m+      else m+    where+      m' = HsMatch s n ps rhs (appendDef (letvarD s x e) ds)+      in_p = HsVar i `elem` freeVars ps+      is_id = isJust (isId e)++letvarD s (x:>:t) e = addDeclsType ([],[HsVar x:>:mono t]) $+		      oneDef (hsSimpleBind s x e)++hsSimpleBind s x e = hsSimpleBind' s x e noDef+hsSimpleBind' s x e = hsPatBind s (var x) (HsBody e)
+ tools/base/TI/TiDkc.hs view
@@ -0,0 +1,120 @@+-- Kind checking for base langauge declarations (the D structure)+module TiDkc where+import List(nub,(\\))+import Maybe(mapMaybe)++import HsDeclStruct+import HsExpStruct(EI)+import HsDeclMaps(accConDecl,mapFunDeps,seqFunDeps)+import FreeNamesBase() -- instance for HsType+import SrcLoc1(srcLoc)+import TI+import TiKEnv(domain)+import TiT(kcPred,kcStar,kcCheck)+import MUtils+import PrettyPrint(pp)++-- Type checking is restricted to these instances of the D & E structures:+type Dinst i e p ds = DI i e p ds (Type i) [Pred i] (Type i)+type Einst i e p ds = EI i e p ds (Type i) [Pred i]++instance (KindCheck i d ()) => KindCheck i [d] () where+  kc = mapM_ kc++instance (TypeVar i,{-DeclInfo i ds,-}KindCheck i ds ())+      => KindCheck i (Dinst i e p ds) () where+  kc = kiD++kc_ d = kc d -- >> done++{-+kiDs :: (DeclInfo [d],KindCheck [d] ())+        => [Dinst e p [d]] -> KI [Typing QId (Kind,TypeInfo)]+-}+{-+kiD :: (DeclInfo [d],KindCheck [d] ())+       => Dinst e p [d] -> KI (KInfo i)+-}+kiD d =+  posContext' (srcLoc d) "(kind check)" $+  case d of+    HsTypeDecl    s tp t           -> kcType tp t+    HsNewTypeDecl s ctx tp cd drv  -> kcData ctx tp $ kcCD cd+    HsDataDecl    s ctx tp cds drv -> kcData ctx tp $ mapM_ kcCD cds+    HsClassDecl   s c tp fdeps ds  -> kcClass c tp fdeps ds $ kc_ ds+    HsInstDecl    s optn c tp ds   -> kcInst c tp ds+    HsDefaultDecl s t              -> mapM_ kcStar t -- >> return [] -- hmm+    HsTypeSig     s nms c tp       -> kcSig c tp+    HsFunBind     s matches        -> done --return []+    HsPatBind     s p rhs ds       -> done --return []+    HsInfixDecl   s fixity names   -> done --return []++    HsPrimitiveTypeDecl s ctx tp   -> kcData ctx tp done+    HsPrimitiveBind    s nm tp     -> kcSig (tail [tp]) tp++kcInst ctx tp ds =+  do kcLhs kpred ctx tp $ done+     kc ds -- there shouldn't be any explicit type info here to check, but ...++kcType tp t =+  do k <- fresh+     kcLhs k [] tp (kcCheck k t)+kcData ctx tp rhs = kcLhs kstar ctx tp rhs+kcClass ctx tp fdeps ds rhs = kcLhs kpred ctx tp rhs++kcLhs :: TypeVar i => Kind -> [Pred i] -> Type i -> KI i () -> KI i ()+kcLhs k ctx tp rhs =+  do vs <- return [] --kintro (freeTyvars (ctx,tp))+     extendkts vs $ do mapM_ kcPred ctx+                       k' <- kc tp+		       k'=*=k+		       rhs++kcCD cd = accConDecl ((>>).kcStar) ((>>).mapM_ kcPred) cd done++kcSig ctx t =+  do --freevs <- domain # getKEnv+     vs <- return [] --kintro (freeTyvars (ctx,t) \\ freevs)+     extendkts vs $ do mapM_ kcPred ctx+                       kcStar t+     --return []++--------------------------------------------------------------------------------++tiType tp t = [c:>:syn]+  where c   = definedType tp+	syn = Synonym (typeParams tp) t++tiNewtype = tiData' Newtype+tiData = tiData' Data+tiData' d ctx tp = [definedType tp:>:d]++tiClass kenv tinfo ctx tp fdeps0 ds = [c:>:Class ctx kvs fdeps ms]+  where+    kvs = kinded kenv vs+    vs = typeParams tp+    ps = zip vs [0..] -- 0-based parameter positions++    fdeps =+      mapMaybe cleanDep $ -- silently ignore duplicates and trivial deps!!+      fromJust' "TiDkc.hs: undefined type variable in functional dependency" $+      seqFunDeps $+      mapFunDeps (flip lookup ps) $+      fdeps0++concatMap superDeps ctx++    cleanDep (xs0,ys0) = if null ys then Nothing else Just (xs,ys)+      where xs = usort xs0+	    ys = usort ys0 \\ xs++    ms = map (fmap unquant) $ snd (explicitlyTyped kenv tinfo [] ds)+    unquant (Forall avs vs' qt) = Forall avs (vs'\\kvs) qt+    c = definedType tp+    --_:>:k = kinded1 kenv c+ -- Check that method types don't restrict any class variables (vs)!++    superDeps p = maybe [] deps ((Just >#< mapM isVarT)=<<flatConAppT p)+      where+        deps (c,vs) =+          case [fdeps|c':>:Class _ _ fdeps _<-tinfo,c'==c] of+            [fdeps] -> mapBoth (map (vs!!)) fdeps+	    _ -> []
+ tools/base/TI/TiDs.hs view
@@ -0,0 +1,238 @@+-- Type checking sequences of declarations+module TiDs where+import List(nub,(\\),intersect,partition)+import Maybe(mapMaybe,fromMaybe)++import HasBaseStruct(HasBaseStruct(..),GetBaseStruct(..))+import SrcLoc1(SrcLoc,HasSrcLoc(..))+import HsLiteral(HsLiteral)+import HsDeclStruct+import HsPatStruct(PI)+import TI hiding (Subst)+import TiNameMaps+import TiDkc(Dinst,Einst)+import TiSolve+import TiSCC(sccD)+import TiContextReduction(contextReduction,entails)+import TiInstanceDB(instType,addInstKind)+import TiDerivedInstances+import TiFunDeps(checkInstances)+import Substitute+import SubstituteBaseStruct+--import QualNames++import MUtils(( # ))+import PrettyPrint(Printable,pp,vcat)++instance DeclInfo i d => DeclInfo i [d] where+  explicitlyTyped ks kinfo ctx ds = (concat kss,concat tss)+    where (kss,tss) = unzip $ map (explicitlyTyped ks kinfo ctx) ds++---+instance (+ TypeId i,ValueId i,Printable i, Fresh i,HasSrcLoc i,+ TypedId PId i,CheckRecursion i d,+ DeclInfo i d, FreeNames i d, TypeCheckDecl i d ds2,HasSrcLoc d,+ HasCoreSyntax i p,HasCoreSyntax i e,HasDef ds d,+ --HasLit e,HasLit p,+ HasBaseStruct e (Einst i e p ds),HasBaseStruct p (PI i p),+ DefinedNames i d,AccNames i d,+ HasBaseStruct d (Dinst i e p ds), GetBaseStruct d (Dinst i e p ds),+ HasDef ds2 d2,  HasLocalDef i e2 d2,  Types i d2,+ HasAbstr i ds2, HasLocalDef i e2 ds2, Types i ds2, AddDeclsType i ds2,+ HasCoreSyntax i e2,+ MapExp e2 ds2,Subst i e2,HasTypeApp i e2, -- for dicts in mono rec calls+ KindCheck i d ()) => TypeCheckDecls i [d] ds2+  where+    tcTopDecls rewrite ds = decorate # tcDs rewrite True ds+    tcInstDecls mts ds = do ds':>:bs <- tcExplDs mts ds+			    return (addDeclsType ([],bs) ds')++--}++decorate (ds:>:(insts,dt)) = addDeclsType dt ds:>:(insts,dt)++--sccD ds = [ds] -- dummy++-- How to type check a (possibly recursive) group of declarations:+tcDs rewrite r ds0 =+    do -- Recursive type synonyms and suprtclass relations can cause the type+       -- checker to loop, so start by checking...+       checkRecursion ds0+       -- Infer the kinds of all class/type identifers, including+       -- type variables.+       -- (Names are assumed to have been made unique in an earlier pass.)+       ks <- errorContext "Kind inference" $+             kgeneralise $ do kbs <- kintro (allTypeNames ds0)+			      let kbs' = map (fmap (flip (,) undefined)) kbs+                              extendkts kbs' (kc ds0>>return kbs)+       -- Find additional info about classes and types+       -- and the types of all explicitly typed value identifiers...+       let (kinfo,expls) = explicitlyTyped ks (map (fmap snd) kinfo) [] ds0+	   vkinfo = [v:>:(k,Tyvar)|v@(HsVar _):>:k<-ks]+       expl <- mapM checkTypeSigClash (collectTyped expls)+       -- ...and add them to the environment (if in a recursive group).+       extendkts (kinfo++vkinfo) $ opt r (extendts expl) $+	do -- Extend the instance database with the declared instances+           (insts,ds) <- getInstances ks ds0+	   checkInstances insts+	   extendIEnv insts $+	    do -- Infer the types of the implicitly typed declarations,+	       -- one strongly connected component (scc) at a time...+	       let (dsImpl,dsExpl) = partition (isImplicit ns) ds+		   dsccs = sccD dsImpl+		   ns:>:_=unzipTyped expl+	       ds1:>:bs1 <- tcImplBGs r expl dsccs+	       -- ...and add them to the environment (if in a recursive group)+	       opt r (extendts bs1) $+		do -- Infer the types of the explicitly typed declarations+		   -- and check that they agree with their explicit types+		   ds2:>:bs2 <- tcExplDs expl dsExpl+		   let env = (kinfo,its++filter noDup bs0++expl)+		       its=map instType insts+		       bs0 = bs1++bs2+		       noDup (x:>:_) = x `notElem` ns+		   -- Finally, return the translated declarations, the+		   -- instances, and the resulting environment+		   ((ds1 `appendDef` ds2)>:(insts,env))+  where	+    getInstances ks ds =+        do modmap <- getModule+           kenv <- getKEnv+           let insts1 = map (addInstKind ks) (instDecls ds modmap kenv)+	   extendIEnv insts1 $+	    do stdnames <- getStdNames+	       (insts2,ds2) <- unzip # derivedInstances ks stdnames modmap kenv ds+	       let insts = insts1++map (addInstKind ks) insts2+	       return (insts,ds++rewrite ds2)++    instDecls ds modmap env =+         [instDecl s optn ctx tp|HsInstDecl s optn ctx tp _<-mapMaybe basestruct ds]+       where+        instDecl s optn ctx tp = (syn tp,(n,map syn ctx))+	  where n = fromMaybe (instName' modmap s tp) optn+        syn = expandSynonyms env++    isImplicit ns d = any (`notElem` ns) (definedValueNames d)++-- Type check a sequence of implicitly typed binding groups:+tcImplBGs r expl [] = noDef>:[]+tcImplBGs r expl (ds:dss) =+  do ds1:>:bs1 <- tcImplBG r expl ds+     ds2:>:bs2 <- extendts bs1 $ tcImplBGs r expl dss+     ds1 `appendDef` ds2>:bs1++bs2++tcImplBG r expl ds =+    checkExplicit r (srcLoc ds) expl =<< tcBG expl r False ds++-- Type check declarations with explicit type signatures+-- pre: the explicitly given types have already been added to the environment+tcExplDs expl ds =conc . unzipTyped # mapM (tcExplD expl) ds+  where conc (dss:>:bss) = concatDefs dss:>:concat bss++tcExplD expl d =+  checkExplicit False (srcLoc d) expl =<< tcBG expl False True [d]++-- Typecheck one (mutually recursive) binding group:+tcBG all_ebs r isExpl ds =+  addErrorContext $+  do (dns,ds'):>:bs' <-+       generalise' keepambig unr mapTs $+       do bs1 <- tintro (values\\ens)+	  bs2 <- tintro ens+	  let bs=bs1++bs2+	      lbs = (map.fmap) mono bs1+	  (:>:bs) # opt r (extendts lbs) (mapM (tcDecl bs) ds)+     (dns,concatDefs ds')>:bs'+  where+    ens=values `intersect` all_ens where all_ens:>:_=unzipTyped all_ebs+    (types,values) = definedNamesSplit ds+    unr = all (isUnrestricted isExpl) ds+    keepambig = all keepAmbigTypes ds++    mapTs = map . fmap+      --where mapTM f (x:>:t) = (x:>:) # f t+    --typed = uncurry (:>:)++    addErrorContext =+      if null types && null values+      then posContext' (srcLoc ds) "in declaration"+      else posContext (srcLoc ds) .+           declContext (types++values)+           {-errorContext (render+	    (sep [(if unr then "In an un" else "In a ")+		   <>"restricted definition of",+		  nest 4 (fsep types $$ fsep values)]))-}++opt b f = if b then f else id++checkExplicit r loc explicit ((dns,d):>:inferred) =+    posContext' loc "type signature vs inferred type" $+    do let xs:>:_ = unzipTyped inferred+	   ixs = xs \\ exs+           (exs,eqscs) =+	       unzip [ (x,(it,et)) |x:>:it<-inferred,y:>:et<-explicit,y==x]+           pick x = if x `elem` exs+		    then head [ t |t@(y:>:_)<-explicit,x==y]+		    else head [ t |t@(y:>:_)<-inferred,x==y]+           -- abstract' adjusts monomorphic rcurive calls:+	   abstract' ixs dns d =+	       if r+	       then abstract dns (esubst addDicts d)+	       else abstract dns d+	     where+	       addDicts x = if HsVar x `elem` ixs+			    then foldl1 app (x':map var dns)+			    else if HsVar x `elem` exs+			         then x' +				 else var x -- Grr!! Type info is lost+		 where+		   x' = spec (HsVar x) sc (map tyvar (tdom gs))+		   _:>:sc@(Forall ags gs qt) = pick (HsVar x)+       if null eqscs then abstract' ixs dns d>:map pick xs+	 else do (ids,eds,eqts) <- freshInsts dns eqscs+		 s0 <- matchEqns eqts =<< getKEnv+		 let ids' = apply s0 ids+		 id {-errorContext (eds,ids',apply s0 eqts)-} $ do+		  -- Although the context ids should already be reduced,+		  -- the instance ids' may still not be in normal form,+		  -- so we have to apply context reduction again.+		  (ids'',r1,s1) <- do reduceAndImprove ids'+		  (is,r2) <-+                    do env <- getKEnv+		       let eds' = (map.fmap) (expandSynonyms env) (apply s1 eds)+		       (eds' `entails` ids'') env+		  let edns:>:_ = unzipTyped eds+		      r = r2 . r1+		      s@(S su) = is `compS` s1 `compS` s0+		  ngvs <- tv # getTEnv+		  mapM_ constrain [tyvar v:=:t|(v,t)<-su,v `elem` ngvs]+		  abstract' ixs edns (r (apply s d))>:apply s (map pick xs)+  where+    freshInsts dns eqscs =+       do ((ctx,eds):_,eqts) <- unzip # mapM freshInst' eqscs+	  return (zipTyped (dns:>:ctx),eds,eqts)++    freshInst' (isc,esc) =+       do -- Don't freshen the inferred type, the quantified tvars can appear in the body:+          --(ids,it) <- freshInst isc+          --let _:>:ctx = unzipTyped ids+          let Forall _ _ (ictx:=>it) = isc+	      Forall _ _ (ectx:=>et) = esc+          --(eds,et) <- freshInst esc+          ds <- map dictName # freshlist (length ectx)+	  let eds = zipTyped (ds:>:ectx)+          return ((ictx,eds),(it,et))++{-++We allow more than one type signature for the same identifier, but we+check that they are syntactically equal. In Haskell 98, its invalid to give+more then one type signature for the same identifier, even if they are+identical (H98 report, section 4.4.1).+-}+checkTypeSigClash (x:>:ts0) =+    case nub ts0 of -- Equality of type schemes. Hmm...+      [t] -> x>:t+      ts -> declContext [x] $+              errorContext "Conflicting type signatures" $+                fail $ pp (vcat ts)
+ tools/base/TI/TiE.hs view
@@ -0,0 +1,169 @@+-- Refactored type inference for the E structure.+-- Returns types and translated expressions.+module TiE where+import HasBaseStruct+import BaseSyntaxStruct+import SrcLoc1+import TI+import TiLit(tcLit)+import TiFields+import TiRhs+--import TiPrelude+import MUtils+import Monad(join)--,liftM2++instance HasId i (EI i e p ds t c) where+  ident = HsId+  isId (HsId x) = Just x+  isId _ = Nothing++instance (HasBaseStruct e (EI i e p ds t c),HasId i p) => HasAbstr i (EI i e p ds t c) where+  abstract xs e = HsLambda (map var xs) (base e)++{-++When inferring the type of an expression, we return a type and a transformed+expression, which can be of any (extended) expression type, hence the+requirement HasCoreSyntax e, HasBaseStruct e ... and the result type Typed e.+-}+{-+-- Copied from the type inferred for tcE by GHC:+instance (Fresh i,TypeId i,ValueId i,+	  HasSrcLoc i, -- for error reporting+	  HasBaseStruct rec (EI i e x r t1 c1),+	  HasTypeAnnot i e,HasTypeAnnot i x,+	  TypeCheck i p1 (Typed i x),+	  TypeCheck i e1 (Typed i e),+	  TypeCheckDecls i ds r,+	  HasBaseStruct e1 (EI i e1 p1 ds t2 c2), HasId i p1, HasAbstr i e1,+	  HasBaseStruct p1 (PI i p), HasCoreSyntax i e1, HasTypeApp i rec,+	  HasLit rec,HasTypeAnnot i rec,+	  DefinedNames i p1, TypeCheck i e1 (Typed i rec),+	  HasBaseStruct d1 (DI i e1 p2 ds1 t c tp),+	  HasId i p2, HasDef ds1 d, HasDef ds d1)+ => TypeCheck i (EI i e1 p1 ds t c) (Typed i rec)+  where tc = tcE+-}+tcE e =+  case e of+    HsId n                 -> inst_loc n+    HsLit s l              -> tcLit (hsLit s) s l+    HsInfixApp x op z      -> inst_loc op `tapp` tc x `tapp` tc z+    HsApp x y              -> tc x `tapp` tc y+    HsNegApp s x           -> instPrel_srcloc s "negate" `tapp` tc x+    HsLambda ps e          -> tcLambda ps e+    HsLet ds e             -> tcLet ds (tc e)+    HsIf x y z             -> join $ tcIf # tc x <# tc y <# tc z+    HsCase e alts          -> tcCase e alts+    HsDo stmts             -> tcStmts stmts+    HsTuple es             -> typedTuple =<< mapM tc es+    HsList es              -> tcList =<< mapM tc es+    HsParen e              -> emap hsParen # tc e+    HsLeftSection x op     -> inst_loc op `tapp` tc x+    HsRightSection op y    -> instPrel "flip" `tapp` inst_loc op `tapp` tc y+    HsRecConstr s c fields -> tcFieldsCon s c fields+    HsRecUpdate s e upds   -> tcFieldsUpd s (tc e) upds+    HsEnumFrom x           -> instPrel "enumFrom" `tapp` tc x+    HsEnumFromTo x y       -> instPrel "enumFromTo" `tapp` tc x `tapp` tc y+    HsEnumFromThen x y     -> instPrel "enumFromThen" `tapp` tc x `tapp` tc y+    HsEnumFromThenTo x y z ->+      instPrel "enumFromThenTo" `tapp` tc x `tapp` tc y `tapp` tc z+    HsListComp stmts       -> emap hsListComp # tcLComp stmts+    HsExpTypeSig s e c t    -> tcExpTypeSig s e c t+    _ -> fail "Bug: not implemented yet"++tcLambda ps e =+  do (ps',e'):>:(tps,t') <- tcLambda' ps e+     let tps' = zipWith typeAnnot ps' tps+     hsLambda tps' (typeAnnot e' t') >: foldr hsTyFun t' tps++tcLambda' ps e =+  do bs <- schintro (patternVars ps)+     extendts bs $ do ps':>:tps <- unzipTyped # mapM tc ps+                      e':>:t'   <- tc e+                      (ps', e') >: (tps,t')++tcDsLambda' ps ds e =+  do bs <- schintro (patternVars ps)+     extendts bs $ do ps':>:tps <- unzipTyped # mapM tc ps+                      ds':>:dbs <- tcLocalDecls ds+                      e':>:t'   <- extendts dbs (tc e)+		      --let ds'' = addDeclsType ([],bs) ds'+                      (ps', ds', e') >: foldr hsTyFun t' tps++tcLet ds tce =+  do ds':>: bs <- tcLocalDecls ds+     e' :>: t' <- extendts bs tce+     hsLet ds' e' >: t'++tcExpTypeSig s e c t =+ do v <- fresh+    tc (hsLet (hsTypeSig s [v] c t `consDef`+	       (hsPatBind s (var v) (HsBody e) noDef `consDef` noDef))+	      (var v)  `asTypeOf` e)+    +--tcIf :: HasBaseStruct e (E e p ds t c) => Typed e -> Typed e -> Typed e -> TI (Typed e)+tcIf (cnd:>:tcnd) (thn:>:tthn) (els:>:tels) =+  do tBool <- getBoolType+     tcnd=:=tBool+     tthn=:=tels+     hsIf cnd thn els >:: tthn++tcCase e alts =+  do e':>:te <- tc e+     alts':>:ats <- unzipTyped # mapM tcAlt alts+     let (tps,tes) = unzip ats+     mapM_ (te=:=) tps+     t <- allSame tes+     hsCase e' alts' >:: t++e >:: t = typeAnnot e t >: t++tcAlt (HsAlt s p rhs ds) = +  do bs <- schintro (patternVars p)+     extendts bs $ do p':>:tp <- tc p+	              ds':>:dbs <- tcLocalDecls ds+	              rhs':>:trhs <- extendts dbs (tc rhs)+		      --let ds'' = addDeclsType ([],bs) ds'+                      HsAlt s p' rhs' ds'>:(tp,trhs)+     +tcStmts stmts =+  do bind <- ident # prelValue ">>="+     thn <- ident # prelValue ">>"+     fail <- ident # prelValue "fail"+     let desugar stmt =+	   case stmt of+	     HsGenerator _ p e stmt -> app (bind `app` e) # match p stmt+	     HsQualifier   e stmt -> app (thn `app` e) # desugar stmt+	     HsLetStmt    ds stmt -> hsLet ds # desugar stmt+	     HsLast        e      -> return e+	 match p stmt =+	   do stmt' <- desugar stmt+	      case isVar p of+		Just v -> return $ abstract [v] stmt'+		_ -> do v <- fresh+			return (abstract [v] $+				 hsCase (var v) [p -+> stmt',+						 hsPWildCard -+> hsFailInDo])+	 hsFailInDo =+           fail `app` hsLit loc0 (HsString "pattern match failure in do")+	 p -+> e = HsAlt loc0 p (HsBody e) noDef+     tc =<< desugar stmts++tcLComp lc =+  case lc of+    HsGenerator s p e lc -> do e':>:et <- tc e+			       bs <- schintro (patternVars p)+			       let ext = extendts bs+			       p':>:pt <- ext (tc p)+			       listType <- getListType+			       et=:=listType pt+			       emap (HsGenerator s p' e') # ext (tcLComp lc)+    HsQualifier e   lc -> do e':>:t <- tc e+			     tBool <- getBoolType+			     t=:=tBool+			     emap (HsQualifier e') # tcLComp lc+    HsLetStmt    ds lc -> do ds':>: bs <- tcLocalDecls ds+			     emap (HsLetStmt ds') # extendts bs (tcLComp lc)+    HsLast      e      -> do e':>:t <- tc e+			     listType <- getListType+		             HsLast e' >: listType t
+ tools/base/TI/TiEnv.hs view
@@ -0,0 +1,19 @@+-- Environemnts (symbol tables)+module TiEnv(Env,extenv1,extenv,empty,lookup,domain,range) where+import Prelude hiding (lookup) -- for Hugs+import qualified Prelude -- Haskell report change workaround++-- Simplest possible implementation...+newtype Env key info = Env [(key,info)] deriving (Show)+-- I've tried using a FiniteMap instead, but it is slower! /TH 2002-12-05++extenv1 x t (Env bs) = Env ((x,t):bs)+extenv bs1 (Env bs2) = Env (bs1++bs2)+empty = Env []++lookup (Env env) x = Prelude.lookup x env+domain (Env env) = map fst env+range (Env env) = map snd env++instance Functor (Env key) where+  fmap f (Env bs) = Env [(k,f i)|(k,i)<-bs]
+ tools/base/TI/TiEnvFM.hs view
@@ -0,0 +1,46 @@+{-++This module implements environments (symbol tables) as finite maps.+Finite maps are not necessarily faster than simple association lists, since+although lookups change from O(n) to O(log n), extension changes from+O(1) to O(log n), and the latter cost can be the dominating cost...+-}+module TiEnvFM(Env,extenv1,extenv,empty,lookup,domain,range) where+import Prelude hiding (lookup) -- for Hugs+import qualified Prelude -- Haskell report change workaround++import Map60204+--import PrettyPrint(Printable(..),fsep) -- for debugging++#if __GLASGOW_HASKELL__ >= 604 +import qualified Data.Map as M (Map)+newtype Env key info = Env (M.Map key info)+#else+import qualified Data.FiniteMap as M (FiniteMap)+newtype Env key info = Env (M.FiniteMap key info)+#endif  ++extenv1 x t (Env bs) = Env (insertM x t bs)+extenv bs1 (Env bs2) = Env (addListToM bs2 bs1)+empty = Env emptyM++lookup (Env env) x = lookupM x env+domain (Env env) = keysM env+range (Env env) = elemsM env+++-- Why isn't there a Show instance for FiniteMap?!+instance (Show key,Show info) => Show (Env key info) where+  showsPrec n (Env env) = showsPrec n (toListM env)++-- Why isn't there a Functor instance for FiniteMap?!+instance Functor (Env key) where+  fmap f (Env bs) = Env (mapM' f bs)++++{-+-- For debugging:+instance (Printable key,Printable info) => Printable (Env key info) where+  ppi (Env env) = fsep (keysFM env)+-}+
+ tools/base/TI/TiError.hs view
@@ -0,0 +1,30 @@+module TiError where+import PrettyPrint(Doc,Printable(..),($$),(<>),(<+>),ppiFSeq,vcat,nest,sep,modn)+import SrcLoc1+import SrcLocPretty+import HsName(ModuleName)++data Error i+  = InContext (ErrorContext i) (Error i)+  | Other Doc+  deriving Show++data ErrorContext i+  = AtPos SrcLoc (Maybe Doc)+  | DeclCtx [i]+  | ModuleCtx [ModuleName]+  | OtherCtx Doc [(Doc,SrcLoc)]+  deriving Show++instance Printable i => Printable (Error i) where+  ppi (InContext ctx e) = ctx<>":" $$ nest 2 e+  ppi (Other msg) = msg++instance Printable i => Printable (ErrorContext i) where+  ppi (AtPos loc Nothing) = ppi loc+  ppi (AtPos loc (Just msg)) = ppi loc<>":"<+>msg+  ppi (DeclCtx is) = "In the declaration of"<+>ppiFSeq is+  ppi (ModuleCtx [m]) = "In module"<+>modn m+  ppi (ModuleCtx ms) = "In modules"<+>ppiFSeq (map modn ms)+  ppi (OtherCtx msg locs) = sep [ppi msg,nest 4 (vcat (map ploc locs))]+    where ploc (d,loc) = sep [ppi d,nest 2 ("from"<+>loc)]
+ tools/base/TI/TiFields.hs view
@@ -0,0 +1,47 @@+module TiFields where+import HasBaseStruct+import BaseSyntaxStruct+import HsFieldsStruct+import TI+import MUtils+--import SpecialNames -- debug++instance (--IsSpecialName i, -- debug+	  ValueId i,TypeVar i,Fresh i,TypeCheck i e (Typed i e2))+      => TypeCheck i (HsFieldsI i e) (Typed i (HsFieldsI i e2)) where+  tc fs=+    do fs:>:ts <- unzipTyped # mapM tc fs+       t <- allSame ts+       fs>:t++instance (--IsSpecialName i, -- debug+          ValueId i,TypeVar i,Fresh i, TypeCheck i e (Typed i e2))+      => TypeCheck i (HsFieldI i e) (Typed i (HsFieldI i e2)) where+  tc=tcHsField++tcHsField (HsField f e) =+  do ft <- inst_field (HsVar f)+     e':>:et <- tc e+     r <- tfresh+     hsTyFun r et =:= ft+     HsField f e'>:r++tcFieldsPat c = tcFieldsCon' hsPRec c+tcFieldsCon s c = tcFieldsCon' (hsRecConstr s) c++tcFieldsCon' appf c = tcFields appf bM+  where+    bM = do tcon <- inst_field (HsCon c)+	    c>:resultType tcon+    resultType (Typ t) =+      case t of+        HsTyFun _ t -> resultType t+	_ -> Typ t++tcFieldsUpd s bM = tcFields (hsRecUpdate s) bM++tcFields c bM fields =+  do b:>:bt <- bM+     fs:>:ft <- tc fields+     bt=:=ft+     c b fs>:bt
+ tools/base/TI/TiFreeNames.hs view
@@ -0,0 +1,19 @@+module TiFreeNames(module TiFreeNames,FreeNames(..)) where+import FreeNames+import HsIdent+import Maybe(mapMaybe)++freeTypeNames x = mapMaybe freeTypeName . freeNames $ x+freeValueNames x = mapMaybe freeValueName . freeNames $ x++freeVars x = filter isHsVar . freeValueNames $ x+freeTyvars x = filter isHsVar . freeTypeNames $ x++freeTypeName (n,ClassOrTypeNames) = Just n+freeTypeName (n,_) = Nothing++freeValueName (n,ValueNames) = Just n+freeValueName (n,_) = Nothing++-- Get the type parameters from the lhs of a type/newtype/data/class decl:+typeParams tp = [v|HsVar v<-freeTyvars tp] -- Hmm. Order?
+ tools/base/TI/TiFresh.hs view
@@ -0,0 +1,44 @@+module TiFresh where+import TiMonad(IM,freshInt)+import TiTypes+import MUtils+import TiKinds++class Fresh a where+  fresh :: IM i c a++freshlist n = sequence (replicate n fresh)++instance Fresh Int where+  fresh = freshInt++instance Fresh String where+  fresh = (show::Int->String) # fresh++--instance Fresh Tyvar where+--  fresh = tvar # fresh++instance (Fresh a,Fresh b) => Fresh (a,b) where+  fresh = (,) # fresh <# fresh++instance Fresh i => Fresh (Type i) where+  fresh = tyvar # fresh++instance Fresh i => Fresh (Scheme i) where+  fresh = forall' [] # fresh++instance Fresh t => Fresh (Qual i t) where+  fresh = ([]:=>) # fresh++--instance Fresh QId where+--  fresh = dictName # fresh++instance Fresh KVar where+  fresh = KVar # fresh++instance Fresh Kind where+  fresh = Kvar # fresh++instance Fresh (TypeInfo i) where+  fresh = return Tyvar+
+ tools/base/TI/TiFunDeps.hs view
@@ -0,0 +1,178 @@+{-++Functions to support the implementation of functional dependencies, as described+by Mark P. Jones in "Type Classes with Functional Dependencies",+http://www.cse.ogi.edu/~mpj/pubs/fundeps.html+-}+module TiFunDeps where+import TiTypes+import HsTypeStruct+--import TiFreeNames(freeTyvars)+import TiInstanceDB(classInstances,InstEntry(..))+import TiMonad+import TiUtil(freshen)+import Unification(unify,match,subst)+import TiSolve(expandSynonyms)++import PrettyPrint+import MUtils(( # ),( #. ),(@@),collectByFst,done,usort,concatMapM,mapBoth)+import Monad(unless)+import Maybe(mapMaybe)+import List((\\),nub)++--import Debug.Trace(trace)+----mtrace s = trace s $ done+trace x y = y++{-++Functions to ensure that declared instances are consisent with the functional+dependencies. See section 6.1 of the paper++We have relaxed the first condition in 6.1 to take the dependencies+implied by the predicates to the left of the arrow into account, to allow +instances like C a b => C [a] [b], where F_C = 1->2.+-}++checkInstances insts0 =+  do insts <- mapM flatInst insts0+     mapM_ checkInstanceConsistency insts+     mapM_ checkPairwiseConsistency (collectByFst insts)++-- Check that instances are pairwise consistent+checkPairwiseConsistency (cl@(HsCon c),heads) =+  do (fdeps,_) <- getDeps cl+     iheads <- instanceHeads c+     unless (null fdeps) $ mapM_ (checkDeps fdeps) (pairwise heads iheads)+  where+    checkDeps fdeps p = mapM_ (checkDep p) fdeps++    checkDep ((head1,_),(head2,_)) (dxs,rxs) = maybe done compare (unify domain)+      where+        ps = zip head1 head2+        domain = map (ps!!) dxs+        range = map (ps!!) rxs++        compare s = unless (all equal range) inconsistent+          where equal (t1,t2) = subst s t1==subst s t2++	inconsistent = +          fail $ pp $ "Instances are not pairwise consistent w.r.t. functional dependencies:" $$+                      nest 4 (vcat [appc cl head1,appc cl head2])++-- Check that an instance is consistent with the functional dependencies:+checkInstanceConsistency (cl,(ts,ps)) =+  do (fdeps,arity) <- getDeps cl+     unless (length ts==arity) $ badInstanceHead p+     pdeps <- predDeps ps+     unless (checkDeps ts pdeps fdeps) $+       fail $ pp $ sep [ppi "Instance is more general than dependencies allow:",ppi p]+  where+    p = appc cl ts+    checkDeps ts pdeps fdeps = all (checkDep ts pdeps) fdeps++    checkDep ts pdeps (dxs,rxs) = range `isSubsetOf` closure pdeps domain+      where+	 domain = vars dxs+	 range = vars rxs+	 vars ix = tv [ts!!i|i<-ix]++-- These errors shouldn't happen for instances that are free from kind errors+badInstanceHead hd = fail $ pp $ "Malformed instance head:"<+>hd++{-+ Iterated improvement: -}+improvements ps =+  do is <- improvement ps+     if apply is ps==ps+	then return is+	else (`compS` is) # improvements (nub (apply is ps))++{-+ Compute an improving subsitution using functional dependencies+    (section 6.2): -}++improvement ps =+    S . tr #. unify @@ expand @@+    concatMapM improve . collectByFst . mapMaybe flatPred $ ps+  where+    expand eqns =+       do kenv <- getKEnv+	  return $ mapBoth (expandSynonyms kenv) eqns++    tr [] = []+    tr s = trace ("Improving subst="++pp s) s++    improve (cl@(HsCon c),heads) =+      do (fdeps,_) <- getDeps cl+         iheads <- map fst # instanceHeads c+	 let imps = concatMap (improveAll cl heads iheads) fdeps+	 concatMapM freshimp imps++    freshimp ([],eqns) = return eqns -- optimization+    freshimp (gs,eqns) = freshen gs eqns++    improveAll cl heads iheads (dxs,rxs) =+        map improvePair (pairs1 heads) ++ map improveInst (pairs2 iheads heads)+      where+	improvePair (head1,head2) =+	  if ds1==ds2+	  then trace ("Improving pair "++show (dxs,rxs)++" "++ppp (head1,head2)) $+               ([],[(head1!!rx,head2!!rx)|rx<-rxs])+	  else ([],[])+          where (ds1,ds2) = ([head1!!dx|dx<-dxs],[head2!!dx|dx<-dxs])++        improveInst (ihead,head) =+            maybe ([],[]) improve1 $ match [(ihead!!dx,head!!dx)|dx<-dxs]+          where+	    improve1 s =+                trace ("Improving inst "++show (dxs,rxs)++ppp (ihead,head)) $+                (tv eqns \\ tv head,eqns)+              where eqns = [(subst s (ihead!!rx),head!!rx)|rx<-rxs]+        ppp (h1,h2) = pp (appc cl h1,appc cl h2)++{-+ Computing the closure w.r.t functional dependencies+    (section 5.2 of the paper).+-}+closure fdeps = fix step . usort+  where+     step xs = usort (xs++[r|(ds,rs)<-fdeps,ds `isSubsetOf` xs,r<-rs])+     fix f = stop . iterate f+     stop (x1:x2:xs) = if x1==x2 then x1 else stop (x2:xs)++{-+ Computing the functional dependencies applied by a set of predicates+    (section 6.3)+-}+predDeps ps = concatMapM pred1Deps (mapMaybe flatPred ps)+pred1Deps (cl,ts) = +  do (fdeps,_) <- getDeps cl+     let vars ix = tv [ts!!i|i<-ix]+     return [(dvs,rvs)|(dxs,rxs)<-fdeps,+	               let dvs = vars dxs+	                   rvs = vars rxs,+	               not (null rvs)]++{-+ Looking up the functional dependencies (and the arity) for a class: -}+getDeps cl =+  do (k,Class _ ps fdeps _) <- env kenv cl+     return (fdeps,length ps)++{-+ Looking up all the instances of a given class: -}+instanceHeads c = map snd # (mapM flatInst . flip classInstances c =<< getIEnv)++{-++Auxiliary functions+-}++xs `isSubsetOf` ys = (`elem` ys) `all` xs++pairwise hs hs' = pairs1 hs++pairs2 hs hs'++pairs1 []     = []+pairs1 (x:xs) = [(x,x')|x'<-xs]++pairs1 xs++pairs2 xs ys = [(x,y)|x<-xs,y<-ys]++flatInst (hd,IE _ _ ps) =+  do (cl,hd') <- flatPred hd+     return (cl,(hd',ps))++flatPred ty = maybe (badInstanceHead ty) return (flatConAppT ty)++appc cl ts = appT (ty cl:ts)
+ tools/base/TI/TiGeneralize.hs view
@@ -0,0 +1,135 @@+{-++This module defines type checking functions for generalizing inferred types+and applying context reduction (#generalise'#).+-}+module TiGeneralize where+import TiMonad+import TiTypes+import TiUtil+import TiSolve(solve,TypeConstraint(..))+import Unification(isVar)+import TiNames(ValueId,TypeVar,dictName,dictName')+import TiClasses hiding (isVar)+import TiKinds+--import TiPrelude+import TiContextReduction+import TiDefault+import TiFunDeps(predDeps,closure,improvement)+import TiFresh+import HasBaseStruct+import HsConstants(mod_Prelude,tuple)+import BaseSyntax(srcLoc,TI(..))+import TypedIds(NameSpace(..))+import PrettyPrint hiding (var)+import List((\\),partition,nub)--,intersect+import MUtils++--import Debug.Trace(trace) -- debug++{-++If there were polymorphic kinds, #kgeneralise# would produce kind schemes,+but currently it just instantiates any remaining kind variables after kind+inference to *, in accordance with the Haskell 98 report, section 4.6.+-}+kgeneralise m =+  do (kbs,s) <- getKSubst m+     return $ (map.fmap) (fixkvars . ksubst s) kbs++{-++As #kgeneralise#, but treat Pred as equal to *. Useful for kind checking+after the dictionary translation.+-}+kgeneraliseSloppy m =+  do (kbs,s) <- getKSubstSloppy m+     return $ (map.fmap) (apFst (fixkvars . ksubst s)) kbs++--generalise1 u = generalise' u id+--generalise u = generalise' u fmap++{-++At the moment, #checkKinds# only keeps track of the kinds of type variables+that remain after type inference. It could be improved to also check+that all subsitutions performed were kind preserving.+-}+checkKinds kpreds = return (tyvars kpreds)+  where+    --tyvars :: Unifiable i => [Kinded (Type i)] -> [Kinded i]+    tyvars kpreds = nub [v:>:k|t:>:k<-kpreds,Just v<-[isVar t]] -- hmm+{-+catchAmbiguity dicts =+    if null dicts+    then done+    else fail $ pp ("Unresolved overloading: "<+>ppDicts dicts)+-}++{-+ Iterate context reduction and improvement until nothing changes -}+reduceAndImprove dicts0 = +  do (dicts1,r1)  <- contextReduction dicts0+     subst1@(S s) <- errorContext "Applying functional dependencies" $+                     improvement [ p | d:>:p<-dicts1]+     if null s+	then return (dicts1,r1,subst1)+	else do --trace (pp $ "Improvement:"<+>vcat [ppi s,"of"<+>ppi dicts1]) $ done+                (dicts2,r2,subst2) <- reduceAndImprove (apply subst1 dicts1)+		return (dicts2,r2 . r1,compS subst2 subst1)+++{-+ Generalize inferred types: -}+generalise' keepambig unrestricted fmap' m =+  do env <- getTEnv+     (x:>:t0,res@(dicts0,kpreds0,subst0)) <- getSubst m+     --trace (pp (t0,res)) $ return ()+     ((dicts,r,subst1),([],kpreds1,S [])) <- getSubst $ reduceAndImprove dicts0+     let subst@(S s) = compS subst1 subst0+     kpreds <- checkKinds (kpreds1++[apply subst1 t:>:k|t:>:k<-kpreds0])+     --trace (pp kpreds) $ return ()+     mono <- monomorphism # getEnv -- The monomorphism restriction is optional!+     fdeps <- predDeps [ p | d:>:p<-dicts]+     let t = apply subst t0+	 ngvs0 = tv env -- could probably be made more efficient...+         s' = [s1|s1@(v,_)<-s,v `elem` ngvs0]+         -- Non-generic variables by the usual Hindley-Milner rules:+	 hmngvs0 = ngvs0++tv (map snd s')+         -- Non-generic vars when taking functional dependencies into account:+	 hmngvs = closure fdeps hmngvs0+	 -- (deferred,retained) predicates:+         (ngdicts,gdicts0) = if not mono || unrestricted+			     then partition ng dicts+			     else (dicts,[]) -- monomorphism restriction applies+	   where ng = all (`elem` hmngvs) . tv+	 mrngvs = tv ngdicts+	 ngvs = hmngvs++  -- the usual Hindley-Milner restriction+                mrngvs    -- from the monomorphism restriction+         (ngkpreds,gkpreds0) = partition ng kpreds+	   where ng (v:>:k) = v `elem` ngvs -- mrngvs is not enough!+	 --(avs,(ambigdicts,gdicts)) = ambiguities ngvs gdicts0 t+     --catchAmbiguity ambigdicts; let subst' = idS; r' = id+     (gdicts,(subst',r')) <-+       let known = (if keepambig then tdom gkpreds0 else [])++{-hm-}ngvs+       in resolveAmbiguities fdeps known gdicts0 t+     gkpreds <- checkKinds [varSubst subst' v:>:k|v:>:k<-gkpreds0]+     let ds:>:ctx = unzipTyped gdicts+         gvs = tdom gkpreds+	 ks = map (emap HsVar) gkpreds+	 gen t = Forall ags (kinded ks gs) qt+	   where ags = filter (\ (v:>:_)->v `notElem` gs) gkpreds+		 qt = ctx:=>t+		 gs = tv qt \\ ngvs -- normal type scheme+		 --gs = gvs \\ ngvs -- keep "ambiguous" type variables+         sc = fmap' gen t+     mapM_ constrain [tyvar v:=:t|(v,t)<-s'] -- deferred equality constraints+     mapM_ addinst ngdicts -- deferred predicates+     --trace (pp $ "ngkpreds:"<+>ngkpreds) $ return ()+     mapM_ addkinst [tyvar v:>:k|v:>:k<-ngkpreds] -- what to propagate?+     --abstract ds (r (apply subst x))>:fmap' gen t+     (ds,r' $ apply subst' $ r $ apply subst x)>:sc+++getSubst m = do env <- getKEnv ; getSubst' (solve env) m+getKSubst = getSubst' ksolve+getKSubstSloppy = getSubst' ksolveSloppy++getSubst' solve m =+  do (ans,cs) <- getConstraints m+     subst <- solve cs+     return (ans,subst)
+ tools/base/TI/TiHsName.hs view
@@ -0,0 +1,40 @@+module TiHsName where+import HsName+import HsConstants()+import SrcLoc1+import SpecialNames+import TiNames+import TiFresh+import MUtils++instance ValueId HsName where+  topName s m n ty = UnQual n -- or Qual m n?+  localVal' n _ = UnQual n+--instName m s = UnQual (instName m s)+  dictName' n _ = fakeQual "d" (show n)+  superName q k = mapHsName (flip superName k) q+  defaultName = mapHsName defaultName++instance TypeCon HsName where topType = Qual+instance TypeVar HsName where+  tvar = fakeQual "t" . show+  ltvar = UnQual++fakeQual s = Qual (fakeModule s)++instance TypeId HsName++instance Fresh HsName where fresh = tvar # fresh++instance IsSpecialName Id -- dummy+instance HasSpecialNames Id -- dummy++instance TypeCon Id where topType m n = n++instance ValueId Id where+  topName s m n ty = n+--instName m (SrcLoc f l c) = "inst__"++show l++"_"++show c+  superName n k = "super"++show k++"_"++n+  defaultName n = if isSymbol (head n)+		  then "$--"++n+		  else "default__"++n
+ tools/base/TI/TiInstanceDB.hs view
@@ -0,0 +1,129 @@+{-++Instance declarations in the source code are assigned names and+added to the instance database, which gets used during context reduction.+-}+module TiInstanceDB(+  IDB,Instance,InstEntry(..),emptyIdb,extendIdb,classInstances,findInst,findInst',+  addInstKind,instType)+ where+import TiTypes(Type,Pred,Subst(..),Types(..),funT,HsIdentI(..),Typing(..),+	       Kinded,kinded,unQual,forall')+import TiSolve()+import Unification(match,unify)+import Maybe(mapMaybe,isJust)+--import HsIdent -- hmm+import PrettyPrint+import SpecialNames+import TiDefinedNames(definedTypeName,optDefinedTypeName)++import MUtils(( # ),mapPartition)+--import Debug.Trace(trace) -- debug+import Map60204++#if __GLASGOW_HASKELL__ >= 604 +import qualified Data.Map as M (Map)+newtype IDB i = Idb (M.Map i [Instance i]) --deriving Show+#else+import qualified Data.FiniteMap as M (FiniteMap)+newtype IDB i = Idb (M.FiniteMap i [Instance i]) --deriving Show+#endif  ++{-++The instance database is simpliy a list of instances. An instance like++    #instance (Show a,Show b) => Show (Either a b)#++might be represented in the database as++    #(Show (Either a b),(inst_Show_Either,[Show a,Show b]))#+-}++type Instance i = (Pred i,InstEntry i)+data InstEntry i = IE i [Kinded i] [Pred i] deriving (Eq,Show,Read)++instClass (hd,_) = definedTypeName hd+instHead (ih,_) = ih+--instName (_,(n,_)) = n++instType (c,IE v gs ctx) = HsVar v:>:forall' gs (unQual (funT (ctx++[c])))++addInstKind ks (c,(i,ctx)) = (c,IE i (kinded ks (tv (c,ctx))) ctx)++emptyIdb = Idb emptyM+--extendIdb1 inst (Idb idb) = Idb (inst:idb)+extendIdb insts (Idb idb)  = Idb (addListTo_CM (++) idb cinsts)+  where+    cinsts = [(instClass i,[i])|i<-insts]++--namesIdb (Idb idb) = [dn|(_,(dn,_))<-idb]++classInstances (Idb idb) k = findWithDefaultM [] k idb++findInst idb = findInst' True idb+findInst' delayIfOverlap (Idb idb) pred =+    --trace (pp debugmsg)+    pick+  where+    {-+    debugmsg =+       "findInst "<+>pred $$+       nest 4 (vcat [+       "Applicable now:  "<+>some (map (fst.fst) nowInsts),+       "Applicable later:"<+>some (map fst laterInsts),+       "Pick:            "<+>some pick,+       "Other: "<+> if null laterInsts+                    then some (map fst otherInsts)+                    else ppi (length otherInsts - length laterInsts)])+      where+        some xs = length xs <+> vcat (take 5 xs)+    -}+    pick = map instantiate (if delayIfOverlap+			    then handleOverlapping+			    else nowInsts)+    (otherInsts,nowInsts) = mapPartition matchInst insts+      where+        matchInst inst =+              maybe (Left inst) (Right . (,) inst)+                $ match [(instHead inst,pred)]++	-- Instances in the same class, or...+	insts = maybe allInsts ( \k-> findWithDefaultM [] k idb) $+		  optPredClass pred+	  where+	    -- Used when looking for an instance in an unknown class!+	    allInsts = concat (elemsM idb)++    laterInsts = mapMaybe laterInst otherInsts+      where laterInst inst = const inst # unify [(pred,instHead inst)]+++    instantiate ((ip,IE dn gs ips),s) = +        ((dn,su ips),((gs,su ip),S s))+      where su x = apply (S s) x++    -- Support for overlapping instances:++    handleOverlapping =+      if null laterInsts+      then findMostSpecific nowInsts+      else []+    +    findMostSpecific is = filter isMostSpecific is+      where+        isMostSpecific i = all (i `mst`) is+        (i1,_) `mst` (i2,_) = i1 `moreSpecificThan` i2++    i1 `moreSpecificThan` i2 = isJust (match [(instHead i2,instHead i1)])++optPredClass p = optDefinedTypeName p++----+instance Show i => Show (IDB i) where+  showsPrec _ (Idb insts) = shows (toListM insts)++instance (IsSpecialName i,Printable i) => Printable (IDB i) where+  ppi (Idb insts) = vcat [pinst i|is<- elemsM insts,i<-is]++pinst (t,IE dn gs ctx) = dn<+>"= instance"<+>ctx<+>"=>"<+>t++instance Printable i => Printable (InstEntry i)
+ tools/base/TI/TiKEnv.hs view
@@ -0,0 +1,7 @@+module TiKEnv(KEnv,extenv1,extenv,empty,lookup,domain,range) where+import Prelude hiding (lookup)+import TiEnvFM+import HsIdent(HsIdentI)+import TiTypes(Kind,TypeInfo)++type KEnv i = Env (HsIdentI i) (Kind,TypeInfo i) -- kind of type identifiers
+ tools/base/TI/TiKinds.hs view
@@ -0,0 +1,71 @@+{-++Types for kinds.+Functions for kind inference. +-}+module TiKinds(module TiKinds,kstar,kpred) where+import HsKind(K(..),mapK,matchK)+--import HsDeclStruct(HsFunDeps)+import HasBaseStruct(HasBaseStruct(..),kstar,kpred)+import TiConstraints+import Unification(Unifiable(..),unify)+import PrettyPrint++-- Be strict to avoid a space leak+data Kind = K !(K Kind) | Kvar KVar deriving (Eq,Show,Read)+newtype KVar = KVar Int deriving (Eq,Show,Read)++instance HasBaseStruct Kind (K Kind) where base = K++data KindConstraint = Kind :=* Kind deriving (Show)+type KSubst = [(KVar,Kind)]++fixkvars :: Kind -> Kind+fixkvars k =+  case k of+    Kvar _ -> kstar+    K k -> K $ mapK fixkvars k++ksubst :: KSubst -> Kind -> Kind+ksubst s k =+  case k of+    K k -> K $ mapK (ksubst s) k+    Kvar kv -> case lookup kv s of+	         Just k' -> k'+		 _ -> k++ksolve :: Monad m => Constraints KindConstraint -> m KSubst+ksolve cs = unify [(k1,k2)|k1:=*k2<-toList cs]++ksolveSloppy cs = unify [(sloppy k1,sloppy k2)|k1:=*k2<-toList cs]+  where+    sloppy k =+      case k of+	Kvar _ -> k+	K Kpred -> K Kstar+	K k -> K $ mapK sloppy k++instance Unifiable Kind KVar where+  topMatch (Kvar kv1,Kvar kv2) | kv1==kv2 = Just []+  topMatch (K k1,K k2) = matchK k1 k2+  topMatch _ = Nothing++  isVar (Kvar kv) = Just kv+  isVar _ = Nothing++  subst = ksubst++  showTerm = pp++---++--instance Show Kind where show = pp+instance Printable Kind where+  ppi (K k) = ppi k+  ppi (Kvar kv) = ppi kv++  wrap (K k) = wrap k+  wrap k = ppi k++instance Printable KVar where+  ppi (KVar k) = ppi ("k"++show k)+  wrap = ppi
+ tools/base/TI/TiLit.hs view
@@ -0,0 +1,36 @@+-- Type inference for literals.+module TiLit where+import BaseSyntaxStruct+--import HasBaseStruct+--import TiPrelude+import TI+import MUtils+{-+instance (TypeId i,ValueId i,Fresh i,+          --HasBaseStruct e (EI i e' p ds t c),+	  HasLit e,+	  HasTypeApp i e)+       => TypeCheck i HsLiteral (Typed i e) where+  tc = tcLit+-}+-- Overloaded literals:+tcLit r s l =+  case l of+    HsInt  _ -> instPrel_srcloc s "fromInteger" `tapp` tl+    HsFrac _ -> instPrel_srcloc s "fromRational" `tapp` tl+    _ -> tl+  where+    tl = emap r # tcLit0 l++-- Non-overloaded literals:+tcLit0 lit = do t <- tLit lit+                lit >: t++-- Types of non-overloaded literals:+tLit lit =+  case lit of+    HsInt    _ -> prelTy "Integer"+    HsChar   _ -> prelTy "Char"+    HsString _ -> prelTy "String"+    HsFrac   _ -> prelTy "Rational"+    -- + extensions...
+ tools/base/TI/TiModule.hs view
@@ -0,0 +1,88 @@+{-++This module defined the function #tcModule#, which type checks a single+module, the function #tcModuleGroup#, which type checks a group+of mutually recursive modules.+-}+module TiModule(tcModule,tcModuleGroup,representative,joinModules,+                monomorphismRestriction) where+import Maybe(mapMaybe,fromJust)+import List(sort)++import TiDefault(resolveToplevelAmbiguities)+import TI+--import TiPrelude(pt)+import SrcLoc1(srcFile)+import HasBaseName(getBaseName)++import HsModule+import HasBaseStruct+import HsDeclStruct++import MUtils++{-++Type checking a single module+-}+tcModule stdNames mod =+  tcModule' stdNames id (const (getBaseName (hsModName mod))) mod++tcModule' stdNames rewrite modmap (HsModule s m es imps ds) =+  withStdNames stdNames $ +  do integer <- prelTy "Integer"+     double <- prelTy "Double"+     let defaultDefaults = [integer,double]+	 dss = if null dss0 then [defaultDefaults] else dss0+	   where dss0 = defaultDecls ds+     emap (HsModule s m es imps) #+       (inModule modmap dss $ checkModule2 $ tcTopDecls rewrite ds)+  where+    -- These functions are present only beause they are needed to implement+    -- the annoying monomorphism restriction...+{-+    -- Without defaulting:+    checkModule1 mM =+      do (m:>:(insts,(ks,ts)),(dicts,kpreds,s1)) <- getSubst mM+         extendkts ks $ extendts ts $ extendIEnv insts $+	  do catchAmbiguity dicts+	     let s = apply s1+	     s m>:(insts,(ks,s ts))+-}+    -- With defaulting:+    checkModule2 mM =+      do (m:>:(insts,(ks,ts)),(dicts,kpreds,s1)) <- getSubst mM+         extendkts ks $ extendts ts $ extendIEnv insts $+          do --catchAmbiguity dicts+	     (s2,r) <- resolveToplevelAmbiguities dicts+	     let s = apply s2 . apply s1+	     r (s m)>:(insts,(ks,s ts))++defaultDecls ds = [ts|HsDefaultDecl s ts<-mapMaybe basestruct ds]++{-++Type check a mutually recursive group of modules by joining them+into one module...+-}+tcModuleGroup stdNames rewrite ms =+    emap (splitModule ms) #+      tcModule' stdNames rewrite (moduleNameMap ms) (joinModules ms)+  where++    splitModule ms HsModule{hsModDecls=ds} = map collectDecls ms+      where+         collectDecls (HsModule s m i e _) =+	     HsModule s m i e (filterDefs sameFile ds)+	   where+	     f = srcFile s+	     sameFile d = srcFile d==f++moduleNameMap ms path =+  fromJust . lookup path $ [(srcFile m,getBaseName (hsModName m))|m<-ms]++joinModules mods@(_:_) =+    fakeModule $ unzip3 [(s,m,ds)|HsModule s m _ _ ds<-mods]+  where+    fakeModule (s:_, ms, dss) =+        HsModule s (representative ms) Nothing [] (concatDefs dss)+joinModules [] = error "Bug: TiModule.joinModules []"++representative = head . sort -- pick one representative from the scc
+ tools/base/TI/TiMonad.hs view
@@ -0,0 +1,5 @@+-- A module to make it ease to switch between the new and the old version+-- of TiMonad.+module TiMonad(module T) where+import OrigTiMonad as T+--import NewTiMonad as T
+ tools/base/TI/TiNameMaps.hs view
@@ -0,0 +1,15 @@+module TiNameMaps(module TiNameMaps,AccNames(..)) where+import List(nub)++import NameMaps(AccNames(..))+import TypedIds(IdTy(..),TypeInfo(..),idTy)+import HsIdent(HsIdentI(..))++allTypeNames ds = nub (accNames typeName ds [])+  where+    typeName x =+      case idTy x of+        Class {}                       -> (HsCon x:)+	Type TypeInfo{defType=Nothing} -> (HsVar x:)+	Type {}                        -> (HsCon x:)+	_ -> id    
+ tools/base/TI/TiNames.hs view
@@ -0,0 +1,98 @@+{-++Since the type of identifiers is not hardwired in the type checker,+this module defines some type classes that capture what the type checker needs+to do with identifiers.+-}+module TiNames where+import Char(isAlphaNum)+import HsIdent+import HsName(ModuleName)+import HsConstants(mod_Prelude)+import SrcLoc1(SrcLoc,srcFile,srcLoc)+import SrcLocPretty(shLineCol)+import PrettyPrint(Printable,pp)+import SpecialNames+import TypedIds(IdTy(..),HasIdTy(..))+import UniqueNames(PN)++type SrcName = String++class ValueId i where+  topName   :: Maybe SrcLoc -> ModuleName -> SrcName -> IdTy (PN String) -> i+  localVal' :: SrcName -> Maybe SrcLoc -> i+--instName  :: ModuleName -> SrcLoc -> i+  dictName' :: Int -> Maybe SrcLoc -> i+  superName :: i -> Int -> i+  defaultName :: i -> i++class HasIdTy n i => TypedId n i | i->n where+  idName :: i -> n++isCon i = +  case idTy i of+    ConstrOf {} -> True+    _ -> False++dictName i = dictName' i Nothing+conName' s m n t ty = topName s m n (ConstrOf t ty)+conName m = conName' Nothing m+prelCon c = conName mod_Prelude c+localVal n = localVal' n Nothing+topVal' m n s = topName s m n Value+topVal m n = topVal' m n Nothing+prelVal' n = topVal' mod_Prelude n+prelVal n = prelVal' n Nothing++{-+ #instName# generates context-independent, unique names for instance+declarations. The module name is included so that the instance names remain+unique when mutually recursive groups of modules are combined into one module.+-}+instName m s inst =+    --topName (Just s) m ("inst__"++pp m++"_"++shLineCol s) Value+    topName (Just s) m ("inst__"++dots2uscore (pp m)++"_"++mangle (pp inst)) Value+  where+    -- A quick hack: !!!+    mangle = concatMap mangle1+    mangle1 c =+      case c of+        ' ' -> "_"+	'(' -> "_l_"+	')' -> "_r_"+	_ -> if isAlphaNum c then [c] else "_"++show (fromEnum c)++instName' modmap s = instName (modmap (srcFile s)) s++derivedInstName' modmap cl = derivedInstName m cl+  where+    s = srcLoc cl+    m = modmap (srcFile s)++derivedInstName m cl tn =+    topName (Just s) m ("derived__"++dots2uscore (pp m)++"_"++pp cl++"_"++n) Value+  where+    s = srcLoc cl+    ts = pp tn+    n = if all isAlphaNum' ts+	then ts+	else shLineCol s+    isAlphaNum' c = c `elem` "_'" || isAlphaNum c++-- For the annoying 'hierarchical' module name extension:+dots2uscore = map dot2uscore+dot2uscore '.' = '_'+dot2uscore c = c++class (HasSpecialNames i,IsSpecialName i) => TypeCon i where+  topType :: ModuleName -> SrcName -> i++prelType n = topType mod_Prelude n++class (Ord i,Printable i) => TypeVar i where+  tvar :: Int -> i+  ltvar :: SrcName -> i++class (TypeCon i,TypeVar i) => TypeId i++-- Prelude values and constructors+pv n = HsVar (prelVal n)+pc n = HsCon (prelVal n)
+ tools/base/TI/TiP.hs view
@@ -0,0 +1,54 @@+module TiP where+import HasBaseStruct+import BaseSyntaxStruct+import TI+import TiLit(tcLit)+import TiFields(tcFieldsPat)+--import TiPrelude+import MUtils++instance HasId i (PI i p) where+  ident = HsPId+  isId (HsPId x) = Just x+  isId _ = Nothing+{-+instance (Fresh i,TypeId i,ValueId i,+          TypeCheck i inp (Typed i outp),HasLit outp,+	  HasTypeApp i outp, HasBaseStruct outp (PI i outp))+	 => TypeCheck i (PI i inp) (Typed i outp) where tc = tcP+-}+tcP p =+  case p of+    HsPId n                -> inst n+--  HsPLit l               -> emap hsPLit # tcLit0 l+    HsPLit s l             -> tcLitP s l+    HsPNeg s l             -> instPrel_srcloc s "negate" `tapp` tcLitP s l+    HsPSucc s n l          -> instPrel_srcloc s "+" `tapp` inst (HsVar n) `tapp` tcLitP s l+    HsPInfixApp x op z     -> instCon op `tapp` tc x `tapp` tc z+    HsPApp nm ps           -> tcPApp nm ps+    HsPTuple s ps          -> typedTuple =<< mapM tc ps+    HsPList  s ps          -> tcList =<< mapM tc ps+    HsPParen p             -> emap hsPParen # tc p+    HsPRec c fields        -> tcFieldsPat c fields+    HsPAsPat nm p          -> tcAsPat nm p+    HsPWildCard            -> (hsPWildCard:>:) # tfresh+    HsPIrrPat p            -> emap hsPIrrPat # tc p+  where+    tcLitP s = tcLit (hsPLit s) s++tcPApp con ps = foldl tapp (instCon con) (map tc ps)++instCon c = inst (HsCon c)++tcAsPat x p =+  do tx <- varinst x+     p' :>: tp <- tc p+     tx =:= tp+     hsPAsPat x p' >: tp++-- binary version of HsPApp (only for constructor applications):+pApp p1 p2 =+  case p1 of+    HsPId (HsCon c) -> HsPApp c [p2]+    HsPApp c ps -> HsPApp c (ps++[p2])+--  _ -> error ("pApp "++show p1)
+ tools/base/TI/TiPNT.hs view
@@ -0,0 +1,86 @@+{-++This module defines instances for the+identifier types #PN# and #PNT# in the classes needed by the type checker.+-}+module TiPNT where+import PNT(PNT(..),PId)+import TiNames+import SrcLoc1(loc0,SrcLoc(..))+import UniqueNames as U+import SpecialNames+import TypedIds+import MUtils+import TiFresh+import HsConstants as Hs(tuple,mod_Prelude)+import QualNames(getQualified)+import TiHsName++instance TypeCon i => TypeCon (PN i) where+  topType m n = PN (topType m n) (G m n noSrcLoc)++instance ValueId i => ValueId (PN i) where+  topName s m n ty = PN (topName s m n ty) (G m n (optSrcLoc s))+  localVal' n Nothing = PN (localVal n) (Sn n loc0) -- hmm+  localVal' n (Just s) = PN (localVal' (n++sh s) (Just s)) (Sn n s)+         where sh (SrcLoc f _ 0 0) = ""+	       sh (SrcLoc f _ r c) = "_"++show r++"_"++show c+--instName m s = PN (instName m s) (I m s)+  dictName' i s = PN (localVal' "d" s) (D i (optSrcLoc s))+  superName (PN n (G m n' s)) k = PN (superName n k) (G m ("super"++show k++"_"++n') s)+  defaultName (PN n (G m n' s)) = PN (defaultName n) (G m (defaultName n') s)++instance TypeVar i => TypeVar (PN i) where+  tvar n = PN (ltvar "t") (D n noSrcLoc)+  ltvar n = PN (ltvar n) P -- just for pretty printing++instance TypeId i => TypeId (PN i)++instance TypeVar i => Fresh (PN i) where+  fresh = tvar # fresh++instance TypeCon PNT where+   topType m n = PNT (topType m n) (Type blankTypeInfo) noSrcLoc++instance ValueId PNT where+  topName s m n ty = PNT (topName s m n ty) ty (optSrcLoc s)+  localVal' n s = PNT (localVal' n s) Value (optSrcLoc s)+--instName m s = PNT (instName m s) Value (U.srcLoc s)+  dictName' i s = PNT (dictName' i s) Value (N s)+  superName (PNT n (Class cnt ms) s) k = PNT (superName n k) (MethodOf (getQualified n) cnt ms) s+  defaultName (PNT n _ s) = PNT (defaultName n) Value s++instance TypeVar PNT where+   tvar n = PNT (tvar n) (Type blankTypeInfo) noSrcLoc+   ltvar n = PNT (ltvar n) (Type blankTypeInfo) noSrcLoc++instance Fresh PNT where fresh = tvar # fresh+instance TypeId PNT++instance TypedId PId PNT where+  idName (PNT n _ _) = getQualified n++instance IsSpecialName i => IsSpecialName (PN i) where+  -- Should probably use the original name instead!+  is_list_tycon_name (PN i _) = is_list_tycon_name i+  is_fun_tycon_name (PN i _) = is_fun_tycon_name i+  is_char_tycon_name (PN _ (G m "Char" _)) = m == mod_Prelude+  is_char_tycon_name _ = False+  is_tuple_tycon_name n (PN i _) = is_tuple_tycon_name n i++instance (TypeCon i,HasSpecialNames i) => HasSpecialNames (PN i) where+  list_tycon_name = prelType "[]"+  fun_tycon_name = prelType "->"+  char_tycon_name = prelType "Char"+  tuple_tycon_name = prelType . Hs.tuple++instance IsSpecialName PNT where+  is_list_tycon_name (PNT i _ _) = is_list_tycon_name i+  is_fun_tycon_name (PNT i _ _) = is_fun_tycon_name i+  is_char_tycon_name (PNT i _ _) = is_char_tycon_name i+  is_tuple_tycon_name n (PNT i _ _) = is_tuple_tycon_name n i++instance HasSpecialNames PNT where+  list_tycon_name = prelType "[]"+  fun_tycon_name = prelType "->"+  char_tycon_name = prelType "Char"+  tuple_tycon_name = prelType . Hs.tuple
+ tools/base/TI/TiPrelude.hs view
@@ -0,0 +1,68 @@+{-++This module defines various auxiliary functions that are used by the type+checker when it needs to refer to things defined in the Prelude, e.g., when+dealing with the do notation, literals, and sections.++These are to considered deprecated now. Since they create hardwired references+to particular original names, they prevent PFE from being used with alternate+Prelude and standard libraries that are structured in differnt ways.+-}+module TiPrelude where+import HsConstants(tuple)+import HasBaseStruct+-- import TiTypes+import TiNames+import HsIdent(HsIdentI)+import HsTypeStruct+++--pt :: String->Type+pt :: (HasBaseStruct r (TI i t), TypeCon i) => SrcName -> r+pt n = hsTyCon . prelType $ n++--tBool :: HasBaseStruct t (T t') => t+--tBool :: (HasBaseStruct rec (TI i t), TypeCon i)  => rec+--tBool = pt "Bool"++prelOtherwise = pv "otherwise"+prelFlip   = pv "flip"+{-+prelOtherwise, prelNegate, prelFlip, prelEnumFrom, prelEnumFromTo,+ prelEnumFromThen, prelEnumFromThenTo, prelThen, prelBind, prelFail,+ prelFromInteger, prelFromRational, prelError+ :: ValueId i => HsIdentI i++prelNegate = pv "negate"+prelEnumFrom = pv "enumFrom"+prelEnumFromTo = pv "enumFromTo"+prelEnumFromThen = pv "enumFromThen"+prelEnumFromThenTo = pv "enumFromThenTo"++prelThen = pv ">>"+prelBind = pv ">>="+prelFail = pv "fail"+++prelFromInteger = pv "fromInteger"+prelFromRational = pv "fromRational"++prelError = pv "error"+prelEqual = pv "=="+prelGE    = pv ">="+prelPlus  = pv "+"+prelMinus = pv "-"+prelNot   = pv "not"+prelAnd   = pv "&&"+prelOr    = pv "||"++prelFalse = pc "False"+prelNil   = pc "[]"+-}+prelTrue  = pc "True"++--tupleType ts = foldl1 hsTyApp (tuplecon (length ts):ts) :: Type+tupleType ts = hsTyTuple ts -- :: Type+--listType t = hsTyApp (pt "[]") t -- :: Type++tuplecon n = pt (tuple (n-1)) -- :: Type+funcon = pt "->"
+ tools/base/TI/TiPretty.hs view
@@ -0,0 +1,71 @@+module TiPretty where+import TiTypes hiding (forall')+import TiNames+import TiKinds+import PrettyPrint+import SpecialNames+import PrettySymbols(forall',imp,el)+import Syntax(hsTyVar)+import HsDeclPretty(ppFunDeps,ppContext)+import MUtils(( # ),ifM)++instance (TypeId i,ValueId i)+      => Printable (Scheme i) where+  ppi (Forall [] [] qt) = ppi qt+  ppi (Forall aks vks qt@(_:=>t)) =+      ppIfUnicode (ppForall varnames) (ppForall asciinames)+    where+      ppForall names = sep [forall' <+> vs'' <+> ".",letNest qt'']+        where+          qt'' = ifM (debugInfo # getPPEnv) (ppi qt) (ppi qt')++          vs'' = ifM (debugInfo # getPPEnv) (asep (k vs)) (asep (k vs'))+	    where k vs = map ppKinded (zipTyped (vs:>:ks))+          vs' = map snd s+	  qt' = apply (S s) qt+	  s = [(v,hsTyVar (ltvar name) `asTypeOf` t) | (v,name) <- zip vs names]+	  vs:>:ks = unzipTyped (aks++vks) -- hmm+	  n = length aks+	  asep avs =+              if null as+	      then fsep vs+	      else braces (fsep as)<+>fsep vs+           where (as,vs) = splitAt n avs+      -- Infinite supplies of variables names:+      varnames = map single [alpha..omega]++asciinames+        where alpha='\x03b1'; omega='\x03c9'+      asciinames = map single letters++[a:show n|n<-[1..],a<-letters]+      single x = [x]+      letters = ['a'..'z']++ppKinded (x:>:k) = if k==kstar then ppi x else parens (x<>el<>k)++instance (IsSpecialName i,Printable i,Printable t)+      => Printable (Qual i t) where+  ppi ([]:=>t) = ppi t+  ppi (ps:=>t) = sep [ppiFTuple ps <+> imp, letNest t]++instance (Printable x,Printable t) => Printable (Typing x t) where+  ppi (x:>:t) = sep [wrap x <+> el,letNest t]+  ppiList xts = vcat xts++instance (ValueId i,TypeId i) => Printable (TypeInfo i) where+  ppi i =+      case i of+	Data -> ppi "data" -- <+> o+	Newtype -> ppi "newtype" -- <+> o+	Class super ps fundeps methods ->+	  "class" <+> sep [ppi (ppContext super<+>"_"<+>fsep (map ppKinded ps)),+			    ppFunDeps fundeps,+			    ppi "where", letNest methods]+	Synonym ps t -> +	  "type" <+> appv (p:ps) <+> "=" <+> letNest t+	Tyvar -> ppi "type variable"+    where+      p =  localVal "_"+      appv = asType . appT . map tyvar++asType = id :: Type i -> Type i++instance (IsSpecialName i,Printable i) => Printable (Subst i) where+  ppi (S s) = ppi s
+ tools/base/TI/TiRhs.hs view
@@ -0,0 +1,30 @@+module TiRhs where+--import HasBaseStruct+import BaseSyntaxStruct+import TI+--import TiPrelude(tBool)+import MUtils+--import PrettyPrint -- debug++instance (--Printable i, -- debug+          TypeCon i,Fresh i,TypeCheck i e (Typed i e'),HasTypeAnnot i e')+      => TypeCheck i (HsRhs e) (Typed i (HsRhs e')) where+  tc = tcRhs++tcRhs rhs =+  case rhs of+    HsBody e -> emap HsBody # tc e+    HsGuard gds -> emap HsGuard # tcGds gds++tcGds gds =+  do gds':>:ts' <- unzipTyped # mapM tcGd gds+     t <- allSame ts'+     gds'>:t++tcGd (s,e1,e2) =+  posContext s $+  do e1':>:t1' <- tc e1+     tBool <- getBoolType+     t1'=:=tBool+     e2':>:t2' <- tc e2+     (s,e1',typeAnnot e2' t2')>:t2'
+ tools/base/TI/TiSCC.hs view
@@ -0,0 +1,30 @@+module TiSCC where+--import TiClasses+import MUtils+import NewSCC+--import Grapheq+import Maybe(fromJust,mapMaybe)+import TiDefinedNames(definedNamesSplit)+import TiFreeNames++default(Int)++sccD' names ds = map (map (def.fst)) (scc graph)+  where+    --scc = scceq (==)+    def n = fromJust (lookup n ndefs)+    graph = [(n,mapMaybe refs xs)|(n,(_,xs))<-nvars]+    refs x = lookup x defnrs+    ndefs = zip [0..] ds+    nvars = mapSnd names ndefs+    +    defnrs = [(x,n)|(n,(xs,_))<-nvars,x<-xs]+  +sccD ds = sccD' names ds+  where+    names d =+      case definedNamesSplit d of+	([],[]) -> ([],[])+	(types,[]) -> (types,freeTypeNames d)+        ([],values) -> (values,freeValueNames d)+	_ -> error "TiSCC.hs: mixed type/value definition"
+ tools/base/TI/TiSolve.hs view
@@ -0,0 +1,101 @@+{-++Functions for unifying types, matching types, and expanding type synonyms.+-}+module TiSolve(TypeConstraint(..),solve,isVar,matches,matchEqns,expandSynonyms) where+import Prelude hiding (lookup) -- for Hugs+import Monad(mplus)+import TiConstraints+import TiTypes+import TiNames+import TiKinds+import TiPrelude(funcon)+import Unification(Unifiable(..),unify,match)+import MUtils+import Syntax(HsTypeI(..),TI(..),HsIdentI(..),matchT,struct,mapT,base)+import TiKEnv(lookup)+import PrettyPrint(Printable,pp)++--------------------------------------------------------------------------------+data TypeConstraint i+  = Type i :=: Type i+  | Inst (Typing i (Pred i))+  | KInst (Kinded (Type i)) -- to keep track of the kinds of type variables+  deriving Show++instance TypeVar v => Types v (TypeConstraint v) where+  tmap f (t1:=:t2) = tmap f t1:=:tmap f t2+  tmap f (Inst i) = Inst (tmap f i)+  tmap f (KInst (t:>:k)) = KInst (tmap f t:>:k)+  tv (t1:=:t2) = tv (t1,t2)+  tv (Inst i) = tv i+  tv (KInst (t:>:k)) = tv t++--------------------------------------------------------------------------------++solve env constraints =+    do let (eqns,(preds0,kpreds0)) = separate (toList constraints)+       s <- S # unify (expandEqns env eqns)+       let preds = apply s preds0+           kpreds = [apply s t:>:k|t:>:k<-kpreds0]+       return (preds,kpreds,s)+  where+    separate = apSnd (mapPartition id) . mapPartition dist+    dist (t1:=:t2) = Left (t1,t2)+    dist (Inst i) = Right (Left i)+    dist (KInst ki) = Right (Right ki)++t1 `matches` t2 = matchEqns [(t2,t1)]+matchEqns eqns env =  S # match (expandEqns env eqns)++instance (Printable i,TypeId i) => Unifiable (Type i) i where+  topMatch (Typ t1,Typ t2) =+    matchT t1 t2 `mplus` matchT (tupleHack t1) (tupleHack t2)++  isVar = isVarT+  subst s t = apply (S s) t++  showTerm = pp++{-++Function types (previously also tuple types) can be represented in two+different ways in the abstract syntax, so we convert one+representation to the other to avoid false unification/matching+errors...+-}+--tupleHack (HsTyTuple ts) = struct $ appT (tuplecon (length ts):ts)+tupleHack (HsTyFun t1 t2) = struct $ appT [funcon,t1,t2]+tupleHack t = t++expandEqns env = mapBoth (expandSynonyms env)++{-++Expand type synonyms.+(Previously, this function also replaced data/newtype names with their+original names. This is now assumed to happen in a pass prior to type checking.)+-}++--expandSynonyms :: Env QId (Kind,TypeInfo) -> Type -> Type+expandSynonyms env (Typ t) =+  case t of+    HsTyApp t1 t2 -> expandApp t1 [t2]+    HsTyCon _     -> expandApp (base t) []+    _ -> base $ mapT (expandSynonyms env) t+ where+   --expandApp :: Type -> [Type] -> Type+   expandApp (Typ t) ts = +     case t of+       HsTyApp t1 t2 -> expandApp t1 (t2:ts)+       HsTyCon c ->+         case TiKEnv.lookup env (HsCon c) of+	   --Just (_,Data orig) -> app (HsTyCon orig)+	   --Just (_,Newtype orig) -> app (HsTyCon orig)+           Just (_,Synonym vs rhs) | n<=length ts ->+	       expandSynonyms env (appT (apply (S (zip vs ts1)) rhs:ts2))+	     where+               n=length vs+	       (ts1,ts2) = splitAt n ts+	   _ -> keepApp+       _ -> keepApp+     where+       keepApp = app t+       app t =  appT (base t:map (expandSynonyms env) ts)
+ tools/base/TI/TiT.hs view
@@ -0,0 +1,37 @@+-- Kind inference for the T structure+module TiT where+import HasBaseStruct+import BaseSyntaxStruct+import TI hiding (TI)+--import MUtils++instance (TypeVar i,KindCheck i t Kind)+      => KindCheck i (TI i t) Kind where+  kc t =+    case t of+      HsTyFun t1 t2   -> do kcStar t1; kcStar t2; return kstar+--    HsTyTuple ts    -> do mapM_ kcStar ts; return kstar+      HsTyApp t1 t2   -> kc t1 `kapp` kc t2+      HsTyVar v       -> kindOf (HsVar v)+      HsTyCon c       -> kindOf (HsCon c)+      HsTyForall vs ps t' -> {-do bs <- kintro (map HsVar vs)+			     extendkts bs $-} mapM_ kcPred ps >> kc t'++instance (TypeVar i,KindCheck i t Kind)+      => KindCheck i (Qual i t) Kind where+  kc (ps:=>t) = do mapM_ kcPred ps; kc t++kcCheck k t = do k'<-kc t; k'=*=k+kcStar t = kcCheck kstar t+kcPred t = kcCheck kpred t++fun `kapp` arg =+  do kf <- fun+     ka <- arg+     k <- fresh+     kf =*= ka `karrow` k+     return k++instance TypeVar i => KindCheck i (Type i) Kind where+  kc (Typ t) = kc t+
+ tools/base/TI/TiTEnv.hs view
@@ -0,0 +1,38 @@+{-++Type environments.++For efficiency, a type environment is represented as a pair of an environment+and the set of (nongeneric) type variables that occur free in the environment.+The type checker needs this information when it generalizes a type,+and traversing the whole environment every time is too costly.+-}+module TiTEnv(TEnv,extenv1,extenv,empty,TiTEnv.lookup,domain,range) where++import HsIdent(HsIdentI)+import TiTypes(Scheme,Types(..))+import TiNames(TypeVar)+import qualified TiEnvFM as E+import Set60204++#if __GLASGOW_HASKELL__ >= 604 +import qualified Data.Set as S (Set)+#else+import qualified Sets as S (Set)+#endif++type TEnv' i = E.Env (HsIdentI i) (Scheme i) -- types of value identifiers+data TEnv i = TEnv (TEnv' i) (S.Set i)++extenv1 x t (TEnv env vs) = TEnv (E.extenv1 x t env) (vs `unionS` fromListS (tv t))+extenv bs1 (TEnv bs2 vs) = TEnv (E.extenv bs1 bs2) (vs `unionS` fromListS (tv (map snd bs1)))+empty = TEnv E.empty emptyS++lookup (TEnv env _) x = E.lookup env x+domain (TEnv env _) = E.domain env+range (TEnv env _) = E.range env++--instance Functor TEnv where ...++instance TypeVar i => Types i (TEnv i) where+  tv (TEnv env vs) = elemsS vs+  -- tmap -- of questionable use...
+ tools/base/TI/TiTypes.hs view
@@ -0,0 +1,173 @@+{-++This module defines the represenation of types, qualified types, type schemes,+substitution and various auxiliary types.+-}+module TiTypes(module TiTypes,HsTypeI(..),HsIdentI(..),Kind) where+import Syntax(HsTypeI(..),TI(..),HsIdentI(..),HsFunDeps,+              hsTyFun,hsTyApp,hsTyTuple,hsTyCon,hsTyVar,+              kstar,base,mapTI,accT)+import List(nub,(\\))+import Maybe(fromMaybe)+import MUtils(collectByFst)+--import TiEnv(Env,range)+import TiKinds(Kind)+import TiNames+import Debug.Trace(trace) -- for debugging++type Type i = HsTypeI i+type Pred i = Type i+data Qual i t = [Pred i] :=> t deriving (Eq,Show,Read)+type QType i = Qual i (Type i)++data Scheme v = Forall [Kinded v] [Kinded v] (QType v)+              deriving (Eq,Show,Read) -- Eq??++unQual t = []:=>t+forall' = Forall []+mono t = forall' [] (unQual t)+--uscheme qt = fakeForall (tv qt) qt --  temporary hack!!!+--  where fakeForall vs qt = Forall (map (:>:kstar) vs) qt --  temporary hack!!!+--upscheme t = uscheme (unQual t) --  temporary hack!!!+kuscheme ks qt = forall' (kinded ks (tv qt)) qt+kupscheme ks t = kuscheme ks (unQual t)++funT ts = foldr1 hsTyFun ts -- :: Type+appT ts = foldl1 hsTyApp ts -- :: Type+tupleT ts = hsTyTuple ts -- :: Type+tyvar v = hsTyVar v -- :: Tyvar -> Type+ty (HsVar v) = tyvar v+ty (HsCon c) = hsTyCon c -- :: Type++isVarT (Typ (HsTyVar v)) = Just v+isVarT _ = Nothing++isFunT (Typ (HsTyFun t1 t2)) = Just (t1,t2)+isFunT _ = Nothing++flatAppT t = flat t []+  where+    flat (Typ (HsTyApp t1 t2)) ts = flat t1 (t2:ts)+    flat t ts = (t,ts)+++flatConAppT ty =+  case flatAppT ty of+    (Typ (HsTyCon c),ts) -> Just (HsCon c,ts)+    _ -> Nothing++--instName (SrcLoc f l c) = HsVar (Qual (Module "i") (show l++"_"++show c))+--dictName n = HsVar (Qual (Module "d") n) :: QId+--vvar = unqual :: String->VarId++infix 1 :>:+data Typing x t = x :>: t deriving (Eq,Show,Read)+type Assump i = Typing (HsIdentI i) (Scheme i)+type Typed i x = Typing x (Type i)++emap f (e :>: t) = f e:>:t+tdom xts = [x|x:>:_<-xts]++unzipTyped :: [Typing x t] -> Typing [x] [t]+unzipTyped ets = uncurry (:>:) $ unzip [(e,t)|e:>:t<-ets]++zipTyped :: Typing [x] [t] -> [Typing x t]+zipTyped (xs:>:ts) = zipWith (:>:) xs ts++--collectTyped :: Ord x => [Typing x t] -> [Typing x [t]]+collectTyped xts = map (uncurry (:>:)) $ collectByFst [(x,t)|x:>:t<-xts]+++type Kinded x = Typing x Kind+kinded1 ks v = v:>:head' [k|HsVar v':>:k<-ks,v'==v] -- not very efficient...+  where head' [] = trace ("Bug in TiTypes.kinded1: missing kind info for "++show v) kstar+	head' (k:_) = k+kinded ks = map (kinded1 ks)+--type KAssump = Typing Id Kind++type KInfo i = [Typing (HsIdentI i) (TypeInfo i)]++data TypeInfo i+  = Data+  | Newtype+  | Class [Pred i]        -- superclasses+          [Kinded i]      -- parameters+          (HsFunDeps Int) -- fun deps (0-based parameter positions)+          [Assump i]      -- methods+  | Synonym [i] (Type i)+  | Tyvar+  deriving ({-Eq,-}Show,Read)++newtype Subst i = S [(i,Type i)] deriving (Show)++idS = S []+infix 5 +->+v+-> t = S [(v,t)]+extS v t s = compS (v+->t) s+compS s1@(S s1') s2 = S (s1'++s2')+   where S s2' = apply s1 s2+domS (S s) = map fst s++varSubst s@(S s') v = fromMaybe (tyvar v) (lookup v s')++applySubst s@(S s') ty@(Typ t) =+    case t of+      HsTyVar v -> fromMaybe ty (lookup v s')+      _ -> base $ mapTI id (applySubst s) t++class TypeVar v => Types v t | t->v where+  tmap :: (Type v->Type v) -> t -> t+  apply :: Subst v -> t -> t+  tv :: t -> Set v++  apply = tmap . applySubst++type Set a = [a]++occurs v t = v `elem` tv t++instance Types v t => Types v [t] where+  tmap = map . tmap+  tv = nub . concatMap tv++instance TypeVar v => Types v (Subst v) where+  tmap f (S s') = S [(v,tmap f t)|(v,t)<-s'] -- hmm+  tv (S s') = tv (map snd s') -- hmm++instance (Types v t1,Types v t2) => Types v (t1,t2) where+  tmap f (t1,t2) = (tmap f t1,tmap f t2)+  tv (t1,t2) = nub (tv t1++tv t2)++instance (Types v t1,Types v t2,Types v t3) => Types v (t1,t2,t3) where+  tmap f (t1,t2,t3) = (tmap f t1,tmap f t2,tmap f t3)+  tv (t1,t2,t3) = nub (tv t1++tv t2++tv t3)++instance Types v t => Types v (Typing x t) where+  tmap f (x:>:t) = x:>:tmap f t+  tv (x:>:t) = tv t++instance Functor (Typing x) where+  fmap f (x:>:t) = x:>:f t -- hmm++instance TypeVar v => Types v (Type v) where+  tmap = id+  tv (Typ t) =+    case t of+      HsTyVar v -> [v]+      HsTyForall vs ps t -> tv (ps,t) \\ vs+      _ -> nub $ accT ((++) . tv) t []++instance TypeVar v => Types v (Scheme v) where+  apply s (Forall ags gs qt) = Forall ags gs (apply (restrict s (tdom (ags++gs))) qt)+  tmap f (Forall ags gs qt) = Forall ags gs (tmap f qt) -- hmm+  tv (Forall ags gs qt) = tv qt \\ tdom (ags++gs)++restrict (S s) gs = S [s1|s1@(v,_)<-s,v `notElem` gs]++instance Types v t => Types v (Qual v t) where+  tmap f (ps:=>t) = tmap f ps:=>tmap f t+  tv (ps:=>t) = tv (ps,t)+{-+instance Types v info => Types v (Env key info) where+  tmap = fmap . tmap+  tv = tv . range+-}
+ tools/base/TI/TiUtil.hs view
@@ -0,0 +1,164 @@+{-++This module defines some basic type checking functions, and some utility+functions, notably functions for type checking applications (#tapp#) and+identifiers (#inst# et al), introducing fresh type/kind variables,+recording constraints on types/kinds and instantiating type schemes.+-}+module TiUtil where+import TiMonad+import TiTypes+import TiSolve(TypeConstraint(..))+import TiNames(ValueId,TypeVar,dictName,dictName')+import TiClasses+import TiKinds(KindConstraint(..))+import TiFresh+import HasBaseStruct+import HsConstants(mod_Prelude,tuple)+import BaseSyntax(srcLoc,TI(..))+import TypedIds(NameSpace(..))+import PrettyPrint hiding (var)+import MUtils++--import IOExts(trace) -- debug++-- How to type check applications:+-- tapp :: HasCoreSyntax e => TI (Typed e) -> TI (Typed e) -> TI (Typed e)+fun `tapp` arg =+  do (f:>:tf) <- fun+     (a:>:ta) <- arg+     r <- appt tf ta+     f `app` a >: r+ where+    -- First case is an optional optimization+    appt (Typ (HsTyFun fa fr)) ta = do fa =:= ta+				       return fr+    appt tf ta = do r <- tfresh+	            tf =:= ta `hsTyFun` r+		    return r++--typedTuple :: HasCoreSyntax e => [Typed e] -> Typed e+typedTuple ets =+    do t <- tupleType ts+       TiClasses.tuple es>:t+  where es:>:ts = unzipTyped ets++--tcList :: HasCoreSyntax e => [Typed e] -> TI (Typed e)+tcList ets =+  do let es:>:ts = unzipTyped ets+     t <- allSame ts+     listType <- getListType+     list es >: listType t++tupleType ts =+   do t <- prelTypeName (HsConstants.tuple (length ts-1))+      return $ foldl hsTyApp (hsTyId t) ts++getListType = hsTyApp . hsTyId # prelTypeName "[]"+getBoolType = hsTyId # prelTypeName "Bool"++allSame [] = tfresh+allSame (t:ts) = mapM_ (t=:=) ts >> return t++stdValue = stdName ValueNames+stdType  = stdName ClassOrTypeNames+stdClass = stdType++prelValue     = stdValue . (,) mod_Prelude+prelTypeName  = stdType  . (,) mod_Prelude+prelClassName = prelTypeName+prelTy n = hsTyId # prelTypeName n++instStd = inst @@ stdValue+instStd_srcloc s = inst_srcloc s @@ stdValue+instPrel = inst @@ prelValue+instPrel_srcloc s = inst_srcloc s @@ prelValue++--inst :: HasCoreSyntax i e => HsIdentI i -> TiMonad.TI i (Typed i e)+inst x = inst_loc' Nothing x+inst_loc x = inst_loc' (Just (srcLoc x)) x+inst_srcloc s = inst_loc' (Just s)++inst_loc' s x =+  do sc@(Forall ags gs qt) <- sch x+     vs <- freshvars gs+     let ctx:=> t = freshen' vs (tdom gs) qt+     ds <- newdicts s ctx+     foldl1 app (spec x sc (map tyvar vs):map var ds) >: t++inst_field f =+  do ctx:=>t <- instsch f+     ds <- newdicts Nothing ctx -- use srcLoc f!!+     return t -- hmm++instsch f = sinst =<< sch f+sinst (Forall ags gs qt) =+  do vs <- freshvars gs+     return (freshen' vs (tdom gs) qt)++freshvars gs =+    do vs <- freshlist (length gs)+       addvars (zipTyped (vs:>:ks))+       return vs+  where+    vs0:>:ks = unzipTyped gs++freshInst :: (TypeVar i,Fresh i,ValueId i)+          => Scheme i -> TiClasses.TI i ([Typing i (Pred i)],Type i)+freshInst (Forall ags gs qt) =+  do ctx:=>t <- freshen (tdom gs) qt+     ds <- map dictName # freshlist (length ctx)+     return (zipTyped ((ds{-::[QId]-}):>:ctx),t)++newdicts s ds = mapM (newdict s) ds+newdict s pred = do d <- flip dictName' s # fresh+	            addinst (d:>:pred)+		    return d++{-+freshdicts ctx =+  do idns <- map dictName # freshlist (length ctx)+     return (zipWith (:>:) idns ctx)+-}++freshen gs t =+  do vs <- freshlist (length gs)+     return (freshen' vs gs t)++freshen' vs gs t = apply s t+  where s = S [(g,tyvar v) | (g,v) <- zip gs vs]+++allfresh t = freshen (tv t) t++varinst x =+  do Forall [] [] ([] :=> t) <- sch (HsVar x)+     return t+++infix 4 =:=,=*=+t1 =:= t2 = constrain (t1:=:t2)+k1 =*= k2 = constrain (k1:=*k2)++addinst = constrain . Inst+addkinst ki = do --trace (pp $ "addkinst"<+>ki) $ return ()+                 constrain (KInst ki)++-- Introduce new types of kind *:+tintro xs = do ts <- freshlist (length xs)+	       addtypes ts+	       return (zipTyped (xs:>:ts))++-- Introduce monomorphic type schemes for types of kind *:+schintro xs = map (fmap mono) # tintro xs++-- Introduce new kind variables:+kintro xs = do ts <- freshlist (length xs)+	       return (zipTyped (xs:>:ts))++tfresh = do t <- fresh+	    addtype t+	    return t++addvars = mapM_ (addkinst.emap tyvar)+addtypes ts = mapM_ addtype ts+addtype t = addkinst (t:>:kstar)
+ tools/base/TI/Unification.hs view
@@ -0,0 +1,91 @@+{-++Generic unification and matching+-}+module Unification where+import Maybe(fromMaybe)+import List(nub)+import MUtils(mapFst,mapSnd,mapBoth,apBoth)++{-++Term types to be unified (or matched) must be instances of the+following class:+-}+class (Show term,Eq var) => Unifiable term var | term -> var where+  topMatch :: Equation term -> Maybe (Equations term)+  isVar :: term -> Maybe var+  subst :: Substitution var term -> term -> term++  showTerm :: term -> String -- for error reporting with fail+ +  showTerm = show++type Equation t = (t,t)+type Equations t = [Equation t]++type Substitution v t = [(v,t)]++--mapSubst = mapSnd+mapSubst f s = [seq y (v,y)|(v,x)<-s,let y=f x]-- more strict to avoid space leaks+mapEqns = mapBoth++unify :: (Monad m,Unifiable t v) => Equations t -> m (Substitution v t)+unify = uni []+  where+    -- Invariant: the vars of eqns are not in the domain of s+    --            s is idempotent+    uni s [] = return s+    uni s (eqn@(t1,t2):eqns) =+	case topMatch eqn of+	  Just eqns' -> uni s (eqns'++eqns)+	  _ -> case apBoth isVar eqn of+		(Just v,_) -> varBind v t2+		(_,Just v) -> varBind v t1+		_ -> mismatch' "(unify)" t1 t2+      where+	-- Pre: t is not the variable v. (This is ensured by topMatch.)+	varBind v t =+	  if occurs v t+	  then mismatch' "(occurs check)" t1 t2+          else let s1=(v,t)+		   su=subst [s1]+	       in uni (s1:mapSubst su s) (mapEqns su eqns)+++match :: (Monad m,Unifiable t v) => Equations t -> m (Substitution v t)+-- Pre: lhs vars are disjoint from rhs vars+match eqns = uni [] eqns+  where+    pvars = nub $ concatMap (vars.snd) eqns++    -- Invariant: the vars of the lhss of the eqns are not in the domain of s+    uni s [] = return s+    uni s (eqn@(t1,t2):eqns) =+	case topMatch eqn of+	  Just eqns' -> uni s (eqns'++eqns)+	  _ -> case isVar t1 of+		Just v -> varBind v t2+		_ -> mismatch' "(match)" t1 t2+      where+	-- Pre: t is not the variable v. (This is ensured by topMatch.)+	varBind v t =+	  if v `elem` pvars+	  then mismatch' "(matchvar)"  t1 t2+          else let s1=(v,t)+		   su=subst [s1]+	       in uni (s1:mapSubst su s) (mapFst su eqns)++mismatch t1 t2 = mismatch' "" t1 t2+mismatch' s t1 t2 =+  fail ("Mismatch: "++s++"\n  "++showTerm t1++"\nvs\n  "++showTerm t2)++subterms t = map fst $ fromMaybe bug (topMatch (t,t)) -- clumpsy...+  where+    bug = error $+          "Unification: bug in topMatch: term doesn't match itself:"++showTerm t++vars t =+  case isVar t of+    Just v -> [v]+    _ -> nub $ concatMap vars $ subterms t++occurs v t = v `elem` vars t
+ tools/base/TiProgram.hs view
@@ -0,0 +1,43 @@+module TiProgram(tcProgramFiles,tcProgram,tcModules,tcModuleGroup) where+import ParseProgram+import ScopeProgram+import HsModule(hsModName)++import TiModule(tcModuleGroup)+import TI(extendIEnv,extendEnv,(+++),errmap,Typing(..))++import WorkModule(analyzeModules)++import PrettyPrint+import MUtils+import Lift++--- Parse and type check a program, given as a list of file names.+-- tcProgramFiles+--   :: ... => [FilePath] -> IO ([[HsModule ds']],DeclsType)+tcProgramFiles parseMod = lift . tcModules @@ parseProgram parseMod++--- Rewrite and type check a program, given as a list of parsed modules+-- tcProgram+--   :: ... => [HsModule ds] -> IO ([[HsModule ds']],DeclsType)+tcProgram mods = tcModules @@ lift . analyzeModules $ mods++tcModules prg = tcModules'.fst =<< scopeProgram prg++-- Type check dependency analyzed modules:+tcModules' modss = tcSccs ([],[]) [] modss+  where+    tcSccs tmods tsccs sccs =+      case sccs of+        [] -> return (reverse tsccs,tmods)+        scc:sccs' -> do (tscc,tmods1,insts) <- tcScc scc+		        extendIEnv insts $+			  extendEnv tmods1 $+			  tcSccs (tmods1+++tmods) (tscc:tsccs) sccs'++    tcScc ms@(_:_) =+        do tms:>:(insts,mt) <- errmap (ctx++) $ tcModuleGroup ms+	   return (tms,mt,insts)+      where+        mns = map hsModName ms+        ctx = pp ("In module(s) "<+>fsep mns)++":\n"
+ tools/base/defs/DefinedNames.hs view
@@ -0,0 +1,82 @@+module DefinedNames(module DefinedNames,module TypedIds) where+import TypedIds+import HsIdent+--import Maybe(mapMaybe)+import Recursive++{-++This modules defines a class for extensible extraction of names+defined by declaration(s). Since the abstract syntax uses the same+type for top level declarations and the body of class definitions, we+need a separate function to extract the methods of a class.+-}++type TypedIdent i = (HsIdentI i,IdTy i)++class DefinedNames i def | def->i where+  definedNames :: def -> [TypedIdent i]++class ClassMethods i def | def->i where+  classMethods :: i -> Int -> def -> [TypedIdent i]++class ContextSize c where contextSize :: c -> Int++{-++Some declarations have no explicit name in the concrete syntax, but can+be assigned an automatically generated name.+-}+class AddName i d | d->i where addName :: d -> d; addName=id++{-++Default methods are part of class declarations in the Haskell syntax, but+after type checking we treat them as separate top-level entities with their+own names, so we need to be able to change their names...+-}+class MapDefinedNames i def | def->i where+  mapDefinedNames :: (i->i) -> def->def++{-++Instances for collecting defined names from lists and pairs of things:+-}+instance DefinedNames i d => DefinedNames i [d] where+  definedNames = concatMap definedNames++instance ClassMethods i d => ClassMethods i [d] where+  classMethods c cnt = concatMap (classMethods c cnt)++instance AddName i d => AddName i [d] where+  addName = map addName++instance MapDefinedNames i d => MapDefinedNames i [d] where+  mapDefinedNames = map . mapDefinedNames++instance (DefinedNames i a, DefinedNames i b) => DefinedNames i (a,b) where+    definedNames (x,y)      = definedNames x ++ definedNames y+--    classMethods c (x,y)    = classMethods c x ++ classMethods c y++{-++Auxiliary functions for extracting particular kinds of names:+-}+definedVars ds = filter isHsVar . definedValues $ ds -- hmm+definedValues' ds = filter (isValue.snd) . definedNames $ ds+definedValues ds = map fst . definedValues' $ ds+definedType tp = c where [(HsCon c,_)] = definedNames tp ++{-++Auxiliary functions to simplify the definition of instances of #DefinedNames#:+-}+definedNamesRec x = definedNames (struct x)+classMethodsRec i cnt = classMethods i cnt . struct+mapDefinedNamesRec f = mapRec (mapDefinedNames f)+addNameRec x = mapRec addName x++value qn = (HsVar qn,Value)+-- con t defty cs n = (HsCon n,ConstrOf t defty cs)+con t defty n = (HsCon n,ConstrOf t defty)++field t tyinfo n = (HsVar n,FieldOf t tyinfo)+method c cnt ms n = (HsVar n,MethodOf c cnt ms)+-- tcon n defty cs fs = (HsCon n,Type defty cs fs)+tcon n tyinfo = (HsCon n, Type tyinfo)+classname c cnt methods = (HsCon c, Class cnt methods)+
+ tools/base/defs/DefinedNamesBase.hs view
@@ -0,0 +1,24 @@+module DefinedNamesBase(module DefinedNames) where+			-- all instances are exported anyway...+import Syntax(HsDeclI,HsTypeI,HsPatI)+import DefinedNames+import DefinedNamesBaseStruct()++{-++This module contains just the knot tying definitions for+the base syntax. The reusable instances for the base structure+are located in DefinedNamesBaseStruct.+-}++instance DefinedNames i    (HsDeclI i) where definedNames = definedNamesRec+instance ClassMethods i    (HsDeclI i) where classMethods = classMethodsRec+instance MapDefinedNames i (HsDeclI i) where mapDefinedNames= mapDefinedNamesRec+instance DefinedNames i    (HsPatI  i) where definedNames = definedNamesRec+instance MapDefinedNames i (HsPatI  i) where mapDefinedNames= mapDefinedNamesRec++-- Only for type patterns:+instance DefinedNames i (HsTypeI i) where  definedNames = definedNamesRec++instance AddName i (HsDeclI i) where addName = addNameRec++instance ContextSize [a] where contextSize = length
+ tools/base/defs/DefinedNamesBaseStruct.hs view
@@ -0,0 +1,123 @@+{-++Instances for extracting defined names from the nonrecursive +base language structures.+-}+module DefinedNamesBaseStruct where+import BaseSyntax+import DefinedNames+import HsIdent (getHSName)++instance DefinedNames i ds => DefinedNames i (HsModuleI m i' ds) where+  definedNames = definedNames . hsModDecls -- hmm++instance ClassMethods i (DI i e p ds t c tp) where+    classMethods cname cnt d =+      case d of +        (HsTypeSig s nms _ _) -> map (method cname cnt nms) nms+        _                   -> [] ++instance AddName i (DI i e p ds t c tp)++instance (DefinedNames i tp, ClassMethods i ds, ContextSize c, DefinedNames i p)+       => DefinedNames i (DI i e p ds t c tp) where+    definedNames d =+      case d of+        HsTypeDecl s tp t              -> dataNames tp Synonym []+        HsNewTypeDecl s ctx tp cd drv  -> dataNames tp Newtype [cd]+        HsDataDecl s ctx tp cds drv    -> dataNames tp Data cds+        HsClassDecl s c tp fd ds       -> classNames tp c ds+        HsInstDecl s optn c tp ds      -> [] -- !!+        HsDefaultDecl s t              -> []+        HsTypeSig s nms c t            -> []+        HsFunBind s (match:_)          -> [matchName match]+        HsPatBind s p rhs ds           -> definedNames p+        HsInfixDecl s fixity names     -> []++        --HsPrimitiveTypeDecl s ctx tp   -> definedNames tp+        HsPrimitiveTypeDecl s ctx tp   -> dataNames tp Primitive []+        HsPrimitiveBind s nm tp        -> [value nm]+        _ -> []++      where +        dataNames tp defty cds = tcon t tyinfo:cons++fields+          where+            tyinfo = TypeInfo +                { defType       = Just defty+                , constructors  = cs+                , fields        = fs +                } +    +            cons    = map (con t tyinfo . conName) cs+            fields  = map (field t tyinfo) fs+            cs      = map conNameArity cds+            fs      = concatMap fieldNames cds+            t       = definedType tp+    +            conNameArity c =+              case c of +                HsConDecl s _ _ n args -> ConInfo {conName=n,+					           conArity=length args,+					           conFields=Nothing}+                HsRecDecl s _ _ n fields -> ConInfo {conName=n,+						     conArity=length fs,+						     conFields=Just fs}+		  where fs = concatMap fst fields+            fieldNames c =+              case c of +                HsConDecl s _ _ n types -> []+                HsRecDecl s _ _ n fields -> concatMap fst fields +    +        classNames tp ctx ds =+              classname c n (map (getHSName . fst) methods) : methods+            where+	      n = contextSize ctx -- number of superclasses+              methods = classMethods c n ds+              c = definedType tp+    +        matchName (HsMatch s n _ _ _) = value n+++-- Limited to function/pattern bindings. It is used to rename default methods...+instance MapDefinedNames i p => MapDefinedNames i (DI i e p ds t c tp) where+  mapDefinedNames f d =+      case d of+        HsPatBind s p rhs ds -> HsPatBind s (m p) rhs ds+	_ -> mapDI2 f id id id id id id id d+    where m x = mapDefinedNames f x+++-- Meaningful for type patterns (types on the lhs in definitions) only:+instance DefinedNames i tp => DefinedNames i (TI i tp) where+  -- no need to define classMethods+  definedNames t =+      case t of+        HsTyApp f x -> definedNames f+        HsTyCon nm  -> [ tcon nm blankTypeInfo ]  +        _ -> [] -- hmm, report error?++{-++For patterns, #definedNames# should return the identifiers that are bound by+the pattern, i.e., variables, but not constructors and field labels.+-}+instance DefinedNames i p => DefinedNames i (PI i p) where+  -- no need to define classMethods+  definedNames p =+      case p of+        HsPRec c fields -> definedNames fields -- (*)+	_ -> accPI2 ((:).value) (const id) ((++).definedNames) p []++      -- (*) This is treated specially, since accPI2 includes fnm in the result++instance DefinedNames i p => DefinedNames i (HsFieldI i p) where+  definedNames (HsField f p) = definedNames p+++instance MapDefinedNames i p => MapDefinedNames i (PI i p) where+  mapDefinedNames f p =+      case p of+        HsPRec c fields -> HsPRec c (m fields)+        _ -> mapPI2 f id m p+    where m x = mapDefinedNames f x++instance MapDefinedNames i p => MapDefinedNames i (HsFieldI i p) where+  mapDefinedNames f (HsField field p) = HsField field (mapDefinedNames f p)
+ tools/base/defs/FiniteMap1.hs view
@@ -0,0 +1,902 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  FiniteMap+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- NOTE: Data.FiniteMap is DEPRECATED, please use "Data.Map" instead.+--+-- A finite map implementation, derived from the paper:+-- 	   /Efficient sets: a balancing act/, S. Adams,+-- 	   Journal of functional programming 3(4) Oct 1993, pp553-562+--+-----------------------------------------------------------------------------++-- ToDo: clean up, remove the COMPILING_GHC stuff.++-- The code is SPECIALIZEd to various highly-desirable types (e.g., Id)+-- near the end (only \tr{#ifdef COMPILING_GHC}).++#ifdef COMPILING_GHC+#include "HsVersions.h"+#define IF_NOT_GHC(a) {--}+#else+#define ASSERT(e) {--}+#define IF_NOT_GHC(a) a+#define COMMA ,+#define _tagCmp compare+#define _LT LT+#define _GT GT+#define _EQ EQ+#endif++#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)/* NB NB NB */+#define OUTPUTABLE_key , Outputable key+#else+#define OUTPUTABLE_key {--}+#endif++module FiniteMap1+  (+	-- * The @FiniteMap@ type+	FiniteMap,		-- abstract type++	-- * Construction+	emptyFM, unitFM, listToFM,++	-- * Lookup operations+	lookupFM, lookupWithDefaultFM,+	elemFM,++	-- * Adding elements+	addToFM,+	addToFM_C,+	addListToFM,+	addListToFM_C,++	-- * Deleting elements+	IF_NOT_GHC(delFromFM COMMA)+	delListFromFM,++	-- * Combination+	plusFM,+	plusFM_C,++	-- * Extracting information+	fmToList, keysFM, eltsFM,+	sizeFM, isEmptyFM,++	-- * Other operations+	minusFM,+	foldFM,+	IF_NOT_GHC(intersectFM COMMA)+	IF_NOT_GHC(intersectFM_C COMMA)+	IF_NOT_GHC(mapFM COMMA filterFM COMMA)++	foldFM_GE, fmToList_GE, keysFM_GE, eltsFM_GE,+	foldFM_LE, fmToList_LE, keysFM_LE, eltsFM_LE,++        minFM, maxFM,++#ifdef COMPILING_GHC+	, bagToFM+#endif+    ) where++import Prelude -- necessary to get dependencies right++import Data.Maybe ( isJust )+#ifdef __GLASGOW_HASKELL__+import GHC.Base+import Data.Typeable+import Data.Generics.Basics+import Data.Generics.Instances+#endif++#ifdef __HADDOCK__+import Prelude+#endif++#ifdef COMPILING_GHC+IMP_Ubiq(){-uitous-}+# ifdef DEBUG+import Pretty+# endif+import Bag	( foldBag )++# if ! OMIT_NATIVE_CODEGEN+#  define IF_NCG(a) a+# else+#  define IF_NCG(a) {--}+# endif+#endif++-- SIGH: but we use unboxed "sizes"...+#if __GLASGOW_HASKELL__+#define IF_GHC(a,b) a+#else /* not GHC */+#define IF_GHC(a,b) b+#endif /* not GHC */++++-- ---------------------------------------------------------------------------+-- The signature of the module++-- | An empty 'FiniteMap'.+emptyFM		:: FiniteMap key elt++-- | A 'FiniteMap' containing a single mapping+unitFM		:: key -> elt -> FiniteMap key elt++-- | Makes a 'FiniteMap' from a list of @(key,value)@ pairs. In the+-- case of duplicates, the last is taken+listToFM	:: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt++#ifdef COMPILING_GHC+bagToFM		:: (Ord key OUTPUTABLE_key) => Bag (key,elt) -> FiniteMap key elt+			-- In the case of duplicates, who knows which is taken+#endif++--	ADDING AND DELETING++-- | Adds an element to a 'FiniteMap'.  Any previous mapping with the same+-- key is overwritten.+addToFM		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> elt  -> FiniteMap key elt++-- | Adds a list of elements to a 'FiniteMap', in the order given in+-- the list.  Overwrites previous mappings.+addListToFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt++		   -- Combines with previous binding+		   -- In the combining function, the first argument is the "old" element,+		   -- while the second is the "new" one.++-- | Adds an element to a 'FiniteMap'.  If there is already an element+-- with the same key, then the specified combination function is used+-- to calculate the new value. The already present element is passed as+-- the first argument and the new element to add as second.+addToFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)+			   -> FiniteMap key elt -> key -> elt+			   -> FiniteMap key elt++-- | A list version of 'addToFM_C'.  The elements are added in the+-- order given in the list.+addListToFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)+			   -> FiniteMap key elt -> [(key,elt)]+			   -> FiniteMap key elt++-- | Deletes an element from a 'FiniteMap'.  If there is no element with+-- the specified key, then the original 'FiniteMap' is returned.+delFromFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key   -> FiniteMap key elt++-- | List version of 'delFromFM'.+delListFromFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [key] -> FiniteMap key elt++-- | Combine two 'FiniteMap's.  Mappings in the second argument shadow+-- those in the first.+plusFM		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt+			   -> FiniteMap key elt++-- | Combine two 'FiniteMap's.  The specified combination function is+-- used to calculate the new value when there are two elements with+-- the same key.+plusFM_C	:: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)+			   -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt++-- | @(minusFM a1 a2)@ deletes from @a1@ any mappings which are bound in @a2@+minusFM		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt1 -> FiniteMap key elt2 -> FiniteMap key elt1++-- | @(intersectFM a1 a2)@ returns a new 'FiniteMap' containing+-- mappings from @a1@ for which @a2@ also has a mapping with the same+-- key.+intersectFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt++-- | Returns the intersection of two mappings, using the specified+-- combination function to combine values.+intersectFM_C	:: (Ord key OUTPUTABLE_key) => (elt1 -> elt2 -> elt3)+			   -> FiniteMap key elt1 -> FiniteMap key elt2 -> FiniteMap key elt3++--	MAPPING, FOLDING, FILTERING+foldFM		:: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a+mapFM		:: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2+filterFM	:: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool)+			   -> FiniteMap key elt -> FiniteMap key elt++--	INTERROGATING+sizeFM		:: FiniteMap key elt -> Int+isEmptyFM	:: FiniteMap key elt -> Bool++-- | Returns 'True' if the specified @key@ has a mapping in this+-- 'FiniteMap', or 'False' otherwise.+elemFM		:: (Ord key OUTPUTABLE_key) => key -> FiniteMap key elt -> Bool++-- | Looks up a key in a 'FiniteMap', returning @'Just' v@ if the key+-- was found with value @v@, or 'Nothing' otherwise.+lookupFM	:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Maybe elt++-- | Looks up a key in a 'FiniteMap', returning @elt@ if the specified+-- @key@ was not found.+lookupWithDefaultFM+		:: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> elt -> key -> elt+		-- lookupWithDefaultFM supplies a "default" elt+		-- to return for an unmapped key++--	LISTIFYING++-- | Convert a 'FiniteMap' to a @[(key, elt)]@ sorted by 'Ord' key+--+fmToList	:: FiniteMap key elt -> [(key,elt)]++-- | Extract the keys from a 'FiniteMap', in the order of the keys, so+--+-- > keysFM == map fst . fmToList+--+keysFM		:: FiniteMap key elt -> [key]++-- | Extract the elements from a 'FiniteMap', in the order of the keys, so+--+-- > eltsFM == map snd . fmToList+--+eltsFM		:: FiniteMap key elt -> [elt]++-- ---------------------------------------------------------------------------+-- The @FiniteMap@ data type, and building of same++-- Invariants about @FiniteMap@:+--+-- *  all keys in a FiniteMap are distinct+--+-- * all keys in left  subtree are $<$ key in Branch and+--   all keys in right subtree are $>$ key in Branch+-- +-- * size field of a Branch gives number of Branch nodes in the tree+-- +-- * size of left subtree is differs from size of right subtree by a+--   factor of at most \tr{sIZE_RATIO}++-- | A mapping from @key@s to @elt@s.+data FiniteMap key elt+  = EmptyFM+  | Branch key elt	    	-- Key and elt stored here+    IF_GHC(Int#,Int{-STRICT-})	-- Size >= 1+    (FiniteMap key elt)	    	-- Children+    (FiniteMap key elt)+++emptyFM = EmptyFM+{-+emptyFM+  = Branch bottom bottom IF_GHC(0#,0) bottom bottom+  where+    bottom = panic "emptyFM"+-}++--  #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _)++unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM++listToFM = addListToFM emptyFM++#ifdef COMPILING_GHC+bagToFM = foldBag plusFM (\ (k,v) -> unitFM k v) emptyFM+#endif++instance (Show k, Show e) => Show (FiniteMap k e) where+  showsPrec p m = showsPrec p (fmToList m)++instance Functor (FiniteMap k) where+  fmap f = mapFM (const f)++#if __GLASGOW_HASKELL__++#include "Typeable.h"+INSTANCE_TYPEABLE2(FiniteMap,arrayTc,"FiniteMap")++-- This instance preserves data abstraction at the cost of inefficiency.+-- We omit reflection services for the sake of data abstraction.++instance (Data a, Data b, Ord a) => Data (FiniteMap a b) where+  gfoldl f z fm = z listToFM `f` (fmToList fm)+  toConstr _    = error "toConstr"+  gunfold _ _   = error "gunfold"+  dataTypeOf _  = mkNorepType "Data.FiniteMap.FiniteMap"++#endif+++-- ---------------------------------------------------------------------------+-- Adding to and deleting from @FiniteMaps@++addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt++addToFM_C combiner EmptyFM key elt = unitFM key elt+addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt+#ifdef __GLASGOW_HASKELL__+  = case _tagCmp new_key key of+	_LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r+	_GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)+	_EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r+#else+  | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r+  | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)+  | otherwise	  = Branch new_key (combiner elt new_elt) size fm_l fm_r+#endif++addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs++addListToFM_C combiner fm key_elt_pairs+  = foldl add fm key_elt_pairs	-- foldl adds from the left+  where+    add fmap (key,elt) = addToFM_C combiner fmap key elt+++delFromFM EmptyFM del_key = emptyFM+delFromFM (Branch key elt size fm_l fm_r) del_key+#if __GLASGOW_HASKELL__+  = case _tagCmp del_key key of+	_GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)+	_LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r+	_EQ -> glueBal fm_l fm_r+#else+  | del_key > key+  = mkBalBranch key elt fm_l (delFromFM fm_r del_key)++  | del_key < key+  = mkBalBranch key elt (delFromFM fm_l del_key) fm_r++  | key == del_key+  = glueBal fm_l fm_r+#endif++delListFromFM fm keys = foldl delFromFM fm keys++-- ---------------------------------------------------------------------------+-- Combining @FiniteMaps@++plusFM_C combiner EmptyFM fm2 = fm2+plusFM_C combiner fm1 EmptyFM = fm1+plusFM_C combiner fm1 (Branch split_key elt2 _ left right)+  = mkVBalBranch split_key new_elt+		 (plusFM_C combiner lts left)+		 (plusFM_C combiner gts right)+  where+    lts     = splitLT fm1 split_key+    gts     = splitGT fm1 split_key+    new_elt = case lookupFM fm1 split_key of+		Nothing   -> elt2+		Just elt1 -> combiner elt1 elt2++-- It's worth doing plusFM specially, because we don't need+-- to do the lookup in fm1.++plusFM EmptyFM fm2 = fm2+plusFM fm1 EmptyFM = fm1+plusFM fm1 (Branch split_key elt1 _ left right)+  = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right)+  where+    lts     = splitLT fm1 split_key+    gts     = splitGT fm1 split_key++minusFM EmptyFM fm2 = emptyFM+minusFM fm1 EmptyFM = fm1+minusFM fm1 (Branch split_key elt _ left right)+  = glueVBal (minusFM lts left) (minusFM gts right)+	-- The two can be way different, so we need glueVBal+  where+    lts = splitLT fm1 split_key		-- NB gt and lt, so the equal ones+    gts = splitGT fm1 split_key		-- are not in either.++intersectFM fm1 fm2 = intersectFM_C (\ left right -> right) fm1 fm2++intersectFM_C combiner fm1 EmptyFM = emptyFM+intersectFM_C combiner EmptyFM fm2 = emptyFM+intersectFM_C combiner fm1 (Branch split_key elt2 _ left right)++  | isJust maybe_elt1	-- split_elt *is* in intersection+  = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left)+						(intersectFM_C combiner gts right)++  | otherwise			-- split_elt is *not* in intersection+  = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right)++  where+    lts = splitLT fm1 split_key		-- NB gt and lt, so the equal ones+    gts = splitGT fm1 split_key		-- are not in either.++    maybe_elt1 = lookupFM fm1 split_key+    Just elt1  = maybe_elt1+++-- ---------------------------------------------------------------------------+-- Mapping, folding, and filtering with @FiniteMaps@++foldFM k z EmptyFM = z+foldFM k z (Branch key elt _ fm_l fm_r)+  = foldFM k (k key elt (foldFM k z fm_r)) fm_l++mapFM f EmptyFM = emptyFM+mapFM f (Branch key elt size fm_l fm_r)+  = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)++filterFM p EmptyFM = emptyFM+filterFM p (Branch key elt _ fm_l fm_r)+  | p key elt		-- Keep the item+  = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r)++  | otherwise		-- Drop the item+  = glueVBal (filterFM p fm_l) (filterFM p fm_r)+++-- ---------------------------------------------------------------------------+-- Interrogating @FiniteMaps@++--{-# INLINE sizeFM #-}+sizeFM EmptyFM		     = 0+sizeFM (Branch _ _ size _ _) = IF_GHC(I# size, size)++isEmptyFM fm = sizeFM fm == 0++lookupFM EmptyFM key = Nothing+lookupFM (Branch key elt _ fm_l fm_r) key_to_find+#if __GLASGOW_HASKELL__+  = case _tagCmp key_to_find key of+	_LT -> lookupFM fm_l key_to_find+	_GT -> lookupFM fm_r key_to_find+	_EQ -> Just elt+#else+  | key_to_find < key = lookupFM fm_l key_to_find+  | key_to_find > key = lookupFM fm_r key_to_find+  | otherwise	  = Just elt+#endif++key `elemFM` fm+  = case (lookupFM fm key) of { Nothing -> False; Just elt -> True }++lookupWithDefaultFM fm deflt key+  = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt }+++-- ---------------------------------------------------------------------------+-- Listifying @FiniteMaps@++fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm+keysFM fm   = foldFM (\ key elt rest -> key : rest)       [] fm+eltsFM fm   = foldFM (\ key elt rest -> elt : rest)       [] fm+++-- ---------------------------------------------------------------------------+-- Bulk operations on all keys >= or <=	a certain threshold++-- | Fold through all elements greater than or equal to the supplied key,+-- in increasing order.+foldFM_GE       :: Ord key => (key -> elt -> a -> a) -> a -> key ->+   FiniteMap key elt -> a++foldFM_GE k z fr EmptyFM = z+foldFM_GE k z fr (Branch key elt _ fm_l fm_r)+  | key >= fr = foldFM_GE k (k key elt (foldFM_GE k z fr fm_r)) fr fm_l+  | otherwise = foldFM_GE k z fr fm_r++-- | List elements greater than or equal to the supplied key, in increasing+-- order+fmToList_GE      :: Ord key => FiniteMap key elt -> key ->  [(key,elt)]+fmToList_GE fm fr = foldFM_GE (\ key elt rest -> (key,elt) : rest) [] fr fm++-- | List keys greater than or equal to the supplied key, in increasing order+keysFM_GE       :: Ord key => FiniteMap key elt -> key -> [key]+keysFM_GE fm fr  = foldFM_GE (\ key elt rest -> key : rest)       [] fr fm++-- | List elements corresponding to keys greater than or equal to the supplied+-- key, in increasing order of key.+eltsFM_GE       :: Ord key => FiniteMap key elt -> key -> [elt]+eltsFM_GE fm fr  = foldFM_GE (\ key elt rest -> elt : rest)       [] fr fm++-- | Fold through all elements less than or equal to the supplied key,+-- in decreasing order.+foldFM_LE       :: Ord key => (key -> elt -> a -> a) -> a -> key ->+   FiniteMap key elt -> a+foldFM_LE k z fr EmptyFM = z+foldFM_LE k z fr (Branch key elt _ fm_l fm_r)+  | key <= fr = foldFM_LE k (k key elt (foldFM_LE k z fr fm_l)) fr fm_r+  | otherwise = foldFM_LE k z fr fm_l++-- | List elements greater than or equal to the supplied key, in decreasing+-- order+fmToList_LE      :: Ord key => FiniteMap key elt -> key ->  [(key,elt)]+fmToList_LE fm fr = foldFM_LE (\ key elt rest -> (key,elt) : rest) [] fr fm++-- | List keys greater than or equal to the supplied key, in decreasing order+keysFM_LE       :: Ord key => FiniteMap key elt -> key -> [key]+keysFM_LE fm fr  = foldFM_LE (\ key elt rest -> key : rest)       [] fr fm++-- | List elements corresponding to keys greater than or equal to the supplied+-- key, in decreasing order of key.+eltsFM_LE       :: Ord key => FiniteMap key elt -> key -> [elt]+eltsFM_LE fm fr  = foldFM_LE (\ key elt rest -> elt : rest)       [] fr fm++-- ---------------------------------------------------------------------------+-- Getting minimum and maximum key out.+-- ---------------------------------------------------------------------------++-- | Extract minimum key, or Nothing if the map is empty.+minFM :: Ord key => FiniteMap key elt -> Maybe key+minFM EmptyFM = Nothing+minFM (Branch key _ _ fm_l _) =+   case minFM fm_l of+      Nothing -> Just key+      Just key1 -> Just key1++-- | Extract maximum key, or Nothing if the map is empty.+maxFM :: Ord key => FiniteMap key elt -> Maybe key+maxFM EmptyFM = Nothing+maxFM (Branch key _ _ _ fm_r) =+   case maxFM fm_r of+      Nothing -> Just key+      Just key1 -> Just key1+++-- ---------------------------------------------------------------------------+-- The implementation of balancing++-- Basic construction of a @FiniteMap@:++-- @mkBranch@ simply gets the size component right.  This is the ONLY+-- (non-trivial) place the Branch object is built, so the ASSERTion+-- recursively checks consistency.  (The trivial use of Branch is in+-- @unitFM@.)++sIZE_RATIO :: Int+sIZE_RATIO = 5++mkBranch :: (Ord key OUTPUTABLE_key) 		-- Used for the assertion checking only+	 => Int+	 -> key -> elt+	 -> FiniteMap key elt -> FiniteMap key elt+	 -> FiniteMap key elt++mkBranch which key elt fm_l fm_r+  = --ASSERT( left_ok && right_ok && balance_ok )+#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)+    if not ( left_ok && right_ok && balance_ok ) then+	pprPanic ("mkBranch:"++show which) (ppAboves [ppr PprDebug [left_ok, right_ok, balance_ok],+				       ppr PprDebug key,+				       ppr PprDebug fm_l,+				       ppr PprDebug fm_r])+    else+#endif+    let+	result = Branch key elt (unbox (1 + left_size + right_size)) fm_l fm_r+    in+--    if sizeFM result <= 8 then+	result+--    else+--	pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) (+--	result+--	)+  where+    left_ok  = case fm_l of+		EmptyFM		         -> True+		Branch left_key _ _ _ _  -> let+						biggest_left_key = fst (findMax fm_l)+					    in+					    biggest_left_key < key+    right_ok = case fm_r of+		EmptyFM		         -> True+		Branch right_key _ _ _ _ -> let+						smallest_right_key = fst (findMin fm_r)+					    in+					    key < smallest_right_key+    balance_ok = True -- sigh+{- LATER:+    balance_ok+      = -- Both subtrees have one or no elements...+	(left_size + right_size <= 1)+-- NO	      || left_size == 0  -- ???+-- NO	      || right_size == 0 -- ???+    	-- ... or the number of elements in a subtree does not exceed+	-- sIZE_RATIO times the number of elements in the other subtree+      || (left_size  * sIZE_RATIO >= right_size &&+    	  right_size * sIZE_RATIO >= left_size)+-}++    left_size  = sizeFM fm_l+    right_size = sizeFM fm_r++#if __GLASGOW_HASKELL__+    unbox :: Int -> Int#+    unbox (I# size) = size+#else+    unbox :: Int -> Int+    unbox x = x+#endif+++-- ---------------------------------------------------------------------------+-- {\em Balanced} construction of a @FiniteMap@++-- @mkBalBranch@ rebalances, assuming that the subtrees aren't too far+-- out of whack.++mkBalBranch :: (Ord key OUTPUTABLE_key)+	    => key -> elt+	    -> FiniteMap key elt -> FiniteMap key elt+	    -> FiniteMap key elt++mkBalBranch key elt fm_L fm_R++  | size_l + size_r < 2+  = mkBranch 1{-which-} key elt fm_L fm_R++  | size_r > sIZE_RATIO * size_l	-- Right tree too big+  = case fm_R of+	Branch _ _ _ fm_rl fm_rr+		| sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R+		| otherwise	   	          -> double_L fm_L fm_R+	-- Other case impossible++  | size_l > sIZE_RATIO * size_r	-- Left tree too big+  = case fm_L of+	Branch _ _ _ fm_ll fm_lr+		| sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R+		| otherwise		          -> double_R fm_L fm_R+	-- Other case impossible++  | otherwise				-- No imbalance+  = mkBranch 2{-which-} key elt fm_L fm_R++  where+    size_l   = sizeFM fm_L+    size_r   = sizeFM fm_R++    single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)+	= mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr++    double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)+	= mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key   elt   fm_l   fm_rll)+				 (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)++    single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r+	= mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r)++    double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r+	= mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll  fm_lrl)+				 (mkBranch 12{-which-} key   elt   fm_lrr fm_r)+++mkVBalBranch :: (Ord key OUTPUTABLE_key)+	     => key -> elt+	     -> FiniteMap key elt -> FiniteMap key elt+	     -> FiniteMap key elt++-- Assert: in any call to (mkVBalBranch_C comb key elt l r),+--	   (a) all keys in l are < all keys in r+--	   (b) all keys in l are < key+--	   (c) all keys in r are > key++mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt+mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt++mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)+		     fm_r@(Branch key_r elt_r _ fm_rl fm_rr)+  | sIZE_RATIO * size_l < size_r+  = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr++  | sIZE_RATIO * size_r < size_l+  = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r)++  | otherwise+  = mkBranch 13{-which-} key elt fm_l fm_r++  where+    size_l = sizeFM fm_l+    size_r = sizeFM fm_r++-- ---------------------------------------------------------------------------+-- Gluing two trees together++-- @glueBal@ assumes its two arguments aren't too far out of whack, just+-- like @mkBalBranch@.  But: all keys in first arg are $<$ all keys in+-- second.++glueBal :: (Ord key OUTPUTABLE_key)+	=> FiniteMap key elt -> FiniteMap key elt+	-> FiniteMap key elt++glueBal EmptyFM fm2 = fm2+glueBal fm1 EmptyFM = fm1+glueBal fm1 fm2+	-- The case analysis here (absent in Adams' program) is really to deal+	-- with the case where fm2 is a singleton. Then deleting the minimum means+	-- we pass an empty tree to mkBalBranch, which breaks its invariant.+  | sizeFM fm2 > sizeFM fm1+  = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)++  | otherwise+  = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2+  where+    (mid_key1, mid_elt1) = findMax fm1+    (mid_key2, mid_elt2) = findMin fm2++-- @glueVBal@ copes with arguments which can be of any size.+-- But: all keys in first arg are $<$ all keys in second.++glueVBal :: (Ord key OUTPUTABLE_key)+	 => FiniteMap key elt -> FiniteMap key elt+	 -> FiniteMap key elt++glueVBal EmptyFM fm2 = fm2+glueVBal fm1 EmptyFM = fm1+glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)+	 fm_r@(Branch key_r elt_r _ fm_rl fm_rr)+  | sIZE_RATIO * size_l < size_r+  = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr++  | sIZE_RATIO * size_r < size_l+  = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r)++  | otherwise		-- We now need the same two cases as in glueBal above.+  = glueBal fm_l fm_r+  where+    size_l = sizeFM fm_l+    size_r = sizeFM fm_r+++-- ---------------------------------------------------------------------------+-- Local utilities++splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt++-- splitLT fm split_key  =  fm restricted to keys <  split_key+-- splitGT fm split_key  =  fm restricted to keys >  split_key++splitLT EmptyFM split_key = emptyFM+splitLT (Branch key elt _ fm_l fm_r) split_key+#if __GLASGOW_HASKELL__+  = case _tagCmp split_key key of+	_LT -> splitLT fm_l split_key+	_GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)+	_EQ -> fm_l+#else+  | split_key < key = splitLT fm_l split_key+  | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key)+  | otherwise	    = fm_l+#endif++splitGT EmptyFM split_key = emptyFM+splitGT (Branch key elt _ fm_l fm_r) split_key+#if __GLASGOW_HASKELL__+  = case _tagCmp split_key key of+	_GT -> splitGT fm_r split_key+	_LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r+	_EQ -> fm_r+#else+  | split_key > key = splitGT fm_r split_key+  | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r+  | otherwise	    = fm_r+#endif++findMin :: FiniteMap key elt -> (key,elt)+findMin (Branch key elt _ EmptyFM _) = (key,elt)+findMin (Branch key elt _ fm_l    _) = findMin fm_l++deleteMin :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt+deleteMin (Branch key elt _ EmptyFM fm_r) = fm_r+deleteMin (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r++findMax :: FiniteMap key elt -> (key,elt)+findMax (Branch key elt _ _ EmptyFM) = (key,elt)+findMax (Branch key elt _ _    fm_r) = findMax fm_r++deleteMax :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt+deleteMax (Branch key elt _ fm_l EmptyFM) = fm_l+deleteMax (Branch key elt _ fm_l    fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r)+++-- ---------------------------------------------------------------------------+-- Output-ery++#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)++instance (Outputable key) => Outputable (FiniteMap key elt) where+    ppr sty fm = pprX sty fm++pprX sty EmptyFM = ppChar '!'+pprX sty (Branch key elt sz fm_l fm_r)+ = ppBesides [ppLparen, pprX sty fm_l, ppSP,+	      ppr sty key, ppSP, ppInt (IF_GHC(I# sz, sz)), ppSP,+	      pprX sty fm_r, ppRparen]+#endif++#ifndef COMPILING_GHC+instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where+  fm_1 == fm_2 = (sizeFM   fm_1 == sizeFM   fm_2) &&   -- quick test+		 (fmToList fm_1 == fmToList fm_2)++{- NO: not clear what The Right Thing to do is:+instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where+  fm_1 <= fm_2 = (sizeFM   fm_1 <= sizeFM   fm_2) &&   -- quick test+		 (fmToList fm_1 <= fmToList fm_2)+-}+#endif++-- ---------------------------------------------------------------------------+-- Efficiency pragmas for GHC++-- When the FiniteMap module is used in GHC, we specialise it for+-- \tr{Uniques}, for dastardly efficiency reasons.++#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ && !defined(REALLY_HASKELL_1_3)++{-# SPECIALIZE addListToFM+		:: FiniteMap (FAST_STRING, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt+		 , FiniteMap RdrName elt -> [(RdrName,elt)] -> FiniteMap RdrName elt+    IF_NCG(COMMA   FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)+    #-}+{-# SPECIALIZE addListToFM_C+		:: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt+		 , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt+    IF_NCG(COMMA   (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)+    #-}+{-# SPECIALIZE addToFM+		:: FiniteMap CLabel elt -> CLabel -> elt  -> FiniteMap CLabel elt+		 , FiniteMap FAST_STRING elt -> FAST_STRING -> elt  -> FiniteMap FAST_STRING elt+		 , FiniteMap (FAST_STRING, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt  -> FiniteMap (FAST_STRING, FAST_STRING) elt+		 , FiniteMap RdrName elt -> RdrName -> elt  -> FiniteMap RdrName elt+		 , FiniteMap OrigName elt -> OrigName -> elt  -> FiniteMap OrigName elt+    IF_NCG(COMMA   FiniteMap Reg elt -> Reg -> elt  -> FiniteMap Reg elt)+    #-}+{-# SPECIALIZE addToFM_C+		:: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt+		 , (elt -> elt -> elt) -> FiniteMap (OrigName, OrigName) elt -> (OrigName, OrigName) -> elt -> FiniteMap (OrigName, OrigName) elt+		 , (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt+    IF_NCG(COMMA   (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)+    #-}+{-# SPECIALIZE bagToFM+		:: Bag (FAST_STRING,elt) -> FiniteMap FAST_STRING elt+    #-}+{-# SPECIALIZE delListFromFM+		:: FiniteMap RdrName elt -> [RdrName]   -> FiniteMap RdrName elt+		 , FiniteMap OrigName elt -> [OrigName]   -> FiniteMap OrigName elt+		 , FiniteMap FAST_STRING elt -> [FAST_STRING]   -> FiniteMap FAST_STRING elt+    IF_NCG(COMMA   FiniteMap Reg elt -> [Reg]   -> FiniteMap Reg elt)+    #-}+{-# SPECIALIZE listToFM+		:: [([Char],elt)] -> FiniteMap [Char] elt+		 , [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt+		 , [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt+		 , [(OrigName,elt)] -> FiniteMap OrigName elt+    IF_NCG(COMMA   [(Reg COMMA elt)] -> FiniteMap Reg elt)+    #-}+{-# SPECIALIZE lookupFM+		:: FiniteMap CLabel elt -> CLabel -> Maybe elt+		 , FiniteMap [Char] elt -> [Char] -> Maybe elt+		 , FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt+		 , FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt+		 , FiniteMap OrigName elt -> OrigName -> Maybe elt+		 , FiniteMap (OrigName,OrigName) elt -> (OrigName,OrigName) -> Maybe elt+		 , FiniteMap RdrName elt -> RdrName -> Maybe elt+		 , FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt+    IF_NCG(COMMA   FiniteMap Reg elt -> Reg -> Maybe elt)+    #-}+{-# SPECIALIZE lookupWithDefaultFM+		:: FiniteMap FAST_STRING elt -> elt -> FAST_STRING -> elt+    IF_NCG(COMMA   FiniteMap Reg elt -> elt -> Reg -> elt)+    #-}+{-# SPECIALIZE plusFM+		:: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt+		 , FiniteMap OrigName elt -> FiniteMap OrigName elt -> FiniteMap OrigName elt+		 , FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt+    IF_NCG(COMMA   FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)+    #-}+{-# SPECIALIZE plusFM_C+		:: (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt+    IF_NCG(COMMA   (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)+    #-}++#endif /* compiling for GHC */+
+ tools/base/defs/Flags.ghc view
@@ -0,0 +1,1 @@+NameMapsBaseStruct.hs: -fallow-undecidable-instances
+ tools/base/defs/FreeNames.hs view
@@ -0,0 +1,70 @@+module FreeNames(module FreeNames,NameSpace(..)) where++import HsIdent+import TypedIds(NameSpace(..),namespace)+import List(nub)+import MUtils(mapSnd)+import DefinedNames+import Recursive++{-++This modules defines a class for extensible extraction of free names+from expressions, type expressions, etc. By free names, we mean names that+occur in an expression and need to be defined/introduced elsewhere. For+example, the constructors that appear in a pattern are considered free names,+while the variables in a pattern are considered defined names rather than+free names.++While it would make sense for method #freeNames# to return a set instead of+a list, there are currently some places in the code where the free names+are assumed to be listed in the order they appeared in the expression+(.e.g. in the definition of TiFreeNames.typeParams).+-}++type FreeName i = (HsIdentI i, NameSpace)++class Eq i => FreeNames i t | t -> i where+    freeNames :: t -> [FreeName i]++{-++Instances for collecting free names from lists, pairs and sums of things:+-}+instance FreeNames i t => FreeNames i [t] where+    freeNames  = nub . concatMap freeNames++instance (FreeNames i a, FreeNames i b) => FreeNames i (a,b) where+    freeNames (x,y) = nub (freeNames x ++ freeNames y)++instance (FreeNames i a, FreeNames i b,FreeNames i c)+       => FreeNames i (a,b,c) where+    freeNames (x,y,z) = nub (freeNames x ++ freeNames y ++ freeNames z)++instance (FreeNames i a, FreeNames i b) => FreeNames i (Either a b) where+    freeNames = either freeNames freeNames++instance FreeNames i a => FreeNames i (Maybe a) where+  freeNames = maybe [] freeNames++{-++Auxiliary functions:+-}+defs x         = mapSnd namespace . definedNames $ x+freeValues x   = map fst . filter ((==ValueNames).snd) . freeNames $ x++freeNamesRec x = freeNames (struct x)++freeCons x = filter (isHsCon.fst) . freeNames $ x+freeVars x = filter (isHsVar.fst) . freeNames $ x++istyvar (x,sp) = isHsVar x && sp==ClassOrTypeNames++-- utils ---------------------------------------++tcon = typ . HsCon+tvar = typ . HsVar+con = val . HsCon+var = val . HsVar++val x           = (x, ValueNames)+typ x           = (x, ClassOrTypeNames)+
+ tools/base/defs/FreeNamesBase.hs view
@@ -0,0 +1,17 @@+module FreeNamesBase where++import Syntax(HsDeclI,HsTypeI,HsPatI,HsExpI) +import FreeNames+import FreeNamesBaseStruct+import DefinedNamesBase++{-++This module contains just he knot tying definitions for the base syntax.+The reusable instances for the base structure are located in+ #FreeNamesBaseStruct#.+-}++instance Eq i => FreeNames i (HsDeclI i) where freeNames = freeNamesRec+instance Eq i => FreeNames i (HsPatI  i) where freeNames = freeNamesRec+instance Eq i => FreeNames i (HsExpI  i) where freeNames = freeNamesRec+instance Eq i => FreeNames i (HsTypeI i) where freeNames = freeNamesRec
+ tools/base/defs/FreeNamesBaseStruct.hs view
@@ -0,0 +1,144 @@+module FreeNamesBaseStruct where++import FreeNames+import DefinedNames(DefinedNames)++import BaseSyntax+import Lists((\\\))+import List(nub)+import TypedIds+--import AccList(accList)++import HsName+++-- modules (computes names that need to be imported)++instance FreeNames i ds => FreeNames i (HsModuleI m i ds) where+  freeNames = freeNames . hsModDecls++{-++For patterns, #freeNames# should return the identifiers that appear in the+pattern, but are not bound by the pattern, i.e., constructors and field labels.+-}+instance FreeNames i p => FreeNames i (PI i p) where+    freeNames p =+      case p of+        HsPRec i fs -> con i : freeNames fs+        _           -> accPI2 (const id) ((:).con) ((++).freeNames) p []++-- freeNotDef p = freeNames p \\\ defs p++-- record fields+instance FreeNames i p => FreeNames i (HsFieldI i p) where+  freeNames (HsField f p) = field f:freeNames p+++-- rhss+instance FreeNames i e => FreeNames i (HsRhs e) where+    freeNames x = accRhs (++) (mapRhs freeNames x) []++-- alts+instance (FreeNames i e, FreeNames i p, FreeNames i ds,+         DefinedNames i ds, DefinedNames i p)+      => FreeNames i (HsAlt e p ds) where+    freeNames (HsAlt _ p rhs ds) +        = freeNames p ++ (freeNames (rhs,ds) \\\ defs (ds,p))++-- stmts+instance ( FreeNames i e, FreeNames i p, FreeNames i ds+         , DefinedNames i p, DefinedNames i ds+         ) => FreeNames i (HsStmt e p ds) where+    freeNames stmt =+      case stmt of+        HsGenerator _ p e stmt -> freeNames (p,e) ++ (freeNames stmt \\\ defs p)+        HsQualifier   e stmt -> freeNames (e,stmt)+        HsLetStmt    ds stmt -> freeNames (stmt,ds) \\\ defs ds+        HsLast        e      -> freeNames e+++-- Since this is not a strictly accumulating function, there are many cases+-- in which accE can not be used...++-- exps+instance ( FreeNames i e, FreeNames i p, FreeNames i ds+         , FreeNames i t, FreeNames i c +         , DefinedNames i p, DefinedNames i ds +         ) => FreeNames i (EI i e p ds t c) where+    freeNames e =+      case e of+        HsLambda ps e          -> freeNames ps ++ (freeNames e \\\ defs ps)+        HsLet ds e             -> freeNames (e,ds) \\\ defs ds+        HsId n                 -> [val n]+        HsInfixApp x op z      -> val op : freeNames (x,z)+        HsCase e alts          -> freeNames (e,alts)+        HsDo stmts             -> freeNames stmts+        HsLeftSection x op     -> val op : freeNames x+        HsRightSection op y    -> val op : freeNames y+        HsListComp stmts       -> freeNames stmts+	HsRecConstr s n fs     -> con n : freeNames fs+	HsRecUpdate s e fs     -> freeNames (e,fs)++        _                      ->+            accEI bug descend bug bug descend descend e []+        where+	descend s = ((++).freeNames) s+        bug = error "freeNames at E ...: should have been handled"++-- matches+instance ( FreeNames i e, FreeNames i p, FreeNames i ds+         , DefinedNames i ds, DefinedNames i p +         ) => FreeNames i (HsMatchI i e p ds) where+    freeNames (HsMatch _ n ps rhs ds) =+        freeNames ps ++ ((freeNames (rhs,ds) \\\ defs ps) +                                \\\ (val (HsVar n) : defs ds))++-- decls +instance ( FreeNames i e, FreeNames i p, FreeNames i ds, FreeNames i t+         , FreeNames i c, FreeNames i tp+         , DefinedNames i p, DefinedNames i ds +         ) => FreeNames i (DI i e p ds t c tp) where+    freeNames d =+	case d of+	  HsTypeDecl s tps t             -> freeNames t \\\ freeNames tps+	  HsNewTypeDecl s ctx tps cd drv -> dataNames ctx tps [cd] drv+	  HsDataDecl s ctx tps cds drv   -> dataNames ctx tps cds  drv+	  HsClassDecl s c tp fdeps ds    -> freeNames (c,ds) \\\ freeNames tp -- hmm+	  HsInstDecl s optn c tp ds      -> freeNames ((c,tp),ds) \\\ freeVars tp -- hmm+	  HsDefaultDecl s t              -> freeNames t+	  HsTypeSig s nms c tp           -> freeCons (c,tp)+	  HsFunBind s matches            -> freeNames matches+	  HsPatBind s p rhs ds           -> freeNames p ++ +					      (freeNames (rhs,ds) \\\ defs (p,ds))+	  HsInfixDecl   s fixity names   -> []++  --      HsPrimitiveTypeDecl s cntxt nm   ->+  --      HsPrimitiveBind s nm t           ->++	  -- TODO+	  _                               -> []+      where+        dataNames ctx tps cds drv =+          nub (map tcon drv++freeNames (ctx,cds)) \\\ freeNames tps++instance (FreeNames i t,FreeNames i c) => FreeNames i (HsConDeclI i t c) where+  freeNames cd =+    case cd of +      HsConDecl s is c n args -> freeNames (c,args) \\\ map tvar is+      HsRecDecl s is c n fields -> freeNames (c,map snd fields) \\\ map tvar is++instance FreeNames i t => FreeNames i (HsBangType t) where+  freeNames = freeNames . unbang++instance FreeNames i t => FreeNames i (TI i t) where+  freeNames t =+    case t of+      HsTyVar v -> [tvar v]+      HsTyCon v -> [tcon v]+      HsTyForall xs ps t -> freeNames (ps,t) \\\ map tvar xs+      _ -> crushT freeNames t+++-- utils ---------------------------------------++field = var -- hmm!!
+ tools/base/defs/HEADER.html view
@@ -0,0 +1,20 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!-- This file is included by the web server in the automatically generated+     directory index.+-->+<head>+<title>Programatica Tools, tools/base/defs</title>+<link rel=parent href="../" title="Directory tools/base">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../../web/icon1.png">+</head>++<base>+<h1><img align=right src="../../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/base/defs</h2>++<p>+The README file is displayed below the directory index.
+ tools/base/defs/NameMaps.hs view
@@ -0,0 +1,101 @@+module NameMaps(module NameMaps,NameSpace(..)) where+--import StateM+import MUtils+import Recursive+import AccList+import HsName(ModuleName)+import TypedIds(NameSpace(..))++class AccNames i s | s->i where+  accNames :: (i->a->a)->s->a->a++-- Auxiliary types for the MapNames class:++data Context i = TopLevel | Local | ClassDef i | Instance i | Pattern+               | Export | Import ModuleName+               --deriving (Show)++data Role i = Def (Context i) | Sig (Context i) | Use | Logic | FieldLabel+            | ExpEnt (Maybe i)  --Just i=subordinate to i+            | ImpEnt ModuleName (Maybe i)  --Just i=subordinate to i+            --deriving (Show)++type Occurence i = (Role i,NameSpace)++instance Functor Context where+  fmap f c = case c of+	       TopLevel -> TopLevel+	       Local -> Local+	       ClassDef i -> ClassDef (f i)+	       Instance i -> Instance (f i)+	       Pattern -> Pattern++instance Functor Role where+  fmap f (Def c) = Def (fmap f c)+  fmap f (Sig c) = Sig (fmap f c)+  fmap f Use = Use+  fmap f Logic = Logic+  fmap f FieldLabel = FieldLabel+  fmap f (ExpEnt opti) = ExpEnt (fmap f opti)+  fmap f (ImpEnt m opti) = ImpEnt m (fmap f opti)++class MapNames i1 s1 i2 s2 | s1->i1,s1 i2->s2,s2->i2 where+  mapNames2 :: Context i1 ->+               (Occurence i1->i1->i2,Occurence i1->i1->i2) -> s1 -> s2+            -- (variables           ,constructors        )+  mapNames :: (i1->i2) -> s1 -> s2+  mapNames f = mapNames2 TopLevel (const f,const f)++class (Monad m,Functor m) => SeqNames m s1 s2 | s1->m s2 where+  seqNames :: s1 -> m s2++instance AccNames i s => AccNames i [s] where+  accNames = accList . accNames++instance (AccNames i a,AccNames i b) => AccNames i (a,b) where+  accNames f (a,b) = accNames f a . accNames f b++instance (AccNames i a,AccNames i b,AccNames i c) => AccNames i (a,b,c) where+  accNames f (a,b,c) = accNames f a . accNames f b . accNames f c++instance MapNames i1 s1 i2 s2 => MapNames i1 [s1] i2 [s2] where+  mapNames2 dctx = map . mapNames2 dctx+  mapNames = map . mapNames++instance MapNames i1 s1 i2 s2 => MapNames i1 (Maybe s1) i2 (Maybe s2) where+  mapNames2 dctx = fmap . mapNames2 dctx+  mapNames = fmap . mapNames++instance (MapNames i1 a1 i2 a2,MapNames i1 b1 i2 b2)+      => MapNames i1 (a1,b1) i2 (a2,b2) where+  mapNames2 dctx f (a,b) = (mapNames2 dctx f a,mapNames2 dctx f b)+  mapNames f (a,b) = (mapNames f a,mapNames f b)++instance SeqNames m s1 s2 => SeqNames m [s1] [s2] where+  seqNames = mapM seqNames++instance SeqNames m s1 s2 => SeqNames m (Maybe s1) (Maybe s2) where+  seqNames = seqMaybe . fmap seqNames++instance (SeqNames m a1 a2,SeqNames m b1 b2)+      => SeqNames m (a1,b1) (a2,b2) where+  seqNames (a1,a2) = (,) # seqNames a1 <# seqNames a2++accNamesRec f = accNames f . struct+mapNames2Rec dctx f = r . mapNames2 dctx f . struct+seqNamesRec x = r # seqNames (struct x)++mapNamesM f = seqNames . mapNames f+mapNames2M ctx f = seqNames . mapNames2 ctx f++--- utilities++pat ctx g (vf,cf) = g (vf (defval ctx)) (cf useval)+bothval = both  useval+bothtype = both (Use,ClassOrTypeNames)+both x g (f1,f2) = g (f1 x) (f2 x)+useval=(Use,ValueNames)+usetype=(Use,ClassOrTypeNames)+defval ctx=(Def ctx,ValueNames)+sigval ctx=(Sig ctx,ValueNames)+deftype ctx=(Def ctx,ClassOrTypeNames)
+ tools/base/defs/NameMapsBase.hs view
@@ -0,0 +1,25 @@+module NameMapsBase where+import NameMaps+import NameMapsBaseStruct()+import DefinedNamesBase() -- because of tp, grr+import Syntax+--import MUtils++instance AccNames i (HsDeclI i) where accNames = accNamesRec+instance AccNames i (HsExpI  i) where accNames = accNamesRec+instance AccNames i (HsPatI  i) where accNames = accNamesRec+instance AccNames i (HsTypeI i) where accNames = accNamesRec++instance MapNames i1 (HsDeclI i1) i2 (HsDeclI i2) where mapNames2 = mapNames2Rec+instance MapNames i1 (HsExpI  i1) i2 (HsExpI  i2) where mapNames2 = mapNames2Rec+instance MapNames i1 (HsPatI  i1) i2 (HsPatI  i2) where mapNames2 = mapNames2Rec+instance MapNames i1 (HsTypeI i1) i2 (HsTypeI i2) where mapNames2 = mapNames2Rec++instance (Monad m,Functor m) => SeqNames m (HsDeclI (m i)) (HsDeclI i) where+  seqNames = seqNamesRec+instance (Monad m,Functor m) => SeqNames m (HsExpI (m i)) (HsExpI i) where+  seqNames = seqNamesRec+instance (Monad m,Functor m) => SeqNames m (HsPatI (m i)) (HsPatI i) where+  seqNames = seqNamesRec+instance (Monad m,Functor m) => SeqNames m (HsTypeI (m i)) (HsTypeI i) where+  seqNames = seqNamesRec
+ tools/base/defs/NameMapsBaseStruct.hs view
@@ -0,0 +1,251 @@+module NameMapsBaseStruct where+import NameMaps+import BaseSyntax+import HasBaseName+import MUtils+import DefinedNames -- because of tp, grr++--accNamesModule f (HsModule s m e i ds) = HsModule s m e i (accNames f ds)++instance (AccNames i e,AccNames i p,AccNames i ds, AccNames i t, AccNames i c)+       => AccNames i (EI i e p ds t c) where+  accNames f = accEI f m m m m m+    where m x = accNames f x++instance AccNames i p => AccNames i (PI i p) where+  accNames f = accPI f (accNames f)++instance (AccNames i e, AccNames i p, AccNames i ds, AccNames i t, AccNames i c,+	  AccNames i tp)+       => AccNames i (DI i e p ds t c tp) where+  accNames f = accDI f m m m m m m+    where m x = accNames f x++instance AccNames i t => AccNames i (TI i t) where+  accNames f = accTI f (accNames f)++instance AccNames i (HsIdentI i) where accNames = accHsIdent++-----------------------------------------------------------------------------+mapNamesModule2 d f (HsModule s mn e i ds) =+    HsModule s mn (m2 e) (m2 i) (m2 ds)+  where+    m2 x = mapNames2 d f x++{-+-- This could be error prone...+instance MapNames i1 (HsIdentI i1) i2 (HsIdentI i2) where+  mapNames = fmap+  --mapNames2  = ?? -- unknown namespace+-}++instance (HasBaseName m ModuleName, MapNames i1 ds1 i2 ds2)+      => MapNames i1 (HsModuleI m i1 ds1) i2 (HsModuleI m i2 ds2) where+  mapNames2 = mapNamesModule2++instance MapNames i1 (HsExportSpecI m i1) i2 (HsExportSpecI m i2) where+  mapNames2 dctx f@(vf,cf) e =+    case e of+      ModuleE mn -> ModuleE mn+      EntE e -> EntE (mapNames2 Export f e)++instance MapNames i1 (EntSpec i1) i2 (EntSpec i2) where+  mapNames2 dctx f@(vf,cf) e =+    -- pre: dctx==Export || dctx==Import m+    case e of+      Var i -> Var (vf eval i)+      Abs i -> Abs (cf etype i)+      AllSubs i -> AllSubs (cf etype i)+      ListSubs i is -> ListSubs (cf etype i) (map (subent i) is)+    where+      eval = (prim,ValueNames)+      etype = (prim,ClassOrTypeNames)+      subent i = both (sub i,ValueNames) mapHsIdent2 f++      prim = ent dctx Nothing+      sub  = ent dctx . Just++      ent Export = ExpEnt+      ent (Import m) = ImpEnt m+      ent _ = const Use -- entity specification in unexpected context!!++instance HasBaseName m ModuleName => +         MapNames i1 (HsImportDeclI m i1) i2 (HsImportDeclI m i2) where+  mapNames2 dctx f (HsImportDecl s m q as optspec) =+      HsImportDecl s m q as (fmap (apSnd (mapNames2 d f)) optspec)+    where d = Import (getBaseName m)++instance (MapNames i1 e1 i2 e2,+	  MapNames i1 p1 i2 p2,+	  MapNames i1 ds1 i2 ds2,+	  MapNames i1 t1 i2 t2,+	  MapNames i1 c1 i2 c2)+       => MapNames i1 (EI i1 e1 p1 ds1 t1 c1)+		   i2 (EI i2 e2 p2 ds2 t2 c2) where+  mapNames2 dctx f e =+      case e of+        HsRecConstr s i fs -> HsRecConstr s (snd f useval i) (m fs)+        HsRecUpdate s e fs -> HsRecUpdate s (m e) (m fs)+        _ -> bothval mapEI2 f m mp ml ml ml e+    where+      m x = m' dctx x+      ml x = m' Local x+      mp x = m' Pattern x+      m' dctx = mapNames2 dctx f++instance MapNames i1 p1 i2 p2 => MapNames i1 (PI i1 p1) i2 (PI i2 p2) where+  mapNames2 dctx f@(vf,cf) p =+    case p of+      HsPRec i p -> HsPRec (snd f useval i) (m p)+      _ -> mapPI2 vf' (cf useval) m p+    where+      m x = mapNames2 dctx f x+      --vf' = vf (defval dctx)+      vf' = case dctx of ClassDef _ -> vf useval+			 _ -> vf (defval dctx)++instance MapNames i1 e1 i2 e2+      => MapNames i1 (HsFieldI i1 e1) i2 (HsFieldI i2 e2) where+  mapNames2 dctx f = mapFieldI (fst f (FieldLabel,ValueNames)) m+    where+      m = mapNames2 dctx f++-- All identifiers i in EI i ... and PI i p denote values+-- All identifiers i in TI i t denote types ++instance (MapNames i1 e1 i2 e2,+	  MapNames i1 p1 i2 p2,+	  MapNames i1 ds1 i2 ds2,+	  MapNames i1 t1 i2 t2,+	  MapNames i1 c1 i2 c2,+	  MapNames i1 tp1 i2 tp2,+	  DefinedNames i1 t1,+	  DefinedNames i1 tp1)+       => MapNames i1 (DI i1 e1 p1 ds1 t1 c1 tp1)+		   i2 (DI i2 e2 p2 ds2 t2 c2 tp2) where+  mapNames2 dctx f@(vf,cf) d =+      case d of+        HsTypeDecl s tp t -> HsTypeDecl s (m tp) (ml t)+        HsNewTypeDecl s ctx tp cd ns ->+             HsNewTypeDecl s (ml ctx) (m tp) (map2conD cd) (map tconf ns)+        HsDataDecl s ctx tp cds ns  ->+             HsDataDecl s (ml ctx) (m tp) (map map2conD cds) (map tconf ns)+	HsClassDecl s ctx tp fdeps ds ->+	    HsClassDecl s (ml ctx) (m tp) (mapFunDeps tvarf fdeps) (mc c1 ds)+	  where c1 = definedType tp +        HsInstDecl s optn ctx tp ds ->+	     HsInstDecl s (fmap vdef optn) (ml ctx) (ml tp) (mi c1 ds)+	  where c1 = definedType tp +		--c2 = tconf c1+	HsDefaultDecl s ts -> HsDefaultDecl s (ml ts)+	HsTypeSig s is ctx tp -> HsTypeSig s (map vf is) (ml ctx) (ml tp)+          where+	    vf = case dctx of ClassDef _ -> vdef+	                      _          -> vsig+	HsInfixDecl s fixity is ->+            HsInfixDecl s fixity (map (bothsigval mapHsIdent2 f) is)+        HsFunBind s ms -> HsFunBind s (m ms)+        HsPrimitiveTypeDecl s ctx tp  ->+            HsPrimitiveTypeDecl s (ml ctx) (m tp)+	HsPrimitiveBind s i tp -> HsPrimitiveBind s (vdef i) (ml tp)+        _ -> bothval mapDI2 f m m ml m m m d+    where+      m x = m' dctx x+      mc c x = m' (ClassDef c) x+      mi c x = m' (Instance c) x+      ml x = m' Local x+      m' dctx = mapNames2 dctx f+      tconf = cf usetype+      tvarf = vf usetype+      --vuse = vf useval+      vdef  = vf (defval dctx)+      vsig  = vf (sigval dctx)+      cdef  = cf (defval dctx)+      --bothdefval = both (defval dctx)+      bothsigval = both (sigval dctx)++      map2conD (HsConDecl s is c n args) =+          HsConDecl s (localq f is) (ml c) (cdef n) (ml args)+      map2conD (HsRecDecl s is c n fields) =+          HsRecDecl s (localq f is) (ml c) (cdef n) (map mf fields)+        where+          mf (is,t) = (map vdef is,ml t)++instance MapNames i1 t1 i2 t2+      => MapNames i1 (HsBangType t1) i2 (HsBangType t2) where+  mapNames2 dctx f = mapBangType (mapNames2 dctx f)++instance (MapNames i1 e1 i2 e2,+	  MapNames i1 p1 i2 p2,+	  MapNames i1 ds1 i2 ds2)+       => MapNames i1 (HsMatchI i1 e1 p1 ds1)+		   i2 (HsMatchI i2 e2 p2 ds2) where+  mapNames2 dctx f@(vf,_) (HsMatch s n ps rhs ds) =+      HsMatch s (vf' n) (mp ps) (mapRhs m rhs) (ml ds)+    where+      vf' = case dctx of ClassDef _ -> vuse+			 --Instance _ -> vdef+			 _ -> vdef+      m x = m' dctx x+      ml x = m' Local x+      mp x = m' Pattern x+      m' dctx = mapNames2 dctx f+      vdef = vf (defval dctx)+      vuse = vf useval++{-++The TI structure is used for both lhss of type definitions and for type+expressions. We set the context to Local when entering a type expression,+and to TopLevel when entering the lhs of a type defintion.+-}+instance MapNames i1 t1 i2 t2 => MapNames i1 (TI i1 t1) i2 (TI i2 t2) where+  mapNames2 dctx f@(vf,cf) t =+      case t of+        HsTyForall vs ps t' -> HsTyForall (localq f vs) (m ps) (m t')+        _ -> mapTI2 vf' cf' (mapNames2 dctx f) t+    where+      m x = mapNames2 dctx f x++      (vf',cf') = case dctx of+		    Local -> (vf usetype,cf usetype)+		    _     -> (vf (deftype Pattern),cf (deftype dctx))++localq (vf,_) = map (vf (deftype Pattern))++--------------------------------------------------------------------------------++instance SeqNames m ds1 ds2+      => SeqNames m (HsModuleI mn (m i) ds1) (HsModuleI mn i ds2) where+  seqNames (HsModule s m e i ds) =+     HsModule s m # seqNames e <# seqNames i <# seqNames ds++instance (Functor m,Monad m) => SeqNames m (EntSpec (m i)) (EntSpec i) where+  seqNames = seqEntSpec++instance (Functor m,Monad m)+      => SeqNames m (HsImportDeclI mn (m i)) (HsImportDeclI mn i) where+  seqNames = seqImportDecl++instance (Functor m,Monad m)+      => SeqNames m (HsExportSpecI mn (m i)) (HsExportSpecI mn i) where+  seqNames = seqExportSpec++instance (SeqNames m e1 e2,SeqNames m p1 p2,SeqNames m ds1 ds2,+          SeqNames m t1 t2,SeqNames m c1 c2)+      => SeqNames m (EI (m i) e1 p1 ds1 t1 c1) (EI i e2 p2 ds2 t2 c2) where+  seqNames = seqEI . mapEI id sn sn sn sn sn++instance SeqNames m p1 p2 => SeqNames m (PI (m i) p1) (PI i p2) where+  seqNames = seqPI . mapPI id sn++instance (SeqNames m e1 e2,SeqNames m p1 p2,SeqNames m ds1 ds2,+          SeqNames m t1 t2,SeqNames m c1 c2,SeqNames m tp1 tp2)+      => SeqNames m (DI (m i) e1 p1 ds1 t1 c1 tp1) (DI i e2 p2 ds2 t2 c2 tp2) where+  seqNames = seqDI . mapDI id sn sn sn sn sn sn++instance SeqNames m t1 t2 => SeqNames m (TI (m i) t1) (TI i t2) where+  seqNames = seqTI . mapT sn++r x = return x+sn x = seqNames x+--------------------------------------------------------------------------------
+ tools/base/defs/PNT.hs view
@@ -0,0 +1,63 @@+module PNT where+import HsName+import HsIdent+import UniqueNames(PN,OptSrcLoc(..),HasOrig(..))+import TypedIds(IdTy,HasIdTy(..))++import SrcLoc1(HasSrcLoc(..))+import HasBaseName(HasBaseName(..))+import QualNames(QualNames(..),unqual)+import PrettyPrint(Printable(..),PrintableOp(..))++import Data.Generics+++type PName = PN HsName+type PIdent = HsIdentI PName+type PId = PN Id++data PNT = PNT PName (IdTy PId) OptSrcLoc deriving (Show,Read, Data, Typeable)++instance Eq  PNT where PNT i1 _ _ == PNT i2 _ _ = i1==i2+instance Ord PNT where compare (PNT i1 _ _) (PNT i2 _ _) = compare i1 i2+instance HasOrig PNT where orig (PNT pn _ _)  = orig pn+instance HasOrig i => HasOrig (HsIdentI i) where orig = orig . getHSName++instance HasIdTy PId PNT where idTy (PNT _ ty _) = ty+++--instance HasNameSpace PNT where namespace (PNT _ idty _) = namespace idty+--instance HasNameSpace i => HasNameSpace (HsIdentI i) where+--   namespace = namespace . getHSName+++instance QualNames qn m n => QualNames (PN qn) m (PN n) where+    getQualifier                = getQualifier . getBaseName+    getQualified                = fmap getQualified++    mkUnqual                    = fmap mkUnqual+    mkQual m                    = fmap (mkQual m)++instance Printable PNT where+  ppi (PNT i _ _) = ppi i+  wrap  (PNT i _ _) = wrap i++instance PrintableOp PNT where+  isOp (PNT i _ _) = isOp i+  ppiOp (PNT i _ _) = ppiOp i++--instance Unique (PN i) where unique m (PN _ o) = o++instance HasBaseName PNT HsName where+  getBaseName (PNT i _ _) = getBaseName i++instance QualNames PNT ModuleName PNT where+    getQualifier                = getQualifier . getBaseName+    getQualified (PNT i t p)    = PNT (unqual i) t p -- hmm++    mkUnqual                    = id -- hmm+    mkQual m (PNT i t p)        = PNT (mkQual m (getQualified i)) t p++instance HasSrcLoc PNT where+  srcLoc (PNT i _ (N (Just s))) = s+  srcLoc (PNT i _ _) = srcLoc i -- hmm
+ tools/base/defs/README.html view
@@ -0,0 +1,86 @@+<title>Extensible Haskell front-end for the Programatica projects -+        directory base/parse2</title>++<h1>Extensible Haskell front-end for the Programatica projects</h1>++<h2>What is in this directory (base/defs)</h2>++<p>+This directory defines functions for identifiers in abstract syntax trees.+We use overloading to allow the same function names to be reused in extended+versions of the syntax. The functions are thus methods in a small number of+classes. These classes are:++<table>+<tr><th>Class+    <th>Description+<tr><td><b class=tcon>DefinedNames</b>+        <br><b class=tcon>ClassMethods</b>+	<br>...+    <td>A method to compute the set of names introduced by declarations and+        patterns. Also, in a separate class, a method to compute the set of+	methods defined by a class declaration.+<tr><td><b class=tcon>FreeNames+    <td>A method to compute the set of names that occur free in declarations,+        expressions, patterns and type expressions+<tr><td><b class=tcon>NameMaps</b>+    <td>Traverse an abstract syntax tree and apply a given function to every+        identifier. Some context information is provided by the+	traversal function.+<tr><td><b class=tcon>ReAssoc</b>+    <td>Rewrite expressions according to operator precedence and associativity.+<tr><td><b class=tcon>ScopeNames</b>+    <td>Pair identifiers with the environment in which it should be interpreted.+</table>++<p>+For each of these classes, there is+<ol>+<li>one module defining the class and some related auxiliary functions,+<li>one module defining re-usable instances for the base language structure,+<li>one module defining the knot-tying recursive definitions for the+    base language (Haskell 98).+</ol>++<table>+<caption>Modules</caption>+<tr><th>Class definition+    <th>re-usable instances+    <th>knot-tying instances+<tr><td><b class=mod>DefinedNames</b>+    <td><b class=mod>DefinedNamesBaseStruct</b>+    <td><b class=mod>DefinedNamesBase</b>+<tr><td><b class=mod>FreeNames</b>+    <td><b class=mod>FreeNamesBaseStruct</b>+    <td><b class=mod>FreeNamesBase</b>+<tr><td><b class=mod>NameMaps</b>+    <td><b class=mod>NameMapsBaseStruct</b>+    <td><b class=mod>NameMapsBase</b>+<tr><td><b class=mod>ReAssoc</b>+    <td><b class=mod>ReAssocBaseStruct</b>+    <td><b class=mod>ReAssocBase</b>+<tr><td><b class=mod>ScopeNames</b>+    <td><b class=mod>ScopeNamesBaseStruct</b>+    <td><b class=mod>ScopeNamesBase</b>+</table>++<p>+There are some additional modules in this directory:++<table><tr><th>Module<th>Purpose+<tr><td><b class=mod>PNT</b>+<td>A data type <b class=tcon>PNT</b>+    for identifiers carrying information on what unique entity+    it refers to, what type of entity it is (class, type, value, ...) and+    the position where it occurred in the source code.+<tr><td><b class=mod>UniqueNames</b>+<td>Data type <b class=tcon>Orig</b> (origin) to identity where something is+    defined.+    Data type <b class=tcon>PN</b> to tag an identifier with an origin.+<tr><td><b class=mod>ReAssocModule</b>+<td>A function for applying the reAssoc method to a module in the appropriate+    top level environment.+<tr><td><b class=mod>ScopeModule</b>+<td>Functions for applying the scoping pass to a module. The output is an+    abstract syntax tree containing identifiers of type <b class=tcon>PNT</b>.+</table>
+ tools/base/defs/ReAssoc.hs view
@@ -0,0 +1,65 @@+module ReAssoc where+import HsAssoc+import HsIdent+import Recursive++{-++A class for extensible rewriting of infix applications according to operator+precedence and associativity.++Since fixity information follows the scope the binding it refers to,+the rewrite uses an environment, which is extended when entering the+scope of a local definition.+-}++class ReAssoc i e where+  reAssoc :: OperatorEnv (HsIdentI i) -> e -> e++reAssocRec env = mapRec (reAssoc env)++{-++To be able to reassociate infix operators in an expression type, all we need+is to be able take infix applications apart, and build new ones:+-}+class HasInfixApp i e a | e->a i where+  infixApp   :: a -> HsIdentI i -> a -> e+  isInfixApp :: e -> Maybe (a,HsIdentI i,a)++{-++We also need to obtain the declared fixities of the operators+-}+class HasInfixDecls i ds | ds->i where+  getInfixDecls :: ds -> OperatorEnv (HsIdentI i)++getInfixDeclsRec x = getInfixDecls (struct x)++{-++A reusable function that rewrites infix applications. Using this when+defining instances of ReAssoc, all that is left to do is pass the aprropriate+operator environment around.+-}+--property: reAssocOp should work.+--proof: it does the same thing as HsExpUtil.reassociateE.+reAssocOp env e1 op e2 =+    case isInfixApp e1' of+      Nothing -> e'+      Just (e11,op1,e12) ->+	  if p>p1 || p==p1 && a==a1 && a==HsAssocRight+	  then infixApp e11 op1 (reAssoc env (infixApp e12 op e2))+	  else e'+	where+	  HsFixity a p = getFixity env op	      +	  HsFixity a1 p1 = getFixity env op1+  where+    e1' = reAssoc env e1+    e2' = reAssoc env e2+    e' = infixApp e1' op e2'+++instance (Eq i,HasInfixDecls i d) => HasInfixDecls i [d] where+  getInfixDecls = foldr (extend2 . getInfixDecls) emptyOE++instance ReAssoc i d => ReAssoc i [d] where reAssoc = map . reAssoc++getInfixes m = oe where OperatorEnv oe = getInfixDecls m+reAssoc' ops = reAssoc (OperatorEnv ops)
+ tools/base/defs/ReAssocBase.hs view
@@ -0,0 +1,25 @@+module ReAssocBase(module ReAssocBase,module ReAssoc) where+import Syntax(HsExpI,HsPatI,HsDeclI,HsIdentI(..))+import ReAssoc+import ReAssocBaseStruct()+import DefinedNamesBase()+import Recursive+import HasBaseStruct(hsInfixApp,hsPInfixApp)++{-+Knot-tying definitions for the base syntax+-}++instance Eq i => ReAssoc i (HsExpI  i) where reAssoc = reAssocRec+instance Eq i => ReAssoc i (HsPatI  i) where reAssoc = reAssocRec+instance Eq i => ReAssoc i (HsDeclI i) where reAssoc = reAssocRec++instance HasInfixDecls i (HsDeclI i)   where getInfixDecls = getInfixDeclsRec++instance HasInfixApp i (HsExpI i) (HsExpI i) where+  infixApp = hsInfixApp+  isInfixApp = isInfixApp . struct++instance HasInfixApp i (HsPatI i) (HsPatI i) where+  infixApp p1 (HsCon c) p2 = hsPInfixApp p1 c p2+  isInfixApp = isInfixApp . struct
+ tools/base/defs/ReAssocBaseStruct.hs view
@@ -0,0 +1,110 @@+module ReAssocBaseStruct where+import BaseSyntax+import ReAssoc+import HsAssoc+--import TypedIds+import DefinedNames+--import DefinedNamesBaseStruct+++instance HasInfixApp i (EI i e p ds t c) e where+  infixApp = HsInfixApp+  isInfixApp e =+    case e of+      HsInfixApp e1 op e2 -> Just (e1,op,e2)+      _ -> Nothing++instance HasInfixApp i (PI i p) p where+  infixApp p1 (HsCon c) p2 = HsPInfixApp p1 c p2+  isInfixApp p =+    case p of+      HsPInfixApp p1 op p2 -> Just (p1,HsCon op,p2)+      _ -> Nothing++instance HasInfixDecls i (DI i e p ds t c tp) where+  getInfixDecls d =+    case d of+      HsInfixDecl s f ns -> OperatorEnv [(n,f)|n<-ns]+      _ -> OperatorEnv []++instance HasInfixDecls i ds => HasInfixDecls i (HsModuleI m i ds) where+  getInfixDecls = getInfixDecls . hsModDecls++instance (Eq i,DefinedNames i ds,HasInfixDecls i ds,ReAssoc i ds)+          => ReAssoc i (HsModuleI m i ds) where+  reAssoc env (HsModule s n e i ds) = HsModule s n e i (reAssoc env' ds)+    where env' = extendOps env ds++instance (Eq i,ReAssoc i e,ReAssoc i p,DefinedNames i p,+          HasInfixDecls i ds,ReAssoc i ds,DefinedNames i ds)+	  => ReAssoc i (DI i e p ds t c tp) where+  reAssoc env d =+     case d of+       HsFunBind s ms -> HsFunBind s (map r ms)+       HsPatBind s p rhs ds -> HsPatBind s (reAssoc env p) (r rhs) (r ds)+         where r x = reAssoc env' x+	       env' = rhsOps env p ds+       _ -> mapDI id r r r id id id d+   where r x = reAssoc env x++instance ReAssoc i e => ReAssoc i (HsRhs e) where+  reAssoc = mapRhs . reAssoc++instance (Eq i,HasInfixApp i e e,ReAssoc i e,+	  DefinedNames i p,HasInfixApp i p p,ReAssoc i p,+          ReAssoc i ds,HasInfixDecls i ds,DefinedNames i ds)+          => ReAssoc i (EI i e p ds t c) where+  reAssoc env e =+    case e of+      HsInfixApp e1 op e2 -> reAssocOp env e1 op e2+      HsLet ds e -> HsLet (reAssoc env' ds) (reAssoc env' e)+        where env' = extendOps env ds+      HsLambda ps e -> HsLambda ps (reAssoc env' e)+        where env' = defaultOps env (definedVars ps)+      HsCase e alts -> HsCase (r e) (map r alts)+      HsDo stmts -> HsDo (reAssoc env stmts)+      HsListComp stmts -> HsListComp (reAssoc env stmts)+      _ -> mapEI id r r r id id e+    where r x = reAssoc env x++instance (Eq i,ReAssoc i e,ReAssoc i p,DefinedNames i p,+	  ReAssoc i ds,DefinedNames i ds,HasInfixDecls i ds)+          => ReAssoc i (HsStmt e p ds) where+  reAssoc env stmt =+      case stmt of+	HsGenerator s p e stmt -> HsGenerator s (r p) (r e) (r' stmt)+	  where r' = reAssoc (defaultOps env (definedVars p))+	HsQualifier   e stmt -> HsQualifier (r e) (r stmt)+	HsLetStmt    ds stmt -> HsLetStmt   (r' ds) (r' stmt)+          where r' x = reAssoc (extendOps env ds) x+	HsLast        e      -> HsLast      (r e)+    where r x = reAssoc env x++instance (Eq i,ReAssoc i e,ReAssoc i p,DefinedNames i p,+	  ReAssoc i ds,DefinedNames i ds,HasInfixDecls i ds)+	  => ReAssoc i (HsAlt e p ds) where+  reAssoc env (HsAlt s p rhs ds) = HsAlt s (reAssoc env p) (r rhs) (r ds)+    where+      r x = reAssoc env' x+      env' = rhsOps env p ds++instance (Eq i,ReAssoc i e,ReAssoc i p,DefinedNames i p,+	  ReAssoc i ds,DefinedNames i ds,HasInfixDecls i ds)+	  => ReAssoc i (HsMatchI i e p ds) where+  reAssoc env (HsMatch s n ps rhs ds) =+      HsMatch s n (map (reAssoc env) ps) (r rhs) (r ds)+    where+      r x = reAssoc env' x+      env' = rhsOps env ps ds++rhsOps env p ds = extendOps (defaultOps env (definedVars p)) ds++instance (Eq i,HasInfixApp i p p,ReAssoc i p) => ReAssoc i (PI i p) where+  reAssoc env p =+    case p of+      HsPInfixApp p1 op p2 -> reAssocOp env p1 (HsCon op) p2+      _ -> mapPI id (reAssoc env) p++extendOps env ds = extend2 (defaultOps env ns) (getInfixDecls ds)+  where+    ns = definedValues ds
+ tools/base/defs/ReAssocModule.hs view
@@ -0,0 +1,26 @@+module ReAssocModule where+import ReAssoc(reAssoc')+import WorkModule+import QualNames+import Ents+import TypedIds(namespace,NameSpace(..))++import Lift+import MUtils++reAssocModule wm origOps mod = reAssoc' opEnv mod+  where+    opEnv = [(q,fixity)|qn<-inScopeDom wm,+			Ent m n t <-inScope wm qn,+			namespace t==ValueNames,+			--m/=mn, -- only imported names+			let --un = mapHsIdent UnQual n+			    q = requal qn n,+			fixity<-lift (lookupOrig m n origOps)]++    lookupOrig m n = lookup n @@ lookup m++    requal qn n = case getQualifier qn of+                    Nothing -> mkUnqual n+                    Just m  -> mkQual m n+
+ tools/base/defs/ScopeModule.hs view
@@ -0,0 +1,266 @@+{-++This module provides the function #scopeModule# which takes abstract+syntax trees returned by the parser, where idientifers are annotated with+the position they occurred at in the source file, and produces abstract+syntax trees where the identifiers are annotated with the following+extra information:++  * Tagging to make every identifier globally unique, i.e., you can tell+    which entity (binding occurence) an identifier refers to, without knowing+    which scope it occurs in.+    Top-level entities are identified by their original names (M.n).+    Local entities are idenfified by their names in combination+     with a source position.++  * Tagging to tell what kind of entity the identifiers refer to (a value,+    a type class, a data constructor, ...)++The type #PNT# is the type used for identifiers holding this extra tagging+information.++(The function #numberNames# is responsible for+making names unique. It currently uses source positions, but it could+generate unique numbers instead, in which case the parser wouldn't have to+provide any position information.)+-}+module ScopeModule(scopeModule,XRefInfo,checkRefs,origName) where++import HsModule(hsModName)+import HsIdent(HsIdentI(..),getHSName,mapHsIdent)+import HsName(HsName,ModuleName)+import SrcLoc1(SrcLoc,srcLoc)+import HasBaseName++import WorkModule(inscpList) --WorkModuleI,ExpRel,inScope,+import Relations(relToList)+import TypedIds--(IdTy(..),blankTypeInfo,namespace,belongsTo)+import NameMaps+import NumberNames(numberNames,PN(..),Orig(G),orig,origModule,eqSrc,optLoc,unique)+import PNT+import ScopeNames+import UniqueNames(optOrigModule)+--import SourceNames(srcName,SN)++import QualNames(getQualified,mkUnqual,mkQual)+import Ents(Ent(..))++import PrettyPrint++import OutputM+import EnvM+import List(partition,nub)+import Maybe(fromJust)+import MUtils(mapSnd)+import OpTypes(ordBy)+import FiniteMap1++--import IOExts(trace) -- for debugging++{-+scopeModule :: ... => ...+                   -> HsModuleI i (ds (SN HsName))+                   -> (HsModuleI i (ds PNT),[XRefInfo])+-}+scopeModule (wm,exports) mod +    = mergeOutputM -- merge now to avoid having to sort later+    . seqNames +    . mapNames2 TopLevel (pickScope m envs HsVar, pickScope m envs HsCon)+    . addScope modenv+    . numberNames $ mod+  where+    m = getBaseName (hsModName mod)+    modenv = topenv wm+    envs = (modenv,mapSnd (impenv.relToList) exports)++    mergeOutputM = foldOutput [] (:[]) merge'++    merge' xs [] = xs+    merge' [] ys = ys+    merge' xxs@(x:xs) yys@(y:ys) = if ordBy srcLoc' x y+				   then x:merge' xs yys+				   else y:merge' xxs ys++    srcLoc' (_,i,_) = srcLoc i++checkRefs :: [XRefInfo] -> [(SrcLoc,Doc)]+checkRefs = concatMap checkRef+  where+    -- Exports and imports have already been checked by the module system code,+    -- so no need to check again. TODO: import specs are checked agains the+    -- environment...+    checkRef ((ExpEnt {},_),x,os) = []+    checkRef ((ImpEnt {},_),x,os) = []+    checkRef ((role,sp),x,os) =+      case os of+	[_] -> []+        [] -> [(srcLoc x,"not in scope:"<+>x)]+	_ -> [(srcLoc x,"ambiguous:"<+>x<+>ppiFTuple (map origname os))]+    origname (x,_) = origModule x<>"."<>getQualified x++--type Filter x y = FiniteMap x y->[y]++type SPName = (PName,ScopeFM)+type Scope = [(PIdent,IdTy PId)]+type ScopeFM = FiniteMap (HsIdentI HsName) Scope+type ImportScope = [(ModuleName,ScopeFM)]+type XRefInfo = ((Role (),NameSpace),PIdent,Scope)++pickScope :: ModuleName ->+             (ScopeFM,ImportScope) ->+             (PName->PIdent)->+	     Occurence SPName ->+	     SPName ->+	     OutputM XRefInfo PNT+pickScope m (modenv,ex) c (dctx,sp) (i,scope) =+     checkref . partition (isLocal.getHSName.fst) . nub . filterSame $ scope'+  where+    scope' = case dctx of+	       ImpEnt m _ -> fromJust (lookup m ex)+	       _ -> scope++    filterSame =+      case dctx of+	{- This should implement the revised Haskell 98 scoping rules for+	   instance declarations and subordinate names in imports/exports.-}+	Def (Instance (cl,_)) -> filterSameSub cl+	ExpEnt (Just (i,_))   -> filterSameSub i+	ImpEnt m (Just (i,_)) -> filterSameSub i+	FieldLabel            -> filter isField . filterSameNormal+	Sig TopLevel	      -> filterSameModule+	Use                   -> filter notLogic . filterSameNormal+	_                     -> filterSameNormal++    filterSameNormal env =+       -- i' `eqSrc` c i && sp == namespace ity'+       [it|it@(i',ity')<-lookenv env (c i),sp==pnamespace ity']++    notLogic (_,Assertion) = False+    notLogic (_,Property)  = False+    notLogic _             = True++    filterSameModule = filter sameModule . filterSameNormal+      where sameModule (i,_) = optOrigModule i == Just m++    -- P-Logic: conids can refer to properties&assertions in imports&exports+    pnamespace = if isExpOrImp then impexpnamespace else namespace+      where+        isExpOrImp =+          case dctx of+	    ExpEnt Nothing -> True+	    ImpEnt _ Nothing -> True+	    _ -> False+	impexpnamespace ity =+          case ity of+	    Assertion -> ClassOrTypeNames+	    Property -> ClassOrTypeNames+	    _ -> namespace ity++    filterSameSub i env = filtFM (sameSub env i) env+      where filtFM p = filter p . concat . eltsFM++    sameSub env iowner =+      case filter (isClassOrType.snd) $ lookenv env (HsCon iowner) of+	[(HsCon c,idty)] ->+	    case [orig s|s<-subs,s `eqSrc` n] of+	      [o] -> sameSub' o+	      [] -> --trace ("subordinate not found "++show (iowner,i,subs)) $+		    const False+	      _ -> --trace ("ambiguous subordinate name "++show (iowner,i,subs)) $+		   const False -- data/class with name duplications...+	  where+	    subs = subordinates idty+	    n = getQualified i -- i should be unqualified+	    sameSub' o (i,idty) = orig i==o && isSubordinate idty++	[] -> --trace ("not in scope "++show iowner) $+	      const False+	ents -> --trace ("ambiguous owner of subordinate names "++show (iowner,ents)) $+		const False++    isField (_,FieldOf {}) =  True+    isField _ = False++    isLocal (PN _ (G {})) = False+    isLocal _ = True -- hmm++    checkref (l:_,_) = ref [l] -- innermost binding, ambiguities not detected+    checkref (_,gs)  = ref (filterdefs gs)++    -- Defining occurences do not themselves conflict with imported names,+    -- except in instances, which aren't really defining occurences.+    filterdefs =+      case dctx of+	Def (Instance _) -> id+	Def _ -> filter ((==m).origModule.getHSName.fst)+	_ -> id++    ref is = output ((strip dctx,sp),c i,is) >>+	     case is of+	       [(oi,idty)] -> return (PNT (keepSrcName oi) idty (optLoc i))+	       _           -> return (PNT i (fakeidty sp) (optLoc i))+      where keepSrcName oi = PN (getBaseName i) (orig oi)++    -- To avoid recursive type:+    strip = fmap (const ())++    -- To avoid failing on references to ids not in scope+    fakeidty ValueNames = Value+    fakeidty ClassOrTypeNames = Type blankTypeInfo+++addScope env m =+    --trace (show (hsModName m,wm)) $+    withEnv env (scopeNames extend m)+  where+    --global (ni,idty) = (N i (G i),idty)+    --  where N i _ = getHSName ni+    --local (ni,idty) = (getHSName ni,idty)+ +    extend new old = extenv old (filter notoldtyvar (mapSnd conv new))+      where+        --oldtyvars = [i|(HsVar i,Type {})<-old]+        notoldtyvar (i@(HsVar _),Type {}) = null [()|(_,Type{})<-lookenv old i]+        notoldtyvar _ = True++    conv = fmap getQualified++envMap = extenv emptyFM+extenv env bs = addListToFM_C (flip (++)) -- innermost binding first in the list+                              env+			      [(getBaseName i,[it])|it@(i,_)<-bs]+lookenv env i = lookupWithDefaultFM env [] (getBaseName i)++--topenv :: WorkModuleI HsName Id -> [(HsIdentI (PName),IdTy (PId))]+topenv wm = envMap [(origIdent qn m i,origt m t)|(qn,Ent m i t)<-inscpList wm]+      where +        origt m = fmap (osub m) +        osub m n = origName n m n+	    -- This generates references to names not necessarily in scope...++{-+impenv ::+  (Unique n, HasBaseName qn HsName, QualNames qn ModuleName n1,+   HasBaseName n ib) =>+  [(n1, Ent n)]+  -> FiniteMap (HsIdentI HsName) [(HsIdentI (PN HsName), IdTy (PN ib))]+--}+impenv exprel =+    envMap [(origIdent (unq m n) m i,origt m t)|(n,Ent m i t)<-exprel]+  where +    unq m n = mkUnqual n `asTypeOf` mkQual m n+                      -- ^ this eliminates an ambiguite that was accepted by GHC+    origt m = fmap (osub m) +    osub m n = origName n m n++origIdent qn m = mapHsIdent (origName qn m)+origName qn m n = PN (getBaseName qn) (unique m n)+--origName qn m n = PN (getBaseName qn) (G m (getBaseName n))++--instance (Printable a,Printable b) => PrintableOp (a,b) where+--  ppiOp (x,y) = "`("<>x<>","<>y<>")`"++subordinates (Class _ ms) = {-map HsVar-} ms+subordinates (Type TypeInfo {constructors=cs,fields=fs}) =+  {-map HsVar-} fs++map ({-HsCon .-} conName) cs+subordinates _ = []+
+ tools/base/defs/ScopeNames.hs view
@@ -0,0 +1,37 @@+module ScopeNames where+import EnvM+import DefinedNames(TypedIdent)+import MUtils+import Recursive++type Env i = [TypedIdent i]++class ScopeNames i e s1 s2 | s1->i, s1 e->s2  where+  scopeNames :: (Env i->e->e)->s1->EnvM e s2++instance ScopeNames i e s1 s2 => ScopeNames i e [s1] [s2] where+  scopeNames = mapM . scopeNames++instance ScopeNames i e s1 s2 => ScopeNames i e (Maybe s1) (Maybe s2) where+  scopeNames ext = seqMaybe . fmap (scopeNames ext)++instance (ScopeNames i e a1 a2,ScopeNames i e b1 b2)+      => ScopeNames i e (a1,b1) (a2,b2) where+  scopeNames ext (a,b) = (,) # scopeNames ext a <# scopeNames ext b+++scopeNamesRec ext s = r # scopeNames ext (struct s)++{-+class ScopeNames i s | s->i where+  envNames :: s -> ScopeM i s++penv x = (,) x # getEnv++--cpenv = penv . HsCon+--vpenv = penv . HsVar++scopeNames f env0 = runEnv [] . seqNames . flip envNames env0 . mapNames f++extend env1 m = \ env2 -> m (env1++env2)+-}
+ tools/base/defs/ScopeNamesBase.hs view
@@ -0,0 +1,20 @@+module ScopeNamesBase where+import ScopeNames+import ScopeNamesBaseStruct+import DefinedNamesBase()+import FreeNamesBase()+import Syntax++instance Eq i => ScopeNames i e (HsExpI i) (HsExpI (i,e)) where+   scopeNames = scopeNamesRec++instance Eq i => ScopeNames i e (HsDeclI i) (HsDeclI (i,e)) where+   scopeNames = scopeNamesRec++instance ScopeNames i e (HsPatI i) (HsPatI (i,e)) where+   scopeNames = scopeNamesRec++instance ScopeNames i e (HsTypeI i) (HsTypeI (i,e)) where+   scopeNames = scopeNamesRec++
+ tools/base/defs/ScopeNamesBaseStruct.hs view
@@ -0,0 +1,157 @@+module ScopeNamesBaseStruct where+import ScopeNames+import DefinedNames+import DefinedNamesBaseStruct()+import FreeNames+import BaseSyntax+import MUtils+import EnvM++instance ScopeNames i e ds1 ds2+      => ScopeNames i e (HsModuleI m i ds1) (HsModuleI m (i,e) ds2) where+  scopeNames ext (HsModule s m e i ds) = HsModule s m # sc e <# sc i <# sc ds+    where sc x = scopeNames ext x++instance ScopeNames i e (HsExportSpecI m i) (HsExportSpecI m (i,e)) where+  scopeNames = scopeSpec++instance ScopeNames i e (HsImportSpecI i) (HsImportSpecI (i,e)) where+  scopeNames = scopeSpec++instance ScopeNames i e (HsImportDeclI m i) (HsImportDeclI m (i,e)) where+  scopeNames = scopeSpec -- uses the wrong environment!!!++scopeSpec ext spec = do env <- getEnv ; return (fmap (\i->(i,env)) spec)++pairEnv x = (,) x # getEnv++instance (Eq i,+	  ScopeNames i e e1 e2,+	  ScopeNames i e p1 p2,DefinedNames i p1,+	  ScopeNames i e ds1 ds2,DefinedNames i ds1,+	  ScopeNames i e t1 t2,FreeNames i t1,+	  ScopeNames i e c1 c2,FreeNames i c1)+       => ScopeNames i e (EI i e1 p1 ds1 t1 c1)+		         (EI (i,e) e2 p2 ds2 t2 c2) where+  scopeNames ext e =+    case e of+      HsLambda ps e        -> ex ps (HsLambda # sc ps <# sc e)+      HsLet ds e           -> ex ds (HsLet    # sc ds <# sc e)+      HsCase e alts        -> HsCase # sc e <# sc alts+      HsDo stmts           -> HsDo # sc stmts+      HsListComp stmts     -> HsListComp # sc stmts+      HsExpTypeSig s e c t -> HsExpTypeSig s # sc e <# ex (sc c) <# ex (sc t)+        where ex = exttvar ext (c,t)+      _ -> seqEI . mapEI pairEnv sc sc sc sc sc $ e+    where+      sc x = scopeNames ext x+      ex b = extdef ext b++extdef ext b = inModEnv . ext $ definedNames b+exttvar ext b = inModEnv . ext $ freeTyvars b+exttvs ext = inModEnv . ext . map (typedTvar . HsVar)++instance (ScopeNames i e e1 e2,+	  ScopeNames i e p1 p2,DefinedNames i p1,+	  ScopeNames i e ds1 ds2,DefinedNames i ds1)+      => ScopeNames i e (HsStmt e1 p1 ds1) (HsStmt e2 p2 ds2) where+  scopeNames ext stmt =+    case stmt of+      HsGenerator s p e stmt -> HsGenerator s # ex p (sc p) <# sc e <# ex p (sc stmt)+      HsQualifier e stmt -> HsQualifier # sc e <# sc stmt+      HsLetStmt ds stmt -> ex ds $ HsLetStmt # sc ds <# sc stmt+      HsLast e -> HsLast # sc e+    where+      sc x = scopeNames ext x+      ex b = extdef ext b++instance (ScopeNames i e e1 e2,+	  ScopeNames i e p1 p2,DefinedNames i p1,+	  ScopeNames i e ds1 ds2,DefinedNames i ds1)+	  => ScopeNames i e (HsAlt e1 p1 ds1) (HsAlt e2 p2 ds2) where+  scopeNames ext (HsAlt s p rhs ds) =+      HsAlt s # ex p (scopeNames ext p) <# r rhs <# r ds+    where+      r x = ex (p,ds) (sc x)+      sc x = scopeNames ext x+      ex b = extdef ext b++instance (ScopeNames i e e1 e2,+	  ScopeNames i e p1 p2,DefinedNames i p1,+	  ScopeNames i e ds1 ds2,DefinedNames i ds1)+	  => ScopeNames i e (HsMatchI i e1 p1 ds1) (HsMatchI (i,e) e2 p2 ds2) where+  scopeNames ext (HsMatch s i ps rhs ds) =+      HsMatch s # pairEnv i <# ex ps (scopeNames ext ps) <# r rhs <# r ds+    where+      r x = ex (ps,ds) (sc x)+      sc x = scopeNames ext x+      ex b = extdef ext b++instance ScopeNames i e e1 e2 => ScopeNames i e (HsRhs e1) (HsRhs e2) where+  scopeNames ext = seqRhs . mapRhs (scopeNames ext)++instance ScopeNames i e p1 p2+      => ScopeNames i e (PI i p1) (PI (i,e) p2) where+  scopeNames ext = seqPI . mapPI pairEnv (scopeNames ext)++instance (Eq i,+	  ScopeNames i e e1 e2,+	  ScopeNames i e p1 p2,DefinedNames i p1,+	  ScopeNames i e ds1 ds2,DefinedNames i ds1,+	  ScopeNames i e t1 t2,FreeNames i t1,+	  ScopeNames i e c1 c2,FreeNames i c1,+	  ScopeNames i e tp1 tp2,FreeNames i tp1)+       => ScopeNames i e (DI i e1 p1 ds1 t1 c1 tp1)+		         (DI (i,e) e2 p2 ds2 t2 c2 tp2) where+  scopeNames ext d =+      case d of+       HsTypeDecl s tps t             -> st tps+       HsNewTypeDecl s ctx tps cd drv ->+         HsNewTypeDecl s # mr ctx <# mr tps <# mr cd <# mapM pairEnv drv+           where mr x = exttvar ext tps $ m x+       HsDataDecl s ctx tps cds drv   ->+         HsDataDecl s # mr ctx <# mr tps <# mr cds <# mapM pairEnv drv+           where mr x = exttvar ext tps $ m x+       HsClassDecl s c tp fdeps ds    -> st tp -- hmm, fdeps+		         -- !!  ^^ Hmm, typevars in type sigs ds+       HsInstDecl s optn c tp ds      -> st (c,tp)+       HsTypeSig s nms c tp           -> st (c,tp)+       HsFunBind s ms -> HsFunBind s # mapM m ms+       HsPatBind s p rhs ds -> HsPatBind s # m p <# mr rhs <# mr ds+          where mr x = extdef ext ds $ m x+		--                ^^ not (p,ds)+		-- The variables in p are added to the environment before+		-- entering the declaration group this binding is part of,+		-- and should not be added again.+       HsPrimitiveTypeDecl s ctx tp   -> st tp+       HsPrimitiveBind s nm tp        -> st tp+       _ -> scAll+    where+      st tp = exttvar ext tp scAll+      scAll = seqDI $ mapDI pairEnv m m m m m m d+      m x = scopeNames ext x++instance (ScopeNames i e t1 t2,ScopeNames i e c1 c2)+      => ScopeNames i e (HsConDeclI i t1 c1) (HsConDeclI (i,e) t2 c2) where+  scopeNames ext d =+    case d of+      HsConDecl s vs ectx c args -> st vs+      HsRecDecl s vs ectx c fields -> st vs+    where+      st vs = exttvs ext vs scAll+      scAll = seqConDecl $ mapConDeclI pairEnv m m d+      m x = scopeNames ext x++instance ScopeNames i e t1 t2+      => ScopeNames i e (TI i t1) (TI (i,e) t2) where+  scopeNames ext t =+      case t of+        HsTyForall vs ps t' -> exttvs ext vs scAll+	_ -> scAll+    where+      scAll = seqTI $ mapTI pairEnv m t+      m x = scopeNames ext x ++freeTyvars tp = [typedTvar i|(i@(HsVar _),_)<-freeNames tp]++typedTvar i = (i,Type blankTypeInfo)
+ tools/base/defs/UniqueNames.hs view
@@ -0,0 +1,93 @@+module UniqueNames where+import SrcLoc1(SrcLoc(..),loc0,HasSrcLoc)+import SrcLocPretty()+import HsName (Id,ModuleName)+import PrettyPrint+import HasBaseName+--import NoEq+import qualified SrcLoc1 as L+import Maybe(fromMaybe)+import Data.Generics++-- Types to decorate identifiers to make them unique++data Orig+  = L Int    -- for unique names generated in the scope pass+  | G ModuleName Id OptSrcLoc -- unique top level names (original names)+  | D Int OptSrcLoc -- for unique variables generated by the type checker+  | S SrcLoc -- for names made unique by their defining occurence in the source+  | Sn Id SrcLoc -- unique by name + a source location+-- | I ModuleName SrcLoc -- for names of instances introduced by the type checker+  | P        -- just for pretty printing+  deriving (Eq,Ord,Show,Read, Data, Typeable)++newtype OptSrcLoc = N (Maybe SrcLoc) deriving (Read, Show, Data, Typeable)+noSrcLoc = N Nothing+srcLoc = N . Just+optSrcLoc = N+instance Eq  OptSrcLoc where _ == _ = True+instance Ord OptSrcLoc where compare _ _ = EQ+-- instance Show OptSrcLoc where showsPrec _ _ = id+-- instance Read OptSrcLoc where readsPrec _ s = [(N Nothing,s)]++data PN i = PN i Orig   deriving (Show,Read, Data, Typeable)++instance HasSrcLoc (PN i) where srcLoc = fromMaybe loc0 . optLoc'++optLoc = N . optLoc'+optLoc' (PN i o) =+  case o of+    G m n (N optp) -> optp+--  I m p -> Just p+    S p -> Just p+    D n (N optp) -> optp+    _ -> Nothing++class Unique n where unique :: ModuleName -> n -> Orig++class HasOrig n where orig :: n -> Orig+instance HasOrig (PN i) where orig (PN i o) = o++origModule n = fromMaybe err (optOrigModule n)+  where err = error $ "Bug: UniqueNames.origModule "++show n -- hmm++optOrigModule n =+  case orig n of+    G m _ _-> Just m+--  I m _ -> Just m+    _ -> Nothing++instance HasBaseName (PN i) i where getBaseName (PN i _) = i++instance          Eq  (PN i) where PN _ p1==PN _ p2 = p1==p2+instance          Ord (PN i) where compare (PN _ p1) (PN _ p2) = compare p1 p2++instance Functor PN where fmap f (PN i o) = PN (f i) o++x `eqSrc` y = getBaseName x == getBaseName y++---++instance Printable i => Printable (PN i) where+  ppi (PN i o) = i<>o+  wrap (PN i o) = wrap i<>o++instance PrintableOp i => PrintableOp (PN i) where+  isOp (PN i n) = isOp i+  ppiOp (PN i n) = ppiOp i<>n++instance Printable Orig where+  ppi (D n (N s)) = ppi (subnum n)<+>ppIfDebug ("<<"<>s<>">>")+  ppi (S p) = ppIfDebug ("<<"<>p<>">>")+  ppi (G m _ _) = ppIfDebug ("<<"<>m<>">>")+  --ppi (Sn n (SrcLoc f r c)) = "«"<>r<>","<>c<>"»"+  ppi _ = empty++subnum n = ppIfUnicode (subdigs (show n)) n+  where+    subdigs ('-':s) = toEnum 0x208b:subdigs' s+    subdigs s = subdigs' s+    subdigs' = map subdig+    subdig :: Char->Char+    subdig = toEnum . (+0x2050) . fromEnum+
+ tools/base/defs/tests/fnT1.hs view
@@ -0,0 +1,9 @@+data S = S { x :: [Int]}++g z@(S {x = y:ys})  = x x x x++f (x:xs) = x:xs++++
+ tools/base/defs/tests/noPrelude.hs view
@@ -0,0 +1,1 @@+module Prelude where
+ tools/base/defs/tests/tstFreeNames.hs view
@@ -0,0 +1,26 @@+import HsParser(parse)+import ParseProgram(parseProgram)+import FreeNames+import FreeNamesBase+import HsModule (hsModDecls)+import PrettyPrint+import ReAssocBase++import System(getArgs)+++test fs = do+    (scMods, wms) <- parseProgram parse fs+    mapM_ f (concat scMods)++    where+    f = mapM_ g . hsModDecls +    g d = do+        putStrLn (pp d)+        putStrLn (pp (fst `map` freeNames d))+        putStrLn ""++main = do+    as <- getArgs+    test as    +
+ tools/base/ghc_test view
@@ -0,0 +1,2 @@++ghc -i. -iparse -ipretty -ilib -iAST -iSA -iTC -i/home/moran/lib  -cpp -recomp -fwarn-incomplete-patterns -H55M -fglasgow-exts -fmax-simplifier-iterations5 -package lang -package concurrent  -c "$1_pretty.hs" -o "$1_pretty.o"
+ tools/base/lib/AbstractIO.hs view
@@ -0,0 +1,223 @@+{-++This module defines a number of classes that captures various forms of IO.+This allows code to specify IO operations without being tied directly to+the standard #IO# monad.++Instances for the standard #IO# type as well as for all monad transformers+(for all classes except one) are provided. This allows the IO operations to+be used without explicit lifting in monads that extend the IO monad by+an arbitrary number of monad transformers.++Note that we redefine some functions exported from the #Prelude#. To be able+to use these, you need to refer to them by a qualified name, or exclude the+Prelude functions from the unqualified name space by explicitly importing+the #Prelude# and hiding them (as shown below, for example).++By the way, it *is* annoying that #Functor# isn't a superclass of+ #Monad#, isn't it!+-}+module AbstractIO(module AbstractIO,+		  IOError,ClockTime,S.ExitCode(..)) where+import Prelude hiding (readFile,writeFile, appendFile,+		       putStr,putStrLn,print,+		       getLine,readLn,getContents,+		       catch,ioError,userError)+import qualified Prelude+import qualified Directory as D+import qualified System as S+import qualified IO+import qualified Time+import Time(ClockTime,CalendarTime)+import MT(MT(..))++{-++Reading and writing files+-------------------------+-}+class (Functor io,Monad io) => FileIO io where+  readFile :: FilePath -> io String+  writeFile :: FilePath -> String -> io ()+  appendFile :: FilePath -> String -> io ()++instance FileIO IO where+  readFile = Prelude.readFile+  writeFile = Prelude.writeFile+  appendFile = Prelude.appendFile++instance (MT t,Functor (t m),Monad (t m),FileIO m) => FileIO (t m) where+  readFile             = lift . readFile+  writeFile path       = lift . writeFile path+  appendFile path      = lift . appendFile path++{-++Standard IO+-----------+(For messages in the terminal window and user input.)+-}+class (Functor io,Monad io) => StdIO io where+  putStr,putStrLn,ePutStr,ePutStrLn :: String -> io ()+  getLine :: io String -- blocking IO is considered bad by some... :-)+  getContents :: io String++  putStrLn s = putStr s >> putStr "\n"+  ePutStrLn s = ePutStr s >> ePutStr "\n"++print x = putStrLn (show x)++readIO s =  case [x | (x,t) <- reads s, ("","") <- lex t] of+              [x] -> return x+              []  -> ioError (userError "Prelude.readIO: no parse")+              _   -> ioError (userError "Prelude.readIO: ambiguous parse")++instance StdIO IO where+  putStr    = Prelude.putStr+  putStrLn  = Prelude.putStrLn+  ePutStr   = IO.hPutStr IO.stderr+  ePutStrLn = IO.hPutStrLn IO.stderr+  getLine  = Prelude.getLine+  getContents = Prelude.getContents++instance (MT t,Functor (t m),Monad (t m),StdIO m) => StdIO (t m) where+  putStr   = lift . putStr+  putStrLn = lift . putStrLn+  ePutStr   = lift . ePutStr+  ePutStrLn = lift . ePutStrLn+  getLine  = lift getLine+  getContents = lift getContents++{-++System interaction+------------------+Operations corresponding to the standard library module #System#.+(Executing shell commands and other interaction with command line shells.)+-}+++class (Functor io,Monad io) => SystemIO io where+  system :: String -> io S.ExitCode+  getEnv :: String -> io String+  getProgName :: io String+  getArgs :: io [String]+  -- ... exitWith++instance SystemIO IO where+  system = S.system+  getEnv = S.getEnv+  getProgName = S.getProgName+  getArgs = S.getArgs++instance (MT t,Functor (t m),Monad (t m),SystemIO m) => SystemIO (t m) where+  system = lift . system+  getEnv = lift . getEnv+  getProgName = lift getProgName+  getArgs = lift getArgs++{-++Directory manipulation+----------------------+Operations corresponding to the standard library module #Directory#.+-}++class (Functor io,Monad io) => DirectoryIO io where+  createDirectory,removeFile :: FilePath -> io ()+  getModificationTime :: FilePath -> io ClockTime+  doesFileExist, doesDirectoryExist :: FilePath -> io Bool+  getDirectoryContents :: FilePath -> io [FilePath]++-- Base case:+instance DirectoryIO IO where+  createDirectory = D.createDirectory+  getModificationTime = D.getModificationTime+  doesFileExist = D.doesFileExist+  doesDirectoryExist = D.doesDirectoryExist . dropFinalSlash+  getDirectoryContents = D.getDirectoryContents+  removeFile = D.removeFile++-- Quick workaround for a Cygwin problem:+dropFinalSlash = reverse . dropit . reverse+  where dropit ('/':s) = s+	dropit s = s++-- Inductive case:+instance (MT t,Functor (t m),Monad (t m),DirectoryIO m)+      => DirectoryIO (t m) where+  createDirectory      = lift . createDirectory+  getModificationTime  = lift . getModificationTime+  doesFileExist        = lift . doesFileExist+  doesDirectoryExist   = lift . doesDirectoryExist+  getDirectoryContents = lift . getDirectoryContents+  removeFile           = lift . removeFile++{-++Time functions+----------------------+Operations corresponding to the standard library module #Time#.+(Only the subset requiring IO.)+-}++class (Functor m,Monad m) => TimeIO m where+  getClockTime :: m ClockTime+  toCalendarTime :: ClockTime -> m CalendarTime++instance TimeIO IO where+  getClockTime = Time.getClockTime+  toCalendarTime = Time.toCalendarTime++instance (MT t,Functor (t m),Monad (t m),TimeIO m) => TimeIO (t m) where+  getClockTime = lift getClockTime+  toCalendarTime = lift . toCalendarTime+++{-++Catching errors+---------------++This is the only class that lacks a general instance for monad transformers.+(It is probably a good idea to try to survive without relying on error+handlers...)+-}++class (Functor io,Monad io) => CatchIO ioerror io | io->ioerror where+  catch :: io a -> (ioerror -> io a) -> io a+  ioError :: ioerror -> io a++try m = fmap Right m `catch` (return . Left)+maybeM m = (Just `fmap` m) `catch` const (return Nothing)++bracket before after m =+  do x <- before+     r <- try (m x)+     after x+     returnTry r++bracket_ before after m =+  do x <- before+     r <- try m+     after x+     returnTry r++tryThen m after =+  do r <- try m+     after+     returnTry r++returnTry r = either ioError return r++instance CatchIO IOError IO where+  catch = Prelude.catch+  ioError = Prelude.ioError++--instance (MT t,Functor (t m),Monad (t m),CatchIO m) => CatchIO (t m) where+  -- !! How do you lift operations with negative occurences of m?++class IOErr ioerror where+  userError :: String -> ioerror+  isDoesNotExistError,isUserError :: ioerror -> Bool+  ioeGetErrorString :: ioerror -> String+  -- ..., ioeGetFileName, ...++instance IOErr IOError where+  userError = IO.userError+  isDoesNotExistError = IO.isDoesNotExistError+  isUserError = IO.isUserError+  ioeGetErrorString = IO.ioeGetErrorString
+ tools/base/lib/AbstractIO.hs.old view
@@ -0,0 +1,221 @@+{-++This module defines a number of classes that captures various forms of IO.+This allows code to specify IO operations without being tied directly to+the standard #IO# monad.++Instances for the standard #IO# type as well as for all monad transformers+(for all classes except one) are provided. This allows the IO operations to+be used without explicit lifting in monads that extend the IO monad by+an arbitrary number of monad transformers.++Note that we redefine some functions exported from the #Prelude#. To be able+to use these, you need to refer to them by a qualified name, or exclude the+Prelude functions from the unqualified name space by explicitly importing+the #Prelude# and hiding them (as shown below, for example).++By the way, it *is* annoying that #Functor# isn't a superclass of+ #Monad#, isn't it!+-}+module AbstractIO(module AbstractIO,+		  IOError,ClockTime,S.ExitCode(..)) where+import Prelude hiding (readFile,writeFile,+		       putStr,putStrLn,print,+		       getLine,readLn,getContents,+		       catch,ioError,userError)+import qualified Prelude+import qualified Directory as D+import qualified System as S+import qualified IO+import qualified Time+import Time(ClockTime,CalendarTime)+import MT(MT(..))++{-++Reading and writing files+-------------------------+-}+class (Functor io,Monad io) => FileIO io where+  readFile :: FilePath -> io String+  writeFile :: FilePath -> String -> io ()++instance FileIO IO where+  readFile = Prelude.readFile+  writeFile = Prelude.writeFile++instance (MT t,Functor (t m),Monad (t m),FileIO m) => FileIO (t m) where+  readFile             = lift . readFile+  writeFile path       = lift . writeFile path+++{-++Standard IO+-----------+(For messages in the terminal window and user input.)+-}+class (Functor io,Monad io) => StdIO io where+  putStr,putStrLn,ePutStr,ePutStrLn :: String -> io ()+  -- getLine :: io String -- blocking IO is considered bad by some... :-)+  getContents :: io String++  putStrLn s = putStr s >> putStr "\n"+  ePutStrLn s = ePutStr s >> ePutStr "\n"++print x = putStrLn (show x)++readIO s =  case [x | (x,t) <- reads s, ("","") <- lex t] of+              [x] -> return x+              []  -> ioError (userError "Prelude.readIO: no parse")+              _   -> ioError (userError "Prelude.readIO: ambiguous parse")++instance StdIO IO where+  putStr    = Prelude.putStr+  putStrLn  = Prelude.putStrLn+  ePutStr   = IO.hPutStr IO.stderr+  ePutStrLn = IO.hPutStrLn IO.stderr+  -- getLine  = Prelude.getLine+  getContents = Prelude.getContents++instance (MT t,Functor (t m),Monad (t m),StdIO m) => StdIO (t m) where+  putStr   = lift . putStr+  putStrLn = lift . putStrLn+  ePutStr   = lift . ePutStr+  ePutStrLn = lift . ePutStrLn+  -- getLine  = lift getLine+  getContents = lift getContents++{-++System interaction+------------------+Operations corresponding to the standard library module #System#.+(Executing shell commands and other interaction with command line shells.)+-}+++class (Functor io,Monad io) => SystemIO io where+  system :: String -> io S.ExitCode+  getEnv :: String -> io String+  getProgName :: io String+  getArgs :: io [String]+  -- ... exitWith++instance SystemIO IO where+  system = S.system+  getEnv = S.getEnv+  getProgName = S.getProgName+  getArgs = S.getArgs++instance (MT t,Functor (t m),Monad (t m),SystemIO m) => SystemIO (t m) where+  system = lift . system+  getEnv = lift . getEnv+  getProgName = lift getProgName+  getArgs = lift getArgs++{-++Directory manipulation+----------------------+Operations corresponding to the standard library module #Directory#.+-}++class (Functor io,Monad io) => DirectoryIO io where+  createDirectory,removeFile :: FilePath -> io ()+  getModificationTime :: FilePath -> io ClockTime+  doesFileExist, doesDirectoryExist :: FilePath -> io Bool+  getDirectoryContents :: FilePath -> io [FilePath]++-- Base case:+instance DirectoryIO IO where+  createDirectory = D.createDirectory+  getModificationTime = D.getModificationTime+  doesFileExist = D.doesFileExist+  doesDirectoryExist = D.doesDirectoryExist . dropFinalSlash+  getDirectoryContents = D.getDirectoryContents+  removeFile = D.removeFile++-- Quick workaround for a Cygwin problem:+dropFinalSlash = reverse . dropit . reverse+  where dropit ('/':s) = s+	dropit s = s++-- Inductive case:+instance (MT t,Functor (t m),Monad (t m),DirectoryIO m)+      => DirectoryIO (t m) where+  createDirectory      = lift . createDirectory+  getModificationTime  = lift . getModificationTime+  doesFileExist        = lift . doesFileExist+  doesDirectoryExist   = lift . doesDirectoryExist+  getDirectoryContents = lift . getDirectoryContents+  removeFile           = lift . removeFile++{-++Time functions+----------------------+Operations corresponding to the standard library module #Time#.+(Only the subset requiring IO.)+-}++class (Functor m,Monad m) => TimeIO m where+  getClockTime :: m ClockTime+  toCalendarTime :: ClockTime -> m CalendarTime++instance TimeIO IO where+  getClockTime = Time.getClockTime+  toCalendarTime = Time.toCalendarTime++instance (MT t,Functor (t m),Monad (t m),TimeIO m) => TimeIO (t m) where+  getClockTime = lift getClockTime+  toCalendarTime = lift . toCalendarTime+++{-++Catching errors+---------------++This is the only class that lacks a general instance for monad transformers.+(It is probably a good idea to try to survive without relying on error+handlers...)+-}++class (Functor io,Monad io) => CatchIO ioerror io | io->ioerror where+  catch :: io a -> (ioerror -> io a) -> io a+  ioError :: ioerror -> io a++try m = fmap Right m `catch` (return . Left)+maybeM m = (Just `fmap` m) `catch` const (return Nothing)++bracket before after m =+  do x <- before+     r <- try (m x)+     after x+     returnTry r++bracket_ before after m =+  do x <- before+     r <- try m+     after x+     returnTry r++tryThen m after =+  do r <- try m+     after+     returnTry r++returnTry r = either ioError return r++instance CatchIO IOError IO where+  catch = Prelude.catch+  ioError = Prelude.ioError++--instance (MT t,Functor (t m),Monad (t m),CatchIO m) => CatchIO (t m) where+  -- !! How do you lift operations with negative occurences of m?++class IOErr ioerror where+  userError :: String -> ioerror+  isDoesNotExistError,isUserError :: ioerror -> Bool+  ioeGetErrorString :: ioerror -> String+  -- ..., ioeGetFileName, ...++instance IOErr IOError where+  userError = IO.userError+  isDoesNotExistError = IO.isDoesNotExistError+  isUserError = IO.isUserError+  ioeGetErrorString = IO.ioeGetErrorString
+ tools/base/lib/AccList.hs view
@@ -0,0 +1,9 @@+-- $Id: AccList.hs,v 1.1 2001/09/06 02:12:55 hallgren Exp $++module AccList (accList) where+++accList acc [] ans     = ans+accList acc (x:xs) ans = accList acc xs (acc x ans) -- LEFT-TO-RIGHT here++-- Property: accList == flip . foldl . flip
+ tools/base/lib/Assoc.hs view
@@ -0,0 +1,46 @@+module Assoc where++import OpTypes+import List(partition)+import Maybe (listToMaybe)+import Products+import EnvM+++class (Prod2 p k v, Functor c) => AssocC c p k v where++    -- define:+    lkpAllEq        :: EqOp k -> k -> EnvM (c p) [v]+    splitAssoc      :: (k -> Bool) -> EnvM (c p) (c p, c p)++{-+    lkpDefEq        :: EqOp k -> v -> k -> EnvM (c p) v+    nonfailLkpEq    :: EqOp k -> k -> EnvM (c p) v++    lkp             :: Eq k => k -> EnvM (c p) (Maybe v)+    lkpDef          :: Eq k => v -> k -> EnvM (c p) v+    nonfailLkp      :: Eq k => k -> EnvM (c p) v++    keys            :: EnvM (c p) (c k)+-}++lkpEq eq i      = listToMaybe . lkpAllEq eq i+lkpDefEq eq v k = maybe v id . lkpEq eq k+nonfailLkpEq eq = lkpDefEq eq (error "nonfailLkp failed.") +lkpAll x        = lkpAllEq (==) x+lkp x           = lkpEq (==) x+lkpDef x        = lkpDefEq (==) x+nonfailLkp x    = nonfailLkpEq (==) x+keys x          = fmap proj1 x+++instance Prod2 p k v => AssocC [] p k v where+    lkpAllEq eq i   = map proj2 . filter (eq i . proj1)+    splitAssoc p    = partition (p . proj1)+++type Assoc a b      = [(a,b)]++++
+ tools/base/lib/Assoc1.hs view
@@ -0,0 +1,59 @@+module Assoc1 where++import Products (fork)+import Maybe (listToMaybe, fromJust)++-- import FiniteMap+++-- useful to sometimes specify types+type IdAt a = a -> a +++class Eq k => IsAssoc a k where+    ascEmpty        :: a k v+    ascFromList     :: [(k,v)] -> a k v+    ascToList       :: a k v -> [(k,v)]+    ascAddList      :: a k v -> [(k,v)] -> a k v++    ascLookup       :: a k v -> k -> Maybe v+    ascLookupAll    :: a k v -> k -> [v]+    ascKeys         :: a k v -> [k]+    ascVals         :: a k v -> [v]+    ascMap          :: (k -> v -> w) -> a k v -> a k w++    ascLookupAll a x= [ v | (k,v) <- ascToList a, k == x ]+    ascLookup a     = listToMaybe . ascLookupAll a  +    ascEmpty        = ascFromList []+++ascLOOKUP :: IsAssoc a k => a k v -> k -> v+ascLOOKUP a = fromJust . ascLookup a+++newtype AscList k v = AL { unAL :: [(k,v)] }++instance Eq k => IsAssoc AscList k where+    ascEmpty                = AL []+    ascAddList (AL a) y     = AL (a ++ y)+    ascLookup (AL a) x      = lookup x a+    ascKeys                 = map fst . unAL+    ascVals                 = map snd . unAL+    ascFromList             = AL+    ascToList               = unAL+    ascMap f                = AL . map (fork fst (uncurry f)) . unAL+    +  {-  +instance Ord k => IsAssoc FiniteMap k where+    ascEmpty    = emptyFM+    ascFromList = listToFM+    ascToList   = fmToList+    ascAddList  = addListToFM+    ascLookup   = lookupFM+    ascKeys     = keysFM+    ascVals     = eltsFM+    ascMap      = mapFM+     +-}++    
+ tools/base/lib/CmdLineParser.hs view
@@ -0,0 +1,43 @@+module CmdLineParser where++data Cmd cmd = Null cmd+             | Args String ([String] -> cmd)++fileArgs = Args "<files>"+fileArg f = fileArgs (mapM_ f)++kwOption kw cmd =+  case cmd of+    Null f -> addKwArg id (null2args f)+    Args args f -> addKwArg (++' ':args) f+  where+    addKwArg rest f = Args (rest ("["++kw++"]")) f'+      where+        f' (a:as) | a==kw = f as True+	f' as             = f as False++    null2args f [] o = f o+    null2args f _  o = fail "superflous arguments"++doCmd (cmds,default_cmd) prg args =+  case args of+    [] -> default_cmd+    cmd:args ->+      case lookup cmd cmds of+	Nothing -> fail $ "Unknown command: "++cmd+	Just (cmd,_) ->+	  case (cmd,args) of+	    (Null   cmd,[]) -> cmd+	    (Args _ cmd,_ ) -> cmd args+	    _ -> fail "Malformed command"++usage prg cmds =+       unlines $+         ["Usage: "++prg++ " <command>",+          "  where <command> is one of:"]+++         map (("    "++).cmdusage) cmds+  where+    cmdusage (name,(cmd,res)) =+      case cmd of+        Null _      -> unwords [name,"--",res]+	Args args _ -> unwords [name,args,"--",res]
+ tools/base/lib/CmdLineParser3.hs view
@@ -0,0 +1,141 @@+module CmdLineParser3(+  P((:--),Token),cmd,(!),(<@),( #@ ),chk,nil,many,arg,kw,opt,flag,named,+  run,usage,parseAll+  ) where+import PrettyPrint hiding (kw)+import Monad(msum,join,liftM,MonadPlus(..),ap)+import Maybe(isJust)+import System(getArgs)++infixl 3 <@,`chk`,#@+infix 2 :--+infixr 1 :!,!++data P res+  = Return res+  | forall arg . Ap (P (arg->res)) (P arg)+  | Named String (P res)+  | P res :-- String+  | Token (String->Maybe res) String+  | P res :! P res+  | forall item . Many (res->[item]) ([item]->res) (P item)++instance Functor P where fmap f p = Return f `Ap` p++chk p p' = const `fmap` p `Ap` p'+cmd s p = Return p `chk` kw s++f #@ p = fmap f p+(!) = (:!)+(<@) = Ap+nil = Return+arg = Token Just+many p = Many id id p+kw s = Token check s+  where check a = if a==s then Just () else Nothing++opt p = fmap Just p ! nil Nothing+flag s = isJust `fmap` opt (kw s)+named = Named++usage prefix p = pp (usageDoc prefix p)+usageDoc prefix p =+    sep [ppi "Usage:", nest 4 (prefix<+>main)] $$+    if null aux+    then empty+    else sep [nest 2 "where", nest 4 (vcat aux)]+  where+    (main,aux) = usage' p++    usage' :: P a -> (Doc,[Doc])+    usage' p =+      case p of+        Return _ -> (empty,[])+	Ap p1 p2 -> (m1<+>m2,a1++a2)+          where (m1,a1) = usage' p1+		(m2,a2) = usage' p2+	Named s p -> (nt,sep [nt<+>"=",nest 2 m]:a)+          where nt = "<"<>s<>">"+                (m,a) = usage' p+        p :-- s -> (m<+>"--"<+>s,a) where (m,a) = usage' p+        Token to s -> (text s,[])+	p1 :! Return _ -> (brackets m,as)+          where (m,as) = usage' p1+	p1 :! p2 -> (vcat ms,concat as)+          where (ms,as) = unzip (map usage' [p1,p2])+        Many _ _ p -> (braces m,a) where (m,a) = usage' p++run p = parseAll p =<< getArgs++parseAll p args =+  case unPM (parse p) args of+    Right (r,[]) -> r+    Right (_,args) -> fail $ "Unrecognized arguments: "++unwords args+    Left (args,errs) ->+        fail $ ('\n':) $+            pp $ "Expected one of:"<+>ppiFSeq errs+               $$ (if null args then empty else "Found: "<+>sep args)+	       -- $$ usageDoc p+               $$ text ""++newtype PM res = PM {unPM ::[String] -> Either ([String],[String]) (res,[String])}++instance Functor PM where fmap = liftM+instance Monad PM where+  fail s = PM $ \ args->Left (args,[s])+  return x = PM $ \args->Right (x,args)+  PM p1>>=xp2 = PM $ \ args->case p1 args of+			       Left err -> Left err+			       Right (x,args') -> unPM (xp2 x) args'+instance MonadPlus PM where+  mzero = fail "no parse"+  mplus (PM p1) (PM p2) =+    PM $ \ args -> case (p1 args,p2 args) of+		     (Right res,_) -> Right res+		     (r1@(Left (a1,errs1)),r2@(Left (a2,errs2))) ->+			 case compare (length a1) (length a2) of+                           LT -> r1+			   EQ -> Left (a1,errs1++errs2)+			   GT -> r2+		     (_,r2) -> r2++get = PM $ \ args -> Right (args,args)+set args = PM $ \ _ -> Right ((),args)++parse :: P res -> PM res+parse p =+  case p of+    Return res -> return res+    Ap pf pa -> parse pf `ap` parse pa+    Named _ p -> parse p+    p :-- s -> parse p+    Token check s ->+      do args <- get+	 case args of+	   a:as -> maybe (fail s)+			 (\a->set as>>return a)+			 (check a)+	   [] -> fail s+    p1 :! p2 -> parse p1 `mplus` parse p2+    Many to from p ->+        parse (cons `fmap` p `Ap` Many to from p ! Return (from []))+      where cons x xs = from (x:to xs)++{-+run :: Cmd m a -> m a++cmd :: String -> m a -> Cmd m a++ap :: Cmd m (a->b) -> Arg m a -> Cmd m b+chk :: P m a -> P m () -> P m a++kw :: String -> P m ()+alt :: P m a -> P m a -> P m a+alts :: [P m a] -> P m a++some,many :: P m a -> P m [a]+opt :: P m a -> P m (Maybe a)++flag :: String -> String -> Bool -> P m Bool+flag name desc def = +-}
+ tools/base/lib/DirUtils.hs view
@@ -0,0 +1,66 @@+module DirUtils where+import Prelude hiding (catch,ioError)+import MUtils+import List(isSuffixOf,nub)+import AbstractIO+import PathUtils(pathSep)++optCreateDirectory d = unlessM (doesDirectoryExist d) (createDirectory d)++getModificationTimeMaybe path = maybeM (getModificationTime path)+{-+  do ifM (doesFileExist path)+         (Just # getModificationTime path)+	 (return Nothing)+-}++-- GHC deficiency workaround:+getModificationTime' path = getModificationTime path `catch` handle+  where+    handle err = if isDoesNotExistError err+		 then fail $ "Missing: "++path+		 else ioError err++latestModTime paths = maximum # mapM getModificationTime' paths+++-- Remove a directory and its contents:+rmR = system . unwords . ("rm -rf":)+			  ++-- Expand directory names to all the Haskell files (.hs & .lhs) in that+-- directory:+expand fs = concat # mapM expand1 (nub fs)+expand1 f =+  do isdir <- doesDirectoryExist f+     if isdir+      then do fs <- getDirectoryContents f+              return [f++[pathSep]++f'|f'<-fs,haskellSuffix f']+      else return [f]++haskellSuffix f = ".hs" `isSuffixOf` f || ".lhs" `isSuffixOf` f++{-+-- Recursively collect Haskell files from subdirectories:+recurse = recurse' "" . nub++recurse' path fs = concat # mapM (recurse1 path) fs++recurse1 path f =+  do let path' = extend path f+     isdir <- doesDirectoryExist path'+     if isdir+      then if okDir f+           then do fs <- getDirectoryContents path'+	           recurse' path' [f|f<-fs,f `notElem` [".",".."]]+	   else return []+      else if haskellSuffix f+	   then return [path']+	   else return []++okDir f = f `notElem` ["objs","CVS","hi","tests","old","spec"]++extend "" f = f+extend "." f = f+extend d f = d++"/"++f+-}
+ tools/base/lib/FileUtils.hs view
@@ -0,0 +1,46 @@+module FileUtils where+import Prelude hiding (readFile,writeFile,+		       putStr,putStrLn,getLine,readLn,print,+		       catch,ioError)+import qualified Prelude+import Monad(unless)+import MUtils(( # ),done,read'',readAtEnd)+import AbstractIO++-- Write to the file only if the new contents is different from the old:+updateFile path contents =+  do unchanged <- ((contents==)#readFileNow path) `catch` const (return False)+     unless unchanged $+          do -- GHC lingering file lock workaround:+             removeFile path `catch` const done -- grr!+             writeFile path contents+     return unchanged++-- Write to the file, even if the new contents is the same:+updateFile' path contents =+  do unchanged <- ((contents==)#readFileNow path) `catch` const (return False)+     -- GHC lingering file lock workaround:+     removeFile path `catch` const done -- grr!+     writeFile path contents+     return unchanged++readFileMaybe path = maybeM (read'' "FileUtils.readFileMaybe" # readFile path)+   -- lazy error checking for efficiency++-- Read a whole file immediately to avoid lingering open file handles+readFileNow path =+    do s <- readFile path+       seq (readall s) (return s)+ where+    readall s | length s>=0 = s++readM s = readM' "FileUtils.readM" s++readM' msg s =+  case reads s of+    [(x,r)] | readAtEnd r -> return x+    []                    -> fail $ msg++": no parse"+    _                     -> fail $ msg++": ambiguous parse"++--readLn = readM =<< getLine+print = putStrLn . show
+ tools/base/lib/Flags.ghc view
@@ -0,0 +1,4 @@+FileUtils.hs: -fno-monomorphism-restriction+DirUtils.hs: -fno-monomorphism-restriction+AbstractIO.hs: -fno-monomorphism-restriction -fallow-undecidable-instances+Sets.hs: -cpp
+ tools/base/lib/GetOpt.hs view
@@ -0,0 +1,215 @@+-- $Id: GetOpt.hs,v 1.1 2001/03/23 19:34:57 moran Exp $++------------------------------------------------------------------------------+-- A Haskell port of GNU's getopt library+-- +-- Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996; last change:+-- Jul. 1998.+--+-- Two rather obscure features are missing: The Bash 2.0 non-option hack (if+-- you don't already know it, you probably don't want to hear about it...) and+-- the recognition of long options with a single dash (e.g. '-help' is+-- recognised as '--help', as long as there is no short option 'h').+--+-- Other differences between GNU's getopt and this implementation:+--    * To enforce a coherent description of options and arguments, there are+--      explanation fields in the option/argument descriptor.+--    * Error messages are now more informative, but no longer POSIX+--      compliant... :-( +-- +-- And a final Haskell advertisement: The GNU C implementation uses well over+-- 1100 lines, we need only 199 here, including a 46 line example! :-)+------------------------------------------------------------------------------++module GetOpt (+   ArgOrder(..),+   OptDescr(..),+   ArgDescr(..),+   usageInfo,+   getOpt+   ) where++import List(isPrefixOf)++data ArgOrder a                  -- what to do with options after non-options:+   = RequireOrder                -- no option processing after first non-option+   | Permute                     -- freely intersperse options and non-options+   | ReturnInOrder (String -> a) -- wrap non-options into options++data OptDescr a                  -- description of a single options:+   = Option [Char]               --    list of short option characters+            [String]             --    list of long option strings (no "--")+            (ArgDescr a)         --    argument descriptor+            String               --    explanation of option for user++data ArgDescr a                        -- description of an argument option:+   = NoArg                   a         --    no argument expected+   | ReqArg (String       -> a) String --    option requires argument+   | OptArg (Maybe String -> a) String --    optional argument++data OptKind a                   -- kind of cmd line arg (internal use only):+   = Opt       a                 --    an option+   | NonOpt    String            --    a non-option+   | EndOfOpts                   --    end-of-options marker (i.e. "--")+   | OptErr    String            --    something went wrong...++usageInfo :: String              -- header+          -> [OptDescr a]        -- option descriptors+          -> String              -- nicely formatted decription of options+usageInfo header optDescr = unlines (header:table)+   where (ss,ls,ds)     = (unzip3 . map fmtOpt) optDescr+         table          = zipWith3 paste (sameLen ss) (sameLen ls) (sameLen ds)+         paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z+         sameLen xs     = flushLeft ((maximum . map length) xs) xs+         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]++fmtOpt :: OptDescr a -> (String,String,String)+fmtOpt (Option sos los ad descr) = (sepBy ", " (map (fmtShort ad) sos),+                                    sepBy ", " (map (fmtLong  ad) los),+                                    descr)+   where sepBy _   []     = ""+         sepBy _   [x]    = x+         sepBy sep (x:xs) = x ++ sep ++ sepBy sep xs++fmtShort :: ArgDescr a -> Char -> String+fmtShort (NoArg  _   ) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg  _   ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"++getOpt :: ArgOrder a                   -- non-option handling+       -> [OptDescr a]                 -- option descriptors+       -> [String]                     -- the commandline arguments+       -> ([a],[String],[String])      -- (options,non-options,error messages)+getOpt _        _        []   =  ([],[],[])+getOpt ordering optDescr args = procNextOpt opt ordering+   where procNextOpt (Opt o)    _                 = (o:os,xs,es)+         procNextOpt (NonOpt x) RequireOrder      = ([],x:rest,[])+         procNextOpt (NonOpt x) Permute           = (os,x:xs,es)+         procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es)+         procNextOpt EndOfOpts  RequireOrder      = ([],rest,[])+         procNextOpt EndOfOpts  Permute           = ([],rest,[])+         procNextOpt EndOfOpts  (ReturnInOrder f) = (map f rest,[],[])+         procNextOpt (OptErr e) _                 = (os,xs,e:es)++         (opt,rest) = getNext args optDescr+         (os,xs,es) = getOpt ordering optDescr rest++-- take a look at the next cmd line arg and decide what to do with it+getNext :: [String] -> [OptDescr a] -> (OptKind a,[String])+getNext (('-':'-':[]):rest) _        = (EndOfOpts,rest)+getNext (('-':'-':xs):rest) optDescr = longOpt xs rest optDescr+getNext (('-':x:xs)  :rest) optDescr = shortOpt x xs rest optDescr+getNext (a           :rest) _        = (NonOpt a,rest)+getNext []                  _        = error "getNext: impossible"++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt xs rest optDescr = long ads arg rest+   where (opt,arg) = break (=='=') xs+         options   = [ o  | o@(Option _ ls _ _) <- optDescr,+		            l <- ls, opt `isPrefixOf` l ]+         ads       = [ ad | Option _ _ ad _ <- options ]+         optStr    = ("--"++opt)++         long (_:_:_)      _        rest1     = (errAmbig options optStr,rest1)+         long [NoArg  a  ] []       rest1     = (Opt a,rest1)+         long [NoArg  _  ] ('=':_)  rest1     = (errNoArg optStr,rest1)+         long [ReqArg _ d] []       []        = (errReq d optStr,[])+         long [ReqArg f _] []       (r:rest1) = (Opt (f r),rest1)+         long [ReqArg f _] ('=':ys) rest1     = (Opt (f ys),rest1)+         long [OptArg f _] []       rest1     = (Opt (f Nothing),rest1)+         long [OptArg f _] ('=':ys) rest1     = (Opt (f (Just ys)),rest1)+         long [_]          (_  :_)  _         = error "long: impossible"+         long []           _        rest1     = (errUnrec optStr,rest1)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt x xs rest optDescr = short ads xs rest+  where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]+        ads     = [ ad | Option _ _ ad _ <- options ]+        optStr  = '-':[x]++        short (_:_:_)        _  rest1     = (errAmbig options optStr,rest1)+        short (NoArg  a  :_) [] rest1     = (Opt a,rest1)+        short (NoArg  a  :_) ys rest1     = (Opt a,('-':ys):rest1)+        short (ReqArg _ d:_) [] []        = (errReq d optStr,[])+        short (ReqArg f _:_) [] (r:rest1) = (Opt (f r),rest1)+        short (ReqArg f _:_) ys rest1     = (Opt (f ys),rest1)+        short (OptArg f _:_) [] rest1     = (Opt (f Nothing),rest1)+        short (OptArg f _:_) ys rest1     = (Opt (f (Just ys)),rest1)+        short []             [] rest1     = (errUnrec optStr,rest1)+        short []             ys rest1     = (errUnrec optStr,('-':ys):rest1)++-- miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr = OptErr (usageInfo header ods)+   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument "+			  ++ d ++ "\n")++errUnrec :: String -> OptKind a+errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n")++errNoArg :: String -> OptKind a+errNoArg optStr = OptErr ("option `" ++ optStr+			  ++ "' doesn't allow an argument\n")++{-+------------------------------------------------------------------------------+-- and here a small and hopefully enlightening example:++data Flag+  = Verbose+  | Version+  | Name String+  | Output String+  | Arg String   deriving Show++options :: [OptDescr Flag]+options =+   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",+    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",+    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",+    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]++out :: Maybe String -> Flag+out Nothing  = Output "stdout"+out (Just o) = Output o++test :: ArgOrder Flag -> [String] -> String+test order cmdline =+    case getOpt order options cmdline of+        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"+        (_,_,errs) -> concat errs ++ usageInfo header options+   where header = "Usage: foobar [OPTION...] files..."++-- example runs:+-- putStr (test RequireOrder ["foo","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["foo","-v"])+--    ==> options=[Verbose]  args=["foo"]+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])+--    ==> options=[Arg "foo", Verbose]  args=[]+-- putStr (test Permute ["foo","--","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])+--    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]+-- putStr (test Permute ["--ver","foo"])+--    ==> option `--ver' is ambiguous; could be one of:+--          -v      --verbose             verbosely list files+--          -V, -?  --version, --release  show version info   +--        Usage: foobar [OPTION...] files...+--          -v        --verbose             verbosely list files  +--          -V, -?    --version, --release  show version info     +--          -o[FILE]  --output[=FILE]       use FILE for dump     +--          -n USER   --name=USER           only dump USER's files+------------------------------------------------------------------------------+-}
+ tools/base/lib/HEADER.html view
@@ -0,0 +1,20 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!-- This file is included by the web server in the automatically generated+     directory index.+-->+<head>+<title>Programatica Tools, tools/base/lib</title>+<link rel=parent href="../" title="Directory tools/base">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../../web/icon1.png">+</head>++<base>+<h1><img align=right src="../../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/base/lib</h2>++<p>+The README file is displayed below the directory index.
+ tools/base/lib/Lift.hs view
@@ -0,0 +1,15 @@+module Lift where+import Maybe(maybeToList)+import PrettyPrint++---+-- An experiment:++class Lift m1 m2 where+  lift :: m1 a -> m2 a++instance (Printable err,Monad m) => Lift (Either err) m where+  lift = either (fail.pp) return++instance Lift Maybe [] where+  lift = maybeToList
+ tools/base/lib/Lists.hs view
@@ -0,0 +1,54 @@+module Lists (module Lists, module List) where++import OpTypes+import List+import Products++mergeOrd        :: OrdOp a -> [a] -> [a] -> [a]+merge           :: Ord a => [a] -> [a] -> [a]+unionMany       :: Eq a => [[a]] -> [a]+mapFst          :: (a -> x) -> [(a,b)] -> [(x,b)]+mapSnds         :: (b -> y) -> [(a, [b])] -> [(a, [y])]+mapFstSnds      :: (a -> x) -> (b -> y) -> [(a, [b])] -> [(x, [y])]+subset          :: Eq a => [a] -> [a] -> Bool++infixl 1 |$|+(|$|)           :: [a -> b] -> [a] -> [b]+(\\\)           :: Eq a => [a] -> [a] -> [a]+++-- property srtedOrd leq xs     = (m `leq` n) ==> (xs !! m) `leq` (xs !! n)+-- property sorted              = sortedOrd (<=)++-- property noDuplEq eq xs      = (xs !! m) `eq` (xs !! n) ==> m === n+-- property noDupl              = noDupl (==) ++-- property mergeOrd  = sortedOrd leq xs /\ sortedOrd leq ys+--                          ==> sortedOrd leq (mergeOrd leq xs ys)+mergeOrd leq [] ys  = ys+mergeOrd leq xs []  = xs+mergeOrd leq a@(x:xs) b@(y:ys)+    | x `leq` y     = x : mergeOrd leq xs b+    | otherwise     = y : mergeOrd leq a ys +++-- property merge   = mergeOrd (<=)+merge = mergeOrd (<=)+++singleton [_]   = True+singleton _     = False++xs `subset` ys  = all (`elem` ys) xs++unionMany       = nub . concat+mapFst f        = map (f >< id)+mapSnds g       = map (id >< map g)+mapFstSnds f g  = map (f >< map g) ++(|$|)           = zipWith ($)+xs \\\ ys       = filter (`notElem` ys) xs++--elemBy,notElemBy :: (a->a->Bool) -> a -> [a] -> Bool+elemBy eq x     = not . notElemBy eq x+notElemBy eq x  = null . filter (eq x)
+ tools/base/lib/MUtils.hs view
@@ -0,0 +1,115 @@+-- Thomas' misc utils (things that are missing in the standard libraries)+module MUtils where+import Monad(ap,unless,when)+import List(groupBy,sortBy,sort)+import Maybe(fromMaybe)+--import ExceptM()++-- all eta expansions because of the stupid monomorphism restriction++infixl 1 #,#.,<#,@@, >#<++-- Infix versions of two essential operators:+f # x = fmap f x+mf <# mx  = ap mf mx++--Kleisli composition, another essential operator, sadly lacking from the+--Haskell 98 libraries:+m1 @@ m2 = \ x -> m1 =<< m2 x++f #. m = \ x -> f # m x++done :: Monad m => m ()+done = return ()++unlessM m1 m2 = do b <- m1+		   unless b m2++whenM m1 m2 = do b <- m1+		 when b m2++ifM bM tM eM = do b <- bM; if b then tM else eM+aM &&& bM = ifM aM bM (return False)+andM ms = foldr (&&&) (return True) ms+allM p = andM . map p++seqMaybe m = maybe (return Nothing) (Just # ) m++-- Property: f # x == return f <# x++(f >#< g) (x,y) = (,) # f x <# g y++mapFstM f = mapM (apFstM f)+apFstM f (x,y) = flip (,) y # f x+mapSndM f = mapM (apSndM f)+apSndM f (x,y) = (,) x # f y++concatMapM f xs = concat # mapM f xs++mapFst f = map (apFst f)+mapSnd f = map (apSnd f)+apSnd f (x,y) = (x,f y)+apFst f (x,y) = (f x,y)++mapBoth f = map (apBoth f)+apBoth f (x,y) = (f x,f y)+dup x = (x,x)+pairWith f x = (x,f x)+-- pairWith f = apSnd f . dup++mapPartition f [] = ([],[])+mapPartition f (x:xs) = either (apFst.(:)) (apSnd.(:)) (f x) (mapPartition f xs)+++collectBySnd x =+    map pick .+    groupBy eqSnd .+    sortBy cmpSnd $ x+  where+    pick xys@((_,y):_) = ({-sort $-} map fst xys,y)++collectByFst x = map swap . collectBySnd . map swap $ x++onFst f (x1,_) (x2,_) = f x1 x2+onSnd f (_,y1) (_,y2) = f y1 y2+cmpFst x = onFst compare x+cmpSnd x = onSnd compare x+eqFst x = onFst (==) x+eqSnd x = onSnd (==) x++swap (x,y) = (y,x)++mapEither f g = either (Left . f) (Right . g)+seqEither x = either (Left # ) (Right # ) x++-- squeezeDups removes adjacent duplicates (cheaper than nub):+squeezeDups (r1:rrs@(r2:_)) = if r1==r2+			      then squeezeDups rrs+			      else r1:squeezeDups rrs+squeezeDups rs = rs++usort xs = squeezeDups (sort xs)++read' s = read'' "MUtils.read'" s++read'' msg s =+  case reads s of+    [(x,r)] | readAtEnd r -> x+    [] -> error $ msg++" no parse: "++take 60 s+    _ ->  error $ msg++" ambiguous parse: "++take 60 s++readAtEnd r = lex r == [("","")]++fromJust' = fromMaybe . error++--instance Functor ((->) a) where fmap = (.)++{-+instance Functor (Either err) where+  fmap = mapEither id++instance Monad (Either err) where+  return = Right+  Left err >>= _ = Left err+  Right ans >>= m = m ans+-}
+ tools/base/lib/Monads/ContM.hs view
@@ -0,0 +1,46 @@+module ContM (HasCont(..), runCont, ContM) where++import MT+++import Monad+++newtype ContM o i = C { ($$) :: (i -> o) -> o }++runCont :: ContM i i -> i+runCont m       = m $$ id+++instance Monad (ContM o) where+  return x    = C (\k -> k x)+  C m >>= f   = C (\k -> m (\i -> f i $$ k))+  C m >> C n  = C (m . const . n)++instance HasBaseMonad (ContM o) (ContM o) where+  inBase        = id+++instance HasCont (ContM o) where+  callcc f    = C (\k -> f (\a -> C (\d -> k a)) $$ k)++++shift           :: ((a -> ContM b b) -> ContM b b) -> ContM b a+shift f         = C (\k -> runCont $ f (\a -> C (\k' -> k' (k a))))++reset           :: ContM a a -> ContM a a+reset m         = return (runCont m)+++{-+test1           = do x <- reset $ do y <- shift (\f -> do z <- f "100"+                                                          f z)+                                     return ("10 + " ++ y)+                     return $ "1 + " ++ x+++test2           = liftM ("1 + " ++) $ reset $ liftM ("10 + " ++) $ shift (\f -> return "100")+test3           = liftM ("1 + " ++) $ reset $ liftM ("10 + " ++)  $ shift $ \f -> liftM2 (\x y -> x ++ " + " ++ y) (f "100") (f "1000")+-}+
+ tools/base/lib/Monads/ContMT.hs view
@@ -0,0 +1,92 @@+module ContMT (HasCont(..), MT(..), at, Z, S, +               removeCont, runCont, WithCont) where++import MT+import Monad(liftM,MonadPlus(..))+import Control_Monad_Fix+import ImpUtils+++newtype WithCont o m i = C { ($$) :: (i -> m o) -> m o }++removeCont :: WithCont o m i -> (i -> m o) -> m o+removeCont = ($$)++runCont :: Monad m => WithCont i m i -> m i+runCont k = k $$ return+++--------------------------------------------------------------------------------+instance Monad m => Functor (WithCont o m) where+  fmap      = liftM++instance Monad m => Monad (WithCont o m) where+  return x  = C ($ x) +  C m >>= f = C $ \k -> m $ \a -> f a $$ k++instance MT (WithCont o) where+  lift m    = C (m >>=)++instance MonadPlus m => MonadPlus (WithCont o m) where+    mzero             = lift mzero+    C m1 `mplus` C m2 = C $ \k -> m1 k `mplus` m2 k+--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+instance HasEnv m ix e => HasEnv (WithCont o m) ix e where+  getEnv ix           = lift (getEnv ix)+  inModEnv ix f (C m) = C (inModEnv ix f . m)++instance HasState m ix s => HasState (WithCont o m) ix s where+  updSt ix            = lift . updSt ix++instance HasOutput m ix o => HasOutput (WithCont ans m) ix o where+  outputTree ix       = lift . outputTree ix++instance HasExcept m x => HasExcept (WithCont o m) x where+  raise               = lift . raise+  handle f m          = C $ \k -> handle (\x -> f x $$ k) (m $$ k)++instance Monad m => HasCont (WithCont o m) where+  callcc f            = C $ \k -> f (\a -> C $ \d -> k a) $$ k+--------------------------------------------------------------------------------+++instance HasBaseMonad m n => HasBaseMonad (WithCont o m) n where+  inBase              = lift . inBase++instance HasRefs m r => HasRefs (WithCont () m) r where+  newRef      = lift . newRef+  readRef     = lift . readRef+  writeRef r  = lift . writeRef r++-- Magnus' fixpoint implementation+instance (MonadFix m, HasRefs m r) => MonadFix (WithCont () m) where+ mfix m = C $ \k -> do x <- newRef Nothing+                       let xcases j n = readRef x >>= maybe n j+                           k' b'      = xcases (const (k b')) (writeRef x (Just b'))+                       mfix $ \b -> do m b $$ k'+                                       xcases return (return (error "mfix in ContMT is bottom"))+                       xcases k (return ())++  ++shift     :: Monad m => ((a -> WithCont o m o) -> WithCont o m o) -> WithCont o m a+shift f   = C (\k -> runCont $ f (\a -> C (\k' -> k' =<< k a)))++reset     :: Monad m => WithCont o m o -> WithCont o m o +reset m   = C (\k -> k =<< runCont m)+++test1           :: WithCont String IO String+test1           = do x <- reset $ do y <- shift (\f -> do z <- f "100"+                                                          f z)+                                     return ("10 + " ++ y)+                     inBase (print "hello")+                     return $ "1 + " ++ x++{-+test2           = liftM ("1 + " ++) $ reset $ liftM ("10 + " ++) $ shift (\f -> return "100")+test3           = liftM ("1 + " ++) $ reset $ liftM ("10 + " ++)  $ shift $ \f -> liftM2 (\x y -> x ++ " + " ++ y) (f "100") (f "1000")+-}
+ tools/base/lib/Monads/Control_Monad_Fix.hs view
@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Fix+-- Copyright   :  (c) Andy Gill 2001,+--		  (c) Oregon Graduate Institute of Science and Technology, 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- The Fix monad.+--+--	  Inspired by the paper+--	  /Functional Programming with Overloading and+--	      Higher-Order Polymorphism/, +--	    Mark P Jones (<http://www.cse.ogi.edu/~mpj>)+--		  Advanced School of Functional Programming, 1995.+--+-----------------------------------------------------------------------------++module Control_Monad_Fix (+	MonadFix(+	   mfix	-- :: (a -> m a) -> m a+         ),+	fix	-- :: (a -> a) -> a+  ) where++import Prelude+import System.IO(fixIO)++fix :: (a -> a) -> a+fix f = let x = f x in x++class (Monad m) => MonadFix m where+	mfix :: (a -> m a) -> m a++-- Instances of MonadFix for Prelude monads++-- Maybe:+instance MonadFix Maybe where+    mfix f = let a = f (unJust a) in a+             where unJust (Just x) = x++-- List:+instance MonadFix [] where+    mfix f = case fix (f . head) of+               []    -> []+               (x:_) -> x : mfix (tail . f)++-- IO:+instance MonadFix IO where+    mfix = fixIO 
+ tools/base/lib/Monads/EnvM.hs view
@@ -0,0 +1,17 @@+module EnvM (module IxEnvM, F.HasEnv, getEnv, inEnv, inModEnv) where++import IxEnvM hiding (HasEnv(..))+import qualified MT as F ++getEnv    :: F.HasEnv m F.Z e => m e+inEnv     :: F.HasEnv m F.Z e => e -> m a -> m a+inModEnv  :: F.HasEnv m F.Z e => (e -> e) -> m a -> m a++getEnv    = F.getEnv F.this +inEnv     = F.inEnv F.this +inModEnv  = F.inModEnv F.this +++++
+ tools/base/lib/Monads/EnvMT.hs view
@@ -0,0 +1,17 @@+module EnvMT (module IxEnvMT, F.MT(..), F.HasEnv, getEnv, inEnv, inModEnv) where++import IxEnvMT hiding (HasEnv(..))+import qualified MT as F ++getEnv    :: F.HasEnv m F.Z e => m e+inEnv     :: F.HasEnv m F.Z e => e -> m a -> m a+inModEnv  :: F.HasEnv m F.Z e => (e -> e) -> m a -> m a++getEnv    = F.getEnv F.this +inEnv     = F.inEnv F.this +inModEnv  = F.inModEnv F.this +++++
+ tools/base/lib/Monads/ExceptM.hs view
@@ -0,0 +1,52 @@+module ExceptM (module ExceptM, HasExcept(..)) where++import MT+import Control_Monad_Fix++import Monad (liftM)++{- use newtype to avoid conflicts with class instances! -}+newtype ExceptM l r      = ExceptM {removeExcept :: Either l r}++{- not used+removeExcept          :: ExceptM x a -> Either x a+removeExcept          = id++mapEither f g         = either (Left . f) (Right . g)+seqEither x           = either (fmap Left) (fmap Right) x++fromEither f (Right x)= x+fromEither f (Left x) = f x++unLeft (Left x)       = x+unLeft _              = error "unLeft"+-}++unRight (ExceptM (Right x)) = x+unRight _                   = error "unRight"++instance Functor (ExceptM x) where+  fmap                = liftM++instance Monad (ExceptM x) where+  return                  = ExceptM . Right+  ExceptM (Right x) >>= f = f x+  ExceptM (Left x) >>= f  = ExceptM (Left x)++  ExceptM (Right _) >> m  = m+  ExceptM (Left x) >> m   = ExceptM (Left x)+    ++instance HasExcept (ExceptM x) x where+  raise               = ExceptM . Left+  handle h (ExceptM (Left x))   = h x+  handle h (ExceptM (Right x))  = ExceptM (Right x)+  ++instance MonadFix (ExceptM x) where+  mfix f              = let a = f (unRight a) in a++instance HasBaseMonad (ExceptM x) (ExceptM x) where+  inBase              = id    ++
+ tools/base/lib/Monads/ExceptMT.hs view
@@ -0,0 +1,68 @@+module ExceptMT (HasExcept(..), MT(..), WithExcept, removeExcept, mapExcept) +  where++import MT+import Control_Monad_Fix ++import Monad(liftM,MonadPlus(..))++newtype WithExcept x m a   = E { removeExcept :: m (Either x a) } +iso f = E . f . removeExcept+++mapExcept :: Monad m => (x -> y) -> WithExcept x m a -> WithExcept y m a+mapExcept f = iso (liftM (either (Left . f) Right))+++--------------------------------------------------------------------------------+instance Monad m => Functor (WithExcept x m) where+  fmap = liftM++instance Monad m => Monad (WithExcept x m) where+  return    = lift . return+  E m >>= f = E $ do x <- m+                     case x of +                       Left x  -> return (Left x)+                       Right a -> removeExcept (f a)+            +instance MT (WithExcept x) where+  lift m    = E (m >>= return . Right)++instance MonadPlus m => MonadPlus (WithExcept x m) where+  mzero             = lift mzero   +  E m1 `mplus` E m2 = E (m1 `mplus` m2)+--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+instance HasEnv m ix e => HasEnv (WithExcept x m) ix e where+  getEnv ix       = lift (getEnv ix)+  inModEnv ix f   = iso (inModEnv ix f)++instance HasState m ix s => HasState (WithExcept x m) ix s where+  updSt ix        = lift . updSt ix++instance HasOutput m ix o => HasOutput (WithExcept x m) ix o where+  outputTree ix   = lift . outputTree ix++instance Monad m => HasExcept (WithExcept x m) x where+  raise           = E . return . Left+  handle h (E m)  = E (m >>= either (removeExcept . h) (return . Right))++instance HasCont m => HasCont (WithExcept x m) where+  callcc f        = E $ callcc $ \k -> removeExcept $ f $ E . k . Right+  ++instance HasBaseMonad m n => HasBaseMonad (WithExcept e m) n where+  inBase          = lift . inBase++instance HasRefs m r => HasRefs (WithExcept x m) r where+  newRef          = lift . newRef+  readRef         = lift . readRef+  writeRef r      = lift . writeRef r+++instance MonadFix m => MonadFix (WithExcept x m) where+  mfix f          = E $ mfix (removeExcept . f . either undefined id)++
+ tools/base/lib/Monads/IdM.hs view
@@ -0,0 +1,21 @@+module IdM where++import MT+import Control_Monad_Fix+++newtype IdM a   = I { removeId :: a }++instance Monad IdM where+  return        = I+  I x >>= f     = f x++instance Functor IdM where+  fmap f (I x)  = I (f x)++instance HasBaseMonad IdM IdM where+  inBase        = id++instance MonadFix IdM where+  mfix f        = let r@(I x) = f x in r+
+ tools/base/lib/Monads/IdMT.hs view
@@ -0,0 +1,49 @@+module IdMT where++import MT+import Control_Monad_Fix+import Monad(liftM)+++newtype With_ m a    = I { removeId :: m a }+++instance MT With_ where+  lift              = I++instance Monad m => Monad (With_ m) where+  return            = lift . return +  I m >>= f         = I (m >>= removeId . f)++instance Monad m => Functor (With_ m) where+  fmap              = liftM++instance HasBaseMonad m n => HasBaseMonad (With_ m) n where+  inBase            = I . inBase ++instance HasEnv m ix e => HasEnv (With_ m) ix e where+  getEnv            = I . getEnv ++instance HasState m ix e => HasState (With_ m) ix e where+  updSt ix          = I . updSt ix++instance HasOutput m ix o => HasOutput (With_ m) ix o where+  outputTree ix     = I . outputTree ix++instance HasExcept m x => HasExcept (With_ m) x where+  raise             = I . raise+  handle h          = I . handle (removeId . h) . removeId++instance HasCont m => HasCont (With_ m) where+  callcc f          = I (callcc f')+    where f' k      = removeId (f (I . k))++instance HasRefs m r => HasRefs (With_ m) r where+  newRef            = I . newRef+  readRef           = I . readRef+  writeRef r        = I . writeRef r+  +instance MonadFix m => MonadFix (With_ m) where+  mfix f            = I (mfix (removeId . f))++
+ tools/base/lib/Monads/ImpUtils.hs view
@@ -0,0 +1,40 @@+module ImpUtils (module ImpUtils, HasRefs(..)) where++import Control.Monad.ST+import Data.STRef(STRef,newSTRef,readSTRef,writeSTRef)+import Data.IORef(IORef,newIORef,readIORef,writeIORef)+import MT+++instance HasBaseMonad IO IO where+  inBase    = id++instance HasRefs IO IORef where+  newRef    = newIORef+  readRef   = readIORef+  writeRef  = writeIORef++instance HasRefs (ST s) (STRef s) where+  newRef    = newSTRef+  readRef   = readSTRef+  writeRef  = writeSTRef++++newPtr      :: HasRefs m r => m (r (Maybe a))+newPtr      = newRef Nothing++writePtr    :: HasRefs m r => r (Maybe a) -> a -> m ()+writePtr p  = writeRef p . Just++get         :: HasRefs m r => (o -> r b) -> o -> m b+get f       = readRef . f++set         :: HasRefs m r => (o -> r b) -> o -> b -> m ()+set f       = writeRef . f++upd         :: HasRefs m r => (o -> r b) -> (b -> b) -> o -> m ()+upd f g o   = let r = f o in writeRef r . g =<< readRef r+++
+ tools/base/lib/Monads/IxEnvM.hs view
@@ -0,0 +1,33 @@+module IxEnvM (HasEnv(..), EnvM, withEnv) where++import MT+import Control_Monad_Fix+++newtype EnvM e a  = E { ($$) :: e -> a }++withEnv :: e -> EnvM e a -> a+withEnv e f       = f $$ e ++mapEnv :: (e2 -> e1) -> EnvM e1 a -> EnvM e2 a+mapEnv f (E g)    = E (g . f)++instance Functor (EnvM e) where+  fmap f (E g)    = E (f . g)++instance Monad (EnvM e) where+  return x        = E (\e -> x)+  f >>= g         = E (\e -> g (f $$ e) $$ e)+  f >> g          = g++instance HasEnv (EnvM e) Top e where+  getEnv _        = E (\e -> e)+  inModEnv _      = mapEnv +  inEnv _ e f     = return (f $$ e) ++instance MonadFix (EnvM e) where+  mfix f          = E (\e -> let a = f a $$ e in a)++instance HasBaseMonad (EnvM e) (EnvM e) where+  inBase          = id+
+ tools/base/lib/Monads/IxEnvMT.hs view
@@ -0,0 +1,69 @@+module IxEnvMT (HasEnv(..), MT(..), at, Z, S, Top, Under, WithEnv, withEnv, mapEnv) where++import MT+import Control_Monad_Fix++import Monad(liftM,MonadPlus(..))+++newtype WithEnv e m a = E { unE :: e -> m a }+++withEnv :: e -> WithEnv e m a -> m a+withEnv e (E f) = f e++mapEnv :: Monad m => (e2 -> e1) -> WithEnv e1 m a -> WithEnv e2 m a+mapEnv f (E m) = E (\e -> m (f e))+++--------------------------------------------------------------------------------+instance Monad m => Functor (WithEnv e m) where+    fmap        = liftM++instance Monad m => Monad (WithEnv e m) where+    return      = lift . return+    E m >>= f   = E (\e -> do x <- m e; unE (f x) e)+    E m >> n    = E (\e -> m e >> withEnv e n)+    fail        = lift . fail++instance MT (WithEnv e) where+    lift        = E . const++instance MonadPlus m => MonadPlus (WithEnv e m) where+    mzero           = lift mzero +    E a `mplus` E b = E (\e -> a e `mplus` b e)+--------------------------------------------------------------------------------+++-- Features --------------------------------------------------------------------+instance Monad m => HasEnv (WithEnv e m) Z e where+    getEnv _    = E return+    inModEnv _  = mapEnv++instance HasEnv m ix e => HasEnv (WithEnv e' m) (S ix) e where+    getEnv (Next ix)        = lift (getEnv ix)+    inModEnv (Next ix) f m  = E (\e -> inModEnv ix f (withEnv e m))++instance HasState m ix s => HasState (WithEnv e m) ix s where+    updSt ix  = lift . updSt ix++instance HasOutput m ix o => HasOutput (WithEnv e m) ix o where+    outputTree ix = lift . outputTree ix++instance HasExcept m x => HasExcept (WithEnv e m) x where+    raise           = lift . raise+    handle h (E m)  = E (\e -> handle (withEnv e . h) (m e))++instance HasCont m => HasCont (WithEnv e m) where+    callcc f    = E (\e -> callcc (\k -> withEnv e $ f (lift . k)))++instance MonadFix m => MonadFix (WithEnv e m) where+    mfix f      = E (\e -> mfix (withEnv e . f))++instance HasBaseMonad m n => HasBaseMonad (WithEnv e m) n where+    inBase      = lift . inBase++instance HasRefs m r => HasRefs (WithEnv e m) r where+    newRef   = lift . newRef+    readRef  = lift . readRef+    writeRef r = lift . writeRef r
+ tools/base/lib/Monads/IxOutputM.hs view
@@ -0,0 +1,37 @@+module IxOutputM +  (HasOutput(..), OutputM, foldOutput, listOutput, mapOutput) where++import MT+import Control_Monad_Fix++import Tree++data OutputM o a = O a (Tree o)+++foldOutput :: b -> (o -> b) -> (b -> b -> b) -> OutputM o a -> (a,b)+foldOutput e s j (O x tree)  = (x, Tree.fold e s j tree)++listOutput :: OutputM o a -> (a,[o])+listOutput (O x o)          = (x, Tree.toList o)++mapOutput :: (o -> p) -> OutputM o a -> OutputM p a+mapOutput f (O x tree)      = O x (fmap f tree)+++instance Functor (OutputM o) where+    fmap f (O x o)          = O (f x) o++instance Monad (OutputM o) where+    return x                = O x Tree.Empty+    O x o >>= f             = let O y p = f x in O y (o `Tree.merge` p)+    O x o >> O y p          = O y (o `Tree.merge` p)++instance HasOutput (OutputM o) Z o where+    outputTree _ t          = O () t++instance MonadFix (OutputM o) where+    mfix f = let it@(O a _) = f a in it++instance HasBaseMonad (OutputM o) (OutputM o) where+  inBase = id
+ tools/base/lib/Monads/IxOutputMT.hs view
@@ -0,0 +1,79 @@+module IxOutputMT (HasOutput(..), MT(..), at, Z, S, Top, Under, WithOutput, +                   removeOutput, listOutput, foldOutput, mapOutput ) where ++import MT+import Control_Monad_Fix++import Monad(liftM,MonadPlus(..))+import Tree+++newtype WithOutput o m a = O { unO :: m (a, Tree o) } ++-- removeOutput :: Monad m => b -> (o -> b) -> (b -> b -> b) +--                    -> WithOutput o m a -> m (a,b)+removeOutput = unO++foldOutput empty single join (O m) = +  do (a,t) <- m+     return (a,Tree.fold empty single join t)++listOutput :: Monad m => WithOutput o m a -> m (a,[o])+listOutput (O m) = do (a,o) <- m; return (a, Tree.toList o)++mapOutput :: Monad m => (o -> p) -> WithOutput o m a -> WithOutput p m a+mapOutput f (O m) = O $ do (a,o) <- m; return (a, fmap f o)+++--------------------------------------------------------------------------------+instance Monad m => Functor (WithOutput o m) where+  fmap = liftM++instance Monad m => Monad (WithOutput o m) where+  return    = lift . return+  O m >>= f = O $ do (a,o) <- m+                     (b,p) <- unO (f a)+                     return (b, o `Tree.merge` p)++instance MT (WithOutput o) where+  lift m = O $ do x <- m; return (x, Tree.Empty)++instance MonadPlus m => MonadPlus (WithOutput o m) where+  mzero             = lift mzero+  O m1 `mplus` O m2 = O (m1 `mplus` m2)+--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+instance HasEnv m ix e => HasEnv (WithOutput o m) ix e where+  getEnv ix           = lift (getEnv ix)+  inModEnv ix f (O m) = O (inModEnv ix f m)++instance HasState m ix s => HasState (WithOutput o m) ix s where+  updSt ix            = lift . updSt ix++instance Monad m => HasOutput (WithOutput o m) Z o where+  outputTree _ t      = O (return ((),t))++instance HasOutput m ix o => HasOutput (WithOutput o' m) (S ix) o where+  outputTree (Next ix) = lift . outputTree ix++instance HasExcept m x => HasExcept (WithOutput o m) x where+  raise               = lift . raise+  handle h            = O . (handle (unO . h)) . unO++instance HasCont m => HasCont (WithOutput o m) where+  callcc f            = O $ callcc $ \k -> unO $ f $ \a -> O $ k (a,Tree.Empty)++instance HasBaseMonad m n => HasBaseMonad (WithOutput o m) n where+  inBase              = lift . inBase++instance HasRefs m r => HasRefs (WithOutput o m) r where+  newRef              = lift . newRef+  readRef             = lift . readRef+  writeRef r          = lift . writeRef r++instance MonadFix m => MonadFix (WithOutput o m) where+  mfix f              = O (mfix (\ ~(a,_) -> unO (f a)))++
+ tools/base/lib/Monads/IxStateM.hs view
@@ -0,0 +1,41 @@+module IxStateM (HasState(..), StateM, withSt, withStS, mapState) where++import MT+import Control_Monad_Fix+++newtype StateM s a   = S { ($$) :: s -> (a,s) }+++withSt :: s -> StateM s a -> a+withSt s m      = fst (m $$ s)++withStS :: s -> StateM s a -> (a,s)+withStS s m     = m $$ s++mapState :: (t -> s) -> (s -> t) -> StateM s a -> StateM t a +mapState inF outF m = S (\s -> let (a,s1) = m $$ inF s in (a, outF s1))++instance Functor (StateM s) where+    fmap f m        = m >>= return . f++instance Monad (StateM s) where+    return x  = S (\s -> (x,s) )+    f >>= g   = S (\s -> let (x,s1) = f $$ s in g x $$ s1)++instance HasState (StateM s) Z s where+    updSt  _ f = S (\s -> (s , f s))+    updSt_ _ f = S (\s -> ((), f s))+    getSt  _   = S (\s -> (s , s  ))+    setSt  _ s = S (\t -> (t , s  ))+    setSt_ _ s = S (\_ -> ((), s  ))+++instance MonadFix (StateM s) where+    mfix f = S (\s -> let S m    = f a+                          (a,s1) = case m s of (a,s1) -> (a,s1)+                      in (a,s1))++instance HasBaseMonad (StateM s) (StateM s) where+  inBase = id+
+ tools/base/lib/Monads/IxStateMT.hs view
@@ -0,0 +1,82 @@+module IxStateMT (HasState(..), MT, at, Z, S, Top, Under,+                  WithState, withSt, withStS, mapState) where++import MT+import Control_Monad_Fix++import Monad(liftM,MonadPlus(..))+++newtype WithState s m a = S { ($$) :: s -> m (a,s) }++withSt :: Monad m => s -> WithState s m a -> m a+withSt s = liftM fst . withStS s++withStS :: s -> WithState s m a -> m (a,s)+withStS s (S f) = f s++mapState :: Monad m => +            (t -> s) -> (s -> t) -> WithState s m a -> WithState t m a+mapState inF outF (S m) = S (liftM outF' . m . inF)+  where outF' (a,s) = (a, outF s)++++--------------------------------------------------------------------------------+instance Monad m => Functor (WithState s m) where+  fmap        = liftM ++instance Monad m => Monad (WithState s m) where+  return x    = S (\s -> return (x,s))+  S m >>= f   = S (\s -> m s >>= \(a,s') -> f a $$ s')+  fail msg    = S (\s -> fail msg)++instance MT (WithState s) where+  lift m      = S (\s -> do a <- m; return (a,s))++instance MonadPlus m => MonadPlus (WithState s m) where+  mzero             = lift mzero+  S m1 `mplus` S m2 = S (\s -> m1 s `mplus` m2 s)+--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+instance HasEnv m ix e => HasEnv (WithState s m) ix e where+  getEnv ix           = lift (getEnv ix)+  inModEnv ix f (S m) = S (inModEnv ix f . m)++instance Monad m => HasState (WithState s m) Z s where+  updSt _ f       = S (\s -> return (s, f s))++instance HasState m ix s => HasState (WithState s' m) (S ix) s where+  updSt (Next ix) = lift . updSt ix++instance HasOutput m ix o => HasOutput (WithState s m) ix o where+  outputTree ix   = lift . outputTree ix++instance HasExcept m x => HasExcept (WithState s m) x where+  raise           = lift . raise+  handle f (S m)  = S (\s -> handle (withStS s . f) (m s))++-- jumping undoes effects+instance HasCont m => HasCont (WithState s m) where+   callcc f       = S $ \s -> callcc $ \break -> withStS s $ f $ \a -> lift $ break (a,s)+--   callcc f       = S $ \s -> callcc $ \break -> withStS s $ f $ \a -> S $ \s' -> break (a,s')+-- jumping preserves effects++++instance HasBaseMonad m n => HasBaseMonad (WithState s m) n where+    inBase      = lift . inBase++instance HasRefs m r => HasRefs (WithState o m) r where+    newRef      = lift . newRef+    readRef     = lift . readRef+    writeRef r  = lift . writeRef r+++instance MonadFix m => MonadFix (WithState s m) where+  mfix f = S (\s -> mfix $ \ ~(a,_) -> withStS s (f a))+++        
+ tools/base/lib/Monads/MT.hs view
@@ -0,0 +1,151 @@+module MT where++import Tree++class MT t where+  lift :: (Monad m, Monad (t m)) => m a -> t m a++{-+class MapMT t where+  mapMT :: (Monad m, Monad n) => (forall a. m a -> n a) -> t m a -> t n a+-}+data Z+newtype S n = Next n++at    = undefined+this  = at::Z+++type Top    = Z+type Under  = S+++-- Properties are written in a style like the one described +-- in the paper "Evaluation Logics" by Andy Pitts+++-- properties are not exhaustive, they are just things that came to mind /Iavor+++--------------------------------------------------------------------------------+class Monad m => HasEnv m ix e | m ix -> e where+  getEnv    :: ix -> m e+  inEnv     :: ix -> e -> m a -> m a+  inModEnv  :: ix -> (e -> e) -> m a -> m a++  inEnv ix e       = inModEnv ix (const e)+  inModEnv ix f m  = do e <- getEnv ix; inEnv ix (f e) m++  -- define at least one of:+  --  * getEnv, inEnv+  --  * getEnv, inModEnv++  -- properties:++  -- getEnv ix >> m = m++  -- [ x <- getEnv+  --   y <- m +  --   z <- getEnv ] (x == z)++  -- inModEnv ix f getEnv = fmap f (getEnv ix)++--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+class Monad m => HasState m ix s | m ix -> s where+  updSt   :: ix -> (s -> s) -> m s+  updSt_  :: ix -> (s -> s) -> m () +  getSt   :: ix -> m s+  setSt   :: ix -> s -> m s+  setSt_  :: ix -> s -> m ()+  +  updSt ix f  = do s <- getSt ix; setSt ix (f s)+  setSt ix    = updSt ix . const+  getSt ix    = updSt ix id++  updSt_ ix f = do updSt ix f; return ()+  setSt_ ix s = do setSt ix s; return ()++  -- define at least one of:+  --  * updSt+  --  * getSt, setSt++  -- properties:++  -- getSt ix >> m = m++  -- [ x <- getSt ix+  --   y <- updSt ix f ] (x = y)++  -- [ x <- getSt ix +  --   y <- updSt ix f+  --   z <- getSt ix ] (z = f x)+ ++--------------------------------------------------------------------------------++  +--------------------------------------------------------------------------------+class Monad m => HasOutput m ix o | m ix -> o where+  output      :: ix -> o -> m ()+  outputs     :: ix -> [o] -> m ()+  outputTree  :: ix -> Tree o -> m ()   ++  output ix   = outputTree ix . Tree.Single+  outputs ix  = mapM_ (output ix)++  outputTree ix Tree.Empty      = return ()+  outputTree ix (Tree.Single x) = output ix x+  outputTree ix (Tree.Node x y) = outputTree ix x >> outputTree ix y++  -- define at least one of:+  -- * outputTree+  -- * output++  +--------------------------------------------------------------------------------++++--------------------------------------------------------------------------------+class Monad m => HasExcept m x | m -> x where+  raise   :: x -> m a+  handle  :: (x -> m a) -> m a -> m a++  -- define at least one of:+  --  * raise, handle+++-- m `catch` h = handle h m++instance HasExcept Maybe () where+  raise _           = Nothing+  handle h Nothing  = h ()+  handle h x        = x+--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+class Monad m => HasCont m where+  callcc :: ((a -> m b) -> m a) -> m a+--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+class (Monad m, Monad n) => HasBaseMonad m n | m -> n where+  inBase :: n a -> m a+--------------------------------------------------------------------------------+++--------------------------------------------------------------------------------+class Monad m => HasRefs m r | m -> r where+  newRef    :: a -> m (r a)+  readRef   :: r a -> m a+  writeRef  :: r a -> a -> m ()+--------------------------------------------------------------------------------++++
+ tools/base/lib/Monads/Makefile view
@@ -0,0 +1,9 @@+GHC_OPTS=-package lang -fglasgow-exts # -O2 -prof -auto-all ++all:+	-mkdir GHC_files+	ghc ${GHC_OPTS} --make *.hs -hidir GHC_files -odir GHC_files+	 ++clean: +	-rm -r GHC_files
+ tools/base/lib/Monads/Monadic.hs view
@@ -0,0 +1,41 @@+module Monadic(module Monadic, module Monad) where++import Monad++infixl 1 #, <#++( # )         :: Monad m => (a -> b) -> (m a -> m b)+( # )         = liftM++(<#)          :: Monad m => m (a -> b) -> m a -> m b+(<#)          = ap+++whenM         :: Monad m => m Bool -> m () -> m ()+whenM p m     = do b <- p; when b m++unlessM       :: Monad m => m Bool -> m () -> m ()+unlessM p m   = whenM (notM p) m++notM          :: Monad m => m Bool -> m Bool+notM p        = liftM not p++whileM        :: Monad m => m Bool -> m () -> m ()+whileM p m    = whenM p (m >> whileM p m)++untilM        :: Monad m => m () -> m Bool -> m ()+m `untilM` p  = m >> unlessM p (m `untilM` p)+++m <&& n       = do b <- m +                   if b then n else return False+m <|| n       = do b <- m+                   if b then return True else n+  +allM p xs     = foldr (<&&) (return True) (map p xs)+anyM p xs     = foldr (<||) (return False) (map p xs)+++++
+ tools/base/lib/Monads/NonDetM.hs view
@@ -0,0 +1,33 @@+module NonDetM (NonDetM, withStrat) where++import Tree+import Monad+import MT+import Control_Monad_Fix++newtype NonDetM a     = ND { unND :: Tree a }++withStrat            :: (Tree a -> b) -> NonDetM a -> b+withStrat f (ND m)    = f m+++instance Functor NonDetM where+  fmap                = liftM++instance Monad NonDetM where+  return x            = ND (return x)+  ND m >>= f          = ND (m >>= unND . f)++instance MonadPlus NonDetM where+  mzero               = ND mzero+  mplus (ND x) (ND y) = ND (mplus x y)++instance HasBaseMonad NonDetM NonDetM where+  inBase              = id++instance MonadFix NonDetM where+  mfix f                = ND (mfix (unND . f))++++
+ tools/base/lib/Monads/NonDetMT.hs view
@@ -0,0 +1,64 @@+module NonDetMT (WithNonDet, removeNonDet) where++import Tree+import Monad+import MT+import Control_Monad_Fix++newtype WithNonDet m a  = ND { removeNonDet :: m (Tree a) }+++instance Monad m => Functor (WithNonDet m) where+  fmap                  = liftM++instance Monad m => Monad (WithNonDet m) where+  return x              = ND (return (return x))+  ND m >>= f            = ND (liftM join . Tree.mapM (removeNonDet . f) =<< m)++instance MT WithNonDet where+  lift m                = ND (liftM return m)++instance Monad m => MonadPlus (WithNonDet m) where+  mzero                 = ND (return mzero)+  mplus (ND x) (ND y)   = ND (liftM2 mplus x y)++++instance HasEnv m ix e => HasEnv (WithNonDet m) ix e where+  getEnv                = lift . getEnv +  inModEnv ix f (ND m)  = ND (inModEnv ix f m)++instance HasState m ix s => HasState (WithNonDet m) ix s where+  updSt ix              = lift . updSt ix ++instance HasOutput m ix o => HasOutput (WithNonDet m) ix o where+  outputTree ix         = lift . outputTree ix ++instance HasExcept m x => HasExcept (WithNonDet m) x where+  raise                 = lift . raise +  handle h (ND m)       = ND (handle (removeNonDet . h) m)++instance HasCont m => HasCont (WithNonDet m) where+  callcc f              = ND $ callcc $ \k -> removeNonDet $ f $ ND . k . return ++instance HasBaseMonad m n => HasBaseMonad (WithNonDet m) n where+  inBase                = lift . inBase++instance HasRefs m r => HasRefs (WithNonDet m) r where+  newRef                = lift . newRef+  readRef               = lift . readRef+  writeRef r            = lift . writeRef r++instance MonadFix m => MonadFix (WithNonDet m) where+  mfix f                = ND $ do res <- mfix (removeNonDet . f . theSingle)+                                  case res of+                                    Node _ _ -> do l <- removeNonDet $ mfix (ND . liftM theLeft . removeNonDet . f)+                                                   r <- removeNonDet $ mfix (ND . liftM theRight . removeNonDet . f)+                                                   return (Node l r)+                                    _        -> return res+         ++        +++
+ tools/base/lib/Monads/OutputM.hs view
@@ -0,0 +1,15 @@+module OutputM (module IxOutputM, F.HasOutput, outputTree, output, outputs) +  where++import IxOutputM hiding (HasOutput(..))+import qualified MT as F +import Tree++outputTree :: F.HasOutput m F.Z o => Tree o -> m ()+output  :: F.HasOutput m F.Z o => o -> m ()+outputs :: F.HasOutput m F.Z o => [o] -> m ()++outputTree  = F.outputTree F.this+output      = F.output F.this+outputs     = F.outputs F.this+
+ tools/base/lib/Monads/OutputMT.hs view
@@ -0,0 +1,16 @@+module OutputMT (module IxOutputMT, F.MT(..), +                 F.HasOutput, output, outputs, outputTree, listOutput) where++import IxOutputMT hiding (HasOutput(..))+import qualified MT as F +import Tree++outputTree  :: F.HasOutput m F.Z o => Tree o -> m ()+output      :: F.HasOutput m F.Z o => o -> m ()+outputs     :: F.HasOutput m F.Z o => [o] -> m ()++outputTree  = F.outputTree F.this+output      = F.output F.this+outputs     = F.outputs F.this++
+ tools/base/lib/Monads/StateM.hs view
@@ -0,0 +1,19 @@+module StateM +  (module IxStateM, F.HasState, updSt, updSt_, getSt, setSt, setSt_) where++import IxStateM hiding (HasState(..))+import qualified MT as F ++updSt   :: F.HasState m F.Z s => (s -> s) -> m s+updSt_  :: F.HasState m F.Z s => (s -> s) -> m ()+getSt   :: F.HasState m F.Z s => m s+setSt   :: F.HasState m F.Z s => s -> m s+setSt_  :: F.HasState m F.Z s => s -> m ()++updSt   = F.updSt F.this +updSt_  = F.updSt_ F.this +getSt   = F.getSt F.this+setSt   = F.setSt F.this+setSt_  = F.setSt_ F.this++
+ tools/base/lib/Monads/StateMT.hs view
@@ -0,0 +1,19 @@+module StateMT +  (module IxStateMT, F.HasState, updSt, updSt_, getSt, setSt, setSt_) where++import IxStateMT hiding (HasState(..))+import qualified MT as F ++updSt   :: F.HasState m F.Z s => (s -> s) -> m s+updSt_  :: F.HasState m F.Z s => (s -> s) -> m ()+getSt   :: F.HasState m F.Z s => m s+setSt   :: F.HasState m F.Z s => s -> m s+setSt_  :: F.HasState m F.Z s => s -> m ()++updSt   = F.updSt F.this +updSt_  = F.updSt_ F.this +getSt   = F.getSt F.this+setSt   = F.setSt F.this+setSt_  = F.setSt_ F.this++
+ tools/base/lib/Monads/Tree.hs view
@@ -0,0 +1,57 @@+module Tree where ++import Monad+import Prelude hiding (sequence)    -- doesn't work in Hugs.+import Control_Monad_Fix+++data Tree a           = Empty | Single { theSingle :: a } | Node { theLeft :: Tree a, theRight :: Tree a }+                          deriving Show++merge Empty t         = t+merge t Empty         = t+merge t1 t2           = Node t1 t2++fold e s n            = f+  where f Empty       = e+        f (Single a)  = s a+        f (Node l r)  = n (f l) (f r)++toList x              = fold id (:) (.) x []+++assertEmpty t         = Empty+assertSingle t        = Single (theSingle t)+assertNode t          = Node (theLeft t) (theRight t)+++instance Functor Tree where+  fmap                = liftM+++instance Monad Tree where+  return              = Single+  Empty    >>= f      = Empty+  Single a >>= f      = f a+  Node x y >>= f      = Node (x >>= f) (y >>= f) ++    +instance MonadPlus Tree where        +  mzero               = Empty+  mplus               = Node++instance MonadFix Tree where+  mfix f                  = obs result+    where result          = f (theSingle result)+          obs (Node _ _)  = Node (mfix (theLeft . f)) (mfix (theRight . f))+          obs x           = x+++++-- left to right+sequence             :: Monad m => Tree (m a) -> m (Tree a)+sequence              = fold (return Empty) (liftM Single) (liftM2 Node)++mapM f                = Tree.sequence . fmap f+
+ tools/base/lib/Monads/UIxStateM.hs view
@@ -0,0 +1,51 @@+module UIxStateM (HasState(..), StateM, withSt, withStS, mapState) where++import MT+import Control_Monad_Fix+++newtype StateM s a   = S (s -> (# a,s #))+++withSt :: s -> StateM s a -> a+withSt s (S m) = case m s of (# a,s #) -> a++withStS :: s -> StateM s a -> (a,s)+withStS s (S m) = case m s of (# a,s #) -> (a,s)++mapState :: (t -> s) -> (s -> t) -> StateM s a -> StateM t a +mapState inF outF (S m) = S +  (\t -> case m (inF t) of (# a,s1 #) -> (# a, outF s1 #) )++instance Functor (StateM s) where+    fmap f m        = m >>= return . f++instance Monad (StateM s) where+    return x  = S (\s -> (# x,s #) )+    S f >>= g = S (\s -> case f s of (# x,s1 #) -> +                                       case g x of S m1 -> m1 s1)++instance HasState (StateM s) Z s where+    updSt  _ f = S (\s -> (# s , f s #))+    updSt_ _ f = S (\s -> (# (), f s #))+    getSt  _   = S (\s -> (# s , s #))+    setSt  _ s = S (\t -> (# t , s #))+    setSt_ _ s = S (\_ -> (# (), s #))+++instance MonadFix (StateM s) where+    mfix f = S (\s -> let S m    = f a+                          (a,s1) = case m s of (# a,s1 #) -> (a,s1)+                      in (# a,s1 #))++instance HasBaseMonad (StateM s) (StateM s) where+  inBase = id++{- tests+foldSt :: (a -> s -> s) -> [a] -> StateM s s+foldSt f []     = getSt this+foldSt f (x:xs) = updSt_ this (f x) >> foldSt f xs+-}+++
+ tools/base/lib/Monads/UStateM.hs view
@@ -0,0 +1,19 @@+module UStateM +  (module UIxStateM, F.HasState, updSt, updSt_, getSt, setSt, setSt_) where++import UIxStateM hiding (HasState(..))+import qualified MT as F ++updSt   :: F.HasState m F.Z s => (s -> s) -> m s+updSt_  :: F.HasState m F.Z s => (s -> s) -> m ()+getSt   :: F.HasState m F.Z s => m s+setSt   :: F.HasState m F.Z s => s -> m s+setSt_  :: F.HasState m F.Z s => s -> m ()++updSt   = F.updSt F.this +updSt_  = F.updSt_ F.this +getSt   = F.getSt F.this+setSt   = F.setSt F.this+setSt_  = F.setSt_ F.this++
+ tools/base/lib/Monads/docs/Commute.txt view
@@ -0,0 +1,67 @@+This describes how the different features (a.k.a transformers) interact with each other.+If two features are orthogonal (i.e. they are independent of each other),+we say that they commute.  The motivation for this terminology is that+it does not matter in what order they are added to the system, as they+won't affect each other.++The identity monad transformer does not do anything, and so it is orthogonal to+everything.++The "plumbing" features: environment, state, and output are all orthogonal to each other.+In fact environment is also orthogonal to the all control features, but continuations.++The "control" features: exceptions, non-determinism, and continuations,+are in general not orthogonal to any other features.+++For non-orthogonal features, the rule of thumb is:+  Earlier features of the system have precedence.++This should become clearer in the following sections.++++Exceptions+==========++To illustrate the behaviour of the exception transformation, +we show its interaction with state:++WithState s (WithExcept x m)  = s -> m (Either x (a,s))+  -- rising an exception loses the state, i.e. changes to the state are not preserved+                                    +WithExcept x (WithState s m)  = s -> m (Either x a, s)+  -- raising an exception only affects the result, and not the state++One way to think of the above is:  ++  Adding state to a system that already knew about exceptions will not preserve the state. +  That is, in order to preserve the state, the system would have to do+  something special, but it was designed before there was a notion of state.++  Raising exceptions that were added after state does not affect the state.+  The reason for this is that if the state is to be undone, something special+  has to happen when writing (or reading), but that was not a design goal in the original system.+++One can also have a system where some of the state is preserved, and some is not:++  WithState volatile +( WithExcept x+( WithState static m ))+++Exceptions interact in a simillar fashion with other transformers:+if exceptions were added after output, raising an exception will not delete +the output.  However, adding output to a system with exceptions+will produce a system, where rising an exception will forget what was outputed.++++++++++  
+ tools/base/lib/Monads/docs/Makefile view
@@ -0,0 +1,9 @@+GHC_OPTS=-package lang -fglasgow-exts+DIRS=..++all:+	ghc ${GHC_OPTS} -i${DIRS} --make *.hs +	 ++clean: +	-rm *.hi *.o *.hcr a.out
+ tools/base/lib/Monads/docs/MultipleEnvs.hs view
@@ -0,0 +1,26 @@+import IxEnvMT+import StateMT+import ImpUtils++{- An exmaple of using two environments -}+++type M = WithEnv Int +       ( WithState Bool +       ( WithEnv Char +         IO ))++intOne = at :: Z+intTwo = at :: S Z+++test :: M ()+test = do+    int <- getEnv intOne+    char <- getEnv intTwo+    io $ print int+    io $ print char++main = withEnv 'a' $ withSt True $ withEnv 4 test++
+ tools/base/lib/Monads/docs/TypeInfer.lhs view
@@ -0,0 +1,139 @@+DOES NOT WORK++> module TypeInfer where+>+> import MonadTransformers+> import StateMTRefs+> import InstsST+> import System(getArgs)+++This module contains a type inference algorithm for the simply-typed+lambda calculus ala Curry.++The syntax of types and terms is as follows:++> data Type s = TyVar (TyVarName s) | Type s :-> Type s+> data Term = Var Id | Abs Id Term | App Term Term ++Identifiers are just plain strings.  Type variable names are a little+more complicated.   The reason for this is that the type inference algorithm +makes use of _unification_.   As a result, variables may be identified+with other types.  This is why we model them as pointers.++> type Id = String+> type TyVarName s = STRef s (Either Id (Type s))++The typing environment is a finite map from term variables to their +corresponding types.  We model it a list.++> type TyEnv s = [(Id,Type s)]++The type inference monad:++> type TypeInfM s+>   = WithEnv (TyEnv s)     -- typing environment+>   ( WithState [Id]        -- identifier supply+>   ( WithExcept String     -- error detection+>   ( ST s+>   )))++Making a new type variable.++> newTyVar :: TypeInfM s (Type s)+> newTyVar = do+>   x:_ <- updSt tail+>   n <- newRef (Left x)+>   return (TyVar n)+++Looking up the type of an identifier.++> -- lookupVar :: Id -> TypeInfM s (Type s)+> lookupVar x = do+>   bindings <- getEnv+>   case lookup x bindings of+>       Nothing -> raise $ "Free variable: " ++ x+>       Just t  -> return t ++> hasType :: Id -> Type s -> TyEnv s -> TyEnv s+> (x `hasType` t) bindings = (x,t) : bindings++> typeOf :: Term -> TypeInfM s (Type s)+> typeOf (Var x) = lookupVar x +> typeOf (Abs x e) = do+>   t  <- newTyVar+>   t' <- inModEnv (x `hasType` t) (typeOf e) +>   return (t :-> t')+> typeOf (App e1 e2) = do+>   t  <- typeOf e1+>   t' <- typeOf e2+>   x  <- newTyVar +>   unify t (t' :-> x)+>   return x+++> unify :: Type s -> Type s -> TypeInfM s ()+> unify (TyVar x) t = x |-> t+> unify t (TyVar x) = x |-> t+> unify (s :-> s') (t :-> t') = unify s t >> unify s' t'+++> (|->) :: TyVarName s -> Type s -> TypeInfM s ()+> x |-> t = follow t >>= bindTo+>   where+>   bindTo (TyVar y)+>       | x == y = return ()+>   bindTo t = do+>       occurs <- x `occursIn` t+>       if occurs then raise "Occurs check!" +>                 else writeRef x (Right t)++> follow it@(TyVar x) = readRef x >>= either (const (return it)) follow+> follow it = return it++> occursIn :: TyVarName s -> Type s -> TypeInfM s Bool+> x `occursIn` t = do+>   t' <- follow t+>   case t' of+>       TyVar y -> return (x == y)+>       a :-> b -> do+>           inA <- x `occursIn` a+>           inB <- x `occursIn` b+>           return (inA || inB)+++-- tests ---------------------------------------------------------------------++> test :: Term -> Either String String+> test t = runST+>   ( removeExcept+>   $ removeState_ names +>   $ removeEnv []+>   $ typeOf t >>= showType      +>   )++> showType it = do+>   t <- follow it +>   case t of+>       TyVar x -> do Left x <- readRef x; return x+>       a :-> b -> do+>           a' <- showType a+>           b' <- showType b+>           return $ "(" ++ a' ++ ") -> (" ++ b' ++ ")"++> names :: [Id]+> names = concat [ map (:d) ['a'..'z'] | d <- ["", "'"] ++ map show [1..] ]++> tId = Abs "x" $ Var "x"+> tK  = Abs "x" $ Abs "y" $ Var "x"+> tApp = Abs "f" $ Abs "x" $ App (Var "f") (Var "x")+> tS  = Abs "f" $ Abs "g" $ Abs "x" $ App (App (Var "f") (Var "x"))+>                                         (App (Var "g") (Var "x"))+> tSApp = Abs "x" $ App (Var "x" ) (Var "x")+> tO    = App tSApp tSApp++> tests = [tId, tK, tApp, tS, tSApp, tO]++> main = getArgs >>= putStrLn . show . test . (tests !!) . read . head+
+ tools/base/lib/NewSCC.hs view
@@ -0,0 +1,87 @@+module NewSCC (sccEq,scc) where++{- A module to find strongly connected components + - and perform a topological sort on them.+ - This is Lennart Augusstoson's code (from hbc?)+ - converted to Haskell by Iavor Diatchki.  + -}++import OpTypes+import Products((><))+import StateM+import Maybe (fromJust,listToMaybe)+++sccEq               :: EqOp a -> Graph a -> [Graph a]+scc                 :: Eq a => Graph a -> [Graph a]+++lkpEq eq x xs = listToMaybe [ v | (k,v) <- xs, x `eq` k ]+nonfailLkpEq eq x = fromJust . lkpEq eq x++type Graph a        = [(a, [a])]+type Numbering a    = [(a, Int)]++type RW a = (Int, Numbering a, Graph a, Int)+pushMany xs (x,ns,ss,y) = (x,ns,ss ++ xs,y)+minLast m (x,ns,ss,y)   = (x,ns,ss,min y m)+getNumbering (x,ns,ss,y) = ns+++sccEq eq gG = concat $ withSt [] $ mapM (g eq gG) gG+scc         = sccEq (==)+++g :: EqOp a -> Graph a -> (a,[a]) -> StateM (Numbering a) [Graph a]+g eq gG vv@(v,_)   = do +    low <- getSt+    let found       = const (return [])+        notFound    = let (cs4, st) = searchC eq gG 1 low vv+                      in setSt (getNumbering st) >> return cs4+    maybe notFound found (lkpEq eq v low)+++++searchC :: EqOp a -> Graph a ->+            Int -> Numbering a -> (a,[a]) -> ([Graph a], RW a)+searchC eq g n low vv@(v, es) +    | nonfailLkpEq eq v low' == min' =+            (cs' ++ [nstack],+             (n', map (id >< const maxBound) nstack ++ low', [], min'))+    | otherwise = (cs', (n', low', nstack, min'))+    where    +    cs'     = concat cs2+    (cs2, (n', low', nstack, min'))+        = let n1 = n + 1 +              initSt = (n1, (v,n1) : low , [vv], n1)+        in withStS initSt $ mapM (f eq g) es ++++-- f :: EqOp a -> Graph a -> a -> StateM (RW a) [Graph a]+f eq g v = do+    (n, low, stack, min') <- getSt+    res <- case lkpEq eq v low of+        Nothing -> let (r,s) = searchC eq g n low (findVV eq g v)+                   in do setSt s; return r+        Just vm -> do setSt (n, low, [], vm); return []++    updSt (minLast min' . pushMany stack)+    return res+++findVV :: EqOp a -> Graph a -> a -> (a, [a])+findVV eq g v = (v, nonfailLkpEq eq v g)++++test = [('c', [])+       ,('a', ['b','c'])+       ,('b', ['a'])+       ]++test1 = [('a', "b")+        ,('c', "b")+        ,('b', "")+        ]
+ tools/base/lib/NoEq.hs view
@@ -0,0 +1,14 @@+module NoEq where++{-++If you want to derive Eq for some big datatype that contains something+that does not allow equality, you can wrap it in NoEq. For example you can+use NoEq (Int->Int) instead of (Int->Int) as an argument to a constructor.+-}++newtype NoEq a = N a++instance Eq  (NoEq a) where _ == _ = True+instance Ord (NoEq a) where compare _ _ = EQ++instance Show a => Show (NoEq a) where showsPrec n (N x) = showsPrec n x
+ tools/base/lib/OpTypes.hs view
@@ -0,0 +1,15 @@+module OpTypes where++type EqOp a     = a -> a -> Bool+type OrdOp a    = a -> a -> Bool+type CmpOp a    = a -> a -> Ordering+++eqBy :: Eq a => (b -> a) -> EqOp b+eqBy f x y      = f x == f y++ordBy :: Ord a => (b -> a) -> OrdOp b+ordBy f x y      = f x <= f y++cmpBy :: Ord a => (b -> a) -> CmpOp b+cmpBy f x y      = f x `compare` f y
+ tools/base/lib/PathUtils.hs view
@@ -0,0 +1,10 @@+-- Functions for manipulating FilePaths+module PathUtils where++import System.Info(os)++-- Normalize file names:+normf ('.':x:s) | x==pathSep = normf s+normf s = s++pathSep = if os=="mingw32" then '\\' else '/'
+ tools/base/lib/Products.hs view
@@ -0,0 +1,80 @@+module Products where++toPair1 p   = proj1 p+toPair2 p   = (proj1 p, proj2 p)+toPair3 p   = (proj1 p, proj2 p, proj3 p)+toPair4 p   = (proj1 p, proj2 p, proj3 p, proj4 p)+toPair5 p   = (proj1 p, proj2 p, proj3 p, proj4 p, proj5 p)++class Prod1 p a | p -> a where+    proj1   :: p -> a++class Prod1 p a => Prod2 p a b | p -> b where+    proj2   :: p -> b++class Prod2 p a b => Prod3 p a b c | p -> c where+    proj3   :: p -> c++class Prod3 p a b c => Prod4 p a b c d | p -> d where+    proj4   :: p -> d++class Prod4 p a b c d => Prod5 p a b c d e | p -> e where+    proj5   :: p -> e+++infix 8 >< ++fork                :: (x -> a) -> (x -> b) -> x -> (a,b)+(><)                :: (x -> y) -> (a -> b) -> (x,a) -> (y,b)++fork f g x          = (f x, g x)+(f >< g) (x,y)      = (f x, g y)+++instance Prod1 (a,b) a where+    proj1 (x,_)         = x++instance Prod1 (a,b,c) a where+    proj1 (x,_,_)       = x++instance Prod1 (a,b,c,d) a where+    proj1 (x,_,_,_)     = x++instance Prod1 (a,b,c,d,e) a where+    proj1 (x,_,_,_,_)   = x+++instance Prod2 (a,b) a b where+    proj2 (_,x)         = x++instance Prod2 (a,b,c) a b where+    proj2 (_,x,_)       = x++instance Prod2 (a,b,c,d) a b where+    proj2 (_,x,_,_)     = x++instance Prod2 (a,b,c,d,e) a b where+    proj2 (_,x,_,_,_)   = x+++instance Prod3 (a,b,c) a b c where+    proj3 (_,_,x)       = x++instance Prod3 (a,b,c,d) a b c where+    proj3 (_,_,x,_)     = x++instance Prod3 (a,b,c,d,e) a b c where+    proj3 (_,_,x,_,_)   = x+++instance Prod4 (a,b,c,d) a b c d where+    proj4 (_,_,_,x)     = x++instance Prod4 (a,b,c,d,e) a b c d where+    proj4 (_,_,_,x,_)   = x+++instance Prod5 (a,b,c,d,e) a b c d e where+    proj5 (_,_,_,_,x)  = x++
+ tools/base/lib/README.html view
@@ -0,0 +1,39 @@+<title>Extensible Haskell front-end for the Programatica projects -+        directory base/parse2</title>++<h1>Extensible Haskell front-end for the Programatica projects</h1>++<h2>What is in this directory (base/lib)</h2>++<p>+This directory contains modules containing general utilities and data+structures, most of which has nothing to do with the implementation of+a Haskell front-end. One exception is the module <b class=mod>Unlit</b>.++<table>+<tr><th>Module+    <th>Purpose+<tr><td><b class=mod>MUtils</b>+    <td>Thomas' misc utilities, defines some essential combinators, sadly+        missing from the Haskell 98 libraries+<tr><td><b class=mod>Lists</b>+    <td>List functions missing from the Haskell 98 <b class=mod>List</b>+        module.+<tr><td><b class=mod>NewSCC</b>+    <td>A function computing strongly connected components.+        (It is used in the module system and the type checker.)+<tr><td><b class=mod>UTF8</b>+    <td>Functions for dealing with the UTF-8 encoding of Unicode text,+        borrowed from HBC.+        Current Haskell implementations do not support Unicode very well...+<tr><td><b class=mod>UTF8Util</b>+    <td>Additional UTF-8 utilities.+<tr><td><b class=mod>AbstractIO</b>+    <td>Classes to abstract away from the monolithic <b class=tcon>IO</b>+        monad.+<tr><td><b class=mod>Unlit</b>+    <td>Implements the translation from literate style Haskell to normal+        Haskell source code.+<tr><td>...+    <td>...+</table>
+ tools/base/lib/Recursive.hs view
@@ -0,0 +1,13 @@+module Recursive where++{-++This module defines a general class for converting to/from a recursive type+and its underlying structure.+-}++class Rec r struct | r -> struct where+  r    :: struct -> r+  struct :: r    -> struct++  mapRec :: (struct ->struct) -> r -> r+  mapRec f = r . f . struct
+ tools/base/lib/Runnable.hs view
@@ -0,0 +1,18 @@+module Runnable where+++class Runnable0 m where+    runM0 :: m a -> a++class Runnable1 m h where+    runM1  :: h -> m a -> a+    runM1' :: h -> m a -> (a,h)++    runM1  h m = fst (runM1' h m)+    runM1' h m = (runM1 h m, h)++class Runnable2 m f where+    runM2 :: f a -> m a -> a++class Monad m => Runnable m a | m -> a where+    runM :: a -> m b -> b
+ tools/base/lib/SIO.hs view
@@ -0,0 +1,55 @@+{-++An IO wrapper monad for redirecting Stdio.+-}+module SIO(SIO,StdIOops(..),runSIO,withStdio,inBase) where+import Prelude hiding (getContents,readFile,writeFile,ioError,catch,putStr)+import AbstractIO as A+import EnvMT as E+import MT(HasBaseMonad(..),HasEnv(..),Z)+import MUtils++newtype SIO a = SIO (WithEnv StdIOops IO a)+              deriving (Functor,Monad,FileIO,SystemIO,DirectoryIO,TimeIO)++data StdIOops = StdIO {put,eput::String->IO (){-, get::IO String-}}++runSIO (SIO m) = withEnv stdIOops m+  where stdIOops = StdIO { put=putStr,eput=ePutStr{-,get=getContents-}}++withStdio ops = E.inEnv (ops::StdIOops)++instance HasEnv SIO Z StdIOops where+  getEnv ix = SIO E.getEnv +  inEnv _ e (SIO m) = SIO (E.inEnv e m)++--instance HasBaseMonad IO IO where inBase = id++instance HasBaseMonad SIO IO where+  inBase io = SIO $ lift io++stdPut s = do put <- put # E.getEnv+	      inBase (put s)+stdePut s = do put <- eput # E.getEnv+	       inBase (put s)+{-+stdGet = do get <- get # E.getEnv+	    inBase get+-}++instance StdIO SIO where+  putStr = stdPut+  ePutStr = stdePut+  getContents = inBase getContents++instance CatchIO IOError SIO where+  SIO m1 `catch` em2 = +     SIO $+     m1 `catch` \ e ->+     let SIO m2 = em2 e+     in m2+  ioError = SIO . ioError++instance CatchIO err m => CatchIO err (WithEnv e m) where+  m `catch` f = do e <- E.getEnv+                   lift (withEnv e m `catch` (withEnv e . f))+  ioError = lift . ioError
+ tools/base/lib/Sets.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS -cpp #-}+module Sets(module Set) where++#if __GLASGOW_HASKELL__>=604+import Data.Set as Set hiding (map,null,partition,filter,empty)+#else+import Data.Set as Set+#endif
+ tools/base/lib/SimpleGraphs.hs view
@@ -0,0 +1,47 @@+-- Graphs, with minimal assumptions about the nodes+module SimpleGraphs where++import List(nub)+import Maybe(fromMaybe)+import MUtils(collectByFst,swap)++++type Graph a = [(a,[a])]+type Reachable a = [a]++graph         ::          [(a,[a])] -> Graph a+reachable     :: Eq a  => Graph a -> [a] -> Reachable a+isReachable   :: Eq a  => Reachable a -> a -> Bool+listReachable ::          Reachable a -> [a]+neighbours    :: Eq a  => Graph a ->  a  -> [a]+nodes         ::          Graph a -> [a] -- may exclude nodes without edges+edges         ::          Graph a ->        [(a,a)]+reverseGraph  :: Ord a => Graph a ->        Graph a++graph = id++-- The set of reachable nodes from a given node in a graph:+reachable graph = r []+  where+    r reached [] = reached+    r reached (s:ss) =+      if s `elem` reached+      then r reached ss+      else r (s:reached) (push (neighbours graph s) ss)++    push [] ss = ss+    push (x:xs) ss = push xs (x:ss)++-- nonreflexive:+reachable' g = reachable g . nub . concatMap (neighbours g)++isReachable xs x = x `elem` xs+listReachable = id++neighbours g n = fromMaybe [] (lookup n g)++reverseGraph g = collectByFst . map swap . edges $ g++edges g = [(from,to)|(from,ns)<-g,to<-ns]+nodes = map fst
+ tools/base/lib/Statistics.hs view
@@ -0,0 +1,51 @@+module Statistics where+import List(sortBy)+import OpTypes(cmpBy)+import Char(toUpper)+import PrettyPrint+import Array++ppStatistics descv descu [] = empty+ppStatistics descv descu xs =+       cap descu<+>"count:"<+> n+    $$ "Total"<+>descv<>":" <+> s+    $$ "Average"<+>descv<+>"per"<+>descu<>":"<+> (s `div` n)+    $$ "Median "<+>descv<+>"per"<+>descu<>":"<+> median n (map snd sxs)+    $$ topbottom+    $$ "Histogram:"<+> ppHistogram (map snd xs)+  where+    n = length xs+    s = sum (map snd xs)+    sxs = sortBy (cmpBy snd) xs++    ppObs (n,x) = n<>":"<+>x++    top = 10+    topbottom =+      if n <= 2*top+5+      then "All      :"<+> vcat (map ppObs sxs)+      else "Top    10:"<+> vcat (map ppObs . take top . reverse $ sxs)+        $$ "Bottom 10:"<+> vcat (map ppObs . take top $ sxs)++cap (c:cs) = toUpper c:cs+cap [] = []++-- pre: n == length xs+median n xs =+  if odd n+  then xs!!(n `div` 2)+  else let x1:x2:_ = drop (n `div` 2 - 1) xs+       in (x1+x2) `div` 2++ppHistogram xs = vcat (map bar h)+  where+    bar x = "|"<>replicate (x*scale `div` m) '*'<+> (100*x `div` s)<>"%"+    h = histogram n xs+    m = maximum h+    scale = min m 50+    s = sum h+    n = min 10 (maximum xs) -- number of bars++histogram n xs = elems $ accumArray (+) 0 (0,n-1) [(x*n `div` (m+1),1)|x<-xs]+  where+    m = maximum xs
+ tools/base/lib/UTF8.hs view
@@ -0,0 +1,34 @@+module UTF8 where++-- From the Char module supplied with HBC.++-- Take a Unicode string and encode it as a string+-- with the UTF8 method.+decodeUTF8 :: String -> String+decodeUTF8 "" = ""+decodeUTF8 (c:cs) | c < '\x80' = c : decodeUTF8 cs+decodeUTF8 (c:c':cs) | '\xc0' <= c  && c  <= '\xdf' && +		      '\x80' <= c' && c' <= '\xbf' =+	toEnum ((fromEnum c `mod` 0x20) * 0x40 + fromEnum c' `mod` 0x40) : decodeUTF8 cs+decodeUTF8 (c:c':c'':cs) | '\xe0' <= c   && c   <= '\xef' && +		          '\x80' <= c'  && c'  <= '\xbf' &&+		          '\x80' <= c'' && c'' <= '\xbf' =+	toEnum ((fromEnum c `mod` 0x10 * 0x1000) + (fromEnum c' `mod` 0x40) * 0x40 + fromEnum c'' `mod` 0x40) : decodeUTF8 cs+decodeUTF8 _ = error "UniChar.decodeUTF8: bad data"++encodeUTF8 :: String -> String+encodeUTF8 "" = ""+encodeUTF8 (c:cs) =+	if c > '\x0000' && c < '\x0080' then+	    c : encodeUTF8 cs+	else if c < toEnum 0x0800 then+	    let i = fromEnum c+	    in  toEnum (0xc0 + i `div` 0x40) : +	        toEnum (0x80 + i `mod` 0x40) : +		encodeUTF8 cs+	else+	    let i = fromEnum c+	    in  toEnum (0xe0 + i `div` 0x1000) : +	        toEnum (0x80 + (i `mod` 0x1000) `div` 0x40) : +		toEnum (0x80 + i `mod` 0x40) : +		encodeUTF8 cs
+ tools/base/lib/UTF8Util.hs view
@@ -0,0 +1,26 @@+module UTF8Util where+import IO(isUserError,ioeGetErrorString)+import UTF8++utf8 = encodeUTF8 -- . arrows++{-+-- Convert \ and -> into lambda and arrow+arrows ('-':'>':s) = '\x2192':arrows s+arrows ('\\':' ':s) = '\x03bb':' ':arrows s+arrows (c:cs) = c:arrows cs+arrows [] = []+-}++-- Smileys+happy = ['\x263a']+sad = ['\x2639'] +-- Note: GHC <=5.02.2 silently truncates Unicode characters in string literals++-- Encode error output+utf8err e =+  if isUserError e+  then fail (utf8 (ioeGetErrorString e++"\n"++sad))+  else ioError e++
+ tools/base/lib/Unlit.hs view
@@ -0,0 +1,157 @@+-- From nhc13/src/comiler13/Unlit.hs+module Unlit(CommentClass(..),unlit,readHaskellFile,writeHaskellFile, optUnlit,isLiterateFile) where+import Prelude hiding (readFile)+import AbstractIO+import MUtils(apFst,pairWith)++-- Part of the following code is from "Report on the Programming Language Haskell",+-- version 1.2, appendix C.++import Char++readHaskellFile cpp path = optUnlit path =<< cppFile cpp path++writeHaskellFile path code = AbstractIO.writeFile path $ optRelit path code++cppFile Nothing path = readFile path+cppFile (Just cpp) path =+  do let tmpname = "hi/readHaskellFile.cpp.tmp" -- Use a unique name!!!+     ExitSuccess <- system (cpp++" "++path++" >"++tmpname) -- improve error message!+     src <- readFile tmpname+     removeFile tmpname+     return src++optRelit path =+  if isLiterateFile path+  then relit +  else id++optUnlit path =+  if isLiterateFile path+  then \ s -> let ((litcmnts,code),es) = unlit path s+              in if null es+	         then return (litcmnts,unlines code)+		 else fail (unlines es)+  else \ s -> return ([],s)++isLiterateFile path = last4 path == ".lhs"+  where last4 = reverse . take 4 . reverse++--------------------------------------------------------------------------------++-- basic re-literation hack+-- assume {-+\t starts encoded literate comment+-- assume > for code by default (lines starting with ' '), +-- begin/end only if code starts in first column+-- (will keep adding empty lines before \begin{code}..)+relit = unlines . inCode False . lines+  where+    inCode False []                = []+    inCode True  []                = ["\\end{code}"]+    inCode False (x:xs) +               | take 4 x=="{-+\t" = (drop 4 x):(inComment xs)+    inCode True  (x:xs) +               | take 4 x=="{-+\t" = "\\end{code}":((drop 4 x):(inComment xs))+    inCode False (x:xs) | x=="{-+" = "":(inComment xs)+    inCode True  (x:xs) | x=="{-+" = "\\end{code}":("":(inComment xs))+    inCode True  (x:xs)            = x:(inCode True xs)+    inCode False (x:xs) +               | all isSpace x     = x:(inCode False xs)+    inCode False ((' ':x):xs)      = ('>':x):(inCode False xs)+    inCode False (('#':x):xs)      = ('#':x):(inCode False xs)+    inCode False xs@(_:_)          = "\\begin{code}":(inCode True xs)++    inComment []               = []+    inComment (x:xs) | x=="-}" = "":(inCode False xs)+    inComment (x:xs)           = x:(inComment xs)++--------------------------------------------------------------------------------++--unlit :: String -> String -> String+unlit file =+--apFst new_unclassify .        -- put literate text in nested comments+  apFst (unzip . map unclassify1) . -- return comment text and code separately+  pairWith (adjacent (Blank "") . addpos file 0) . -- error checking+  classify .+  lines+--------------------------------------------------------------------------------++data Classified+  = Program String String+  | Blank String+  | Comment String+  | Include Int String+  | Pre String++classify :: [String] -> [Classified]+classify []                = []+classify (l@('\\':x):xs) | x == "begin{code}" = Blank l : allProg xs+   where allProg [] = []  -- Should give an error message, but I have no good position information.+         allProg (l@('\\':x):xs) |  x == "end{code}" = Blank l : classify xs+	 allProg (x:xs) = Program "" x:allProg xs+classify (('>':x):xs)      = Program ">" (' ':x) : classify xs+classify (('!':x):xs)      = Program "!" (' ':x) : classify xs -- Programatica extra+classify (('#':x):xs)      = (case words x of+                                (line:file:_) | all isDigit line -> Include (read line) file+                                _                                -> Pre x+                             ) : classify xs+classify (x:xs) | all isSpace x = Blank x:classify xs+classify (x:xs)                 = Comment x:classify xs++-- Old version: put literate comment lines in one-line comments+--old_unclassify = unlines . map unclassify1++data CommentClass = CodePrefix | Directive | BlankLine | LitCmnt++unclassify1 :: Classified -> ((CommentClass,String),String)+unclassify1 (Program cmnt code) = ((CodePrefix,cmnt),code)+unclassify1 (Pre s)             = ((Directive,'#':s),"")+unclassify1 (Include i f)       = ((Directive,'#':' ':show i ++ ' ':f),"")+unclassify1 (Blank cmnt)        = ((BlankLine,cmnt),"")+unclassify1 (Comment cmnt)      = ((LitCmnt,cmnt),"")++-- New version: put literate comment blocks in nested comments+-- (Drawback: these can potentially interfere with other comments)+new_unclassify = unclassify0+  where+    unclassify0 (Comment s:xs) = "{-+\t"++s++"\n"++unc xs -- -}+    unclassify0 xs = un xs++    -- Normal state, inside code block+    un [] = []+    un (Blank cmnt:Comment s:xs) = "{-+"++cmnt++"\n"++s++"\n"++unc xs -- -}+    un (x:xs) = snd (unclassify1 x)++"\n"++un xs -- ??++    -- Comment state, inside a literate comment+    unc [] = "-}\n"+    unc (Comment s:xs) = s++"\n"++unc xs+    unc (Blank s:xs) = s++"\n"++unb xs -- ??++    -- Blank line state, inside a literate comment, after a blank line+    unb [] = "-}\n"+    unb (Blank s:xs) = s++"\n"++unb xs -- ??+    unb xs@(Comment _:_) = "\n"++unc xs+    unb xs = "-}\n"++un xs++--adjacent :: Classified -> [((FilePath,Int),Classified)] -> [String]+adjacent _ [] = []+adjacent y ((pos,x):xs) =+  case (y,x) of+   (_        , Pre _      ) -> adjacent y xs+   (_        , Include _ _) -> adjacent y xs+   (Program _ _, Comment _) -> message pos "program" "comment":adjacent x xs+   (Comment _, Program _ _) -> message pos "comment" "program":adjacent x xs+   _                        -> adjacent x xs++addpos file n [] = []+addpos file n (x:xs) =+    case x of+      Include i f -> l:addpos f i xs+      _ -> l:addpos file (n+1) xs+  where l = ((file,n),x)++message pos p c = showpos pos++": "++p++ " line before "++c++" line.\n"+  where+    showpos ([],n)     = "Line "++show n+    showpos ("\"\"",n) = "Line "++show n+    showpos (file,n)   = "In file " ++ file ++ " at line "++show n
+ tools/base/myghci view
@@ -0,0 +1,6 @@+#!/bin/sh++. HuMakefile++ghci -fno-monomorphism-restriction $GHCFLAGS -i${SRC_DIRS} $*+
+ tools/base/myhugs view
@@ -0,0 +1,6 @@+#!/bin/sh++. HuMakefile++hugs -98 -P${SRC_DIRS}: $*+
+ tools/base/parse/LexUtil.hs view
@@ -0,0 +1,42 @@+-- $Id: LexUtil.hs,v 1.4 2001/11/08 22:09:28 hallgren Exp $++module LexUtil (isIdent,isLower_,  -- Char -> Bool+		isSymbol,      -- Char -> Bool+		readInteger,   -- String -> Integer+		readNumber,    -- Integer -> String -> Integer+		readRational)  -- String -> Rational++where++import HsName(isSymbol)+import Char(isDigit, isOctDigit, isHexDigit, digitToInt, isAlpha, isLower)+import Ratio++isIdent  c = isAlpha c || isDigit c || c == '\'' || c == '_'+isLower_ c = isLower c || c == '_'++readInteger :: String -> Integer+readInteger ('0':'o':ds) = readInteger2  8 isOctDigit ds+readInteger ('0':'O':ds) = readInteger2  8 isOctDigit ds+readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds+readInteger ('0':'X':ds) = readInteger2 16 isHexDigit ds+readInteger          ds  = readInteger2 10 isDigit    ds++readNumber :: Integer -> String -> Integer+readNumber radix ds = readInteger2 radix (const True) ds++readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer+readInteger2 radix isDig ds +  = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) +				    (takeWhile isDig ds))++readRational :: String -> Rational+readRational xs+    = (readInteger (i ++ m))%1 * 10^^((case e of+				       ""       -> 0+				       ('+':e2) -> read e2+				       _        -> read e) - length m)+      where (i, r1) = span isDigit xs+	    (m, r2) = span isDigit (dropWhile (== '.') r1)+	    e       = dropWhile (== 'e') r2+
+ tools/base/parse/Lexer.hs view
@@ -0,0 +1,510 @@+-- $Id: Lexer.hs,v 1.11 2001/11/08 22:09:28 hallgren Exp $++{-++ToDo: Parsing floats is a *real* hack...+ToDo: FloatTok should have three parts (integer part, fraction, exponent)+ToDo: Use a lexical analyser generator (lx?)++Known bug: It seems that _x is a valid identifier name; our lexer, on the+other hand, produces two lexemes, the wildcard followed by x. Argh!!!!+e.p. FIXED e.p.++-}++module Lexer (Token(..), lexer, isSymbol) where+++import ParseMonad+import LexUtil+import SrcLoc+import Char+import Ratio+--import IOExts(trace)+import Token+++{-++The source location, (f, y, x), is the coordinates of the previous token.+col is the current column in the source file f.  If col is 0, we are+somewhere at the beginning of the line before the first token.++Setting col to 0 is used in two places: just after emitting a virtual+close brace due to layout, so that next time through we check whether+we also need to emit a semi-colon, and at the beginning of the file,+to kick off the lexer.++-}+lexer :: (Token -> PM a) -> PM a+lexer cont =+    PM $ \input (SrcLoc f y x) col ->+    if col == 0 then tab f y x   True  input  col+                else tab f y col False input  col -- throw away old x+    where+    -- move past whitespace and comments+    tab f y x bol []          col = (unPM $ cont EOF) [] (SrcLoc f y x) col+    tab f y x bol ('\t':s)    col = tab f y (nextTab x) bol s col+    tab f y x bol ('\n':s)    col = newLine f s y col+    tab f y x bol ('-':'-':s) col = newLine f (drop 1 (dropWhile (/= '\n') s))+				      y col+    tab f y x bol ('{':'-':s) col = nestedComment tab f y x bol s col+    tab f y x bol (c:s)       col+		 | isSpace c = tab f y (x + 1) bol s col+	         | otherwise =+		     if bol then+		         (unPM $ lexBOL cont)   (c:s) (SrcLoc f y x) x+		     else+		         (unPM $ lexToken cont) (c:s) (SrcLoc f y x) x++    newLine f s y col = tab f (y + 1) 1 True s col+++nextTab x = x + (tab_length - (x - 1) `mod` tab_length)++{-++When we are lexing the first token of a line, check whether we need to+insert virtual semicolons or close braces due to layout.++-}+lexBOL :: (Token -> PM a) -> PM a+lexBOL cont =+    PM $ \ s loc@(SrcLoc f y x) col (state@ctx) ->+    if need_close_curly x ctx then +        -- trace "layout: inserting '}'\n" $+	-- Set col to 0, indicating that we're still at the+	-- beginning of the line, in case we need a semi-colon too.+	-- Also pop the context here, so that we don't insert+	-- another close brace before the parser can pop it.+        (unPM $ cont VRightCurly) s loc 0 (tail ctx)+    else if need_semi_colon x ctx then+        -- trace "layout: inserting ';'\n" $+	(unPM $ cont SemiColon) s loc col state+    else+        (unPM $ lexToken cont)  s loc col state+    where+        need_close_curly x []    = False+	need_close_curly x (i:_) = case i of+				   NoLayout -> False+				   Layout n -> x < n++        need_semi_colon x []     = False+	need_semi_colon x (i:_)  = case i of+				   NoLayout -> False+				   Layout n -> x == n+++lexToken :: (Token -> PM a) -> PM a+lexToken cont =+    PM lexToken'+    where+    lexToken' (c:s) loc@(SrcLoc f y x') x =+        -- trace ("lexer: y = " ++ show y ++ " x = " ++ show x ++ "\n") $ +	case c of+	-- First the special symbols+        '(' -> special LeftParen+        ')' -> special RightParen+        ',' -> special Comma+        ';' -> special SemiColon+        '[' -> special LeftSquare+        ']' -> special RightSquare+        '`' -> special BackQuote+        '{' -> special LeftCurly . (NoLayout:) -- push context on '{'+        '}' -> \state ->+               case state of+               _:ctxt ->+	           special RightCurly ctxt -- pop context on '}'+               []       ->+		   (unPM $ parseError "parse error (possibly incorrect indentation)")+                   s loc x []++        '\'' -> (unPM $ lexChar cont)   s loc (x + 1)+        '\"' -> (unPM $ lexString cont) s loc (x + 1)+++        c | isDigit c ->+	      case lexInt (c:s) of+	      Decimal (n, rest) ->+		  case rest of+		  ('.':c2:rest2) | isDigit c2 ->+				     case lexFloatRest (c2:rest2) of+				     Nothing -> (unPM $+						 parseError "illegal float.")+						s loc x+				     Just (n2,rest3) ->+					 let f = n ++ ('.':n2) in+				         forward (length f) (FloatTok f) rest3+		  _ -> forward (length n) (IntTok n) rest+	      Octal       (n,rest) -> forward (length n) (IntTok n) rest+	      Hexadecimal (n,rest) -> forward (length n) (IntTok n) rest++          | isLower_ c ->+	      let (vidtail, rest) = span isIdent s+		  vid             = c:vidtail+		  l_vid           = 1 + length vidtail+	      in+		  case lookup vid reserved_ids of+		  Just keyword -> forward l_vid keyword rest+		  Nothing      -> forward l_vid (VarId vid) rest++          | isUpper c ->+	      let (contail, rest) = span isIdent s+		  l_con           = 1 + length contail+		  con             = c:contail+	      in+		  case lookup con reserved_ids of+		  Just keyword -> forward l_con keyword rest+		  Nothing      -> lexQual l_con con rest+                                      (forward l_con (ConId con) rest)+		  +          | isSymbol c ->+	      let (symtail, rest) = span isSymbol s+		  sym             = c : symtail+		  l_sym           = 1 + length symtail+	      in+	          case lookup sym reserved_ops of+		  Just t  -> forward l_sym t rest+		  Nothing -> case c of+			     ':' -> forward l_sym (ConSym sym) rest+                             '.' | l_sym == 1 -> special Period+                                 | otherwise  ->+                                    forward l_sym (VarSym sym) rest+			     _   -> forward l_sym (VarSym sym) rest++          | otherwise ->+	      (unPM $+	       parseError ("illegal character \'" +++			   showLitChar c "" ++ "\'\n"))+	      s loc x+		  +      where+      special t = forward 1 t s+      forward n t s = (unPM $ cont t) s loc (x + n)+ +      lexFloatRest r = case span isDigit r of+		       (r2, 'e':r3) -> lexFloatExp (r2 ++ "e") r3+		       (r2, 'E':r3) -> lexFloatExp (r2 ++ "e") r3+		       f@(r2,   r3) -> Just f+ +      lexFloatExp r1 ('-':r2) = lexFloatExp2 (r1 ++ "-") r2+      lexFloatExp r1 ('+':r2) = lexFloatExp2 (r1 ++ "+") r2+      lexFloatExp r1      r2  = lexFloatExp2 r1          r2++      lexFloatExp2 r1 r2 = case span isDigit r2 of+			   ("", _ ) -> Nothing+			   (ds, r3) -> Just (r1++ds,r3)++      lexQual l_mod mod s lexConId =+          case s of+          '.':c:rest+           | isLower c ->	-- qualified varid?+	       let (vidtail, rest1) = span isIdent rest+		   vid              = c:vidtail+		   l_vid            = 1 + length vidtail+	       in+	       case lookup vid reserved_ids of -- cannot qualify reserved word+	       Just keyword -> lexConId+	       Nothing      -> forward (l_mod + l_vid + 1) -- + 1 for the '.'+				       (QVarId (mod, vid)) rest1++           | isUpper c ->	-- qualified conid?+	       let (con1, rest1) = span isIdent rest+		   qcon          = c : con1+		   l_con1        = 1 + length con1+	       in+		   forward (l_mod + l_con1 + 1) -- + 1 for the '.'+			   (QConId (mod, qcon)) rest1++           | isSymbol c ->	-- qualified symbol?+               let (symtail, rest1) = span isSymbol rest    +		   sym              = c : symtail+		   l_sym            = 1 + length symtail+               in+	       case lookup sym reserved_ops of+	       -- cannot qualify a reserved operator+	       Just _  -> lexConId+	       Nothing ->+		   case c of+	           ':' -> forward (l_mod + l_sym + 1) -- + 1 for the '.'+			          (QConSym (mod, sym)) rest1+		   _   -> forward (l_mod + l_sym + 1) -- + 1 for the '.'+			          (QVarSym (mod, sym)) rest1++           -- special case for M.[]; allows whitespace between '[' and ']'+	   -- (provided layout is not violated)+           | c == '[' ->+	       case snd $ span isSpace rest of+	       (']':_) -> forward l_mod (QModId mod) s+               _       -> lexConId++           -- special case for M.(), M.(,,,), etc.; allows whitespace between+	   -- '(' and ')', and '(' and ',' (provided layout is not violated)+           | c == '(' ->+	       case snd $ span isSpace rest of+	       (')':_) -> forward l_mod (QModId mod) s+               (',':_) -> forward l_mod (QModId mod) s+	       _       -> lexConId++	  _ -> lexConId -- not a qualified object+			      +    lexToken' _  _ _ =+	error "Lexer.lexToken: Internal error: empty input stream."+++lexInt ('0':o:d:r) | toLower o == 'o' && isOctDigit d+    = let (ds, rs) = span isOctDigit r+      in+           Octal       ('0':'o':d:ds, rs)+lexInt ('0':x:d:r) | toLower x == 'x' && isHexDigit d+    = let (ds, rs) = span isHexDigit r+      in +           Hexadecimal ('0':'x':d:ds, rs)+lexInt r = Decimal     (span isDigit r)+++lexChar :: (Token -> PM a) -> PM a+lexChar cont = PM lexChar'+    where+    lexChar' s loc x =+	case s of+	'\\':s ->+	    let (e, s2, i) =+		  runPM (escapeChar s) "" loc x []+	    in+                charEnd e s2 loc (x + i)+	c:s  -> charEnd c s  loc (x + 1)+	[]   -> error "Lexer.lexChar: Internal error: empty list."++    charEnd c ('\'':s)   =+	\loc x -> (unPM $ cont (Character c)) s loc (x + 1)+    charEnd c s         =+	(unPM $ parseError "improperly terminated character constant.") s +++lexString :: (Token -> PM a) -> PM a+lexString cont = PM lexString'+    where+    lexString' s loc@(SrcLoc f y _) x = loop "" s x y+	where+	loop e s x y =+	    case s of+            '\\':'&':s  -> loop e s (x+2) y+	    '\\':c:s | isSpace c -> stringGap e s (x + 2) y+		     | otherwise ->+			 let (e', sr, i) =+			       runPM (escapeChar (c:s)) ""  loc x []+                         in  loop (e':e) sr (x+i) y+            '\"':s{-"-} -> (unPM $ cont (StringTok (reverse e))) s  loc (x + 1)+	    c:s	      -> loop (c:e) s (x + 1) y+	    []          -> (unPM $ parseError "improperly terminated string.")+			            s  loc x++	stringGap e s x y =+	    case s of+		'\n':s -> stringGap e s 1 (y + 1)+	        '\\':s -> loop e s (x + 1) y+	        c:s' | isSpace c -> stringGap e s' (x + 1) y+	             | otherwise ->+			 (unPM $ parseError "illegal character in string gap.")+			 s  loc x+	        []     -> error "Lexer.stringGap: Internal error: empty list."+++escapeChar :: String -> PM (Char, String, Int)+escapeChar s = case s of+    -- Production charesc from section B.2 (Note: \& is handled by caller)+   'a':s 	 -> return ('\a', s, 2)+   'b':s 	 -> return ('\b', s, 2)+   'f':s 	 -> return ('\f', s, 2)+   'n':s 	 -> return ('\n', s, 2)+   'r':s 	 -> return ('\r', s, 2)+   't':s 	 -> return ('\t', s, 2)+   'v':s 	 -> return ('\v', s, 2)+   '\\':s        -> return ('\\', s, 2)+   '"':s         -> return ('\"', s, 2)+   '\'':s        -> return ('\'', s, 2)++    -- Production ascii from section B.2+   '^':x@(c:s)   -> cntrl x+   'N':'U':'L':s -> return ('\NUL', s, 4)+   'S':'O':'H':s -> return ('\SOH', s, 4)+   'S':'T':'X':s -> return ('\STX', s, 4)+   'E':'T':'X':s -> return ('\ETX', s, 4)+   'E':'O':'T':s -> return ('\EOT', s, 4)+   'E':'N':'Q':s -> return ('\ENQ', s, 4)+   'A':'C':'K':s -> return ('\ACK', s, 4)+   'B':'E':'L':s -> return ('\BEL', s, 4)+   'B':'S':s     -> return ('\BS',  s, 3)+   'H':'T':s  	 -> return ('\HT',  s, 3)+   'L':'F':s 	 -> return ('\LF',  s, 3)+   'V':'T':s 	 -> return ('\VT',  s, 3)+   'F':'F':s 	 -> return ('\FF',  s, 3)+   'C':'R':s 	 -> return ('\CR',  s, 3)+   'S':'O':s 	 -> return ('\SO',  s, 3)+   'S':'I':s 	 -> return ('\SI',  s, 3)+   'D':'L':'E':s -> return ('\DLE', s, 4)+   'D':'C':'1':s -> return ('\DC1', s, 4)+   'D':'C':'2':s -> return ('\DC2', s, 4)+   'D':'C':'3':s -> return ('\DC3', s, 4)+   'D':'C':'4':s -> return ('\DC4', s, 4)+   'N':'A':'K':s -> return ('\NAK', s, 4)+   'S':'Y':'N':s -> return ('\SYN', s, 4)+   'E':'T':'B':s -> return ('\ETB', s, 4)+   'C':'A':'N':s -> return ('\CAN', s, 4)+   'E':'M':s     -> return ('\EM',  s, 3)+   'S':'U':'B':s -> return ('\SUB', s, 4)+   'E':'S':'C':s -> return ('\ESC', s, 4)+   'F':'S':s     -> return ('\FS',  s, 3)+   'G':'S':s     -> return ('\GS',  s, 3)+   'R':'S':s     -> return ('\RS',  s, 3)+   'U':'S':s     -> return ('\US',  s, 3)+   'S':'P':s     -> return ('\SP',  s, 3)+   'D':'E':'L':s -> return ('\DEL', s, 4)+++   -- Depending upon the compiler/interpreter's Char type, these yield either+   -- just 8-bit ISO-8859-1 or 2^16 UniCode.  The report says it should be the+   -- latter.++   -- Octal representation of a character+   'o':s           -> let (ds, s') = span isOctDigit s+			  n        = readNumber 8 ds+                      in +		          numberToChar n s' (length ds + 1)++   -- Hexadecimal representation of a character+   'x':s           -> let (ds, s') = span isHexDigit s+			  n        = readNumber 16 ds+                      in+		          numberToChar n s' (length ds + 1)+ +   -- Base 10 representation of a charactef+   d:s | isDigit d -> let (ds, s') = span isDigit s+			  n        = readNumber 10 (d:ds)+                      in +		          numberToChar n s' (length ds + 1)++   _               -> parseError "illegal escape sequence."++   where numberToChar n s l_n =+	     if toInteger (fromEnum (minBound :: Char))<=n &&+		n <= toInteger (fromEnum (maxBound :: Char))+	     then return (chr $ fromInteger n, s, l_n)+	     else parseError $ "illegal character literal (number "+++			       show n++" out of range)."+            +{-++Production cntrl from section B.2++-}+cntrl :: String -> PM (Char, String, Int)+cntrl (c   :s) | isUpper c = return (chr (ord c - ord 'A'), s, 2)+cntrl ('@' :s)             = return ('\^@', s, 2)+cntrl ('[' :s)             = return ('\^[', s, 2)+cntrl ('\\':s)             = return ('\^\', s, 2)+cntrl (']' :s)             = return ('\^]', s, 2)+cntrl ('^' :s)             = return ('\^^', s, 2)+cntrl ('_' :s)             = return ('\^_', s, 2)+cntrl _                    = parseError "illegal control character"+++nestedComment cont f y x bol s  col =+    case s of+    '-':'}':s -> cont f y (x + 2) bol s  col+    '{':'-':s -> nestedComment (nestedComment cont) f y (x + 2) bol s  col+    '\t':s    -> nestedComment cont f y (nextTab x) bol s  col+    '\n':s    -> nestedComment cont f (y + 1) 1 True s  col+    c:s       -> nestedComment cont f y (x + 1) bol s  col+    []        -> error "Lexer.nestedComment: Internal error: empty list."+++{-+getTokens 0       = return []+getTokens (n + 1) = lexer (\t -> do { l <- getTokens n+			            ; return (t:l)+				    }+			  )++tokens f s =+    (unPM $ getTokens (length s)) s (SrcLoc f 0 0) 0+        (error "Lexer.tokens: problem with initial infix environment.", [])++-}++{-+instance Printable Token where+    ppi (VarId v)        = text v+    ppi (QVarId (m, v))  = text m <> '.' <> text v+    ppi (ConId c)        = text c+    ppi (QConId (m, c))  = text m <> '.' <> text c+    ppi (VarSym v)       = text v+    ppi (ConSym c)       = text c+    ppi (QVarSym (m, v)) = text m <> '.' <> text v+    ppi (QConSym (m, c)) = text m <> '.' <> text c+    ppi (QModId m)       = text m+    ppi (IntTok i)       = text i+    ppi (FloatTok f)     = text f+    ppi (Character ch)   = char ch+    ppi (StringTok s)    = text s++    ppi LeftParen    = lparen+    ppi RightParen   = rparen+    ppi SemiColon    = semi+    ppi LeftCurly    = lcurly+    ppi RightCurly   = rcurly+    ppi VRightCurly  = text "virtual" <+> rcurly+    ppi LeftSquare   = lbrack+    ppi RightSquare  = rbrack+    ppi Comma        = comma+    ppi Underscore   = char '_'+    ppi BackQuote    = backQuote+    ppi Period       = char '.'++    ppi DotDot       = text ".."+    ppi DoubleColon  = text "::"+    ppi Equals       = text "=="+    ppi Backslash    = char '\\'+    ppi Bar          = char '|'+    ppi LeftArrow    = text "<-"+    ppi RightArrow   = text "->"+    ppi At           = char'@'+    ppi Tilde        = char '~'+    ppi DoubleArrow  = text "=>"+    ppi Minus        = char '-'+    ppi Exclamation  = char '!'++    ppi KW_As        = text "as"+    ppi KW_Case      = text "case"     +    ppi KW_Class     = text "class"    +    ppi KW_Data      = text "data"     +    ppi KW_Default   = text "default"  +    ppi KW_Deriving  = text "deriving" +    ppi KW_Do        = text "do"       +    ppi KW_Else      = text "else"     +    ppi KW_If        = text "if"       +    ppi KW_Import    = text "import"   +    ppi KW_In        = text "in"       +    ppi KW_Infix     = text "infix"    +    ppi KW_InfixL    = text "infixl"   +    ppi KW_InfixR    = text "infixr"   +    ppi KW_Instance  = text "instance" +    ppi KW_Let       = text "let"      +    ppi KW_Module    = text "module"   +    ppi KW_NewType   = text "newtype"  +    ppi KW_Of        = text "of"       +    ppi KW_Then      = text "then"     +    ppi KW_Type      = text "type"     +    ppi KW_Where     = text "where"    +    ppi KW_Qualified = text "qualified"+    ppi KW_Hiding    = text "hiding"+    ppi KW_Primitive = text "primitive"++    ppi KW_Property  = text "property"+    ppi KW_QAll      = text "All"+    ppi KW_QExists   = text "Ex"+    ppi KW_QAllDef   = text "AllDef"++    ppi EOF = text "EOF"+-}
+ tools/base/parse/NumberNames.hs view
@@ -0,0 +1,11 @@+module NumberNames(module NumberNames,module UniqueNames) where+import NameMaps+import StateM+import UniqueNames+import MUtils++numberNames m = withSt (1::Int) . mapNamesM num $ m+  where+    num i = local i # fresh+    fresh = updSt (+1)+    local i = PN i . L
+ tools/base/parse/ParseMonad.lhs view
@@ -0,0 +1,111 @@+-----------------------------------------------------------------------------+Haskell Parser Monad+-----------------------------------------------------------------------------++\begin{code}+module ParseMonad where++import SrcLoc+import SrcLocPretty+--import HsAssoc+--import IOExts(trace)+import PrettyPrint+\end{code}++\begin{code}+data ParseResult a+    = Ok ParseState a+    | Failed String+      deriving Show++data LexContext+    = NoLayout+    | Layout Int+      deriving (Eq, Ord, Show)++--type  ParseState env = (env, [LexContext])+type  ParseState = [LexContext]++--type PM a = PME OperatorEnv a+--type PM a = PME a++newtype PM a +    =  PM (String		-- input string+          -> SrcLoc		-- location of last token read+	  -> Int		-- current column+	  -> ParseState   	-- layout info. and infix operator environment+	  -> ParseResult a)++unPM (PM p) = p++thenPM :: PM a -> (a -> PM  b) -> PM  b+m `thenPM` k = PM $ \i l c s -> +	       case (unPM m) i l c s of +	       Failed s -> Failed s+	       Ok s' a  -> case k a of PM k' -> k' i l c s'++-- m `thenPM_` k = m `thenPM ` \_ -> k++-- same as mapM+{-+mapP :: (a -> P b) -> [a] -> P [b]+mapP f []     = returnP []+mapP f (a:as) = +     f a       `thenP` \b ->+     mapP f as `thenP` \bs ->+     returnP (b:bs)+-}++returnPM a = PM $ \i l c s -> Ok s a++parseFile (PM p) f s =+    case p s  (SrcLoc f 1 1) 0 [] of+      Ok state mod -> return mod -- No rewriting here+      Failed err -> fail err++runPM (PM p) i l c s =+    case p i l c s of+        Ok _ a -> a+	Failed err -> error err++failPM :: String -> PM a+failPM err = PM $ \i l c s -> Failed err++getSrcLoc :: PM SrcLoc+getSrcLoc = PM $ \i l c s -> Ok s l++getContext :: PM [LexContext]+getContext = PM $ \i l c s -> Ok s s++--getInfixEnv :: PM env+--getInfixEnv =  PM $ \i l c s -> Ok s (fst s)++--setInfixEnv e  =  PM $ \i l c s -> Ok (e, snd s) ()+++pushContext :: LexContext -> PM ()+pushContext ctxt =+    -- trace ("pushing lexical scope: " ++ show ctxt ++"\n") $+    PM $ \i l c s -> Ok (ctxt:s) ()+++popContext :: PM ()+popContext = PM $ \i loc c stk ->+    case stk of+    (_:s) -> --trace ("popping lexical scope, context now " ++ show s ++ "\n") $+	     Ok s ()+    []    -> Failed $ render $+             hcat [ ppi loc, +	            text ": parse error (possibly incorrect indentation)" ]+++instance Monad PM where+    (>>=)  = thenPM +    return = returnPM +--  fail   = failPM+    fail = parseError++parseError :: String -> PM a+parseError err =+    PM $ \r loc -> (unPM $ fail $ pp loc ++ ": " ++ err ++ "\n") r loc+\end{code}
+ tools/base/parse/ParsedSyntax.hs view
@@ -0,0 +1,8 @@+module ParsedSyntax(module Syntax,Src,lexerPass0) where+import Syntax++type Src i = i++lexerPass0 :: String -> () -- to avoid ambiguous overloading+lexerPass0 =+  error "This function is only available with the new parser and lexer."
+ tools/base/parse/SourceNames.hs view
@@ -0,0 +1,8 @@+module SourceNames where+import UniqueNames+import HsName++instance Unique HsName      where unique m n = G m (hsUnQual n) noSrcLoc+instance Unique Id          where unique m n = G m n noSrcLoc++srcName (PN n _) = n
+ tools/base/parse/extras/HsParser.hs view
@@ -0,0 +1,8627 @@+-- parser produced by Happy Version 1.11++module HsParser (parse) where+ +import Syntax+import SyntaxUtil+import ParseMonad+import Lexer+import LexUtil(readInteger, readRational)+import ParseUtil+--import Rewrite+import IOExts+import Char(showLitChar)++data HappyAbsSyn +	= HappyTerminal Token+	| HappyErrorToken Int+	| HappyAbsSyn4 (HsModuleR)+	| HappyAbsSyn5 (([HsImportDecl], [HsDecl]))+	| HappyAbsSyn7 (())+	| HappyAbsSyn8 (Maybe [HsExportSpec])+	| HappyAbsSyn9 ([HsExportSpec])+	| HappyAbsSyn12 (HsExportSpec)+	| HappyAbsSyn13 ([HsName])+	| HappyAbsSyn14 (HsName)+	| HappyAbsSyn15 ([HsImportDecl])+	| HappyAbsSyn16 (HsImportDecl)+	| HappyAbsSyn17 (Bool)+	| HappyAbsSyn18 (Maybe Module)+	| HappyAbsSyn19 (Maybe (Bool, [HsImportSpec]))+	| HappyAbsSyn20 ((Bool, [HsImportSpec]))+	| HappyAbsSyn21 ([HsImportSpec])+	| HappyAbsSyn23 (HsImportSpec)+	| HappyAbsSyn26 ([HsDecl])+	| HappyAbsSyn27 (HsDecl)+	| HappyAbsSyn28 (Int)+	| HappyAbsSyn29 (HsAssoc)+	| HappyAbsSyn30 ([HsIdent])+	| HappyAbsSyn32 (HsFunDeps HsType)+	| HappyAbsSyn34 (HsFunDep HsType)+	| HappyAbsSyn35 ([HsType])+	| HappyAbsSyn42 (HsType)+	| HappyAbsSyn46 (([HsType],HsType))+	| HappyAbsSyn48 (([HsType], [HsType]))+	| HappyAbsSyn51 (([HsType], HsName))+	| HappyAbsSyn52 ([HsConDecl HsType ])+	| HappyAbsSyn53 (HsConDecl HsType)+	| HappyAbsSyn54 ((HsName, [HsBangType HsType]))+	| HappyAbsSyn56 (HsBangType HsType)+	| HappyAbsSyn58 ([([HsName], HsBangType HsType)])+	| HappyAbsSyn59 (([HsName], HsBangType HsType))+	| HappyAbsSyn70 ((HsName,[HsPat]))+	| HappyAbsSyn72 (HsRhs HsExp)+	| HappyAbsSyn73 ([(SrcLoc, HsExp, HsExp)])+	| HappyAbsSyn74 ((SrcLoc, HsExp, HsExp))+	| HappyAbsSyn75 (HsExp)+	| HappyAbsSyn82 ([HsExp])+	| HappyAbsSyn85 ([HsStmtAtom HsExp HsPat [HsDecl] ])+	| HappyAbsSyn86 (HsStmtAtom HsExp HsPat [HsDecl])+	| HappyAbsSyn87 ([HsAlt HsExp HsPat [HsDecl]])+	| HappyAbsSyn89 (HsAlt HsExp HsPat [HsDecl])+	| HappyAbsSyn93 ([HsStmtAtom HsExp HsPat [HsDecl]])+	| HappyAbsSyn96 ([HsFieldUpdate HsExp])+	| HappyAbsSyn98 (HsFieldUpdate HsExp)+	| HappyAbsSyn99 (HsPat)+	| HappyAbsSyn103 ([HsPat])+	| HappyAbsSyn105 ([HsPatField HsPat])+	| HappyAbsSyn107 (HsPatField HsPat)+	| HappyAbsSyn120 (HsIdent)+	| HappyAbsSyn132 (HsLiteral)+	| HappyAbsSyn134 (SrcLoc)+	| HappyAbsSyn137 (Module)++type HappyReduction = +	   Int +	-> (Token)+	-> HappyState (Token) (HappyStk HappyAbsSyn -> PM(HappyAbsSyn))+	-> [HappyState (Token) (HappyStk HappyAbsSyn -> PM(HappyAbsSyn))] +	-> HappyStk HappyAbsSyn +	-> PM(HappyAbsSyn)++action_0,+ action_1,+ action_2,+ action_3,+ action_4,+ action_5,+ action_6,+ action_7,+ action_8,+ action_9,+ action_10,+ action_11,+ action_12,+ action_13,+ action_14,+ action_15,+ action_16,+ action_17,+ action_18,+ action_19,+ action_20,+ action_21,+ action_22,+ action_23,+ action_24,+ action_25,+ action_26,+ action_27,+ action_28,+ action_29,+ action_30,+ action_31,+ action_32,+ action_33,+ action_34,+ action_35,+ action_36,+ action_37,+ action_38,+ action_39,+ action_40,+ action_41,+ action_42,+ action_43,+ action_44,+ action_45,+ action_46,+ action_47,+ action_48,+ action_49,+ action_50,+ action_51,+ action_52,+ action_53,+ action_54,+ action_55,+ action_56,+ action_57,+ action_58,+ action_59,+ action_60,+ action_61,+ action_62,+ action_63,+ action_64,+ action_65,+ action_66,+ action_67,+ action_68,+ action_69,+ action_70,+ action_71,+ action_72,+ action_73,+ action_74,+ action_75,+ action_76,+ action_77,+ action_78,+ action_79,+ action_80,+ action_81,+ action_82,+ action_83,+ action_84,+ action_85,+ action_86,+ action_87,+ action_88,+ action_89,+ action_90,+ action_91,+ action_92,+ action_93,+ action_94,+ action_95,+ action_96,+ action_97,+ action_98,+ action_99,+ action_100,+ action_101,+ action_102,+ action_103,+ action_104,+ action_105,+ action_106,+ action_107,+ action_108,+ action_109,+ action_110,+ action_111,+ action_112,+ action_113,+ action_114,+ action_115,+ action_116,+ action_117,+ action_118,+ action_119,+ action_120,+ action_121,+ action_122,+ action_123,+ action_124,+ action_125,+ action_126,+ action_127,+ action_128,+ action_129,+ action_130,+ action_131,+ action_132,+ action_133,+ action_134,+ action_135,+ action_136,+ action_137,+ action_138,+ action_139,+ action_140,+ action_141,+ action_142,+ action_143,+ action_144,+ action_145,+ action_146,+ action_147,+ action_148,+ action_149,+ action_150,+ action_151,+ action_152,+ action_153,+ action_154,+ action_155,+ action_156,+ action_157,+ action_158,+ action_159,+ action_160,+ action_161,+ action_162,+ action_163,+ action_164,+ action_165,+ action_166,+ action_167,+ action_168,+ action_169,+ action_170,+ action_171,+ action_172,+ action_173,+ action_174,+ action_175,+ action_176,+ action_177,+ action_178,+ action_179,+ action_180,+ action_181,+ action_182,+ action_183,+ action_184,+ action_185,+ action_186,+ action_187,+ action_188,+ action_189,+ action_190,+ action_191,+ action_192,+ action_193,+ action_194,+ action_195,+ action_196,+ action_197,+ action_198,+ action_199,+ action_200,+ action_201,+ action_202,+ action_203,+ action_204,+ action_205,+ action_206,+ action_207,+ action_208,+ action_209,+ action_210,+ action_211,+ action_212,+ action_213,+ action_214,+ action_215,+ action_216,+ action_217,+ action_218,+ action_219,+ action_220,+ action_221,+ action_222,+ action_223,+ action_224,+ action_225,+ action_226,+ action_227,+ action_228,+ action_229,+ action_230,+ action_231,+ action_232,+ action_233,+ action_234,+ action_235,+ action_236,+ action_237,+ action_238,+ action_239,+ action_240,+ action_241,+ action_242,+ action_243,+ action_244,+ action_245,+ action_246,+ action_247,+ action_248,+ action_249,+ action_250,+ action_251,+ action_252,+ action_253,+ action_254,+ action_255,+ action_256,+ action_257,+ action_258,+ action_259,+ action_260,+ action_261,+ action_262,+ action_263,+ action_264,+ action_265,+ action_266,+ action_267,+ action_268,+ action_269,+ action_270,+ action_271,+ action_272,+ action_273,+ action_274,+ action_275,+ action_276,+ action_277,+ action_278,+ action_279,+ action_280,+ action_281,+ action_282,+ action_283,+ action_284,+ action_285,+ action_286,+ action_287,+ action_288,+ action_289,+ action_290,+ action_291,+ action_292,+ action_293,+ action_294,+ action_295,+ action_296,+ action_297,+ action_298,+ action_299,+ action_300,+ action_301,+ action_302,+ action_303,+ action_304,+ action_305,+ action_306,+ action_307,+ action_308,+ action_309,+ action_310,+ action_311,+ action_312,+ action_313,+ action_314,+ action_315,+ action_316,+ action_317,+ action_318,+ action_319,+ action_320,+ action_321,+ action_322,+ action_323,+ action_324,+ action_325,+ action_326,+ action_327,+ action_328,+ action_329,+ action_330,+ action_331,+ action_332,+ action_333,+ action_334,+ action_335,+ action_336,+ action_337,+ action_338,+ action_339,+ action_340,+ action_341,+ action_342,+ action_343,+ action_344,+ action_345,+ action_346,+ action_347,+ action_348,+ action_349,+ action_350,+ action_351,+ action_352,+ action_353,+ action_354,+ action_355,+ action_356,+ action_357,+ action_358,+ action_359,+ action_360,+ action_361,+ action_362,+ action_363,+ action_364,+ action_365,+ action_366,+ action_367,+ action_368,+ action_369,+ action_370,+ action_371,+ action_372,+ action_373,+ action_374,+ action_375,+ action_376,+ action_377,+ action_378,+ action_379,+ action_380,+ action_381,+ action_382,+ action_383,+ action_384,+ action_385,+ action_386,+ action_387,+ action_388,+ action_389,+ action_390,+ action_391,+ action_392,+ action_393,+ action_394,+ action_395,+ action_396,+ action_397,+ action_398,+ action_399,+ action_400,+ action_401,+ action_402,+ action_403,+ action_404,+ action_405,+ action_406,+ action_407,+ action_408,+ action_409,+ action_410,+ action_411,+ action_412,+ action_413,+ action_414,+ action_415,+ action_416,+ action_417,+ action_418,+ action_419,+ action_420,+ action_421,+ action_422,+ action_423,+ action_424,+ action_425,+ action_426,+ action_427,+ action_428,+ action_429,+ action_430,+ action_431,+ action_432,+ action_433,+ action_434,+ action_435,+ action_436,+ action_437,+ action_438,+ action_439,+ action_440,+ action_441,+ action_442,+ action_443,+ action_444,+ action_445,+ action_446,+ action_447,+ action_448,+ action_449,+ action_450,+ action_451,+ action_452,+ action_453,+ action_454,+ action_455,+ action_456,+ action_457,+ action_458,+ action_459,+ action_460,+ action_461,+ action_462,+ action_463,+ action_464,+ action_465,+ action_466,+ action_467,+ action_468,+ action_469,+ action_470,+ action_471,+ action_472,+ action_473,+ action_474,+ action_475,+ action_476,+ action_477,+ action_478,+ action_479,+ action_480,+ action_481,+ action_482,+ action_483,+ action_484,+ action_485,+ action_486,+ action_487,+ action_488,+ action_489,+ action_490,+ action_491,+ action_492,+ action_493,+ action_494,+ action_495,+ action_496,+ action_497,+ action_498,+ action_499,+ action_500,+ action_501,+ action_502,+ action_503,+ action_504,+ action_505,+ action_506,+ action_507,+ action_508,+ action_509,+ action_510,+ action_511,+ action_512,+ action_513,+ action_514,+ action_515,+ action_516,+ action_517,+ action_518,+ action_519,+ action_520,+ action_521,+ action_522,+ action_523,+ action_524,+ action_525,+ action_526,+ action_527,+ action_528,+ action_529,+ action_530,+ action_531,+ action_532,+ action_533,+ action_534,+ action_535,+ action_536,+ action_537,+ action_538,+ action_539,+ action_540,+ action_541,+ action_542,+ action_543,+ action_544,+ action_545,+ action_546,+ action_547,+ action_548,+ action_549,+ action_550,+ action_551,+ action_552,+ action_553,+ action_554,+ action_555,+ action_556,+ action_557,+ action_558,+ action_559,+ action_560,+ action_561,+ action_562,+ action_563,+ action_564,+ action_565,+ action_566,+ action_567,+ action_568,+ action_569,+ action_570,+ action_571,+ action_572,+ action_573,+ action_574,+ action_575 :: Int -> HappyReduction++happyReduce_1,+ happyReduce_2,+ happyReduce_3,+ happyReduce_4,+ happyReduce_5,+ happyReduce_6,+ happyReduce_7,+ happyReduce_8,+ happyReduce_9,+ happyReduce_10,+ happyReduce_11,+ happyReduce_12,+ happyReduce_13,+ happyReduce_14,+ happyReduce_15,+ happyReduce_16,+ happyReduce_17,+ happyReduce_18,+ happyReduce_19,+ happyReduce_20,+ happyReduce_21,+ happyReduce_22,+ happyReduce_23,+ happyReduce_24,+ happyReduce_25,+ happyReduce_26,+ happyReduce_27,+ happyReduce_28,+ happyReduce_29,+ happyReduce_30,+ happyReduce_31,+ happyReduce_32,+ happyReduce_33,+ happyReduce_34,+ happyReduce_35,+ happyReduce_36,+ happyReduce_37,+ happyReduce_38,+ happyReduce_39,+ happyReduce_40,+ happyReduce_41,+ happyReduce_42,+ happyReduce_43,+ happyReduce_44,+ happyReduce_45,+ happyReduce_46,+ happyReduce_47,+ happyReduce_48,+ happyReduce_49,+ happyReduce_50,+ happyReduce_51,+ happyReduce_52,+ happyReduce_53,+ happyReduce_54,+ happyReduce_55,+ happyReduce_56,+ happyReduce_57,+ happyReduce_58,+ happyReduce_59,+ happyReduce_60,+ happyReduce_61,+ happyReduce_62,+ happyReduce_63,+ happyReduce_64,+ happyReduce_65,+ happyReduce_66,+ happyReduce_67,+ happyReduce_68,+ happyReduce_69,+ happyReduce_70,+ happyReduce_71,+ happyReduce_72,+ happyReduce_73,+ happyReduce_74,+ happyReduce_75,+ happyReduce_76,+ happyReduce_77,+ happyReduce_78,+ happyReduce_79,+ happyReduce_80,+ happyReduce_81,+ happyReduce_82,+ happyReduce_83,+ happyReduce_84,+ happyReduce_85,+ happyReduce_86,+ happyReduce_87,+ happyReduce_88,+ happyReduce_89,+ happyReduce_90,+ happyReduce_91,+ happyReduce_92,+ happyReduce_93,+ happyReduce_94,+ happyReduce_95,+ happyReduce_96,+ happyReduce_97,+ happyReduce_98,+ happyReduce_99,+ happyReduce_100,+ happyReduce_101,+ happyReduce_102,+ happyReduce_103,+ happyReduce_104,+ happyReduce_105,+ happyReduce_106,+ happyReduce_107,+ happyReduce_108,+ happyReduce_109,+ happyReduce_110,+ happyReduce_111,+ happyReduce_112,+ happyReduce_113,+ happyReduce_114,+ happyReduce_115,+ happyReduce_116,+ happyReduce_117,+ happyReduce_118,+ happyReduce_119,+ happyReduce_120,+ happyReduce_121,+ happyReduce_122,+ happyReduce_123,+ happyReduce_124,+ happyReduce_125,+ happyReduce_126,+ happyReduce_127,+ happyReduce_128,+ happyReduce_129,+ happyReduce_130,+ happyReduce_131,+ happyReduce_132,+ happyReduce_133,+ happyReduce_134,+ happyReduce_135,+ happyReduce_136,+ happyReduce_137,+ happyReduce_138,+ happyReduce_139,+ happyReduce_140,+ happyReduce_141,+ happyReduce_142,+ happyReduce_143,+ happyReduce_144,+ happyReduce_145,+ happyReduce_146,+ happyReduce_147,+ happyReduce_148,+ happyReduce_149,+ happyReduce_150,+ happyReduce_151,+ happyReduce_152,+ happyReduce_153,+ happyReduce_154,+ happyReduce_155,+ happyReduce_156,+ happyReduce_157,+ happyReduce_158,+ happyReduce_159,+ happyReduce_160,+ happyReduce_161,+ happyReduce_162,+ happyReduce_163,+ happyReduce_164,+ happyReduce_165,+ happyReduce_166,+ happyReduce_167,+ happyReduce_168,+ happyReduce_169,+ happyReduce_170,+ happyReduce_171,+ happyReduce_172,+ happyReduce_173,+ happyReduce_174,+ happyReduce_175,+ happyReduce_176,+ happyReduce_177,+ happyReduce_178,+ happyReduce_179,+ happyReduce_180,+ happyReduce_181,+ happyReduce_182,+ happyReduce_183,+ happyReduce_184,+ happyReduce_185,+ happyReduce_186,+ happyReduce_187,+ happyReduce_188,+ happyReduce_189,+ happyReduce_190,+ happyReduce_191,+ happyReduce_192,+ happyReduce_193,+ happyReduce_194,+ happyReduce_195,+ happyReduce_196,+ happyReduce_197,+ happyReduce_198,+ happyReduce_199,+ happyReduce_200,+ happyReduce_201,+ happyReduce_202,+ happyReduce_203,+ happyReduce_204,+ happyReduce_205,+ happyReduce_206,+ happyReduce_207,+ happyReduce_208,+ happyReduce_209,+ happyReduce_210,+ happyReduce_211,+ happyReduce_212,+ happyReduce_213,+ happyReduce_214,+ happyReduce_215,+ happyReduce_216,+ happyReduce_217,+ happyReduce_218,+ happyReduce_219,+ happyReduce_220,+ happyReduce_221,+ happyReduce_222,+ happyReduce_223,+ happyReduce_224,+ happyReduce_225,+ happyReduce_226,+ happyReduce_227,+ happyReduce_228,+ happyReduce_229,+ happyReduce_230,+ happyReduce_231,+ happyReduce_232,+ happyReduce_233,+ happyReduce_234,+ happyReduce_235,+ happyReduce_236,+ happyReduce_237,+ happyReduce_238,+ happyReduce_239,+ happyReduce_240,+ happyReduce_241,+ happyReduce_242,+ happyReduce_243,+ happyReduce_244,+ happyReduce_245,+ happyReduce_246,+ happyReduce_247,+ happyReduce_248,+ happyReduce_249,+ happyReduce_250,+ happyReduce_251,+ happyReduce_252,+ happyReduce_253,+ happyReduce_254,+ happyReduce_255,+ happyReduce_256,+ happyReduce_257,+ happyReduce_258,+ happyReduce_259,+ happyReduce_260,+ happyReduce_261,+ happyReduce_262,+ happyReduce_263,+ happyReduce_264,+ happyReduce_265,+ happyReduce_266,+ happyReduce_267,+ happyReduce_268,+ happyReduce_269,+ happyReduce_270,+ happyReduce_271,+ happyReduce_272,+ happyReduce_273,+ happyReduce_274,+ happyReduce_275,+ happyReduce_276,+ happyReduce_277,+ happyReduce_278,+ happyReduce_279,+ happyReduce_280,+ happyReduce_281,+ happyReduce_282,+ happyReduce_283,+ happyReduce_284,+ happyReduce_285,+ happyReduce_286,+ happyReduce_287,+ happyReduce_288,+ happyReduce_289,+ happyReduce_290,+ happyReduce_291,+ happyReduce_292,+ happyReduce_293,+ happyReduce_294,+ happyReduce_295,+ happyReduce_296,+ happyReduce_297,+ happyReduce_298,+ happyReduce_299,+ happyReduce_300,+ happyReduce_301,+ happyReduce_302,+ happyReduce_303,+ happyReduce_304,+ happyReduce_305,+ happyReduce_306,+ happyReduce_307,+ happyReduce_308,+ happyReduce_309,+ happyReduce_310,+ happyReduce_311,+ happyReduce_312,+ happyReduce_313,+ happyReduce_314,+ happyReduce_315,+ happyReduce_316,+ happyReduce_317,+ happyReduce_318,+ happyReduce_319,+ happyReduce_320,+ happyReduce_321,+ happyReduce_322,+ happyReduce_323,+ happyReduce_324,+ happyReduce_325,+ happyReduce_326 :: HappyReduction++action_0 (4) = happyGoto action_3+action_0 (134) = happyGoto action_4+action_0 _ = happyReduce_317++action_1 (134) = happyGoto action_2+action_1 _ = happyFail++action_2 (197) = happyShift action_8+action_2 _ = happyFail++action_3 (205) = happyAccept+action_3 _ = happyFail++action_4 (160) = happyShift action_7+action_4 (197) = happyShift action_8+action_4 (5) = happyGoto action_5+action_4 (135) = happyGoto action_6+action_4 _ = happyReduce_318++action_5 _ = happyReduce_2++action_6 (143) = happyShift action_34+action_6 (144) = happyShift action_35+action_6 (145) = happyShift action_36+action_6 (146) = happyShift action_37+action_6 (147) = happyShift action_38+action_6 (153) = happyShift action_39+action_6 (154) = happyShift action_40+action_6 (155) = happyShift action_41+action_6 (156) = happyShift action_42+action_6 (157) = happyShift action_43+action_6 (163) = happyShift action_44+action_6 (166) = happyShift action_45+action_6 (177) = happyShift action_46+action_6 (180) = happyShift action_47+action_6 (182) = happyShift action_48+action_6 (183) = happyShift action_49+action_6 (184) = happyShift action_50+action_6 (188) = happyShift action_51+action_6 (190) = happyShift action_52+action_6 (192) = happyShift action_53+action_6 (193) = happyShift action_54+action_6 (194) = happyShift action_55+action_6 (195) = happyShift action_56+action_6 (198) = happyShift action_57+action_6 (201) = happyShift action_58+action_6 (203) = happyShift action_59+action_6 (204) = happyShift action_60+action_6 (6) = happyGoto action_61+action_6 (15) = happyGoto action_12+action_6 (16) = happyGoto action_13+action_6 (26) = happyGoto action_14+action_6 (27) = happyGoto action_15+action_6 (29) = happyGoto action_16+action_6 (31) = happyGoto action_17+action_6 (38) = happyGoto action_18+action_6 (40) = happyGoto action_19+action_6 (41) = happyGoto action_20+action_6 (69) = happyGoto action_21+action_6 (70) = happyGoto action_22+action_6 (100) = happyGoto action_23+action_6 (101) = happyGoto action_24+action_6 (102) = happyGoto action_25+action_6 (113) = happyGoto action_26+action_6 (115) = happyGoto action_27+action_6 (122) = happyGoto action_28+action_6 (123) = happyGoto action_29+action_6 (124) = happyGoto action_30+action_6 (126) = happyGoto action_31+action_6 (132) = happyGoto action_32+action_6 (133) = happyGoto action_33+action_6 _ = happyReduce_8++action_7 (143) = happyShift action_34+action_7 (144) = happyShift action_35+action_7 (145) = happyShift action_36+action_7 (146) = happyShift action_37+action_7 (147) = happyShift action_38+action_7 (153) = happyShift action_39+action_7 (154) = happyShift action_40+action_7 (155) = happyShift action_41+action_7 (156) = happyShift action_42+action_7 (157) = happyShift action_43+action_7 (163) = happyShift action_44+action_7 (166) = happyShift action_45+action_7 (177) = happyShift action_46+action_7 (180) = happyShift action_47+action_7 (182) = happyShift action_48+action_7 (183) = happyShift action_49+action_7 (184) = happyShift action_50+action_7 (188) = happyShift action_51+action_7 (190) = happyShift action_52+action_7 (192) = happyShift action_53+action_7 (193) = happyShift action_54+action_7 (194) = happyShift action_55+action_7 (195) = happyShift action_56+action_7 (198) = happyShift action_57+action_7 (201) = happyShift action_58+action_7 (203) = happyShift action_59+action_7 (204) = happyShift action_60+action_7 (6) = happyGoto action_11+action_7 (15) = happyGoto action_12+action_7 (16) = happyGoto action_13+action_7 (26) = happyGoto action_14+action_7 (27) = happyGoto action_15+action_7 (29) = happyGoto action_16+action_7 (31) = happyGoto action_17+action_7 (38) = happyGoto action_18+action_7 (40) = happyGoto action_19+action_7 (41) = happyGoto action_20+action_7 (69) = happyGoto action_21+action_7 (70) = happyGoto action_22+action_7 (100) = happyGoto action_23+action_7 (101) = happyGoto action_24+action_7 (102) = happyGoto action_25+action_7 (113) = happyGoto action_26+action_7 (115) = happyGoto action_27+action_7 (122) = happyGoto action_28+action_7 (123) = happyGoto action_29+action_7 (124) = happyGoto action_30+action_7 (126) = happyGoto action_31+action_7 (132) = happyGoto action_32+action_7 (133) = happyGoto action_33+action_7 _ = happyReduce_8++action_8 (145) = happyShift action_10+action_8 (137) = happyGoto action_9+action_8 _ = happyFail++action_9 (157) = happyShift action_130+action_9 (8) = happyGoto action_128+action_9 (9) = happyGoto action_129+action_9 _ = happyReduce_12++action_10 _ = happyReduce_321++action_11 (161) = happyShift action_127+action_11 _ = happyFail++action_12 (159) = happyShift action_126+action_12 (7) = happyGoto action_125+action_12 _ = happyReduce_10++action_13 _ = happyReduce_30++action_14 (159) = happyShift action_124+action_14 (7) = happyGoto action_123+action_14 _ = happyReduce_10++action_15 _ = happyReduce_84++action_16 (134) = happyGoto action_122+action_16 _ = happyReduce_317++action_17 _ = happyReduce_54++action_18 _ = happyReduce_71++action_19 _ = happyReduce_83++action_20 (165) = happyShift action_121+action_20 (134) = happyGoto action_120+action_20 _ = happyReduce_317++action_21 _ = happyReduce_85++action_22 (134) = happyGoto action_119+action_22 _ = happyReduce_317++action_23 (147) = happyShift action_117+action_23 (148) = happyShift action_99+action_23 (149) = happyShift action_100+action_23 (150) = happyShift action_101+action_23 (151) = happyShift action_102+action_23 (167) = happyShift action_118+action_23 (168) = happyShift action_104+action_23 (179) = happyShift action_105+action_23 (117) = happyGoto action_112+action_23 (119) = happyGoto action_113+action_23 (127) = happyGoto action_114+action_23 (128) = happyGoto action_94+action_23 (129) = happyGoto action_115+action_23 (130) = happyGoto action_96+action_23 (131) = happyGoto action_97+action_23 (134) = happyGoto action_116+action_23 _ = happyReduce_317++action_24 _ = happyReduce_234++action_25 _ = happyReduce_238++action_26 (143) = happyShift action_34+action_26 (144) = happyShift action_35+action_26 (145) = happyShift action_36+action_26 (146) = happyShift action_37+action_26 (153) = happyShift action_39+action_26 (154) = happyShift action_40+action_26 (155) = happyShift action_41+action_26 (156) = happyShift action_42+action_26 (157) = happyShift action_83+action_26 (163) = happyShift action_44+action_26 (165) = happyReduce_90+action_26 (166) = happyShift action_45+action_26 (170) = happyReduce_90+action_26 (176) = happyShift action_111+action_26 (177) = happyShift action_46+action_26 (180) = happyShift action_47+action_26 (188) = happyShift action_51+action_26 (203) = happyShift action_59+action_26 (102) = happyGoto action_107+action_26 (103) = happyGoto action_110+action_26 (113) = happyGoto action_81+action_26 (115) = happyGoto action_82+action_26 (122) = happyGoto action_28+action_26 (123) = happyGoto action_29+action_26 (124) = happyGoto action_30+action_26 (126) = happyGoto action_31+action_26 (132) = happyGoto action_32+action_26 (133) = happyGoto action_33+action_26 _ = happyReduce_239++action_27 (143) = happyShift action_34+action_27 (144) = happyShift action_35+action_27 (145) = happyShift action_36+action_27 (146) = happyShift action_37+action_27 (153) = happyShift action_39+action_27 (154) = happyShift action_40+action_27 (155) = happyShift action_41+action_27 (156) = happyShift action_42+action_27 (157) = happyShift action_83+action_27 (160) = happyShift action_109+action_27 (163) = happyShift action_44+action_27 (166) = happyShift action_45+action_27 (177) = happyShift action_46+action_27 (180) = happyShift action_47+action_27 (188) = happyShift action_51+action_27 (203) = happyShift action_59+action_27 (102) = happyGoto action_107+action_27 (103) = happyGoto action_108+action_27 (113) = happyGoto action_81+action_27 (115) = happyGoto action_82+action_27 (122) = happyGoto action_28+action_27 (123) = happyGoto action_29+action_27 (124) = happyGoto action_30+action_27 (126) = happyGoto action_31+action_27 (132) = happyGoto action_32+action_27 (133) = happyGoto action_33+action_27 _ = happyReduce_241++action_28 _ = happyReduce_273++action_29 _ = happyReduce_291++action_30 _ = happyReduce_277++action_31 _ = happyReduce_297++action_32 _ = happyReduce_244++action_33 _ = happyReduce_312++action_34 _ = happyReduce_293++action_35 _ = happyReduce_292++action_36 _ = happyReduce_301++action_37 _ = happyReduce_298++action_38 (153) = happyShift action_39+action_38 (154) = happyShift action_40+action_38 (133) = happyGoto action_106+action_38 _ = happyFail++action_39 _ = happyReduce_315++action_40 _ = happyReduce_316++action_41 _ = happyReduce_313++action_42 _ = happyReduce_314++action_43 (143) = happyShift action_34+action_43 (144) = happyShift action_35+action_43 (145) = happyShift action_36+action_43 (146) = happyShift action_37+action_43 (147) = happyShift action_98+action_43 (148) = happyShift action_99+action_43 (149) = happyShift action_100+action_43 (150) = happyShift action_101+action_43 (151) = happyShift action_102+action_43 (153) = happyShift action_39+action_43 (154) = happyShift action_40+action_43 (155) = happyShift action_41+action_43 (156) = happyShift action_42+action_43 (157) = happyShift action_43+action_43 (158) = happyShift action_103+action_43 (163) = happyShift action_44+action_43 (166) = happyShift action_45+action_43 (168) = happyShift action_104+action_43 (177) = happyShift action_46+action_43 (179) = happyShift action_105+action_43 (180) = happyShift action_47+action_43 (188) = happyShift action_51+action_43 (203) = happyShift action_59+action_43 (70) = happyGoto action_88+action_43 (99) = happyGoto action_89+action_43 (100) = happyGoto action_90+action_43 (101) = happyGoto action_24+action_43 (102) = happyGoto action_25+action_43 (108) = happyGoto action_91+action_43 (113) = happyGoto action_92+action_43 (115) = happyGoto action_27+action_43 (122) = happyGoto action_28+action_43 (123) = happyGoto action_29+action_43 (124) = happyGoto action_30+action_43 (126) = happyGoto action_31+action_43 (127) = happyGoto action_93+action_43 (128) = happyGoto action_94+action_43 (129) = happyGoto action_95+action_43 (130) = happyGoto action_96+action_43 (131) = happyGoto action_97+action_43 (132) = happyGoto action_32+action_43 (133) = happyGoto action_33+action_43 _ = happyFail++action_44 (143) = happyShift action_34+action_44 (144) = happyShift action_35+action_44 (145) = happyShift action_36+action_44 (146) = happyShift action_37+action_44 (147) = happyShift action_38+action_44 (153) = happyShift action_39+action_44 (154) = happyShift action_40+action_44 (155) = happyShift action_41+action_44 (156) = happyShift action_42+action_44 (157) = happyShift action_83+action_44 (163) = happyShift action_44+action_44 (166) = happyShift action_45+action_44 (177) = happyShift action_46+action_44 (180) = happyShift action_47+action_44 (188) = happyShift action_51+action_44 (203) = happyShift action_59+action_44 (99) = happyGoto action_84+action_44 (100) = happyGoto action_85+action_44 (101) = happyGoto action_24+action_44 (102) = happyGoto action_25+action_44 (109) = happyGoto action_86+action_44 (110) = happyGoto action_87+action_44 (113) = happyGoto action_81+action_44 (115) = happyGoto action_27+action_44 (122) = happyGoto action_28+action_44 (123) = happyGoto action_29+action_44 (124) = happyGoto action_30+action_44 (126) = happyGoto action_31+action_44 (132) = happyGoto action_32+action_44 (133) = happyGoto action_33+action_44 _ = happyReduce_260++action_45 _ = happyReduce_245++action_46 (143) = happyShift action_34+action_46 (144) = happyShift action_35+action_46 (145) = happyShift action_36+action_46 (146) = happyShift action_37+action_46 (153) = happyShift action_39+action_46 (154) = happyShift action_40+action_46 (155) = happyShift action_41+action_46 (156) = happyShift action_42+action_46 (157) = happyShift action_83+action_46 (163) = happyShift action_44+action_46 (166) = happyShift action_45+action_46 (177) = happyShift action_46+action_46 (180) = happyShift action_47+action_46 (188) = happyShift action_51+action_46 (203) = happyShift action_59+action_46 (102) = happyGoto action_80+action_46 (113) = happyGoto action_81+action_46 (115) = happyGoto action_82+action_46 (122) = happyGoto action_28+action_46 (123) = happyGoto action_29+action_46 (124) = happyGoto action_30+action_46 (126) = happyGoto action_31+action_46 (132) = happyGoto action_32+action_46 (133) = happyGoto action_33+action_46 _ = happyFail++action_47 _ = happyReduce_294++action_48 (134) = happyGoto action_79+action_48 _ = happyReduce_317++action_49 (134) = happyGoto action_78+action_49 _ = happyReduce_317++action_50 (134) = happyGoto action_77+action_50 _ = happyReduce_317++action_51 _ = happyReduce_296++action_52 (134) = happyGoto action_76+action_52 _ = happyReduce_317++action_53 _ = happyReduce_58++action_54 _ = happyReduce_59++action_55 _ = happyReduce_60++action_56 (134) = happyGoto action_75+action_56 _ = happyReduce_317++action_57 (134) = happyGoto action_74+action_57 _ = happyReduce_317++action_58 (145) = happyShift action_36+action_58 (146) = happyShift action_71+action_58 (157) = happyShift action_72+action_58 (163) = happyShift action_73+action_58 (45) = happyGoto action_66+action_58 (49) = happyGoto action_67+action_58 (125) = happyGoto action_68+action_58 (126) = happyGoto action_69+action_58 (139) = happyGoto action_70+action_58 _ = happyFail++action_59 _ = happyReduce_295++action_60 (134) = happyGoto action_65+action_60 _ = happyReduce_317++action_61 (1) = happyShift action_63+action_61 (162) = happyShift action_64+action_61 (136) = happyGoto action_62+action_61 _ = happyFail++action_62 _ = happyReduce_4++action_63 _ = happyReduce_320++action_64 _ = happyReduce_319++action_65 (143) = happyShift action_34+action_65 (157) = happyShift action_147+action_65 (180) = happyShift action_47+action_65 (188) = happyShift action_51+action_65 (203) = happyShift action_59+action_65 (112) = happyGoto action_202+action_65 (123) = happyGoto action_146+action_65 _ = happyFail++action_66 (143) = happyShift action_34+action_66 (180) = happyShift action_47+action_66 (188) = happyShift action_51+action_66 (203) = happyShift action_59+action_66 (50) = happyGoto action_200+action_66 (123) = happyGoto action_180+action_66 (142) = happyGoto action_201+action_66 _ = happyReduce_112++action_67 (134) = happyGoto action_199+action_67 _ = happyReduce_317++action_68 _ = happyReduce_100++action_69 _ = happyReduce_323++action_70 _ = happyReduce_299++action_71 _ = happyReduce_300++action_72 (158) = happyShift action_196+action_72 (165) = happyShift action_197+action_72 (175) = happyShift action_198+action_72 (81) = happyGoto action_195+action_72 _ = happyFail++action_73 (164) = happyShift action_194+action_73 _ = happyFail++action_74 (143) = happyShift action_34+action_74 (145) = happyShift action_36+action_74 (146) = happyShift action_71+action_74 (157) = happyShift action_182+action_74 (163) = happyShift action_183+action_74 (180) = happyShift action_47+action_74 (188) = happyShift action_51+action_74 (203) = happyShift action_59+action_74 (42) = happyGoto action_184+action_74 (43) = happyGoto action_176+action_74 (44) = happyGoto action_177+action_74 (45) = happyGoto action_185+action_74 (48) = happyGoto action_193+action_74 (49) = happyGoto action_187+action_74 (123) = happyGoto action_180+action_74 (125) = happyGoto action_68+action_74 (126) = happyGoto action_69+action_74 (139) = happyGoto action_70+action_74 (142) = happyGoto action_181+action_74 _ = happyFail++action_75 (143) = happyShift action_34+action_75 (145) = happyShift action_36+action_75 (146) = happyShift action_71+action_75 (157) = happyShift action_182+action_75 (163) = happyShift action_183+action_75 (180) = happyShift action_47+action_75 (188) = happyShift action_51+action_75 (203) = happyShift action_59+action_75 (42) = happyGoto action_175+action_75 (43) = happyGoto action_176+action_75 (44) = happyGoto action_177+action_75 (45) = happyGoto action_178+action_75 (46) = happyGoto action_192+action_75 (123) = happyGoto action_180+action_75 (125) = happyGoto action_68+action_75 (126) = happyGoto action_69+action_75 (139) = happyGoto action_70+action_75 (142) = happyGoto action_181+action_75 _ = happyFail++action_76 (203) = happyShift action_191+action_76 (17) = happyGoto action_190+action_76 _ = happyReduce_33++action_77 (143) = happyShift action_34+action_77 (145) = happyShift action_36+action_77 (146) = happyShift action_71+action_77 (157) = happyShift action_182+action_77 (163) = happyShift action_183+action_77 (180) = happyShift action_47+action_77 (188) = happyShift action_51+action_77 (203) = happyShift action_59+action_77 (42) = happyGoto action_189+action_77 (43) = happyGoto action_176+action_77 (44) = happyGoto action_177+action_77 (45) = happyGoto action_178+action_77 (123) = happyGoto action_180+action_77 (125) = happyGoto action_68+action_77 (126) = happyGoto action_69+action_77 (139) = happyGoto action_70+action_77 (142) = happyGoto action_181+action_77 _ = happyFail++action_78 (143) = happyShift action_34+action_78 (145) = happyShift action_36+action_78 (146) = happyShift action_71+action_78 (157) = happyShift action_182+action_78 (163) = happyShift action_183+action_78 (180) = happyShift action_47+action_78 (188) = happyShift action_51+action_78 (203) = happyShift action_59+action_78 (42) = happyGoto action_184+action_78 (43) = happyGoto action_176+action_78 (44) = happyGoto action_177+action_78 (45) = happyGoto action_185+action_78 (48) = happyGoto action_186+action_78 (49) = happyGoto action_187+action_78 (51) = happyGoto action_188+action_78 (123) = happyGoto action_180+action_78 (125) = happyGoto action_68+action_78 (126) = happyGoto action_69+action_78 (139) = happyGoto action_70+action_78 (142) = happyGoto action_181+action_78 _ = happyFail++action_79 (143) = happyShift action_34+action_79 (145) = happyShift action_36+action_79 (146) = happyShift action_71+action_79 (157) = happyShift action_182+action_79 (163) = happyShift action_183+action_79 (180) = happyShift action_47+action_79 (188) = happyShift action_51+action_79 (203) = happyShift action_59+action_79 (42) = happyGoto action_175+action_79 (43) = happyGoto action_176+action_79 (44) = happyGoto action_177+action_79 (45) = happyGoto action_178+action_79 (46) = happyGoto action_179+action_79 (123) = happyGoto action_180+action_79 (125) = happyGoto action_68+action_79 (126) = happyGoto action_69+action_79 (139) = happyGoto action_70+action_79 (142) = happyGoto action_181+action_79 _ = happyFail++action_80 _ = happyReduce_249++action_81 (176) = happyShift action_111+action_81 _ = happyReduce_239++action_82 (160) = happyShift action_109+action_82 _ = happyReduce_241++action_83 (143) = happyShift action_34+action_83 (144) = happyShift action_35+action_83 (145) = happyShift action_36+action_83 (146) = happyShift action_37+action_83 (147) = happyShift action_98+action_83 (148) = happyShift action_99+action_83 (149) = happyShift action_100+action_83 (150) = happyShift action_101+action_83 (151) = happyShift action_102+action_83 (153) = happyShift action_39+action_83 (154) = happyShift action_40+action_83 (155) = happyShift action_41+action_83 (156) = happyShift action_42+action_83 (157) = happyShift action_83+action_83 (158) = happyShift action_103+action_83 (163) = happyShift action_44+action_83 (166) = happyShift action_45+action_83 (168) = happyShift action_104+action_83 (177) = happyShift action_46+action_83 (179) = happyShift action_105+action_83 (180) = happyShift action_47+action_83 (188) = happyShift action_51+action_83 (203) = happyShift action_59+action_83 (99) = happyGoto action_89+action_83 (100) = happyGoto action_85+action_83 (101) = happyGoto action_24+action_83 (102) = happyGoto action_25+action_83 (108) = happyGoto action_91+action_83 (113) = happyGoto action_81+action_83 (115) = happyGoto action_27+action_83 (122) = happyGoto action_28+action_83 (123) = happyGoto action_29+action_83 (124) = happyGoto action_30+action_83 (126) = happyGoto action_31+action_83 (127) = happyGoto action_93+action_83 (128) = happyGoto action_94+action_83 (129) = happyGoto action_95+action_83 (130) = happyGoto action_96+action_83 (131) = happyGoto action_97+action_83 (132) = happyGoto action_32+action_83 (133) = happyGoto action_33+action_83 _ = happyFail++action_84 (165) = happyShift action_174+action_84 _ = happyReduce_263++action_85 (149) = happyShift action_100+action_85 (151) = happyShift action_102+action_85 (167) = happyShift action_173+action_85 (119) = happyGoto action_113+action_85 (127) = happyGoto action_114+action_85 (128) = happyGoto action_94+action_85 _ = happyReduce_233++action_86 (164) = happyShift action_172+action_86 _ = happyFail++action_87 _ = happyReduce_261++action_88 (158) = happyShift action_171+action_88 _ = happyFail++action_89 (158) = happyShift action_169+action_89 (165) = happyShift action_170+action_89 _ = happyFail++action_90 (147) = happyShift action_117+action_90 (148) = happyShift action_99+action_90 (149) = happyShift action_100+action_90 (150) = happyShift action_101+action_90 (151) = happyShift action_102+action_90 (167) = happyShift action_118+action_90 (168) = happyShift action_104+action_90 (179) = happyShift action_105+action_90 (117) = happyGoto action_112+action_90 (119) = happyGoto action_113+action_90 (127) = happyGoto action_114+action_90 (128) = happyGoto action_94+action_90 (129) = happyGoto action_115+action_90 (130) = happyGoto action_96+action_90 (131) = happyGoto action_97+action_90 _ = happyReduce_233++action_91 (158) = happyShift action_168+action_91 _ = happyFail++action_92 (143) = happyShift action_34+action_92 (144) = happyShift action_35+action_92 (145) = happyShift action_36+action_92 (146) = happyShift action_37+action_92 (153) = happyShift action_39+action_92 (154) = happyShift action_40+action_92 (155) = happyShift action_41+action_92 (156) = happyShift action_42+action_92 (157) = happyShift action_83+action_92 (163) = happyShift action_44+action_92 (166) = happyShift action_45+action_92 (176) = happyShift action_111+action_92 (177) = happyShift action_46+action_92 (180) = happyShift action_47+action_92 (188) = happyShift action_51+action_92 (203) = happyShift action_59+action_92 (102) = happyGoto action_107+action_92 (103) = happyGoto action_110+action_92 (113) = happyGoto action_81+action_92 (115) = happyGoto action_82+action_92 (122) = happyGoto action_28+action_92 (123) = happyGoto action_29+action_92 (124) = happyGoto action_30+action_92 (126) = happyGoto action_31+action_92 (132) = happyGoto action_32+action_92 (133) = happyGoto action_33+action_92 _ = happyReduce_239++action_93 (158) = happyShift action_167+action_93 _ = happyFail++action_94 _ = happyReduce_302++action_95 (158) = happyShift action_166+action_95 _ = happyFail++action_96 _ = happyReduce_305++action_97 _ = happyReduce_306++action_98 (153) = happyShift action_39+action_98 (154) = happyShift action_40+action_98 (133) = happyGoto action_106+action_98 _ = happyReduce_308++action_99 _ = happyReduce_307++action_100 _ = happyReduce_304++action_101 _ = happyReduce_311++action_102 _ = happyReduce_303++action_103 _ = happyReduce_242++action_104 _ = happyReduce_310++action_105 _ = happyReduce_309++action_106 _ = happyReduce_237++action_107 (143) = happyShift action_34+action_107 (144) = happyShift action_35+action_107 (145) = happyShift action_36+action_107 (146) = happyShift action_37+action_107 (153) = happyShift action_39+action_107 (154) = happyShift action_40+action_107 (155) = happyShift action_41+action_107 (156) = happyShift action_42+action_107 (157) = happyShift action_83+action_107 (163) = happyShift action_44+action_107 (166) = happyShift action_45+action_107 (177) = happyShift action_46+action_107 (180) = happyShift action_47+action_107 (188) = happyShift action_51+action_107 (203) = happyShift action_59+action_107 (102) = happyGoto action_164+action_107 (104) = happyGoto action_165+action_107 (113) = happyGoto action_81+action_107 (115) = happyGoto action_82+action_107 (122) = happyGoto action_28+action_107 (123) = happyGoto action_29+action_107 (124) = happyGoto action_30+action_107 (126) = happyGoto action_31+action_107 (132) = happyGoto action_32+action_107 (133) = happyGoto action_33+action_107 _ = happyReduce_251++action_108 _ = happyReduce_236++action_109 (143) = happyShift action_34+action_109 (144) = happyShift action_35+action_109 (157) = happyShift action_136+action_109 (180) = happyShift action_47+action_109 (188) = happyShift action_51+action_109 (203) = happyShift action_59+action_109 (105) = happyGoto action_160+action_109 (106) = happyGoto action_161+action_109 (107) = happyGoto action_162+action_109 (113) = happyGoto action_163+action_109 (122) = happyGoto action_28+action_109 (123) = happyGoto action_29+action_109 _ = happyReduce_253++action_110 _ = happyReduce_157++action_111 (143) = happyShift action_34+action_111 (144) = happyShift action_35+action_111 (145) = happyShift action_36+action_111 (146) = happyShift action_37+action_111 (153) = happyShift action_39+action_111 (154) = happyShift action_40+action_111 (155) = happyShift action_41+action_111 (156) = happyShift action_42+action_111 (157) = happyShift action_83+action_111 (163) = happyShift action_44+action_111 (166) = happyShift action_45+action_111 (177) = happyShift action_46+action_111 (180) = happyShift action_47+action_111 (188) = happyShift action_51+action_111 (203) = happyShift action_59+action_111 (102) = happyGoto action_159+action_111 (113) = happyGoto action_81+action_111 (115) = happyGoto action_82+action_111 (122) = happyGoto action_28+action_111 (123) = happyGoto action_29+action_111 (124) = happyGoto action_30+action_111 (126) = happyGoto action_31+action_111 (132) = happyGoto action_32+action_111 (133) = happyGoto action_33+action_111 _ = happyFail++action_112 (143) = happyShift action_34+action_112 (144) = happyShift action_35+action_112 (145) = happyShift action_36+action_112 (146) = happyShift action_37+action_112 (147) = happyShift action_38+action_112 (153) = happyShift action_39+action_112 (154) = happyShift action_40+action_112 (155) = happyShift action_41+action_112 (156) = happyShift action_42+action_112 (157) = happyShift action_83+action_112 (163) = happyShift action_44+action_112 (166) = happyShift action_45+action_112 (177) = happyShift action_46+action_112 (180) = happyShift action_47+action_112 (188) = happyShift action_51+action_112 (203) = happyShift action_59+action_112 (100) = happyGoto action_158+action_112 (101) = happyGoto action_24+action_112 (102) = happyGoto action_25+action_112 (113) = happyGoto action_81+action_112 (115) = happyGoto action_27+action_112 (122) = happyGoto action_28+action_112 (123) = happyGoto action_29+action_112 (124) = happyGoto action_30+action_112 (126) = happyGoto action_31+action_112 (132) = happyGoto action_32+action_112 (133) = happyGoto action_33+action_112 _ = happyFail++action_113 (143) = happyShift action_34+action_113 (144) = happyShift action_35+action_113 (145) = happyShift action_36+action_113 (146) = happyShift action_37+action_113 (147) = happyShift action_38+action_113 (153) = happyShift action_39+action_113 (154) = happyShift action_40+action_113 (155) = happyShift action_41+action_113 (156) = happyShift action_42+action_113 (157) = happyShift action_83+action_113 (163) = happyShift action_44+action_113 (166) = happyShift action_45+action_113 (177) = happyShift action_46+action_113 (180) = happyShift action_47+action_113 (188) = happyShift action_51+action_113 (203) = happyShift action_59+action_113 (101) = happyGoto action_157+action_113 (102) = happyGoto action_25+action_113 (113) = happyGoto action_81+action_113 (115) = happyGoto action_27+action_113 (122) = happyGoto action_28+action_113 (123) = happyGoto action_29+action_113 (124) = happyGoto action_30+action_113 (126) = happyGoto action_31+action_113 (132) = happyGoto action_32+action_113 (133) = happyGoto action_33+action_113 _ = happyFail++action_114 _ = happyReduce_285++action_115 _ = happyReduce_281++action_116 (171) = happyShift action_152+action_116 (173) = happyShift action_153+action_116 (72) = happyGoto action_156+action_116 (73) = happyGoto action_150+action_116 (74) = happyGoto action_151+action_116 _ = happyFail++action_117 _ = happyReduce_308++action_118 (143) = happyShift action_34+action_118 (144) = happyShift action_35+action_118 (145) = happyShift action_36+action_118 (146) = happyShift action_37+action_118 (180) = happyShift action_47+action_118 (188) = happyShift action_51+action_118 (203) = happyShift action_59+action_118 (122) = happyGoto action_154+action_118 (123) = happyGoto action_29+action_118 (124) = happyGoto action_155+action_118 (126) = happyGoto action_31+action_118 _ = happyFail++action_119 (171) = happyShift action_152+action_119 (173) = happyShift action_153+action_119 (72) = happyGoto action_149+action_119 (73) = happyGoto action_150+action_119 (74) = happyGoto action_151+action_119 _ = happyFail++action_120 (170) = happyShift action_148+action_120 _ = happyFail++action_121 (143) = happyShift action_34+action_121 (157) = happyShift action_147+action_121 (180) = happyShift action_47+action_121 (188) = happyShift action_51+action_121 (203) = happyShift action_59+action_121 (112) = happyGoto action_145+action_121 (123) = happyGoto action_146+action_121 _ = happyFail++action_122 (153) = happyShift action_144+action_122 (28) = happyGoto action_143+action_122 _ = happyReduce_56++action_123 _ = happyReduce_6++action_124 (143) = happyShift action_34+action_124 (144) = happyShift action_35+action_124 (145) = happyShift action_36+action_124 (146) = happyShift action_37+action_124 (147) = happyShift action_38+action_124 (153) = happyShift action_39+action_124 (154) = happyShift action_40+action_124 (155) = happyShift action_41+action_124 (156) = happyShift action_42+action_124 (157) = happyShift action_43+action_124 (163) = happyShift action_44+action_124 (166) = happyShift action_45+action_124 (177) = happyShift action_46+action_124 (180) = happyShift action_47+action_124 (182) = happyShift action_48+action_124 (183) = happyShift action_49+action_124 (184) = happyShift action_50+action_124 (188) = happyShift action_51+action_124 (192) = happyShift action_53+action_124 (193) = happyShift action_54+action_124 (194) = happyShift action_55+action_124 (195) = happyShift action_56+action_124 (198) = happyShift action_57+action_124 (201) = happyShift action_58+action_124 (203) = happyShift action_59+action_124 (204) = happyShift action_60+action_124 (27) = happyGoto action_15+action_124 (29) = happyGoto action_16+action_124 (31) = happyGoto action_142+action_124 (38) = happyGoto action_18+action_124 (40) = happyGoto action_19+action_124 (41) = happyGoto action_20+action_124 (69) = happyGoto action_21+action_124 (70) = happyGoto action_22+action_124 (100) = happyGoto action_23+action_124 (101) = happyGoto action_24+action_124 (102) = happyGoto action_25+action_124 (113) = happyGoto action_26+action_124 (115) = happyGoto action_27+action_124 (122) = happyGoto action_28+action_124 (123) = happyGoto action_29+action_124 (124) = happyGoto action_30+action_124 (126) = happyGoto action_31+action_124 (132) = happyGoto action_32+action_124 (133) = happyGoto action_33+action_124 _ = happyReduce_9++action_125 _ = happyReduce_7++action_126 (143) = happyShift action_34+action_126 (144) = happyShift action_35+action_126 (145) = happyShift action_36+action_126 (146) = happyShift action_37+action_126 (147) = happyShift action_38+action_126 (153) = happyShift action_39+action_126 (154) = happyShift action_40+action_126 (155) = happyShift action_41+action_126 (156) = happyShift action_42+action_126 (157) = happyShift action_43+action_126 (163) = happyShift action_44+action_126 (166) = happyShift action_45+action_126 (177) = happyShift action_46+action_126 (180) = happyShift action_47+action_126 (182) = happyShift action_48+action_126 (183) = happyShift action_49+action_126 (184) = happyShift action_50+action_126 (188) = happyShift action_51+action_126 (190) = happyShift action_52+action_126 (192) = happyShift action_53+action_126 (193) = happyShift action_54+action_126 (194) = happyShift action_55+action_126 (195) = happyShift action_56+action_126 (198) = happyShift action_57+action_126 (201) = happyShift action_58+action_126 (203) = happyShift action_59+action_126 (204) = happyShift action_60+action_126 (16) = happyGoto action_140+action_126 (26) = happyGoto action_141+action_126 (27) = happyGoto action_15+action_126 (29) = happyGoto action_16+action_126 (31) = happyGoto action_17+action_126 (38) = happyGoto action_18+action_126 (40) = happyGoto action_19+action_126 (41) = happyGoto action_20+action_126 (69) = happyGoto action_21+action_126 (70) = happyGoto action_22+action_126 (100) = happyGoto action_23+action_126 (101) = happyGoto action_24+action_126 (102) = happyGoto action_25+action_126 (113) = happyGoto action_26+action_126 (115) = happyGoto action_27+action_126 (122) = happyGoto action_28+action_126 (123) = happyGoto action_29+action_126 (124) = happyGoto action_30+action_126 (126) = happyGoto action_31+action_126 (132) = happyGoto action_32+action_126 (133) = happyGoto action_33+action_126 _ = happyReduce_9++action_127 _ = happyReduce_3++action_128 (202) = happyShift action_139+action_128 _ = happyFail++action_129 _ = happyReduce_11++action_130 (143) = happyShift action_34+action_130 (144) = happyShift action_35+action_130 (145) = happyShift action_36+action_130 (146) = happyShift action_71+action_130 (157) = happyShift action_136+action_130 (158) = happyShift action_137+action_130 (180) = happyShift action_47+action_130 (188) = happyShift action_51+action_130 (197) = happyShift action_138+action_130 (203) = happyShift action_59+action_130 (11) = happyGoto action_131+action_130 (12) = happyGoto action_132+action_130 (113) = happyGoto action_133+action_130 (122) = happyGoto action_28+action_130 (123) = happyGoto action_29+action_130 (125) = happyGoto action_134+action_130 (126) = happyGoto action_69+action_130 (139) = happyGoto action_70+action_130 (140) = happyGoto action_135+action_130 _ = happyFail++action_131 (165) = happyShift action_273+action_131 (10) = happyGoto action_272+action_131 _ = happyReduce_16++action_132 _ = happyReduce_18++action_133 _ = happyReduce_19++action_134 _ = happyReduce_324++action_135 (157) = happyShift action_271+action_135 _ = happyReduce_20++action_136 (147) = happyShift action_117+action_136 (148) = happyShift action_99+action_136 (150) = happyShift action_101+action_136 (168) = happyShift action_104+action_136 (179) = happyShift action_105+action_136 (129) = happyGoto action_95+action_136 (130) = happyGoto action_96+action_136 (131) = happyGoto action_97+action_136 _ = happyFail++action_137 _ = happyReduce_14++action_138 (145) = happyShift action_10+action_138 (137) = happyGoto action_270+action_138 _ = happyFail++action_139 (160) = happyShift action_7+action_139 (5) = happyGoto action_269+action_139 (135) = happyGoto action_6+action_139 _ = happyReduce_318++action_140 _ = happyReduce_29++action_141 (159) = happyShift action_124+action_141 (7) = happyGoto action_268+action_141 _ = happyReduce_10++action_142 _ = happyReduce_53++action_143 (147) = happyShift action_117+action_143 (148) = happyShift action_99+action_143 (149) = happyShift action_100+action_143 (167) = happyShift action_267+action_143 (168) = happyShift action_104+action_143 (179) = happyShift action_105+action_143 (30) = happyGoto action_261+action_143 (116) = happyGoto action_262+action_143 (118) = happyGoto action_263+action_143 (120) = happyGoto action_264+action_143 (128) = happyGoto action_265+action_143 (130) = happyGoto action_266+action_143 _ = happyFail++action_144 _ = happyReduce_57++action_145 _ = happyReduce_89++action_146 _ = happyReduce_271++action_147 (147) = happyShift action_117+action_147 (148) = happyShift action_99+action_147 (168) = happyShift action_104+action_147 (179) = happyShift action_105+action_147 (130) = happyGoto action_260+action_147 _ = happyFail++action_148 (143) = happyShift action_34+action_148 (145) = happyShift action_36+action_148 (146) = happyShift action_71+action_148 (157) = happyShift action_182+action_148 (163) = happyShift action_183+action_148 (180) = happyShift action_47+action_148 (188) = happyShift action_51+action_148 (203) = happyShift action_59+action_148 (42) = happyGoto action_175+action_148 (43) = happyGoto action_176+action_148 (44) = happyGoto action_177+action_148 (45) = happyGoto action_178+action_148 (46) = happyGoto action_259+action_148 (123) = happyGoto action_180+action_148 (125) = happyGoto action_68+action_148 (126) = happyGoto action_69+action_148 (139) = happyGoto action_70+action_148 (142) = happyGoto action_181+action_148 _ = happyFail++action_149 (202) = happyShift action_232+action_149 (71) = happyGoto action_258+action_149 _ = happyReduce_161++action_150 (173) = happyShift action_153+action_150 (74) = happyGoto action_257+action_150 _ = happyReduce_163++action_151 _ = happyReduce_165++action_152 (143) = happyShift action_34+action_152 (144) = happyShift action_35+action_152 (145) = happyShift action_36+action_152 (146) = happyShift action_37+action_152 (147) = happyShift action_245+action_152 (152) = happyShift action_246+action_152 (153) = happyShift action_39+action_152 (154) = happyShift action_40+action_152 (155) = happyShift action_41+action_152 (156) = happyShift action_42+action_152 (157) = happyShift action_247+action_152 (163) = happyShift action_248+action_152 (166) = happyShift action_249+action_152 (172) = happyShift action_250+action_152 (177) = happyShift action_251+action_152 (180) = happyShift action_47+action_152 (181) = happyShift action_252+action_152 (186) = happyShift action_253+action_152 (188) = happyShift action_51+action_152 (189) = happyShift action_254+action_152 (196) = happyShift action_255+action_152 (203) = happyShift action_59+action_152 (75) = happyGoto action_256+action_152 (76) = happyGoto action_236+action_152 (77) = happyGoto action_237+action_152 (78) = happyGoto action_238+action_152 (79) = happyGoto action_239+action_152 (80) = happyGoto action_240+action_152 (111) = happyGoto action_241+action_152 (113) = happyGoto action_242+action_152 (115) = happyGoto action_243+action_152 (122) = happyGoto action_28+action_152 (123) = happyGoto action_29+action_152 (124) = happyGoto action_30+action_152 (126) = happyGoto action_31+action_152 (132) = happyGoto action_244+action_152 (133) = happyGoto action_33+action_152 _ = happyFail++action_153 (143) = happyShift action_34+action_153 (144) = happyShift action_35+action_153 (145) = happyShift action_36+action_153 (146) = happyShift action_37+action_153 (147) = happyShift action_245+action_153 (152) = happyShift action_246+action_153 (153) = happyShift action_39+action_153 (154) = happyShift action_40+action_153 (155) = happyShift action_41+action_153 (156) = happyShift action_42+action_153 (157) = happyShift action_247+action_153 (163) = happyShift action_248+action_153 (166) = happyShift action_249+action_153 (172) = happyShift action_250+action_153 (177) = happyShift action_251+action_153 (180) = happyShift action_47+action_153 (181) = happyShift action_252+action_153 (186) = happyShift action_253+action_153 (188) = happyShift action_51+action_153 (189) = happyShift action_254+action_153 (196) = happyShift action_255+action_153 (203) = happyShift action_59+action_153 (75) = happyGoto action_235+action_153 (76) = happyGoto action_236+action_153 (77) = happyGoto action_237+action_153 (78) = happyGoto action_238+action_153 (79) = happyGoto action_239+action_153 (80) = happyGoto action_240+action_153 (111) = happyGoto action_241+action_153 (113) = happyGoto action_242+action_153 (115) = happyGoto action_243+action_153 (122) = happyGoto action_28+action_153 (123) = happyGoto action_29+action_153 (124) = happyGoto action_30+action_153 (126) = happyGoto action_31+action_153 (132) = happyGoto action_244+action_153 (133) = happyGoto action_33+action_153 _ = happyFail++action_154 (167) = happyShift action_234+action_154 _ = happyFail++action_155 (167) = happyShift action_233+action_155 _ = happyFail++action_156 (202) = happyShift action_232+action_156 (71) = happyGoto action_231+action_156 _ = happyReduce_161++action_157 _ = happyReduce_235++action_158 (149) = happyShift action_100+action_158 (151) = happyShift action_102+action_158 (167) = happyShift action_173+action_158 (119) = happyGoto action_113+action_158 (127) = happyGoto action_114+action_158 (128) = happyGoto action_94+action_158 _ = happyReduce_158++action_159 _ = happyReduce_240++action_160 (161) = happyShift action_230+action_160 _ = happyFail++action_161 _ = happyReduce_254++action_162 (165) = happyShift action_229+action_162 _ = happyReduce_256++action_163 (171) = happyShift action_228+action_163 _ = happyFail++action_164 (143) = happyShift action_34+action_164 (144) = happyShift action_35+action_164 (145) = happyShift action_36+action_164 (146) = happyShift action_37+action_164 (153) = happyShift action_39+action_164 (154) = happyShift action_40+action_164 (155) = happyShift action_41+action_164 (156) = happyShift action_42+action_164 (157) = happyShift action_83+action_164 (163) = happyShift action_44+action_164 (166) = happyShift action_45+action_164 (177) = happyShift action_46+action_164 (180) = happyShift action_47+action_164 (188) = happyShift action_51+action_164 (203) = happyShift action_59+action_164 (102) = happyGoto action_164+action_164 (104) = happyGoto action_227+action_164 (113) = happyGoto action_81+action_164 (115) = happyGoto action_82+action_164 (122) = happyGoto action_28+action_164 (123) = happyGoto action_29+action_164 (124) = happyGoto action_30+action_164 (126) = happyGoto action_31+action_164 (132) = happyGoto action_32+action_164 (133) = happyGoto action_33+action_164 _ = happyReduce_251++action_165 _ = happyReduce_250++action_166 _ = happyReduce_274++action_167 _ = happyReduce_278++action_168 _ = happyReduce_247++action_169 _ = happyReduce_246++action_170 (143) = happyShift action_34+action_170 (144) = happyShift action_35+action_170 (145) = happyShift action_36+action_170 (146) = happyShift action_37+action_170 (147) = happyShift action_38+action_170 (153) = happyShift action_39+action_170 (154) = happyShift action_40+action_170 (155) = happyShift action_41+action_170 (156) = happyShift action_42+action_170 (157) = happyShift action_83+action_170 (163) = happyShift action_44+action_170 (166) = happyShift action_45+action_170 (177) = happyShift action_46+action_170 (180) = happyShift action_47+action_170 (188) = happyShift action_51+action_170 (203) = happyShift action_59+action_170 (99) = happyGoto action_225+action_170 (100) = happyGoto action_85+action_170 (101) = happyGoto action_24+action_170 (102) = happyGoto action_25+action_170 (108) = happyGoto action_226+action_170 (113) = happyGoto action_81+action_170 (115) = happyGoto action_27+action_170 (122) = happyGoto action_28+action_170 (123) = happyGoto action_29+action_170 (124) = happyGoto action_30+action_170 (126) = happyGoto action_31+action_170 (132) = happyGoto action_32+action_170 (133) = happyGoto action_33+action_170 _ = happyFail++action_171 (143) = happyShift action_34+action_171 (144) = happyShift action_35+action_171 (145) = happyShift action_36+action_171 (146) = happyShift action_37+action_171 (153) = happyShift action_39+action_171 (154) = happyShift action_40+action_171 (155) = happyShift action_41+action_171 (156) = happyShift action_42+action_171 (157) = happyShift action_83+action_171 (163) = happyShift action_44+action_171 (166) = happyShift action_45+action_171 (177) = happyShift action_46+action_171 (180) = happyShift action_47+action_171 (188) = happyShift action_51+action_171 (203) = happyShift action_59+action_171 (102) = happyGoto action_164+action_171 (104) = happyGoto action_224+action_171 (113) = happyGoto action_81+action_171 (115) = happyGoto action_82+action_171 (122) = happyGoto action_28+action_171 (123) = happyGoto action_29+action_171 (124) = happyGoto action_30+action_171 (126) = happyGoto action_31+action_171 (132) = happyGoto action_32+action_171 (133) = happyGoto action_33+action_171 _ = happyReduce_251++action_172 _ = happyReduce_248++action_173 (145) = happyShift action_36+action_173 (146) = happyShift action_37+action_173 (124) = happyGoto action_155+action_173 (126) = happyGoto action_31+action_173 _ = happyFail++action_174 (143) = happyShift action_34+action_174 (144) = happyShift action_35+action_174 (145) = happyShift action_36+action_174 (146) = happyShift action_37+action_174 (147) = happyShift action_38+action_174 (153) = happyShift action_39+action_174 (154) = happyShift action_40+action_174 (155) = happyShift action_41+action_174 (156) = happyShift action_42+action_174 (157) = happyShift action_83+action_174 (163) = happyShift action_44+action_174 (166) = happyShift action_45+action_174 (177) = happyShift action_46+action_174 (180) = happyShift action_47+action_174 (188) = happyShift action_51+action_174 (203) = happyShift action_59+action_174 (99) = happyGoto action_84+action_174 (100) = happyGoto action_85+action_174 (101) = happyGoto action_24+action_174 (102) = happyGoto action_25+action_174 (109) = happyGoto action_223+action_174 (110) = happyGoto action_87+action_174 (113) = happyGoto action_81+action_174 (115) = happyGoto action_27+action_174 (122) = happyGoto action_28+action_174 (123) = happyGoto action_29+action_174 (124) = happyGoto action_30+action_174 (126) = happyGoto action_31+action_174 (132) = happyGoto action_32+action_174 (133) = happyGoto action_33+action_174 _ = happyReduce_260++action_175 (178) = happyShift action_222+action_175 _ = happyReduce_106++action_176 (143) = happyShift action_34+action_176 (145) = happyShift action_36+action_176 (146) = happyShift action_71+action_176 (157) = happyShift action_182+action_176 (163) = happyShift action_183+action_176 (175) = happyShift action_221+action_176 (180) = happyShift action_47+action_176 (188) = happyShift action_51+action_176 (203) = happyShift action_59+action_176 (44) = happyGoto action_220+action_176 (45) = happyGoto action_178+action_176 (123) = happyGoto action_180+action_176 (125) = happyGoto action_68+action_176 (126) = happyGoto action_69+action_176 (139) = happyGoto action_70+action_176 (142) = happyGoto action_181+action_176 _ = happyReduce_92++action_177 _ = happyReduce_94++action_178 _ = happyReduce_95++action_179 (173) = happyShift action_219+action_179 (32) = happyGoto action_218+action_179 _ = happyReduce_72++action_180 _ = happyReduce_326++action_181 _ = happyReduce_96++action_182 (143) = happyShift action_34+action_182 (145) = happyShift action_36+action_182 (146) = happyShift action_71+action_182 (157) = happyShift action_182+action_182 (158) = happyShift action_196+action_182 (163) = happyShift action_183+action_182 (165) = happyShift action_197+action_182 (175) = happyShift action_198+action_182 (180) = happyShift action_47+action_182 (188) = happyShift action_51+action_182 (203) = happyShift action_59+action_182 (42) = happyGoto action_216+action_182 (43) = happyGoto action_176+action_182 (44) = happyGoto action_177+action_182 (45) = happyGoto action_178+action_182 (47) = happyGoto action_217+action_182 (81) = happyGoto action_195+action_182 (123) = happyGoto action_180+action_182 (125) = happyGoto action_68+action_182 (126) = happyGoto action_69+action_182 (139) = happyGoto action_70+action_182 (142) = happyGoto action_181+action_182 _ = happyFail++action_183 (143) = happyShift action_34+action_183 (145) = happyShift action_36+action_183 (146) = happyShift action_71+action_183 (157) = happyShift action_182+action_183 (163) = happyShift action_183+action_183 (164) = happyShift action_194+action_183 (180) = happyShift action_47+action_183 (188) = happyShift action_51+action_183 (203) = happyShift action_59+action_183 (42) = happyGoto action_215+action_183 (43) = happyGoto action_176+action_183 (44) = happyGoto action_177+action_183 (45) = happyGoto action_178+action_183 (123) = happyGoto action_180+action_183 (125) = happyGoto action_68+action_183 (126) = happyGoto action_69+action_183 (139) = happyGoto action_70+action_183 (142) = happyGoto action_181+action_183 _ = happyFail++action_184 (178) = happyShift action_214+action_184 _ = happyFail++action_185 (143) = happyShift action_34+action_185 (145) = happyReduce_95+action_185 (146) = happyReduce_95+action_185 (157) = happyReduce_95+action_185 (163) = happyReduce_95+action_185 (175) = happyReduce_95+action_185 (178) = happyReduce_95+action_185 (180) = happyShift action_47+action_185 (188) = happyShift action_51+action_185 (203) = happyShift action_59+action_185 (50) = happyGoto action_200+action_185 (123) = happyGoto action_180+action_185 (142) = happyGoto action_201+action_185 _ = happyReduce_112++action_186 (171) = happyShift action_213+action_186 _ = happyReduce_115++action_187 _ = happyReduce_110++action_188 _ = happyReduce_69++action_189 _ = happyReduce_68++action_190 (145) = happyShift action_10+action_190 (137) = happyGoto action_212+action_190 _ = happyFail++action_191 _ = happyReduce_32++action_192 (202) = happyShift action_211+action_192 (67) = happyGoto action_210+action_192 _ = happyReduce_152++action_193 (171) = happyShift action_209+action_193 _ = happyFail++action_194 _ = happyReduce_102++action_195 (158) = happyShift action_207+action_195 (165) = happyShift action_208+action_195 _ = happyFail++action_196 _ = happyReduce_101++action_197 _ = happyReduce_194++action_198 (158) = happyShift action_206+action_198 _ = happyFail++action_199 (171) = happyShift action_205+action_199 _ = happyFail++action_200 (143) = happyShift action_34+action_200 (180) = happyShift action_47+action_200 (188) = happyShift action_51+action_200 (203) = happyShift action_59+action_200 (123) = happyGoto action_180+action_200 (142) = happyGoto action_204+action_200 _ = happyReduce_111++action_201 _ = happyReduce_114++action_202 (170) = happyShift action_203+action_202 _ = happyFail++action_203 (143) = happyShift action_34+action_203 (145) = happyShift action_36+action_203 (146) = happyShift action_71+action_203 (157) = happyShift action_182+action_203 (163) = happyShift action_183+action_203 (180) = happyShift action_47+action_203 (188) = happyShift action_51+action_203 (203) = happyShift action_59+action_203 (42) = happyGoto action_346+action_203 (43) = happyGoto action_176+action_203 (44) = happyGoto action_177+action_203 (45) = happyGoto action_178+action_203 (123) = happyGoto action_180+action_203 (125) = happyGoto action_68+action_203 (126) = happyGoto action_69+action_203 (139) = happyGoto action_70+action_203 (142) = happyGoto action_181+action_203 _ = happyFail++action_204 _ = happyReduce_113++action_205 (143) = happyShift action_34+action_205 (145) = happyShift action_36+action_205 (146) = happyShift action_71+action_205 (157) = happyShift action_182+action_205 (163) = happyShift action_183+action_205 (180) = happyShift action_47+action_205 (188) = happyShift action_51+action_205 (203) = happyShift action_59+action_205 (42) = happyGoto action_345+action_205 (43) = happyGoto action_176+action_205 (44) = happyGoto action_177+action_205 (45) = happyGoto action_178+action_205 (123) = happyGoto action_180+action_205 (125) = happyGoto action_68+action_205 (126) = happyGoto action_69+action_205 (139) = happyGoto action_70+action_205 (142) = happyGoto action_181+action_205 _ = happyFail++action_206 _ = happyReduce_103++action_207 _ = happyReduce_104++action_208 _ = happyReduce_193++action_209 (53) = happyGoto action_344+action_209 (134) = happyGoto action_339+action_209 _ = happyReduce_317++action_210 _ = happyReduce_67++action_211 (160) = happyShift action_343+action_211 (135) = happyGoto action_342+action_211 _ = happyReduce_318++action_212 (180) = happyShift action_341+action_212 (18) = happyGoto action_340+action_212 _ = happyReduce_35++action_213 (52) = happyGoto action_337+action_213 (53) = happyGoto action_338+action_213 (134) = happyGoto action_339+action_213 _ = happyReduce_317++action_214 (145) = happyShift action_36+action_214 (146) = happyShift action_71+action_214 (157) = happyShift action_72+action_214 (163) = happyShift action_73+action_214 (45) = happyGoto action_66+action_214 (49) = happyGoto action_336+action_214 (125) = happyGoto action_68+action_214 (126) = happyGoto action_69+action_214 (139) = happyGoto action_70+action_214 _ = happyFail++action_215 (164) = happyShift action_335+action_215 _ = happyFail++action_216 (158) = happyShift action_333+action_216 (165) = happyShift action_334+action_216 _ = happyFail++action_217 (158) = happyShift action_331+action_217 (165) = happyShift action_332+action_217 _ = happyFail++action_218 (202) = happyShift action_330+action_218 (63) = happyGoto action_329+action_218 _ = happyReduce_142++action_219 (143) = happyShift action_34+action_219 (180) = happyShift action_47+action_219 (188) = happyShift action_51+action_219 (203) = happyShift action_59+action_219 (33) = happyGoto action_325+action_219 (34) = happyGoto action_326+action_219 (35) = happyGoto action_327+action_219 (50) = happyGoto action_328+action_219 (123) = happyGoto action_180+action_219 (142) = happyGoto action_201+action_219 _ = happyReduce_77++action_220 _ = happyReduce_93++action_221 (143) = happyShift action_34+action_221 (145) = happyShift action_36+action_221 (146) = happyShift action_71+action_221 (157) = happyShift action_182+action_221 (163) = happyShift action_183+action_221 (180) = happyShift action_47+action_221 (188) = happyShift action_51+action_221 (203) = happyShift action_59+action_221 (42) = happyGoto action_324+action_221 (43) = happyGoto action_176+action_221 (44) = happyGoto action_177+action_221 (45) = happyGoto action_178+action_221 (123) = happyGoto action_180+action_221 (125) = happyGoto action_68+action_221 (126) = happyGoto action_69+action_221 (139) = happyGoto action_70+action_221 (142) = happyGoto action_181+action_221 _ = happyFail++action_222 (143) = happyShift action_34+action_222 (145) = happyShift action_36+action_222 (146) = happyShift action_71+action_222 (157) = happyShift action_182+action_222 (163) = happyShift action_183+action_222 (180) = happyShift action_47+action_222 (188) = happyShift action_51+action_222 (203) = happyShift action_59+action_222 (42) = happyGoto action_323+action_222 (43) = happyGoto action_176+action_222 (44) = happyGoto action_177+action_222 (45) = happyGoto action_178+action_222 (123) = happyGoto action_180+action_222 (125) = happyGoto action_68+action_222 (126) = happyGoto action_69+action_222 (139) = happyGoto action_70+action_222 (142) = happyGoto action_181+action_222 _ = happyFail++action_223 _ = happyReduce_262++action_224 _ = happyReduce_159++action_225 (165) = happyShift action_170+action_225 _ = happyReduce_259++action_226 _ = happyReduce_258++action_227 _ = happyReduce_252++action_228 (143) = happyShift action_34+action_228 (144) = happyShift action_35+action_228 (145) = happyShift action_36+action_228 (146) = happyShift action_37+action_228 (147) = happyShift action_38+action_228 (153) = happyShift action_39+action_228 (154) = happyShift action_40+action_228 (155) = happyShift action_41+action_228 (156) = happyShift action_42+action_228 (157) = happyShift action_83+action_228 (163) = happyShift action_44+action_228 (166) = happyShift action_45+action_228 (177) = happyShift action_46+action_228 (180) = happyShift action_47+action_228 (188) = happyShift action_51+action_228 (203) = happyShift action_59+action_228 (99) = happyGoto action_322+action_228 (100) = happyGoto action_85+action_228 (101) = happyGoto action_24+action_228 (102) = happyGoto action_25+action_228 (113) = happyGoto action_81+action_228 (115) = happyGoto action_27+action_228 (122) = happyGoto action_28+action_228 (123) = happyGoto action_29+action_228 (124) = happyGoto action_30+action_228 (126) = happyGoto action_31+action_228 (132) = happyGoto action_32+action_228 (133) = happyGoto action_33+action_228 _ = happyFail++action_229 (143) = happyShift action_34+action_229 (144) = happyShift action_35+action_229 (157) = happyShift action_136+action_229 (180) = happyShift action_47+action_229 (188) = happyShift action_51+action_229 (203) = happyShift action_59+action_229 (106) = happyGoto action_321+action_229 (107) = happyGoto action_162+action_229 (113) = happyGoto action_163+action_229 (122) = happyGoto action_28+action_229 (123) = happyGoto action_29+action_229 _ = happyFail++action_230 _ = happyReduce_243++action_231 _ = happyReduce_156++action_232 (160) = happyShift action_289+action_232 (39) = happyGoto action_320+action_232 (135) = happyGoto action_288+action_232 _ = happyReduce_318++action_233 _ = happyReduce_286++action_234 _ = happyReduce_282++action_235 (134) = happyGoto action_319+action_235 _ = happyReduce_317++action_236 (147) = happyShift action_117+action_236 (148) = happyShift action_99+action_236 (149) = happyShift action_100+action_236 (150) = happyShift action_101+action_236 (151) = happyShift action_102+action_236 (167) = happyShift action_118+action_236 (168) = happyShift action_104+action_236 (170) = happyShift action_318+action_236 (179) = happyShift action_105+action_236 (117) = happyGoto action_305+action_236 (119) = happyGoto action_306+action_236 (121) = happyGoto action_317+action_236 (127) = happyGoto action_114+action_236 (128) = happyGoto action_94+action_236 (129) = happyGoto action_115+action_236 (130) = happyGoto action_96+action_236 (131) = happyGoto action_97+action_236 _ = happyReduce_168++action_237 _ = happyReduce_169++action_238 (143) = happyShift action_34+action_238 (144) = happyShift action_35+action_238 (145) = happyShift action_36+action_238 (146) = happyShift action_37+action_238 (152) = happyShift action_246+action_238 (153) = happyShift action_39+action_238 (154) = happyShift action_40+action_238 (155) = happyShift action_41+action_238 (156) = happyShift action_42+action_238 (157) = happyShift action_247+action_238 (163) = happyShift action_248+action_238 (166) = happyShift action_249+action_238 (177) = happyShift action_251+action_238 (180) = happyShift action_47+action_238 (188) = happyShift action_51+action_238 (203) = happyShift action_59+action_238 (79) = happyGoto action_316+action_238 (80) = happyGoto action_240+action_238 (111) = happyGoto action_241+action_238 (113) = happyGoto action_242+action_238 (115) = happyGoto action_243+action_238 (122) = happyGoto action_28+action_238 (123) = happyGoto action_29+action_238 (124) = happyGoto action_30+action_238 (126) = happyGoto action_31+action_238 (132) = happyGoto action_244+action_238 (133) = happyGoto action_33+action_238 _ = happyReduce_177++action_239 (160) = happyShift action_315+action_239 _ = happyReduce_179++action_240 _ = happyReduce_181++action_241 _ = happyReduce_183++action_242 (176) = happyShift action_314+action_242 _ = happyReduce_182++action_243 _ = happyReduce_270++action_244 _ = happyReduce_184++action_245 (143) = happyShift action_34+action_245 (144) = happyShift action_35+action_245 (145) = happyShift action_36+action_245 (146) = happyShift action_37+action_245 (152) = happyShift action_246+action_245 (153) = happyShift action_39+action_245 (154) = happyShift action_40+action_245 (155) = happyShift action_41+action_245 (156) = happyShift action_42+action_245 (157) = happyShift action_247+action_245 (163) = happyShift action_248+action_245 (166) = happyShift action_249+action_245 (177) = happyShift action_251+action_245 (180) = happyShift action_47+action_245 (188) = happyShift action_51+action_245 (203) = happyShift action_59+action_245 (78) = happyGoto action_313+action_245 (79) = happyGoto action_239+action_245 (80) = happyGoto action_240+action_245 (111) = happyGoto action_241+action_245 (113) = happyGoto action_242+action_245 (115) = happyGoto action_243+action_245 (122) = happyGoto action_28+action_245 (123) = happyGoto action_29+action_245 (124) = happyGoto action_30+action_245 (126) = happyGoto action_31+action_245 (132) = happyGoto action_244+action_245 (133) = happyGoto action_33+action_245 _ = happyFail++action_246 (168) = happyShift action_312+action_246 _ = happyFail++action_247 (143) = happyShift action_34+action_247 (144) = happyShift action_35+action_247 (145) = happyShift action_36+action_247 (146) = happyShift action_37+action_247 (147) = happyShift action_310+action_247 (148) = happyShift action_99+action_247 (149) = happyShift action_100+action_247 (150) = happyShift action_101+action_247 (151) = happyShift action_102+action_247 (152) = happyShift action_246+action_247 (153) = happyShift action_39+action_247 (154) = happyShift action_40+action_247 (155) = happyShift action_41+action_247 (156) = happyShift action_42+action_247 (157) = happyShift action_247+action_247 (158) = happyShift action_311+action_247 (163) = happyShift action_248+action_247 (165) = happyShift action_197+action_247 (166) = happyShift action_249+action_247 (167) = happyShift action_118+action_247 (168) = happyShift action_104+action_247 (172) = happyShift action_250+action_247 (177) = happyShift action_251+action_247 (179) = happyShift action_105+action_247 (180) = happyShift action_47+action_247 (181) = happyShift action_252+action_247 (186) = happyShift action_253+action_247 (188) = happyShift action_51+action_247 (189) = happyShift action_254+action_247 (196) = happyShift action_255+action_247 (203) = happyShift action_59+action_247 (75) = happyGoto action_301+action_247 (76) = happyGoto action_302+action_247 (77) = happyGoto action_237+action_247 (78) = happyGoto action_238+action_247 (79) = happyGoto action_239+action_247 (80) = happyGoto action_240+action_247 (81) = happyGoto action_303+action_247 (82) = happyGoto action_304+action_247 (111) = happyGoto action_241+action_247 (113) = happyGoto action_242+action_247 (115) = happyGoto action_243+action_247 (117) = happyGoto action_305+action_247 (119) = happyGoto action_306+action_247 (121) = happyGoto action_307+action_247 (122) = happyGoto action_28+action_247 (123) = happyGoto action_29+action_247 (124) = happyGoto action_30+action_247 (126) = happyGoto action_31+action_247 (127) = happyGoto action_308+action_247 (128) = happyGoto action_94+action_247 (129) = happyGoto action_309+action_247 (130) = happyGoto action_96+action_247 (131) = happyGoto action_97+action_247 (132) = happyGoto action_244+action_247 (133) = happyGoto action_33+action_247 _ = happyFail++action_248 (143) = happyShift action_34+action_248 (144) = happyShift action_35+action_248 (145) = happyShift action_36+action_248 (146) = happyShift action_37+action_248 (147) = happyShift action_245+action_248 (152) = happyShift action_246+action_248 (153) = happyShift action_39+action_248 (154) = happyShift action_40+action_248 (155) = happyShift action_41+action_248 (156) = happyShift action_42+action_248 (157) = happyShift action_247+action_248 (163) = happyShift action_248+action_248 (164) = happyShift action_300+action_248 (166) = happyShift action_249+action_248 (172) = happyShift action_250+action_248 (177) = happyShift action_251+action_248 (180) = happyShift action_47+action_248 (181) = happyShift action_252+action_248 (186) = happyShift action_253+action_248 (188) = happyShift action_51+action_248 (189) = happyShift action_254+action_248 (196) = happyShift action_255+action_248 (203) = happyShift action_59+action_248 (75) = happyGoto action_297+action_248 (76) = happyGoto action_236+action_248 (77) = happyGoto action_237+action_248 (78) = happyGoto action_238+action_248 (79) = happyGoto action_239+action_248 (80) = happyGoto action_240+action_248 (83) = happyGoto action_298+action_248 (84) = happyGoto action_299+action_248 (111) = happyGoto action_241+action_248 (113) = happyGoto action_242+action_248 (115) = happyGoto action_243+action_248 (122) = happyGoto action_28+action_248 (123) = happyGoto action_29+action_248 (124) = happyGoto action_30+action_248 (126) = happyGoto action_31+action_248 (132) = happyGoto action_244+action_248 (133) = happyGoto action_33+action_248 _ = happyFail++action_249 _ = happyReduce_191++action_250 (143) = happyShift action_34+action_250 (144) = happyShift action_35+action_250 (145) = happyShift action_36+action_250 (146) = happyShift action_37+action_250 (153) = happyShift action_39+action_250 (154) = happyShift action_40+action_250 (155) = happyShift action_41+action_250 (156) = happyShift action_42+action_250 (157) = happyShift action_83+action_250 (163) = happyShift action_44+action_250 (166) = happyShift action_45+action_250 (177) = happyShift action_46+action_250 (180) = happyShift action_47+action_250 (188) = happyShift action_51+action_250 (203) = happyShift action_59+action_250 (102) = happyGoto action_164+action_250 (104) = happyGoto action_296+action_250 (113) = happyGoto action_81+action_250 (115) = happyGoto action_82+action_250 (122) = happyGoto action_28+action_250 (123) = happyGoto action_29+action_250 (124) = happyGoto action_30+action_250 (126) = happyGoto action_31+action_250 (132) = happyGoto action_32+action_250 (133) = happyGoto action_33+action_250 _ = happyReduce_251++action_251 (143) = happyShift action_34+action_251 (144) = happyShift action_35+action_251 (145) = happyShift action_36+action_251 (146) = happyShift action_37+action_251 (152) = happyShift action_246+action_251 (153) = happyShift action_39+action_251 (154) = happyShift action_40+action_251 (155) = happyShift action_41+action_251 (156) = happyShift action_42+action_251 (157) = happyShift action_247+action_251 (163) = happyShift action_248+action_251 (166) = happyShift action_249+action_251 (177) = happyShift action_251+action_251 (180) = happyShift action_47+action_251 (188) = happyShift action_51+action_251 (203) = happyShift action_59+action_251 (80) = happyGoto action_295+action_251 (111) = happyGoto action_241+action_251 (113) = happyGoto action_242+action_251 (115) = happyGoto action_243+action_251 (122) = happyGoto action_28+action_251 (123) = happyGoto action_29+action_251 (124) = happyGoto action_30+action_251 (126) = happyGoto action_31+action_251 (132) = happyGoto action_244+action_251 (133) = happyGoto action_33+action_251 _ = happyFail++action_252 (143) = happyShift action_34+action_252 (144) = happyShift action_35+action_252 (145) = happyShift action_36+action_252 (146) = happyShift action_37+action_252 (147) = happyShift action_245+action_252 (152) = happyShift action_246+action_252 (153) = happyShift action_39+action_252 (154) = happyShift action_40+action_252 (155) = happyShift action_41+action_252 (156) = happyShift action_42+action_252 (157) = happyShift action_247+action_252 (163) = happyShift action_248+action_252 (166) = happyShift action_249+action_252 (172) = happyShift action_250+action_252 (177) = happyShift action_251+action_252 (180) = happyShift action_47+action_252 (181) = happyShift action_252+action_252 (186) = happyShift action_253+action_252 (188) = happyShift action_51+action_252 (189) = happyShift action_254+action_252 (196) = happyShift action_255+action_252 (203) = happyShift action_59+action_252 (75) = happyGoto action_294+action_252 (76) = happyGoto action_236+action_252 (77) = happyGoto action_237+action_252 (78) = happyGoto action_238+action_252 (79) = happyGoto action_239+action_252 (80) = happyGoto action_240+action_252 (111) = happyGoto action_241+action_252 (113) = happyGoto action_242+action_252 (115) = happyGoto action_243+action_252 (122) = happyGoto action_28+action_252 (123) = happyGoto action_29+action_252 (124) = happyGoto action_30+action_252 (126) = happyGoto action_31+action_252 (132) = happyGoto action_244+action_252 (133) = happyGoto action_33+action_252 _ = happyFail++action_253 (160) = happyShift action_293+action_253 (93) = happyGoto action_291+action_253 (135) = happyGoto action_292+action_253 _ = happyReduce_318++action_254 (143) = happyShift action_34+action_254 (144) = happyShift action_35+action_254 (145) = happyShift action_36+action_254 (146) = happyShift action_37+action_254 (147) = happyShift action_245+action_254 (152) = happyShift action_246+action_254 (153) = happyShift action_39+action_254 (154) = happyShift action_40+action_254 (155) = happyShift action_41+action_254 (156) = happyShift action_42+action_254 (157) = happyShift action_247+action_254 (163) = happyShift action_248+action_254 (166) = happyShift action_249+action_254 (172) = happyShift action_250+action_254 (177) = happyShift action_251+action_254 (180) = happyShift action_47+action_254 (181) = happyShift action_252+action_254 (186) = happyShift action_253+action_254 (188) = happyShift action_51+action_254 (189) = happyShift action_254+action_254 (196) = happyShift action_255+action_254 (203) = happyShift action_59+action_254 (75) = happyGoto action_290+action_254 (76) = happyGoto action_236+action_254 (77) = happyGoto action_237+action_254 (78) = happyGoto action_238+action_254 (79) = happyGoto action_239+action_254 (80) = happyGoto action_240+action_254 (111) = happyGoto action_241+action_254 (113) = happyGoto action_242+action_254 (115) = happyGoto action_243+action_254 (122) = happyGoto action_28+action_254 (123) = happyGoto action_29+action_254 (124) = happyGoto action_30+action_254 (126) = happyGoto action_31+action_254 (132) = happyGoto action_244+action_254 (133) = happyGoto action_33+action_254 _ = happyFail++action_255 (160) = happyShift action_289+action_255 (39) = happyGoto action_287+action_255 (135) = happyGoto action_288+action_255 _ = happyReduce_318++action_256 _ = happyReduce_162++action_257 _ = happyReduce_164++action_258 _ = happyReduce_155++action_259 _ = happyReduce_88++action_260 (158) = happyShift action_286+action_260 _ = happyFail++action_261 _ = happyReduce_55++action_262 _ = happyReduce_287++action_263 _ = happyReduce_288++action_264 (165) = happyShift action_285+action_264 _ = happyReduce_62++action_265 _ = happyReduce_283++action_266 _ = happyReduce_279++action_267 (143) = happyShift action_34+action_267 (145) = happyShift action_36+action_267 (180) = happyShift action_47+action_267 (188) = happyShift action_51+action_267 (203) = happyShift action_59+action_267 (123) = happyGoto action_283+action_267 (126) = happyGoto action_284+action_267 _ = happyFail++action_268 _ = happyReduce_5++action_269 _ = happyReduce_1++action_270 _ = happyReduce_24++action_271 (143) = happyShift action_34+action_271 (144) = happyShift action_35+action_271 (145) = happyShift action_36+action_271 (146) = happyShift action_37+action_271 (157) = happyShift action_280+action_271 (158) = happyShift action_281+action_271 (169) = happyShift action_282+action_271 (180) = happyShift action_47+action_271 (188) = happyShift action_51+action_271 (203) = happyShift action_59+action_271 (13) = happyGoto action_276+action_271 (14) = happyGoto action_277+action_271 (113) = happyGoto action_278+action_271 (115) = happyGoto action_279+action_271 (122) = happyGoto action_28+action_271 (123) = happyGoto action_29+action_271 (124) = happyGoto action_30+action_271 (126) = happyGoto action_31+action_271 _ = happyFail++action_272 (158) = happyShift action_275+action_272 _ = happyFail++action_273 (143) = happyShift action_34+action_273 (144) = happyShift action_35+action_273 (145) = happyShift action_36+action_273 (146) = happyShift action_71+action_273 (157) = happyShift action_136+action_273 (180) = happyShift action_47+action_273 (188) = happyShift action_51+action_273 (197) = happyShift action_138+action_273 (203) = happyShift action_59+action_273 (12) = happyGoto action_274+action_273 (113) = happyGoto action_133+action_273 (122) = happyGoto action_28+action_273 (123) = happyGoto action_29+action_273 (125) = happyGoto action_134+action_273 (126) = happyGoto action_69+action_273 (139) = happyGoto action_70+action_273 (140) = happyGoto action_135+action_273 _ = happyReduce_15++action_274 _ = happyReduce_17++action_275 _ = happyReduce_13++action_276 (158) = happyShift action_418+action_276 (165) = happyShift action_419+action_276 _ = happyFail++action_277 _ = happyReduce_26++action_278 _ = happyReduce_27++action_279 _ = happyReduce_28++action_280 (147) = happyShift action_117+action_280 (148) = happyShift action_99+action_280 (149) = happyShift action_100+action_280 (150) = happyShift action_101+action_280 (151) = happyShift action_102+action_280 (168) = happyShift action_104+action_280 (179) = happyShift action_105+action_280 (127) = happyGoto action_93+action_280 (128) = happyGoto action_94+action_280 (129) = happyGoto action_95+action_280 (130) = happyGoto action_96+action_280 (131) = happyGoto action_97+action_280 _ = happyFail++action_281 _ = happyReduce_22++action_282 (158) = happyShift action_417+action_282 _ = happyFail++action_283 (167) = happyShift action_416+action_283 _ = happyFail++action_284 (167) = happyShift action_415+action_284 _ = happyFail++action_285 (147) = happyShift action_117+action_285 (148) = happyShift action_99+action_285 (149) = happyShift action_100+action_285 (167) = happyShift action_267+action_285 (168) = happyShift action_104+action_285 (179) = happyShift action_105+action_285 (30) = happyGoto action_414+action_285 (116) = happyGoto action_262+action_285 (118) = happyGoto action_263+action_285 (120) = happyGoto action_264+action_285 (128) = happyGoto action_265+action_285 (130) = happyGoto action_266+action_285 _ = happyFail++action_286 _ = happyReduce_272++action_287 (191) = happyShift action_413+action_287 _ = happyFail++action_288 (143) = happyShift action_34+action_288 (144) = happyShift action_35+action_288 (145) = happyShift action_36+action_288 (146) = happyShift action_37+action_288 (147) = happyShift action_38+action_288 (153) = happyShift action_39+action_288 (154) = happyShift action_40+action_288 (155) = happyShift action_41+action_288 (156) = happyShift action_42+action_288 (157) = happyShift action_43+action_288 (159) = happyShift action_353+action_288 (163) = happyShift action_44+action_288 (166) = happyShift action_45+action_288 (177) = happyShift action_46+action_288 (180) = happyShift action_47+action_288 (188) = happyShift action_51+action_288 (192) = happyShift action_53+action_288 (193) = happyShift action_54+action_288 (194) = happyShift action_55+action_288 (203) = happyShift action_59+action_288 (7) = happyGoto action_408+action_288 (27) = happyGoto action_15+action_288 (29) = happyGoto action_16+action_288 (36) = happyGoto action_412+action_288 (37) = happyGoto action_410+action_288 (38) = happyGoto action_411+action_288 (40) = happyGoto action_19+action_288 (41) = happyGoto action_20+action_288 (69) = happyGoto action_21+action_288 (70) = happyGoto action_22+action_288 (100) = happyGoto action_23+action_288 (101) = happyGoto action_24+action_288 (102) = happyGoto action_25+action_288 (113) = happyGoto action_26+action_288 (115) = happyGoto action_27+action_288 (122) = happyGoto action_28+action_288 (123) = happyGoto action_29+action_288 (124) = happyGoto action_30+action_288 (126) = happyGoto action_31+action_288 (132) = happyGoto action_32+action_288 (133) = happyGoto action_33+action_288 _ = happyReduce_10++action_289 (143) = happyShift action_34+action_289 (144) = happyShift action_35+action_289 (145) = happyShift action_36+action_289 (146) = happyShift action_37+action_289 (147) = happyShift action_38+action_289 (153) = happyShift action_39+action_289 (154) = happyShift action_40+action_289 (155) = happyShift action_41+action_289 (156) = happyShift action_42+action_289 (157) = happyShift action_43+action_289 (159) = happyShift action_353+action_289 (163) = happyShift action_44+action_289 (166) = happyShift action_45+action_289 (177) = happyShift action_46+action_289 (180) = happyShift action_47+action_289 (188) = happyShift action_51+action_289 (192) = happyShift action_53+action_289 (193) = happyShift action_54+action_289 (194) = happyShift action_55+action_289 (203) = happyShift action_59+action_289 (7) = happyGoto action_408+action_289 (27) = happyGoto action_15+action_289 (29) = happyGoto action_16+action_289 (36) = happyGoto action_409+action_289 (37) = happyGoto action_410+action_289 (38) = happyGoto action_411+action_289 (40) = happyGoto action_19+action_289 (41) = happyGoto action_20+action_289 (69) = happyGoto action_21+action_289 (70) = happyGoto action_22+action_289 (100) = happyGoto action_23+action_289 (101) = happyGoto action_24+action_289 (102) = happyGoto action_25+action_289 (113) = happyGoto action_26+action_289 (115) = happyGoto action_27+action_289 (122) = happyGoto action_28+action_289 (123) = happyGoto action_29+action_289 (124) = happyGoto action_30+action_289 (126) = happyGoto action_31+action_289 (132) = happyGoto action_32+action_289 (133) = happyGoto action_33+action_289 _ = happyReduce_10++action_290 (200) = happyShift action_407+action_290 _ = happyFail++action_291 _ = happyReduce_176++action_292 (143) = happyShift action_34+action_292 (144) = happyShift action_35+action_292 (145) = happyShift action_36+action_292 (146) = happyShift action_37+action_292 (147) = happyShift action_245+action_292 (152) = happyShift action_246+action_292 (153) = happyShift action_39+action_292 (154) = happyShift action_40+action_292 (155) = happyShift action_41+action_292 (156) = happyShift action_42+action_292 (157) = happyShift action_247+action_292 (163) = happyShift action_248+action_292 (166) = happyShift action_249+action_292 (172) = happyShift action_250+action_292 (177) = happyShift action_251+action_292 (180) = happyShift action_47+action_292 (181) = happyShift action_252+action_292 (186) = happyShift action_253+action_292 (188) = happyShift action_51+action_292 (189) = happyShift action_254+action_292 (196) = happyShift action_405+action_292 (203) = happyShift action_59+action_292 (75) = happyGoto action_400+action_292 (76) = happyGoto action_401+action_292 (77) = happyGoto action_237+action_292 (78) = happyGoto action_238+action_292 (79) = happyGoto action_239+action_292 (80) = happyGoto action_240+action_292 (86) = happyGoto action_402+action_292 (94) = happyGoto action_406+action_292 (95) = happyGoto action_404+action_292 (111) = happyGoto action_241+action_292 (113) = happyGoto action_242+action_292 (115) = happyGoto action_243+action_292 (122) = happyGoto action_28+action_292 (123) = happyGoto action_29+action_292 (124) = happyGoto action_30+action_292 (126) = happyGoto action_31+action_292 (132) = happyGoto action_244+action_292 (133) = happyGoto action_33+action_292 _ = happyFail++action_293 (143) = happyShift action_34+action_293 (144) = happyShift action_35+action_293 (145) = happyShift action_36+action_293 (146) = happyShift action_37+action_293 (147) = happyShift action_245+action_293 (152) = happyShift action_246+action_293 (153) = happyShift action_39+action_293 (154) = happyShift action_40+action_293 (155) = happyShift action_41+action_293 (156) = happyShift action_42+action_293 (157) = happyShift action_247+action_293 (163) = happyShift action_248+action_293 (166) = happyShift action_249+action_293 (172) = happyShift action_250+action_293 (177) = happyShift action_251+action_293 (180) = happyShift action_47+action_293 (181) = happyShift action_252+action_293 (186) = happyShift action_253+action_293 (188) = happyShift action_51+action_293 (189) = happyShift action_254+action_293 (196) = happyShift action_405+action_293 (203) = happyShift action_59+action_293 (75) = happyGoto action_400+action_293 (76) = happyGoto action_401+action_293 (77) = happyGoto action_237+action_293 (78) = happyGoto action_238+action_293 (79) = happyGoto action_239+action_293 (80) = happyGoto action_240+action_293 (86) = happyGoto action_402+action_293 (94) = happyGoto action_403+action_293 (95) = happyGoto action_404+action_293 (111) = happyGoto action_241+action_293 (113) = happyGoto action_242+action_293 (115) = happyGoto action_243+action_293 (122) = happyGoto action_28+action_293 (123) = happyGoto action_29+action_293 (124) = happyGoto action_30+action_293 (126) = happyGoto action_31+action_293 (132) = happyGoto action_244+action_293 (133) = happyGoto action_33+action_293 _ = happyFail++action_294 (199) = happyShift action_399+action_294 _ = happyFail++action_295 _ = happyReduce_192++action_296 (175) = happyShift action_398+action_296 _ = happyFail++action_297 (165) = happyShift action_395+action_297 (169) = happyShift action_396+action_297 (173) = happyShift action_397+action_297 _ = happyReduce_197++action_298 (164) = happyShift action_394+action_298 _ = happyFail++action_299 (165) = happyShift action_393+action_299 _ = happyReduce_198++action_300 _ = happyReduce_265++action_301 (158) = happyShift action_391+action_301 (165) = happyShift action_392+action_301 _ = happyFail++action_302 (147) = happyShift action_117+action_302 (148) = happyShift action_99+action_302 (149) = happyShift action_100+action_302 (150) = happyShift action_101+action_302 (151) = happyShift action_102+action_302 (167) = happyShift action_118+action_302 (168) = happyShift action_104+action_302 (170) = happyShift action_318+action_302 (179) = happyShift action_105+action_302 (117) = happyGoto action_305+action_302 (119) = happyGoto action_306+action_302 (121) = happyGoto action_390+action_302 (127) = happyGoto action_114+action_302 (128) = happyGoto action_94+action_302 (129) = happyGoto action_115+action_302 (130) = happyGoto action_96+action_302 (131) = happyGoto action_97+action_302 _ = happyReduce_168++action_303 (158) = happyShift action_389+action_303 (165) = happyShift action_208+action_303 _ = happyFail++action_304 (158) = happyShift action_387+action_304 (165) = happyShift action_388+action_304 _ = happyFail++action_305 _ = happyReduce_289++action_306 _ = happyReduce_290++action_307 (143) = happyShift action_34+action_307 (144) = happyShift action_35+action_307 (145) = happyShift action_36+action_307 (146) = happyShift action_37+action_307 (147) = happyShift action_245+action_307 (152) = happyShift action_246+action_307 (153) = happyShift action_39+action_307 (154) = happyShift action_40+action_307 (155) = happyShift action_41+action_307 (156) = happyShift action_42+action_307 (157) = happyShift action_247+action_307 (163) = happyShift action_248+action_307 (166) = happyShift action_249+action_307 (172) = happyShift action_250+action_307 (177) = happyShift action_251+action_307 (180) = happyShift action_47+action_307 (181) = happyShift action_252+action_307 (186) = happyShift action_253+action_307 (188) = happyShift action_51+action_307 (189) = happyShift action_254+action_307 (196) = happyShift action_255+action_307 (203) = happyShift action_59+action_307 (76) = happyGoto action_386+action_307 (77) = happyGoto action_237+action_307 (78) = happyGoto action_238+action_307 (79) = happyGoto action_239+action_307 (80) = happyGoto action_240+action_307 (111) = happyGoto action_241+action_307 (113) = happyGoto action_242+action_307 (115) = happyGoto action_243+action_307 (122) = happyGoto action_28+action_307 (123) = happyGoto action_29+action_307 (124) = happyGoto action_30+action_307 (126) = happyGoto action_31+action_307 (132) = happyGoto action_244+action_307 (133) = happyGoto action_33+action_307 _ = happyFail++action_308 (158) = happyShift action_167+action_308 _ = happyReduce_285++action_309 (158) = happyShift action_166+action_309 _ = happyReduce_281++action_310 (143) = happyShift action_34+action_310 (144) = happyShift action_35+action_310 (145) = happyShift action_36+action_310 (146) = happyShift action_37+action_310 (152) = happyShift action_246+action_310 (153) = happyShift action_39+action_310 (154) = happyShift action_40+action_310 (155) = happyShift action_41+action_310 (156) = happyShift action_42+action_310 (157) = happyShift action_247+action_310 (163) = happyShift action_248+action_310 (166) = happyShift action_249+action_310 (177) = happyShift action_251+action_310 (180) = happyShift action_47+action_310 (188) = happyShift action_51+action_310 (203) = happyShift action_59+action_310 (78) = happyGoto action_313+action_310 (79) = happyGoto action_239+action_310 (80) = happyGoto action_240+action_310 (111) = happyGoto action_241+action_310 (113) = happyGoto action_242+action_310 (115) = happyGoto action_243+action_310 (122) = happyGoto action_28+action_310 (123) = happyGoto action_29+action_310 (124) = happyGoto action_30+action_310 (126) = happyGoto action_31+action_310 (132) = happyGoto action_244+action_310 (133) = happyGoto action_33+action_310 _ = happyReduce_308++action_311 _ = happyReduce_264++action_312 (157) = happyShift action_384+action_312 (163) = happyShift action_385+action_312 _ = happyFail++action_313 (143) = happyShift action_34+action_313 (144) = happyShift action_35+action_313 (145) = happyShift action_36+action_313 (146) = happyShift action_37+action_313 (152) = happyShift action_246+action_313 (153) = happyShift action_39+action_313 (154) = happyShift action_40+action_313 (155) = happyShift action_41+action_313 (156) = happyShift action_42+action_313 (157) = happyShift action_247+action_313 (163) = happyShift action_248+action_313 (166) = happyShift action_249+action_313 (177) = happyShift action_251+action_313 (180) = happyShift action_47+action_313 (188) = happyShift action_51+action_313 (203) = happyShift action_59+action_313 (79) = happyGoto action_316+action_313 (80) = happyGoto action_240+action_313 (111) = happyGoto action_241+action_313 (113) = happyGoto action_242+action_313 (115) = happyGoto action_243+action_313 (122) = happyGoto action_28+action_313 (123) = happyGoto action_29+action_313 (124) = happyGoto action_30+action_313 (126) = happyGoto action_31+action_313 (132) = happyGoto action_244+action_313 (133) = happyGoto action_33+action_313 _ = happyReduce_175++action_314 (143) = happyShift action_34+action_314 (144) = happyShift action_35+action_314 (145) = happyShift action_36+action_314 (146) = happyShift action_37+action_314 (152) = happyShift action_246+action_314 (153) = happyShift action_39+action_314 (154) = happyShift action_40+action_314 (155) = happyShift action_41+action_314 (156) = happyShift action_42+action_314 (157) = happyShift action_247+action_314 (163) = happyShift action_248+action_314 (166) = happyShift action_249+action_314 (177) = happyShift action_251+action_314 (180) = happyShift action_47+action_314 (188) = happyShift action_51+action_314 (203) = happyShift action_59+action_314 (80) = happyGoto action_383+action_314 (111) = happyGoto action_241+action_314 (113) = happyGoto action_242+action_314 (115) = happyGoto action_243+action_314 (122) = happyGoto action_28+action_314 (123) = happyGoto action_29+action_314 (124) = happyGoto action_30+action_314 (126) = happyGoto action_31+action_314 (132) = happyGoto action_244+action_314 (133) = happyGoto action_33+action_314 _ = happyFail++action_315 (143) = happyShift action_34+action_315 (144) = happyShift action_35+action_315 (157) = happyShift action_136+action_315 (180) = happyShift action_47+action_315 (188) = happyShift action_51+action_315 (203) = happyShift action_59+action_315 (96) = happyGoto action_379+action_315 (97) = happyGoto action_380+action_315 (98) = happyGoto action_381+action_315 (113) = happyGoto action_382+action_315 (122) = happyGoto action_28+action_315 (123) = happyGoto action_29+action_315 _ = happyReduce_228++action_316 (160) = happyShift action_315+action_316 _ = happyReduce_178++action_317 (143) = happyShift action_34+action_317 (144) = happyShift action_35+action_317 (145) = happyShift action_36+action_317 (146) = happyShift action_37+action_317 (147) = happyShift action_245+action_317 (152) = happyShift action_246+action_317 (153) = happyShift action_39+action_317 (154) = happyShift action_40+action_317 (155) = happyShift action_41+action_317 (156) = happyShift action_42+action_317 (157) = happyShift action_247+action_317 (163) = happyShift action_248+action_317 (166) = happyShift action_249+action_317 (172) = happyShift action_250+action_317 (177) = happyShift action_251+action_317 (180) = happyShift action_47+action_317 (181) = happyShift action_252+action_317 (186) = happyShift action_253+action_317 (188) = happyShift action_51+action_317 (189) = happyShift action_254+action_317 (196) = happyShift action_255+action_317 (203) = happyShift action_59+action_317 (77) = happyGoto action_378+action_317 (78) = happyGoto action_238+action_317 (79) = happyGoto action_239+action_317 (80) = happyGoto action_240+action_317 (111) = happyGoto action_241+action_317 (113) = happyGoto action_242+action_317 (115) = happyGoto action_243+action_317 (122) = happyGoto action_28+action_317 (123) = happyGoto action_29+action_317 (124) = happyGoto action_30+action_317 (126) = happyGoto action_31+action_317 (132) = happyGoto action_244+action_317 (133) = happyGoto action_33+action_317 _ = happyFail++action_318 (134) = happyGoto action_377+action_318 _ = happyReduce_317++action_319 (171) = happyShift action_376+action_319 _ = happyFail++action_320 _ = happyReduce_160++action_321 _ = happyReduce_255++action_322 _ = happyReduce_257++action_323 _ = happyReduce_105++action_324 _ = happyReduce_91++action_325 _ = happyReduce_73++action_326 (165) = happyShift action_375+action_326 _ = happyReduce_74++action_327 (175) = happyShift action_374+action_327 _ = happyFail++action_328 (143) = happyShift action_34+action_328 (180) = happyShift action_47+action_328 (188) = happyShift action_51+action_328 (203) = happyShift action_59+action_328 (123) = happyGoto action_180+action_328 (142) = happyGoto action_204+action_328 _ = happyReduce_78++action_329 _ = happyReduce_66++action_330 (160) = happyShift action_373+action_330 (135) = happyGoto action_372+action_330 _ = happyReduce_318++action_331 _ = happyReduce_97++action_332 (143) = happyShift action_34+action_332 (145) = happyShift action_36+action_332 (146) = happyShift action_71+action_332 (157) = happyShift action_182+action_332 (163) = happyShift action_183+action_332 (180) = happyShift action_47+action_332 (188) = happyShift action_51+action_332 (203) = happyShift action_59+action_332 (42) = happyGoto action_371+action_332 (43) = happyGoto action_176+action_332 (44) = happyGoto action_177+action_332 (45) = happyGoto action_178+action_332 (123) = happyGoto action_180+action_332 (125) = happyGoto action_68+action_332 (126) = happyGoto action_69+action_332 (139) = happyGoto action_70+action_332 (142) = happyGoto action_181+action_332 _ = happyFail++action_333 _ = happyReduce_99++action_334 (143) = happyShift action_34+action_334 (145) = happyShift action_36+action_334 (146) = happyShift action_71+action_334 (157) = happyShift action_182+action_334 (163) = happyShift action_183+action_334 (180) = happyShift action_47+action_334 (188) = happyShift action_51+action_334 (203) = happyShift action_59+action_334 (42) = happyGoto action_370+action_334 (43) = happyGoto action_176+action_334 (44) = happyGoto action_177+action_334 (45) = happyGoto action_178+action_334 (123) = happyGoto action_180+action_334 (125) = happyGoto action_68+action_334 (126) = happyGoto action_69+action_334 (139) = happyGoto action_70+action_334 (142) = happyGoto action_181+action_334 _ = happyFail++action_335 _ = happyReduce_98++action_336 _ = happyReduce_109++action_337 (173) = happyShift action_369+action_337 (185) = happyShift action_348+action_337 (61) = happyGoto action_368+action_337 _ = happyReduce_134++action_338 _ = happyReduce_117++action_339 (143) = happyShift action_34+action_339 (145) = happyShift action_36+action_339 (146) = happyShift action_71+action_339 (157) = happyShift action_366+action_339 (163) = happyShift action_183+action_339 (179) = happyShift action_367+action_339 (180) = happyShift action_47+action_339 (188) = happyShift action_51+action_339 (203) = happyShift action_59+action_339 (43) = happyGoto action_360+action_339 (44) = happyGoto action_177+action_339 (45) = happyGoto action_178+action_339 (54) = happyGoto action_361+action_339 (55) = happyGoto action_362+action_339 (57) = happyGoto action_363+action_339 (114) = happyGoto action_364+action_339 (123) = happyGoto action_180+action_339 (125) = happyGoto action_68+action_339 (126) = happyGoto action_365+action_339 (139) = happyGoto action_70+action_339 (142) = happyGoto action_181+action_339 _ = happyFail++action_340 (157) = happyShift action_358+action_340 (188) = happyShift action_359+action_340 (19) = happyGoto action_356+action_340 (20) = happyGoto action_357+action_340 _ = happyReduce_37++action_341 (145) = happyShift action_10+action_341 (137) = happyGoto action_355+action_341 _ = happyFail++action_342 (143) = happyShift action_34+action_342 (144) = happyShift action_35+action_342 (145) = happyShift action_36+action_342 (146) = happyShift action_37+action_342 (147) = happyShift action_38+action_342 (153) = happyShift action_39+action_342 (154) = happyShift action_40+action_342 (155) = happyShift action_41+action_342 (156) = happyShift action_42+action_342 (157) = happyShift action_43+action_342 (159) = happyShift action_353+action_342 (163) = happyShift action_44+action_342 (166) = happyShift action_45+action_342 (177) = happyShift action_46+action_342 (180) = happyShift action_47+action_342 (188) = happyShift action_51+action_342 (203) = happyShift action_59+action_342 (7) = happyGoto action_349+action_342 (66) = happyGoto action_350+action_342 (68) = happyGoto action_354+action_342 (69) = happyGoto action_352+action_342 (70) = happyGoto action_22+action_342 (100) = happyGoto action_23+action_342 (101) = happyGoto action_24+action_342 (102) = happyGoto action_25+action_342 (113) = happyGoto action_92+action_342 (115) = happyGoto action_27+action_342 (122) = happyGoto action_28+action_342 (123) = happyGoto action_29+action_342 (124) = happyGoto action_30+action_342 (126) = happyGoto action_31+action_342 (132) = happyGoto action_32+action_342 (133) = happyGoto action_33+action_342 _ = happyReduce_10++action_343 (143) = happyShift action_34+action_343 (144) = happyShift action_35+action_343 (145) = happyShift action_36+action_343 (146) = happyShift action_37+action_343 (147) = happyShift action_38+action_343 (153) = happyShift action_39+action_343 (154) = happyShift action_40+action_343 (155) = happyShift action_41+action_343 (156) = happyShift action_42+action_343 (157) = happyShift action_43+action_343 (159) = happyShift action_353+action_343 (163) = happyShift action_44+action_343 (166) = happyShift action_45+action_343 (177) = happyShift action_46+action_343 (180) = happyShift action_47+action_343 (188) = happyShift action_51+action_343 (203) = happyShift action_59+action_343 (7) = happyGoto action_349+action_343 (66) = happyGoto action_350+action_343 (68) = happyGoto action_351+action_343 (69) = happyGoto action_352+action_343 (70) = happyGoto action_22+action_343 (100) = happyGoto action_23+action_343 (101) = happyGoto action_24+action_343 (102) = happyGoto action_25+action_343 (113) = happyGoto action_92+action_343 (115) = happyGoto action_27+action_343 (122) = happyGoto action_28+action_343 (123) = happyGoto action_29+action_343 (124) = happyGoto action_30+action_343 (126) = happyGoto action_31+action_343 (132) = happyGoto action_32+action_343 (133) = happyGoto action_33+action_343 _ = happyReduce_10++action_344 (185) = happyShift action_348+action_344 (61) = happyGoto action_347+action_344 _ = happyReduce_134++action_345 _ = happyReduce_63++action_346 _ = happyReduce_70++action_347 _ = happyReduce_65++action_348 (145) = happyShift action_36+action_348 (146) = happyShift action_71+action_348 (157) = happyShift action_487+action_348 (125) = happyGoto action_485+action_348 (126) = happyGoto action_69+action_348 (139) = happyGoto action_70+action_348 (141) = happyGoto action_486+action_348 _ = happyFail++action_349 _ = happyReduce_154++action_350 (159) = happyShift action_484+action_350 (7) = happyGoto action_483+action_350 _ = happyReduce_10++action_351 (161) = happyShift action_482+action_351 _ = happyFail++action_352 _ = happyReduce_149++action_353 _ = happyReduce_9++action_354 (1) = happyShift action_63+action_354 (162) = happyShift action_64+action_354 (136) = happyGoto action_481+action_354 _ = happyFail++action_355 _ = happyReduce_34++action_356 _ = happyReduce_31++action_357 _ = happyReduce_36++action_358 (143) = happyShift action_34+action_358 (145) = happyShift action_36+action_358 (157) = happyShift action_147+action_358 (165) = happyShift action_480+action_358 (180) = happyShift action_47+action_358 (188) = happyShift action_51+action_358 (203) = happyShift action_59+action_358 (10) = happyGoto action_473+action_358 (21) = happyGoto action_474+action_358 (22) = happyGoto action_475+action_358 (23) = happyGoto action_476+action_358 (112) = happyGoto action_477+action_358 (123) = happyGoto action_146+action_358 (126) = happyGoto action_478+action_358 (138) = happyGoto action_479+action_358 _ = happyReduce_16++action_359 (157) = happyShift action_472+action_359 _ = happyFail++action_360 (143) = happyShift action_34+action_360 (145) = happyShift action_36+action_360 (146) = happyShift action_71+action_360 (149) = happyReduce_127+action_360 (157) = happyShift action_182+action_360 (163) = happyShift action_183+action_360 (167) = happyReduce_127+action_360 (179) = happyShift action_471+action_360 (180) = happyShift action_47+action_360 (188) = happyShift action_51+action_360 (203) = happyShift action_59+action_360 (44) = happyGoto action_220+action_360 (45) = happyGoto action_178+action_360 (123) = happyGoto action_180+action_360 (125) = happyGoto action_68+action_360 (126) = happyGoto action_69+action_360 (139) = happyGoto action_70+action_360 (142) = happyGoto action_181+action_360 _ = happyReduce_121++action_361 _ = happyReduce_118++action_362 (143) = happyShift action_34+action_362 (145) = happyShift action_36+action_362 (146) = happyShift action_71+action_362 (157) = happyShift action_182+action_362 (163) = happyShift action_183+action_362 (179) = happyShift action_470+action_362 (180) = happyShift action_47+action_362 (188) = happyShift action_51+action_362 (203) = happyShift action_59+action_362 (44) = happyGoto action_468+action_362 (45) = happyGoto action_178+action_362 (56) = happyGoto action_469+action_362 (123) = happyGoto action_180+action_362 (125) = happyGoto action_68+action_362 (126) = happyGoto action_69+action_362 (139) = happyGoto action_70+action_362 (142) = happyGoto action_181+action_362 _ = happyReduce_122++action_363 (149) = happyShift action_100+action_363 (167) = happyShift action_467+action_363 (118) = happyGoto action_466+action_363 (128) = happyGoto action_265+action_363 _ = happyFail++action_364 (160) = happyShift action_465+action_364 _ = happyFail++action_365 (160) = happyReduce_275+action_365 _ = happyReduce_323++action_366 (143) = happyShift action_34+action_366 (145) = happyShift action_36+action_366 (146) = happyShift action_71+action_366 (149) = happyShift action_100+action_366 (157) = happyShift action_182+action_366 (158) = happyShift action_196+action_366 (163) = happyShift action_183+action_366 (165) = happyShift action_197+action_366 (175) = happyShift action_198+action_366 (180) = happyShift action_47+action_366 (188) = happyShift action_51+action_366 (203) = happyShift action_59+action_366 (42) = happyGoto action_216+action_366 (43) = happyGoto action_176+action_366 (44) = happyGoto action_177+action_366 (45) = happyGoto action_178+action_366 (47) = happyGoto action_217+action_366 (81) = happyGoto action_195+action_366 (123) = happyGoto action_180+action_366 (125) = happyGoto action_68+action_366 (126) = happyGoto action_69+action_366 (128) = happyGoto action_464+action_366 (139) = happyGoto action_70+action_366 (142) = happyGoto action_181+action_366 _ = happyFail++action_367 (143) = happyShift action_34+action_367 (145) = happyShift action_36+action_367 (146) = happyShift action_71+action_367 (157) = happyShift action_182+action_367 (163) = happyShift action_183+action_367 (180) = happyShift action_47+action_367 (188) = happyShift action_51+action_367 (203) = happyShift action_59+action_367 (44) = happyGoto action_463+action_367 (45) = happyGoto action_178+action_367 (123) = happyGoto action_180+action_367 (125) = happyGoto action_68+action_367 (126) = happyGoto action_69+action_367 (139) = happyGoto action_70+action_367 (142) = happyGoto action_181+action_367 _ = happyFail++action_368 _ = happyReduce_64++action_369 (53) = happyGoto action_462+action_369 (134) = happyGoto action_339+action_369 _ = happyReduce_317++action_370 _ = happyReduce_108++action_371 _ = happyReduce_107++action_372 (143) = happyShift action_34+action_372 (144) = happyShift action_35+action_372 (157) = happyShift action_136+action_372 (159) = happyShift action_353+action_372 (180) = happyShift action_47+action_372 (188) = happyShift action_51+action_372 (203) = happyShift action_59+action_372 (7) = happyGoto action_456+action_372 (40) = happyGoto action_457+action_372 (41) = happyGoto action_20+action_372 (64) = happyGoto action_461+action_372 (65) = happyGoto action_459+action_372 (113) = happyGoto action_460+action_372 (122) = happyGoto action_28+action_372 (123) = happyGoto action_29+action_372 _ = happyReduce_10++action_373 (143) = happyShift action_34+action_373 (144) = happyShift action_35+action_373 (157) = happyShift action_136+action_373 (159) = happyShift action_353+action_373 (180) = happyShift action_47+action_373 (188) = happyShift action_51+action_373 (203) = happyShift action_59+action_373 (7) = happyGoto action_456+action_373 (40) = happyGoto action_457+action_373 (41) = happyGoto action_20+action_373 (64) = happyGoto action_458+action_373 (65) = happyGoto action_459+action_373 (113) = happyGoto action_460+action_373 (122) = happyGoto action_28+action_373 (123) = happyGoto action_29+action_373 _ = happyReduce_10++action_374 (143) = happyShift action_34+action_374 (180) = happyShift action_47+action_374 (188) = happyShift action_51+action_374 (203) = happyShift action_59+action_374 (35) = happyGoto action_455+action_374 (50) = happyGoto action_328+action_374 (123) = happyGoto action_180+action_374 (142) = happyGoto action_201+action_374 _ = happyReduce_77++action_375 (143) = happyShift action_34+action_375 (180) = happyShift action_47+action_375 (188) = happyShift action_51+action_375 (203) = happyShift action_59+action_375 (33) = happyGoto action_454+action_375 (34) = happyGoto action_326+action_375 (35) = happyGoto action_327+action_375 (50) = happyGoto action_328+action_375 (123) = happyGoto action_180+action_375 (142) = happyGoto action_201+action_375 _ = happyReduce_77++action_376 (143) = happyShift action_34+action_376 (144) = happyShift action_35+action_376 (145) = happyShift action_36+action_376 (146) = happyShift action_37+action_376 (147) = happyShift action_245+action_376 (152) = happyShift action_246+action_376 (153) = happyShift action_39+action_376 (154) = happyShift action_40+action_376 (155) = happyShift action_41+action_376 (156) = happyShift action_42+action_376 (157) = happyShift action_247+action_376 (163) = happyShift action_248+action_376 (166) = happyShift action_249+action_376 (172) = happyShift action_250+action_376 (177) = happyShift action_251+action_376 (180) = happyShift action_47+action_376 (181) = happyShift action_252+action_376 (186) = happyShift action_253+action_376 (188) = happyShift action_51+action_376 (189) = happyShift action_254+action_376 (196) = happyShift action_255+action_376 (203) = happyShift action_59+action_376 (75) = happyGoto action_453+action_376 (76) = happyGoto action_236+action_376 (77) = happyGoto action_237+action_376 (78) = happyGoto action_238+action_376 (79) = happyGoto action_239+action_376 (80) = happyGoto action_240+action_376 (111) = happyGoto action_241+action_376 (113) = happyGoto action_242+action_376 (115) = happyGoto action_243+action_376 (122) = happyGoto action_28+action_376 (123) = happyGoto action_29+action_376 (124) = happyGoto action_30+action_376 (126) = happyGoto action_31+action_376 (132) = happyGoto action_244+action_376 (133) = happyGoto action_33+action_376 _ = happyFail++action_377 (143) = happyShift action_34+action_377 (145) = happyShift action_36+action_377 (146) = happyShift action_71+action_377 (157) = happyShift action_182+action_377 (163) = happyShift action_183+action_377 (180) = happyShift action_47+action_377 (188) = happyShift action_51+action_377 (203) = happyShift action_59+action_377 (42) = happyGoto action_175+action_377 (43) = happyGoto action_176+action_377 (44) = happyGoto action_177+action_377 (45) = happyGoto action_178+action_377 (46) = happyGoto action_452+action_377 (123) = happyGoto action_180+action_377 (125) = happyGoto action_68+action_377 (126) = happyGoto action_69+action_377 (139) = happyGoto action_70+action_377 (142) = happyGoto action_181+action_377 _ = happyFail++action_378 _ = happyReduce_170++action_379 (161) = happyShift action_451+action_379 _ = happyFail++action_380 (165) = happyShift action_450+action_380 _ = happyReduce_229++action_381 _ = happyReduce_231++action_382 (171) = happyShift action_449+action_382 _ = happyFail++action_383 _ = happyReduce_190++action_384 (158) = happyShift action_448+action_384 (165) = happyShift action_197+action_384 (81) = happyGoto action_447+action_384 _ = happyFail++action_385 (164) = happyShift action_446+action_385 _ = happyFail++action_386 (147) = happyShift action_117+action_386 (148) = happyShift action_99+action_386 (149) = happyShift action_100+action_386 (150) = happyShift action_101+action_386 (151) = happyShift action_102+action_386 (158) = happyShift action_445+action_386 (167) = happyShift action_118+action_386 (168) = happyShift action_104+action_386 (179) = happyShift action_105+action_386 (117) = happyGoto action_305+action_386 (119) = happyGoto action_306+action_386 (121) = happyGoto action_317+action_386 (127) = happyGoto action_114+action_386 (128) = happyGoto action_94+action_386 (129) = happyGoto action_115+action_386 (130) = happyGoto action_96+action_386 (131) = happyGoto action_97+action_386 _ = happyFail++action_387 _ = happyReduce_186++action_388 (143) = happyShift action_34+action_388 (144) = happyShift action_35+action_388 (145) = happyShift action_36+action_388 (146) = happyShift action_37+action_388 (147) = happyShift action_245+action_388 (152) = happyShift action_246+action_388 (153) = happyShift action_39+action_388 (154) = happyShift action_40+action_388 (155) = happyShift action_41+action_388 (156) = happyShift action_42+action_388 (157) = happyShift action_247+action_388 (163) = happyShift action_248+action_388 (166) = happyShift action_249+action_388 (172) = happyShift action_250+action_388 (177) = happyShift action_251+action_388 (180) = happyShift action_47+action_388 (181) = happyShift action_252+action_388 (186) = happyShift action_253+action_388 (188) = happyShift action_51+action_388 (189) = happyShift action_254+action_388 (196) = happyShift action_255+action_388 (203) = happyShift action_59+action_388 (75) = happyGoto action_444+action_388 (76) = happyGoto action_236+action_388 (77) = happyGoto action_237+action_388 (78) = happyGoto action_238+action_388 (79) = happyGoto action_239+action_388 (80) = happyGoto action_240+action_388 (111) = happyGoto action_241+action_388 (113) = happyGoto action_242+action_388 (115) = happyGoto action_243+action_388 (122) = happyGoto action_28+action_388 (123) = happyGoto action_29+action_388 (124) = happyGoto action_30+action_388 (126) = happyGoto action_31+action_388 (132) = happyGoto action_244+action_388 (133) = happyGoto action_33+action_388 _ = happyFail++action_389 _ = happyReduce_266++action_390 (143) = happyShift action_34+action_390 (144) = happyShift action_35+action_390 (145) = happyShift action_36+action_390 (146) = happyShift action_37+action_390 (147) = happyShift action_245+action_390 (152) = happyShift action_246+action_390 (153) = happyShift action_39+action_390 (154) = happyShift action_40+action_390 (155) = happyShift action_41+action_390 (156) = happyShift action_42+action_390 (157) = happyShift action_247+action_390 (158) = happyShift action_443+action_390 (163) = happyShift action_248+action_390 (166) = happyShift action_249+action_390 (172) = happyShift action_250+action_390 (177) = happyShift action_251+action_390 (180) = happyShift action_47+action_390 (181) = happyShift action_252+action_390 (186) = happyShift action_253+action_390 (188) = happyShift action_51+action_390 (189) = happyShift action_254+action_390 (196) = happyShift action_255+action_390 (203) = happyShift action_59+action_390 (77) = happyGoto action_378+action_390 (78) = happyGoto action_238+action_390 (79) = happyGoto action_239+action_390 (80) = happyGoto action_240+action_390 (111) = happyGoto action_241+action_390 (113) = happyGoto action_242+action_390 (115) = happyGoto action_243+action_390 (122) = happyGoto action_28+action_390 (123) = happyGoto action_29+action_390 (124) = happyGoto action_30+action_390 (126) = happyGoto action_31+action_390 (132) = happyGoto action_244+action_390 (133) = happyGoto action_33+action_390 _ = happyFail++action_391 _ = happyReduce_185++action_392 (143) = happyShift action_34+action_392 (144) = happyShift action_35+action_392 (145) = happyShift action_36+action_392 (146) = happyShift action_37+action_392 (147) = happyShift action_245+action_392 (152) = happyShift action_246+action_392 (153) = happyShift action_39+action_392 (154) = happyShift action_40+action_392 (155) = happyShift action_41+action_392 (156) = happyShift action_42+action_392 (157) = happyShift action_247+action_392 (163) = happyShift action_248+action_392 (166) = happyShift action_249+action_392 (172) = happyShift action_250+action_392 (177) = happyShift action_251+action_392 (180) = happyShift action_47+action_392 (181) = happyShift action_252+action_392 (186) = happyShift action_253+action_392 (188) = happyShift action_51+action_392 (189) = happyShift action_254+action_392 (196) = happyShift action_255+action_392 (203) = happyShift action_59+action_392 (75) = happyGoto action_442+action_392 (76) = happyGoto action_236+action_392 (77) = happyGoto action_237+action_392 (78) = happyGoto action_238+action_392 (79) = happyGoto action_239+action_392 (80) = happyGoto action_240+action_392 (111) = happyGoto action_241+action_392 (113) = happyGoto action_242+action_392 (115) = happyGoto action_243+action_392 (122) = happyGoto action_28+action_392 (123) = happyGoto action_29+action_392 (124) = happyGoto action_30+action_392 (126) = happyGoto action_31+action_392 (132) = happyGoto action_244+action_392 (133) = happyGoto action_33+action_392 _ = happyFail++action_393 (143) = happyShift action_34+action_393 (144) = happyShift action_35+action_393 (145) = happyShift action_36+action_393 (146) = happyShift action_37+action_393 (147) = happyShift action_245+action_393 (152) = happyShift action_246+action_393 (153) = happyShift action_39+action_393 (154) = happyShift action_40+action_393 (155) = happyShift action_41+action_393 (156) = happyShift action_42+action_393 (157) = happyShift action_247+action_393 (163) = happyShift action_248+action_393 (166) = happyShift action_249+action_393 (172) = happyShift action_250+action_393 (177) = happyShift action_251+action_393 (180) = happyShift action_47+action_393 (181) = happyShift action_252+action_393 (186) = happyShift action_253+action_393 (188) = happyShift action_51+action_393 (189) = happyShift action_254+action_393 (196) = happyShift action_255+action_393 (203) = happyShift action_59+action_393 (75) = happyGoto action_441+action_393 (76) = happyGoto action_236+action_393 (77) = happyGoto action_237+action_393 (78) = happyGoto action_238+action_393 (79) = happyGoto action_239+action_393 (80) = happyGoto action_240+action_393 (111) = happyGoto action_241+action_393 (113) = happyGoto action_242+action_393 (115) = happyGoto action_243+action_393 (122) = happyGoto action_28+action_393 (123) = happyGoto action_29+action_393 (124) = happyGoto action_30+action_393 (126) = happyGoto action_31+action_393 (132) = happyGoto action_244+action_393 (133) = happyGoto action_33+action_393 _ = happyFail++action_394 _ = happyReduce_187++action_395 (143) = happyShift action_34+action_395 (144) = happyShift action_35+action_395 (145) = happyShift action_36+action_395 (146) = happyShift action_37+action_395 (147) = happyShift action_245+action_395 (152) = happyShift action_246+action_395 (153) = happyShift action_39+action_395 (154) = happyShift action_40+action_395 (155) = happyShift action_41+action_395 (156) = happyShift action_42+action_395 (157) = happyShift action_247+action_395 (163) = happyShift action_248+action_395 (166) = happyShift action_249+action_395 (172) = happyShift action_250+action_395 (177) = happyShift action_251+action_395 (180) = happyShift action_47+action_395 (181) = happyShift action_252+action_395 (186) = happyShift action_253+action_395 (188) = happyShift action_51+action_395 (189) = happyShift action_254+action_395 (196) = happyShift action_255+action_395 (203) = happyShift action_59+action_395 (75) = happyGoto action_440+action_395 (76) = happyGoto action_236+action_395 (77) = happyGoto action_237+action_395 (78) = happyGoto action_238+action_395 (79) = happyGoto action_239+action_395 (80) = happyGoto action_240+action_395 (111) = happyGoto action_241+action_395 (113) = happyGoto action_242+action_395 (115) = happyGoto action_243+action_395 (122) = happyGoto action_28+action_395 (123) = happyGoto action_29+action_395 (124) = happyGoto action_30+action_395 (126) = happyGoto action_31+action_395 (132) = happyGoto action_244+action_395 (133) = happyGoto action_33+action_395 _ = happyFail++action_396 (143) = happyShift action_34+action_396 (144) = happyShift action_35+action_396 (145) = happyShift action_36+action_396 (146) = happyShift action_37+action_396 (147) = happyShift action_245+action_396 (152) = happyShift action_246+action_396 (153) = happyShift action_39+action_396 (154) = happyShift action_40+action_396 (155) = happyShift action_41+action_396 (156) = happyShift action_42+action_396 (157) = happyShift action_247+action_396 (163) = happyShift action_248+action_396 (166) = happyShift action_249+action_396 (172) = happyShift action_250+action_396 (177) = happyShift action_251+action_396 (180) = happyShift action_47+action_396 (181) = happyShift action_252+action_396 (186) = happyShift action_253+action_396 (188) = happyShift action_51+action_396 (189) = happyShift action_254+action_396 (196) = happyShift action_255+action_396 (203) = happyShift action_59+action_396 (75) = happyGoto action_439+action_396 (76) = happyGoto action_236+action_396 (77) = happyGoto action_237+action_396 (78) = happyGoto action_238+action_396 (79) = happyGoto action_239+action_396 (80) = happyGoto action_240+action_396 (111) = happyGoto action_241+action_396 (113) = happyGoto action_242+action_396 (115) = happyGoto action_243+action_396 (122) = happyGoto action_28+action_396 (123) = happyGoto action_29+action_396 (124) = happyGoto action_30+action_396 (126) = happyGoto action_31+action_396 (132) = happyGoto action_244+action_396 (133) = happyGoto action_33+action_396 _ = happyReduce_199++action_397 (143) = happyShift action_34+action_397 (144) = happyShift action_35+action_397 (145) = happyShift action_36+action_397 (146) = happyShift action_37+action_397 (147) = happyShift action_245+action_397 (152) = happyShift action_246+action_397 (153) = happyShift action_39+action_397 (154) = happyShift action_40+action_397 (155) = happyShift action_41+action_397 (156) = happyShift action_42+action_397 (157) = happyShift action_247+action_397 (163) = happyShift action_248+action_397 (166) = happyShift action_249+action_397 (172) = happyShift action_250+action_397 (177) = happyShift action_251+action_397 (180) = happyShift action_47+action_397 (181) = happyShift action_252+action_397 (186) = happyShift action_253+action_397 (188) = happyShift action_51+action_397 (189) = happyShift action_254+action_397 (196) = happyShift action_405+action_397 (203) = happyShift action_59+action_397 (75) = happyGoto action_436+action_397 (76) = happyGoto action_401+action_397 (77) = happyGoto action_237+action_397 (78) = happyGoto action_238+action_397 (79) = happyGoto action_239+action_397 (80) = happyGoto action_240+action_397 (85) = happyGoto action_437+action_397 (86) = happyGoto action_438+action_397 (111) = happyGoto action_241+action_397 (113) = happyGoto action_242+action_397 (115) = happyGoto action_243+action_397 (122) = happyGoto action_28+action_397 (123) = happyGoto action_29+action_397 (124) = happyGoto action_30+action_397 (126) = happyGoto action_31+action_397 (132) = happyGoto action_244+action_397 (133) = happyGoto action_33+action_397 _ = happyFail++action_398 (143) = happyShift action_34+action_398 (144) = happyShift action_35+action_398 (145) = happyShift action_36+action_398 (146) = happyShift action_37+action_398 (147) = happyShift action_245+action_398 (152) = happyShift action_246+action_398 (153) = happyShift action_39+action_398 (154) = happyShift action_40+action_398 (155) = happyShift action_41+action_398 (156) = happyShift action_42+action_398 (157) = happyShift action_247+action_398 (163) = happyShift action_248+action_398 (166) = happyShift action_249+action_398 (172) = happyShift action_250+action_398 (177) = happyShift action_251+action_398 (180) = happyShift action_47+action_398 (181) = happyShift action_252+action_398 (186) = happyShift action_253+action_398 (188) = happyShift action_51+action_398 (189) = happyShift action_254+action_398 (196) = happyShift action_255+action_398 (203) = happyShift action_59+action_398 (75) = happyGoto action_435+action_398 (76) = happyGoto action_236+action_398 (77) = happyGoto action_237+action_398 (78) = happyGoto action_238+action_398 (79) = happyGoto action_239+action_398 (80) = happyGoto action_240+action_398 (111) = happyGoto action_241+action_398 (113) = happyGoto action_242+action_398 (115) = happyGoto action_243+action_398 (122) = happyGoto action_28+action_398 (123) = happyGoto action_29+action_398 (124) = happyGoto action_30+action_398 (126) = happyGoto action_31+action_398 (132) = happyGoto action_244+action_398 (133) = happyGoto action_33+action_398 _ = happyFail++action_399 (160) = happyShift action_434+action_399 (87) = happyGoto action_432+action_399 (135) = happyGoto action_433+action_399 _ = happyReduce_318++action_400 (159) = happyReduce_209+action_400 _ = happyReduce_225++action_401 (147) = happyShift action_117+action_401 (148) = happyShift action_99+action_401 (149) = happyShift action_100+action_401 (150) = happyShift action_101+action_401 (151) = happyShift action_102+action_401 (167) = happyShift action_118+action_401 (168) = happyShift action_104+action_401 (170) = happyShift action_318+action_401 (174) = happyShift action_431+action_401 (179) = happyShift action_105+action_401 (117) = happyGoto action_305+action_401 (119) = happyGoto action_306+action_401 (121) = happyGoto action_317+action_401 (127) = happyGoto action_114+action_401 (128) = happyGoto action_94+action_401 (129) = happyGoto action_115+action_401 (130) = happyGoto action_96+action_401 (131) = happyGoto action_97+action_401 _ = happyReduce_168++action_402 _ = happyReduce_227++action_403 (161) = happyShift action_430+action_403 _ = happyFail++action_404 (159) = happyShift action_429+action_404 _ = happyFail++action_405 (160) = happyShift action_289+action_405 (39) = happyGoto action_428+action_405 (135) = happyGoto action_288+action_405 _ = happyReduce_318++action_406 (1) = happyShift action_63+action_406 (162) = happyShift action_64+action_406 (136) = happyGoto action_427+action_406 _ = happyFail++action_407 (143) = happyShift action_34+action_407 (144) = happyShift action_35+action_407 (145) = happyShift action_36+action_407 (146) = happyShift action_37+action_407 (147) = happyShift action_245+action_407 (152) = happyShift action_246+action_407 (153) = happyShift action_39+action_407 (154) = happyShift action_40+action_407 (155) = happyShift action_41+action_407 (156) = happyShift action_42+action_407 (157) = happyShift action_247+action_407 (163) = happyShift action_248+action_407 (166) = happyShift action_249+action_407 (172) = happyShift action_250+action_407 (177) = happyShift action_251+action_407 (180) = happyShift action_47+action_407 (181) = happyShift action_252+action_407 (186) = happyShift action_253+action_407 (188) = happyShift action_51+action_407 (189) = happyShift action_254+action_407 (196) = happyShift action_255+action_407 (203) = happyShift action_59+action_407 (75) = happyGoto action_426+action_407 (76) = happyGoto action_236+action_407 (77) = happyGoto action_237+action_407 (78) = happyGoto action_238+action_407 (79) = happyGoto action_239+action_407 (80) = happyGoto action_240+action_407 (111) = happyGoto action_241+action_407 (113) = happyGoto action_242+action_407 (115) = happyGoto action_243+action_407 (122) = happyGoto action_28+action_407 (123) = happyGoto action_29+action_407 (124) = happyGoto action_30+action_407 (126) = happyGoto action_31+action_407 (132) = happyGoto action_244+action_407 (133) = happyGoto action_33+action_407 _ = happyFail++action_408 _ = happyReduce_80++action_409 (161) = happyShift action_425+action_409 _ = happyFail++action_410 (159) = happyShift action_424+action_410 (7) = happyGoto action_423+action_410 _ = happyReduce_10++action_411 _ = happyReduce_82++action_412 (1) = happyShift action_63+action_412 (162) = happyShift action_64+action_412 (136) = happyGoto action_422+action_412 _ = happyFail++action_413 (143) = happyShift action_34+action_413 (144) = happyShift action_35+action_413 (145) = happyShift action_36+action_413 (146) = happyShift action_37+action_413 (147) = happyShift action_245+action_413 (152) = happyShift action_246+action_413 (153) = happyShift action_39+action_413 (154) = happyShift action_40+action_413 (155) = happyShift action_41+action_413 (156) = happyShift action_42+action_413 (157) = happyShift action_247+action_413 (163) = happyShift action_248+action_413 (166) = happyShift action_249+action_413 (172) = happyShift action_250+action_413 (177) = happyShift action_251+action_413 (180) = happyShift action_47+action_413 (181) = happyShift action_252+action_413 (186) = happyShift action_253+action_413 (188) = happyShift action_51+action_413 (189) = happyShift action_254+action_413 (196) = happyShift action_255+action_413 (203) = happyShift action_59+action_413 (75) = happyGoto action_421+action_413 (76) = happyGoto action_236+action_413 (77) = happyGoto action_237+action_413 (78) = happyGoto action_238+action_413 (79) = happyGoto action_239+action_413 (80) = happyGoto action_240+action_413 (111) = happyGoto action_241+action_413 (113) = happyGoto action_242+action_413 (115) = happyGoto action_243+action_413 (122) = happyGoto action_28+action_413 (123) = happyGoto action_29+action_413 (124) = happyGoto action_30+action_413 (126) = happyGoto action_31+action_413 (132) = happyGoto action_244+action_413 (133) = happyGoto action_33+action_413 _ = happyFail++action_414 _ = happyReduce_61++action_415 _ = happyReduce_284++action_416 _ = happyReduce_280++action_417 _ = happyReduce_21++action_418 _ = happyReduce_23++action_419 (143) = happyShift action_34+action_419 (144) = happyShift action_35+action_419 (145) = happyShift action_36+action_419 (146) = happyShift action_37+action_419 (157) = happyShift action_280+action_419 (180) = happyShift action_47+action_419 (188) = happyShift action_51+action_419 (203) = happyShift action_59+action_419 (14) = happyGoto action_420+action_419 (113) = happyGoto action_278+action_419 (115) = happyGoto action_279+action_419 (122) = happyGoto action_28+action_419 (123) = happyGoto action_29+action_419 (124) = happyGoto action_30+action_419 (126) = happyGoto action_31+action_419 _ = happyFail++action_420 _ = happyReduce_25++action_421 _ = happyReduce_172++action_422 _ = happyReduce_87++action_423 _ = happyReduce_79++action_424 (143) = happyShift action_34+action_424 (144) = happyShift action_35+action_424 (145) = happyShift action_36+action_424 (146) = happyShift action_37+action_424 (147) = happyShift action_38+action_424 (153) = happyShift action_39+action_424 (154) = happyShift action_40+action_424 (155) = happyShift action_41+action_424 (156) = happyShift action_42+action_424 (157) = happyShift action_43+action_424 (163) = happyShift action_44+action_424 (166) = happyShift action_45+action_424 (177) = happyShift action_46+action_424 (180) = happyShift action_47+action_424 (188) = happyShift action_51+action_424 (192) = happyShift action_53+action_424 (193) = happyShift action_54+action_424 (194) = happyShift action_55+action_424 (203) = happyShift action_59+action_424 (27) = happyGoto action_15+action_424 (29) = happyGoto action_16+action_424 (38) = happyGoto action_522+action_424 (40) = happyGoto action_19+action_424 (41) = happyGoto action_20+action_424 (69) = happyGoto action_21+action_424 (70) = happyGoto action_22+action_424 (100) = happyGoto action_23+action_424 (101) = happyGoto action_24+action_424 (102) = happyGoto action_25+action_424 (113) = happyGoto action_26+action_424 (115) = happyGoto action_27+action_424 (122) = happyGoto action_28+action_424 (123) = happyGoto action_29+action_424 (124) = happyGoto action_30+action_424 (126) = happyGoto action_31+action_424 (132) = happyGoto action_32+action_424 (133) = happyGoto action_33+action_424 _ = happyReduce_9++action_425 _ = happyReduce_86++action_426 (187) = happyShift action_521+action_426 _ = happyFail++action_427 _ = happyReduce_223++action_428 (191) = happyShift action_413+action_428 _ = happyReduce_210++action_429 (143) = happyShift action_34+action_429 (144) = happyShift action_35+action_429 (145) = happyShift action_36+action_429 (146) = happyShift action_37+action_429 (147) = happyShift action_245+action_429 (152) = happyShift action_246+action_429 (153) = happyShift action_39+action_429 (154) = happyShift action_40+action_429 (155) = happyShift action_41+action_429 (156) = happyShift action_42+action_429 (157) = happyShift action_247+action_429 (163) = happyShift action_248+action_429 (166) = happyShift action_249+action_429 (172) = happyShift action_250+action_429 (177) = happyShift action_251+action_429 (180) = happyShift action_47+action_429 (181) = happyShift action_252+action_429 (186) = happyShift action_253+action_429 (188) = happyShift action_51+action_429 (189) = happyShift action_254+action_429 (196) = happyShift action_405+action_429 (203) = happyShift action_59+action_429 (75) = happyGoto action_519+action_429 (76) = happyGoto action_401+action_429 (77) = happyGoto action_237+action_429 (78) = happyGoto action_238+action_429 (79) = happyGoto action_239+action_429 (80) = happyGoto action_240+action_429 (86) = happyGoto action_520+action_429 (111) = happyGoto action_241+action_429 (113) = happyGoto action_242+action_429 (115) = happyGoto action_243+action_429 (122) = happyGoto action_28+action_429 (123) = happyGoto action_29+action_429 (124) = happyGoto action_30+action_429 (126) = happyGoto action_31+action_429 (132) = happyGoto action_244+action_429 (133) = happyGoto action_33+action_429 _ = happyFail++action_430 _ = happyReduce_222++action_431 (143) = happyShift action_34+action_431 (144) = happyShift action_35+action_431 (145) = happyShift action_36+action_431 (146) = happyShift action_37+action_431 (147) = happyShift action_245+action_431 (152) = happyShift action_246+action_431 (153) = happyShift action_39+action_431 (154) = happyShift action_40+action_431 (155) = happyShift action_41+action_431 (156) = happyShift action_42+action_431 (157) = happyShift action_247+action_431 (163) = happyShift action_248+action_431 (166) = happyShift action_249+action_431 (172) = happyShift action_250+action_431 (177) = happyShift action_251+action_431 (180) = happyShift action_47+action_431 (181) = happyShift action_252+action_431 (186) = happyShift action_253+action_431 (188) = happyShift action_51+action_431 (189) = happyShift action_254+action_431 (196) = happyShift action_255+action_431 (203) = happyShift action_59+action_431 (75) = happyGoto action_518+action_431 (76) = happyGoto action_236+action_431 (77) = happyGoto action_237+action_431 (78) = happyGoto action_238+action_431 (79) = happyGoto action_239+action_431 (80) = happyGoto action_240+action_431 (111) = happyGoto action_241+action_431 (113) = happyGoto action_242+action_431 (115) = happyGoto action_243+action_431 (122) = happyGoto action_28+action_431 (123) = happyGoto action_29+action_431 (124) = happyGoto action_30+action_431 (126) = happyGoto action_31+action_431 (132) = happyGoto action_244+action_431 (133) = happyGoto action_33+action_431 _ = happyFail++action_432 _ = happyReduce_174++action_433 (143) = happyShift action_34+action_433 (144) = happyShift action_35+action_433 (145) = happyShift action_36+action_433 (146) = happyShift action_37+action_433 (147) = happyShift action_38+action_433 (153) = happyShift action_39+action_433 (154) = happyShift action_40+action_433 (155) = happyShift action_41+action_433 (156) = happyShift action_42+action_433 (157) = happyShift action_83+action_433 (163) = happyShift action_44+action_433 (166) = happyShift action_45+action_433 (177) = happyShift action_46+action_433 (180) = happyShift action_47+action_433 (188) = happyShift action_51+action_433 (203) = happyShift action_59+action_433 (88) = happyGoto action_517+action_433 (89) = happyGoto action_515+action_433 (100) = happyGoto action_516+action_433 (101) = happyGoto action_24+action_433 (102) = happyGoto action_25+action_433 (113) = happyGoto action_81+action_433 (115) = happyGoto action_27+action_433 (122) = happyGoto action_28+action_433 (123) = happyGoto action_29+action_433 (124) = happyGoto action_30+action_433 (126) = happyGoto action_31+action_433 (132) = happyGoto action_32+action_433 (133) = happyGoto action_33+action_433 _ = happyFail++action_434 (143) = happyShift action_34+action_434 (144) = happyShift action_35+action_434 (145) = happyShift action_36+action_434 (146) = happyShift action_37+action_434 (147) = happyShift action_38+action_434 (153) = happyShift action_39+action_434 (154) = happyShift action_40+action_434 (155) = happyShift action_41+action_434 (156) = happyShift action_42+action_434 (157) = happyShift action_83+action_434 (163) = happyShift action_44+action_434 (166) = happyShift action_45+action_434 (177) = happyShift action_46+action_434 (180) = happyShift action_47+action_434 (188) = happyShift action_51+action_434 (203) = happyShift action_59+action_434 (88) = happyGoto action_514+action_434 (89) = happyGoto action_515+action_434 (100) = happyGoto action_516+action_434 (101) = happyGoto action_24+action_434 (102) = happyGoto action_25+action_434 (113) = happyGoto action_81+action_434 (115) = happyGoto action_27+action_434 (122) = happyGoto action_28+action_434 (123) = happyGoto action_29+action_434 (124) = happyGoto action_30+action_434 (126) = happyGoto action_31+action_434 (132) = happyGoto action_32+action_434 (133) = happyGoto action_33+action_434 _ = happyFail++action_435 _ = happyReduce_171++action_436 _ = happyReduce_209++action_437 (165) = happyShift action_513+action_437 _ = happyReduce_203++action_438 _ = happyReduce_207++action_439 _ = happyReduce_201++action_440 (169) = happyShift action_512+action_440 _ = happyReduce_205++action_441 _ = happyReduce_204++action_442 _ = happyReduce_196++action_443 _ = happyReduce_188++action_444 _ = happyReduce_195++action_445 _ = happyReduce_189++action_446 _ = happyReduce_268++action_447 (158) = happyShift action_511+action_447 (165) = happyShift action_208+action_447 _ = happyFail++action_448 _ = happyReduce_267++action_449 (143) = happyShift action_34+action_449 (144) = happyShift action_35+action_449 (145) = happyShift action_36+action_449 (146) = happyShift action_37+action_449 (147) = happyShift action_245+action_449 (152) = happyShift action_246+action_449 (153) = happyShift action_39+action_449 (154) = happyShift action_40+action_449 (155) = happyShift action_41+action_449 (156) = happyShift action_42+action_449 (157) = happyShift action_247+action_449 (163) = happyShift action_248+action_449 (166) = happyShift action_249+action_449 (172) = happyShift action_250+action_449 (177) = happyShift action_251+action_449 (180) = happyShift action_47+action_449 (181) = happyShift action_252+action_449 (186) = happyShift action_253+action_449 (188) = happyShift action_51+action_449 (189) = happyShift action_254+action_449 (196) = happyShift action_255+action_449 (203) = happyShift action_59+action_449 (75) = happyGoto action_510+action_449 (76) = happyGoto action_236+action_449 (77) = happyGoto action_237+action_449 (78) = happyGoto action_238+action_449 (79) = happyGoto action_239+action_449 (80) = happyGoto action_240+action_449 (111) = happyGoto action_241+action_449 (113) = happyGoto action_242+action_449 (115) = happyGoto action_243+action_449 (122) = happyGoto action_28+action_449 (123) = happyGoto action_29+action_449 (124) = happyGoto action_30+action_449 (126) = happyGoto action_31+action_449 (132) = happyGoto action_244+action_449 (133) = happyGoto action_33+action_449 _ = happyFail++action_450 (143) = happyShift action_34+action_450 (144) = happyShift action_35+action_450 (157) = happyShift action_136+action_450 (180) = happyShift action_47+action_450 (188) = happyShift action_51+action_450 (203) = happyShift action_59+action_450 (98) = happyGoto action_509+action_450 (113) = happyGoto action_382+action_450 (122) = happyGoto action_28+action_450 (123) = happyGoto action_29+action_450 _ = happyFail++action_451 _ = happyReduce_180++action_452 _ = happyReduce_167++action_453 _ = happyReduce_166++action_454 _ = happyReduce_75++action_455 _ = happyReduce_76++action_456 _ = happyReduce_145++action_457 _ = happyReduce_147++action_458 (161) = happyShift action_508+action_458 _ = happyFail++action_459 (159) = happyShift action_507+action_459 (7) = happyGoto action_506+action_459 _ = happyReduce_10++action_460 _ = happyReduce_90++action_461 (1) = happyShift action_63+action_461 (162) = happyShift action_64+action_461 (136) = happyGoto action_505+action_461 _ = happyFail++action_462 _ = happyReduce_116++action_463 _ = happyReduce_128++action_464 (158) = happyShift action_504+action_464 _ = happyFail++action_465 (143) = happyShift action_34+action_465 (144) = happyShift action_35+action_465 (157) = happyShift action_136+action_465 (180) = happyShift action_47+action_465 (188) = happyShift action_51+action_465 (203) = happyShift action_59+action_465 (41) = happyGoto action_501+action_465 (58) = happyGoto action_502+action_465 (59) = happyGoto action_503+action_465 (113) = happyGoto action_460+action_465 (122) = happyGoto action_28+action_465 (123) = happyGoto action_29+action_465 _ = happyFail++action_466 (143) = happyShift action_34+action_466 (145) = happyShift action_36+action_466 (146) = happyShift action_71+action_466 (157) = happyShift action_182+action_466 (163) = happyShift action_183+action_466 (179) = happyShift action_367+action_466 (180) = happyShift action_47+action_466 (188) = happyShift action_51+action_466 (203) = happyShift action_59+action_466 (43) = happyGoto action_499+action_466 (44) = happyGoto action_177+action_466 (45) = happyGoto action_178+action_466 (57) = happyGoto action_500+action_466 (123) = happyGoto action_180+action_466 (125) = happyGoto action_68+action_466 (126) = happyGoto action_69+action_466 (139) = happyGoto action_70+action_466 (142) = happyGoto action_181+action_466 _ = happyFail++action_467 (145) = happyShift action_36+action_467 (126) = happyGoto action_284+action_467 _ = happyFail++action_468 _ = happyReduce_125++action_469 _ = happyReduce_124++action_470 (143) = happyShift action_34+action_470 (145) = happyShift action_36+action_470 (146) = happyShift action_71+action_470 (157) = happyShift action_182+action_470 (163) = happyShift action_183+action_470 (180) = happyShift action_47+action_470 (188) = happyShift action_51+action_470 (203) = happyShift action_59+action_470 (44) = happyGoto action_498+action_470 (45) = happyGoto action_178+action_470 (123) = happyGoto action_180+action_470 (125) = happyGoto action_68+action_470 (126) = happyGoto action_69+action_470 (139) = happyGoto action_70+action_470 (142) = happyGoto action_181+action_470 _ = happyFail++action_471 (143) = happyShift action_34+action_471 (145) = happyShift action_36+action_471 (146) = happyShift action_71+action_471 (157) = happyShift action_182+action_471 (163) = happyShift action_183+action_471 (180) = happyShift action_47+action_471 (188) = happyShift action_51+action_471 (203) = happyShift action_59+action_471 (44) = happyGoto action_497+action_471 (45) = happyGoto action_178+action_471 (123) = happyGoto action_180+action_471 (125) = happyGoto action_68+action_471 (126) = happyGoto action_69+action_471 (139) = happyGoto action_70+action_471 (142) = happyGoto action_181+action_471 _ = happyFail++action_472 (143) = happyShift action_34+action_472 (145) = happyShift action_36+action_472 (157) = happyShift action_147+action_472 (165) = happyShift action_480+action_472 (180) = happyShift action_47+action_472 (188) = happyShift action_51+action_472 (203) = happyShift action_59+action_472 (10) = happyGoto action_473+action_472 (21) = happyGoto action_496+action_472 (22) = happyGoto action_475+action_472 (23) = happyGoto action_476+action_472 (112) = happyGoto action_477+action_472 (123) = happyGoto action_146+action_472 (126) = happyGoto action_478+action_472 (138) = happyGoto action_479+action_472 _ = happyReduce_16++action_473 _ = happyReduce_40++action_474 (165) = happyShift action_480+action_474 (10) = happyGoto action_495+action_474 _ = happyReduce_16++action_475 (165) = happyShift action_494+action_475 (10) = happyGoto action_493+action_475 _ = happyReduce_16++action_476 _ = happyReduce_43++action_477 _ = happyReduce_44++action_478 _ = happyReduce_322++action_479 (157) = happyShift action_492+action_479 _ = happyReduce_45++action_480 _ = happyReduce_15++action_481 _ = happyReduce_151++action_482 _ = happyReduce_150++action_483 _ = happyReduce_153++action_484 (143) = happyShift action_34+action_484 (144) = happyShift action_35+action_484 (145) = happyShift action_36+action_484 (146) = happyShift action_37+action_484 (147) = happyShift action_38+action_484 (153) = happyShift action_39+action_484 (154) = happyShift action_40+action_484 (155) = happyShift action_41+action_484 (156) = happyShift action_42+action_484 (157) = happyShift action_43+action_484 (163) = happyShift action_44+action_484 (166) = happyShift action_45+action_484 (177) = happyShift action_46+action_484 (180) = happyShift action_47+action_484 (188) = happyShift action_51+action_484 (203) = happyShift action_59+action_484 (69) = happyGoto action_491+action_484 (70) = happyGoto action_22+action_484 (100) = happyGoto action_23+action_484 (101) = happyGoto action_24+action_484 (102) = happyGoto action_25+action_484 (113) = happyGoto action_92+action_484 (115) = happyGoto action_27+action_484 (122) = happyGoto action_28+action_484 (123) = happyGoto action_29+action_484 (124) = happyGoto action_30+action_484 (126) = happyGoto action_31+action_484 (132) = happyGoto action_32+action_484 (133) = happyGoto action_33+action_484 _ = happyReduce_9++action_485 _ = happyReduce_325++action_486 _ = happyReduce_135++action_487 (145) = happyShift action_36+action_487 (146) = happyShift action_71+action_487 (158) = happyShift action_490+action_487 (62) = happyGoto action_488+action_487 (125) = happyGoto action_485+action_487 (126) = happyGoto action_69+action_487 (139) = happyGoto action_70+action_487 (141) = happyGoto action_489+action_487 _ = happyFail++action_488 (158) = happyShift action_546+action_488 (165) = happyShift action_547+action_488 _ = happyFail++action_489 _ = happyReduce_139++action_490 _ = happyReduce_136++action_491 _ = happyReduce_148++action_492 (143) = happyShift action_34+action_492 (145) = happyShift action_36+action_492 (157) = happyShift action_543+action_492 (158) = happyShift action_544+action_492 (169) = happyShift action_545+action_492 (180) = happyShift action_47+action_492 (188) = happyShift action_51+action_492 (203) = happyShift action_59+action_492 (24) = happyGoto action_538+action_492 (25) = happyGoto action_539+action_492 (112) = happyGoto action_540+action_492 (114) = happyGoto action_541+action_492 (123) = happyGoto action_146+action_492 (126) = happyGoto action_542+action_492 _ = happyFail++action_493 _ = happyReduce_41++action_494 (143) = happyShift action_34+action_494 (145) = happyShift action_36+action_494 (157) = happyShift action_147+action_494 (180) = happyShift action_47+action_494 (188) = happyShift action_51+action_494 (203) = happyShift action_59+action_494 (23) = happyGoto action_537+action_494 (112) = happyGoto action_477+action_494 (123) = happyGoto action_146+action_494 (126) = happyGoto action_478+action_494 (138) = happyGoto action_479+action_494 _ = happyReduce_15++action_495 (158) = happyShift action_536+action_495 _ = happyFail++action_496 (165) = happyShift action_480+action_496 (10) = happyGoto action_535+action_496 _ = happyReduce_16++action_497 _ = happyReduce_123++action_498 _ = happyReduce_126++action_499 (143) = happyShift action_34+action_499 (145) = happyShift action_36+action_499 (146) = happyShift action_71+action_499 (157) = happyShift action_182+action_499 (163) = happyShift action_183+action_499 (180) = happyShift action_47+action_499 (188) = happyShift action_51+action_499 (203) = happyShift action_59+action_499 (44) = happyGoto action_220+action_499 (45) = happyGoto action_178+action_499 (123) = happyGoto action_180+action_499 (125) = happyGoto action_68+action_499 (126) = happyGoto action_69+action_499 (139) = happyGoto action_70+action_499 (142) = happyGoto action_181+action_499 _ = happyReduce_127++action_500 _ = happyReduce_119++action_501 (165) = happyShift action_121+action_501 (170) = happyShift action_534+action_501 _ = happyFail++action_502 (161) = happyShift action_532+action_502 (165) = happyShift action_533+action_502 _ = happyFail++action_503 _ = happyReduce_130++action_504 _ = happyReduce_276++action_505 _ = happyReduce_141++action_506 _ = happyReduce_144++action_507 (143) = happyShift action_34+action_507 (144) = happyShift action_35+action_507 (145) = happyShift action_36+action_507 (146) = happyShift action_37+action_507 (147) = happyShift action_38+action_507 (153) = happyShift action_39+action_507 (154) = happyShift action_40+action_507 (155) = happyShift action_41+action_507 (156) = happyShift action_42+action_507 (157) = happyShift action_43+action_507 (163) = happyShift action_44+action_507 (166) = happyShift action_45+action_507 (177) = happyShift action_46+action_507 (180) = happyShift action_47+action_507 (188) = happyShift action_51+action_507 (203) = happyShift action_59+action_507 (40) = happyGoto action_530+action_507 (41) = happyGoto action_20+action_507 (66) = happyGoto action_531+action_507 (69) = happyGoto action_352+action_507 (70) = happyGoto action_22+action_507 (100) = happyGoto action_23+action_507 (101) = happyGoto action_24+action_507 (102) = happyGoto action_25+action_507 (113) = happyGoto action_26+action_507 (115) = happyGoto action_27+action_507 (122) = happyGoto action_28+action_507 (123) = happyGoto action_29+action_507 (124) = happyGoto action_30+action_507 (126) = happyGoto action_31+action_507 (132) = happyGoto action_32+action_507 (133) = happyGoto action_33+action_507 _ = happyReduce_9++action_508 _ = happyReduce_140++action_509 _ = happyReduce_230++action_510 _ = happyReduce_232++action_511 _ = happyReduce_269++action_512 (143) = happyShift action_34+action_512 (144) = happyShift action_35+action_512 (145) = happyShift action_36+action_512 (146) = happyShift action_37+action_512 (147) = happyShift action_245+action_512 (152) = happyShift action_246+action_512 (153) = happyShift action_39+action_512 (154) = happyShift action_40+action_512 (155) = happyShift action_41+action_512 (156) = happyShift action_42+action_512 (157) = happyShift action_247+action_512 (163) = happyShift action_248+action_512 (166) = happyShift action_249+action_512 (172) = happyShift action_250+action_512 (177) = happyShift action_251+action_512 (180) = happyShift action_47+action_512 (181) = happyShift action_252+action_512 (186) = happyShift action_253+action_512 (188) = happyShift action_51+action_512 (189) = happyShift action_254+action_512 (196) = happyShift action_255+action_512 (203) = happyShift action_59+action_512 (75) = happyGoto action_529+action_512 (76) = happyGoto action_236+action_512 (77) = happyGoto action_237+action_512 (78) = happyGoto action_238+action_512 (79) = happyGoto action_239+action_512 (80) = happyGoto action_240+action_512 (111) = happyGoto action_241+action_512 (113) = happyGoto action_242+action_512 (115) = happyGoto action_243+action_512 (122) = happyGoto action_28+action_512 (123) = happyGoto action_29+action_512 (124) = happyGoto action_30+action_512 (126) = happyGoto action_31+action_512 (132) = happyGoto action_244+action_512 (133) = happyGoto action_33+action_512 _ = happyReduce_200++action_513 (143) = happyShift action_34+action_513 (144) = happyShift action_35+action_513 (145) = happyShift action_36+action_513 (146) = happyShift action_37+action_513 (147) = happyShift action_245+action_513 (152) = happyShift action_246+action_513 (153) = happyShift action_39+action_513 (154) = happyShift action_40+action_513 (155) = happyShift action_41+action_513 (156) = happyShift action_42+action_513 (157) = happyShift action_247+action_513 (163) = happyShift action_248+action_513 (166) = happyShift action_249+action_513 (172) = happyShift action_250+action_513 (177) = happyShift action_251+action_513 (180) = happyShift action_47+action_513 (181) = happyShift action_252+action_513 (186) = happyShift action_253+action_513 (188) = happyShift action_51+action_513 (189) = happyShift action_254+action_513 (196) = happyShift action_405+action_513 (203) = happyShift action_59+action_513 (75) = happyGoto action_436+action_513 (76) = happyGoto action_401+action_513 (77) = happyGoto action_237+action_513 (78) = happyGoto action_238+action_513 (79) = happyGoto action_239+action_513 (80) = happyGoto action_240+action_513 (86) = happyGoto action_528+action_513 (111) = happyGoto action_241+action_513 (113) = happyGoto action_242+action_513 (115) = happyGoto action_243+action_513 (122) = happyGoto action_28+action_513 (123) = happyGoto action_29+action_513 (124) = happyGoto action_30+action_513 (126) = happyGoto action_31+action_513 (132) = happyGoto action_244+action_513 (133) = happyGoto action_33+action_513 _ = happyFail++action_514 (159) = happyShift action_525+action_514 (7) = happyGoto action_527+action_514 _ = happyReduce_10++action_515 _ = happyReduce_214++action_516 (149) = happyShift action_100+action_516 (151) = happyShift action_102+action_516 (167) = happyShift action_173+action_516 (119) = happyGoto action_113+action_516 (127) = happyGoto action_114+action_516 (128) = happyGoto action_94+action_516 (134) = happyGoto action_526+action_516 _ = happyReduce_317++action_517 (159) = happyShift action_525+action_517 (7) = happyGoto action_524+action_517 _ = happyReduce_10++action_518 _ = happyReduce_208++action_519 (159) = happyReduce_209+action_519 _ = happyReduce_224++action_520 _ = happyReduce_226++action_521 (143) = happyShift action_34+action_521 (144) = happyShift action_35+action_521 (145) = happyShift action_36+action_521 (146) = happyShift action_37+action_521 (147) = happyShift action_245+action_521 (152) = happyShift action_246+action_521 (153) = happyShift action_39+action_521 (154) = happyShift action_40+action_521 (155) = happyShift action_41+action_521 (156) = happyShift action_42+action_521 (157) = happyShift action_247+action_521 (163) = happyShift action_248+action_521 (166) = happyShift action_249+action_521 (172) = happyShift action_250+action_521 (177) = happyShift action_251+action_521 (180) = happyShift action_47+action_521 (181) = happyShift action_252+action_521 (186) = happyShift action_253+action_521 (188) = happyShift action_51+action_521 (189) = happyShift action_254+action_521 (196) = happyShift action_255+action_521 (203) = happyShift action_59+action_521 (75) = happyGoto action_523+action_521 (76) = happyGoto action_236+action_521 (77) = happyGoto action_237+action_521 (78) = happyGoto action_238+action_521 (79) = happyGoto action_239+action_521 (80) = happyGoto action_240+action_521 (111) = happyGoto action_241+action_521 (113) = happyGoto action_242+action_521 (115) = happyGoto action_243+action_521 (122) = happyGoto action_28+action_521 (123) = happyGoto action_29+action_521 (124) = happyGoto action_30+action_521 (126) = happyGoto action_31+action_521 (132) = happyGoto action_244+action_521 (133) = happyGoto action_33+action_521 _ = happyFail++action_522 _ = happyReduce_81++action_523 _ = happyReduce_173++action_524 (1) = happyShift action_63+action_524 (162) = happyShift action_64+action_524 (136) = happyGoto action_565+action_524 _ = happyFail++action_525 (143) = happyShift action_34+action_525 (144) = happyShift action_35+action_525 (145) = happyShift action_36+action_525 (146) = happyShift action_37+action_525 (147) = happyShift action_38+action_525 (153) = happyShift action_39+action_525 (154) = happyShift action_40+action_525 (155) = happyShift action_41+action_525 (156) = happyShift action_42+action_525 (157) = happyShift action_83+action_525 (163) = happyShift action_44+action_525 (166) = happyShift action_45+action_525 (177) = happyShift action_46+action_525 (180) = happyShift action_47+action_525 (188) = happyShift action_51+action_525 (203) = happyShift action_59+action_525 (89) = happyGoto action_564+action_525 (100) = happyGoto action_516+action_525 (101) = happyGoto action_24+action_525 (102) = happyGoto action_25+action_525 (113) = happyGoto action_81+action_525 (115) = happyGoto action_27+action_525 (122) = happyGoto action_28+action_525 (123) = happyGoto action_29+action_525 (124) = happyGoto action_30+action_525 (126) = happyGoto action_31+action_525 (132) = happyGoto action_32+action_525 (133) = happyGoto action_33+action_525 _ = happyReduce_9++action_526 (173) = happyShift action_562+action_526 (175) = happyShift action_563+action_526 (90) = happyGoto action_559+action_526 (91) = happyGoto action_560+action_526 (92) = happyGoto action_561+action_526 _ = happyFail++action_527 (161) = happyShift action_558+action_527 _ = happyFail++action_528 _ = happyReduce_206++action_529 _ = happyReduce_202++action_530 _ = happyReduce_146++action_531 (159) = happyShift action_484+action_531 (7) = happyGoto action_557+action_531 _ = happyReduce_10++action_532 _ = happyReduce_120++action_533 (143) = happyShift action_34+action_533 (144) = happyShift action_35+action_533 (157) = happyShift action_136+action_533 (180) = happyShift action_47+action_533 (188) = happyShift action_51+action_533 (203) = happyShift action_59+action_533 (41) = happyGoto action_501+action_533 (59) = happyGoto action_556+action_533 (113) = happyGoto action_460+action_533 (122) = happyGoto action_28+action_533 (123) = happyGoto action_29+action_533 _ = happyFail++action_534 (143) = happyShift action_34+action_534 (145) = happyShift action_36+action_534 (146) = happyShift action_71+action_534 (157) = happyShift action_182+action_534 (163) = happyShift action_183+action_534 (179) = happyShift action_555+action_534 (180) = happyShift action_47+action_534 (188) = happyShift action_51+action_534 (203) = happyShift action_59+action_534 (42) = happyGoto action_553+action_534 (43) = happyGoto action_176+action_534 (44) = happyGoto action_177+action_534 (45) = happyGoto action_178+action_534 (60) = happyGoto action_554+action_534 (123) = happyGoto action_180+action_534 (125) = happyGoto action_68+action_534 (126) = happyGoto action_69+action_534 (139) = happyGoto action_70+action_534 (142) = happyGoto action_181+action_534 _ = happyFail++action_535 (158) = happyShift action_552+action_535 _ = happyFail++action_536 _ = happyReduce_38++action_537 _ = happyReduce_42++action_538 (158) = happyShift action_550+action_538 (165) = happyShift action_551+action_538 _ = happyFail++action_539 _ = happyReduce_50++action_540 _ = happyReduce_51++action_541 _ = happyReduce_52++action_542 _ = happyReduce_275++action_543 (147) = happyShift action_117+action_543 (148) = happyShift action_99+action_543 (149) = happyShift action_100+action_543 (168) = happyShift action_104+action_543 (179) = happyShift action_105+action_543 (128) = happyGoto action_464+action_543 (130) = happyGoto action_260+action_543 _ = happyFail++action_544 _ = happyReduce_47++action_545 (158) = happyShift action_549+action_545 _ = happyFail++action_546 _ = happyReduce_137++action_547 (145) = happyShift action_36+action_547 (146) = happyShift action_71+action_547 (125) = happyGoto action_485+action_547 (126) = happyGoto action_69+action_547 (139) = happyGoto action_70+action_547 (141) = happyGoto action_548+action_547 _ = happyFail++action_548 _ = happyReduce_138++action_549 _ = happyReduce_46++action_550 _ = happyReduce_48++action_551 (143) = happyShift action_34+action_551 (145) = happyShift action_36+action_551 (157) = happyShift action_543+action_551 (180) = happyShift action_47+action_551 (188) = happyShift action_51+action_551 (203) = happyShift action_59+action_551 (25) = happyGoto action_571+action_551 (112) = happyGoto action_540+action_551 (114) = happyGoto action_541+action_551 (123) = happyGoto action_146+action_551 (126) = happyGoto action_542+action_551 _ = happyFail++action_552 _ = happyReduce_39++action_553 _ = happyReduce_132++action_554 _ = happyReduce_131++action_555 (143) = happyShift action_34+action_555 (145) = happyShift action_36+action_555 (146) = happyShift action_71+action_555 (157) = happyShift action_182+action_555 (163) = happyShift action_183+action_555 (180) = happyShift action_47+action_555 (188) = happyShift action_51+action_555 (203) = happyShift action_59+action_555 (44) = happyGoto action_570+action_555 (45) = happyGoto action_178+action_555 (123) = happyGoto action_180+action_555 (125) = happyGoto action_68+action_555 (126) = happyGoto action_69+action_555 (139) = happyGoto action_70+action_555 (142) = happyGoto action_181+action_555 _ = happyFail++action_556 _ = happyReduce_129++action_557 _ = happyReduce_143++action_558 _ = happyReduce_211++action_559 (202) = happyShift action_569+action_559 _ = happyReduce_215++action_560 (173) = happyShift action_562+action_560 (92) = happyGoto action_568+action_560 _ = happyReduce_218++action_561 _ = happyReduce_220++action_562 (134) = happyGoto action_567+action_562 _ = happyReduce_317++action_563 (143) = happyShift action_34+action_563 (144) = happyShift action_35+action_563 (145) = happyShift action_36+action_563 (146) = happyShift action_37+action_563 (147) = happyShift action_245+action_563 (152) = happyShift action_246+action_563 (153) = happyShift action_39+action_563 (154) = happyShift action_40+action_563 (155) = happyShift action_41+action_563 (156) = happyShift action_42+action_563 (157) = happyShift action_247+action_563 (163) = happyShift action_248+action_563 (166) = happyShift action_249+action_563 (172) = happyShift action_250+action_563 (177) = happyShift action_251+action_563 (180) = happyShift action_47+action_563 (181) = happyShift action_252+action_563 (186) = happyShift action_253+action_563 (188) = happyShift action_51+action_563 (189) = happyShift action_254+action_563 (196) = happyShift action_255+action_563 (203) = happyShift action_59+action_563 (75) = happyGoto action_566+action_563 (76) = happyGoto action_236+action_563 (77) = happyGoto action_237+action_563 (78) = happyGoto action_238+action_563 (79) = happyGoto action_239+action_563 (80) = happyGoto action_240+action_563 (111) = happyGoto action_241+action_563 (113) = happyGoto action_242+action_563 (115) = happyGoto action_243+action_563 (122) = happyGoto action_28+action_563 (123) = happyGoto action_29+action_563 (124) = happyGoto action_30+action_563 (126) = happyGoto action_31+action_563 (132) = happyGoto action_244+action_563 (133) = happyGoto action_33+action_563 _ = happyFail++action_564 _ = happyReduce_213++action_565 _ = happyReduce_212++action_566 _ = happyReduce_217++action_567 (143) = happyShift action_34+action_567 (144) = happyShift action_35+action_567 (145) = happyShift action_36+action_567 (146) = happyShift action_37+action_567 (147) = happyShift action_245+action_567 (152) = happyShift action_246+action_567 (153) = happyShift action_39+action_567 (154) = happyShift action_40+action_567 (155) = happyShift action_41+action_567 (156) = happyShift action_42+action_567 (157) = happyShift action_247+action_567 (163) = happyShift action_248+action_567 (166) = happyShift action_249+action_567 (172) = happyShift action_250+action_567 (177) = happyShift action_251+action_567 (180) = happyShift action_47+action_567 (181) = happyShift action_252+action_567 (186) = happyShift action_253+action_567 (188) = happyShift action_51+action_567 (189) = happyShift action_254+action_567 (196) = happyShift action_255+action_567 (203) = happyShift action_59+action_567 (75) = happyGoto action_573+action_567 (76) = happyGoto action_236+action_567 (77) = happyGoto action_237+action_567 (78) = happyGoto action_238+action_567 (79) = happyGoto action_239+action_567 (80) = happyGoto action_240+action_567 (111) = happyGoto action_241+action_567 (113) = happyGoto action_242+action_567 (115) = happyGoto action_243+action_567 (122) = happyGoto action_28+action_567 (123) = happyGoto action_29+action_567 (124) = happyGoto action_30+action_567 (126) = happyGoto action_31+action_567 (132) = happyGoto action_244+action_567 (133) = happyGoto action_33+action_567 _ = happyFail++action_568 _ = happyReduce_219++action_569 (160) = happyShift action_289+action_569 (39) = happyGoto action_572+action_569 (135) = happyGoto action_288+action_569 _ = happyReduce_318++action_570 _ = happyReduce_133++action_571 _ = happyReduce_49++action_572 _ = happyReduce_216++action_573 (175) = happyShift action_574+action_573 _ = happyFail++action_574 (143) = happyShift action_34+action_574 (144) = happyShift action_35+action_574 (145) = happyShift action_36+action_574 (146) = happyShift action_37+action_574 (147) = happyShift action_245+action_574 (152) = happyShift action_246+action_574 (153) = happyShift action_39+action_574 (154) = happyShift action_40+action_574 (155) = happyShift action_41+action_574 (156) = happyShift action_42+action_574 (157) = happyShift action_247+action_574 (163) = happyShift action_248+action_574 (166) = happyShift action_249+action_574 (172) = happyShift action_250+action_574 (177) = happyShift action_251+action_574 (180) = happyShift action_47+action_574 (181) = happyShift action_252+action_574 (186) = happyShift action_253+action_574 (188) = happyShift action_51+action_574 (189) = happyShift action_254+action_574 (196) = happyShift action_255+action_574 (203) = happyShift action_59+action_574 (75) = happyGoto action_575+action_574 (76) = happyGoto action_236+action_574 (77) = happyGoto action_237+action_574 (78) = happyGoto action_238+action_574 (79) = happyGoto action_239+action_574 (80) = happyGoto action_240+action_574 (111) = happyGoto action_241+action_574 (113) = happyGoto action_242+action_574 (115) = happyGoto action_243+action_574 (122) = happyGoto action_28+action_574 (123) = happyGoto action_29+action_574 (124) = happyGoto action_30+action_574 (126) = happyGoto action_31+action_574 (132) = happyGoto action_244+action_574 (133) = happyGoto action_33+action_574 _ = happyFail++action_575 _ = happyReduce_221++happyReduce_1 = happyReduce 6 4 happyReduction_1+happyReduction_1 ((HappyAbsSyn5  happy_var_6) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn8  happy_var_4) `HappyStk`+	(HappyAbsSyn137  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn134  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn4+		 (hsModule happy_var_1 happy_var_3 happy_var_4 happy_var_6+	) `HappyStk` happyRest++happyReduce_2 = happySpecReduce_2 4 happyReduction_2+happyReduction_2 (HappyAbsSyn5  happy_var_2)+	(HappyAbsSyn134  happy_var_1)+	 =  HappyAbsSyn4+		 (hsModule happy_var_1 main_mod Nothing happy_var_2+	)+happyReduction_2 _ _  = notHappyAtAll ++happyReduce_3 = happySpecReduce_3 5 happyReduction_3+happyReduction_3 _+	(HappyAbsSyn5  happy_var_2)+	_+	 =  HappyAbsSyn5+		 (happy_var_2+	)+happyReduction_3 _ _ _  = notHappyAtAll ++happyReduce_4 = happySpecReduce_3 5 happyReduction_4+happyReduction_4 _+	(HappyAbsSyn5  happy_var_2)+	_+	 =  HappyAbsSyn5+		 (happy_var_2+	)+happyReduction_4 _ _ _  = notHappyAtAll ++happyReduce_5 = happyReduce 4 6 happyReduction_5+happyReduction_5 (_ `HappyStk`+	(HappyAbsSyn26  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn15  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn5+		 ((happy_var_1, happy_var_3)+	) `HappyStk` happyRest++happyReduce_6 = happySpecReduce_2 6 happyReduction_6+happyReduction_6 _+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn5+		 (([], happy_var_1)+	)+happyReduction_6 _ _  = notHappyAtAll ++happyReduce_7 = happySpecReduce_2 6 happyReduction_7+happyReduction_7 _+	(HappyAbsSyn15  happy_var_1)+	 =  HappyAbsSyn5+		 ((happy_var_1, [])+	)+happyReduction_7 _ _  = notHappyAtAll ++happyReduce_8 = happySpecReduce_0 6 happyReduction_8+happyReduction_8  =  HappyAbsSyn5+		 (([], [])+	)++happyReduce_9 = happySpecReduce_1 7 happyReduction_9+happyReduction_9 _+	 =  HappyAbsSyn7+		 (()+	)++happyReduce_10 = happySpecReduce_0 7 happyReduction_10+happyReduction_10  =  HappyAbsSyn7+		 (()+	)++happyReduce_11 = happySpecReduce_1 8 happyReduction_11+happyReduction_11 (HappyAbsSyn9  happy_var_1)+	 =  HappyAbsSyn8+		 (Just happy_var_1+	)+happyReduction_11 _  = notHappyAtAll ++happyReduce_12 = happySpecReduce_0 8 happyReduction_12+happyReduction_12  =  HappyAbsSyn8+		 (Nothing+	)++happyReduce_13 = happyReduce 4 9 happyReduction_13+happyReduction_13 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn9  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn9+		 (reverse happy_var_2+	) `HappyStk` happyRest++happyReduce_14 = happySpecReduce_2 9 happyReduction_14+happyReduction_14 _+	_+	 =  HappyAbsSyn9+		 ([]+	)++happyReduce_15 = happySpecReduce_1 10 happyReduction_15+happyReduction_15 _+	 =  HappyAbsSyn7+		 (()+	)++happyReduce_16 = happySpecReduce_0 10 happyReduction_16+happyReduction_16  =  HappyAbsSyn7+		 (()+	)++happyReduce_17 = happySpecReduce_3 11 happyReduction_17+happyReduction_17 (HappyAbsSyn12  happy_var_3)+	_+	(HappyAbsSyn9  happy_var_1)+	 =  HappyAbsSyn9+		 (happy_var_3 : happy_var_1+	)+happyReduction_17 _ _ _  = notHappyAtAll ++happyReduce_18 = happySpecReduce_1 11 happyReduction_18+happyReduction_18 (HappyAbsSyn12  happy_var_1)+	 =  HappyAbsSyn9+		 ([happy_var_1]+	)+happyReduction_18 _  = notHappyAtAll ++happyReduce_19 = happySpecReduce_1 12 happyReduction_19+happyReduction_19 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn12+		 (HsEVar happy_var_1+	)+happyReduction_19 _  = notHappyAtAll ++happyReduce_20 = happySpecReduce_1 12 happyReduction_20+happyReduction_20 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn12+		 (HsEAbs happy_var_1+	)+happyReduction_20 _  = notHappyAtAll ++happyReduce_21 = happyReduce 4 12 happyReduction_21+happyReduction_21 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn12+		 (HsEThingAll happy_var_1+	) `HappyStk` happyRest++happyReduce_22 = happySpecReduce_3 12 happyReduction_22+happyReduction_22 _+	_+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn12+		 (HsEThingWith happy_var_1 []+	)+happyReduction_22 _ _ _  = notHappyAtAll ++happyReduce_23 = happyReduce 4 12 happyReduction_23+happyReduction_23 (_ `HappyStk`+	(HappyAbsSyn13  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn12+		 (HsEThingWith happy_var_1 (reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_24 = happySpecReduce_2 12 happyReduction_24+happyReduction_24 (HappyAbsSyn137  happy_var_2)+	_+	 =  HappyAbsSyn12+		 (HsEModuleContents happy_var_2+	)+happyReduction_24 _ _  = notHappyAtAll ++happyReduce_25 = happySpecReduce_3 13 happyReduction_25+happyReduction_25 (HappyAbsSyn14  happy_var_3)+	_+	(HappyAbsSyn13  happy_var_1)+	 =  HappyAbsSyn13+		 (happy_var_3 : happy_var_1+	)+happyReduction_25 _ _ _  = notHappyAtAll ++happyReduce_26 = happySpecReduce_1 13 happyReduction_26+happyReduction_26 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn13+		 ([happy_var_1]+	)+happyReduction_26 _  = notHappyAtAll ++happyReduce_27 = happySpecReduce_1 14 happyReduction_27+happyReduction_27 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_27 _  = notHappyAtAll ++happyReduce_28 = happySpecReduce_1 14 happyReduction_28+happyReduction_28 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_28 _  = notHappyAtAll ++happyReduce_29 = happySpecReduce_3 15 happyReduction_29+happyReduction_29 (HappyAbsSyn16  happy_var_3)+	_+	(HappyAbsSyn15  happy_var_1)+	 =  HappyAbsSyn15+		 (happy_var_3 : happy_var_1+	)+happyReduction_29 _ _ _  = notHappyAtAll ++happyReduce_30 = happySpecReduce_1 15 happyReduction_30+happyReduction_30 (HappyAbsSyn16  happy_var_1)+	 =  HappyAbsSyn15+		 ([happy_var_1]+	)+happyReduction_30 _  = notHappyAtAll ++happyReduce_31 = happyReduce 6 16 happyReduction_31+happyReduction_31 ((HappyAbsSyn19  happy_var_6) `HappyStk`+	(HappyAbsSyn18  happy_var_5) `HappyStk`+	(HappyAbsSyn137  happy_var_4) `HappyStk`+	(HappyAbsSyn17  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn16+		 (HsImportDecl happy_var_2 happy_var_4 happy_var_3 happy_var_5 happy_var_6+	) `HappyStk` happyRest++happyReduce_32 = happySpecReduce_1 17 happyReduction_32+happyReduction_32 _+	 =  HappyAbsSyn17+		 (True+	)++happyReduce_33 = happySpecReduce_0 17 happyReduction_33+happyReduction_33  =  HappyAbsSyn17+		 (False+	)++happyReduce_34 = happySpecReduce_2 18 happyReduction_34+happyReduction_34 (HappyAbsSyn137  happy_var_2)+	_+	 =  HappyAbsSyn18+		 (Just happy_var_2+	)+happyReduction_34 _ _  = notHappyAtAll ++happyReduce_35 = happySpecReduce_0 18 happyReduction_35+happyReduction_35  =  HappyAbsSyn18+		 (Nothing+	)++happyReduce_36 = happySpecReduce_1 19 happyReduction_36+happyReduction_36 (HappyAbsSyn20  happy_var_1)+	 =  HappyAbsSyn19+		 (Just happy_var_1+	)+happyReduction_36 _  = notHappyAtAll ++happyReduce_37 = happySpecReduce_0 19 happyReduction_37+happyReduction_37  =  HappyAbsSyn19+		 (Nothing+	)++happyReduce_38 = happyReduce 4 20 happyReduction_38+happyReduction_38 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn21  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn20+		 ((False, reverse happy_var_2)+	) `HappyStk` happyRest++happyReduce_39 = happyReduce 5 20 happyReduction_39+happyReduction_39 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn21  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn20+		 ((True,  reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_40 = happySpecReduce_1 21 happyReduction_40+happyReduction_40 _+	 =  HappyAbsSyn21+		 ([]+	)++happyReduce_41 = happySpecReduce_2 21 happyReduction_41+happyReduction_41 _+	(HappyAbsSyn21  happy_var_1)+	 =  HappyAbsSyn21+		 (happy_var_1+	)+happyReduction_41 _ _  = notHappyAtAll ++happyReduce_42 = happySpecReduce_3 22 happyReduction_42+happyReduction_42 (HappyAbsSyn23  happy_var_3)+	_+	(HappyAbsSyn21  happy_var_1)+	 =  HappyAbsSyn21+		 (happy_var_3 : happy_var_1+	)+happyReduction_42 _ _ _  = notHappyAtAll ++happyReduce_43 = happySpecReduce_1 22 happyReduction_43+happyReduction_43 (HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn21+		 ([happy_var_1]+	)+happyReduction_43 _  = notHappyAtAll ++happyReduce_44 = happySpecReduce_1 23 happyReduction_44+happyReduction_44 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn23+		 (HsIVar happy_var_1+	)+happyReduction_44 _  = notHappyAtAll ++happyReduce_45 = happySpecReduce_1 23 happyReduction_45+happyReduction_45 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn23+		 (HsIAbs happy_var_1+	)+happyReduction_45 _  = notHappyAtAll ++happyReduce_46 = happyReduce 4 23 happyReduction_46+happyReduction_46 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn23+		 (HsIThingAll happy_var_1+	) `HappyStk` happyRest++happyReduce_47 = happySpecReduce_3 23 happyReduction_47+happyReduction_47 _+	_+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn23+		 (HsIThingWith happy_var_1 []+	)+happyReduction_47 _ _ _  = notHappyAtAll ++happyReduce_48 = happyReduce 4 23 happyReduction_48+happyReduction_48 (_ `HappyStk`+	(HappyAbsSyn13  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn23+		 (HsIThingWith happy_var_1 (reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_49 = happySpecReduce_3 24 happyReduction_49+happyReduction_49 (HappyAbsSyn14  happy_var_3)+	_+	(HappyAbsSyn13  happy_var_1)+	 =  HappyAbsSyn13+		 (happy_var_3 : happy_var_1+	)+happyReduction_49 _ _ _  = notHappyAtAll ++happyReduce_50 = happySpecReduce_1 24 happyReduction_50+happyReduction_50 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn13+		 ([happy_var_1]+	)+happyReduction_50 _  = notHappyAtAll ++happyReduce_51 = happySpecReduce_1 25 happyReduction_51+happyReduction_51 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_51 _  = notHappyAtAll ++happyReduce_52 = happySpecReduce_1 25 happyReduction_52+happyReduction_52 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_52 _  = notHappyAtAll ++happyReduce_53 = happySpecReduce_3 26 happyReduction_53+happyReduction_53 (HappyAbsSyn27  happy_var_3)+	_+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (funCons happy_var_3 happy_var_1+	)+happyReduction_53 _ _ _  = notHappyAtAll ++happyReduce_54 = happySpecReduce_1 26 happyReduction_54+happyReduction_54 (HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn26+		 ([happy_var_1]+	)+happyReduction_54 _  = notHappyAtAll ++happyReduce_55 = happyReduce 4 27 happyReduction_55+happyReduction_55 ((HappyAbsSyn30  happy_var_4) `HappyStk`+	(HappyAbsSyn28  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	(HappyAbsSyn29  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn27+		 (hsInfixDecl happy_var_2 (HsFixity happy_var_1 happy_var_3) happy_var_4+	) `HappyStk` happyRest++happyReduce_56 = happySpecReduce_0 28 happyReduction_56+happyReduction_56  =  HappyAbsSyn28+		 (9+	)++happyReduce_57 = happySpecReduce_1 28 happyReduction_57+happyReduction_57 (HappyTerminal (IntTok happy_var_1))+	 =  HappyAbsSyn28+		 (fromInteger (readInteger happy_var_1)+	)+happyReduction_57 _  = notHappyAtAll ++happyReduce_58 = happySpecReduce_1 29 happyReduction_58+happyReduction_58 _+	 =  HappyAbsSyn29+		 (HsAssocNone+	)++happyReduce_59 = happySpecReduce_1 29 happyReduction_59+happyReduction_59 _+	 =  HappyAbsSyn29+		 (HsAssocLeft+	)++happyReduce_60 = happySpecReduce_1 29 happyReduction_60+happyReduction_60 _+	 =  HappyAbsSyn29+		 (HsAssocRight+	)++happyReduce_61 = happySpecReduce_3 30 happyReduction_61+happyReduction_61 (HappyAbsSyn30  happy_var_3)+	_+	(HappyAbsSyn120  happy_var_1)+	 =  HappyAbsSyn30+		 (happy_var_1 : happy_var_3+	)+happyReduction_61 _ _ _  = notHappyAtAll ++happyReduce_62 = happySpecReduce_1 30 happyReduction_62+happyReduction_62 (HappyAbsSyn120  happy_var_1)+	 =  HappyAbsSyn30+		 ([happy_var_1]+	)+happyReduction_62 _  = notHappyAtAll ++happyReduce_63 = happyReduce 5 31 happyReduction_63+happyReduction_63 ((HappyAbsSyn42  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn134  happy_var_3) `HappyStk`+	(HappyAbsSyn35  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn27+		 (hsTypeDecl happy_var_3 happy_var_2 happy_var_5+	) `HappyStk` happyRest++happyReduce_64 = happyReduce 6 31 happyReduction_64+happyReduction_64 ((HappyAbsSyn13  happy_var_6) `HappyStk`+	(HappyAbsSyn52  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn48  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn27+		 (hsDataDecl happy_var_2 (fst happy_var_3) (snd happy_var_3) (reverse happy_var_5) happy_var_6+	) `HappyStk` happyRest++happyReduce_65 = happyReduce 6 31 happyReduction_65+happyReduction_65 ((HappyAbsSyn13  happy_var_6) `HappyStk`+	(HappyAbsSyn53  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn48  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn27+		 (hsNewTypeDecl happy_var_2 (fst happy_var_3) (snd happy_var_3) happy_var_5 happy_var_6+	) `HappyStk` happyRest++happyReduce_66 = happyReduce 5 31 happyReduction_66+happyReduction_66 ((HappyAbsSyn26  happy_var_5) `HappyStk`+	(HappyAbsSyn32  happy_var_4) `HappyStk`+	(HappyAbsSyn46  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn27+		 (hsClassDecl  happy_var_2 (fst happy_var_3) (snd happy_var_3) happy_var_4 happy_var_5+	) `HappyStk` happyRest++happyReduce_67 = happyReduce 4 31 happyReduction_67+happyReduction_67 ((HappyAbsSyn26  happy_var_4) `HappyStk`+	(HappyAbsSyn46  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn27+		 (hsInstDecl happy_var_2 (fst happy_var_3) (snd happy_var_3) happy_var_4+	) `HappyStk` happyRest++happyReduce_68 = happySpecReduce_3 31 happyReduction_68+happyReduction_68 (HappyAbsSyn42  happy_var_3)+	(HappyAbsSyn134  happy_var_2)+	_+	 =  HappyAbsSyn27+		 (hsDefaultDecl happy_var_2 happy_var_3+	)+happyReduction_68 _ _ _  = notHappyAtAll ++happyReduce_69 = happySpecReduce_3 31 happyReduction_69+happyReduction_69 (HappyAbsSyn51  happy_var_3)+	(HappyAbsSyn134  happy_var_2)+	_+	 =  HappyAbsSyn27+		 (hsPrimitiveTypeDecl happy_var_2 (fst happy_var_3) (snd happy_var_3)+	)+happyReduction_69 _ _ _  = notHappyAtAll ++happyReduce_70 = happyReduce 5 31 happyReduction_70+happyReduction_70 ((HappyAbsSyn42  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn27+		 (hsPrimitiveBind happy_var_2 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_71 = happySpecReduce_1 31 happyReduction_71+happyReduction_71 (HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn27+		 (happy_var_1+	)+happyReduction_71 _  = notHappyAtAll ++happyReduce_72 = happySpecReduce_0 32 happyReduction_72+happyReduction_72  =  HappyAbsSyn32+		 ([]+	)++happyReduce_73 = happySpecReduce_2 32 happyReduction_73+happyReduction_73 (HappyAbsSyn32  happy_var_2)+	_+	 =  HappyAbsSyn32+		 (happy_var_2+	)+happyReduction_73 _ _  = notHappyAtAll ++happyReduce_74 = happySpecReduce_1 33 happyReduction_74+happyReduction_74 (HappyAbsSyn34  happy_var_1)+	 =  HappyAbsSyn32+		 ([happy_var_1]+	)+happyReduction_74 _  = notHappyAtAll ++happyReduce_75 = happySpecReduce_3 33 happyReduction_75+happyReduction_75 (HappyAbsSyn32  happy_var_3)+	_+	(HappyAbsSyn34  happy_var_1)+	 =  HappyAbsSyn32+		 (happy_var_1:happy_var_3+	)+happyReduction_75 _ _ _  = notHappyAtAll ++happyReduce_76 = happySpecReduce_3 34 happyReduction_76+happyReduction_76 (HappyAbsSyn35  happy_var_3)+	_+	(HappyAbsSyn35  happy_var_1)+	 =  HappyAbsSyn34+		 ((happy_var_1,happy_var_3)+	)+happyReduction_76 _ _ _  = notHappyAtAll ++happyReduce_77 = happySpecReduce_0 35 happyReduction_77+happyReduction_77  =  HappyAbsSyn35+		 ([]+	)++happyReduce_78 = happySpecReduce_1 35 happyReduction_78+happyReduction_78 (HappyAbsSyn35  happy_var_1)+	 =  HappyAbsSyn35+		 (happy_var_1+	)+happyReduction_78 _  = notHappyAtAll ++happyReduce_79 = happySpecReduce_2 36 happyReduction_79+happyReduction_79 _+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (reverse happy_var_1+	)+happyReduction_79 _ _  = notHappyAtAll ++happyReduce_80 = happySpecReduce_1 36 happyReduction_80+happyReduction_80 _+	 =  HappyAbsSyn26+		 ([]+	)++happyReduce_81 = happySpecReduce_3 37 happyReduction_81+happyReduction_81 (HappyAbsSyn27  happy_var_3)+	_+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (funCons happy_var_3 happy_var_1+	)+happyReduction_81 _ _ _  = notHappyAtAll ++happyReduce_82 = happySpecReduce_1 37 happyReduction_82+happyReduction_82 (HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn26+		 ([happy_var_1]+	)+happyReduction_82 _  = notHappyAtAll ++happyReduce_83 = happySpecReduce_1 38 happyReduction_83+happyReduction_83 (HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn27+		 (happy_var_1+	)+happyReduction_83 _  = notHappyAtAll ++happyReduce_84 = happySpecReduce_1 38 happyReduction_84+happyReduction_84 (HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn27+		 (happy_var_1+	)+happyReduction_84 _  = notHappyAtAll ++happyReduce_85 = happySpecReduce_1 38 happyReduction_85+happyReduction_85 (HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn27+		 (happy_var_1+	)+happyReduction_85 _  = notHappyAtAll ++happyReduce_86 = happySpecReduce_3 39 happyReduction_86+happyReduction_86 _+	(HappyAbsSyn26  happy_var_2)+	_+	 =  HappyAbsSyn26+		 (happy_var_2+	)+happyReduction_86 _ _ _  = notHappyAtAll ++happyReduce_87 = happySpecReduce_3 39 happyReduction_87+happyReduction_87 _+	(HappyAbsSyn26  happy_var_2)+	_+	 =  HappyAbsSyn26+		 (happy_var_2+	)+happyReduction_87 _ _ _  = notHappyAtAll ++happyReduce_88 = happyReduce 4 40 happyReduction_88+happyReduction_88 ((HappyAbsSyn46  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	(HappyAbsSyn13  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn27+		 (hsTypeSig happy_var_2 (reverse happy_var_1) (fst happy_var_4) (snd happy_var_4)+	) `HappyStk` happyRest++happyReduce_89 = happySpecReduce_3 41 happyReduction_89+happyReduction_89 (HappyAbsSyn14  happy_var_3)+	_+	(HappyAbsSyn13  happy_var_1)+	 =  HappyAbsSyn13+		 (happy_var_3 : happy_var_1+	)+happyReduction_89 _ _ _  = notHappyAtAll ++happyReduce_90 = happyMonadReduce 1 41 happyReduction_90+happyReduction_90 ((HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( case happy_var_1 of+				   Qual _ _ -> parseError "bad qvar in vars."+				   _        -> return [happy_var_1]+	) (\r -> happyReturn (HappyAbsSyn13 r))++happyReduce_91 = happySpecReduce_3 42 happyReduction_91+happyReduction_91 (HappyAbsSyn42  happy_var_3)+	_+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn42+		 (hsTyFun happy_var_1 happy_var_3+	)+happyReduction_91 _ _ _  = notHappyAtAll ++happyReduce_92 = happySpecReduce_1 42 happyReduction_92+happyReduction_92 (HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn42+		 (happy_var_1+	)+happyReduction_92 _  = notHappyAtAll ++happyReduce_93 = happySpecReduce_2 43 happyReduction_93+happyReduction_93 (HappyAbsSyn42  happy_var_2)+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn42+		 (hsTyApp happy_var_1 happy_var_2+	)+happyReduction_93 _ _  = notHappyAtAll ++happyReduce_94 = happySpecReduce_1 43 happyReduction_94+happyReduction_94 (HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn42+		 (happy_var_1+	)+happyReduction_94 _  = notHappyAtAll ++happyReduce_95 = happySpecReduce_1 44 happyReduction_95+happyReduction_95 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn42+		 (hsTyCon happy_var_1+	)+happyReduction_95 _  = notHappyAtAll ++happyReduce_96 = happySpecReduce_1 44 happyReduction_96+happyReduction_96 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn42+		 (hsTyVar happy_var_1+	)+happyReduction_96 _  = notHappyAtAll ++happyReduce_97 = happySpecReduce_3 44 happyReduction_97+happyReduction_97 _+	(HappyAbsSyn35  happy_var_2)+	_+	 =  HappyAbsSyn42+		 (hsTyTuple (reverse happy_var_2)+	)+happyReduction_97 _ _ _  = notHappyAtAll ++happyReduce_98 = happySpecReduce_3 44 happyReduction_98+happyReduction_98 _+	(HappyAbsSyn42  happy_var_2)+	_+	 =  HappyAbsSyn42+		 (hsTyApp list_tycon happy_var_2+	)+happyReduction_98 _ _ _  = notHappyAtAll ++happyReduce_99 = happySpecReduce_3 44 happyReduction_99+happyReduction_99 _+	(HappyAbsSyn42  happy_var_2)+	_+	 =  HappyAbsSyn42+		 (happy_var_2+	)+happyReduction_99 _ _ _  = notHappyAtAll ++happyReduce_100 = happySpecReduce_1 45 happyReduction_100+happyReduction_100 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_100 _  = notHappyAtAll ++happyReduce_101 = happySpecReduce_2 45 happyReduction_101+happyReduction_101 _+	_+	 =  HappyAbsSyn14+		 (unit_tycon_name+	)++happyReduce_102 = happySpecReduce_2 45 happyReduction_102+happyReduction_102 _+	_+	 =  HappyAbsSyn14+		 (list_tycon_name+	)++happyReduce_103 = happySpecReduce_3 45 happyReduction_103+happyReduction_103 _+	_+	_+	 =  HappyAbsSyn14+		 (fun_tycon_name+	)++happyReduce_104 = happySpecReduce_3 45 happyReduction_104+happyReduction_104 _+	(HappyAbsSyn28  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (tuple_tycon_name happy_var_2+	)+happyReduction_104 _ _ _  = notHappyAtAll ++happyReduce_105 = happySpecReduce_3 46 happyReduction_105+happyReduction_105 (HappyAbsSyn42  happy_var_3)+	_+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn46+		 ((reverse (tupleTypeToContext happy_var_1), happy_var_3)+	)+happyReduction_105 _ _ _  = notHappyAtAll ++happyReduce_106 = happySpecReduce_1 46 happyReduction_106+happyReduction_106 (HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn46+		 (([], happy_var_1)+	)+happyReduction_106 _  = notHappyAtAll ++happyReduce_107 = happySpecReduce_3 47 happyReduction_107+happyReduction_107 (HappyAbsSyn42  happy_var_3)+	_+	(HappyAbsSyn35  happy_var_1)+	 =  HappyAbsSyn35+		 (happy_var_3 : happy_var_1+	)+happyReduction_107 _ _ _  = notHappyAtAll ++happyReduce_108 = happySpecReduce_3 47 happyReduction_108+happyReduction_108 (HappyAbsSyn42  happy_var_3)+	_+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn35+		 ([happy_var_3, happy_var_1]+	)+happyReduction_108 _ _ _  = notHappyAtAll ++happyReduce_109 = happySpecReduce_3 48 happyReduction_109+happyReduction_109 (HappyAbsSyn35  happy_var_3)+	_+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn48+		 ((reverse (tupleTypeToContext happy_var_1), happy_var_3)+	)+happyReduction_109 _ _ _  = notHappyAtAll ++happyReduce_110 = happySpecReduce_1 48 happyReduction_110+happyReduction_110 (HappyAbsSyn35  happy_var_1)+	 =  HappyAbsSyn48+		 (([], happy_var_1)+	)+happyReduction_110 _  = notHappyAtAll ++happyReduce_111 = happySpecReduce_2 49 happyReduction_111+happyReduction_111 (HappyAbsSyn35  happy_var_2)+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn35+		 (hsTyCon happy_var_1 : reverse happy_var_2+	)+happyReduction_111 _ _  = notHappyAtAll ++happyReduce_112 = happySpecReduce_1 49 happyReduction_112+happyReduction_112 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn35+		 ([hsTyCon happy_var_1]+	)+happyReduction_112 _  = notHappyAtAll ++happyReduce_113 = happySpecReduce_2 50 happyReduction_113+happyReduction_113 (HappyAbsSyn14  happy_var_2)+	(HappyAbsSyn35  happy_var_1)+	 =  HappyAbsSyn35+		 (hsTyVar happy_var_2 : happy_var_1+	)+happyReduction_113 _ _  = notHappyAtAll ++happyReduce_114 = happySpecReduce_1 50 happyReduction_114+happyReduction_114 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn35+		 ([hsTyVar happy_var_1]+	)+happyReduction_114 _  = notHappyAtAll ++happyReduce_115 = happyMonadReduce 1 51 happyReduction_115+happyReduction_115 ((HappyAbsSyn48  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( case snd happy_var_1 of+		             [Typ (HsTyCon nm)] -> return (fst happy_var_1,nm)+			     _ -> parseError "Primitive types are not allowed to have parameters"+	) (\r -> happyReturn (HappyAbsSyn51 r))++happyReduce_116 = happySpecReduce_3 52 happyReduction_116+happyReduction_116 (HappyAbsSyn53  happy_var_3)+	_+	(HappyAbsSyn52  happy_var_1)+	 =  HappyAbsSyn52+		 (happy_var_3 : happy_var_1+	)+happyReduction_116 _ _ _  = notHappyAtAll ++happyReduce_117 = happySpecReduce_1 52 happyReduction_117+happyReduction_117 (HappyAbsSyn53  happy_var_1)+	 =  HappyAbsSyn52+		 ([happy_var_1]+	)+happyReduction_117 _  = notHappyAtAll ++happyReduce_118 = happySpecReduce_2 53 happyReduction_118+happyReduction_118 (HappyAbsSyn54  happy_var_2)+	(HappyAbsSyn134  happy_var_1)+	 =  HappyAbsSyn53+		 (HsConDecl happy_var_1 (fst happy_var_2) (snd happy_var_2)+	)+happyReduction_118 _ _  = notHappyAtAll ++happyReduce_119 = happyReduce 4 53 happyReduction_119+happyReduction_119 ((HappyAbsSyn56  happy_var_4) `HappyStk`+	(HappyAbsSyn14  happy_var_3) `HappyStk`+	(HappyAbsSyn56  happy_var_2) `HappyStk`+	(HappyAbsSyn134  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn53+		 (HsConDecl happy_var_1 happy_var_3 [happy_var_2, happy_var_4]+	) `HappyStk` happyRest++happyReduce_120 = happyReduce 5 53 happyReduction_120+happyReduction_120 (_ `HappyStk`+	(HappyAbsSyn58  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_2) `HappyStk`+	(HappyAbsSyn134  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn53+		 (HsRecDecl happy_var_1 happy_var_2 (reverse happy_var_4)+	) `HappyStk` happyRest++happyReduce_121 = happyMonadReduce 1 54 happyReduction_121+happyReduction_121 ((HappyAbsSyn42  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( do { (c, ts) <- splitTyConApp happy_var_1 ;+					    return (c, map HsUnBangedType ts)+					  }+	) (\r -> happyReturn (HappyAbsSyn54 r))++happyReduce_122 = happySpecReduce_1 54 happyReduction_122+happyReduction_122 (HappyAbsSyn54  happy_var_1)+	 =  HappyAbsSyn54+		 (happy_var_1+	)+happyReduction_122 _  = notHappyAtAll ++happyReduce_123 = happyMonadReduce 3 55 happyReduction_123+happyReduction_123 ((HappyAbsSyn42  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn42  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( do { (c, ts) <- splitTyConApp happy_var_1 ;+		      return (c, map HsUnBangedType ts ++ [HsBangedType happy_var_3])+		    }+	) (\r -> happyReturn (HappyAbsSyn54 r))++happyReduce_124 = happySpecReduce_2 55 happyReduction_124+happyReduction_124 (HappyAbsSyn56  happy_var_2)+	(HappyAbsSyn54  happy_var_1)+	 =  HappyAbsSyn54+		 ((fst happy_var_1, snd happy_var_1 ++ [happy_var_2] )+	)+happyReduction_124 _ _  = notHappyAtAll ++happyReduce_125 = happySpecReduce_1 56 happyReduction_125+happyReduction_125 (HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn56+		 (HsUnBangedType happy_var_1+	)+happyReduction_125 _  = notHappyAtAll ++happyReduce_126 = happySpecReduce_2 56 happyReduction_126+happyReduction_126 (HappyAbsSyn42  happy_var_2)+	_+	 =  HappyAbsSyn56+		 (HsBangedType   happy_var_2+	)+happyReduction_126 _ _  = notHappyAtAll ++happyReduce_127 = happySpecReduce_1 57 happyReduction_127+happyReduction_127 (HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn56+		 (HsUnBangedType happy_var_1+	)+happyReduction_127 _  = notHappyAtAll ++happyReduce_128 = happySpecReduce_2 57 happyReduction_128+happyReduction_128 (HappyAbsSyn42  happy_var_2)+	_+	 =  HappyAbsSyn56+		 (HsBangedType   happy_var_2+	)+happyReduction_128 _ _  = notHappyAtAll ++happyReduce_129 = happySpecReduce_3 58 happyReduction_129+happyReduction_129 (HappyAbsSyn59  happy_var_3)+	_+	(HappyAbsSyn58  happy_var_1)+	 =  HappyAbsSyn58+		 (happy_var_3 : happy_var_1+	)+happyReduction_129 _ _ _  = notHappyAtAll ++happyReduce_130 = happySpecReduce_1 58 happyReduction_130+happyReduction_130 (HappyAbsSyn59  happy_var_1)+	 =  HappyAbsSyn58+		 ([happy_var_1]+	)+happyReduction_130 _  = notHappyAtAll ++happyReduce_131 = happySpecReduce_3 59 happyReduction_131+happyReduction_131 (HappyAbsSyn56  happy_var_3)+	_+	(HappyAbsSyn13  happy_var_1)+	 =  HappyAbsSyn59+		 ((reverse happy_var_1, happy_var_3)+	)+happyReduction_131 _ _ _  = notHappyAtAll ++happyReduce_132 = happySpecReduce_1 60 happyReduction_132+happyReduction_132 (HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn56+		 (HsUnBangedType happy_var_1+	)+happyReduction_132 _  = notHappyAtAll ++happyReduce_133 = happySpecReduce_2 60 happyReduction_133+happyReduction_133 (HappyAbsSyn42  happy_var_2)+	_+	 =  HappyAbsSyn56+		 (HsBangedType   happy_var_2+	)+happyReduction_133 _ _  = notHappyAtAll ++happyReduce_134 = happySpecReduce_0 61 happyReduction_134+happyReduction_134  =  HappyAbsSyn13+		 ([]+	)++happyReduce_135 = happySpecReduce_2 61 happyReduction_135+happyReduction_135 (HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn13+		 ([happy_var_2]+	)+happyReduction_135 _ _  = notHappyAtAll ++happyReduce_136 = happySpecReduce_3 61 happyReduction_136+happyReduction_136 _+	_+	_+	 =  HappyAbsSyn13+		 ([]+	)++happyReduce_137 = happyReduce 4 61 happyReduction_137+happyReduction_137 (_ `HappyStk`+	(HappyAbsSyn13  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn13+		 (reverse happy_var_3+	) `HappyStk` happyRest++happyReduce_138 = happySpecReduce_3 62 happyReduction_138+happyReduction_138 (HappyAbsSyn14  happy_var_3)+	_+	(HappyAbsSyn13  happy_var_1)+	 =  HappyAbsSyn13+		 (happy_var_3 : happy_var_1+	)+happyReduction_138 _ _ _  = notHappyAtAll ++happyReduce_139 = happySpecReduce_1 62 happyReduction_139+happyReduction_139 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn13+		 ([happy_var_1]+	)+happyReduction_139 _  = notHappyAtAll ++happyReduce_140 = happyReduce 4 63 happyReduction_140+happyReduction_140 (_ `HappyStk`+	(HappyAbsSyn26  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_141 = happyReduce 4 63 happyReduction_141+happyReduction_141 (_ `HappyStk`+	(HappyAbsSyn26  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_142 = happySpecReduce_0 63 happyReduction_142+happyReduction_142  =  HappyAbsSyn26+		 ([]+	)++happyReduce_143 = happyReduce 4 64 happyReduction_143+happyReduction_143 (_ `HappyStk`+	(HappyAbsSyn26  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn26  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (reverse happy_var_1 ++ reverse happy_var_3+	) `HappyStk` happyRest++happyReduce_144 = happySpecReduce_2 64 happyReduction_144+happyReduction_144 _+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (reverse happy_var_1+	)+happyReduction_144 _ _  = notHappyAtAll ++happyReduce_145 = happySpecReduce_1 64 happyReduction_145+happyReduction_145 _+	 =  HappyAbsSyn26+		 ([]+	)++happyReduce_146 = happySpecReduce_3 65 happyReduction_146+happyReduction_146 (HappyAbsSyn27  happy_var_3)+	_+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (funCons happy_var_3  happy_var_1+	)+happyReduction_146 _ _ _  = notHappyAtAll ++happyReduce_147 = happySpecReduce_1 65 happyReduction_147+happyReduction_147 (HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn26+		 ([happy_var_1]+	)+happyReduction_147 _  = notHappyAtAll ++happyReduce_148 = happySpecReduce_3 66 happyReduction_148+happyReduction_148 (HappyAbsSyn27  happy_var_3)+	_+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (funCons happy_var_3  happy_var_1+	)+happyReduction_148 _ _ _  = notHappyAtAll ++happyReduce_149 = happySpecReduce_1 66 happyReduction_149+happyReduction_149 (HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn26+		 ([happy_var_1]+	)+happyReduction_149 _  = notHappyAtAll ++happyReduce_150 = happyReduce 4 67 happyReduction_150+happyReduction_150 (_ `HappyStk`+	(HappyAbsSyn26  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_151 = happyReduce 4 67 happyReduction_151+happyReduction_151 (_ `HappyStk`+	(HappyAbsSyn26  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_152 = happySpecReduce_0 67 happyReduction_152+happyReduction_152  =  HappyAbsSyn26+		 ([]+	)++happyReduce_153 = happySpecReduce_2 68 happyReduction_153+happyReduction_153 _+	(HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (reverse happy_var_1+	)+happyReduction_153 _ _  = notHappyAtAll ++happyReduce_154 = happySpecReduce_1 68 happyReduction_154+happyReduction_154 _+	 =  HappyAbsSyn26+		 ([]+	)++happyReduce_155 = happyReduce 4 69 happyReduction_155+happyReduction_155 ((HappyAbsSyn26  happy_var_4) `HappyStk`+	(HappyAbsSyn72  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	(HappyAbsSyn70  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn27+		 (mkFunDef' happy_var_1 happy_var_2 happy_var_3 happy_var_4+	) `HappyStk` happyRest++happyReduce_156 = happyReduce 4 69 happyReduction_156+happyReduction_156 ((HappyAbsSyn26  happy_var_4) `HappyStk`+	(HappyAbsSyn72  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	(HappyAbsSyn99  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn27+		 (hsPatBind happy_var_2 happy_var_1 happy_var_3 happy_var_4+	) `HappyStk` happyRest++happyReduce_157 = happySpecReduce_2 70 happyReduction_157+happyReduction_157 (HappyAbsSyn103  happy_var_2)+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn70+		 ((happy_var_1,happy_var_2)+	)+happyReduction_157 _ _  = notHappyAtAll ++happyReduce_158 = happySpecReduce_3 70 happyReduction_158+happyReduction_158 (HappyAbsSyn99  happy_var_3)+	(HappyAbsSyn14  happy_var_2)+	(HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn70+		 ((happy_var_2,[happy_var_1,happy_var_3])+	)+happyReduction_158 _ _ _  = notHappyAtAll ++happyReduce_159 = happyReduce 4 70 happyReduction_159+happyReduction_159 ((HappyAbsSyn103  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn70  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn70+		 ((fst happy_var_2,snd happy_var_2++happy_var_4)+	) `HappyStk` happyRest++happyReduce_160 = happySpecReduce_2 71 happyReduction_160+happyReduction_160 (HappyAbsSyn26  happy_var_2)+	_+	 =  HappyAbsSyn26+		 (happy_var_2+	)+happyReduction_160 _ _  = notHappyAtAll ++happyReduce_161 = happySpecReduce_0 71 happyReduction_161+happyReduction_161  =  HappyAbsSyn26+		 ([]+	)++happyReduce_162 = happySpecReduce_2 72 happyReduction_162+happyReduction_162 (HappyAbsSyn75  happy_var_2)+	_+	 =  HappyAbsSyn72+		 (HsBody happy_var_2+	)+happyReduction_162 _ _  = notHappyAtAll ++happyReduce_163 = happySpecReduce_1 72 happyReduction_163+happyReduction_163 (HappyAbsSyn73  happy_var_1)+	 =  HappyAbsSyn72+		 (HsGuard (reverse happy_var_1)+	)+happyReduction_163 _  = notHappyAtAll ++happyReduce_164 = happySpecReduce_2 73 happyReduction_164+happyReduction_164 (HappyAbsSyn74  happy_var_2)+	(HappyAbsSyn73  happy_var_1)+	 =  HappyAbsSyn73+		 (happy_var_2 : happy_var_1+	)+happyReduction_164 _ _  = notHappyAtAll ++happyReduce_165 = happySpecReduce_1 73 happyReduction_165+happyReduction_165 (HappyAbsSyn74  happy_var_1)+	 =  HappyAbsSyn73+		 ([happy_var_1]+	)+happyReduction_165 _  = notHappyAtAll ++happyReduce_166 = happyReduce 5 74 happyReduction_166+happyReduction_166 ((HappyAbsSyn75  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn134  happy_var_3) `HappyStk`+	(HappyAbsSyn75  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn74+		 ((happy_var_3, happy_var_2, happy_var_5)+	) `HappyStk` happyRest++happyReduce_167 = happyReduce 4 75 happyReduction_167+happyReduction_167 ((HappyAbsSyn46  happy_var_4) `HappyStk`+	(HappyAbsSyn134  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn75  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsExpTypeSig happy_var_3 happy_var_1 (fst happy_var_4) (snd happy_var_4)+	) `HappyStk` happyRest++happyReduce_168 = happySpecReduce_1 75 happyReduction_168+happyReduction_168 (HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (happy_var_1+	)+happyReduction_168 _  = notHappyAtAll ++happyReduce_169 = happySpecReduce_1 76 happyReduction_169+happyReduction_169 (HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (happy_var_1+	)+happyReduction_169 _  = notHappyAtAll ++happyReduce_170 = happySpecReduce_3 76 happyReduction_170+happyReduction_170 (HappyAbsSyn75  happy_var_3)+	(HappyAbsSyn120  happy_var_2)+	(HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (hsInfixApp happy_var_1 happy_var_2 happy_var_3+	)+happyReduction_170 _ _ _  = notHappyAtAll ++happyReduce_171 = happyReduce 4 77 happyReduction_171+happyReduction_171 ((HappyAbsSyn75  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn103  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsLambda happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_172 = happyReduce 4 77 happyReduction_172+happyReduction_172 ((HappyAbsSyn75  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn26  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsLet happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_173 = happyReduce 6 77 happyReduction_173+happyReduction_173 ((HappyAbsSyn75  happy_var_6) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn75  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn75  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsIf happy_var_2 happy_var_4 happy_var_6+	) `HappyStk` happyRest++happyReduce_174 = happyReduce 4 77 happyReduction_174+happyReduction_174 ((HappyAbsSyn87  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn75  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsCase happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_175 = happySpecReduce_2 77 happyReduction_175+happyReduction_175 (HappyAbsSyn75  happy_var_2)+	_+	 =  HappyAbsSyn75+		 (hsNegApp happy_var_2+	)+happyReduction_175 _ _  = notHappyAtAll ++happyReduce_176 = happySpecReduce_2 77 happyReduction_176+happyReduction_176 (HappyAbsSyn93  happy_var_2)+	_+	 =  HappyAbsSyn75+		 (hsDo (atoms2Stmt happy_var_2)+	)+happyReduction_176 _ _  = notHappyAtAll ++happyReduce_177 = happySpecReduce_1 77 happyReduction_177+happyReduction_177 (HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (happy_var_1+	)+happyReduction_177 _  = notHappyAtAll ++happyReduce_178 = happySpecReduce_2 78 happyReduction_178+happyReduction_178 (HappyAbsSyn75  happy_var_2)+	(HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (hsApp happy_var_1 happy_var_2+	)+happyReduction_178 _ _  = notHappyAtAll ++happyReduce_179 = happySpecReduce_1 78 happyReduction_179+happyReduction_179 (HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (happy_var_1+	)+happyReduction_179 _  = notHappyAtAll ++happyReduce_180 = happyReduce 4 79 happyReduction_180+happyReduction_180 (_ `HappyStk`+	(HappyAbsSyn96  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn75  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (mkRecord happy_var_1 (reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_181 = happySpecReduce_1 79 happyReduction_181+happyReduction_181 (HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (happy_var_1+	)+happyReduction_181 _  = notHappyAtAll ++happyReduce_182 = happySpecReduce_1 80 happyReduction_182+happyReduction_182 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn75+		 (hsEVar (happy_var_1 :: HsName)+	)+happyReduction_182 _  = notHappyAtAll ++happyReduce_183 = happySpecReduce_1 80 happyReduction_183+happyReduction_183 (HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (happy_var_1+	)+happyReduction_183 _  = notHappyAtAll ++happyReduce_184 = happySpecReduce_1 80 happyReduction_184+happyReduction_184 (HappyAbsSyn132  happy_var_1)+	 =  HappyAbsSyn75+		 (hsLit happy_var_1+	)+happyReduction_184 _  = notHappyAtAll ++happyReduce_185 = happySpecReduce_3 80 happyReduction_185+happyReduction_185 _+	(HappyAbsSyn75  happy_var_2)+	_+	 =  HappyAbsSyn75+		 (hsParen happy_var_2+	)+happyReduction_185 _ _ _  = notHappyAtAll ++happyReduce_186 = happySpecReduce_3 80 happyReduction_186+happyReduction_186 _+	(HappyAbsSyn82  happy_var_2)+	_+	 =  HappyAbsSyn75+		 (hsTuple (reverse happy_var_2)+	)+happyReduction_186 _ _ _  = notHappyAtAll ++happyReduce_187 = happySpecReduce_3 80 happyReduction_187+happyReduction_187 _+	(HappyAbsSyn75  happy_var_2)+	_+	 =  HappyAbsSyn75+		 (happy_var_2+	)+happyReduction_187 _ _ _  = notHappyAtAll ++happyReduce_188 = happyReduce 4 80 happyReduction_188+happyReduction_188 (_ `HappyStk`+	(HappyAbsSyn120  happy_var_3) `HappyStk`+	(HappyAbsSyn75  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsLeftSection happy_var_2 happy_var_3+	) `HappyStk` happyRest++happyReduce_189 = happyReduce 4 80 happyReduction_189+happyReduction_189 (_ `HappyStk`+	(HappyAbsSyn75  happy_var_3) `HappyStk`+	(HappyAbsSyn120  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsRightSection happy_var_2 happy_var_3+	) `HappyStk` happyRest++happyReduce_190 = happySpecReduce_3 80 happyReduction_190+happyReduction_190 (HappyAbsSyn75  happy_var_3)+	_+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn75+		 (hsAsPat happy_var_1 happy_var_3+	)+happyReduction_190 _ _ _  = notHappyAtAll ++happyReduce_191 = happySpecReduce_1 80 happyReduction_191+happyReduction_191 _+	 =  HappyAbsSyn75+		 (hsWildCard+	)++happyReduce_192 = happySpecReduce_2 80 happyReduction_192+happyReduction_192 (HappyAbsSyn75  happy_var_2)+	_+	 =  HappyAbsSyn75+		 (hsIrrPat happy_var_2+	)+happyReduction_192 _ _  = notHappyAtAll ++happyReduce_193 = happySpecReduce_2 81 happyReduction_193+happyReduction_193 _+	(HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (happy_var_1 + 1+	)+happyReduction_193 _ _  = notHappyAtAll ++happyReduce_194 = happySpecReduce_1 81 happyReduction_194+happyReduction_194 _+	 =  HappyAbsSyn28+		 (1+	)++happyReduce_195 = happySpecReduce_3 82 happyReduction_195+happyReduction_195 (HappyAbsSyn75  happy_var_3)+	_+	(HappyAbsSyn82  happy_var_1)+	 =  HappyAbsSyn82+		 (happy_var_3 : happy_var_1+	)+happyReduction_195 _ _ _  = notHappyAtAll ++happyReduce_196 = happySpecReduce_3 82 happyReduction_196+happyReduction_196 (HappyAbsSyn75  happy_var_3)+	_+	(HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn82+		 ([happy_var_3, happy_var_1]+	)+happyReduction_196 _ _ _  = notHappyAtAll ++happyReduce_197 = happySpecReduce_1 83 happyReduction_197+happyReduction_197 (HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (hsList [happy_var_1]+	)+happyReduction_197 _  = notHappyAtAll ++happyReduce_198 = happySpecReduce_1 83 happyReduction_198+happyReduction_198 (HappyAbsSyn82  happy_var_1)+	 =  HappyAbsSyn75+		 (hsList (reverse happy_var_1)+	)+happyReduction_198 _  = notHappyAtAll ++happyReduce_199 = happySpecReduce_2 83 happyReduction_199+happyReduction_199 _+	(HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (hsEnumFrom happy_var_1+	)+happyReduction_199 _ _  = notHappyAtAll ++happyReduce_200 = happyReduce 4 83 happyReduction_200+happyReduction_200 (_ `HappyStk`+	(HappyAbsSyn75  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn75  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsEnumFromThen happy_var_1 happy_var_3+	) `HappyStk` happyRest++happyReduce_201 = happySpecReduce_3 83 happyReduction_201+happyReduction_201 (HappyAbsSyn75  happy_var_3)+	_+	(HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (hsEnumFromTo happy_var_1 happy_var_3+	)+happyReduction_201 _ _ _  = notHappyAtAll ++happyReduce_202 = happyReduce 5 83 happyReduction_202+happyReduction_202 ((HappyAbsSyn75  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn75  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn75  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsEnumFromThenTo happy_var_1 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_203 = happySpecReduce_3 83 happyReduction_203+happyReduction_203 (HappyAbsSyn85  happy_var_3)+	_+	(HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn75+		 (hsListComp (atoms2Stmt (reverse happy_var_3 ++ [HsQualifierAtom happy_var_1]))+	)+happyReduction_203 _ _ _  = notHappyAtAll ++happyReduce_204 = happySpecReduce_3 84 happyReduction_204+happyReduction_204 (HappyAbsSyn75  happy_var_3)+	_+	(HappyAbsSyn82  happy_var_1)+	 =  HappyAbsSyn82+		 (happy_var_3 : happy_var_1+	)+happyReduction_204 _ _ _  = notHappyAtAll ++happyReduce_205 = happySpecReduce_3 84 happyReduction_205+happyReduction_205 (HappyAbsSyn75  happy_var_3)+	_+	(HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn82+		 ([happy_var_3,happy_var_1]+	)+happyReduction_205 _ _ _  = notHappyAtAll ++happyReduce_206 = happySpecReduce_3 85 happyReduction_206+happyReduction_206 (HappyAbsSyn86  happy_var_3)+	_+	(HappyAbsSyn85  happy_var_1)+	 =  HappyAbsSyn85+		 (happy_var_3 : happy_var_1+	)+happyReduction_206 _ _ _  = notHappyAtAll ++happyReduce_207 = happySpecReduce_1 85 happyReduction_207+happyReduction_207 (HappyAbsSyn86  happy_var_1)+	 =  HappyAbsSyn85+		 ([happy_var_1]+	)+happyReduction_207 _  = notHappyAtAll ++happyReduce_208 = happyMonadReduce 3 86 happyReduction_208+happyReduction_208 ((HappyAbsSyn75  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn75  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( do { p <- expToPat happy_var_1 ; +                                                return (HsGeneratorAtom p happy_var_3)+					      }+	) (\r -> happyReturn (HappyAbsSyn86 r))++happyReduce_209 = happySpecReduce_1 86 happyReduction_209+happyReduction_209 (HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn86+		 (HsQualifierAtom happy_var_1+	)+happyReduction_209 _  = notHappyAtAll ++happyReduce_210 = happySpecReduce_2 86 happyReduction_210+happyReduction_210 (HappyAbsSyn26  happy_var_2)+	_+	 =  HappyAbsSyn86+		 (HsLetStmtAtom   happy_var_2+	)+happyReduction_210 _ _  = notHappyAtAll ++happyReduce_211 = happyReduce 4 87 happyReduction_211+happyReduction_211 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn87  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn87+		 (reverse happy_var_2+	) `HappyStk` happyRest++happyReduce_212 = happyReduce 4 87 happyReduction_212+happyReduction_212 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn87  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn87+		 (reverse happy_var_2+	) `HappyStk` happyRest++happyReduce_213 = happySpecReduce_3 88 happyReduction_213+happyReduction_213 (HappyAbsSyn89  happy_var_3)+	_+	(HappyAbsSyn87  happy_var_1)+	 =  HappyAbsSyn87+		 (happy_var_3 : happy_var_1+	)+happyReduction_213 _ _ _  = notHappyAtAll ++happyReduce_214 = happySpecReduce_1 88 happyReduction_214+happyReduction_214 (HappyAbsSyn89  happy_var_1)+	 =  HappyAbsSyn87+		 ([happy_var_1]+	)+happyReduction_214 _  = notHappyAtAll ++happyReduce_215 = happySpecReduce_3 89 happyReduction_215+happyReduction_215 (HappyAbsSyn72  happy_var_3)+	(HappyAbsSyn134  happy_var_2)+	(HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn89+		 (HsAlt happy_var_2 happy_var_1 happy_var_3 []+	)+happyReduction_215 _ _ _  = notHappyAtAll ++happyReduce_216 = happyReduce 5 89 happyReduction_216+happyReduction_216 ((HappyAbsSyn26  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn72  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	(HappyAbsSyn99  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn89+		 (HsAlt happy_var_2 happy_var_1 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_217 = happySpecReduce_2 90 happyReduction_217+happyReduction_217 (HappyAbsSyn75  happy_var_2)+	_+	 =  HappyAbsSyn72+		 (HsBody happy_var_2+	)+happyReduction_217 _ _  = notHappyAtAll ++happyReduce_218 = happySpecReduce_1 90 happyReduction_218+happyReduction_218 (HappyAbsSyn73  happy_var_1)+	 =  HappyAbsSyn72+		 (HsGuard (reverse happy_var_1)+	)+happyReduction_218 _  = notHappyAtAll ++happyReduce_219 = happySpecReduce_2 91 happyReduction_219+happyReduction_219 (HappyAbsSyn74  happy_var_2)+	(HappyAbsSyn73  happy_var_1)+	 =  HappyAbsSyn73+		 (happy_var_2 : happy_var_1+	)+happyReduction_219 _ _  = notHappyAtAll ++happyReduce_220 = happySpecReduce_1 91 happyReduction_220+happyReduction_220 (HappyAbsSyn74  happy_var_1)+	 =  HappyAbsSyn73+		 ([happy_var_1]+	)+happyReduction_220 _  = notHappyAtAll ++happyReduce_221 = happyReduce 5 92 happyReduction_221+happyReduction_221 ((HappyAbsSyn75  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn75  happy_var_3) `HappyStk`+	(HappyAbsSyn134  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn74+		 ((happy_var_2, happy_var_3, happy_var_5)+	) `HappyStk` happyRest++happyReduce_222 = happySpecReduce_3 93 happyReduction_222+happyReduction_222 _+	(HappyAbsSyn93  happy_var_2)+	_+	 =  HappyAbsSyn93+		 (happy_var_2+	)+happyReduction_222 _ _ _  = notHappyAtAll ++happyReduce_223 = happySpecReduce_3 93 happyReduction_223+happyReduction_223 _+	(HappyAbsSyn93  happy_var_2)+	_+	 =  HappyAbsSyn93+		 (happy_var_2+	)+happyReduction_223 _ _ _  = notHappyAtAll ++happyReduce_224 = happySpecReduce_3 94 happyReduction_224+happyReduction_224 (HappyAbsSyn75  happy_var_3)+	_+	(HappyAbsSyn93  happy_var_1)+	 =  HappyAbsSyn93+		 (reverse (HsQualifierAtom happy_var_3 : happy_var_1)+	)+happyReduction_224 _ _ _  = notHappyAtAll ++happyReduce_225 = happySpecReduce_1 94 happyReduction_225+happyReduction_225 (HappyAbsSyn75  happy_var_1)+	 =  HappyAbsSyn93+		 ([HsQualifierAtom happy_var_1]+	)+happyReduction_225 _  = notHappyAtAll ++happyReduce_226 = happySpecReduce_3 95 happyReduction_226+happyReduction_226 (HappyAbsSyn86  happy_var_3)+	_+	(HappyAbsSyn93  happy_var_1)+	 =  HappyAbsSyn93+		 (happy_var_3 : happy_var_1+	)+happyReduction_226 _ _ _  = notHappyAtAll ++happyReduce_227 = happySpecReduce_1 95 happyReduction_227+happyReduction_227 (HappyAbsSyn86  happy_var_1)+	 =  HappyAbsSyn93+		 ([happy_var_1]+	)+happyReduction_227 _  = notHappyAtAll ++happyReduce_228 = happySpecReduce_0 96 happyReduction_228+happyReduction_228  =  HappyAbsSyn96+		 ([]+	)++happyReduce_229 = happySpecReduce_1 96 happyReduction_229+happyReduction_229 (HappyAbsSyn96  happy_var_1)+	 =  HappyAbsSyn96+		 (happy_var_1+	)+happyReduction_229 _  = notHappyAtAll ++happyReduce_230 = happySpecReduce_3 97 happyReduction_230+happyReduction_230 (HappyAbsSyn98  happy_var_3)+	_+	(HappyAbsSyn96  happy_var_1)+	 =  HappyAbsSyn96+		 (happy_var_3 : happy_var_1+	)+happyReduction_230 _ _ _  = notHappyAtAll ++happyReduce_231 = happySpecReduce_1 97 happyReduction_231+happyReduction_231 (HappyAbsSyn98  happy_var_1)+	 =  HappyAbsSyn96+		 ([happy_var_1]+	)+happyReduction_231 _  = notHappyAtAll ++happyReduce_232 = happySpecReduce_3 98 happyReduction_232+happyReduction_232 (HappyAbsSyn75  happy_var_3)+	_+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn98+		 (HsFieldUpdate happy_var_1 happy_var_3+	)+happyReduction_232 _ _ _  = notHappyAtAll ++happyReduce_233 = happySpecReduce_1 99 happyReduction_233+happyReduction_233 (HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn99+		 (happy_var_1+	)+happyReduction_233 _  = notHappyAtAll ++happyReduce_234 = happySpecReduce_1 100 happyReduction_234+happyReduction_234 (HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn99+		 (happy_var_1+	)+happyReduction_234 _  = notHappyAtAll ++happyReduce_235 = happySpecReduce_3 100 happyReduction_235+happyReduction_235 (HappyAbsSyn99  happy_var_3)+	(HappyAbsSyn14  happy_var_2)+	(HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn99+		 (hsPInfixApp happy_var_1 (HsCon happy_var_2) happy_var_3+	)+happyReduction_235 _ _ _  = notHappyAtAll ++happyReduce_236 = happySpecReduce_2 101 happyReduction_236+happyReduction_236 (HappyAbsSyn103  happy_var_2)+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn99+		 (hsPApp happy_var_1 happy_var_2+	)+happyReduction_236 _ _  = notHappyAtAll ++happyReduce_237 = happySpecReduce_2 101 happyReduction_237+happyReduction_237 (HappyAbsSyn132  happy_var_2)+	_+	 =  HappyAbsSyn99+		 (hsPNeg (hsPLit happy_var_2)+	)+happyReduction_237 _ _  = notHappyAtAll ++happyReduce_238 = happySpecReduce_1 101 happyReduction_238+happyReduction_238 (HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn99+		 (happy_var_1+	)+happyReduction_238 _  = notHappyAtAll ++happyReduce_239 = happySpecReduce_1 102 happyReduction_239+happyReduction_239 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn99+		 (hsPVar happy_var_1+	)+happyReduction_239 _  = notHappyAtAll ++happyReduce_240 = happySpecReduce_3 102 happyReduction_240+happyReduction_240 (HappyAbsSyn99  happy_var_3)+	_+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn99+		 (hsPAsPat happy_var_1 happy_var_3+	)+happyReduction_240 _ _ _  = notHappyAtAll ++happyReduce_241 = happySpecReduce_1 102 happyReduction_241+happyReduction_241 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn99+		 (hsPCon happy_var_1+	)+happyReduction_241 _  = notHappyAtAll ++happyReduce_242 = happySpecReduce_2 102 happyReduction_242+happyReduction_242 _+	_+	 =  HappyAbsSyn99+		 (hsPCon (qualify "Prelude" "()")+	)++happyReduce_243 = happyReduce 4 102 happyReduction_243+happyReduction_243 (_ `HappyStk`+	(HappyAbsSyn105  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn99+		 (hsPRec happy_var_1 happy_var_3+	) `HappyStk` happyRest++happyReduce_244 = happySpecReduce_1 102 happyReduction_244+happyReduction_244 (HappyAbsSyn132  happy_var_1)+	 =  HappyAbsSyn99+		 (hsPLit happy_var_1+	)+happyReduction_244 _  = notHappyAtAll ++happyReduce_245 = happySpecReduce_1 102 happyReduction_245+happyReduction_245 _+	 =  HappyAbsSyn99+		 (hsPWildCard+	)++happyReduce_246 = happySpecReduce_3 102 happyReduction_246+happyReduction_246 _+	(HappyAbsSyn99  happy_var_2)+	_+	 =  HappyAbsSyn99+		 (hsPParen happy_var_2+	)+happyReduction_246 _ _ _  = notHappyAtAll ++happyReduce_247 = happySpecReduce_3 102 happyReduction_247+happyReduction_247 _+	(HappyAbsSyn103  happy_var_2)+	_+	 =  HappyAbsSyn99+		 (hsPTuple happy_var_2+	)+happyReduction_247 _ _ _  = notHappyAtAll ++happyReduce_248 = happySpecReduce_3 102 happyReduction_248+happyReduction_248 _+	(HappyAbsSyn103  happy_var_2)+	_+	 =  HappyAbsSyn99+		 (hsPList happy_var_2+	)+happyReduction_248 _ _ _  = notHappyAtAll ++happyReduce_249 = happySpecReduce_2 102 happyReduction_249+happyReduction_249 (HappyAbsSyn99  happy_var_2)+	_+	 =  HappyAbsSyn99+		 (hsPIrrPat happy_var_2+	)+happyReduction_249 _ _  = notHappyAtAll ++happyReduce_250 = happySpecReduce_2 103 happyReduction_250+happyReduction_250 (HappyAbsSyn103  happy_var_2)+	(HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn103+		 (happy_var_1 : happy_var_2+	)+happyReduction_250 _ _  = notHappyAtAll ++happyReduce_251 = happySpecReduce_0 104 happyReduction_251+happyReduction_251  =  HappyAbsSyn103+		 ([]+	)++happyReduce_252 = happySpecReduce_2 104 happyReduction_252+happyReduction_252 (HappyAbsSyn103  happy_var_2)+	(HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn103+		 (happy_var_1 : happy_var_2+	)+happyReduction_252 _ _  = notHappyAtAll ++happyReduce_253 = happySpecReduce_0 105 happyReduction_253+happyReduction_253  =  HappyAbsSyn105+		 ([]+	)++happyReduce_254 = happySpecReduce_1 105 happyReduction_254+happyReduction_254 (HappyAbsSyn105  happy_var_1)+	 =  HappyAbsSyn105+		 (happy_var_1+	)+happyReduction_254 _  = notHappyAtAll ++happyReduce_255 = happySpecReduce_3 106 happyReduction_255+happyReduction_255 (HappyAbsSyn105  happy_var_3)+	_+	(HappyAbsSyn107  happy_var_1)+	 =  HappyAbsSyn105+		 (happy_var_1 : happy_var_3+	)+happyReduction_255 _ _ _  = notHappyAtAll ++happyReduce_256 = happySpecReduce_1 106 happyReduction_256+happyReduction_256 (HappyAbsSyn107  happy_var_1)+	 =  HappyAbsSyn105+		 ([happy_var_1]+	)+happyReduction_256 _  = notHappyAtAll ++happyReduce_257 = happySpecReduce_3 107 happyReduction_257+happyReduction_257 (HappyAbsSyn99  happy_var_3)+	_+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn107+		 (HsPFieldPat happy_var_1 happy_var_3+	)+happyReduction_257 _ _ _  = notHappyAtAll ++happyReduce_258 = happySpecReduce_3 108 happyReduction_258+happyReduction_258 (HappyAbsSyn103  happy_var_3)+	_+	(HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn103+		 (happy_var_1 : happy_var_3+	)+happyReduction_258 _ _ _  = notHappyAtAll ++happyReduce_259 = happySpecReduce_3 108 happyReduction_259+happyReduction_259 (HappyAbsSyn99  happy_var_3)+	_+	(HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn103+		 ([happy_var_1, happy_var_3]+	)+happyReduction_259 _ _ _  = notHappyAtAll ++happyReduce_260 = happySpecReduce_0 109 happyReduction_260+happyReduction_260  =  HappyAbsSyn103+		 ([]+	)++happyReduce_261 = happySpecReduce_1 109 happyReduction_261+happyReduction_261 (HappyAbsSyn103  happy_var_1)+	 =  HappyAbsSyn103+		 (happy_var_1+	)+happyReduction_261 _  = notHappyAtAll ++happyReduce_262 = happySpecReduce_3 110 happyReduction_262+happyReduction_262 (HappyAbsSyn103  happy_var_3)+	_+	(HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn103+		 (happy_var_1 : happy_var_3+	)+happyReduction_262 _ _ _  = notHappyAtAll ++happyReduce_263 = happySpecReduce_1 110 happyReduction_263+happyReduction_263 (HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn103+		 ([happy_var_1]+	)+happyReduction_263 _  = notHappyAtAll ++happyReduce_264 = happySpecReduce_2 111 happyReduction_264+happyReduction_264 _+	_+	 =  HappyAbsSyn75+		 (hsECon (qualify "Prelude" "()")+	)++happyReduce_265 = happySpecReduce_2 111 happyReduction_265+happyReduction_265 _+	_+	 =  HappyAbsSyn75+		 (hsList []+	)++happyReduce_266 = happySpecReduce_3 111 happyReduction_266+happyReduction_266 _+	(HappyAbsSyn28  happy_var_2)+	_+	 =  HappyAbsSyn75+		 (hsECon (qualify "Prelude" (tuple happy_var_2))+	)+happyReduction_266 _ _ _  = notHappyAtAll ++happyReduce_267 = happyReduce 4 111 happyReduction_267+happyReduction_267 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal (QModId happy_var_1)) `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsECon (qualify happy_var_1 "()")+	) `HappyStk` happyRest++happyReduce_268 = happyReduce 4 111 happyReduction_268+happyReduction_268 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsList []+	) `HappyStk` happyRest++happyReduce_269 = happyReduce 5 111 happyReduction_269+happyReduction_269 (_ `HappyStk`+	(HappyAbsSyn28  happy_var_4) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal (QModId happy_var_1)) `HappyStk`+	happyRest)+	 = HappyAbsSyn75+		 (hsECon (qualify happy_var_1 (tuple happy_var_4))+	) `HappyStk` happyRest++happyReduce_270 = happySpecReduce_1 111 happyReduction_270+happyReduction_270 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn75+		 (hsECon happy_var_1+	)+happyReduction_270 _  = notHappyAtAll ++happyReduce_271 = happySpecReduce_1 112 happyReduction_271+happyReduction_271 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_271 _  = notHappyAtAll ++happyReduce_272 = happySpecReduce_3 112 happyReduction_272+happyReduction_272 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_272 _ _ _  = notHappyAtAll ++happyReduce_273 = happySpecReduce_1 113 happyReduction_273+happyReduction_273 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_273 _  = notHappyAtAll ++happyReduce_274 = happySpecReduce_3 113 happyReduction_274+happyReduction_274 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_274 _ _ _  = notHappyAtAll ++happyReduce_275 = happySpecReduce_1 114 happyReduction_275+happyReduction_275 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_275 _  = notHappyAtAll ++happyReduce_276 = happySpecReduce_3 114 happyReduction_276+happyReduction_276 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_276 _ _ _  = notHappyAtAll ++happyReduce_277 = happySpecReduce_1 115 happyReduction_277+happyReduction_277 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_277 _  = notHappyAtAll ++happyReduce_278 = happySpecReduce_3 115 happyReduction_278+happyReduction_278 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_278 _ _ _  = notHappyAtAll ++happyReduce_279 = happySpecReduce_1 116 happyReduction_279+happyReduction_279 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_279 _  = notHappyAtAll ++happyReduce_280 = happySpecReduce_3 116 happyReduction_280+happyReduction_280 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_280 _ _ _  = notHappyAtAll ++happyReduce_281 = happySpecReduce_1 117 happyReduction_281+happyReduction_281 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_281 _  = notHappyAtAll ++happyReduce_282 = happySpecReduce_3 117 happyReduction_282+happyReduction_282 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_282 _ _ _  = notHappyAtAll ++happyReduce_283 = happySpecReduce_1 118 happyReduction_283+happyReduction_283 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_283 _  = notHappyAtAll ++happyReduce_284 = happySpecReduce_3 118 happyReduction_284+happyReduction_284 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_284 _ _ _  = notHappyAtAll ++happyReduce_285 = happySpecReduce_1 119 happyReduction_285+happyReduction_285 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_285 _  = notHappyAtAll ++happyReduce_286 = happySpecReduce_3 119 happyReduction_286+happyReduction_286 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_286 _ _ _  = notHappyAtAll ++happyReduce_287 = happySpecReduce_1 120 happyReduction_287+happyReduction_287 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn120+		 (hsVar happy_var_1+	)+happyReduction_287 _  = notHappyAtAll ++happyReduce_288 = happySpecReduce_1 120 happyReduction_288+happyReduction_288 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn120+		 (hsCon happy_var_1+	)+happyReduction_288 _  = notHappyAtAll ++happyReduce_289 = happySpecReduce_1 121 happyReduction_289+happyReduction_289 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn120+		 (hsVar happy_var_1+	)+happyReduction_289 _  = notHappyAtAll ++happyReduce_290 = happySpecReduce_1 121 happyReduction_290+happyReduction_290 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn120+		 (hsCon happy_var_1+	)+happyReduction_290 _  = notHappyAtAll ++happyReduce_291 = happySpecReduce_1 122 happyReduction_291+happyReduction_291 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_291 _  = notHappyAtAll ++happyReduce_292 = happySpecReduce_1 122 happyReduction_292+happyReduction_292 (HappyTerminal (QVarId happy_var_1))+	 =  HappyAbsSyn14+		 (uncurry (Qual . Module) happy_var_1+	)+happyReduction_292 _  = notHappyAtAll ++happyReduce_293 = happySpecReduce_1 123 happyReduction_293+happyReduction_293 (HappyTerminal (VarId happy_var_1))+	 =  HappyAbsSyn14+		 (UnQual happy_var_1+	)+happyReduction_293 _  = notHappyAtAll ++happyReduce_294 = happySpecReduce_1 123 happyReduction_294+happyReduction_294 _+	 =  HappyAbsSyn14+		 (as_name+	)++happyReduce_295 = happySpecReduce_1 123 happyReduction_295+happyReduction_295 _+	 =  HappyAbsSyn14+		 (qualified_name+	)++happyReduce_296 = happySpecReduce_1 123 happyReduction_296+happyReduction_296 _+	 =  HappyAbsSyn14+		 (hiding_name+	)++happyReduce_297 = happySpecReduce_1 124 happyReduction_297+happyReduction_297 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_297 _  = notHappyAtAll ++happyReduce_298 = happySpecReduce_1 124 happyReduction_298+happyReduction_298 (HappyTerminal (QConId happy_var_1))+	 =  HappyAbsSyn14+		 (uncurry (Qual . Module) happy_var_1+	)+happyReduction_298 _  = notHappyAtAll ++happyReduce_299 = happySpecReduce_1 125 happyReduction_299+happyReduction_299 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_299 _  = notHappyAtAll ++happyReduce_300 = happySpecReduce_1 125 happyReduction_300+happyReduction_300 (HappyTerminal (QConId happy_var_1))+	 =  HappyAbsSyn14+		 (uncurry (Qual . Module) happy_var_1+	)+happyReduction_300 _  = notHappyAtAll ++happyReduce_301 = happySpecReduce_1 126 happyReduction_301+happyReduction_301 (HappyTerminal (ConId happy_var_1))+	 =  HappyAbsSyn14+		 (UnQual happy_var_1+	)+happyReduction_301 _  = notHappyAtAll ++happyReduce_302 = happySpecReduce_1 127 happyReduction_302+happyReduction_302 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_302 _  = notHappyAtAll ++happyReduce_303 = happySpecReduce_1 127 happyReduction_303+happyReduction_303 (HappyTerminal (QConSym happy_var_1))+	 =  HappyAbsSyn14+		 (uncurry (Qual . Module) happy_var_1+	)+happyReduction_303 _  = notHappyAtAll ++happyReduce_304 = happySpecReduce_1 128 happyReduction_304+happyReduction_304 (HappyTerminal (ConSym happy_var_1))+	 =  HappyAbsSyn14+		 (UnQual happy_var_1+	)+happyReduction_304 _  = notHappyAtAll ++happyReduce_305 = happySpecReduce_1 129 happyReduction_305+happyReduction_305 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_305 _  = notHappyAtAll ++happyReduce_306 = happySpecReduce_1 129 happyReduction_306+happyReduction_306 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_306 _  = notHappyAtAll ++happyReduce_307 = happySpecReduce_1 130 happyReduction_307+happyReduction_307 (HappyTerminal (VarSym happy_var_1))+	 =  HappyAbsSyn14+		 (UnQual happy_var_1+	)+happyReduction_307 _  = notHappyAtAll ++happyReduce_308 = happySpecReduce_1 130 happyReduction_308+happyReduction_308 _+	 =  HappyAbsSyn14+		 (minus_name+	)++happyReduce_309 = happySpecReduce_1 130 happyReduction_309+happyReduction_309 _+	 =  HappyAbsSyn14+		 (pling_name+	)++happyReduce_310 = happySpecReduce_1 130 happyReduction_310+happyReduction_310 _+	 =  HappyAbsSyn14+		 (period_name+	)++happyReduce_311 = happySpecReduce_1 131 happyReduction_311+happyReduction_311 (HappyTerminal (QVarSym happy_var_1))+	 =  HappyAbsSyn14+		 (uncurry (Qual . Module) happy_var_1+	)+happyReduction_311 _  = notHappyAtAll ++happyReduce_312 = happySpecReduce_1 132 happyReduction_312+happyReduction_312 (HappyAbsSyn132  happy_var_1)+	 =  HappyAbsSyn132+		 (happy_var_1+	)+happyReduction_312 _  = notHappyAtAll ++happyReduce_313 = happySpecReduce_1 132 happyReduction_313+happyReduction_313 (HappyTerminal (Character happy_var_1))+	 =  HappyAbsSyn132+		 (HsChar happy_var_1+	)+happyReduction_313 _  = notHappyAtAll ++happyReduce_314 = happySpecReduce_1 132 happyReduction_314+happyReduction_314 (HappyTerminal (StringTok happy_var_1))+	 =  HappyAbsSyn132+		 (HsString happy_var_1+	)+happyReduction_314 _  = notHappyAtAll ++happyReduce_315 = happySpecReduce_1 133 happyReduction_315+happyReduction_315 (HappyTerminal (IntTok happy_var_1))+	 =  HappyAbsSyn132+		 (HsInt (readInteger happy_var_1)+	)+happyReduction_315 _  = notHappyAtAll ++happyReduce_316 = happySpecReduce_1 133 happyReduction_316+happyReduction_316 (HappyTerminal (FloatTok happy_var_1))+	 =  HappyAbsSyn132+		 (HsFrac (readRational happy_var_1)+	)+happyReduction_316 _  = notHappyAtAll ++happyReduce_317 = happyMonadReduce 0 134 happyReduction_317+happyReduction_317 (happyRest)+	 = happyThen ( getSrcLoc+	) (\r -> happyReturn (HappyAbsSyn134 r))++happyReduce_318 = happyMonadReduce 0 135 happyReduction_318+happyReduction_318 (happyRest)+	 = happyThen ( do { SrcLoc _ _ c <- getSrcLoc ;+					pushContext (Layout c)+				      }+	) (\r -> happyReturn (HappyAbsSyn7 r))++happyReduce_319 = happySpecReduce_1 136 happyReduction_319+happyReduction_319 _+	 =  HappyAbsSyn7+		 (()+	)++happyReduce_320 = happyMonadReduce 1 136 happyReduction_320+happyReduction_320 (_ `HappyStk`+	happyRest)+	 = happyThen ( popContext+	) (\r -> happyReturn (HappyAbsSyn7 r))++happyReduce_321 = happySpecReduce_1 137 happyReduction_321+happyReduction_321 (HappyTerminal (ConId happy_var_1))+	 =  HappyAbsSyn137+		 (Module happy_var_1+	)+happyReduction_321 _  = notHappyAtAll ++happyReduce_322 = happySpecReduce_1 138 happyReduction_322+happyReduction_322 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_322 _  = notHappyAtAll ++happyReduce_323 = happySpecReduce_1 139 happyReduction_323+happyReduction_323 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_323 _  = notHappyAtAll ++happyReduce_324 = happySpecReduce_1 140 happyReduction_324+happyReduction_324 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_324 _  = notHappyAtAll ++happyReduce_325 = happySpecReduce_1 141 happyReduction_325+happyReduction_325 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_325 _  = notHappyAtAll ++happyReduce_326 = happySpecReduce_1 142 happyReduction_326+happyReduction_326 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_326 _  = notHappyAtAll ++happyNewToken action sts stk+	= lexer(\tk -> +	let cont i = action i i tk (HappyState action) sts stk in+	case tk of {+	EOF -> action 205 205 (error "reading EOF!") (HappyState action) sts stk;+	VarId happy_dollar_dollar -> cont 143;+	QVarId happy_dollar_dollar -> cont 144;+	ConId happy_dollar_dollar -> cont 145;+	QConId happy_dollar_dollar -> cont 146;+	VarSym "-" -> cont 147;+	VarSym happy_dollar_dollar -> cont 148;+	ConSym happy_dollar_dollar -> cont 149;+	QVarSym happy_dollar_dollar -> cont 150;+	QConSym happy_dollar_dollar -> cont 151;+	QModId happy_dollar_dollar -> cont 152;+	IntTok happy_dollar_dollar -> cont 153;+	FloatTok happy_dollar_dollar -> cont 154;+	Character happy_dollar_dollar -> cont 155;+	StringTok happy_dollar_dollar -> cont 156;+	LeftParen -> cont 157;+	RightParen -> cont 158;+	SemiColon -> cont 159;+	LeftCurly -> cont 160;+	RightCurly -> cont 161;+	VRightCurly -> cont 162;+	LeftSquare -> cont 163;+	RightSquare -> cont 164;+	Comma -> cont 165;+	Underscore -> cont 166;+	BackQuote -> cont 167;+	Period -> cont 168;+	DotDot -> cont 169;+	DoubleColon -> cont 170;+	Equals -> cont 171;+	Backslash -> cont 172;+	Bar -> cont 173;+	LeftArrow -> cont 174;+	RightArrow -> cont 175;+	At -> cont 176;+	Tilde -> cont 177;+	DoubleArrow -> cont 178;+	Exclamation -> cont 179;+	KW_As -> cont 180;+	KW_Case -> cont 181;+	KW_Class -> cont 182;+	KW_Data -> cont 183;+	KW_Default -> cont 184;+	KW_Deriving -> cont 185;+	KW_Do -> cont 186;+	KW_Else -> cont 187;+	KW_Hiding -> cont 188;+	KW_If -> cont 189;+	KW_Import -> cont 190;+	KW_In -> cont 191;+	KW_Infix -> cont 192;+	KW_InfixL -> cont 193;+	KW_InfixR -> cont 194;+	KW_Instance -> cont 195;+	KW_Let -> cont 196;+	KW_Module -> cont 197;+	KW_NewType -> cont 198;+	KW_Of -> cont 199;+	KW_Then -> cont 200;+	KW_Type -> cont 201;+	KW_Where -> cont 202;+	KW_Qualified -> cont 203;+	KW_Primitive -> cont 204;+	})++happyThen :: PM a -> (a -> PM b) -> PM b+happyThen = (thenPM)+happyReturn = (returnPM)+happyThen1 = happyThen+happyReturn1 = happyReturn++parse = happyThen (happyParse action_0) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })++happyError = parseError "parse error"+{-# LINE 1 "GenericTemplate.hs" #-}+{-# LINE 1 "GenericTemplate.hs" #-}+-- $Id: HsParser.hs,v 1.17 2001/11/24 04:55:36 hallgren Exp $++{-# LINE 15 "GenericTemplate.hs" #-}+++++++++++++++++++++++++++++++++++++++++++++++++++++++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++happyAccept j tk st sts (HappyStk ans _) = ++					   (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++{-# LINE 138 "GenericTemplate.hs" #-}+++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++++newtype HappyState b c = HappyState+        (Int ->                    -- token number+         Int ->                    -- token number (yes, again)+         b ->                           -- token semantic value+         HappyState b c ->              -- current state+         [HappyState b c] ->            -- state stack+         c)++++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =+     let i = (case x of { HappyErrorToken (i) -> i }) in+--     trace "shifting the error token" $+     new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)++happyShift new_state i tk st sts stk =+     happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk+     = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')+     = action nt j tk st sts (fn v1 `HappyStk` stk')++happySpecReduce_2 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')+     = action nt j tk st sts (fn v1 v2 `HappyStk` stk')++happySpecReduce_3 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+     = action nt j tk st sts (fn v1 v2 v3 `HappyStk` stk')++happyReduce k i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happyReduce k nt fn j tk st sts stk = action nt j tk st1 sts1 (fn stk)+       where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))++happyMonadReduce k nt fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+        happyThen1 (fn stk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))+       where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))+             drop_stk = happyDropStk k stk++happyDrop (0) l = l+happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t++happyDropStk (0) l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction++++++++++happyGoto action j tk st = action j j tk (HappyState action)+++-----------------------------------------------------------------------------+-- Error recovery ((1) is the error token)++-- parse error if we are in recovery and we fail again+happyFail  (1) tk old_st _ stk =+--	trace "failing" $ +    	happyError+++{-  We don't need state discarding for our restricted implementation of+    "error".  In fact, it can cause some bogus parses, so I've disabled it+    for now --SDM++-- discard a state+happyFail  (1) tk old_st (((HappyState (action))):(sts)) +						(saved_tok `HappyStk` _ `HappyStk` stk) =+--	trace ("discarding state, depth " ++ show (length stk))  $+	action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+--                       save the old token and carry on.+happyFail  i tk (HappyState (action)) sts stk =+--      trace "entering error recovery" $+	action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions++++++++-----------------------------------------------------------------------------+-- Don't inline any functions from the template.  GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.++++++++++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ tools/base/parse/extras/HsParser.y view
@@ -0,0 +1,1064 @@+-- $Id: HsParser.y,v 1.16 2001/11/24 04:55:36 hallgren Exp $++-- New Low-level Haskell Parser+-- Bill Harrison and Emir Pasalic and Andrew Moran and Thomas Hallgren+--+-- Note: +--   This parser is based on Simon Marlow and Sven Panne's (1997,1998) Haskell+--   grammar for Happy. +--   The parser does not correspond strictly to the grammar of standard+--   Haskell.  Rather, it relies on a number of postprocessing steps that +--    (1) validate the rather leaky terms produced by the and discard invalid +--        programs +--    (2) perform a small amount of rewriting (e.g., for infix operator+--        precedences)++{+module HsParser (parse) where+ +import Syntax+import SyntaxUtil+import ParseMonad+import Lexer+import LexUtil(readInteger, readRational)+import ParseUtil+--import Rewrite+import IOExts+import Char(showLitChar)++}++%token+        VARID 	 { VarId $$ }+	QVARID 	 { QVarId $$ }+	CONID	 { ConId $$ }+	QCONID   { QConId $$ }+	'-'	 { VarSym "-" }+	VARSYM	 { VarSym $$ }+	CONSYM	 { ConSym $$ }+	QVARSYM	 { QVarSym $$ }+	QCONSYM  { QConSym $$ }+	QMODID   { QModId $$ }+	INT	 { IntTok $$ }+	RATIONAL { FloatTok $$ }+	CHAR	 { Character $$ }+	STRING   { StringTok $$ }+--- Symbols --------------------------+	'('	{ LeftParen }+	')'	{ RightParen }+	';'	{ SemiColon }+	'{'	{ LeftCurly }+	'}'	{ RightCurly }+	vccurly { VRightCurly }	      -- a virtual close brace+	'['	{ LeftSquare }+	']'	{ RightSquare }+  	','	{ Comma }+	'_'	{ Underscore }+	'`'	{ BackQuote }+        '.'     { Period }            -- must be a token so it can matched in+	                              -- property quantifier expressions; it+                                      -- must be turned into an id when not+                                      -- matched thus, or used in a float.++--- Reserved operators ----------------++	'..'	{ DotDot }+	'::'	{ DoubleColon }+	'='	{ Equals }+	'\\'	{ Backslash }+	'|'	{ Bar }+	'<-'	{ LeftArrow }+	'->'	{ RightArrow }+	'@'	{ At }+	'~'	{ Tilde }+	'=>'	{ DoubleArrow }+--	'-'	{ Minus }+	'!'	{ Exclamation }+--- Reserved Ids ----------------------+	'as'		{ KW_As }+	'case'		{ KW_Case }+	'class'		{ KW_Class }+	'data'		{ KW_Data }+	'default'	{ KW_Default }+	'deriving'	{ KW_Deriving }+	'do'		{ KW_Do }+	'else'		{ KW_Else }+	'hiding'	{ KW_Hiding }+	'if'		{ KW_If }+	'import'	{ KW_Import }+	'in'		{ KW_In }+	'infix'		{ KW_Infix }+	'infixl'	{ KW_InfixL }+	'infixr'	{ KW_InfixR }+	'instance'	{ KW_Instance }+	'let'		{ KW_Let }+	'module'	{ KW_Module }+	'newtype'	{ KW_NewType }+	'of'		{ KW_Of }+	'then'		{ KW_Then }+	'type'		{ KW_Type }+	'where'		{ KW_Where }+	'qualified'	{ KW_Qualified }+	'primitive'     { KW_Primitive }+{-+--      Additions for property syntax+        'property'      { KW_Property }+        'All'           { KW_QAll }+        'Ex'            { KW_QExists }+        'AllDef'        { KW_QAllDef }+        'ExU'           { KW_QExistsU }+-}+%monad { PM } { thenPM } { returnPM }+%lexer { lexer } { EOF }+%name parse+%tokentype { Token }+%%+{-++-----------------------------------------------------------------------------+Module Header++-}+module :: { HsModuleR }+        : srcloc 'module' modid maybeexports 'where' body+			     { hsModule $1 $3 $4 $6 }+        | srcloc body	     { hsModule $1 main_mod Nothing $2 }++body :: { ([HsImportDecl], [HsDecl]) }+	:   '{' bodyaux '}'			{ $2 }+ 	| open  bodyaux close			{ $2 }++bodyaux :: { ([HsImportDecl], [HsDecl]) }+	: impdecls ';' topdecls optsemi    { ($1, $3) }+	|              topdecls optsemi    { ([], $1) }+	| impdecls              optsemi    { ($1, []) }+	| {- empty -}			   { ([], []) }++optsemi :: { () }+	: ';'						{ () }+	| {- empty -}					{ () }+{-++-----------------------------------------------------------------------------+The Export List++-}+maybeexports :: { Maybe [HsExportSpec] }+ 	:  exports				{ Just $1 }+ 	|  {- empty -}				{ Nothing }++exports :: { [HsExportSpec] }+	: '(' exportlist maybecomma ')'		{ reverse $2 }+	| '(' ')'				{ [] }++maybecomma :: { () }+	: ','					{ () }+	| {- empty -}				{ () }++exportlist :: { [HsExportSpec] }+ 	:  exportlist ',' export		{ $3 : $1 }+ 	|  export				{ [$1]  }++export :: { HsExportSpec }+ 	:  qvar				      { HsEVar $1 }+ 	|  qtyconorcls			      { HsEAbs $1 }+ 	|  qtyconorcls '(' '..' ')'	      { HsEThingAll $1 }+ 	|  qtyconorcls '(' ')'		      { HsEThingWith $1 [] }+ 	|  qtyconorcls '(' qcnames ')'	      { HsEThingWith $1 (reverse $3) }+ 	|  'module' modid		      { HsEModuleContents $2 }++qcnames :: { [HsName] }+ 	:  qcnames ',' qcname			{ $3 : $1 }+ 	|  qcname				{ [$1]  }++qcname :: { HsName }+	:  qvar					{ $1 }+ 	|  qcon					{ $1 }+{-++-----------------------------------------------------------------------------+Import Declarations++-}+impdecls :: { [HsImportDecl] }+	: impdecls ';' impdecl			{ $3 : $1 }+	| impdecl				{ [$1] }++impdecl :: { HsImportDecl }+	: 'import' srcloc optqualified modid maybeas maybeimpspec+ 		  		{ HsImportDecl $2 $4 $3 $5 $6 }++optqualified :: { Bool }+       : 'qualified'                            { True  }+       | {- empty -}				{ False }++maybeas :: { Maybe Module }+       : 'as' modid                             { Just $2 }+       | {- empty -}				{ Nothing }++maybeimpspec :: { Maybe (Bool, [HsImportSpec]) }+	: impspec				{ Just $1 }+	| {- empty -}				{ Nothing }++impspec :: { (Bool, [HsImportSpec]) }+ 	:  '(' optimportlist maybecomma ')'  	  { (False, reverse $2) }+ 	|  'hiding' '(' optimportlist maybecomma ')' { (True,  reverse $3) }++optimportlist :: { [HsImportSpec] }+	      : maybecomma			{ [] }+	      | importlist maybecomma		{ $1 }+	      +importlist :: { [HsImportSpec] }+ 	:  importlist ',' import		{ $3 : $1 }+ 	|  import				{ [$1]  }++import :: { HsImportSpec }+ 	:  var				      { HsIVar $1 }+ 	|  tyconorcls			      { HsIAbs $1 }+ 	|  tyconorcls '(' '..' ')'	      { HsIThingAll $1 }+ 	|  tyconorcls '(' ')'		      { HsIThingWith $1 [] }+ 	|  tyconorcls '(' cnames ')'	      { HsIThingWith $1 (reverse $3) }++cnames :: { [HsName] }+ 	:  cnames ',' cname			{ $3 : $1 }+ 	|  cname				{ [$1]  }++cname :: { HsName }+	:  var					{ $1 }+ 	|  con					{ $1 }++{-++-----------------------------------------------------------------------------+Top-level declarations.++-}++topdecls :: { [HsDecl] }+	: topdecls ';' topdecl     { funCons $3 $1 }+	| topdecl		      { [$1] }++{-++-----------------------------------------------------------------------------+Fixity Declarations++checkPrec has been eliminated; fixities may now be negative => must be added+to the static check.++-}++fix :: { HsDecl }+ 	: infix srcloc prec ops   { hsInfixDecl $2 (HsFixity $1 $3) $4 }+	                +prec :: { Int }+	: {- empty -}		  { 9 }+	| INT		          { fromInteger (readInteger $1) }++infix :: { HsAssoc }+	: 'infix'				{ HsAssocNone  }+	| 'infixl'				{ HsAssocLeft  }+	| 'infixr'				{ HsAssocRight }++ops   :: { [HsIdent] }+	: op ',' ops				{ $1 : $3 }+	| op					{ [$1] }++{-++-----------------------------------------------------------------------------+Top-Level Declarations++Note: The report allows topdecls to be empty. This would result in another+shift/reduce-conflict, so we don't handle this case here, but in bodyaux.++-}++{-+topdecls :: { [HsDecl] }+	: topdecls ';' topdecl		{ funCons $3  $1 }+	| topdecl			{ [$1] }+-}++topdecl :: { HsDecl }+	: 'type' tyconparams srcloc '=' type	+	       { hsTypeDecl $3 $2 $5 }+        | 'data' srcloc ctyconparams '=' constrs deriving+               { hsDataDecl $2 (fst $3) (snd $3) (reverse $5) $6 } +	| 'newtype' srcloc ctyconparams '=' constr deriving+	       { hsNewTypeDecl $2 (fst $3) (snd $3) $5 $6 }++	| 'class' srcloc ctype optfundeps optcbody	+	       { hsClassDecl  $2 (fst $3) (snd $3) $4 $5 }+	| 'instance' srcloc ctype optvaldefs+               { hsInstDecl $2 (fst $3) (snd $3) $4 }	+	| 'default' srcloc type		+	       { hsDefaultDecl $2 $3 }++        -- Hugs compatibility+        | 'data' srcloc ctybinding+	       { hsPrimitiveTypeDecl $2 (fst $3) (snd $3) }++	| 'primitive' srcloc var '::' type+	       { hsPrimitiveBind $2 $3 $5 }+        +        | decl { $1 }++optfundeps :: { HsFunDeps HsType }+	   :			 	{ [] }+	   | '|' fundeps		{ $2 }++fundeps	   :: { HsFunDeps HsType }+	   : fundep			{ [$1] }+	   | fundep ',' fundeps		{ $1:$3 }++fundep	   :: { HsFunDep HsType }+	   : tyvars '->' tyvars		{ ($1,$3) }++tyvars	   :: { [HsType] }+	   :				{ [] }+	   | typarams			{ $1 }++decls :: { [HsDecl] }+	: decls1 optsemi		{ reverse $1 }+	| optsemi 			{ [] }++decls1 :: { [HsDecl] }+	: decls1 ';' decl		{ funCons $3 $1 }+	| decl				{ [$1] }++decl :: { HsDecl }+	: signdecl			{ $1 }+        | fix                           { $1 }+	| valdef			{ $1 }+{-+        -- Property declarations+        | propdecl                      { $1 }+-}++decllist :: { [HsDecl] }+	:  '{' decls '}'	{ $2 }+	| open decls close	{ $2 }++signdecl :: { HsDecl }+	: vars srcloc '::' ctype+	      { hsTypeSig $2 (reverse $1) (fst $4) (snd $4) }+{-+++ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var+instead of qvar, we get another shift/reduce-conflict. Consider the+following programs:++   { (+) :: ... }          A "signdecl" where everything to the left of the+                           :: is parsed as "vars" which should allow only var++   { (+) x y  = ... }      A "valdef" where everything to the left of the+                           = is parsed as an "infixexp" which (incorrectly+                           in this context) allows a "qvar", since "infixexp"+                           is also used to parse patterns where "qvar" is+                           allowed++This leads to a shift/reduce-conflict. The parser must decide without too much+lookahead.  By allowing a qvar as the first thing in "vars" the parser shifts+(until it sees a "," or a "::") and doesn't get confused.  Without this,+deciding what to do with requires more lookahead.  So let's allow "qvar" in+"vars" and then check for ourselves afterwards that this didn't happen.++-}+vars	:: { [HsName] }+	: vars ',' var		{ $3 : $1 }+	| qvar			{% case $1 of+				   Qual _ _ -> parseError "bad qvar in vars."+				   _        -> return [$1]+				}+{-++-----------------------------------------------------------------------------+Types++-}+type :: { HsType }+	: btype '->' type		{ hsTyFun $1 $3 }+	| btype				{ $1 }++btype :: { HsType }+        : btype atype                   { hsTyApp $1 $2 }+        | atype                         { $1 }++atype :: { HsType }+	: gtycon			{ hsTyCon $1 }+	| tyvar				{ hsTyVar $1 }+	| '(' types ')'			{ hsTyTuple (reverse $2) }+	| '[' type ']'			{ hsTyApp list_tycon $2 }+	| '(' type ')'			{ $2 }++gtycon :: { HsName }+	: qtycon			{ $1 }+	| '(' ')'			{ unit_tycon_name }+	| '[' ']'			{ list_tycon_name }+	| '(' '->' ')'	                { fun_tycon_name }+	| '(' commas ')'		{ tuple_tycon_name $2 }+{- There is no need to qualify special syntax, since it *always* refers to +   things defined in Prelude... /TH+        -- These next three are not strictly Haskell 98, but are accepted by+        -- GHC.  Their omission from the report seems to be a bug, since+	-- without this, one cannot import the Prelude qualified and refer to+        -- the type construtors (), [], or the tuple type constructors.+	| QMODID '.' '(' ')'		{ qualify $1 "()" }+	| QMODID '.' '[' ']'		{ qualify $1 "[]" }+	| QMODID '.' '(' commas ')'     { qualify $1 (tuple $4) }+-}+{-++(Slightly edited) Comment from GHC's hsparser.y:+"context => type" vs  "type" is a problem, because you can't distinguish+between:++	foo :: (Baz a, Baz a)++	bar :: (Baz a, Baz a) => [a] -> [a] -> [a]++with one token of lookahead.  The HACK is to parse the context as a btype+(more specifically as a tuple type), then check that it has the right form+C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!++-}+ctype :: { ([HsType],HsType) }+	: type '=>' type      { (reverse (tupleTypeToContext $1), $3) }+	| type		      { ([], $1) }++types	:: { [HsType] }+	: types ',' type	    { $3 : $1 }+	| type  ',' type	    { [$3, $1] }++ctyconparams :: { ([HsType], [HsType]) }+	: type '=>' tyconparams     { (reverse (tupleTypeToContext $1), $3) }+	| tyconparams               { ([], $1) }++-- Replacing tycon with gtycon as an experiment: /TH+tyconparams :: { [HsType] }+        : gtycon typarams           { hsTyCon $1 : reverse $2 }+	| gtycon		    { [hsTyCon $1] }++typarams :: { [HsType] }+	: typarams tyvar            { hsTyVar $2 : $1 }+	| tyvar			    { [hsTyVar $1] }++ctybinding :: { ([HsType], HsName) }+	: ctyconparams  {% case snd $1 of+		             [Typ (HsTyCon nm)] -> return (fst $1,nm)+			     _ -> parseError "Primitive types are not allowed to have parameters" }++{-++-----------------------------------------------------------------------------+Datatype declarations++-}+constrs :: { [HsConDecl HsType ] }+	: constrs '|' constr		{ $3 : $1 }+	| constr			{ [$1] }++constr :: { HsConDecl HsType }+	: srcloc scontype		{ HsConDecl $1 (fst $2) (snd $2) }+	| srcloc sbtype conop sbtype	{ HsConDecl $1 $3 [$2, $4] }+	| srcloc con '{' fielddecls '}' +					{ HsRecDecl $1 $2 (reverse $4) }+scontype :: { (HsName, [HsBangType HsType]) }+	: btype			    {% do { (c, ts) <- splitTyConApp $1 ;+					    return (c, map HsUnBangedType ts)+					  }+				    }+	| scontype1		    { $1 }+--      | '(' qconsym ')' satypes   { ($2,$4) }++scontype1 :: { (HsName, [HsBangType HsType]) }+	: btype '!' atype+	      {% do { (c, ts) <- splitTyConApp $1 ;+		      return (c, map HsUnBangedType ts ++ [HsBangedType $3])+		    }+	      }+	| scontype1 satype		+              { (fst $1, snd $1 ++ [$2] ) }+{-+satypes :: { [HsBangType HsType] }+	:				{ [] }+	| satype satypes		{ $1:$2 }+-}+satype :: { HsBangType HsType }+	: atype				{ HsUnBangedType $1 }+	| '!' atype			{ HsBangedType   $2 }++sbtype :: { HsBangType HsType }+	: btype				{ HsUnBangedType $1 }+	| '!' atype			{ HsBangedType   $2 }++fielddecls :: { [([HsName], HsBangType HsType)] }+	: fielddecls ',' fielddecl	{ $3 : $1 }+	| fielddecl			{ [$1] }++fielddecl :: { ([HsName], HsBangType HsType) }+	: vars '::' stype		{ (reverse $1, $3) }++stype :: { HsBangType HsType}+	: type				{ HsUnBangedType $1 }	+	| '!' atype			{ HsBangedType   $2 }++deriving :: { [HsName] }+	: {- empty -}			{ [] }+	| 'deriving' qtycls		{ [$2] }+	| 'deriving' '('          ')'	{ [] }+	| 'deriving' '(' dclasses ')'	{ reverse $3 }++dclasses :: { [HsName] }+	: dclasses ',' qtycls		{ $3 : $1 }+        | qtycls			{ [$1] }+{-++-----------------------------------------------------------------------------+Class declarations++-}+optcbody :: { [HsDecl] }+	: 'where'  '{' cbody '}'		{ $3 }+	| 'where' open cbody close		{ $3 }+	| {- empty -}				{ [] }++cbody :: { [HsDecl] }+	: cmethods ';' cdefaults optsemi	{ reverse $1 ++ reverse $3 }+	| cmethods optsemi			{ reverse $1 }+	| optsemi				{ [] }++cmethods :: { [HsDecl] }+	: cmethods ';' signdecl			{ funCons $3  $1 }+	| signdecl				{ [$1] }++cdefaults :: { [HsDecl] }+	: cdefaults ';' valdef			{ funCons $3  $1 }+	| valdef				{ [$1] }+{-++-----------------------------------------------------------------------------+Instance declarations++-}+optvaldefs :: { [HsDecl] }+	: 'where'  '{' valdefs '}'	{ $3 }+	| 'where' open valdefs close	{ $3 }+	| {- empty -}				{ [] }+{-++Recycling...++-}+valdefs :: { [HsDecl] }+	: cdefaults optsemi			{ reverse $1 }+	| optsemi				{ [] }+{-++-----------------------------------------------------------------------------+Value definitions++-}++{-+valdef :: { HsDecl }+	: infixexp srcloc rhs optwheredecls+				    {% if isPatternExp $1 +                                       then mkValDef $1 $2 $3 $4+                                       else mkFunDef $1 $2 $3 $4+				    }+-}++valdef :: { HsDecl }+	: funlhs srcloc rhs optwheredecls   { mkFunDef' $1 $2 $3 $4 }+        | infixpat srcloc rhs optwheredecls { hsPatBind $2 $1 $3 $4 }++funlhs :: { (HsName,[HsPat]) }+        : qvar apats1               { ($1,$2) }+        | infixpat qvarop infixpat   { ($2,[$1,$3]) }+        | '(' funlhs ')' apats      { (fst $2,snd $2++$4) }+	              -- ^ Haskell 98 requires apats1 (at least one apat)++optwheredecls :: { [HsDecl] }+        : 'where' decllist          { $2 }+        | {- empty -}               { [] }++rhs	:: { HsRhs HsExp }+	: '=' exp		    { HsBody $2 }+	| gdrhss		    { HsGuard (reverse $1) }++gdrhss :: { [(SrcLoc, HsExp, HsExp)] }+	: gdrhss gdrhs		    { $2 : $1 }+	| gdrhs			    { [$1] }++gdrhs :: { (SrcLoc, HsExp, HsExp) }+	: '|' exp srcloc '=' exp    { ($3, $2, $5) }++{-++-----------------------------------------------------------------------------+Expressions++-}+exp   :: { HsExp }+	: infixexp '::' srcloc ctype  	{ hsExpTypeSig $3 $1 (fst $4) (snd $4) }+        | infixexp	                { $1 }++infixexp :: { HsExp }+	: exp10				{ $1 }+	| infixexp qop exp10		{ hsInfixApp $1 $2 $3 }++{-++    From MPJ's Tool0 Hugs98 parser.y:++        | qfier pats '.' exp		{$$ = gc4(ap(QUANTIFY,+                                                     ap($1,+                                                        pair(rev($2),+                                                             pair($3,$4)))));}+-}++exp10 :: { HsExp }+	: '\\' apats '->' exp { hsLambda $2 $4 }+	      {-% do { ps <- mapM expToPat $2 ;+                      return (hsLambda (reverse ps) $4)+		    }+              -}+{-+       | quant pats '.' exp+             {% do { ps <- mapM expToPat $2 ;+                     return (hsPropQuant (reverse ps) $4)+		   }+             }  +-}+  	| 'let' decllist 'in' exp	 { hsLet $2 $4 }+	| 'if' exp 'then' exp 'else' exp { hsIf $2 $4 $6 }+   	| 'case' exp 'of' altslist	 { hsCase $2 $4 } +	| '-' fexp			 { hsNegApp $2 }+  	| 'do' stmtlist			 { hsDo (atoms2Stmt $2) }+	| fexp				 { $1 }++fexp :: { HsExp }+	: fexp aexp			{ hsApp $1 $2 }+  	| aexp				{ $1 }+{-+aexps :: { [HsExp] }+	: aexps aexp			{ $2 : $1 }+  	| aexp				{ [$1] }+-}+{-++Note: The first alternative of aexp is not neccessarily a record update, it+could be a labeled construction, too.++-}+aexp	:: { HsExp }+  	: aexp '{' fbinds '}'        { mkRecord $1 (reverse $3) }+  	| aexp1			     { $1 }++aexp1	:: { HsExp }+	: qvar			     { hsEVar ($1 :: HsName) }+	| gcon			     { $1 }+  	| literal		     { hsLit $1 }+	| '(' exp ')'		     { hsParen $2 }+	| '(' texps ')'		     { hsTuple (reverse $2) }+	| '[' list ']'               { $2 }+	| '(' infixexp qop ')'	     { hsLeftSection $2 $3 }+	| '(' qop infixexp ')'	     { hsRightSection $2 $3 }+	| qvar '@' aexp1	     { hsAsPat $1 $3 }+	| '_'			     { hsWildCard }+	| '~' aexp1		     { hsIrrPat $2 }++commas :: { Int }+	: commas ','		     { $1 + 1 }+	| ','			     { 1 }++texps :: { [HsExp] }+	: texps ',' exp		     { $3 : $1 }+	| exp ',' exp		     { [$3, $1] }++{-++-----------------------------------------------------------------------------+List expressions++The rules below are little bit contorted to keep lexps left-recursive while+avoiding another shift/reduce-conflict.++-}+list :: { HsExp }+	: exp				{ hsList [$1] }+	| lexps 			{ hsList (reverse $1) }+	| exp '..'			{ hsEnumFrom $1 }+	| exp ',' exp '..' 		{ hsEnumFromThen $1 $3 }+	| exp '..' exp	 		{ hsEnumFromTo $1 $3 }+	| exp ',' exp '..' exp		{ hsEnumFromThenTo $1 $3 $5 }+	| exp '|' quals			+          { hsListComp (atoms2Stmt (reverse $3 ++ [HsQualifierAtom $1])) }++lexps :: { [HsExp] }+	: lexps ',' exp 		{ $3 : $1 }+	| exp ',' exp			{ [$3,$1] }+{-++-----------------------------------------------------------------------------+List comprehensions++-}+quals :: { [HsStmtAtom HsExp HsPat [HsDecl] ] }+	: quals ',' qual		{ $3 : $1 }+	| qual				{ [$1] }++qual  :: { HsStmtAtom HsExp HsPat [HsDecl] }+	: infixexp '<-' exp		{% do { p <- expToPat $1 ; +                                                return (HsGeneratorAtom p $3)+					      }+					}+	| exp			  	{ HsQualifierAtom $1 }+  	| 'let' decllist		{ HsLetStmtAtom   $2 }++{-++-----------------------------------------------------------------------------+Case alternatives++-}+altslist :: { [HsAlt HsExp HsPat [HsDecl]] }+	: '{'   alts optsemi '}'	{ reverse $2 }+	| open  alts optsemi close	{ reverse $2 }+++alts :: { [HsAlt HsExp HsPat [HsDecl]] }+	: alts ';' alt				{ $3 : $1 }+	| alt					{ [$1] }++alt :: { HsAlt HsExp HsPat [HsDecl] }+	: infixpat srcloc rhscasealts { HsAlt $2 $1 $3 [] }+	      {-% do { p <- expToPat $1 ;+	              return (HsAlt $2 p $3 [])+		    }+	      -} +        | infixpat srcloc rhscasealts 'where' decllist { HsAlt $2 $1 $3 $5 }+	      {-% do { p <- expToPat $1 ;+		      return (HsAlt $2 p $3 $5)+		    }+	      -}++rhscasealts :: { HsRhs HsExp }+	: '->' exp		            { HsBody $2 }+	| gdcaserhss		            { HsGuard (reverse $1) }++gdcaserhss :: { [(SrcLoc, HsExp, HsExp)] }+	: gdcaserhss gdcaserhs		    { $2 : $1 }+	| gdcaserhs			    { [$1] }++gdcaserhs :: { (SrcLoc, HsExp, HsExp) }+	: '|' srcloc exp  '->' exp          { ($2, $3, $5) }++{-++-----------------------------------------------------------------------------+Statement sequences++-}+stmtlist :: { [HsStmtAtom HsExp HsPat [HsDecl]] }+	:   '{' stmts '}'	{ $2 }+	| open  stmts close	{ $2 }++stmts :: { [HsStmtAtom HsExp HsPat [HsDecl]] }+        : stmts1 ';' exp	      { reverse (HsQualifierAtom $3 : $1) }+ 	| exp               	      { [HsQualifierAtom $1] }++stmts1 :: { [HsStmtAtom HsExp HsPat [HsDecl]] }+  	: stmts1 ';' qual		{ $3 : $1 }+	| qual 				{ [$1] }++--- Record Field Update/Construction -------------------------------------------++fbinds :: { [HsFieldUpdate HsExp] }+	  :				{ [] }+	  | fbinds1			{ $1 }++fbinds1 :: { [HsFieldUpdate HsExp] }+	: fbinds1 ',' fbind		{ $3 : $1 }+	| fbind				{ [$1] }++fbind	:: { HsFieldUpdate HsExp }+	: qvar '=' exp			{ HsFieldUpdate $1 $3 }+--	| qvar				{ HsFieldBind $1 }++--- Patterns -------------------------------------------------------------------++pat :: { HsPat }+        : infixpat                { $1 }+     -- | n+k++infixpat :: { HsPat }+	: pat10                   { $1 }+	| infixpat qconop pat10   { hsPInfixApp $1 (HsCon $2) $3 }++pat10 :: { HsPat }+        : qcon apats1             { hsPApp $1 $2 } -- should be gcon...+	| '-' numlit		  { hsPNeg (hsPLit $2) }+        | apat                    { $1 }++apat :: { HsPat }+        : qvar                    { hsPVar $1 }+        | qvar '@' apat           { hsPAsPat $1 $3 }+        | qcon                    { hsPCon $1 } -- should be gcon...+	| '(' ')'                 { hsPCon (qualify "Prelude" "()") }+        | qcon '{' fpats '}'      { hsPRec $1 $3 }+        | literal                 { hsPLit $1 }+        | '_'                     { hsPWildCard }+	| '(' pat ')'             { hsPParen $2 }+	| '(' tpats ')'           { hsPTuple $2 }+	| '[' lpats ']'           { hsPList $2 }+        | '~' apat                { hsPIrrPat $2 }++apats1 :: { [HsPat] }+        : apat apats              { $1 : $2 }++apats :: { [HsPat] }+	:                         { [] }+	| apat apats              { $1 : $2 }++fpats :: { [HsPatField HsPat] }+        :                         { [] }+        | fpats1                  { $1 }++fpats1 :: { [HsPatField HsPat] }+        : fpat ',' fpats1         { $1 : $3 }+	| fpat                    { [$1] }++fpat :: { HsPatField HsPat }+        : qvar '=' pat            { HsPFieldPat $1 $3 }++tpats :: { [HsPat] }+        : pat ',' tpats           { $1 : $3 }+        | pat ',' pat             { [$1, $3] }++lpats :: { [HsPat] }+        :                         { [] }+	| lpats1                  { $1 }++lpats1 :: { [HsPat] }+        : pat ',' lpats           { $1 : $3 }+        | pat                     { [$1] }++{-++-----------------------------------------------------------------------------+Variables, Constructors and Operators.++-}+gcon :: { HsExp }+  	: '(' ')'		     { hsECon (qualify "Prelude" "()") }+	| '[' ']'		     { hsList [] }+	| '(' commas ')'	     { hsECon (qualify "Prelude" (tuple $2)) }+        -- These next three are not strictly Haskell 98, but are accepted by+        -- GHC.  Their omission from the report seems to be a bug, since+	-- without this, one cannot import the Prelude qualified and refer to+        -- the values (), [], or the tuple constructors.  It's unclear what+	-- effect of qualifying the nil list would actually have, since it is+	-- otherwise treated separately (i.e., there is no VARSYM called+        -- "[]").  Since it can't reused, according to the report, I have+	-- treated the same as an unqualified [], ignoring the qualifying+	-- module.  AKM+	| QMODID '.' '(' ')'	     { hsECon (qualify $1 "()") }+	| QMODID '.' '[' ']'	     { hsList [] }+	| QMODID '.' '(' commas ')'  { hsECon (qualify $1 (tuple $4)) }+  	| qcon			     { hsECon $1 }++var 	:: { HsName }+	: varid			{ $1 }+	| '(' varsym ')'	{ $2 }++qvar 	:: { HsName }+	: qvarid		{ $1 }+	| '(' qvarsym ')'	{ $2 }++con	:: { HsName }+	: conid			{ $1 }+	| '(' consym ')'        { $2 }++qcon	:: { HsName }+	: qconid		{ $1 }+	| '(' qconsym ')'	{ $2 }++varop	:: { HsName }+	: varsym		{ $1 }+	| '`' varid '`'		{ $2 }++qvarop :: { HsName }+	: qvarsym		{ $1 }+	| '`' qvarid '`'	{ $2 }+{-+qvaropm :: { HsName }+	: qvarsymm		{ $1 }+	| '`' qvarid '`'	{ $2 }+-}+conop :: { HsName }+	: consym		{ $1 }	+	| '`' conid '`'		{ $2 }++qconop :: { HsName }+	: qconsym		{ $1 }+	| '`' qconid '`'	{ $2 }++op	:: { HsIdent }+	: varop			{ hsVar $1 }+	| conop 		{ hsCon $1 }++qop	:: { HsIdent }+	: qvarop		{ hsVar $1 }+	| qconop		{ hsCon $1 }+{-+qopm	:: { HsIdent }+	: qvaropm		{ hsVar $1 }+	| qconop		{ hsCon $1 }+-}+qvarid :: { HsName }+	: varid			{ $1 }+	| QVARID		{ uncurry (Qual . Module) $1 }++varid :: { HsName }+	: VARID			{ UnQual $1 }+	| 'as'			{ as_name }+	| 'qualified'           { qualified_name }+	| 'hiding'		{ hiding_name }++qconid :: { HsName }+	: conid			{ $1 }+        | QCONID		{ uncurry (Qual . Module) $1 }++qtycon :: { HsName }+	: tycon			{ $1 }+	| QCONID		{ uncurry (Qual . Module) $1 }++conid :: { HsName }+	: CONID			{ UnQual $1 }++qconsym :: { HsName }+	: consym		{ $1 }+	| QCONSYM		{ uncurry (Qual . Module) $1 }++consym :: { HsName }+	: CONSYM		{ UnQual $1 }++qvarsym :: { HsName }+	: varsym		{ $1 }+	| qvarsym1		{ $1 }+{-+qvarsymm :: { HsName }+	: varsymm		{ $1 }+	| qvarsym1		{ $1 }+-}+varsym :: { HsName }+	: VARSYM		{ UnQual $1 }+	| '-'			{ minus_name }+	| '!'			{ pling_name }+        | '.'                   { period_name }+{-+varsymm :: { HsName } -- varsym not including '-'+	: VARSYM		{ UnQual $1 }+	| '!'			{ pling_name }+        | '.'                   { period_name }+-}+qvarsym1 :: { HsName }+	: QVARSYM		{ uncurry (Qual . Module) $1 }++literal :: { HsLiteral }+	: numlit		{ $1 }+	| CHAR 			{ HsChar $1 }+	| STRING		{ HsString $1 }++numlit :: { HsLiteral }+	: INT 			{ HsInt (readInteger $1) }+	| RATIONAL		{ HsFrac (readRational $1) }+        +srcloc :: { SrcLoc }	:	{% getSrcLoc }++--- Layout ---------------------------------------------------------------------++open  :: { () }+       :	                {% do { SrcLoc _ _ c <- getSrcLoc ;+					pushContext (Layout c)+				      }+				}++close :: { () }+	: vccurly		{ () } -- context popped in lexer.+	| error			{% popContext }++--- Miscellaneous (mostly renamings) -------------------------------------------++modid :: { Module }+	: CONID			{ Module $1 }++tyconorcls :: { HsName }+	: conid			{ $1 }++tycon :: { HsName }+	: conid			{ $1 }++qtyconorcls :: { HsName }+	: qtycon		{ $1 }++qtycls :: { HsName }+	: qtycon		{ $1 }++tyvar :: { HsName }+	: varid			{ $1 }+{-++-----------------------------------------------------------------------------++     Property declarations++-----------------------------------------------------------------------------++From MPJ's Tool0 Hugs98 parser.y file:++gendecl   : PROPERTY pLhs '=' exp	{$$ = gc4(ap(PROP,ap($2,ap($3,$4))));}+	  | PROPERTY error		{syntaxError("property decl");}+	  ;+pLhs	  : pLhs varid			{$$ = gc2(ap($1,$2));}+	  | CONID			{$$ = $1;}+	  | error			{syntaxError("property defn lhs");}+	  ;+qfier	  : QALL			{$$ = gc1(quantAll);}+	  | QEX				{$$ = gc1(quantEx);}+	  | QALLDEF			{$$ = gc1(quantAlldef);}+	  | QEXU			{$$ = gc1(quantExu);}+	  ;++-}++{-++propdecl :: { HsDecl }+	: 'property' quant pLhs '=' exp  { hsProp $2 $3 $5 }++quant :: { HsQuantifier } +	: 'All'                          { hsPropForall } +        | 'Ex'                           { hsPropExists }+	| 'AllDef'                       { hsPropForallDefined }+	| 'ExU'                          { hsPropExistsUnique }++pLhs :: { [HsName] }+        : pLhs varid                     { $2 : $1 }+        | conid                          { [$1] }++-}++{-++-----------------------------------------------------------------------------++-}++{+happyError = parseError "parse error"+}
+ tools/base/parse/extras/ParseUtil.hs view
@@ -0,0 +1,152 @@+-- $Id: ParseUtil.hs,v 1.8 2001/11/15 02:42:03 hallgren Exp $++{-++Utilities for the parser.++Author(s): Simon Marlow 1997, 1998;+           Emir Pasalic, Bill Harrison, Andrew Moran 2001++-}++module ParseUtil (--setInfix,          -- HsInfixDecl -> PM ()+		  splitTyConApp,     -- HsType -> PM (HsName, [HsType])+		  mkValDef,          -- HsExp -> SrcLoc -> HsRhs HsExp+		                     --   -> [HsDecl] -> PM HsDecl+                  mkFunDef,          -- HsExp -> SrcLoc -> HsRhs HsExp+                                     --   -> [HsDecl] -> PM HsDecl+                  mkFunDef',+                  expToPat)          -- HsExp -> PM HsPat+where++--import ParseMonad+--import Rewrite+import HsAssoc+import Syntax+import SyntaxUtil(isConE)+import PrettyPrint++{-+-- Update the infix environment with infix information from declaration.+setInfix (HsInfixDecl sl (HsFixity prec assoc) names) = +  mapM (addToEnv prec assoc) names+  where +      addToEnv prec HsAssocNone  n =+	  do { s <- getInfixEnv ;+	       setInfixEnv $ extend s (HsInfix HsAssocNone  prec n)+	     }+      addToEnv prec HsAssocRight n =+	  do { s <- getInfixEnv ;+	       setInfixEnv $ extend s (HsInfix HsAssocLeft  prec n)+	     }+      addToEnv prec HsAssocLeft  n =+	  do { s <- getInfixEnv ;+	       setInfixEnv $ extend s (HsInfix HsAssocRight prec n)+	     }+-}+--splitTyConApp :: HsType -> PM (HsName, [HsType])+splitTyConApp t = split t []+    where+    --split :: HsType -> [HsType] -> PM (HsName, [HsType])+    split (Typ (HsTyApp t u)) ts = split t (u:ts)+    split (Typ (HsTyCon t))   ts = return (t, ts)+    split _                   _+        = fail "illegal data/newtype declaration"++--mkValDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> PM HsDecl+mkValDef lhs sloc (HsBody b) wheres = +    do { lpat <- expToPat lhs ;+	 return $ hsPatBind sloc lpat (HsBody b) wheres+       }+mkValDef lhs sloc (HsGuard gds) wheres = +    do { lpat <- expToPat lhs ;+	 return $ hsPatBind sloc lpat (HsGuard gds) wheres+       }++--mkFunDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> PM HsDecl+mkFunDef lhs sloc rhs wheres = +    do { (fnamePat, ps) <- getFundefPats lhs ; +	 case fnamePat of +         Pat (HsPId (HsVar nm)) ->+              return $ hsFunBind sloc [HsMatch sloc nm ps rhs  wheres]+         _                      ->+              fail $ "invalid function name in:\n\n" ++ pp lhs+       }++mkFunDef' (nm,ps) sloc rhs wheres =+    hsFunBind sloc [HsMatch sloc nm ps rhs wheres]++--getFundefPats :: HsExp -> PM (HsPat, [HsPat])+getFundefPats (Exp pexp) = + case pexp of +   HsId (HsVar nm) -> return (hsPVar nm, [])+   HsApp l r ->  +     do { (pv, ps) <- getFundefPats l ;+          p        <- expToPat r ;+          return (pv, ps ++ [p])+	}+   HsInfixApp l (HsVar n) r -> +     do { lp  <- expToPat l ;+          rp  <- expToPat r ;+          return (hsPVar n, [lp, rp])+	}+   HsInfixApp l (HsCon n) r -> +     do { lp  <- expToPat l ;+          rp  <- expToPat r ;+          return (hsPCon n, [lp, rp])+	}+   HsParen e -> getFundefPats e+   _     -> fail $+	    "cannot use\n\n" ++ pp pexp +++	   "\n\nas a function definition pattern."++--expToPat :: HsExp -> PM HsPat+expToPat l@(Exp lhexp)  = +    case lhexp of +      HsId (HsVar n) -> return $ hsPVar n+      HsId (HsCon n) -> return $ hsPCon n+      HsLit literal  -> return $ hsPLit literal+      HsNegApp  e    -> do { p <- expToPat e ; return $ hsPNeg p }+      HsLambda _ _   -> fail "lambdas not allowed in patterns."+      HsList es      -> do { ps <- sequence (map expToPat es) ;+			     return $ hsPList ps+			   }+      HsTuple es     -> do { ps <- sequence (map expToPat es) ;+			     return $ hsPTuple ps+			   }+      HsWildCard     -> return hsPWildCard+      HsIrrPat e     -> do { p <- expToPat e ; return $ hsPIrrPat p }+      HsAsPat nm e   -> do { p <- expToPat e ; return $ hsPAsPat nm p}+      HsApp l r | isConE l   -> +                      do { let { Exp (HsId (HsCon n)) = l } ;+			   rp <- expToPat r ;+			   return $ hsPApp n [rp]+			 }+                | otherwise ->+                      do { lp <- expToPat l ;+                           rp <- expToPat r ;+                           case lp of +                           Pat (HsPApp n ps) ->+			        return $ hsPApp n (ps ++ [rp])+                           _                 ->+			        fail $+			        "Cannot use:\n\n" +++			        pp lhexp +++			        "\n\n as a pattern."+                          }+      HsInfixApp l (HsCon n) r -> +                       do { lp <- expToPat l ;+                            rp <- expToPat r ;+                            return $ hsPInfixApp lp (HsCon n) rp +			  }+      HsParen e      -> expToPat e+      HsRecConstr con fields ->+                       do { pfs <- mapM fieldToPat fields ;+			    return $ hsPRec con pfs+			  }+      _              ->+          fail $ "ParseUtil.expToPat: not a valid/supported pattern:\n\n"+                       ++ pp lhexp+    where fieldToPat (HsFieldUpdate f e) = do { p <- expToPat e ;+						return $ HsPFieldPat f p+					      }
+ tools/base/parse/extras/Token.hs view
@@ -0,0 +1,154 @@+-- $Id: Token.hs,v 1.3 2001/11/08 22:09:34 hallgren Exp $++module Token(Token(..),+             IntKind(..),+             reserved_ids,+             reserved_ops,+             tab_length)++where+++data Token +    = VarId String+    | QVarId (String, String)+    | ConId String+    | QConId (String, String)+    | VarSym String+    | ConSym String+    | QVarSym (String, String)+    | QConSym (String, String)+    | QModId String -- special case hack for M.(,,,).  The token QModId+                    -- holds the M, and the '.' and the list/tupe constructors+                    -- follow tokenized.  Must be matched in the grammar.+		    -- This isn't used for M.[N], since that must parse as+		    -- M . [N], most likely ending in an error.+    | IntTok String+    | FloatTok String+    | Character Char+    | StringTok String+{-++Symbols++-}+    | LeftParen+    | RightParen+    | SemiColon+    | LeftCurly+    | RightCurly+    | VRightCurly			-- a virtual close brace+    | LeftSquare+    | RightSquare+    | Comma+    | Underscore+    | BackQuote+    | Period                            -- needed for properties+{-++Reserved operators++-}+    | DotDot+    | DoubleColon+    | Equals+    | Backslash+    | Bar+    | LeftArrow+    | RightArrow+    | At+    | Tilde+    | DoubleArrow+    | Minus+    | Exclamation+{-++Reserved Ids++-}+    | KW_As       +    | KW_Case     +    | KW_Class    +    | KW_Data     +    | KW_Default  +    | KW_Deriving +    | KW_Do       +    | KW_Else     +    | KW_Hiding+    | KW_If       +    | KW_Import   +    | KW_In       +    | KW_Infix    +    | KW_InfixL   +    | KW_InfixR   +    | KW_Instance +    | KW_Let      +    | KW_Module   +    | KW_NewType  +    | KW_Of       +    | KW_Then     +    | KW_Type     +    | KW_Where    +    | KW_Qualified+    | KW_Primitive+    | EOF+      deriving (Eq, Show)+++reserved_ops :: [(String, Token)]+reserved_ops+    = [+        ( "..", DotDot ),    +	( "::", DoubleColon ),+	( "=",  Equals ),    +	( "\\", Backslash ), +	( "|",  Bar ),       +	( "<-", LeftArrow ), +	( "->", RightArrow ),+	( "@",  At ),        +	( "~",  Tilde ),     +	( "=>", DoubleArrow ),+--	( "-",  Minus ),	-- ToDo: shouldn't be here+	( "!",  Exclamation )	-- ditto+      ]+++reserved_ids :: [(String, Token)]+reserved_ids+    = [+	( "_",         Underscore ),       +	( "as",        KW_As ),       +        ( "case",      KW_Case ),     +	( "class",     KW_Class ),    +	( "data",      KW_Data ),     +	( "default",   KW_Default ),  +	( "deriving",  KW_Deriving ), +	( "do",        KW_Do ),       +	( "else",      KW_Else ),     +	( "if",        KW_If ),       +	( "import",    KW_Import ),   +	( "in",        KW_In ),       +	( "infix",     KW_Infix ),    +	( "infixl",    KW_InfixL ),   +	( "infixr",    KW_InfixR ),   +	( "instance",  KW_Instance ), +	( "let",       KW_Let ),      +	( "module",    KW_Module ),   +	( "newtype",   KW_NewType ),  +	( "of",        KW_Of ),       +	( "then",      KW_Then ),     +	( "type",      KW_Type ),     +	( "where",     KW_Where ),    +	( "qualified", KW_Qualified ),+	( "hiding",    KW_Hiding ),+	( "primitive", KW_Primitive )+      ]+++data IntKind+    = Decimal     (String, String)+    | Octal       (String, String)+    | Hexadecimal (String, String)+++tab_length = 8 :: Int
+ tools/base/parse2/HEADER.html view
@@ -0,0 +1,23 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!-- This file is included by the web server in the automatically generated+     directory index.+-->+<head>+<title>Programatica Tools, tools/base/parse2</title>+<link rel=parent href="../" title="Directory tools/base">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../../web/icon1.png">+</head>++<base>+<h1><img align=right src="../../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/base/parse2</h2>++The README file is displayed below the directory index.++<p>+See also the <a href="pfe.cgi">HTML version of the source code for the+Lexer for Haskell in Haskell</a>.
+ tools/base/parse2/HuMakefile view
@@ -0,0 +1,1 @@+SRC_DIRS=.:LexerGen:Lexer:LexerSpec:../lib:../lib/Monads:../tests/HbcLibraries
+ tools/base/parse2/LexUtil.hs view
@@ -0,0 +1,42 @@+-- $Id: LexUtil.hs,v 1.1 2001/11/16 22:35:52 hallgren Exp $++module LexUtil (isIdent,isLower_,  -- Char -> Bool+		isSymbol,      -- Char -> Bool+		readInteger,   -- String -> Integer+		readNumber,    -- Integer -> String -> Integer+		readRational)  -- String -> Rational++where++import HsName(isSymbol)+import Char(isDigit, isOctDigit, isHexDigit, digitToInt, isAlpha, isLower)+import Ratio++isIdent  c = isAlpha c || isDigit c || c == '\'' || c == '_'+isLower_ c = isLower c || c == '_'++readInteger :: String -> Integer+readInteger ('0':'o':ds) = readInteger2  8 isOctDigit ds+readInteger ('0':'O':ds) = readInteger2  8 isOctDigit ds+readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds+readInteger ('0':'X':ds) = readInteger2 16 isHexDigit ds+readInteger          ds  = readInteger2 10 isDigit    ds++readNumber :: Integer -> String -> Integer+readNumber radix ds = readInteger2 radix (const True) ds++readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer+readInteger2 radix isDig ds +  = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) +				    (takeWhile isDig ds))++readRational :: String -> Rational+readRational xs+    = (readInteger (i ++ m))%1 * 10^^((case e of+				       ""       -> 0+				       ('+':e2) -> read e2+				       _        -> read e) - length m)+      where (i, r1) = span isDigit xs+	    (m, r2) = span isDigit (dropWhile (== '.') r1)+	    e       = dropWhile (== 'e') r2+
+ tools/base/parse2/Lexer/Flags.ghc view
@@ -0,0 +1,2 @@+HsLexUtils.hs: -O -cpp+HsLex.hs: -O
+ tools/base/parse2/Lexer/HsLayoutPre.hs view
@@ -0,0 +1,61 @@+module HsLayoutPre(layoutPre,PosToken) where+import HsTokens+import HsLexerPos++{-++This is+an implementation of Haskell layout, as specified in section 9.3 of the+revised Haskell 98 report.++This module contains the layout preprocessor that inserts the extra+&lt;n&gt; and {n} tokens.+-}++type PosToken = (Token,(Pos,String))++layoutPre :: [PosToken] -> [PosToken]+layoutPre = indent . open++open = open1++{-++If the first lexeme of a module is not { or module, then it is preceded+by {n} where n is the indentation of the lexeme.+-}+open1 (t1@(Reservedid,(_,"module")):ts) = t1:open2 ts+open1 (t1@(Special,(_,"{")):ts)         = t1:open2 ts+open1 ts@((t,(p,s)):_)	                = (Open (column p),(p,"")):open2 ts+open1 []                                = []++{-++If a let, where, do, or of keyword is not followed by the lexeme {,+the token {n} is inserted after the keyword, where n is the indentation of+the next lexeme if there is one, or 0 if the end of file has been reached.+-}+open2 (t1:ts1) | isLtoken t1 =+    case ts1 of+      t2@(_,(p,_)):ts2 ->+        if notLBrace t2+        then t1:(Open (column p),(p,"")):open2 ts1+	else t1:t2:open2 ts2+      [] -> t1:(Open 0,(fst (snd t1),"")):[]+  where+    isLtoken (Reservedid,(_,s)) = s `elem` ["let","where","do","of"]+    isLtoken _ = False++    notLBrace (Special,(_,"{")) = False+    notLBrace _ = True+open2 (t:ts) = t:open2 ts+open2 [] = []++{-++(This is from the original Haskell 98 report.)+The first token on each line (not including tokens already annotated) is+preceeded by &lt;n&gt;, where n is the indentation of the token.+-}+indent (t1@(Open _,(p,_)):ts) = t1:indent2 (line p) ts+indent (t1@(t,(p,s)):ts)    = (Indent (column p),(p,"")):t1:indent2 (line p) ts+indent [] = []++indent2 r (t1@(_,(p,_)):ts) | line p==r = t1:indent2 r ts+indent2 r ts = indent ts
+ tools/base/parse2/Lexer/HsLex.hs view
@@ -0,0 +1,5366 @@++-- Automatically generated code for a DFA follows:+--Equal states: [[[2,3],[8,9],[5,31],[10,11],[36,37],[39,40]]]+module HsLex (haskellLex) where+import Char+import HsLexUtils++type Output = [(Token,String)]+type Input = String+type Acc = Input -- reversed+type Lexer = Input -> Output+type LexerState = (Acc->Lexer) -> Acc -> Lexer++haskellLex :: Lexer+haskellLex is = start1 is++cclass :: Char -> Int+cclass c =+  case c of+    '\t' -> 1+    '\n' -> 2+    '\v' -> 3+    '\f' -> 4+    '\r' -> 5+    ' ' -> 6+    '\160' -> 6+    '!' -> 7+    '#' -> 7+    '$' -> 7+    '%' -> 7+    '*' -> 7+    '/' -> 7+    '?' -> 7+    '\161' -> 7+    '\162' -> 7+    '\163' -> 7+    '\164' -> 7+    '\165' -> 7+    '\166' -> 7+    '\167' -> 7+    '\168' -> 7+    '\169' -> 7+    '\172' -> 7+    '\173' -> 7+    '\174' -> 7+    '\175' -> 7+    '\176' -> 7+    '\177' -> 7+    '\180' -> 7+    '\182' -> 7+    '\183' -> 7+    '\184' -> 7+    '\191' -> 7+    '\215' -> 7+    '\247' -> 7+    '"' -> 8+    '&' -> 9+    '\'' -> 10+    '(' -> 11+    ')' -> 11+    ',' -> 11+    ';' -> 11+    '`' -> 11+    '}' -> 11+    '+' -> 12+    '-' -> 13+    '.' -> 14+    '0' -> 15+    '1' -> 16+    '2' -> 16+    '3' -> 16+    '4' -> 16+    '5' -> 17+    '6' -> 17+    '7' -> 17+    '8' -> 18+    '9' -> 18+    ':' -> 19+    '<' -> 20+    '=' -> 21+    '>' -> 22+    '@' -> 23+    'A' -> 24+    'B' -> 25+    'C' -> 26+    'D' -> 27+    'E' -> 28+    'F' -> 29+    'G' -> 30+    'H' -> 31+    'I' -> 32+    'P' -> 32+    'J' -> 33+    'W' -> 33+    'Z' -> 33+    'K' -> 34+    'L' -> 35+    'M' -> 36+    'N' -> 37+    'O' -> 38+    'Q' -> 39+    'R' -> 40+    'S' -> 41+    'T' -> 42+    'U' -> 43+    'V' -> 44+    'X' -> 45+    'Y' -> 46+    '[' -> 47+    ']' -> 47+    '\\' -> 48+    '^' -> 49+    '_' -> 50+    'a' -> 51+    'b' -> 52+    'c' -> 53+    'd' -> 54+    'e' -> 55+    'f' -> 56+    'g' -> 57+    'h' -> 58+    'i' -> 59+    'j' -> 60+    'k' -> 60+    'q' -> 60+    'z' -> 60+    '\223' -> 60+    '\224' -> 60+    '\225' -> 60+    '\226' -> 60+    '\227' -> 60+    '\228' -> 60+    '\229' -> 60+    '\230' -> 60+    '\231' -> 60+    '\232' -> 60+    '\233' -> 60+    '\234' -> 60+    '\235' -> 60+    '\236' -> 60+    '\237' -> 60+    '\238' -> 60+    '\239' -> 60+    '\240' -> 60+    '\241' -> 60+    '\242' -> 60+    '\243' -> 60+    '\244' -> 60+    '\245' -> 60+    '\246' -> 60+    '\248' -> 60+    '\249' -> 60+    '\250' -> 60+    '\251' -> 60+    '\252' -> 60+    '\253' -> 60+    '\254' -> 60+    '\255' -> 60+    'l' -> 61+    'm' -> 62+    'n' -> 63+    'o' -> 64+    'p' -> 65+    'r' -> 66+    's' -> 67+    't' -> 68+    'u' -> 69+    'v' -> 70+    'w' -> 71+    'x' -> 72+    'y' -> 73+    '{' -> 74+    '|' -> 75+    '~' -> 75+    '\170' -> 76+    '\171' -> 76+    '\178' -> 76+    '\179' -> 76+    '\181' -> 76+    '\185' -> 76+    '\186' -> 76+    '\187' -> 76+    '\188' -> 76+    '\189' -> 76+    '\190' -> 76+    '\192' -> 77+    '\193' -> 77+    '\194' -> 77+    '\195' -> 77+    '\196' -> 77+    '\197' -> 77+    '\198' -> 77+    '\199' -> 77+    '\200' -> 77+    '\201' -> 77+    '\202' -> 77+    '\203' -> 77+    '\204' -> 77+    '\205' -> 77+    '\206' -> 77+    '\207' -> 77+    '\208' -> 77+    '\209' -> 77+    '\210' -> 77+    '\211' -> 77+    '\212' -> 77+    '\213' -> 77+    '\214' -> 77+    '\216' -> 77+    '\217' -> 77+    '\218' -> 77+    '\219' -> 77+    '\220' -> 77+    '\221' -> 77+    '\222' -> 77+    c | isAscii c -> 0+      | isSpace c -> 3+      | isSymbol c -> 7+      | isDigit c -> 18+      | isLower c -> 60+      | isUpper c -> 77+      | otherwise -> 0++start1 :: Lexer+start1 is = state1 (\ as is -> gotError as is) "" is+state1 :: LexerState+state1 err as [] = gotEOF as+state1 err as iis@(i:is) =+  case cclass i of+    51 -> state162 err (i:as) is+    52 -> state162 err (i:as) is+    56 -> state162 err (i:as) is+    57 -> state162 err (i:as) is+    58 -> state162 err (i:as) is+    60 -> state162 err (i:as) is+    65 -> state162 err (i:as) is+    66 -> state162 err (i:as) is+    67 -> state162 err (i:as) is+    69 -> state162 err (i:as) is+    70 -> state162 err (i:as) is+    72 -> state162 err (i:as) is+    73 -> state162 err (i:as) is+    1 -> state2 err (i:as) is+    2 -> state2 err (i:as) is+    3 -> state2 err (i:as) is+    4 -> state2 err (i:as) is+    5 -> state2 err (i:as) is+    6 -> state2 err (i:as) is+    7 -> state4 err (i:as) is+    9 -> state4 err (i:as) is+    12 -> state4 err (i:as) is+    22 -> state4 err (i:as) is+    49 -> state4 err (i:as) is+    23 -> state79 err (i:as) is+    48 -> state79 err (i:as) is+    75 -> state79 err (i:as) is+    16 -> state87 err (i:as) is+    17 -> state87 err (i:as) is+    18 -> state87 err (i:as) is+    0 -> err as iis+    76 -> err as iis+    11 -> state73 err (i:as) is+    47 -> state73 err (i:as) is+    8 -> state5 err (i:as) is+    10 -> state41 err (i:as) is+    13 -> state74 err (i:as) is+    14 -> state80 err (i:as) is+    15 -> state81 err (i:as) is+    19 -> state92 err (i:as) is+    20 -> state95 err (i:as) is+    21 -> state96 err (i:as) is+    50 -> state161 err (i:as) is+    53 -> state163 err (i:as) is+    54 -> state169 err (i:as) is+    55 -> state182 err (i:as) is+    59 -> state183 err (i:as) is+    61 -> state195 err (i:as) is+    62 -> state196 err (i:as) is+    63 -> state200 err (i:as) is+    64 -> state205 err (i:as) is+    68 -> state206 err (i:as) is+    71 -> state209 err (i:as) is+    74 -> state212 err (i:as) is+    _ -> state97 err (i:as) is++state2 :: LexerState+state2 err as [] = err as []+  where err _ _ = output Whitespace as (start1 [])+state2 err as iis@(i:is) =+  case cclass i of+    1 -> state2 err (i:as) is+    2 -> state2 err (i:as) is+    3 -> state2 err (i:as) is+    4 -> state2 err (i:as) is+    5 -> state2 err (i:as) is+    6 -> state2 err (i:as) is+    _ -> err as iis+  where err _ _ = output Whitespace as (start1 iis)++state4 :: LexerState+state4 err as [] = err as []+  where err _ _ = output Varsym as (start1 [])+state4 err as iis@(i:is) =+  case cclass i of+    7 -> state4 err (i:as) is+    9 -> state4 err (i:as) is+    12 -> state4 err (i:as) is+    13 -> state4 err (i:as) is+    14 -> state4 err (i:as) is+    19 -> state4 err (i:as) is+    20 -> state4 err (i:as) is+    21 -> state4 err (i:as) is+    22 -> state4 err (i:as) is+    23 -> state4 err (i:as) is+    48 -> state4 err (i:as) is+    49 -> state4 err (i:as) is+    75 -> state4 err (i:as) is+    _ -> err as iis+  where err _ _ = output Varsym as (start1 iis)++start5 :: Lexer+start5 is = state5 (\ as is -> gotError as is) "" is+state5 :: LexerState+state5 err as [] = err as []+state5 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    8 -> state6 err (i:as) is+    48 -> state7 err (i:as) is+    _ -> state5 err (i:as) is++state6 :: LexerState+state6 err as is = output StringLit as (start1 is)++start7 :: Lexer+start7 is = state7 (\ as is -> gotError as is) "" is+state7 :: LexerState+state7 err as [] = err as []+state7 err as iis@(i:is) =+  case cclass i of+    8 -> state5 err (i:as) is+    9 -> state5 err (i:as) is+    10 -> state5 err (i:as) is+    48 -> state5 err (i:as) is+    51 -> state5 err (i:as) is+    52 -> state5 err (i:as) is+    56 -> state5 err (i:as) is+    63 -> state5 err (i:as) is+    66 -> state5 err (i:as) is+    68 -> state5 err (i:as) is+    70 -> state5 err (i:as) is+    1 -> state8 err (i:as) is+    2 -> state8 err (i:as) is+    3 -> state8 err (i:as) is+    4 -> state8 err (i:as) is+    5 -> state8 err (i:as) is+    6 -> state8 err (i:as) is+    15 -> state10 err (i:as) is+    16 -> state10 err (i:as) is+    17 -> state10 err (i:as) is+    18 -> state10 err (i:as) is+    30 -> state27 err (i:as) is+    40 -> state27 err (i:as) is+    43 -> state27 err (i:as) is+    31 -> state23 err (i:as) is+    44 -> state23 err (i:as) is+    24 -> state12 err (i:as) is+    25 -> state14 err (i:as) is+    26 -> state16 err (i:as) is+    27 -> state18 err (i:as) is+    28 -> state21 err (i:as) is+    29 -> state26 err (i:as) is+    35 -> state28 err (i:as) is+    37 -> state29 err (i:as) is+    41 -> state30 err (i:as) is+    49 -> state34 err (i:as) is+    64 -> state35 err (i:as) is+    72 -> state38 err (i:as) is+    _ -> err as iis++start8 :: Lexer+start8 is = state8 (\ as is -> gotError as is) "" is+state8 :: LexerState+state8 err as [] = err as []+state8 err as iis@(i:is) =+  case cclass i of+    1 -> state8 err (i:as) is+    2 -> state8 err (i:as) is+    3 -> state8 err (i:as) is+    4 -> state8 err (i:as) is+    5 -> state8 err (i:as) is+    6 -> state8 err (i:as) is+    48 -> state5 err (i:as) is+    _ -> err as iis++start10 :: Lexer+start10 is = state10 (\ as is -> gotError as is) "" is+state10 :: LexerState+state10 err as [] = err as []+state10 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    15 -> state10 err (i:as) is+    16 -> state10 err (i:as) is+    17 -> state10 err (i:as) is+    18 -> state10 err (i:as) is+    8 -> state6 err (i:as) is+    48 -> state7 err (i:as) is+    _ -> state5 err (i:as) is++start12 :: Lexer+start12 is = state12 (\ as is -> gotError as is) "" is+state12 :: LexerState+state12 err as [] = err as []+state12 err as iis@(i:is) =+  case cclass i of+    26 -> state13 err (i:as) is+    _ -> err as iis++start13 :: Lexer+start13 is = state13 (\ as is -> gotError as is) "" is+state13 :: LexerState+state13 err as [] = err as []+state13 err as iis@(i:is) =+  case cclass i of+    34 -> state5 err (i:as) is+    _ -> err as iis++start14 :: Lexer+start14 is = state14 (\ as is -> gotError as is) "" is+state14 :: LexerState+state14 err as [] = err as []+state14 err as iis@(i:is) =+  case cclass i of+    41 -> state5 err (i:as) is+    28 -> state15 err (i:as) is+    _ -> err as iis++start15 :: Lexer+start15 is = state15 (\ as is -> gotError as is) "" is+state15 :: LexerState+state15 err as [] = err as []+state15 err as iis@(i:is) =+  case cclass i of+    35 -> state5 err (i:as) is+    _ -> err as iis++start16 :: Lexer+start16 is = state16 (\ as is -> gotError as is) "" is+state16 :: LexerState+state16 err as [] = err as []+state16 err as iis@(i:is) =+  case cclass i of+    40 -> state5 err (i:as) is+    24 -> state17 err (i:as) is+    _ -> err as iis++start17 :: Lexer+start17 is = state17 (\ as is -> gotError as is) "" is+state17 :: LexerState+state17 err as [] = err as []+state17 err as iis@(i:is) =+  case cclass i of+    37 -> state5 err (i:as) is+    _ -> err as iis++start18 :: Lexer+start18 is = state18 (\ as is -> gotError as is) "" is+state18 :: LexerState+state18 err as [] = err as []+state18 err as iis@(i:is) =+  case cclass i of+    28 -> state15 err (i:as) is+    26 -> state19 err (i:as) is+    35 -> state20 err (i:as) is+    _ -> err as iis++start19 :: Lexer+start19 is = state19 (\ as is -> gotError as is) "" is+state19 :: LexerState+state19 err as [] = err as []+state19 err as iis@(i:is) =+  case cclass i of+    16 -> state5 err (i:as) is+    _ -> err as iis++start20 :: Lexer+start20 is = state20 (\ as is -> gotError as is) "" is+state20 :: LexerState+state20 err as [] = err as []+state20 err as iis@(i:is) =+  case cclass i of+    28 -> state5 err (i:as) is+    _ -> err as iis++start21 :: Lexer+start21 is = state21 (\ as is -> gotError as is) "" is+state21 :: LexerState+state21 err as [] = err as []+state21 err as iis@(i:is) =+  case cclass i of+    36 -> state5 err (i:as) is+    37 -> state22 err (i:as) is+    38 -> state23 err (i:as) is+    41 -> state24 err (i:as) is+    42 -> state25 err (i:as) is+    _ -> err as iis++start22 :: Lexer+start22 is = state22 (\ as is -> gotError as is) "" is+state22 :: LexerState+state22 err as [] = err as []+state22 err as iis@(i:is) =+  case cclass i of+    39 -> state5 err (i:as) is+    _ -> err as iis++start23 :: Lexer+start23 is = state23 (\ as is -> gotError as is) "" is+state23 :: LexerState+state23 err as [] = err as []+state23 err as iis@(i:is) =+  case cclass i of+    42 -> state5 err (i:as) is+    _ -> err as iis++start24 :: Lexer+start24 is = state24 (\ as is -> gotError as is) "" is+state24 :: LexerState+state24 err as [] = err as []+state24 err as iis@(i:is) =+  case cclass i of+    26 -> state5 err (i:as) is+    _ -> err as iis++start25 :: Lexer+start25 is = state25 (\ as is -> gotError as is) "" is+state25 :: LexerState+state25 err as [] = err as []+state25 err as iis@(i:is) =+  case cclass i of+    25 -> state5 err (i:as) is+    45 -> state5 err (i:as) is+    _ -> err as iis++start26 :: Lexer+start26 is = state26 (\ as is -> gotError as is) "" is+state26 :: LexerState+state26 err as [] = err as []+state26 err as iis@(i:is) =+  case cclass i of+    29 -> state5 err (i:as) is+    41 -> state5 err (i:as) is+    _ -> err as iis++start27 :: Lexer+start27 is = state27 (\ as is -> gotError as is) "" is+state27 :: LexerState+state27 err as [] = err as []+state27 err as iis@(i:is) =+  case cclass i of+    41 -> state5 err (i:as) is+    _ -> err as iis++start28 :: Lexer+start28 is = state28 (\ as is -> gotError as is) "" is+state28 :: LexerState+state28 err as [] = err as []+state28 err as iis@(i:is) =+  case cclass i of+    29 -> state5 err (i:as) is+    _ -> err as iis++start29 :: Lexer+start29 is = state29 (\ as is -> gotError as is) "" is+state29 :: LexerState+state29 err as [] = err as []+state29 err as iis@(i:is) =+  case cclass i of+    24 -> state13 err (i:as) is+    43 -> state15 err (i:as) is+    _ -> err as iis++start30 :: Lexer+start30 is = state30 (\ as is -> gotError as is) "" is+state30 :: LexerState+state30 err as [] = err as []+state30 err as iis@(i:is) =+  case cclass i of+    32 -> state5 err (i:as) is+    38 -> state5 err (i:as) is+    46 -> state17 err (i:as) is+    42 -> state32 err (i:as) is+    43 -> state33 err (i:as) is+    _ -> err as iis++start32 :: Lexer+start32 is = state32 (\ as is -> gotError as is) "" is+state32 :: LexerState+state32 err as [] = err as []+state32 err as iis@(i:is) =+  case cclass i of+    45 -> state5 err (i:as) is+    _ -> err as iis++start33 :: Lexer+start33 is = state33 (\ as is -> gotError as is) "" is+state33 :: LexerState+state33 err as [] = err as []+state33 err as iis@(i:is) =+  case cclass i of+    25 -> state5 err (i:as) is+    _ -> err as iis++start34 :: Lexer+start34 is = state34 (\ as is -> gotError as is) "" is+state34 :: LexerState+state34 err as [] = err as []+state34 err as iis@(i:is) =+  case cclass i of+    23 -> state5 err (i:as) is+    24 -> state5 err (i:as) is+    25 -> state5 err (i:as) is+    26 -> state5 err (i:as) is+    27 -> state5 err (i:as) is+    28 -> state5 err (i:as) is+    29 -> state5 err (i:as) is+    30 -> state5 err (i:as) is+    31 -> state5 err (i:as) is+    32 -> state5 err (i:as) is+    33 -> state5 err (i:as) is+    34 -> state5 err (i:as) is+    35 -> state5 err (i:as) is+    36 -> state5 err (i:as) is+    37 -> state5 err (i:as) is+    38 -> state5 err (i:as) is+    39 -> state5 err (i:as) is+    40 -> state5 err (i:as) is+    41 -> state5 err (i:as) is+    42 -> state5 err (i:as) is+    43 -> state5 err (i:as) is+    44 -> state5 err (i:as) is+    45 -> state5 err (i:as) is+    46 -> state5 err (i:as) is+    47 -> state5 err (i:as) is+    48 -> state5 err (i:as) is+    49 -> state5 err (i:as) is+    50 -> state5 err (i:as) is+    _ -> err as iis++start35 :: Lexer+start35 is = state35 (\ as is -> gotError as is) "" is+state35 :: LexerState+state35 err as [] = err as []+state35 err as iis@(i:is) =+  case cclass i of+    15 -> state36 err (i:as) is+    16 -> state36 err (i:as) is+    17 -> state36 err (i:as) is+    _ -> err as iis++start36 :: Lexer+start36 is = state36 (\ as is -> gotError as is) "" is+state36 :: LexerState+state36 err as [] = err as []+state36 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    15 -> state36 err (i:as) is+    16 -> state36 err (i:as) is+    17 -> state36 err (i:as) is+    8 -> state6 err (i:as) is+    48 -> state7 err (i:as) is+    _ -> state5 err (i:as) is++start38 :: Lexer+start38 is = state38 (\ as is -> gotError as is) "" is+state38 :: LexerState+state38 err as [] = err as []+state38 err as iis@(i:is) =+  case cclass i of+    15 -> state39 err (i:as) is+    16 -> state39 err (i:as) is+    17 -> state39 err (i:as) is+    18 -> state39 err (i:as) is+    24 -> state39 err (i:as) is+    25 -> state39 err (i:as) is+    26 -> state39 err (i:as) is+    27 -> state39 err (i:as) is+    28 -> state39 err (i:as) is+    29 -> state39 err (i:as) is+    51 -> state39 err (i:as) is+    52 -> state39 err (i:as) is+    53 -> state39 err (i:as) is+    54 -> state39 err (i:as) is+    55 -> state39 err (i:as) is+    56 -> state39 err (i:as) is+    _ -> err as iis++start39 :: Lexer+start39 is = state39 (\ as is -> gotError as is) "" is+state39 :: LexerState+state39 err as [] = err as []+state39 err as iis@(i:is) =+  case cclass i of+    15 -> state39 err (i:as) is+    16 -> state39 err (i:as) is+    17 -> state39 err (i:as) is+    18 -> state39 err (i:as) is+    24 -> state39 err (i:as) is+    25 -> state39 err (i:as) is+    26 -> state39 err (i:as) is+    27 -> state39 err (i:as) is+    28 -> state39 err (i:as) is+    29 -> state39 err (i:as) is+    51 -> state39 err (i:as) is+    52 -> state39 err (i:as) is+    53 -> state39 err (i:as) is+    54 -> state39 err (i:as) is+    55 -> state39 err (i:as) is+    56 -> state39 err (i:as) is+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    8 -> state6 err (i:as) is+    48 -> state7 err (i:as) is+    _ -> state5 err (i:as) is++start41 :: Lexer+start41 is = state41 (\ as is -> gotError as is) "" is+state41 :: LexerState+state41 err as [] = err as []+state41 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    10 -> err as iis+    48 -> state44 err (i:as) is+    _ -> state42 err (i:as) is++start42 :: Lexer+start42 is = state42 (\ as is -> gotError as is) "" is+state42 :: LexerState+state42 err as [] = err as []+state42 err as iis@(i:is) =+  case cclass i of+    10 -> state43 err (i:as) is+    _ -> err as iis++state43 :: LexerState+state43 err as is = output CharLit as (start1 is)++start44 :: Lexer+start44 is = state44 (\ as is -> gotError as is) "" is+state44 :: LexerState+state44 err as [] = err as []+state44 err as iis@(i:is) =+  case cclass i of+    8 -> state42 err (i:as) is+    9 -> state42 err (i:as) is+    10 -> state42 err (i:as) is+    48 -> state42 err (i:as) is+    51 -> state42 err (i:as) is+    52 -> state42 err (i:as) is+    56 -> state42 err (i:as) is+    63 -> state42 err (i:as) is+    66 -> state42 err (i:as) is+    68 -> state42 err (i:as) is+    70 -> state42 err (i:as) is+    15 -> state45 err (i:as) is+    16 -> state45 err (i:as) is+    17 -> state45 err (i:as) is+    18 -> state45 err (i:as) is+    30 -> state61 err (i:as) is+    40 -> state61 err (i:as) is+    43 -> state61 err (i:as) is+    31 -> state57 err (i:as) is+    44 -> state57 err (i:as) is+    24 -> state46 err (i:as) is+    25 -> state48 err (i:as) is+    26 -> state50 err (i:as) is+    27 -> state52 err (i:as) is+    28 -> state55 err (i:as) is+    29 -> state60 err (i:as) is+    35 -> state62 err (i:as) is+    37 -> state63 err (i:as) is+    41 -> state64 err (i:as) is+    49 -> state68 err (i:as) is+    64 -> state69 err (i:as) is+    72 -> state71 err (i:as) is+    _ -> err as iis++start45 :: Lexer+start45 is = state45 (\ as is -> gotError as is) "" is+state45 :: LexerState+state45 err as [] = err as []+state45 err as iis@(i:is) =+  case cclass i of+    15 -> state45 err (i:as) is+    16 -> state45 err (i:as) is+    17 -> state45 err (i:as) is+    18 -> state45 err (i:as) is+    10 -> state43 err (i:as) is+    _ -> err as iis++start46 :: Lexer+start46 is = state46 (\ as is -> gotError as is) "" is+state46 :: LexerState+state46 err as [] = err as []+state46 err as iis@(i:is) =+  case cclass i of+    26 -> state47 err (i:as) is+    _ -> err as iis++start47 :: Lexer+start47 is = state47 (\ as is -> gotError as is) "" is+state47 :: LexerState+state47 err as [] = err as []+state47 err as iis@(i:is) =+  case cclass i of+    34 -> state42 err (i:as) is+    _ -> err as iis++start48 :: Lexer+start48 is = state48 (\ as is -> gotError as is) "" is+state48 :: LexerState+state48 err as [] = err as []+state48 err as iis@(i:is) =+  case cclass i of+    41 -> state42 err (i:as) is+    28 -> state49 err (i:as) is+    _ -> err as iis++start49 :: Lexer+start49 is = state49 (\ as is -> gotError as is) "" is+state49 :: LexerState+state49 err as [] = err as []+state49 err as iis@(i:is) =+  case cclass i of+    35 -> state42 err (i:as) is+    _ -> err as iis++start50 :: Lexer+start50 is = state50 (\ as is -> gotError as is) "" is+state50 :: LexerState+state50 err as [] = err as []+state50 err as iis@(i:is) =+  case cclass i of+    40 -> state42 err (i:as) is+    24 -> state51 err (i:as) is+    _ -> err as iis++start51 :: Lexer+start51 is = state51 (\ as is -> gotError as is) "" is+state51 :: LexerState+state51 err as [] = err as []+state51 err as iis@(i:is) =+  case cclass i of+    37 -> state42 err (i:as) is+    _ -> err as iis++start52 :: Lexer+start52 is = state52 (\ as is -> gotError as is) "" is+state52 :: LexerState+state52 err as [] = err as []+state52 err as iis@(i:is) =+  case cclass i of+    28 -> state49 err (i:as) is+    26 -> state53 err (i:as) is+    35 -> state54 err (i:as) is+    _ -> err as iis++start53 :: Lexer+start53 is = state53 (\ as is -> gotError as is) "" is+state53 :: LexerState+state53 err as [] = err as []+state53 err as iis@(i:is) =+  case cclass i of+    16 -> state42 err (i:as) is+    _ -> err as iis++start54 :: Lexer+start54 is = state54 (\ as is -> gotError as is) "" is+state54 :: LexerState+state54 err as [] = err as []+state54 err as iis@(i:is) =+  case cclass i of+    28 -> state42 err (i:as) is+    _ -> err as iis++start55 :: Lexer+start55 is = state55 (\ as is -> gotError as is) "" is+state55 :: LexerState+state55 err as [] = err as []+state55 err as iis@(i:is) =+  case cclass i of+    36 -> state42 err (i:as) is+    37 -> state56 err (i:as) is+    38 -> state57 err (i:as) is+    41 -> state58 err (i:as) is+    42 -> state59 err (i:as) is+    _ -> err as iis++start56 :: Lexer+start56 is = state56 (\ as is -> gotError as is) "" is+state56 :: LexerState+state56 err as [] = err as []+state56 err as iis@(i:is) =+  case cclass i of+    39 -> state42 err (i:as) is+    _ -> err as iis++start57 :: Lexer+start57 is = state57 (\ as is -> gotError as is) "" is+state57 :: LexerState+state57 err as [] = err as []+state57 err as iis@(i:is) =+  case cclass i of+    42 -> state42 err (i:as) is+    _ -> err as iis++start58 :: Lexer+start58 is = state58 (\ as is -> gotError as is) "" is+state58 :: LexerState+state58 err as [] = err as []+state58 err as iis@(i:is) =+  case cclass i of+    26 -> state42 err (i:as) is+    _ -> err as iis++start59 :: Lexer+start59 is = state59 (\ as is -> gotError as is) "" is+state59 :: LexerState+state59 err as [] = err as []+state59 err as iis@(i:is) =+  case cclass i of+    25 -> state42 err (i:as) is+    45 -> state42 err (i:as) is+    _ -> err as iis++start60 :: Lexer+start60 is = state60 (\ as is -> gotError as is) "" is+state60 :: LexerState+state60 err as [] = err as []+state60 err as iis@(i:is) =+  case cclass i of+    29 -> state42 err (i:as) is+    41 -> state42 err (i:as) is+    _ -> err as iis++start61 :: Lexer+start61 is = state61 (\ as is -> gotError as is) "" is+state61 :: LexerState+state61 err as [] = err as []+state61 err as iis@(i:is) =+  case cclass i of+    41 -> state42 err (i:as) is+    _ -> err as iis++start62 :: Lexer+start62 is = state62 (\ as is -> gotError as is) "" is+state62 :: LexerState+state62 err as [] = err as []+state62 err as iis@(i:is) =+  case cclass i of+    29 -> state42 err (i:as) is+    _ -> err as iis++start63 :: Lexer+start63 is = state63 (\ as is -> gotError as is) "" is+state63 :: LexerState+state63 err as [] = err as []+state63 err as iis@(i:is) =+  case cclass i of+    24 -> state47 err (i:as) is+    43 -> state49 err (i:as) is+    _ -> err as iis++start64 :: Lexer+start64 is = state64 (\ as is -> gotError as is) "" is+state64 :: LexerState+state64 err as [] = err as []+state64 err as iis@(i:is) =+  case cclass i of+    32 -> state42 err (i:as) is+    46 -> state51 err (i:as) is+    38 -> state65 err (i:as) is+    42 -> state66 err (i:as) is+    43 -> state67 err (i:as) is+    _ -> err as iis++start65 :: Lexer+start65 is = state65 (\ as is -> gotError as is) "" is+state65 :: LexerState+state65 err as [] = err as []+state65 err as iis@(i:is) =+  case cclass i of+    31 -> state42 err (i:as) is+    10 -> state43 err (i:as) is+    _ -> err as iis++start66 :: Lexer+start66 is = state66 (\ as is -> gotError as is) "" is+state66 :: LexerState+state66 err as [] = err as []+state66 err as iis@(i:is) =+  case cclass i of+    45 -> state42 err (i:as) is+    _ -> err as iis++start67 :: Lexer+start67 is = state67 (\ as is -> gotError as is) "" is+state67 :: LexerState+state67 err as [] = err as []+state67 err as iis@(i:is) =+  case cclass i of+    25 -> state42 err (i:as) is+    _ -> err as iis++start68 :: Lexer+start68 is = state68 (\ as is -> gotError as is) "" is+state68 :: LexerState+state68 err as [] = err as []+state68 err as iis@(i:is) =+  case cclass i of+    23 -> state42 err (i:as) is+    24 -> state42 err (i:as) is+    25 -> state42 err (i:as) is+    26 -> state42 err (i:as) is+    27 -> state42 err (i:as) is+    28 -> state42 err (i:as) is+    29 -> state42 err (i:as) is+    30 -> state42 err (i:as) is+    31 -> state42 err (i:as) is+    32 -> state42 err (i:as) is+    33 -> state42 err (i:as) is+    34 -> state42 err (i:as) is+    35 -> state42 err (i:as) is+    36 -> state42 err (i:as) is+    37 -> state42 err (i:as) is+    38 -> state42 err (i:as) is+    39 -> state42 err (i:as) is+    40 -> state42 err (i:as) is+    41 -> state42 err (i:as) is+    42 -> state42 err (i:as) is+    43 -> state42 err (i:as) is+    44 -> state42 err (i:as) is+    45 -> state42 err (i:as) is+    46 -> state42 err (i:as) is+    47 -> state42 err (i:as) is+    48 -> state42 err (i:as) is+    49 -> state42 err (i:as) is+    50 -> state42 err (i:as) is+    _ -> err as iis++start69 :: Lexer+start69 is = state69 (\ as is -> gotError as is) "" is+state69 :: LexerState+state69 err as [] = err as []+state69 err as iis@(i:is) =+  case cclass i of+    15 -> state70 err (i:as) is+    16 -> state70 err (i:as) is+    17 -> state70 err (i:as) is+    _ -> err as iis++start70 :: Lexer+start70 is = state70 (\ as is -> gotError as is) "" is+state70 :: LexerState+state70 err as [] = err as []+state70 err as iis@(i:is) =+  case cclass i of+    15 -> state70 err (i:as) is+    16 -> state70 err (i:as) is+    17 -> state70 err (i:as) is+    10 -> state43 err (i:as) is+    _ -> err as iis++start71 :: Lexer+start71 is = state71 (\ as is -> gotError as is) "" is+state71 :: LexerState+state71 err as [] = err as []+state71 err as iis@(i:is) =+  case cclass i of+    15 -> state72 err (i:as) is+    16 -> state72 err (i:as) is+    17 -> state72 err (i:as) is+    18 -> state72 err (i:as) is+    24 -> state72 err (i:as) is+    25 -> state72 err (i:as) is+    26 -> state72 err (i:as) is+    27 -> state72 err (i:as) is+    28 -> state72 err (i:as) is+    29 -> state72 err (i:as) is+    51 -> state72 err (i:as) is+    52 -> state72 err (i:as) is+    53 -> state72 err (i:as) is+    54 -> state72 err (i:as) is+    55 -> state72 err (i:as) is+    56 -> state72 err (i:as) is+    _ -> err as iis++start72 :: Lexer+start72 is = state72 (\ as is -> gotError as is) "" is+state72 :: LexerState+state72 err as [] = err as []+state72 err as iis@(i:is) =+  case cclass i of+    15 -> state72 err (i:as) is+    16 -> state72 err (i:as) is+    17 -> state72 err (i:as) is+    18 -> state72 err (i:as) is+    24 -> state72 err (i:as) is+    25 -> state72 err (i:as) is+    26 -> state72 err (i:as) is+    27 -> state72 err (i:as) is+    28 -> state72 err (i:as) is+    29 -> state72 err (i:as) is+    51 -> state72 err (i:as) is+    52 -> state72 err (i:as) is+    53 -> state72 err (i:as) is+    54 -> state72 err (i:as) is+    55 -> state72 err (i:as) is+    56 -> state72 err (i:as) is+    10 -> state43 err (i:as) is+    _ -> err as iis++state73 :: LexerState+state73 err as is = output Special as (start1 is)++state74 :: LexerState+state74 err as [] = err as []+  where err _ _ = output Varsym as (start1 [])+state74 err as iis@(i:is) =+  case cclass i of+    7 -> state4 err (i:as) is+    9 -> state4 err (i:as) is+    12 -> state4 err (i:as) is+    14 -> state4 err (i:as) is+    19 -> state4 err (i:as) is+    20 -> state4 err (i:as) is+    21 -> state4 err (i:as) is+    23 -> state4 err (i:as) is+    48 -> state4 err (i:as) is+    49 -> state4 err (i:as) is+    75 -> state4 err (i:as) is+    13 -> state75 err (i:as) is+    22 -> state79 err (i:as) is+    _ -> err as iis+  where err _ _ = output Varsym as (start1 iis)++state75 :: LexerState+state75 err as [] = err as []+  where err _ _ = output Commentstart as (start76 [])+state75 err as iis@(i:is) =+  case cclass i of+    7 -> state4 err (i:as) is+    9 -> state4 err (i:as) is+    12 -> state4 err (i:as) is+    14 -> state4 err (i:as) is+    19 -> state4 err (i:as) is+    20 -> state4 err (i:as) is+    21 -> state4 err (i:as) is+    22 -> state4 err (i:as) is+    23 -> state4 err (i:as) is+    48 -> state4 err (i:as) is+    49 -> state4 err (i:as) is+    75 -> state4 err (i:as) is+    13 -> state75 err (i:as) is+    _ -> err as iis+  where err _ _ = output Commentstart as (start76 iis)++start76 :: Lexer+start76 is = state76 (\ as is -> gotError as is) "" is+state76 :: LexerState+state76 err as [] = err as []+state76 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    3 -> err as iis+    2 -> state77 err (i:as) is+    4 -> state77 err (i:as) is+    5 -> state78 err (i:as) is+    _ -> state76 err (i:as) is++state77 :: LexerState+state77 err as is = output Comment as (start1 is)++state78 :: LexerState+state78 err as [] = err as []+  where err _ _ = output Comment as (start1 [])+state78 err as iis@(i:is) =+  case cclass i of+    2 -> state77 err (i:as) is+    _ -> err as iis+  where err _ _ = output Comment as (start1 iis)++state79 :: LexerState+state79 err as [] = err as []+  where err _ _ = output Reservedop as (start1 [])+state79 err as iis@(i:is) =+  case cclass i of+    7 -> state4 err (i:as) is+    9 -> state4 err (i:as) is+    12 -> state4 err (i:as) is+    13 -> state4 err (i:as) is+    14 -> state4 err (i:as) is+    19 -> state4 err (i:as) is+    20 -> state4 err (i:as) is+    21 -> state4 err (i:as) is+    22 -> state4 err (i:as) is+    23 -> state4 err (i:as) is+    48 -> state4 err (i:as) is+    49 -> state4 err (i:as) is+    75 -> state4 err (i:as) is+    _ -> err as iis+  where err _ _ = output Reservedop as (start1 iis)++state80 :: LexerState+state80 err as [] = err as []+  where err _ _ = output Varsym as (start1 [])+state80 err as iis@(i:is) =+  case cclass i of+    7 -> state4 err (i:as) is+    9 -> state4 err (i:as) is+    12 -> state4 err (i:as) is+    13 -> state4 err (i:as) is+    19 -> state4 err (i:as) is+    20 -> state4 err (i:as) is+    21 -> state4 err (i:as) is+    22 -> state4 err (i:as) is+    23 -> state4 err (i:as) is+    48 -> state4 err (i:as) is+    49 -> state4 err (i:as) is+    75 -> state4 err (i:as) is+    14 -> state79 err (i:as) is+    _ -> err as iis+  where err _ _ = output Varsym as (start1 iis)++state81 :: LexerState+state81 err as [] = err as []+  where err _ _ = output IntLit as (start1 [])+state81 err as iis@(i:is) =+  case cclass i of+    15 -> state87 err (i:as) is+    16 -> state87 err (i:as) is+    17 -> state87 err (i:as) is+    18 -> state87 err (i:as) is+    38 -> state88 err (i:as) is+    64 -> state88 err (i:as) is+    45 -> state90 err (i:as) is+    72 -> state90 err (i:as) is+    14 -> state82 err (i:as) is+    _ -> err as iis+  where err _ _ = output IntLit as (start1 iis)++start82 :: Lexer+start82 is = state82 (\ as is -> gotError as is) "" is+state82 :: LexerState+state82 err as [] = err as []+state82 err as iis@(i:is) =+  case cclass i of+    15 -> state83 err (i:as) is+    16 -> state83 err (i:as) is+    17 -> state83 err (i:as) is+    18 -> state83 err (i:as) is+    _ -> err as iis++state83 :: LexerState+state83 err as [] = err as []+  where err _ _ = output FloatLit as (start1 [])+state83 err as iis@(i:is) =+  case cclass i of+    15 -> state83 err (i:as) is+    16 -> state83 err (i:as) is+    17 -> state83 err (i:as) is+    18 -> state83 err (i:as) is+    28 -> state84 err (i:as) is+    55 -> state84 err (i:as) is+    _ -> err as iis+  where err _ _ = output FloatLit as (start1 iis)++start84 :: Lexer+start84 is = state84 (\ as is -> gotError as is) "" is+state84 :: LexerState+state84 err as [] = err as []+state84 err as iis@(i:is) =+  case cclass i of+    15 -> state86 err (i:as) is+    16 -> state86 err (i:as) is+    17 -> state86 err (i:as) is+    18 -> state86 err (i:as) is+    12 -> state85 err (i:as) is+    13 -> state85 err (i:as) is+    _ -> err as iis++start85 :: Lexer+start85 is = state85 (\ as is -> gotError as is) "" is+state85 :: LexerState+state85 err as [] = err as []+state85 err as iis@(i:is) =+  case cclass i of+    15 -> state86 err (i:as) is+    16 -> state86 err (i:as) is+    17 -> state86 err (i:as) is+    18 -> state86 err (i:as) is+    _ -> err as iis++state86 :: LexerState+state86 err as [] = err as []+  where err _ _ = output FloatLit as (start1 [])+state86 err as iis@(i:is) =+  case cclass i of+    15 -> state86 err (i:as) is+    16 -> state86 err (i:as) is+    17 -> state86 err (i:as) is+    18 -> state86 err (i:as) is+    _ -> err as iis+  where err _ _ = output FloatLit as (start1 iis)++state87 :: LexerState+state87 err as [] = err as []+  where err _ _ = output IntLit as (start1 [])+state87 err as iis@(i:is) =+  case cclass i of+    15 -> state87 err (i:as) is+    16 -> state87 err (i:as) is+    17 -> state87 err (i:as) is+    18 -> state87 err (i:as) is+    14 -> state82 err (i:as) is+    _ -> err as iis+  where err _ _ = output IntLit as (start1 iis)++start88 :: Lexer+start88 is = state88 (\ as is -> gotError as is) "" is+state88 :: LexerState+state88 err as [] = err as []+state88 err as iis@(i:is) =+  case cclass i of+    15 -> state89 err (i:as) is+    16 -> state89 err (i:as) is+    17 -> state89 err (i:as) is+    _ -> err as iis++state89 :: LexerState+state89 err as [] = err as []+  where err _ _ = output IntLit as (start1 [])+state89 err as iis@(i:is) =+  case cclass i of+    15 -> state89 err (i:as) is+    16 -> state89 err (i:as) is+    17 -> state89 err (i:as) is+    _ -> err as iis+  where err _ _ = output IntLit as (start1 iis)++start90 :: Lexer+start90 is = state90 (\ as is -> gotError as is) "" is+state90 :: LexerState+state90 err as [] = err as []+state90 err as iis@(i:is) =+  case cclass i of+    15 -> state91 err (i:as) is+    16 -> state91 err (i:as) is+    17 -> state91 err (i:as) is+    18 -> state91 err (i:as) is+    24 -> state91 err (i:as) is+    25 -> state91 err (i:as) is+    26 -> state91 err (i:as) is+    27 -> state91 err (i:as) is+    28 -> state91 err (i:as) is+    29 -> state91 err (i:as) is+    51 -> state91 err (i:as) is+    52 -> state91 err (i:as) is+    53 -> state91 err (i:as) is+    54 -> state91 err (i:as) is+    55 -> state91 err (i:as) is+    56 -> state91 err (i:as) is+    _ -> err as iis++state91 :: LexerState+state91 err as [] = err as []+  where err _ _ = output IntLit as (start1 [])+state91 err as iis@(i:is) =+  case cclass i of+    15 -> state91 err (i:as) is+    16 -> state91 err (i:as) is+    17 -> state91 err (i:as) is+    18 -> state91 err (i:as) is+    24 -> state91 err (i:as) is+    25 -> state91 err (i:as) is+    26 -> state91 err (i:as) is+    27 -> state91 err (i:as) is+    28 -> state91 err (i:as) is+    29 -> state91 err (i:as) is+    51 -> state91 err (i:as) is+    52 -> state91 err (i:as) is+    53 -> state91 err (i:as) is+    54 -> state91 err (i:as) is+    55 -> state91 err (i:as) is+    56 -> state91 err (i:as) is+    _ -> err as iis+  where err _ _ = output IntLit as (start1 iis)++state92 :: LexerState+state92 err as [] = err as []+  where err _ _ = output Reservedop as (start1 [])+state92 err as iis@(i:is) =+  case cclass i of+    7 -> state93 err (i:as) is+    9 -> state93 err (i:as) is+    12 -> state93 err (i:as) is+    13 -> state93 err (i:as) is+    14 -> state93 err (i:as) is+    20 -> state93 err (i:as) is+    21 -> state93 err (i:as) is+    22 -> state93 err (i:as) is+    23 -> state93 err (i:as) is+    48 -> state93 err (i:as) is+    49 -> state93 err (i:as) is+    75 -> state93 err (i:as) is+    19 -> state94 err (i:as) is+    _ -> err as iis+  where err _ _ = output Reservedop as (start1 iis)++state93 :: LexerState+state93 err as [] = err as []+  where err _ _ = output Consym as (start1 [])+state93 err as iis@(i:is) =+  case cclass i of+    7 -> state93 err (i:as) is+    9 -> state93 err (i:as) is+    12 -> state93 err (i:as) is+    13 -> state93 err (i:as) is+    14 -> state93 err (i:as) is+    19 -> state93 err (i:as) is+    20 -> state93 err (i:as) is+    21 -> state93 err (i:as) is+    22 -> state93 err (i:as) is+    23 -> state93 err (i:as) is+    48 -> state93 err (i:as) is+    49 -> state93 err (i:as) is+    75 -> state93 err (i:as) is+    _ -> err as iis+  where err _ _ = output Consym as (start1 iis)++state94 :: LexerState+state94 err as [] = err as []+  where err _ _ = output Reservedop as (start1 [])+state94 err as iis@(i:is) =+  case cclass i of+    7 -> state93 err (i:as) is+    9 -> state93 err (i:as) is+    12 -> state93 err (i:as) is+    13 -> state93 err (i:as) is+    14 -> state93 err (i:as) is+    19 -> state93 err (i:as) is+    20 -> state93 err (i:as) is+    21 -> state93 err (i:as) is+    22 -> state93 err (i:as) is+    23 -> state93 err (i:as) is+    48 -> state93 err (i:as) is+    49 -> state93 err (i:as) is+    75 -> state93 err (i:as) is+    _ -> err as iis+  where err _ _ = output Reservedop as (start1 iis)++state95 :: LexerState+state95 err as [] = err as []+  where err _ _ = output Varsym as (start1 [])+state95 err as iis@(i:is) =+  case cclass i of+    7 -> state4 err (i:as) is+    9 -> state4 err (i:as) is+    12 -> state4 err (i:as) is+    14 -> state4 err (i:as) is+    19 -> state4 err (i:as) is+    20 -> state4 err (i:as) is+    21 -> state4 err (i:as) is+    22 -> state4 err (i:as) is+    23 -> state4 err (i:as) is+    48 -> state4 err (i:as) is+    49 -> state4 err (i:as) is+    75 -> state4 err (i:as) is+    13 -> state79 err (i:as) is+    _ -> err as iis+  where err _ _ = output Varsym as (start1 iis)++state96 :: LexerState+state96 err as [] = err as []+  where err _ _ = output Reservedop as (start1 [])+state96 err as iis@(i:is) =+  case cclass i of+    7 -> state4 err (i:as) is+    9 -> state4 err (i:as) is+    12 -> state4 err (i:as) is+    13 -> state4 err (i:as) is+    14 -> state4 err (i:as) is+    19 -> state4 err (i:as) is+    20 -> state4 err (i:as) is+    21 -> state4 err (i:as) is+    23 -> state4 err (i:as) is+    48 -> state4 err (i:as) is+    49 -> state4 err (i:as) is+    75 -> state4 err (i:as) is+    22 -> state79 err (i:as) is+    _ -> err as iis+  where err _ _ = output Reservedop as (start1 iis)++state97 :: LexerState+state97 err as [] = err as []+  where err _ _ = output Conid as (start1 [])+state97 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    14 -> state98 err (i:as) is+    _ -> state97 err (i:as) is+  where err _ _ = output Conid as (start1 iis)++start98 :: Lexer+start98 is = state98 (\ as is -> gotError as is) "" is+state98 :: LexerState+state98 err as [] = err as []+state98 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    8 -> err as iis+    10 -> err as iis+    11 -> err as iis+    15 -> err as iis+    16 -> err as iis+    17 -> err as iis+    18 -> err as iis+    47 -> err as iis+    74 -> err as iis+    76 -> err as iis+    51 -> state111 err (i:as) is+    52 -> state111 err (i:as) is+    56 -> state111 err (i:as) is+    57 -> state111 err (i:as) is+    58 -> state111 err (i:as) is+    60 -> state111 err (i:as) is+    65 -> state111 err (i:as) is+    66 -> state111 err (i:as) is+    67 -> state111 err (i:as) is+    69 -> state111 err (i:as) is+    70 -> state111 err (i:as) is+    72 -> state111 err (i:as) is+    73 -> state111 err (i:as) is+    7 -> state99 err (i:as) is+    9 -> state99 err (i:as) is+    12 -> state99 err (i:as) is+    22 -> state99 err (i:as) is+    49 -> state99 err (i:as) is+    23 -> state102 err (i:as) is+    48 -> state102 err (i:as) is+    75 -> state102 err (i:as) is+    13 -> state100 err (i:as) is+    14 -> state103 err (i:as) is+    19 -> state104 err (i:as) is+    20 -> state107 err (i:as) is+    21 -> state108 err (i:as) is+    50 -> state110 err (i:as) is+    53 -> state112 err (i:as) is+    54 -> state118 err (i:as) is+    55 -> state131 err (i:as) is+    59 -> state132 err (i:as) is+    61 -> state144 err (i:as) is+    62 -> state145 err (i:as) is+    63 -> state149 err (i:as) is+    64 -> state154 err (i:as) is+    68 -> state155 err (i:as) is+    71 -> state158 err (i:as) is+    _ -> state109 err (i:as) is++state99 :: LexerState+state99 err as [] = err as []+  where err _ _ = output Qvarsym as (start1 [])+state99 err as iis@(i:is) =+  case cclass i of+    7 -> state99 err (i:as) is+    9 -> state99 err (i:as) is+    12 -> state99 err (i:as) is+    13 -> state99 err (i:as) is+    14 -> state99 err (i:as) is+    19 -> state99 err (i:as) is+    20 -> state99 err (i:as) is+    21 -> state99 err (i:as) is+    22 -> state99 err (i:as) is+    23 -> state99 err (i:as) is+    48 -> state99 err (i:as) is+    49 -> state99 err (i:as) is+    75 -> state99 err (i:as) is+    _ -> err as iis+  where err _ _ = output Qvarsym as (start1 iis)++state100 :: LexerState+state100 err as [] = err as []+  where err _ _ = output Qvarsym as (start1 [])+state100 err as iis@(i:is) =+  case cclass i of+    7 -> state99 err (i:as) is+    9 -> state99 err (i:as) is+    12 -> state99 err (i:as) is+    14 -> state99 err (i:as) is+    19 -> state99 err (i:as) is+    20 -> state99 err (i:as) is+    21 -> state99 err (i:as) is+    23 -> state99 err (i:as) is+    48 -> state99 err (i:as) is+    49 -> state99 err (i:as) is+    75 -> state99 err (i:as) is+    13 -> state101 err (i:as) is+    22 -> state102 err (i:as) is+    _ -> err as iis+  where err _ _ = output Qvarsym as (start1 iis)++start101 :: Lexer+start101 is = state101 (\ as is -> gotError as is) "" is+state101 :: LexerState+state101 err as [] = err as []+state101 err as iis@(i:is) =+  case cclass i of+    7 -> state99 err (i:as) is+    9 -> state99 err (i:as) is+    12 -> state99 err (i:as) is+    14 -> state99 err (i:as) is+    19 -> state99 err (i:as) is+    20 -> state99 err (i:as) is+    21 -> state99 err (i:as) is+    22 -> state99 err (i:as) is+    23 -> state99 err (i:as) is+    48 -> state99 err (i:as) is+    49 -> state99 err (i:as) is+    75 -> state99 err (i:as) is+    13 -> state101 err (i:as) is+    _ -> err as iis++start102 :: Lexer+start102 is = state102 (\ as is -> gotError as is) "" is+state102 :: LexerState+state102 err as [] = err as []+state102 err as iis@(i:is) =+  case cclass i of+    7 -> state99 err (i:as) is+    9 -> state99 err (i:as) is+    12 -> state99 err (i:as) is+    13 -> state99 err (i:as) is+    14 -> state99 err (i:as) is+    19 -> state99 err (i:as) is+    20 -> state99 err (i:as) is+    21 -> state99 err (i:as) is+    22 -> state99 err (i:as) is+    23 -> state99 err (i:as) is+    48 -> state99 err (i:as) is+    49 -> state99 err (i:as) is+    75 -> state99 err (i:as) is+    _ -> err as iis++state103 :: LexerState+state103 err as [] = err as []+  where err _ _ = output Qvarsym as (start1 [])+state103 err as iis@(i:is) =+  case cclass i of+    7 -> state99 err (i:as) is+    9 -> state99 err (i:as) is+    12 -> state99 err (i:as) is+    13 -> state99 err (i:as) is+    19 -> state99 err (i:as) is+    20 -> state99 err (i:as) is+    21 -> state99 err (i:as) is+    22 -> state99 err (i:as) is+    23 -> state99 err (i:as) is+    48 -> state99 err (i:as) is+    49 -> state99 err (i:as) is+    75 -> state99 err (i:as) is+    14 -> state102 err (i:as) is+    _ -> err as iis+  where err _ _ = output Qvarsym as (start1 iis)++start104 :: Lexer+start104 is = state104 (\ as is -> gotError as is) "" is+state104 :: LexerState+state104 err as [] = err as []+state104 err as iis@(i:is) =+  case cclass i of+    7 -> state105 err (i:as) is+    9 -> state105 err (i:as) is+    12 -> state105 err (i:as) is+    13 -> state105 err (i:as) is+    14 -> state105 err (i:as) is+    20 -> state105 err (i:as) is+    21 -> state105 err (i:as) is+    22 -> state105 err (i:as) is+    23 -> state105 err (i:as) is+    48 -> state105 err (i:as) is+    49 -> state105 err (i:as) is+    75 -> state105 err (i:as) is+    19 -> state106 err (i:as) is+    _ -> err as iis++state105 :: LexerState+state105 err as [] = err as []+  where err _ _ = output Qconsym as (start1 [])+state105 err as iis@(i:is) =+  case cclass i of+    7 -> state105 err (i:as) is+    9 -> state105 err (i:as) is+    12 -> state105 err (i:as) is+    13 -> state105 err (i:as) is+    14 -> state105 err (i:as) is+    19 -> state105 err (i:as) is+    20 -> state105 err (i:as) is+    21 -> state105 err (i:as) is+    22 -> state105 err (i:as) is+    23 -> state105 err (i:as) is+    48 -> state105 err (i:as) is+    49 -> state105 err (i:as) is+    75 -> state105 err (i:as) is+    _ -> err as iis+  where err _ _ = output Qconsym as (start1 iis)++start106 :: Lexer+start106 is = state106 (\ as is -> gotError as is) "" is+state106 :: LexerState+state106 err as [] = err as []+state106 err as iis@(i:is) =+  case cclass i of+    7 -> state105 err (i:as) is+    9 -> state105 err (i:as) is+    12 -> state105 err (i:as) is+    13 -> state105 err (i:as) is+    14 -> state105 err (i:as) is+    19 -> state105 err (i:as) is+    20 -> state105 err (i:as) is+    21 -> state105 err (i:as) is+    22 -> state105 err (i:as) is+    23 -> state105 err (i:as) is+    48 -> state105 err (i:as) is+    49 -> state105 err (i:as) is+    75 -> state105 err (i:as) is+    _ -> err as iis++state107 :: LexerState+state107 err as [] = err as []+  where err _ _ = output Qvarsym as (start1 [])+state107 err as iis@(i:is) =+  case cclass i of+    7 -> state99 err (i:as) is+    9 -> state99 err (i:as) is+    12 -> state99 err (i:as) is+    14 -> state99 err (i:as) is+    19 -> state99 err (i:as) is+    20 -> state99 err (i:as) is+    21 -> state99 err (i:as) is+    22 -> state99 err (i:as) is+    23 -> state99 err (i:as) is+    48 -> state99 err (i:as) is+    49 -> state99 err (i:as) is+    75 -> state99 err (i:as) is+    13 -> state102 err (i:as) is+    _ -> err as iis+  where err _ _ = output Qvarsym as (start1 iis)++start108 :: Lexer+start108 is = state108 (\ as is -> gotError as is) "" is+state108 :: LexerState+state108 err as [] = err as []+state108 err as iis@(i:is) =+  case cclass i of+    7 -> state99 err (i:as) is+    9 -> state99 err (i:as) is+    12 -> state99 err (i:as) is+    13 -> state99 err (i:as) is+    14 -> state99 err (i:as) is+    19 -> state99 err (i:as) is+    20 -> state99 err (i:as) is+    21 -> state99 err (i:as) is+    23 -> state99 err (i:as) is+    48 -> state99 err (i:as) is+    49 -> state99 err (i:as) is+    75 -> state99 err (i:as) is+    22 -> state102 err (i:as) is+    _ -> err as iis++state109 :: LexerState+state109 err as [] = err as []+  where err _ _ = output Qconid as (start1 [])+state109 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    14 -> state98 err (i:as) is+    _ -> state109 err (i:as) is+  where err _ _ = output Qconid as (start1 iis)++start110 :: Lexer+start110 is = state110 (\ as is -> gotError as is) "" is+state110 :: LexerState+state110 err as [] = err as []+state110 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    _ -> state111 err (i:as) is++state111 :: LexerState+state111 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state111 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state112 :: LexerState+state112 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state112 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    51 -> state113 err (i:as) is+    61 -> state115 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state113 :: LexerState+state113 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state113 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    67 -> state114 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state114 :: LexerState+state114 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state114 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    55 -> state110 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state115 :: LexerState+state115 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state115 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    51 -> state116 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state116 :: LexerState+state116 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state116 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    67 -> state117 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state117 :: LexerState+state117 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state117 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    67 -> state110 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state118 :: LexerState+state118 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state118 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    64 -> state110 err (i:as) is+    51 -> state119 err (i:as) is+    55 -> state121 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state119 :: LexerState+state119 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state119 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    68 -> state120 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state120 :: LexerState+state120 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state120 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    51 -> state110 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state121 :: LexerState+state121 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state121 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    56 -> state122 err (i:as) is+    66 -> state126 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state122 :: LexerState+state122 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state122 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    51 -> state123 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state123 :: LexerState+state123 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state123 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    69 -> state124 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state124 :: LexerState+state124 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state124 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    61 -> state125 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state125 :: LexerState+state125 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state125 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    68 -> state110 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state126 :: LexerState+state126 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state126 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    59 -> state127 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state127 :: LexerState+state127 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state127 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    70 -> state128 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state128 :: LexerState+state128 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state128 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    59 -> state129 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state129 :: LexerState+state129 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state129 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    63 -> state130 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state130 :: LexerState+state130 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state130 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    57 -> state110 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state131 :: LexerState+state131 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state131 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    61 -> state113 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state132 :: LexerState+state132 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state132 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    56 -> state110 err (i:as) is+    62 -> state133 err (i:as) is+    63 -> state136 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state133 :: LexerState+state133 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state133 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    65 -> state134 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state134 :: LexerState+state134 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state134 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    64 -> state135 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state135 :: LexerState+state135 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state135 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    66 -> state125 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++start136 :: Lexer+start136 is = state136 (\ as is -> gotError as is) "" is+state136 :: LexerState+state136 err as [] = err as []+state136 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    56 -> state137 err (i:as) is+    67 -> state140 err (i:as) is+    _ -> state111 err (i:as) is++state137 :: LexerState+state137 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state137 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    59 -> state138 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state138 :: LexerState+state138 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state138 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    72 -> state139 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++start139 :: Lexer+start139 is = state139 (\ as is -> gotError as is) "" is+state139 :: LexerState+state139 err as [] = err as []+state139 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    61 -> state110 err (i:as) is+    66 -> state110 err (i:as) is+    _ -> state111 err (i:as) is++state140 :: LexerState+state140 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state140 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    68 -> state141 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state141 :: LexerState+state141 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state141 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    51 -> state142 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state142 :: LexerState+state142 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state142 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    63 -> state143 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state143 :: LexerState+state143 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state143 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    53 -> state114 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state144 :: LexerState+state144 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state144 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    55 -> state125 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state145 :: LexerState+state145 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state145 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    64 -> state146 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state146 :: LexerState+state146 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state146 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    54 -> state147 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state147 :: LexerState+state147 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state147 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    69 -> state148 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state148 :: LexerState+state148 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state148 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    61 -> state114 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state149 :: LexerState+state149 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state149 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    55 -> state150 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state150 :: LexerState+state150 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state150 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    71 -> state151 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state151 :: LexerState+state151 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state151 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    68 -> state152 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state152 :: LexerState+state152 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state152 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    73 -> state153 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state153 :: LexerState+state153 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state153 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    65 -> state114 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state154 :: LexerState+state154 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state154 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    56 -> state110 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state155 :: LexerState+state155 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state155 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    73 -> state153 err (i:as) is+    58 -> state156 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state156 :: LexerState+state156 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state156 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    55 -> state157 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state157 :: LexerState+state157 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state157 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    63 -> state110 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state158 :: LexerState+state158 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state158 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    58 -> state159 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state159 :: LexerState+state159 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state159 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    55 -> state160 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state160 :: LexerState+state160 err as [] = err as []+  where err _ _ = output Qvarid as (start1 [])+state160 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    66 -> state114 err (i:as) is+    _ -> state111 err (i:as) is+  where err _ _ = output Qvarid as (start1 iis)++state161 :: LexerState+state161 err as [] = err as []+  where err _ _ = output Reservedid as (start1 [])+state161 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    _ -> state162 err (i:as) is+  where err _ _ = output Reservedid as (start1 iis)++state162 :: LexerState+state162 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state162 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state163 :: LexerState+state163 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state163 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    51 -> state164 err (i:as) is+    61 -> state166 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state164 :: LexerState+state164 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state164 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    67 -> state165 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state165 :: LexerState+state165 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state165 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    55 -> state161 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state166 :: LexerState+state166 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state166 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    51 -> state167 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state167 :: LexerState+state167 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state167 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    67 -> state168 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state168 :: LexerState+state168 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state168 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    67 -> state161 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state169 :: LexerState+state169 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state169 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    64 -> state161 err (i:as) is+    51 -> state170 err (i:as) is+    55 -> state172 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state170 :: LexerState+state170 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state170 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    68 -> state171 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state171 :: LexerState+state171 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state171 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    51 -> state161 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state172 :: LexerState+state172 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state172 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    56 -> state173 err (i:as) is+    66 -> state177 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state173 :: LexerState+state173 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state173 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    51 -> state174 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state174 :: LexerState+state174 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state174 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    69 -> state175 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state175 :: LexerState+state175 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state175 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    61 -> state176 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state176 :: LexerState+state176 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state176 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    68 -> state161 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state177 :: LexerState+state177 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state177 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    59 -> state178 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state178 :: LexerState+state178 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state178 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    70 -> state179 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state179 :: LexerState+state179 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state179 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    59 -> state180 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state180 :: LexerState+state180 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state180 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    63 -> state181 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state181 :: LexerState+state181 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state181 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    57 -> state161 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state182 :: LexerState+state182 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state182 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    61 -> state164 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state183 :: LexerState+state183 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state183 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    56 -> state161 err (i:as) is+    62 -> state184 err (i:as) is+    63 -> state187 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state184 :: LexerState+state184 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state184 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    65 -> state185 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state185 :: LexerState+state185 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state185 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    64 -> state186 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state186 :: LexerState+state186 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state186 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    66 -> state176 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state187 :: LexerState+state187 err as [] = err as []+  where err _ _ = output Reservedid as (start1 [])+state187 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    56 -> state188 err (i:as) is+    67 -> state191 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Reservedid as (start1 iis)++state188 :: LexerState+state188 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state188 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    59 -> state189 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state189 :: LexerState+state189 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state189 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    72 -> state190 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state190 :: LexerState+state190 err as [] = err as []+  where err _ _ = output Reservedid as (start1 [])+state190 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    61 -> state161 err (i:as) is+    66 -> state161 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Reservedid as (start1 iis)++state191 :: LexerState+state191 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state191 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    68 -> state192 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state192 :: LexerState+state192 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state192 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    51 -> state193 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state193 :: LexerState+state193 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state193 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    63 -> state194 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state194 :: LexerState+state194 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state194 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    53 -> state165 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state195 :: LexerState+state195 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state195 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    55 -> state176 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state196 :: LexerState+state196 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state196 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    64 -> state197 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state197 :: LexerState+state197 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state197 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    54 -> state198 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state198 :: LexerState+state198 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state198 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    69 -> state199 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state199 :: LexerState+state199 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state199 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    61 -> state165 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state200 :: LexerState+state200 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state200 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    55 -> state201 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state201 :: LexerState+state201 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state201 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    71 -> state202 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state202 :: LexerState+state202 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state202 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    68 -> state203 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state203 :: LexerState+state203 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state203 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    73 -> state204 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state204 :: LexerState+state204 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state204 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    65 -> state165 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state205 :: LexerState+state205 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state205 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    56 -> state161 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state206 :: LexerState+state206 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state206 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    73 -> state204 err (i:as) is+    58 -> state207 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state207 :: LexerState+state207 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state207 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    55 -> state208 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state208 :: LexerState+state208 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state208 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    63 -> state161 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state209 :: LexerState+state209 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state209 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    58 -> state210 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state210 :: LexerState+state210 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state210 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    55 -> state211 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state211 :: LexerState+state211 err as [] = err as []+  where err _ _ = output Varid as (start1 [])+state211 err as iis@(i:is) =+  case cclass i of+    0 -> err as iis+    1 -> err as iis+    2 -> err as iis+    3 -> err as iis+    4 -> err as iis+    5 -> err as iis+    6 -> err as iis+    7 -> err as iis+    8 -> err as iis+    9 -> err as iis+    11 -> err as iis+    12 -> err as iis+    13 -> err as iis+    14 -> err as iis+    19 -> err as iis+    20 -> err as iis+    21 -> err as iis+    22 -> err as iis+    23 -> err as iis+    47 -> err as iis+    48 -> err as iis+    49 -> err as iis+    74 -> err as iis+    75 -> err as iis+    76 -> err as iis+    66 -> state165 err (i:as) is+    _ -> state162 err (i:as) is+  where err _ _ = output Varid as (start1 iis)++state212 :: LexerState+state212 err as [] = err as []+  where err _ _ = output Special as (start1 [])+state212 err as iis@(i:is) =+  case cclass i of+    13 -> state213 err (i:as) is+    _ -> err as iis+  where err _ _ = output Special as (start1 iis)++state213 :: LexerState+state213 err as is = nestedComment as is state214++state214 :: LexerState+state214 err as is = output NestedComment as (start1 is)++
+ tools/base/parse2/Lexer/HsLexMerge.hs view
@@ -0,0 +1,88 @@+module HsLexMerge where+import HsLexerPos(Pos(..),startPos,nextPos,nextPos1)+import HsTokens+--import OpTypes(eqBy)+import List(groupBy)+import Unlit(CommentClass(..))++{-+ #mergeLex#: Merge literate comments with a token stream+Note: this may split tokens, so the result is not suitable for parsing!!+-}+--mergeLex :: ([String], [PosToken]) -> [PosToken]+mergeLex ([],ts) = ts -- for efficiency when tokens are not from a literal file+mergeLex (litcmnts,ts) =+    rejoin .+    addSpace startPos .+    merge (groupLit (addPos litcmnts)) .+    concatMap split .+    filter notSpace +    $ ts+  where+    addPos = zipWith pos [1..]+       where pos l s = (Pos 0 l 1,s) -- dummy character position++    notSpace (t,_) = t/=Whitespace++    split (t,(Pos n y x,s)) =+	[(t,(Pos n y' x',l))|((y',x'),l)<-zip ps (lines s),l/=""]+      where ps = zip [y..] (x:repeat 1)++    rejoin [] = []+    rejoin (t@(tt,(p@Pos{char=n},s)):ts) =+      case rejoin ts of+        t'@(tt',(Pos{char=n'},s')):ts' | n>0 && tt==tt' && n'==n -> (tt,(p,s++s')):ts'+	ts' -> t:ts'++    groupLit = map join . groupBy bothLitCmnt+      where+        bothLitCmnt (_,(LitCmnt,_)) (_,(LitCmnt,_)) = True+	bothLitCmnt _ _ = False++        join ((p,(LitCmnt,s)):cs) = (p,(LitCmnt,unlines (s:map (snd.snd) cs)))+        join [l] = l++    litc (p,(cc,c)) = (conv cc,(p,c))+      where+        conv LitCmnt = LiterateComment+	conv _       = Whitespace++    merge [] ts = ts+    merge cmnts [] = map litc cmnts++    merge cs0@(c@(pc,sc):cs) ts0@(t@(tt,(pt,s)):ts) =+	if pc<=pt+	then litc c:merge cs ts0+	else --if pt'<=pc then+	       t:merge cs0 ts+	     --else error "literate comment inside token not handled yet"+        -- TODO: handle tokens containing literate comments+{-+      where+        pc' = nextPos pc sc+	pt' = nextPos pt s++        overlap1 pc sc pt s =+           case compare pc pt of+             LT -> litc (pc,sc1):overlap pt sc2 s+	       where (sc1,sc2) = split pc pt sc+             GT -> (t,(pt,s1)):overlap pc sc s2+	       where (s1,s2) = split pt pc s+	     EQ -> overlap pc sc s++        split pc pt (c:cs) | pc<pt = apFst (c:) (split (nextPos1 pc c) pt cs)+        split _ _ s = ("",s)++        overlap pc (c:cs) (' ':s) =+-}++    addSpace p0 [] = []+    addSpace p0 (t@(_,(p,s)):ts) =+       (if p0<p+        then ((Whitespace,(p0,space p0 p)):)+        else id) $ t:addSpace (nextPos p s) ts++    space (Pos _ y0 x0) (Pos _ y x) = vspace y0 x0 y x+    vspace y0 x0 y x =+      if y0<y+      then '\n':vspace (y0+1) 1 y x+      else replicate (x-x0) ' '
+ tools/base/parse2/Lexer/HsLexUtils.hs view
@@ -0,0 +1,41 @@+module HsLexUtils(module HsLexUtils,Token(..)) where+import HsTokens++gotEOF [] = []+gotEOF as = [(GotEOF, reverse as)]++gotError as is =+  (ErrorToken, reverse as):+  if null is then [(GotEOF,[])] else [(TheRest,is{-reverse (take 80 is)-})]++-- Inlining the call to output does not make a big difference.+--output token as cont = (token, reverse as):cont++-- Not reversing the token string seems to save about 10% of the time with HBC.+-- The difference in speed seems insignificant with ghc-6.0.1 -O.+output token as cont = (token,reverse as):cont++-- This avoids constructing a closure for the call to reverse.+-- This saves about 10% too.+{-+output token as cont =+    rev as []+  where+    rev [] as' = (token,as'):cont+    rev (a:as) as' = rev as (a:as')+--}++-- #ifndef __HBC__+isSymbol _ = False+-- #endif++nestedComment as is next = nest 0 as is+  where+    nest n as is =+      case is of+	'-':'}':is -> if n==0+		      then next gotError ('}':'-':as) is+		      else nest (n-1) ('}':'-':as) is+        '{':'-':is -> nest (n+1) ('-':'{':as) is+	c:is -> nest n (c:as) is+	_ -> gotError as is -- EOF inside comment
+ tools/base/parse2/Lexer/HsLexer.hs view
@@ -0,0 +1,59 @@+module HsLexer where+import ParseMonad+import HsTokens(Token(..))+--import MUtils+--import IOExts(trace)++{-++This module implements the part of the lexer that interacts with the+Happy parser, i.e., the layout processing.+-}++lexer cont = cont =<< token++{-+ #popContext#, together with the error handling in the Happy parser,+implements the equation dealing with parse-error(t) in the definition of+the function L, in secion 9.3 in the revised Haskell 98 report.+-}++popContext =  do (ts,m:ms) <- get+		 if m/=0 then set (ts,ms) -- redudant test+		  else fail "Grammar bug? Unbalanced implicit braces?"++token = uncurry l =<< get+  where+    -- Here is the rest of the function L in the report:+    -- The equations for cases when <n> is the first token:+    l ts0@((Indent n,(p,_)):ts) ms0@(m:ms)+	| m==n      = ok (semi p)    ts  ms0+	| n<m       = ok (vrcurly p) ts0 ms+    l ((Indent _,_):ts) ms = l ts ms+    -- The equations for cases when {n} is the first token:+    l ((Open n,(p,_)):ts) (m:ms) | n>m = ok (vlcurly p) ts (n:m:ms)+    l ((Open n,(p,_)):ts) []     | n>0 = ok (vlcurly p) ts [n]+    l ((Open n,(p,_)):ts) ms           = ok (vlcurly p) -- (1st of 2 tokens)+					    (vrcurly p:(Indent n,(p,"")):ts)+				            (0:ms)+    -- Equations for explicit braces:+    l (t1@(Special,(_,"}")):ts) (0:ms) = ok t1 ts ms+    l (t1@(Layout, (_,"}")):ts) (0:ms) = ok t1 ts ms -- (2nd of 2 tokens)+    -- Haskell 98 Report bug workaround:+    l ts0@(t1@(Special,(p,"}")):ts) (m:ms) = ok (vrcurly p) ts0 ms+    l (t1@(Special,(_,"}")):ts) ms     = fail "unexpected }"+      +    l (t1@(Special,(p,"{")):ts) ms     = ok t1 ts (0:ms)+    -- The equation for ordinary tokens:+    l (t:ts) ms = ok t ts ms+    -- Equations for end of file:+    l [] [] = return eoftoken+    l [] (m:ms) = if m/=0+		  then ok (vrcurly eof) [] ms+		  else fail "missing } at eof"++    ok t ts ctx =+      --trace (show (t,ctx)) $+      setreturn t (ts,ctx)++    vlcurly p = (Layout,(p,"{"))+    vrcurly p = (Layout,(p,"}"))+    semi p = (Special,(p,";"))
+ tools/base/parse2/Lexer/HsLexerPass1.hs view
@@ -0,0 +1,54 @@+module HsLexerPass1(module HsLexerPass1,module HsLexerPos) where+import HsLex(haskellLex)+import HsLexUtils+import HsLayoutPre(layoutPre,PosToken)+import HsLexerPos+import List(mapAccumL)++default(Int)++{-++The function #lexerPass1# handles the part of lexical analysis that+can be done independently of the parser, i.e., the tokenization and the+addition of the extra layout tokens &lt;n&gt; and {n}, as specified in+section 9.3 of the revised Haskell 98 Report.+-}++type LexerOutput = [PosToken]+type Lexer = String -> LexerOutput++lexerPass1 :: Lexer+lexerPass1 = lexerPass1Only . lexerPass0++lexerPass1Only = layoutPre . rmSpace++rmSpace = filter (notWhite.fst)++notWhite t = t/=Whitespace &&+             t/=Commentstart && t/=Comment &&+             t/=NestedComment++-- Tokenize and add position information:++lexerPass0 :: Lexer+lexerPass0 = lexerPass0' startPos++lexerPass0' :: Pos -> Lexer+lexerPass0' pos0 = addPos . haskellLex . rmcr+  where+    addPos = snd . mapAccumL pos pos0++    pos p (t,s) = {-seq p'-} (p',(t,(p,s)))+        where p' = nextPos p s+--      where s = reverse r++{-++Since #nextPos# examines one character at a time, it will increase the line+number by 2 if it sees \CR\LF, which can happen when reading DOS files on+a Unix like system.+Since the extra \CR characters can cause trouble later as well, we choose+to simply remove them here.+-}+rmcr ('\CR':'\LF':s) = '\LF':rmcr s+rmcr (c:s) = c:rmcr s+rmcr "" = ""
+ tools/base/parse2/Lexer/HsLexerPos.hs view
@@ -0,0 +1,34 @@+module HsLexerPos where++data Pos = Pos { char, line, column :: !Int } deriving (Show)++simpPos (Pos _ l c) = (l,c)++-- Some functions still put fake char positions in Pos values, so...+instance Eq Pos where p1 == p2 = simpPos p1 == simpPos p2+instance Ord Pos where compare p1 p2 = compare (simpPos p1) (simpPos p2)+++startPos = Pos { char=0,+		 line=1,+		 column=1  -- The first column is designated column 1, not 0.+	       }++nextPos :: Pos -> String -> Pos+nextPos = foldl nextPos1++nextPos1 :: Pos -> Char -> Pos+nextPos1 (Pos n y x) c =+    case c of+      -- The characters newline, return, linefeed, and formfeed, all start+      -- a new line.+      '\n'  -> Pos (n+1) (y+1) 1+      '\CR' -> Pos (n+1) (y+1) 1+      '\LF' -> Pos (n+1) (y+1) 1+      '\FF' -> Pos (n+1) (y+1) 1+      -- Tab stops are 8 characters apart.+      -- A tab character causes the insertion of enough spaces to align the+      -- current position with the next tab stop.+      -- + (not in the report) the first tab stop is column 1.+      '\t'  -> Pos (n+1) y (x+8-(x-1) `mod` 8)+      _ -> Pos (n+1) y (x+1)
+ tools/base/parse2/Lexer/HsTokens.hs view
@@ -0,0 +1,27 @@+module HsTokens where++-- Haskell token classifications:++data Token+  = Varid | Conid | Varsym | Consym+  | Reservedid | Reservedop  | Specialid+  | IntLit | FloatLit | CharLit | StringLit+  | Qvarid | Qconid | Qvarsym | Qconsym+  | Special | Whitespace++  | NestedCommentStart -- will cause a call to an external function+  | NestedComment  -- from the external function+  | LiterateComment -- not handled by the lexer++  | Commentstart  -- dashes+  | Comment -- what follows the dashes++  | ErrorToken | GotEOF | TheRest++  | ModuleName | ModuleAlias -- recognized in a later pass++  -- Inserted during layout processing (see Haskell 98, 9.3):+  | Layout     -- for implicit braces+  | Indent Int -- <n>, to preceed first token on each line+  | Open Int   -- {n}, after let, where, do or of, if not followed by a "{"+  deriving (Show,Eq,Ord)
+ tools/base/parse2/LexerGen/CompileRegExp.hs view
@@ -0,0 +1,27 @@+{-++Compiling regular expressions, the new way.+-}+module CompileRegExp where+import RegExpOps+import qualified Data.Map as M+import Maybe(isJust,fromJust)+--import Trace++compile r = number (build M.empty [r])+  where+    build dfa [] = []+    build dfa (r:rs) =+       if isJust (M.lookup r dfa)+       then build dfa rs+       else (r,fs):build dfa' (frs++rs)+     where+       dfa' = M.insert r fs dfa+       fs = factors r+       frs = map snd (snd fs)++    number states = map numb states+      where+        mapping = M.fromList (zip (map fst states) [(1::Int) ..])+	num = fromJust . (\k -> M.lookup k mapping)++        numb (r,(b,edges)) = (num r,(b,[(t,num r)|(t,r)<-edges]))
+ tools/base/parse2/LexerGen/DFA.hs view
@@ -0,0 +1,47 @@+module DFA where+import qualified OrdMap as OM+import MUtils(apFst,mapFst,mapSnd,collectByFst,collectBySnd,usort)+import Maybe(fromJust)++type DMap s i o = OM.OrdMap s ([(i,s)],[(o,s)])+newtype DFA s i o = DFA (DMap s i o)++---+{-+instance (Show s,Show i,Show o) => Show (DFA s i o) where+  showsPrec d (DFA m) = showsPrec d (OM.toList m)+-}++showDFA (n,DFA dfa) = "("++show n++","++showStates (OM.toList dfa)++")"+  where+    showStates = show . mapSnd (apFst collectBySnd)++---++tokenClasses x = collectBySnd . collectByFst . dfaInputEdges $ x++dfaInputEdges (DFA m) = [(e,(s,g))|(s,(is,os))<-OM.toList m,(e,g)<-is]++renumberEdges tclss (DFA ss) = DFA (fmap (apFst renEdges) ss)+  where+    renEdges is = usort $ mapFst renEdge is++    renEdge c = fromJust (OM.lookup c tcmap)++    tcmap = OM.fromList tclss+++renumberStates ((start,final),DFA detm) =+    ((subst start,map subst final),+     DFA . OM.fromList . map subststate . OM.toList $ detm)+  where+    oldstate = OM.indices detm+    newstate = OM.fromList (zip oldstate [(1::Int)..])+    +    subststate (st,(iedges,oedges)) =+        (subst st,(mapSnd subst iedges,mapSnd subst oedges))++    subst st =+      case OM.lookup st newstate of+        Just s -> s+	Nothing -> error ("No mapping for "++show st)
+ tools/base/parse2/LexerGen/DetMachine.hs view
@@ -0,0 +1,35 @@+module DetMachine where+import NondetMachine+import FSM+import DFA(DFA(..))+import qualified OrdMap as OM++-- Representation of Deterministic Finite State Machines:++type DState = [State]++-- Translation of nondeterministic to deterministic state machines:++deterministicMachine ((start,final),nfa) =+    ((states inited,finalstates),DFA detm)+  where+    inited = initM nfa start+    detm = determine inited (OM.empty)+    determine state@(N g eg ss) detm =+      case OM.lookup ss detm of+        Just _ -> detm+	Nothing ->+	    foldr determine detm' next+	  where+	    detm' = OM.add (ss,(ithis,othis)) detm+	    next = map snd onext++map snd inext+	    inext = getnext canAccept+	    onext = getnext canOutput+	    ithis = this inext+	    othis = this onext+	    this next = [(t,states ss)|(ts,ss)<-next,t<-ts]+	    getnext f = [(ts,goto state ss)|(ts,ss)<-f state]++    finalstates = [ss | ss<-OM.indices detm,final `elem` ss]++states (N _ _ ss) = ss
+ tools/base/parse2/LexerGen/DetMachineToHaskell2.hs view
@@ -0,0 +1,204 @@+module DetMachineToHaskell2(dfaToHaskell,CaseOf(..),OutputFun(..)) where+import PPrint+import HaskellChars+import HsTokens+import List(partition,sort,sortBy,nub)+import DFA(DFA(..))+import qualified OrdMap as OM+import OpTypes(cmpBy)+import MUtils(collectBySnd)+import Trace(trace)++dfaToHaskell charclasses modname imports funname ((init,final),DFA dfa) =+    "module" & modname & "("!funname!")" & "where" & nl &+    vmap ("import"&) imports & nl &+    "type" & "Output" & "=" & "[(Token,String)]" & nl &+    "type" & "Input" & "=" & "String" & nl &+    "type" & "Acc"  & "=" & "Input" & "-- reversed" & nl &+    "type" & "Lexer"  & "=" & "Input -> Output" & nl &+    "type" & "LexerState"  & "=" & "(Acc->Lexer) -> Acc -> Lexer" & nl &+    nl &+    funname & "::" & "Lexer" & nl &+    funname & "is" & "=" & start init "is" & nl &+    nl &+    charclassfundef &+    statesToHaskell final charclassfun dfa+  where+    (charclassfundef,charclassfun) =+      case charclasses::(Maybe [(HaskellChar,Int)]) of+        Nothing -> (nil,id)+	Just ccs -> (charClassFunToHaskell ccs & nl,("cclass" &))++charClassFunToHaskell ccs =+    "cclass" & "::" & "Char" & "->" & "Int" & nl &+    "cclass" & "c" & "=" & nl &+    indented (haskellCharCase "c" show "0" ccs) & nl++state st = "state"!st+scall st err acc is = state st & err & acc & is -- state function call+lhs st is = scall st "err" "as" is -- lhs of state function++startstate st = "start"!st+start st is = startstate st & is -- (re)start from state +startlhs st is = start st is -- lhs of state start function++statesToHaskell final ccfun dfa =+    vmap (stateToHaskell final (ccfun,alphabet)) states+  where+    states = OM.toList dfa+    alphabet =+      case errorValue of+	Just e ->  Just (e:nub [c|(_,(iedges,_))<-states,(c,_)<-iedges])+	Nothing -> Nothing++stateToHaskell final ccinfo ste@(st,(_,oedges)) =+    startdef &+    state st & "::" & "LexerState" & nl &+    stateToHaskell'' final ccinfo ste+  where+    -- If there are output edges, this state can't be a start state.+    startdef =+      if null oedges+      then startstate st & "::" & "Lexer" & nl &+           startlhs st "is" & "=" & scall st err (show "") "is" & nl+      else nil++    err = "("!"\\"&"as"&"is"&"->"&oedgesToHaskell "is" oedges !")"++stateToHaskell'' final ccinfo (st,([],oedges@(_:_))) =+  lhs st "is" & "=" & indented (oedgesToHaskell "is" oedges) & nl+stateToHaskell'' final ccinfo (st,es@(_,oedges)) =+  lhs st "[]" & "=" & indented (eofEdge st final oedges) & nl &+  lhs st "iis@(i:is)" & "=" &+  stateToHaskell' ccinfo es & nl++eofEdge st final []     | st `elem` final = "gotEOF" & "as"+eofEdge _  _     oedges                   =+    opterrfun oedges "[]" ("err"&"as"&"[]")+    --oedgesToHaskell "[]" oedges++stateToHaskell' ccinfo ([],    oedges) = oedgesToHaskell "iis" oedges+stateToHaskell' (ccfun,Just allClasses) (iedges@(_:_),oedges) =+  nl &+  indented (opterrfun oedges "iis"(+    caseExp (ccfun (pr"i"))+            opt_iedgeToHaskell'+	    (opt_iedgeToHaskell' iedge')+	    iedges''))+  where+    (_,iedge'):iedges' = sortBy order $+			 collectBySnd [(c,lookup c iedges)|c<-allClasses]+    order = cmpBy (negate.length.fst)+    iedges'' = [(c,st)|(cs,st)<-iedges',c<-cs]++    opt_iedgeToHaskell' = maybe ("err"&"as"&"iis") iedgeToHaskell'++stateToHaskell' (ccfun,Nothing) (iedges,oedges) =+  nl &+  indented (opterrfun oedges "iis"(+    caseExp (ccfun (pr"i"))+            iedgeToHaskell'+	    ("err"&"as"&"iis") -- (oedgesToHaskell "iis" oedges)+	    iedges))++opterrfun oedges iis body =+    if null oedges+    then body+    else body&nl&"where"&"err"&"_ _"&"="&oedgesToHaskell iis oedges+{-+    else "let"&"err"&"_ _"&"="&oedgesToHaskell iis oedges & nl &+	  "in"&body+-}+--iedgesToHaskell = vpr . map iedgeToHaskell+--iedgeToHaskell (c,st) = show c & "->" & iedgeToHaskell' st++iedgeToHaskell' st = scall st "err" "(i:as)" "is"++oedgesToHaskell is = oedgesToHaskell' "as" is+oedgesToHaskell' as is [] = "gotError" & as & is+oedgesToHaskell' as is [oedge] = oedgeToHaskell as is oedge+oedgesToHaskell' as is oedges0 =+  trace msg $+  oedgeToHaskell as is oedge+  -- & nl & "--" & msg+  where+    -- On ambiguities, make a choice by comparing token classes:+    oedges = sort oedges0+    oedge = last oedges -- give priority to later tokens in the token data type+    msg = "Machine is nondeterministic: "++show oedges+oedgeToHaskell as is (os,st) =+-- "("!show os!","&"reverse"&"as"!")"&":"&state st & show "" & is+  output os (pr as) (pr st) (pr is)+++--++class Show token => OutputFun token where+  output :: token -> Document -> Document -> Document -> Document++  output = default_output++default_output token as next is =+  "output" & show token & as & "("!startstate next & is !")"++instance OutputFun Token where+  output token as next is =+    case token of+      NestedCommentStart -> "nestedComment" & as & is & state next+      _ -> default_output token as next is++class CaseOf a where+  caseExp :: (Printable exp,Printable rhs) =>+             exp -> (v->rhs) -> rhs -> [(a,v)] -> Document+  errorValue :: Maybe a+  errorValue = Nothing++--++instance CaseOf HaskellChar where caseExp = haskellCharCase++haskellCharCase e rhs defaultrhs cases =+    caseE e (haskelLCharCaseBranches cases)+  where+    haskelLCharCaseBranches cases =+      case partition (isAscii . fst) cases of+	(as,us) -> vpr' (map asciiCharClass as++[uniCharClasses us])++    isAscii (ASCII _) = True+    isAscii _ = False++    asciiCharClass (ASCII c,n) = show c & "->" & rhs n++    uniCharClasses [] = "_" & "->" & defaultrhs+    uniCharClasses us =+      "c" & indented (+        vpr' $ ("|" & "isAscii" & "c" & "->" & defaultrhs):+	      map uniCharClass us +++	      [defaultcase])++    uniCharClass (u,n) = "|" & tstFunc u & "c" & "->" & rhs n++    defaultcase = "|" & "otherwise" & "->" & defaultrhs++    tstFunc u =+      case u of+        UniWhite -> "isSpace"+	UniSymbol -> "isSymbol"+	UniDigit -> "isDigit"+	UniLarge -> "isUpper"+	UniSmall -> "isLower"++instance CaseOf Int where caseExp = simpleCase; errorValue=Just 0+instance CaseOf Char where caseExp = simpleCase++simpleCase e rhs defaultrhs cases =+    caseE e (branches cases)+  where+    branches cases = vpr' (map branch cases++[defaultbranch])++    branch (a,v) = show a & "->" & rhs v+    defaultbranch = "_" & "->" & defaultrhs++vpr' = prsep nl++caseE e bs = "case" & e & "of" & nl & indented bs
+ tools/base/parse2/LexerGen/FSM.hs view
@@ -0,0 +1,74 @@+module FSM(NFA(..),Edge(..),Trans(..),State(..),Map(..),compileRegExp) where+import RegExp+import qualified IntMap as M++-- The representation of (nondeterministic) Finite State Machines:++type Map a = M.IntMap a++type State = Int+data Edge t = E | T t deriving (Eq,Ord,Show)+newtype NFA t = NFA (Map [(Edge t,State)]) deriving (Show)++empty = NFA M.empty++-- Compilation of Regular Expressions into Finite State Machines:++compileRegExp :: RegExp t -> ((State,State),NFA t)+compileRegExp re = run (compile0 re) empty++compile0 re =+  do s <- newstate+     g <- newstate+     compile s g re+     return (s,g)++compile s g re =+     case re of+       Zero -> return ()+       One -> addedge s E g+       S t -> addedge s (T t) g+       re1 :& re2 ->+         do b <- newstate+	    compile s b re1+	    compile b g re2+       re1 :! re2 ->+         do compile s g re1+	    compile s g re2+       re1 :-! re2 -> compile s g re1 -- !!+       Many re ->+         do b <- newstate+	    addedge s E b+	    compile b b re+	    addedge b E g+       Some re ->+         do (s',g') <- compile0 re+	    addedge s E s'+	    addedge g' E s' +	    addedge g' E g++-- A Regular Expression Compiler Monad:+-- (It's a state monad, where the state contains the next unused state+--  and the machine generated so far.)++newtype Compile t a = C (State -> NFA t -> (a,State,NFA t))++newstate :: Compile t State+newstate = C $ \ n (NFA m) -> (n,n+1,NFA m)++addedge s e g = C $ \ n (NFA m) -> ((),n,NFA (addedge m))+  where+    addedge m = M.add_C (++) (s,[(e,g)]) m++run (C c) fsm = +  case c 1 fsm of+    (ans,_,fsm) -> (ans,fsm)++instance Monad (Compile t) where+  return x = C $ \ n fsm -> (x,n,fsm)++  C m1 >>= xm2 =+    C $ \ n0 fsm0 -> case m1 n0 fsm0 of+                   (a,n1,fsm1) ->+		     case xm2 a of+		       C m2 -> m2 n1 fsm1
+ tools/base/parse2/LexerGen/FSMOpt.hs view
@@ -0,0 +1,59 @@+module FSMOpt where+import FSM+import GraphOps+import MUtils(collectByFst,collectBySnd,mapFst,mapSnd,usort)+import qualified IntMap as M+import qualified IntSet as S+import qualified OrdMap as OM+import List(sort,partition)++rmeqstate (n,NFA m) = (n',NFA (M.fromList m'))+  where (n',m') = repeat' rmeqstate1 (n,M.toList m)++repeat' f x =+  case f x of+    (True,x') -> x'+    (False,x') -> repeat' f x'++rmeqstate1 ((st,go),m) = (null sml,((s st,s go), m3))+  where+    m3 = [(st,[(e,s go)|(e,go)<-es])|(st:_,es)<-m2b]+    s x= M.lookupWithDefault sm x x+    sm = M.fromList sml+    sml = smla++smlb+    smlb = [(old,new)|(new:ss,_)<-m2b,old<-ss]+    smla = [(old,new)|(olds,[(E,new)])<-m2a,old<-olds]+    (m2a,m2b) = partition jumpstate m2+    m2 = opt m++    jumpstate (ss,[(E,g)]) = True+    jumpstate _ = False++    opt = collectBySnd . mapSnd usort++connectivity (n,NFA m) = (n,fmap next m)+  where next = S.fromList . map snd++epsilonconnectivity m = fmap epsnext m+  where epsnext ns = S.fromList [s|(E,s)<-ns]++unreachable fsm = sort . S.toList $ all `S.minus` r+  where+    r = reachable g start+    all = S.fromList . map fst . M.toList $ g+    ((start,_),g) = connectivity fsm++tokenclasses x = collectBySnd . collectByFst . tokenedges . edges $x++tokenedges edges = [(i,sg)|(T (I i),sg)<-edges]+outputedges edges = [(o,sg)|(T (O o),sg)<-edges]+epsilonedges edges = [sg|(E,sg)<-edges]++edges (NFA m) = [(e,(s,g))|(s,es)<-M.toList m,(e,g)<-es]++renumberEdges tclss (NFA ss) = NFA (fmap (usort . mapFst renEdge) ss)+  where+    renEdge (T (I c)) = case OM.lookup c tcmap of Just i -> T (I i)+    renEdge (T (O x)) = T (O x)+    renEdge E = E+    tcmap = OM.fromList tclss
+ tools/base/parse2/LexerGen/Flags.ghc view
@@ -0,0 +1,1 @@+FSMOpt.hs: -fno-monomorphism-restriction
+ tools/base/parse2/LexerGen/GraphOps.hs view
@@ -0,0 +1,69 @@+module GraphOps where+import qualified IntMap as M+import qualified IntSet as S+--import ListUtil(mapSnd)+--import Collect++---- Various functions on directed graphs (or relations if you wish)++-- A graph is represented as a finite map from nodes to set of nodes,+type Graph = M.IntMap NodeSet+-- and nodes are represented by numbers.+type Node = Int+type NodeSet = S.IntSet++--------------------------------------------------------------------------------+neighbours        :: Graph -> Node -> NodeSet+neighbourlist     :: Graph -> Node -> [Node]+reachable         :: Graph -> Node -> NodeSet+transitiveClosure :: Graph -> Graph+nodes             :: Graph -> [Node]+scc               :: Graph -> [[Node]]+--------------------------------------------------------------------------------++-- The neighbours of a node:+neighbours g = M.lookupWithDefault g S.empty +neighbourlist g = S.toList . neighbours g ++-- The set of reachable nodes from a given node in a graph:+reachable graph start = r S.empty [start]+  where+    r reached [] = reached+    r reached (s:ss) =+      if s `S.elem` reached+      then r reached ss+      else r (S.add s reached) (push (neighbourlist graph s) ss)++    push [] ss = ss+    push (x:xs) ss = push xs (x:ss)++-- The reflexitive, transitive closure of a graph (relation):+transitiveClosure graph = +  M.fromList . map (\s->(s,reachable graph s)) . nodes $ graph++-- Reverse all the edges in a graph+--converse = neighbourtable . map swap . edgelist++-- Represenation changes:+--edgelist graph = [(from,to)|(from,tos)<-M.toList graph,to<-S.toList tos]+--neighbourtable = M.fromList . mapSnd S.fromList . collectByFst++-- List the nodes in a graph:+nodes = map fst . M.toList+++-- Strongly Connected Components (equivalence classes):+scc graph = sc S.empty (nodes graph)+  where+    tg = transitiveClosure graph++    sc visited [] = []+    sc visited (n:ns) =+       case n `S.elem` visited of+         True -> sc visited ns+	 False -> if null scc0 then sc visited' ns else scc1:sc visited' ns+	   where+	     visited' = S.union visited (S.fromList scc1)+	     scc1 = n:scc0+	     scc0 = [n' | n' <- forward, n'/=n, n `S.elem` neighbours tg n']+	     forward = neighbourlist tg n
+ tools/base/parse2/LexerGen/HsLexerGen view
binary file changed (absent → 1424040 bytes)
+ tools/base/parse2/LexerGen/HsLexerGen.hs view
@@ -0,0 +1,7 @@+-- This program generates the core of lexical analyser for Haskell++import HaskellLexicalSyntax(program) -- The lexical syntax specification+import LexerGen2(lexerGen)           -- The lexer generator implementation+import System(getArgs)++main = putStrLn . lexerGen "HsLex" "haskellLex" program =<< getArgs
+ tools/base/parse2/LexerGen/LexerGen.hs view
@@ -0,0 +1,48 @@+module LexerGen(lexerGen,OutputFun(..)) where++import RegExp+import FSM+import FSMOpt+import DFA(showDFA,renumberStates)+import DetMachine+import DetMachineToHaskell2+import PPrint(pprint)+import List(sort)+import HaskellChars(HaskellChar)++{-++The lexer generator takes the name of the module to generate, the+name of the lexer function to export from that module and the regular+expression that defines the lexical syntax. It outputs the generated Haskell+module on the standard output.+<p>+<code>lexerGen</code> also consults the command line arguments. If+the word nocc is present, it does not use character classes to reduce+the size of the code.+-}+lexerGen :: (Ord o,Show o,OutputFun o) =>+            String -> String -> Transducer HaskellChar o -> [String] -> String+lexerGen moduleName functionName program args =+  if "nfa" `elem` args+  then show m+  else if "nocc" `elem` args+       then outputDetm Nothing m+       else outputWithCharClasses m+  where+    m@(n,nfa) = rmeqstate (compileRegExp program)++    outputWithCharClasses (n,nfa) =+        outputDetm (Just ccs) (n,renumberEdges ccs nfa)+      where+        charclasses = sort $ tokenclasses nfa+	ccs = [(c,n)|(n,(cs,_))<-zip [(1::Int)..] charclasses,c<-cs]++    outputDetm optccs nfa =+        if "dfa" `elem` args+	then showDFA dfa+	else "\n-- Automatically generated code for a DFA follows:\n" +++	     pprint haskellCode+      where+	haskellCode =+          dfaToHaskell optccs moduleName ["Char","HsLexUtils"] functionName dfa+        dfa = renumberStates (deterministicMachine nfa)
+ tools/base/parse2/LexerGen/LexerGen2.hs view
@@ -0,0 +1,61 @@+module LexerGen2(lexerGen,OutputFun(..)) where++import RegExp(Trans(..),Transducer)+import DFA(DFA(..),renumberEdges,tokenClasses,showDFA)+import Minimalize+import CompileRegExp(compile)+import DetMachineToHaskell2(dfaToHaskell,OutputFun(..))+import PPrint(pprint)+import qualified OrdMap as OM(fromList)+import List(sort)+import HaskellChars(HaskellChar)++{-++The lexer generator takes the name of the module to generate, the+name of the lexer function to export from that module and the regular+expression that defines the lexical syntax. It returns the generated Haskell+module as a string.+<p>+<code>lexerGen</code> also consults the command line arguments. If+the word nocc is present, it does not use character classes to reduce+the size of the code.+-}+lexerGen :: (Ord o,Show o,OutputFun o) =>+            String -> String -> Transducer HaskellChar o -> [String] -> String+lexerGen moduleName functionName program args =+    outputDFA (dfa2old (compile program))+  where+    outDFA = "dfa"  `elem`    args -- output the DFA or generate Haskell?+    useCC  = "nocc" `notElem` args -- use character classes?++    outputDFA = if useCC then outputWithCharClasses else outputDetm Nothing++    outputWithCharClasses (n,dfa) =+        outputDetm (Just ccs) (n,renumberEdges ccs dfa)+      where+        charclasses = sort $ tokenClasses dfa+	ccs = [(c,n)|(n,(cs,_))<-zip [(1::Int)..] charclasses,c<-cs]++    outputDetm optccs dfa0 =+        if outDFA+	then showDFA dfa+	else "\n-- Automatically generated code for a DFA follows:\n" +++	     "--Equal states: "++show eqs++"\n"+++	     pprint haskellCode+      where+        (eqs,dfa) = minimalize dfa0+	haskellCode =+          dfaToHaskell optccs moduleName ["Char","HsLexUtils"] functionName dfa+++{-++A function to convert from the new to the old DFA represenation...+-}+dfa2old dfa = ((1::Int,final),DFA (OM.fromList states))+  where+    final = [s|(s,(True,_))<-dfa]+    states = map state dfa+    state (n,(_,edges)) = (n,(input,output))+      where+        input  = [(i,n)|(I i,n)<-edges]+	output = [(o,n)|(O o,n)<-edges]
+ tools/base/parse2/LexerGen/Minimalize.hs view
@@ -0,0 +1,25 @@+module Minimalize where+import DFA+import MUtils(usort,mapSnd,collectBySnd)+import qualified OrdMap as OM+import Maybe(fromMaybe)++minimalize (s,DFA states) = iter [] (s,OM.toList states)+  where+    iter eqs dfa = case equalStates dfa of+	             ([],(s,states)) -> (eqs,(s,DFA (OM.fromList states)))+		     (eqs',dfa) -> iter (eqs':eqs) dfa++equalStates ((st,fin),states) =+    (eqclasses,((sren st,usort $ map sren fin),states'))+  where+     eqstates = collectBySnd states+     eqclasses = filter ((>1).length) . map fst $ eqstates+     smap = [(s',s)|s:ss<-eqclasses,s'<-ss]+     sren s = fromMaybe s (lookup s smap)++     states' = map renState eqstates++     renState (s:_,(is,os)) = (s,(nubMapSnd sren is,nubMapSnd sren os))++     nubMapSnd f = usort . mapSnd f
+ tools/base/parse2/LexerGen/NondetMachine.hs view
@@ -0,0 +1,43 @@+module NondetMachine where+import FSM+import FSMOpt+import GraphOps+import MUtils(collectByFst,collectBySnd,usort)+import qualified IntMap as M+import qualified IntSet as S++-- Simulation of nondeterministic finite state machines++data NondetState i o = N (Map [(Edge (Trans i o),State)]) (Map S.IntSet) [State]++initM (NFA graph) start = goto (N graph epsg []) [start]+  where+    epsg = transitiveClosure (epsilonconnectivity graph)++goto (N g eg _) ss = N g eg (usort (concatMap (neighbourlist eg) ss))++accept state@(N g eg ss) t =+   case [s'|s<-ss,(T (I t'),s')<-next s,t'==t] of+     [] -> case unzip [(o,s')|s<-ss,(T (O o),s')<-next s] of+             (os,ss') -> Left (os,goto state ss')+     ss' -> Right (goto state ss')+  where+    next = M.lookupWithDefault g []++runM state = run [] state+  where+    run as state@(N _ _ []) is = [Right ([],reverse as),Left []]+    run as state@(N _ _ ss) [] = [Right ([],reverse as)]+    run as state@(N _ _ ss) (i:is) =+      Left ss:+      case accept state i of+	Right state -> run (i:as) state is+	Left (os,state) -> Right (os,reverse as):run [] state (i:is)++canAccept (N g eg ss) =+   collectBySnd . collectByFst $+   [(t,s') | s<-ss,(T (I t),s')<-M.lookupWithDefault g [] s]++canOutput (N g eg ss) =+   collectBySnd . collectByFst $+   [(t,s') | s<-ss,(T (O t),s')<-M.lookupWithDefault g [] s]
+ tools/base/parse2/LexerGen/OldHsLexerGen.hs view
@@ -0,0 +1,7 @@+-- This program generates the core of lexical analyser for Haskell++import HaskellLexicalSyntax(program) -- The lexical syntax specification+import LexerGen(lexerGen)            -- The lexer generator implementation+import System(getArgs)++main = putStrLn . lexerGen "HsLex" "haskellLex" program =<< getArgs
+ tools/base/parse2/LexerGen/PPrint.hs view
@@ -0,0 +1,99 @@+-- Simple and efficient printing combinators+module PPrint where++infixr 2 &,!+infixr 1 !/++data Output = Sep | Str String | Nl | Indent Int++newtype Document = P ([Output] -> [Output])++class Printable a where+  pr :: a -> Document+  prList :: [a] -> Document++  prList = wpr++instance Printable Document where+  pr = id++nil = P id++nl = P (Nl:)+sep = P (Sep:)++indented x = indented' 2 x+indented' n x = P (Indent n:) ! x ! P (Indent (-n):)++vpr xs = foldr (!/) nil xs+wpr xs = prsep sep xs+hpr xs = foldr (!) nil xs++vmap f = foldr ((!/) . f) nil+wmap f xs = wpr (map f xs)+hmap f = foldr ((!) . f) nil++x !/ y = x ! nl ! y++x ! y = comp (pr x) (pr y)+  where comp (P x) (P y) = P (x . y)++x & y = x ! sep ! y++prsep s [] = nil+prsep s (x:xs) = x ! prpre s xs++prpre s [] = nil+prpre s (x:xs) = s ! x ! prpre s xs++instance Printable Char where+  pr c = P (Str [c]:)+  prList s = P (Str s:)++instance Printable a => Printable [a] where+  pr = prList++instance Printable Int where+  pr x = pr (show (x `asTypeOf` 1))++{-+instance Printable a => Printable (Maybe a) where+  pr Nothing = nil+  pr (Just x) = pr x+-}++pprint x = fmt0 0 (apply (pr x) [])+  where+    apply (P pr) = pr++    -- The printer is designed to avoid producing redundant spaces:+    --  + No indentation space on blank lines.+    --  + No trailing spaces at the end of lines.+    --  + No double spaces between items.+    +    -- fmt0: at the beginning of a line, before indentation has been made+    fmt0 n [] = []+    fmt0 n (Nl:os) = "\n"++fmt0 n os+    fmt0 n (Indent i:os) = fmt0 (n+i) os+    fmt0 n (Sep:os) = fmt0 n os+    fmt0 n (Str s:os) = space n++s++fmt n os++    space n = replicate (n `div` 8) '\t' ++ replicate (n `mod` 8) ' '++    -- fmt: in the middle of a line, after indentation and some text+    fmt n [] = []+    fmt n (o:os) =+      case o of+	Str s -> s++fmt n os+	Nl -> "\n"++fmt0 n os+	Indent i -> fmt (n+i) os+	Sep -> fmt1 n os++    -- fmt1: in the middle of a line, a space is to be inserted before next item+    fmt1 n [] = []+    fmt1 n (o:os) =+      case o of+        Str s -> ' ':s++fmt n os+	Nl -> "\n"++fmt0 n os+	Indent i -> fmt1 (n+i) os+	Sep -> fmt1 n os
+ tools/base/parse2/LexerGen/RegExp.hs view
@@ -0,0 +1,95 @@+module RegExp where+--import List+import MUtils(usort)++infixl 2 !,-!,:!,:-!+infixr 3 &,:&++{-+ Transitions for transducers: -}+data Trans i o = I i | O o deriving (Show,Eq,Ord)++type Transducer i o = RegExp (Trans i o)++{-+ Regular expressions: -}+data RegExp t+  = One -- the language containing the empty string, unit of :&+  | Zero -- the empty language, unit of :!+  | S t -- a single symbol+  | RegExp t :& RegExp t -- sequence (associative)+  | RegExp t :! RegExp t -- alternative (cummutative and associative)+  | RegExp t :-! RegExp t -- difference+  | Many (RegExp t) -- sequence of zero or more+  | Some (RegExp t) -- sequence of one or more+-- An experimental extension with a fix-point operator:+  | Fix (RegExp t)+  | Self+  deriving (Eq,Ord,Show)++{-+ Some convenient constructor functions: -}+e     = One+z     = Zero+t     = S . I+o     = S . O+ts rs = seqs $ map t rs+a  rs = alts $ map t rs++opt r = r ! e++alts rs = foldr (!) z rs+seqs rs = foldr (&) e rs++{-+ Optimizing regular expression constructors: -}+many One = One+many Zero = One+many (Many r) = Many r+many (Some r) = Many r+many r = Many r++some One = One+some Zero = Zero+some (Many r) = Many r+some (Some r) = Some r+some r = Some r++r1 ! r2   = alts' (usort ts)+  where+    ts = terms r1 . terms r2 $ []++    alts' [] = z+    alts' ts = foldr1 (:!) ts++    terms Zero = id+    terms (r1 :! r2) = terms r1 . terms r2+    terms r = (r:)++r1 & Zero = Zero+r1 & One  = r1+r1 & r2   = consFactors r1 r2+  where+    consFactors One = id+    consFactors Zero = const Zero+    consFactors (r1:&r2) = consFactors r1 . consFactors r2+    consFactors r = (r:&)++Zero -! r = Zero+r -! Zero = r+r1 -! r2 = if r1==r2 then Zero else r1 :-! r2++fix Zero = Zero+fix One = One+fix Self = Zero+fix ((One:!Self):&r) | not (selfIn r) = some r+fix r = if selfIn r then Fix r else r++selfIn r =+     case r of+       Zero -> False+       One -> False+       S _ -> False+       r1 :& r2  -> selfIn r1 || selfIn r2+       r1 :! r2  -> selfIn r1 || selfIn r2+       r1 :-! r2 -> selfIn r1 || selfIn r2+       Many r -> selfIn r+       Some r -> selfIn r+       Fix r -> False+       Self -> True
+ tools/base/parse2/LexerGen/RegExpOps.hs view
@@ -0,0 +1,65 @@+module RegExpOps where+import RegExp+import List++{-++"" =~ r <==> nullable r+-}+nullable r =+  case r of+    Zero -> False+    One -> True+    S _ -> False+    r1 :& r2  -> nullable r1 && nullable r2+    r1 :! r2  -> nullable r1 || nullable r2+    r1 :-! r2 -> nullable r1 && not (nullable r2)+    Many re -> True+    Some re -> nullable re++--nullR r = if nullable r then e else z++{-++For all i in first r, there exists an is such that i:is =~ r+-}+first r =+  case r of+    Zero -> []+    One -> []+    S i -> [i]+    r1 :& r2  -> first r1 `union` (if nullable r1 then first r2 else [])+    r1 :! r2  -> first r1 `union` first r2+--  r1 :-! r2 -> first r1 \\ first r2         -- this is wrong!+    r1 :-! r2 -> first r1 -- `union` first r2+    Many re -> first re+    Some re -> first re++{-++i:is =~ r <==> is =~ follow i r+-}+follow i r =+  case r of+    Zero -> Zero+    One -> Zero+    S i' -> if i'==i then One else Zero+    r1 :& r2  -> follow i r1 & r2 ! (if nullable r1 then follow i r2 else Zero) +    r1 :! r2  -> follow i r1 ! follow i r2+    r1 :-! r2 -> follow i r1 -! follow i r2+    Many re -> follow i re & Many re+    Some re ->  follow i re & Many re++factors r = (nullable r,[(i,r')|i<-sort (first r),let r'=follow i r,r'/=Zero])++factorsR (n,fs) = (if n then e else z) ! alts [S i & r|(i,r)<-fs]+++{-++Inspired by:++comp.compilers, comp.theory+http://compilers.iecc.com/comparch/article/93-10-022++The Equational Approach: (1) Regular Expressions -> DFA's.+markh@csd4.csd.uwm.edu (Mark)+Computing Services Division, University of Wisconsin - Milwaukee+Sat, 2 Oct 1993 17:47:13 GMT+-}
+ tools/base/parse2/LexerNotes.html view
@@ -0,0 +1,85 @@+<link rel="alternate stylesheet" type="text/css" HREF="/~hallgren/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="/~hallgren/src.css" title="Normal">++Some useful notes by+<a href="http://www.cse.ogi.edu/~diatchki/">Iavor S. Diatchki</a>.+<small>(Converted to HTML by+<a href="http://www.cse.ogi.edu/~hallgren/">Thomas Hallgren</a>)</small>+<h2>The Lexer</h2>++We use <code class=code>LexerGen/HsLexerGen</code> to generate+<a href="Lexer/HsLex.hs"><code class=code>Lexer/HsLex.hs</code></a> which is the+basic lexer.  Its main goal is to define:+<pre class=code>+haskellLex :: String -> [(Token,String)]+</pre>+<code class=code>Token</code> is defined in+<a href="Lexer/HsTokens.hs"><code class=code>Lexer/HsTokens.hs</code></a>,+and it is basically the+different types of token we have.  The string is the value of the+token.++<hr>++Next comes+<a href="Lexer/HsLexerPass1.hs"><code class=code>Lexer/HsLexerPass1.hs</code></a>+which makes use of the basic lexer+<code class=code>haskellLex</code>.  Its main goal is to define:+<pre class=code>+lexerPass0 :: String -> [(Token,(Pos,String))]+lexerPass1Only :: [(Token,(Pos,String))] -> [(Token,(Pos,String))]+</pre>+<code class=code>lexerPass0</code> uses haskellLex to separate the input into tokens, and+then annotates them with their positions.  <code class=code>lexerPass1Only</code> removes+whitespace tokens from the input.+<p>+At this stage <code class=code>Pos</code> is simply a pair of Int (defined in+<code class=code>Lexer/HsLexerPass1.hs</code>).  The format is (rows,cols).  Positions start+at (1,1).++<hr>++Finally the file+<a href="Lexer/HsLexer.hs"><code class=code>Lexer/HsLexer.hs</code></a> contains the+real lexer that can+interact with the Happy grammar.  It defines <code class=code>lexer</code>+<pre class=code>+lexer :: ((Token,(SrcLoc,String)) -> PM a) -> PM a+</pre>+Here <CODE CLASS=CODE>PM</CODE> is the parsing monad, located in+<a href="ParseMonad.hs"><code class=code>ParseMonad.hs</code></a>+The lexer expects the parsing monad to have a state component of type:+<pre class=code>+type State = ([(Token,(SrcPos,String)],[Int])+</pre>+The first component of the state is the list of remaining tokens.+The second component is the layout context, i.e. a stack keeping track+of indentations of blocks of declarations.+<p>+The lexer accesses the state with the aid of three functions:+<pre class=code>+get         :: PM State+set         :: State -> PM ()+setreturn   :: a -> State -> PM a+fail        :: String -> PM a+</pre>+(setreturn is simply an optiomization (is it wortherd?),+setreturn x s = set s >> return x+)++<p>+Currently the file <code class=code>ParseMonad.hs</code> also defines:++<pre class=code>+eoftoken = (GotEOF,(eof,""))+eof = SrcLoc "?" (-1) (-1) -- hmm+(this is also used in HsLexer.hs)+</pre>++<p>+<code class=code>SrcLoc</code>+is a type defined in+<a href="../AST/SrcLoc.hs"><code class=code>../AST/SrcLoc.hs</code></a>+and is positions with file+names in them.  The conversion from <code class=code>Pos</code> to <code class=code>SrcLoc</code>+happens in a function parseTokens defined in <code class=code>ParseMonad.hs</code>.
+ tools/base/parse2/LexerSpec/HaskellChars.hs view
@@ -0,0 +1,82 @@+module HaskellChars where+import Char++{-++This module collects the definitions from the Lexical Syntax in appendix B.3+of the (revised) Haskell 98 report that define sets of characters.+These sets are referred to in the rest of the lexical syntax,+which is given in module HaskellLexicalSyntax.+-}++{-++ASCII characters are represented by themselves, while+non-ASCII characters are represented by the class they belong to.+-}+data HaskellChar+  = ASCII Char+  | UniWhite   -- any Unicode character defined as whitespace+  | UniSymbol  -- any Unicode symbol or punctuation+  | UniDigit   -- any Unicode numeric+  | UniLarge   -- any uppercase or titlecase Unicode letter+  | UniSmall   -- any Unicode lowercase letter+  deriving (Eq,Ord{-,Show-})++acs = map ASCII++-- Character classifications:+special   = acs "(),;[]`{}"+creturn   = acs "\r"+linefeed  = acs "\LF"+vertab    = acs "\VT"+formfeed  = acs "\FF"+space     = acs " \xa0"+tab       = acs "\t"+uniWhite  = [UniWhite]+cany      = graphic++space++tab+graphic   = small++large++symbol++digit++special++acs ":\"'"++latin1Print+small     = ascSmall++uniSmall++acs "_"+ascSmall  = acs ['a'..'z']+uniSmall  = [UniSmall] ++acs latin1Lower -- because of isSymbol workaround+large     = ascLarge++uniLarge+ascLarge  = acs ['A'..'Z']+uniLarge  = [UniLarge] ++acs latin1Upper -- because of isSymbol workaround+symbol    = ascSymbol++uniSymbol+ascSymbol = acs "!#$%&*+./<=>?@\\^|-~"+uniSymbol = [UniSymbol]++acs latin1Symbol -- !! GHC missing isSymbol workaround+digit     = ascDigit++uniDigit+ascDigit  = acs ['0'..'9']+uniDigit  = [UniDigit]+octit     = acs ['0'..'7']+hexit     = digit ++ acs ['A'..'F'] ++ acs ['a'..'f']++-- Some of these are actually UniSmall, UniLarge, UniSymbol, but since GHC's+-- isUpper etc doesn't recognize them, we include them here, as a partial+-- workaround.+latin1Print = acs ['\160'..'\255']+latin1Upper = "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ"+latin1Lower = "ßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ"+latin1Symbol = "¡¢£¤¥¦§¨©¬­®¯°±´¶·¸¿×÷"++----++instance Show HaskellChar where+  showsPrec d h =+    case h of+      ASCII c   -> showsPrec d c+      UniWhite  -> showString "UW"+      UniSymbol -> showString "US"+      UniDigit  -> showString "UD"+      UniLarge  -> showString "UU"+      UniSmall  -> showString "UL"++  showList s = showChar '"' . foldr ((.).shC) id s . showChar '"'+    where+      shC h =+	case h of+	  ASCII c   -> showString (init . tail $ show c)+	  UniWhite  -> showS "UW"+	  UniSymbol -> showS "US"+	  UniDigit  -> showS "UD"+	  UniLarge  -> showS "UU"+	  UniSmall  -> showS "UL"+        where showS s = showChar '"' . showString s . showChar '"'
+ tools/base/parse2/LexerSpec/HaskellLexicalSyntax.hs view
@@ -0,0 +1,136 @@+module HaskellLexicalSyntax where+{-++This module is a transcription of the Lexical Syntax given in appendix B.2+of the Haskell 98 Report, except for character set definitions, which are+given in module HaskellChars.++The grammar below contains extra annotations (not found in the report) to+allow the recognized strings to be paired with token classifications, which+are used in the token specifications in the Happy parser.+-}+import List((\\))+import HaskellChars+import HsTokens+import RegExp++--+program = many (lexeme ! whitespace)++lexeme  = varid      & o Varid  +        ! conid      & o Conid+        ! varsym     & o Varsym+        ! consym     & o Consym+        ! literal -- & o Literal+        ! a special  & o Special+        ! reservedop & o Reservedop+        ! reservedid & o Reservedid+--      ! specialid  & o Specialid -- recognized by the parser++        ! qvarid     & o Qvarid+        ! qconid     & o Qconid+        ! qvarsym    & o Qvarsym+        ! qconsym    & o Qconsym++literal = integer    & o IntLit+        ! float      & o FloatLit+        ! char       & o CharLit+        ! string     & o StringLit++whitechar = newline ! a vertab ! a space ! a tab ! a uniWhite+newline   = a creturn & a linefeed+          ! a creturn ! a linefeed ! a formfeed++whitespace = some whitechar & o Whitespace+           ! comment & o Comment+           ! ncomment & o NestedComment+comment = dashes & o Commentstart & many (a cany) & newline+dashes = as "--" & many (aa "-")+opencom = as "{-"+--closecom = as "-}"+ncomment = opencom & o NestedCommentStart -- handled by calling an external function++-- This doesn't work, since regular expressions can't be recursive...+--ncomment = opencom & lANYseq & many (ncomment & lANYseq) & closecom+--ncomment = fix (opencom & lANYseq & many (Self & lANYseq) & closecom)++--ncomment = opencom & lANYseq & closecom -- unnested comments!+--lANYseq = many cANY -! (many cANY & ( opencom ! closecom ) & many cANY)+--cANY      = a graphic ! whitechar+++varid = a small & idtail -! reservedid+conid = a large & idtail+idtail = many (a small ! a large ! a digit ! aa "'")++reservedid =+  ass [ "case", "class", "data", "default", "deriving", "do", "else",+        "if", "import", "in", "infix", "infixl", "infixr", "instance",+        "let", "module", "newtype", "of", "then", "type", "where", "_"]++{-+specialid = as"as" ! as"qualified" ! as"hiding" +          ! as"forall" -- rank 2 polymorphism extension+          ! as"primitive" -- Hugs foreign function interface+-}++varsym = (a symbol & many (a symbol ! aa ":")) -! (reservedop ! dashes)+consym = (aa ":" & many (a symbol ! aa ":")) -! reservedop++reservedop = ass ["..", ":","::", "=","\\","|","<-","->","@","~","=>"]++--specialop = aa "-" ! aa "!" -- recognized by the parser instead++modid = conid+--optq = opt qual++-- qual = modid & aa "." -- For Haskell 98+qual = some (modid & aa ".") -- For "hierachical module names"++{-++In the report, qvarid etc include both qualified and unqualified names, but+here they denote qualified names only. This allows qualified and unqualified+names to be distinguished in a more natural way in the parser.+-}+qvarid = qual & varid+qconid = qual & conid+qvarsym = qual & varsym+qconsym = qual & consym++decimal = some (a digit)+octal = some (a octit)+hexadecimal = some (a hexit)++integer = decimal+        ! aa "0" & aa "Oo" & octal+	! aa "0" & aa "Xx" & hexadecimal++float = decimal & aa "." & decimal & opt (aa "eE" & opt (aa "-+") & decimal)+char = aa "'" & (a (graphic \\ acs "'\\") ! a space ! escape{-<\&>-}) & aa "'"+string = aa "\"" & many (a (graphic \\ acs "\"\\") ! a space ! escape ! gap) & aa "\""++escape = aa "\\" & ( charesc ! ascii ! decimal !+                    aa "o" & octal ! aa "x" & hexadecimal )++charesc = aa "abfnrtv\\\"'&"++ascii = aa "^" & cntrl !+        ass [ "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK",+     "BEL", "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "DLE",+     "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN",+     "EM", "SUB", "ESC", "FS", "GS", "RS", "US", "SP", "DEL"]++cntrl = a ascLarge ! aa "@[\\]^_"++gap = aa "\\" & some whitechar & aa "\\"++--+aa = a . acs -- any of the ASCII chars+as = ts . acs -- ASCII string+ass = foldr1 (!) . map as++--+--tyvar = varid+--tycon = conid+--tycls = conid+--qtycon = qual & tycon+--qtycls = qual & tycls
+ tools/base/parse2/Makefile view
@@ -0,0 +1,39 @@++GENERATED=Lexer/HsLex.hs Parser/HsParser.hs+GENERATOR=LexerGen/HsLexerGen++TARGETS=$(GENERATED) $(GENERATOR)++#Tools:+HMAKE=sh ../../scripts/hsmake.sh+RM=rm -f++################################################################################+### Rules for the targets:++all: $(GENERATED)+lexer: Lexer/HsLex.hs+parser: Parser/HsParser.hs++Parser/HsParser.hs: Parser/HsParser.y+	cd Parser; happy HsParser.y++Lexer/HsLex.hs: LexerSpec/*.hs Lexer/HsTokens.hs+	@$(MAKE) $(GENERATOR)+	LexerGen/HsLexerGen >Lexer/HsLex.hs++#Lexer/HsLex.hs::+#	$(HMAKE) -O -package data -O tst+#	if [ ./tst -nt Lexer/HsLex.hs ] ; then ./tst >Lexer/HsLex.hs ; fi++#./lexgen Lexer/HsLex.hs++$(GENERATOR)::+	$(HMAKE) -O -package data $(GENERATOR) -o $(GENERATOR)++################################################################################+### Rules for cleaning up++clean:+	$(RM) -r $(TARGETS)+	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'
+ tools/base/parse2/NumberNames.hs view
@@ -0,0 +1,11 @@+module NumberNames(module NumberNames,module UniqueNames) where+import NameMaps+import UniqueNames+import SourceNames++--numberNames = id+--+numberNames m = mapNames conv m+  where+    conv (SN i p) = PN i (S p)+--}
+ tools/base/parse2/ParseMonad.hs view
@@ -0,0 +1,92 @@+{-++This module defines the parser monad, and the function #parseFile#, which is+the only way to invoke a parser.+-}+module ParseMonad(thenPM,PM,HToken,returnPM,parseError,getSrcLoc,+	          State,get,set,setreturn,eof,eoftoken,+		  parseFile,parseTokens) where+import HsTokens(Token(GotEOF))+import HsLexerPass1(lexerPass1Only,lexerPass0,Pos(..),line,column)+import MUtils+import SrcLoc1+import SrcLocPretty+import PrettyPrint(pp)+import Control.Monad.Error+--import Control.Monad(liftM,MonadPlus(..))+import Monad+import ExceptM()+ --import IOExts(trace) -- for debugging only++default(Int)++type HToken = (Token,(SrcLoc,String))+ --type Pos = (Int,Int)+type Error = String+type LayoutContext = Int+type State = ([HToken],[LayoutContext])++-- Parser monad type:+newtype PM a = PM {unPM::(State->Either ParseMonad.Error (a,State))} ++returnPM x = PM $ Right . (,) x+PM p1 `thenPM` xp2 = PM $ \ts -> p1 ts >>= uncurry (unPM . xp2) -- =<< p1 ts+failPM msg = PM $ \ _ -> Left msg++{-+emapPM f (PM p) = PM $ \ ts -> case p ts of+				 Right ans -> Right ans+				 Left err -> Left (f err)+-}++get = PM $ \ st -> Right (st,st)+set st = PM $ \ _ -> Right ((),st)+setreturn x st = PM $ \ _ -> Right (x,st)++instance Monad PM where+  return=returnPM+  (>>=) = thenPM+  fail = parseError++{-instance Monad (Either String) where+    (Left a)  >>= _ = Left a+    (Right b) >>= f = f b+    return          = Right+    fail a          = Left a -}++instance Functor PM where fmap = liftM++instance MonadPlus PM where+  mzero = fail "parser failed"+  PM p1 `mplus` PM p2 = PM $ \ s -> case p1 s of+			              y@(Right _) -> y+				      Left _ -> p2 s++getSrcLoc = fst.snd # peek++peek = tok1 # get+  where+    tok1 (ts,_) = case ts of+		    t:_ -> t+		    []  -> eoftoken++parseError msg = err =<< peek+  where err (t,(p,s)) =+            failPM $ pos++": "++msg+          where pos = if p==eof+	              then "at end of file"+	              else pp p++", before "++s++parseFile pm f = parseTokens pm f . lexerPass0++parseTokens (PM p) f ts =+  case p (map convPos $ lexerPass1Only ts,initial_layout_context_stack) of+    Left err    -> fail ({-f++": "++-}err)+    Right (x,_) -> return x+  where+    convPos (t,(Pos n l c,s)) = {-seq loc-} (t,(loc,s))+      where loc = SrcLoc f n l c++eoftoken = (GotEOF,(eof,""))+eof = SrcLoc "?" 0 (-1) (-1) -- hmm++initial_layout_context_stack = []
+ tools/base/parse2/ParsedSyntax.hs view
@@ -0,0 +1,5 @@+module ParsedSyntax(module PosSyntax,Src,lexerPass0) where+import PosSyntax+import HsLexerPass1(lexerPass0)++type Src i = SN i
+ tools/base/parse2/Parser/HsParser.hs view
@@ -0,0 +1,9747 @@+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+module HsParser (parse,parseExp) where+ +import PosSyntax+--import SyntaxUtil+import HsTokens(Token(..))+import ParseMonad+import HsLexer+import LexUtil(readInteger, readRational)+import ParseUtil+--import IOExts++-- parser produced by Happy Version 1.18.4++data HappyAbsSyn +	= HappyTerminal (HToken)+	| HappyErrorToken Int+	| HappyAbsSyn5 (HsModuleR)+	| HappyAbsSyn6 (([HsImportDecl], [HsDecl]))+	| HappyAbsSyn8 (())+	| HappyAbsSyn10 (Maybe [HsExportSpec])+	| HappyAbsSyn11 ([HsExportSpec])+	| HappyAbsSyn14 (HsExportSpec)+	| HappyAbsSyn15 ([HsIdent])+	| HappyAbsSyn16 (HsIdent)+	| HappyAbsSyn17 ([HsImportDecl])+	| HappyAbsSyn18 (HsImportDecl)+	| HappyAbsSyn19 (Bool)+	| HappyAbsSyn20 (Maybe ModuleName)+	| HappyAbsSyn21 (Maybe (Bool, [HsImportSpec]))+	| HappyAbsSyn22 ((Bool, [HsImportSpec]))+	| HappyAbsSyn23 ([HsImportSpec])+	| HappyAbsSyn25 (HsImportSpec)+	| HappyAbsSyn28 ([HsDecl])+	| HappyAbsSyn29 (HsDecl)+	| HappyAbsSyn30 (Int)+	| HappyAbsSyn31 ((SrcLoc,HsAssoc))+	| HappyAbsSyn34 (Maybe String)+	| HappyAbsSyn36 (HsName)+	| HappyAbsSyn38 (String)+	| HappyAbsSyn39 (HsFunDeps HsName)+	| HappyAbsSyn41 (HsFunDep HsName)+	| HappyAbsSyn42 ([HsName])+	| HappyAbsSyn51 (HsType)+	| HappyAbsSyn54 ([HsType])+	| HappyAbsSyn57 (([HsType],HsType))+	| HappyAbsSyn60 (([HsType], HsType))+	| HappyAbsSyn61 ([HsConDecl HsType [HsType]])+	| HappyAbsSyn62 (HsConDecl HsType [HsType])+	| HappyAbsSyn64 (SrcLoc -> [HsName] -> [HsType] -> HsConDecl HsType [HsType])+	| HappyAbsSyn65 ((HsName, [HsBangType HsType]))+	| HappyAbsSyn67 (HsBangType HsType)+	| HappyAbsSyn69 ([([HsName], HsBangType HsType)])+	| HappyAbsSyn70 (([HsName], HsBangType HsType))+	| HappyAbsSyn83 ((HsName,[HsPat]))+	| HappyAbsSyn85 (HsRhs HsExp)+	| HappyAbsSyn86 ([(SrcLoc, HsExp, HsExp)])+	| HappyAbsSyn87 ((SrcLoc, HsExp, HsExp))+	| HappyAbsSyn88 (HsExp)+	| HappyAbsSyn94 ([HsExp])+	| HappyAbsSyn97 ([HsStmtAtom HsExp HsPat [HsDecl] ])+	| HappyAbsSyn98 (HsStmtAtom HsExp HsPat [HsDecl])+	| HappyAbsSyn99 ([HsAlt HsExp HsPat [HsDecl]])+	| HappyAbsSyn101 (HsAlt HsExp HsPat [HsDecl])+	| HappyAbsSyn105 ([HsStmtAtom HsExp HsPat [HsDecl]])+	| HappyAbsSyn107 ([HsField HsExp])+	| HappyAbsSyn109 (HsField HsExp)+	| HappyAbsSyn110 (HsPat)+	| HappyAbsSyn114 ([HsPat])+	| HappyAbsSyn116 ([HsField HsPat])+	| HappyAbsSyn118 (HsField HsPat)+	| HappyAbsSyn150 ((SrcLoc,HsLiteral))+	| HappyAbsSyn152 (SrcLoc)+	| HappyAbsSyn155 (ModuleName)++{- to allow type-synonyms as our monads (likely+ - with explicitly-specified bind and return)+ - in Haskell98, it seems that with+ - /type M a = .../, then /(HappyReduction M)/+ - is not allowed.  But Happy is a+ - code-generator that can just substitute it.+type HappyReduction m = +	   Int +	-> (HToken)+	-> HappyState (HToken) (HappyStk HappyAbsSyn -> m HappyAbsSyn)+	-> [HappyState (HToken) (HappyStk HappyAbsSyn -> m HappyAbsSyn)] +	-> HappyStk HappyAbsSyn +	-> m HappyAbsSyn+-}++action_0,+ action_1,+ action_2,+ action_3,+ action_4,+ action_5,+ action_6,+ action_7,+ action_8,+ action_9,+ action_10,+ action_11,+ action_12,+ action_13,+ action_14,+ action_15,+ action_16,+ action_17,+ action_18,+ action_19,+ action_20,+ action_21,+ action_22,+ action_23,+ action_24,+ action_25,+ action_26,+ action_27,+ action_28,+ action_29,+ action_30,+ action_31,+ action_32,+ action_33,+ action_34,+ action_35,+ action_36,+ action_37,+ action_38,+ action_39,+ action_40,+ action_41,+ action_42,+ action_43,+ action_44,+ action_45,+ action_46,+ action_47,+ action_48,+ action_49,+ action_50,+ action_51,+ action_52,+ action_53,+ action_54,+ action_55,+ action_56,+ action_57,+ action_58,+ action_59,+ action_60,+ action_61,+ action_62,+ action_63,+ action_64,+ action_65,+ action_66,+ action_67,+ action_68,+ action_69,+ action_70,+ action_71,+ action_72,+ action_73,+ action_74,+ action_75,+ action_76,+ action_77,+ action_78,+ action_79,+ action_80,+ action_81,+ action_82,+ action_83,+ action_84,+ action_85,+ action_86,+ action_87,+ action_88,+ action_89,+ action_90,+ action_91,+ action_92,+ action_93,+ action_94,+ action_95,+ action_96,+ action_97,+ action_98,+ action_99,+ action_100,+ action_101,+ action_102,+ action_103,+ action_104,+ action_105,+ action_106,+ action_107,+ action_108,+ action_109,+ action_110,+ action_111,+ action_112,+ action_113,+ action_114,+ action_115,+ action_116,+ action_117,+ action_118,+ action_119,+ action_120,+ action_121,+ action_122,+ action_123,+ action_124,+ action_125,+ action_126,+ action_127,+ action_128,+ action_129,+ action_130,+ action_131,+ action_132,+ action_133,+ action_134,+ action_135,+ action_136,+ action_137,+ action_138,+ action_139,+ action_140,+ action_141,+ action_142,+ action_143,+ action_144,+ action_145,+ action_146,+ action_147,+ action_148,+ action_149,+ action_150,+ action_151,+ action_152,+ action_153,+ action_154,+ action_155,+ action_156,+ action_157,+ action_158,+ action_159,+ action_160,+ action_161,+ action_162,+ action_163,+ action_164,+ action_165,+ action_166,+ action_167,+ action_168,+ action_169,+ action_170,+ action_171,+ action_172,+ action_173,+ action_174,+ action_175,+ action_176,+ action_177,+ action_178,+ action_179,+ action_180,+ action_181,+ action_182,+ action_183,+ action_184,+ action_185,+ action_186,+ action_187,+ action_188,+ action_189,+ action_190,+ action_191,+ action_192,+ action_193,+ action_194,+ action_195,+ action_196,+ action_197,+ action_198,+ action_199,+ action_200,+ action_201,+ action_202,+ action_203,+ action_204,+ action_205,+ action_206,+ action_207,+ action_208,+ action_209,+ action_210,+ action_211,+ action_212,+ action_213,+ action_214,+ action_215,+ action_216,+ action_217,+ action_218,+ action_219,+ action_220,+ action_221,+ action_222,+ action_223,+ action_224,+ action_225,+ action_226,+ action_227,+ action_228,+ action_229,+ action_230,+ action_231,+ action_232,+ action_233,+ action_234,+ action_235,+ action_236,+ action_237,+ action_238,+ action_239,+ action_240,+ action_241,+ action_242,+ action_243,+ action_244,+ action_245,+ action_246,+ action_247,+ action_248,+ action_249,+ action_250,+ action_251,+ action_252,+ action_253,+ action_254,+ action_255,+ action_256,+ action_257,+ action_258,+ action_259,+ action_260,+ action_261,+ action_262,+ action_263,+ action_264,+ action_265,+ action_266,+ action_267,+ action_268,+ action_269,+ action_270,+ action_271,+ action_272,+ action_273,+ action_274,+ action_275,+ action_276,+ action_277,+ action_278,+ action_279,+ action_280,+ action_281,+ action_282,+ action_283,+ action_284,+ action_285,+ action_286,+ action_287,+ action_288,+ action_289,+ action_290,+ action_291,+ action_292,+ action_293,+ action_294,+ action_295,+ action_296,+ action_297,+ action_298,+ action_299,+ action_300,+ action_301,+ action_302,+ action_303,+ action_304,+ action_305,+ action_306,+ action_307,+ action_308,+ action_309,+ action_310,+ action_311,+ action_312,+ action_313,+ action_314,+ action_315,+ action_316,+ action_317,+ action_318,+ action_319,+ action_320,+ action_321,+ action_322,+ action_323,+ action_324,+ action_325,+ action_326,+ action_327,+ action_328,+ action_329,+ action_330,+ action_331,+ action_332,+ action_333,+ action_334,+ action_335,+ action_336,+ action_337,+ action_338,+ action_339,+ action_340,+ action_341,+ action_342,+ action_343,+ action_344,+ action_345,+ action_346,+ action_347,+ action_348,+ action_349,+ action_350,+ action_351,+ action_352,+ action_353,+ action_354,+ action_355,+ action_356,+ action_357,+ action_358,+ action_359,+ action_360,+ action_361,+ action_362,+ action_363,+ action_364,+ action_365,+ action_366,+ action_367,+ action_368,+ action_369,+ action_370,+ action_371,+ action_372,+ action_373,+ action_374,+ action_375,+ action_376,+ action_377,+ action_378,+ action_379,+ action_380,+ action_381,+ action_382,+ action_383,+ action_384,+ action_385,+ action_386,+ action_387,+ action_388,+ action_389,+ action_390,+ action_391,+ action_392,+ action_393,+ action_394,+ action_395,+ action_396,+ action_397,+ action_398,+ action_399,+ action_400,+ action_401,+ action_402,+ action_403,+ action_404,+ action_405,+ action_406,+ action_407,+ action_408,+ action_409,+ action_410,+ action_411,+ action_412,+ action_413,+ action_414,+ action_415,+ action_416,+ action_417,+ action_418,+ action_419,+ action_420,+ action_421,+ action_422,+ action_423,+ action_424,+ action_425,+ action_426,+ action_427,+ action_428,+ action_429,+ action_430,+ action_431,+ action_432,+ action_433,+ action_434,+ action_435,+ action_436,+ action_437,+ action_438,+ action_439,+ action_440,+ action_441,+ action_442,+ action_443,+ action_444,+ action_445,+ action_446,+ action_447,+ action_448,+ action_449,+ action_450,+ action_451,+ action_452,+ action_453,+ action_454,+ action_455,+ action_456,+ action_457,+ action_458,+ action_459,+ action_460,+ action_461,+ action_462,+ action_463,+ action_464,+ action_465,+ action_466,+ action_467,+ action_468,+ action_469,+ action_470,+ action_471,+ action_472,+ action_473,+ action_474,+ action_475,+ action_476,+ action_477,+ action_478,+ action_479,+ action_480,+ action_481,+ action_482,+ action_483,+ action_484,+ action_485,+ action_486,+ action_487,+ action_488,+ action_489,+ action_490,+ action_491,+ action_492,+ action_493,+ action_494,+ action_495,+ action_496,+ action_497,+ action_498,+ action_499,+ action_500,+ action_501,+ action_502,+ action_503,+ action_504,+ action_505,+ action_506,+ action_507,+ action_508,+ action_509,+ action_510,+ action_511,+ action_512,+ action_513,+ action_514,+ action_515,+ action_516,+ action_517,+ action_518,+ action_519,+ action_520,+ action_521,+ action_522,+ action_523,+ action_524,+ action_525,+ action_526,+ action_527,+ action_528,+ action_529,+ action_530,+ action_531,+ action_532,+ action_533,+ action_534,+ action_535,+ action_536,+ action_537,+ action_538,+ action_539,+ action_540,+ action_541,+ action_542,+ action_543,+ action_544,+ action_545,+ action_546,+ action_547,+ action_548,+ action_549,+ action_550,+ action_551,+ action_552,+ action_553,+ action_554,+ action_555,+ action_556,+ action_557,+ action_558,+ action_559,+ action_560,+ action_561,+ action_562,+ action_563,+ action_564,+ action_565,+ action_566,+ action_567,+ action_568,+ action_569,+ action_570,+ action_571,+ action_572,+ action_573,+ action_574,+ action_575,+ action_576,+ action_577,+ action_578,+ action_579,+ action_580,+ action_581,+ action_582,+ action_583,+ action_584,+ action_585,+ action_586,+ action_587,+ action_588,+ action_589,+ action_590,+ action_591,+ action_592,+ action_593,+ action_594,+ action_595,+ action_596,+ action_597,+ action_598,+ action_599,+ action_600,+ action_601,+ action_602,+ action_603,+ action_604,+ action_605 :: () => Int -> ({-HappyReduction (PM) = -}+	   Int +	-> (HToken)+	-> HappyState (HToken) (HappyStk HappyAbsSyn -> (PM) HappyAbsSyn)+	-> [HappyState (HToken) (HappyStk HappyAbsSyn -> (PM) HappyAbsSyn)] +	-> HappyStk HappyAbsSyn +	-> (PM) HappyAbsSyn)++happyReduce_2,+ happyReduce_3,+ happyReduce_4,+ happyReduce_5,+ happyReduce_6,+ happyReduce_7,+ happyReduce_8,+ happyReduce_9,+ happyReduce_10,+ happyReduce_11,+ happyReduce_12,+ happyReduce_13,+ happyReduce_14,+ happyReduce_15,+ happyReduce_16,+ happyReduce_17,+ happyReduce_18,+ happyReduce_19,+ happyReduce_20,+ happyReduce_21,+ happyReduce_22,+ happyReduce_23,+ happyReduce_24,+ happyReduce_25,+ happyReduce_26,+ happyReduce_27,+ happyReduce_28,+ happyReduce_29,+ happyReduce_30,+ happyReduce_31,+ happyReduce_32,+ happyReduce_33,+ happyReduce_34,+ happyReduce_35,+ happyReduce_36,+ happyReduce_37,+ happyReduce_38,+ happyReduce_39,+ happyReduce_40,+ happyReduce_41,+ happyReduce_42,+ happyReduce_43,+ happyReduce_44,+ happyReduce_45,+ happyReduce_46,+ happyReduce_47,+ happyReduce_48,+ happyReduce_49,+ happyReduce_50,+ happyReduce_51,+ happyReduce_52,+ happyReduce_53,+ happyReduce_54,+ happyReduce_55,+ happyReduce_56,+ happyReduce_57,+ happyReduce_58,+ happyReduce_59,+ happyReduce_60,+ happyReduce_61,+ happyReduce_62,+ happyReduce_63,+ happyReduce_64,+ happyReduce_65,+ happyReduce_66,+ happyReduce_67,+ happyReduce_68,+ happyReduce_69,+ happyReduce_70,+ happyReduce_71,+ happyReduce_72,+ happyReduce_73,+ happyReduce_74,+ happyReduce_75,+ happyReduce_76,+ happyReduce_77,+ happyReduce_78,+ happyReduce_79,+ happyReduce_80,+ happyReduce_81,+ happyReduce_82,+ happyReduce_83,+ happyReduce_84,+ happyReduce_85,+ happyReduce_86,+ happyReduce_87,+ happyReduce_88,+ happyReduce_89,+ happyReduce_90,+ happyReduce_91,+ happyReduce_92,+ happyReduce_93,+ happyReduce_94,+ happyReduce_95,+ happyReduce_96,+ happyReduce_97,+ happyReduce_98,+ happyReduce_99,+ happyReduce_100,+ happyReduce_101,+ happyReduce_102,+ happyReduce_103,+ happyReduce_104,+ happyReduce_105,+ happyReduce_106,+ happyReduce_107,+ happyReduce_108,+ happyReduce_109,+ happyReduce_110,+ happyReduce_111,+ happyReduce_112,+ happyReduce_113,+ happyReduce_114,+ happyReduce_115,+ happyReduce_116,+ happyReduce_117,+ happyReduce_118,+ happyReduce_119,+ happyReduce_120,+ happyReduce_121,+ happyReduce_122,+ happyReduce_123,+ happyReduce_124,+ happyReduce_125,+ happyReduce_126,+ happyReduce_127,+ happyReduce_128,+ happyReduce_129,+ happyReduce_130,+ happyReduce_131,+ happyReduce_132,+ happyReduce_133,+ happyReduce_134,+ happyReduce_135,+ happyReduce_136,+ happyReduce_137,+ happyReduce_138,+ happyReduce_139,+ happyReduce_140,+ happyReduce_141,+ happyReduce_142,+ happyReduce_143,+ happyReduce_144,+ happyReduce_145,+ happyReduce_146,+ happyReduce_147,+ happyReduce_148,+ happyReduce_149,+ happyReduce_150,+ happyReduce_151,+ happyReduce_152,+ happyReduce_153,+ happyReduce_154,+ happyReduce_155,+ happyReduce_156,+ happyReduce_157,+ happyReduce_158,+ happyReduce_159,+ happyReduce_160,+ happyReduce_161,+ happyReduce_162,+ happyReduce_163,+ happyReduce_164,+ happyReduce_165,+ happyReduce_166,+ happyReduce_167,+ happyReduce_168,+ happyReduce_169,+ happyReduce_170,+ happyReduce_171,+ happyReduce_172,+ happyReduce_173,+ happyReduce_174,+ happyReduce_175,+ happyReduce_176,+ happyReduce_177,+ happyReduce_178,+ happyReduce_179,+ happyReduce_180,+ happyReduce_181,+ happyReduce_182,+ happyReduce_183,+ happyReduce_184,+ happyReduce_185,+ happyReduce_186,+ happyReduce_187,+ happyReduce_188,+ happyReduce_189,+ happyReduce_190,+ happyReduce_191,+ happyReduce_192,+ happyReduce_193,+ happyReduce_194,+ happyReduce_195,+ happyReduce_196,+ happyReduce_197,+ happyReduce_198,+ happyReduce_199,+ happyReduce_200,+ happyReduce_201,+ happyReduce_202,+ happyReduce_203,+ happyReduce_204,+ happyReduce_205,+ happyReduce_206,+ happyReduce_207,+ happyReduce_208,+ happyReduce_209,+ happyReduce_210,+ happyReduce_211,+ happyReduce_212,+ happyReduce_213,+ happyReduce_214,+ happyReduce_215,+ happyReduce_216,+ happyReduce_217,+ happyReduce_218,+ happyReduce_219,+ happyReduce_220,+ happyReduce_221,+ happyReduce_222,+ happyReduce_223,+ happyReduce_224,+ happyReduce_225,+ happyReduce_226,+ happyReduce_227,+ happyReduce_228,+ happyReduce_229,+ happyReduce_230,+ happyReduce_231,+ happyReduce_232,+ happyReduce_233,+ happyReduce_234,+ happyReduce_235,+ happyReduce_236,+ happyReduce_237,+ happyReduce_238,+ happyReduce_239,+ happyReduce_240,+ happyReduce_241,+ happyReduce_242,+ happyReduce_243,+ happyReduce_244,+ happyReduce_245,+ happyReduce_246,+ happyReduce_247,+ happyReduce_248,+ happyReduce_249,+ happyReduce_250,+ happyReduce_251,+ happyReduce_252,+ happyReduce_253,+ happyReduce_254,+ happyReduce_255,+ happyReduce_256,+ happyReduce_257,+ happyReduce_258,+ happyReduce_259,+ happyReduce_260,+ happyReduce_261,+ happyReduce_262,+ happyReduce_263,+ happyReduce_264,+ happyReduce_265,+ happyReduce_266,+ happyReduce_267,+ happyReduce_268,+ happyReduce_269,+ happyReduce_270,+ happyReduce_271,+ happyReduce_272,+ happyReduce_273,+ happyReduce_274,+ happyReduce_275,+ happyReduce_276,+ happyReduce_277,+ happyReduce_278,+ happyReduce_279,+ happyReduce_280,+ happyReduce_281,+ happyReduce_282,+ happyReduce_283,+ happyReduce_284,+ happyReduce_285,+ happyReduce_286,+ happyReduce_287,+ happyReduce_288,+ happyReduce_289,+ happyReduce_290,+ happyReduce_291,+ happyReduce_292,+ happyReduce_293,+ happyReduce_294,+ happyReduce_295,+ happyReduce_296,+ happyReduce_297,+ happyReduce_298,+ happyReduce_299,+ happyReduce_300,+ happyReduce_301,+ happyReduce_302,+ happyReduce_303,+ happyReduce_304,+ happyReduce_305,+ happyReduce_306,+ happyReduce_307,+ happyReduce_308,+ happyReduce_309,+ happyReduce_310,+ happyReduce_311,+ happyReduce_312,+ happyReduce_313,+ happyReduce_314,+ happyReduce_315,+ happyReduce_316,+ happyReduce_317,+ happyReduce_318,+ happyReduce_319,+ happyReduce_320,+ happyReduce_321,+ happyReduce_322,+ happyReduce_323,+ happyReduce_324,+ happyReduce_325,+ happyReduce_326,+ happyReduce_327,+ happyReduce_328,+ happyReduce_329,+ happyReduce_330,+ happyReduce_331,+ happyReduce_332,+ happyReduce_333,+ happyReduce_334,+ happyReduce_335,+ happyReduce_336,+ happyReduce_337,+ happyReduce_338,+ happyReduce_339,+ happyReduce_340,+ happyReduce_341,+ happyReduce_342,+ happyReduce_343,+ happyReduce_344,+ happyReduce_345,+ happyReduce_346,+ happyReduce_347,+ happyReduce_348,+ happyReduce_349,+ happyReduce_350,+ happyReduce_351,+ happyReduce_352,+ happyReduce_353,+ happyReduce_354,+ happyReduce_355,+ happyReduce_356 :: () => ({-HappyReduction (PM) = -}+	   Int +	-> (HToken)+	-> HappyState (HToken) (HappyStk HappyAbsSyn -> (PM) HappyAbsSyn)+	-> [HappyState (HToken) (HappyStk HappyAbsSyn -> (PM) HappyAbsSyn)] +	-> HappyStk HappyAbsSyn +	-> (PM) HappyAbsSyn)++action_0 (179) = happyShift action_3+action_0 (5) = happyGoto action_43+action_0 (152) = happyGoto action_44+action_0 _ = happyReduce_347++action_1 (161) = happyShift action_20+action_1 (162) = happyShift action_21+action_1 (167) = happyShift action_22+action_1 (169) = happyShift action_23+action_1 (170) = happyShift action_24+action_1 (171) = happyShift action_25+action_1 (178) = happyShift action_26+action_1 (185) = happyShift action_27+action_1 (186) = happyShift action_28+action_1 (188) = happyShift action_29+action_1 (189) = happyShift action_30+action_1 (196) = happyShift action_31+action_1 (205) = happyShift action_32+action_1 (210) = happyShift action_33+action_1 (213) = happyShift action_34+action_1 (214) = happyShift action_35+action_1 (215) = happyShift action_36+action_1 (216) = happyShift action_37+action_1 (217) = happyShift action_38+action_1 (222) = happyShift action_39+action_1 (223) = happyShift action_40+action_1 (224) = happyShift action_41+action_1 (225) = happyShift action_42+action_1 (88) = happyGoto action_4+action_1 (89) = happyGoto action_5+action_1 (90) = happyGoto action_6+action_1 (91) = happyGoto action_7+action_1 (92) = happyGoto action_8+action_1 (122) = happyGoto action_9+action_1 (123) = happyGoto action_10+action_1 (125) = happyGoto action_11+action_1 (127) = happyGoto action_12+action_1 (137) = happyGoto action_13+action_1 (138) = happyGoto action_14+action_1 (139) = happyGoto action_15+action_1 (140) = happyGoto action_16+action_1 (142) = happyGoto action_17+action_1 (150) = happyGoto action_18+action_1 (151) = happyGoto action_19+action_1 _ = happyFail++action_2 (179) = happyShift action_3+action_2 _ = happyFail++action_3 (215) = happyShift action_36+action_3 (216) = happyShift action_37+action_3 (140) = happyGoto action_113+action_3 (142) = happyGoto action_17+action_3 (155) = happyGoto action_114+action_3 _ = happyFail++action_4 (227) = happyAccept+action_4 _ = happyFail++action_5 (199) = happyShift action_107+action_5 (200) = happyShift action_108+action_5 (202) = happyShift action_83+action_5 (203) = happyShift action_109+action_5 (212) = happyShift action_110+action_5 (217) = happyShift action_111+action_5 (218) = happyShift action_112+action_5 (219) = happyShift action_87+action_5 (220) = happyShift action_88+action_5 (221) = happyShift action_89+action_5 (129) = happyGoto action_101+action_5 (132) = happyGoto action_102+action_5 (134) = happyGoto action_103+action_5 (135) = happyGoto action_104+action_5 (143) = happyGoto action_72+action_5 (144) = happyGoto action_73+action_5 (145) = happyGoto action_105+action_5 (147) = happyGoto action_76+action_5 (149) = happyGoto action_106+action_5 _ = happyReduce_188++action_6 (161) = happyShift action_20+action_6 (169) = happyShift action_23+action_6 (170) = happyShift action_24+action_6 (185) = happyShift action_27+action_6 (186) = happyShift action_28+action_6 (188) = happyShift action_29+action_6 (189) = happyShift action_30+action_6 (196) = happyShift action_31+action_6 (210) = happyShift action_33+action_6 (213) = happyShift action_34+action_6 (214) = happyShift action_35+action_6 (215) = happyShift action_36+action_6 (216) = happyShift action_37+action_6 (222) = happyShift action_39+action_6 (223) = happyShift action_40+action_6 (224) = happyShift action_41+action_6 (225) = happyShift action_42+action_6 (91) = happyGoto action_100+action_6 (92) = happyGoto action_8+action_6 (122) = happyGoto action_9+action_6 (123) = happyGoto action_10+action_6 (125) = happyGoto action_11+action_6 (127) = happyGoto action_12+action_6 (137) = happyGoto action_13+action_6 (138) = happyGoto action_14+action_6 (139) = happyGoto action_15+action_6 (140) = happyGoto action_16+action_6 (142) = happyGoto action_17+action_6 (150) = happyGoto action_18+action_6 (151) = happyGoto action_19+action_6 _ = happyReduce_196++action_7 (192) = happyShift action_99+action_7 _ = happyReduce_198++action_8 _ = happyReduce_200++action_9 _ = happyReduce_202++action_10 _ = happyReduce_283++action_11 (209) = happyShift action_98+action_11 _ = happyReduce_201++action_12 _ = happyReduce_284++action_13 _ = happyReduce_289++action_14 _ = happyReduce_319++action_15 _ = happyReduce_312++action_16 _ = happyReduce_293++action_17 _ = happyReduce_321++action_18 _ = happyReduce_203++action_19 _ = happyReduce_342++action_20 _ = happyReduce_315++action_21 (161) = happyShift action_20+action_21 (162) = happyShift action_21+action_21 (167) = happyShift action_22+action_21 (169) = happyShift action_23+action_21 (170) = happyShift action_24+action_21 (171) = happyShift action_25+action_21 (178) = happyShift action_26+action_21 (185) = happyShift action_27+action_21 (186) = happyShift action_28+action_21 (188) = happyShift action_29+action_21 (189) = happyShift action_30+action_21 (196) = happyShift action_31+action_21 (205) = happyShift action_32+action_21 (210) = happyShift action_33+action_21 (213) = happyShift action_34+action_21 (214) = happyShift action_35+action_21 (215) = happyShift action_36+action_21 (216) = happyShift action_37+action_21 (217) = happyShift action_38+action_21 (222) = happyShift action_39+action_21 (223) = happyShift action_40+action_21 (224) = happyShift action_41+action_21 (225) = happyShift action_42+action_21 (88) = happyGoto action_97+action_21 (89) = happyGoto action_5+action_21 (90) = happyGoto action_6+action_21 (91) = happyGoto action_7+action_21 (92) = happyGoto action_8+action_21 (122) = happyGoto action_9+action_21 (123) = happyGoto action_10+action_21 (125) = happyGoto action_11+action_21 (127) = happyGoto action_12+action_21 (137) = happyGoto action_13+action_21 (138) = happyGoto action_14+action_21 (139) = happyGoto action_15+action_21 (140) = happyGoto action_16+action_21 (142) = happyGoto action_17+action_21 (150) = happyGoto action_18+action_21 (151) = happyGoto action_19+action_21 _ = happyFail++action_22 (192) = happyShift action_96+action_22 (194) = happyShift action_48+action_22 (105) = happyGoto action_94+action_22 (153) = happyGoto action_95+action_22 _ = happyFail++action_23 _ = happyReduce_320++action_24 _ = happyReduce_317++action_25 (161) = happyShift action_20+action_25 (162) = happyShift action_21+action_25 (167) = happyShift action_22+action_25 (169) = happyShift action_23+action_25 (170) = happyShift action_24+action_25 (171) = happyShift action_25+action_25 (178) = happyShift action_26+action_25 (185) = happyShift action_27+action_25 (186) = happyShift action_28+action_25 (188) = happyShift action_29+action_25 (189) = happyShift action_30+action_25 (196) = happyShift action_31+action_25 (205) = happyShift action_32+action_25 (210) = happyShift action_33+action_25 (213) = happyShift action_34+action_25 (214) = happyShift action_35+action_25 (215) = happyShift action_36+action_25 (216) = happyShift action_37+action_25 (217) = happyShift action_38+action_25 (222) = happyShift action_39+action_25 (223) = happyShift action_40+action_25 (224) = happyShift action_41+action_25 (225) = happyShift action_42+action_25 (88) = happyGoto action_93+action_25 (89) = happyGoto action_5+action_25 (90) = happyGoto action_6+action_25 (91) = happyGoto action_7+action_25 (92) = happyGoto action_8+action_25 (122) = happyGoto action_9+action_25 (123) = happyGoto action_10+action_25 (125) = happyGoto action_11+action_25 (127) = happyGoto action_12+action_25 (137) = happyGoto action_13+action_25 (138) = happyGoto action_14+action_25 (139) = happyGoto action_15+action_25 (140) = happyGoto action_16+action_25 (142) = happyGoto action_17+action_25 (150) = happyGoto action_18+action_25 (151) = happyGoto action_19+action_25 _ = happyFail++action_26 (192) = happyShift action_92+action_26 (194) = happyShift action_48+action_26 (47) = happyGoto action_90+action_26 (153) = happyGoto action_91+action_26 _ = happyFail++action_27 _ = happyReduce_316++action_28 _ = happyReduce_209++action_29 _ = happyReduce_318++action_30 (161) = happyShift action_20+action_30 (162) = happyShift action_21+action_30 (167) = happyShift action_22+action_30 (169) = happyShift action_23+action_30 (170) = happyShift action_24+action_30 (171) = happyShift action_25+action_30 (178) = happyShift action_26+action_30 (185) = happyShift action_27+action_30 (186) = happyShift action_28+action_30 (188) = happyShift action_29+action_30 (189) = happyShift action_30+action_30 (190) = happyShift action_79+action_30 (196) = happyShift action_31+action_30 (198) = happyShift action_80+action_30 (199) = happyShift action_81+action_30 (200) = happyShift action_82+action_30 (202) = happyShift action_83+action_30 (205) = happyShift action_32+action_30 (210) = happyShift action_33+action_30 (212) = happyShift action_84+action_30 (213) = happyShift action_34+action_30 (214) = happyShift action_35+action_30 (215) = happyShift action_36+action_30 (216) = happyShift action_37+action_30 (217) = happyShift action_85+action_30 (218) = happyShift action_86+action_30 (219) = happyShift action_87+action_30 (220) = happyShift action_88+action_30 (221) = happyShift action_89+action_30 (222) = happyShift action_39+action_30 (223) = happyShift action_40+action_30 (224) = happyShift action_41+action_30 (225) = happyShift action_42+action_30 (88) = happyGoto action_64+action_30 (89) = happyGoto action_65+action_30 (90) = happyGoto action_6+action_30 (91) = happyGoto action_7+action_30 (92) = happyGoto action_8+action_30 (93) = happyGoto action_66+action_30 (94) = happyGoto action_67+action_30 (122) = happyGoto action_9+action_30 (123) = happyGoto action_10+action_30 (125) = happyGoto action_11+action_30 (127) = happyGoto action_12+action_30 (130) = happyGoto action_68+action_30 (132) = happyGoto action_69+action_30 (135) = happyGoto action_70+action_30 (136) = happyGoto action_71+action_30 (137) = happyGoto action_13+action_30 (138) = happyGoto action_14+action_30 (139) = happyGoto action_15+action_30 (140) = happyGoto action_16+action_30 (142) = happyGoto action_17+action_30 (143) = happyGoto action_72+action_30 (144) = happyGoto action_73+action_30 (145) = happyGoto action_74+action_30 (146) = happyGoto action_75+action_30 (147) = happyGoto action_76+action_30 (148) = happyGoto action_77+action_30 (149) = happyGoto action_78+action_30 (150) = happyGoto action_18+action_30 (151) = happyGoto action_19+action_30 _ = happyFail++action_31 (161) = happyShift action_20+action_31 (162) = happyShift action_21+action_31 (167) = happyShift action_22+action_31 (169) = happyShift action_23+action_31 (170) = happyShift action_24+action_31 (171) = happyShift action_25+action_31 (178) = happyShift action_26+action_31 (185) = happyShift action_27+action_31 (186) = happyShift action_28+action_31 (188) = happyShift action_29+action_31 (189) = happyShift action_30+action_31 (196) = happyShift action_31+action_31 (197) = happyShift action_63+action_31 (205) = happyShift action_32+action_31 (210) = happyShift action_33+action_31 (213) = happyShift action_34+action_31 (214) = happyShift action_35+action_31 (215) = happyShift action_36+action_31 (216) = happyShift action_37+action_31 (217) = happyShift action_38+action_31 (222) = happyShift action_39+action_31 (223) = happyShift action_40+action_31 (224) = happyShift action_41+action_31 (225) = happyShift action_42+action_31 (88) = happyGoto action_60+action_31 (89) = happyGoto action_5+action_31 (90) = happyGoto action_6+action_31 (91) = happyGoto action_7+action_31 (92) = happyGoto action_8+action_31 (95) = happyGoto action_61+action_31 (96) = happyGoto action_62+action_31 (122) = happyGoto action_9+action_31 (123) = happyGoto action_10+action_31 (125) = happyGoto action_11+action_31 (127) = happyGoto action_12+action_31 (137) = happyGoto action_13+action_31 (138) = happyGoto action_14+action_31 (139) = happyGoto action_15+action_31 (140) = happyGoto action_16+action_31 (142) = happyGoto action_17+action_31 (150) = happyGoto action_18+action_31 (151) = happyGoto action_19+action_31 _ = happyFail++action_32 (161) = happyShift action_20+action_32 (169) = happyShift action_23+action_32 (170) = happyShift action_24+action_32 (185) = happyShift action_27+action_32 (186) = happyShift action_56+action_32 (188) = happyShift action_29+action_32 (189) = happyShift action_57+action_32 (196) = happyShift action_58+action_32 (210) = happyShift action_59+action_32 (213) = happyShift action_34+action_32 (214) = happyShift action_35+action_32 (215) = happyShift action_36+action_32 (216) = happyShift action_37+action_32 (222) = happyShift action_39+action_32 (223) = happyShift action_40+action_32 (224) = happyShift action_41+action_32 (225) = happyShift action_42+action_32 (113) = happyGoto action_51+action_32 (115) = happyGoto action_52+action_32 (125) = happyGoto action_53+action_32 (127) = happyGoto action_54+action_32 (137) = happyGoto action_13+action_32 (138) = happyGoto action_14+action_32 (139) = happyGoto action_15+action_32 (140) = happyGoto action_16+action_32 (142) = happyGoto action_17+action_32 (150) = happyGoto action_55+action_32 (151) = happyGoto action_19+action_32 _ = happyReduce_269++action_33 (161) = happyShift action_20+action_33 (169) = happyShift action_23+action_33 (170) = happyShift action_24+action_33 (185) = happyShift action_27+action_33 (186) = happyShift action_28+action_33 (188) = happyShift action_29+action_33 (189) = happyShift action_30+action_33 (196) = happyShift action_31+action_33 (210) = happyShift action_33+action_33 (213) = happyShift action_34+action_33 (214) = happyShift action_35+action_33 (215) = happyShift action_36+action_33 (216) = happyShift action_37+action_33 (222) = happyShift action_39+action_33 (223) = happyShift action_40+action_33 (224) = happyShift action_41+action_33 (225) = happyShift action_42+action_33 (92) = happyGoto action_50+action_33 (122) = happyGoto action_9+action_33 (123) = happyGoto action_10+action_33 (125) = happyGoto action_11+action_33 (127) = happyGoto action_12+action_33 (137) = happyGoto action_13+action_33 (138) = happyGoto action_14+action_33 (139) = happyGoto action_15+action_33 (140) = happyGoto action_16+action_33 (142) = happyGoto action_17+action_33 (150) = happyGoto action_18+action_33 (151) = happyGoto action_19+action_33 _ = happyFail++action_34 _ = happyReduce_314++action_35 _ = happyReduce_313++action_36 _ = happyReduce_325++action_37 _ = happyReduce_322++action_38 (161) = happyShift action_20+action_38 (169) = happyShift action_23+action_38 (170) = happyShift action_24+action_38 (185) = happyShift action_27+action_38 (186) = happyShift action_28+action_38 (188) = happyShift action_29+action_38 (189) = happyShift action_30+action_38 (196) = happyShift action_31+action_38 (210) = happyShift action_33+action_38 (213) = happyShift action_34+action_38 (214) = happyShift action_35+action_38 (215) = happyShift action_36+action_38 (216) = happyShift action_37+action_38 (222) = happyShift action_39+action_38 (223) = happyShift action_40+action_38 (224) = happyShift action_41+action_38 (225) = happyShift action_42+action_38 (90) = happyGoto action_49+action_38 (91) = happyGoto action_7+action_38 (92) = happyGoto action_8+action_38 (122) = happyGoto action_9+action_38 (123) = happyGoto action_10+action_38 (125) = happyGoto action_11+action_38 (127) = happyGoto action_12+action_38 (137) = happyGoto action_13+action_38 (138) = happyGoto action_14+action_38 (139) = happyGoto action_15+action_38 (140) = happyGoto action_16+action_38 (142) = happyGoto action_17+action_38 (150) = happyGoto action_18+action_38 (151) = happyGoto action_19+action_38 _ = happyFail++action_39 _ = happyReduce_345++action_40 _ = happyReduce_346++action_41 _ = happyReduce_343++action_42 _ = happyReduce_344++action_43 (227) = happyAccept+action_43 _ = happyFail++action_44 (192) = happyShift action_47+action_44 (194) = happyShift action_48+action_44 (6) = happyGoto action_45+action_44 (153) = happyGoto action_46+action_44 _ = happyFail++action_45 _ = happyReduce_3++action_46 (161) = happyShift action_20+action_46 (163) = happyShift action_212+action_46 (164) = happyShift action_213+action_46 (165) = happyShift action_214+action_46 (169) = happyShift action_23+action_46 (170) = happyShift action_24+action_46 (172) = happyShift action_215+action_46 (174) = happyShift action_169+action_46 (175) = happyShift action_170+action_46 (176) = happyShift action_171+action_46 (177) = happyShift action_216+action_46 (180) = happyShift action_217+action_46 (183) = happyShift action_218+action_46 (185) = happyShift action_27+action_46 (186) = happyShift action_56+action_46 (187) = happyShift action_219+action_46 (188) = happyShift action_220+action_46 (189) = happyShift action_172+action_46 (196) = happyShift action_58+action_46 (210) = happyShift action_59+action_46 (213) = happyShift action_34+action_46 (214) = happyShift action_35+action_46 (215) = happyShift action_36+action_46 (216) = happyShift action_37+action_46 (217) = happyShift action_174+action_46 (222) = happyShift action_39+action_46 (223) = happyShift action_40+action_46 (224) = happyShift action_41+action_46 (225) = happyShift action_42+action_46 (7) = happyGoto action_221+action_46 (17) = happyGoto action_206+action_46 (18) = happyGoto action_207+action_46 (28) = happyGoto action_208+action_46 (29) = happyGoto action_153+action_46 (31) = happyGoto action_154+action_46 (33) = happyGoto action_209+action_46 (35) = happyGoto action_210+action_46 (45) = happyGoto action_211+action_46 (46) = happyGoto action_158+action_46 (48) = happyGoto action_159+action_46 (49) = happyGoto action_160+action_46 (50) = happyGoto action_161+action_46 (82) = happyGoto action_162+action_46 (83) = happyGoto action_163+action_46 (111) = happyGoto action_164+action_46 (112) = happyGoto action_165+action_46 (113) = happyGoto action_166+action_46 (125) = happyGoto action_167+action_46 (127) = happyGoto action_168+action_46 (137) = happyGoto action_13+action_46 (138) = happyGoto action_14+action_46 (139) = happyGoto action_15+action_46 (140) = happyGoto action_16+action_46 (142) = happyGoto action_17+action_46 (150) = happyGoto action_55+action_46 (151) = happyGoto action_19+action_46 _ = happyReduce_9++action_47 (161) = happyShift action_20+action_47 (163) = happyShift action_212+action_47 (164) = happyShift action_213+action_47 (165) = happyShift action_214+action_47 (169) = happyShift action_23+action_47 (170) = happyShift action_24+action_47 (172) = happyShift action_215+action_47 (174) = happyShift action_169+action_47 (175) = happyShift action_170+action_47 (176) = happyShift action_171+action_47 (177) = happyShift action_216+action_47 (180) = happyShift action_217+action_47 (183) = happyShift action_218+action_47 (185) = happyShift action_27+action_47 (186) = happyShift action_56+action_47 (187) = happyShift action_219+action_47 (188) = happyShift action_220+action_47 (189) = happyShift action_172+action_47 (196) = happyShift action_58+action_47 (210) = happyShift action_59+action_47 (213) = happyShift action_34+action_47 (214) = happyShift action_35+action_47 (215) = happyShift action_36+action_47 (216) = happyShift action_37+action_47 (217) = happyShift action_174+action_47 (222) = happyShift action_39+action_47 (223) = happyShift action_40+action_47 (224) = happyShift action_41+action_47 (225) = happyShift action_42+action_47 (7) = happyGoto action_205+action_47 (17) = happyGoto action_206+action_47 (18) = happyGoto action_207+action_47 (28) = happyGoto action_208+action_47 (29) = happyGoto action_153+action_47 (31) = happyGoto action_154+action_47 (33) = happyGoto action_209+action_47 (35) = happyGoto action_210+action_47 (45) = happyGoto action_211+action_47 (46) = happyGoto action_158+action_47 (48) = happyGoto action_159+action_47 (49) = happyGoto action_160+action_47 (50) = happyGoto action_161+action_47 (82) = happyGoto action_162+action_47 (83) = happyGoto action_163+action_47 (111) = happyGoto action_164+action_47 (112) = happyGoto action_165+action_47 (113) = happyGoto action_166+action_47 (125) = happyGoto action_167+action_47 (127) = happyGoto action_168+action_47 (137) = happyGoto action_13+action_47 (138) = happyGoto action_14+action_47 (139) = happyGoto action_15+action_47 (140) = happyGoto action_16+action_47 (142) = happyGoto action_17+action_47 (150) = happyGoto action_55+action_47 (151) = happyGoto action_19+action_47 _ = happyReduce_9++action_48 _ = happyReduce_348++action_49 (161) = happyShift action_20+action_49 (169) = happyShift action_23+action_49 (170) = happyShift action_24+action_49 (185) = happyShift action_27+action_49 (186) = happyShift action_28+action_49 (188) = happyShift action_29+action_49 (189) = happyShift action_30+action_49 (196) = happyShift action_31+action_49 (210) = happyShift action_33+action_49 (213) = happyShift action_34+action_49 (214) = happyShift action_35+action_49 (215) = happyShift action_36+action_49 (216) = happyShift action_37+action_49 (222) = happyShift action_39+action_49 (223) = happyShift action_40+action_49 (224) = happyShift action_41+action_49 (225) = happyShift action_42+action_49 (91) = happyGoto action_100+action_49 (92) = happyGoto action_8+action_49 (122) = happyGoto action_9+action_49 (123) = happyGoto action_10+action_49 (125) = happyGoto action_11+action_49 (127) = happyGoto action_12+action_49 (137) = happyGoto action_13+action_49 (138) = happyGoto action_14+action_49 (139) = happyGoto action_15+action_49 (140) = happyGoto action_16+action_49 (142) = happyGoto action_17+action_49 (150) = happyGoto action_18+action_49 (151) = happyGoto action_19+action_49 _ = happyReduce_194++action_50 _ = happyReduce_210++action_51 (161) = happyShift action_20+action_51 (169) = happyShift action_23+action_51 (170) = happyShift action_24+action_51 (185) = happyShift action_27+action_51 (186) = happyShift action_56+action_51 (188) = happyShift action_29+action_51 (189) = happyShift action_57+action_51 (196) = happyShift action_58+action_51 (210) = happyShift action_59+action_51 (213) = happyShift action_34+action_51 (214) = happyShift action_35+action_51 (215) = happyShift action_36+action_51 (216) = happyShift action_37+action_51 (222) = happyShift action_39+action_51 (223) = happyShift action_40+action_51 (224) = happyShift action_41+action_51 (225) = happyShift action_42+action_51 (113) = happyGoto action_51+action_51 (115) = happyGoto action_204+action_51 (125) = happyGoto action_53+action_51 (127) = happyGoto action_54+action_51 (137) = happyGoto action_13+action_51 (138) = happyGoto action_14+action_51 (139) = happyGoto action_15+action_51 (140) = happyGoto action_16+action_51 (142) = happyGoto action_17+action_51 (150) = happyGoto action_55+action_51 (151) = happyGoto action_19+action_51 _ = happyReduce_269++action_52 (208) = happyShift action_203+action_52 _ = happyFail++action_53 (209) = happyShift action_202+action_53 _ = happyReduce_257++action_54 (192) = happyShift action_201+action_54 _ = happyReduce_259++action_55 _ = happyReduce_262++action_56 _ = happyReduce_263++action_57 (161) = happyShift action_20+action_57 (169) = happyShift action_23+action_57 (170) = happyShift action_24+action_57 (185) = happyShift action_27+action_57 (186) = happyShift action_56+action_57 (188) = happyShift action_29+action_57 (189) = happyShift action_57+action_57 (190) = happyShift action_199+action_57 (196) = happyShift action_58+action_57 (200) = happyShift action_108+action_57 (202) = happyShift action_83+action_57 (210) = happyShift action_59+action_57 (212) = happyShift action_110+action_57 (213) = happyShift action_34+action_57 (214) = happyShift action_35+action_57 (215) = happyShift action_36+action_57 (216) = happyShift action_37+action_57 (217) = happyShift action_200+action_57 (218) = happyShift action_112+action_57 (219) = happyShift action_87+action_57 (220) = happyShift action_88+action_57 (221) = happyShift action_89+action_57 (222) = happyShift action_39+action_57 (223) = happyShift action_40+action_57 (224) = happyShift action_41+action_57 (225) = happyShift action_42+action_57 (110) = happyGoto action_196+action_57 (111) = happyGoto action_193+action_57 (112) = happyGoto action_165+action_57 (113) = happyGoto action_166+action_57 (119) = happyGoto action_197+action_57 (125) = happyGoto action_53+action_57 (127) = happyGoto action_168+action_57 (135) = happyGoto action_198+action_57 (137) = happyGoto action_13+action_57 (138) = happyGoto action_14+action_57 (139) = happyGoto action_15+action_57 (140) = happyGoto action_16+action_57 (142) = happyGoto action_17+action_57 (143) = happyGoto action_72+action_57 (144) = happyGoto action_73+action_57 (145) = happyGoto action_74+action_57 (147) = happyGoto action_76+action_57 (149) = happyGoto action_106+action_57 (150) = happyGoto action_55+action_57 (151) = happyGoto action_19+action_57 _ = happyFail++action_58 (161) = happyShift action_20+action_58 (169) = happyShift action_23+action_58 (170) = happyShift action_24+action_58 (185) = happyShift action_27+action_58 (186) = happyShift action_56+action_58 (188) = happyShift action_29+action_58 (189) = happyShift action_57+action_58 (196) = happyShift action_58+action_58 (210) = happyShift action_59+action_58 (213) = happyShift action_34+action_58 (214) = happyShift action_35+action_58 (215) = happyShift action_36+action_58 (216) = happyShift action_37+action_58 (217) = happyShift action_174+action_58 (222) = happyShift action_39+action_58 (223) = happyShift action_40+action_58 (224) = happyShift action_41+action_58 (225) = happyShift action_42+action_58 (110) = happyGoto action_192+action_58 (111) = happyGoto action_193+action_58 (112) = happyGoto action_165+action_58 (113) = happyGoto action_166+action_58 (120) = happyGoto action_194+action_58 (121) = happyGoto action_195+action_58 (125) = happyGoto action_53+action_58 (127) = happyGoto action_168+action_58 (137) = happyGoto action_13+action_58 (138) = happyGoto action_14+action_58 (139) = happyGoto action_15+action_58 (140) = happyGoto action_16+action_58 (142) = happyGoto action_17+action_58 (150) = happyGoto action_55+action_58 (151) = happyGoto action_19+action_58 _ = happyReduce_278++action_59 (161) = happyShift action_20+action_59 (169) = happyShift action_23+action_59 (170) = happyShift action_24+action_59 (185) = happyShift action_27+action_59 (186) = happyShift action_56+action_59 (188) = happyShift action_29+action_59 (189) = happyShift action_57+action_59 (196) = happyShift action_58+action_59 (210) = happyShift action_59+action_59 (213) = happyShift action_34+action_59 (214) = happyShift action_35+action_59 (215) = happyShift action_36+action_59 (216) = happyShift action_37+action_59 (222) = happyShift action_39+action_59 (223) = happyShift action_40+action_59 (224) = happyShift action_41+action_59 (225) = happyShift action_42+action_59 (113) = happyGoto action_191+action_59 (125) = happyGoto action_53+action_59 (127) = happyGoto action_54+action_59 (137) = happyGoto action_13+action_59 (138) = happyGoto action_14+action_59 (139) = happyGoto action_15+action_59 (140) = happyGoto action_16+action_59 (142) = happyGoto action_17+action_59 (150) = happyGoto action_55+action_59 (151) = happyGoto action_19+action_59 _ = happyFail++action_60 (198) = happyShift action_188+action_60 (201) = happyShift action_189+action_60 (206) = happyShift action_190+action_60 _ = happyReduce_215++action_61 (197) = happyShift action_187+action_61 _ = happyFail++action_62 (198) = happyShift action_186+action_62 _ = happyReduce_216++action_63 _ = happyReduce_282++action_64 (198) = happyShift action_185+action_64 _ = happyReduce_214++action_65 (199) = happyShift action_107+action_65 (200) = happyShift action_108+action_65 (202) = happyShift action_83+action_65 (203) = happyShift action_109+action_65 (212) = happyShift action_110+action_65 (217) = happyShift action_111+action_65 (218) = happyShift action_112+action_65 (219) = happyShift action_87+action_65 (220) = happyShift action_88+action_65 (221) = happyShift action_89+action_65 (129) = happyGoto action_101+action_65 (132) = happyGoto action_102+action_65 (134) = happyGoto action_184+action_65 (135) = happyGoto action_104+action_65 (143) = happyGoto action_72+action_65 (144) = happyGoto action_73+action_65 (145) = happyGoto action_105+action_65 (147) = happyGoto action_76+action_65 (149) = happyGoto action_106+action_65 _ = happyReduce_188++action_66 (190) = happyShift action_182+action_66 (198) = happyShift action_183+action_66 _ = happyFail++action_67 (190) = happyShift action_181+action_67 _ = happyFail++action_68 _ = happyReduce_310++action_69 _ = happyReduce_311++action_70 (190) = happyShift action_180+action_70 _ = happyReduce_303++action_71 (161) = happyShift action_20+action_71 (162) = happyShift action_21+action_71 (167) = happyShift action_22+action_71 (169) = happyShift action_23+action_71 (170) = happyShift action_24+action_71 (171) = happyShift action_25+action_71 (178) = happyShift action_26+action_71 (185) = happyShift action_27+action_71 (186) = happyShift action_28+action_71 (188) = happyShift action_29+action_71 (189) = happyShift action_30+action_71 (196) = happyShift action_31+action_71 (205) = happyShift action_32+action_71 (210) = happyShift action_33+action_71 (213) = happyShift action_34+action_71 (214) = happyShift action_35+action_71 (215) = happyShift action_36+action_71 (216) = happyShift action_37+action_71 (217) = happyShift action_38+action_71 (222) = happyShift action_39+action_71 (223) = happyShift action_40+action_71 (224) = happyShift action_41+action_71 (225) = happyShift action_42+action_71 (89) = happyGoto action_179+action_71 (90) = happyGoto action_6+action_71 (91) = happyGoto action_7+action_71 (92) = happyGoto action_8+action_71 (122) = happyGoto action_9+action_71 (123) = happyGoto action_10+action_71 (125) = happyGoto action_11+action_71 (127) = happyGoto action_12+action_71 (137) = happyGoto action_13+action_71 (138) = happyGoto action_14+action_71 (139) = happyGoto action_15+action_71 (140) = happyGoto action_16+action_71 (142) = happyGoto action_17+action_71 (150) = happyGoto action_18+action_71 (151) = happyGoto action_19+action_71 _ = happyFail++action_72 _ = happyReduce_309++action_73 _ = happyReduce_326++action_74 (190) = happyShift action_178+action_74 _ = happyFail++action_75 _ = happyReduce_299++action_76 _ = happyReduce_330++action_77 _ = happyReduce_332++action_78 (190) = happyReduce_331+action_78 _ = happyReduce_333++action_79 _ = happyReduce_285++action_80 _ = happyReduce_212++action_81 (161) = happyShift action_20+action_81 (169) = happyShift action_23+action_81 (170) = happyShift action_24+action_81 (185) = happyShift action_27+action_81 (188) = happyShift action_29+action_81 (213) = happyShift action_34+action_81 (214) = happyShift action_35+action_81 (215) = happyShift action_36+action_81 (216) = happyShift action_37+action_81 (137) = happyGoto action_177+action_81 (138) = happyGoto action_14+action_81 (139) = happyGoto action_15+action_81 (140) = happyGoto action_134+action_81 (142) = happyGoto action_17+action_81 _ = happyFail++action_82 (190) = happyReduce_337+action_82 _ = happyReduce_340++action_83 _ = happyReduce_329++action_84 (190) = happyReduce_336+action_84 _ = happyReduce_339++action_85 (161) = happyShift action_20+action_85 (169) = happyShift action_23+action_85 (170) = happyShift action_24+action_85 (185) = happyShift action_27+action_85 (186) = happyShift action_28+action_85 (188) = happyShift action_29+action_85 (189) = happyShift action_30+action_85 (196) = happyShift action_31+action_85 (210) = happyShift action_33+action_85 (213) = happyShift action_34+action_85 (214) = happyShift action_35+action_85 (215) = happyShift action_36+action_85 (216) = happyShift action_37+action_85 (222) = happyShift action_39+action_85 (223) = happyShift action_40+action_85 (224) = happyShift action_41+action_85 (225) = happyShift action_42+action_85 (90) = happyGoto action_49+action_85 (91) = happyGoto action_7+action_85 (92) = happyGoto action_8+action_85 (122) = happyGoto action_9+action_85 (123) = happyGoto action_10+action_85 (125) = happyGoto action_11+action_85 (127) = happyGoto action_12+action_85 (137) = happyGoto action_13+action_85 (138) = happyGoto action_14+action_85 (139) = happyGoto action_15+action_85 (140) = happyGoto action_16+action_85 (142) = happyGoto action_17+action_85 (150) = happyGoto action_18+action_85 (151) = happyGoto action_19+action_85 _ = happyReduce_335++action_86 (190) = happyReduce_334+action_86 _ = happyReduce_338++action_87 _ = happyReduce_328++action_88 _ = happyReduce_341++action_89 _ = happyReduce_327++action_90 (173) = happyShift action_176+action_90 _ = happyFail++action_91 (161) = happyShift action_20+action_91 (169) = happyShift action_23+action_91 (170) = happyShift action_24+action_91 (174) = happyShift action_169+action_91 (175) = happyShift action_170+action_91 (176) = happyShift action_171+action_91 (185) = happyShift action_27+action_91 (186) = happyShift action_56+action_91 (188) = happyShift action_29+action_91 (189) = happyShift action_172+action_91 (191) = happyShift action_173+action_91 (196) = happyShift action_58+action_91 (210) = happyShift action_59+action_91 (213) = happyShift action_34+action_91 (214) = happyShift action_35+action_91 (215) = happyShift action_36+action_91 (216) = happyShift action_37+action_91 (217) = happyShift action_174+action_91 (222) = happyShift action_39+action_91 (223) = happyShift action_40+action_91 (224) = happyShift action_41+action_91 (225) = happyShift action_42+action_91 (9) = happyGoto action_152+action_91 (29) = happyGoto action_153+action_91 (31) = happyGoto action_154+action_91 (43) = happyGoto action_175+action_91 (44) = happyGoto action_156+action_91 (45) = happyGoto action_157+action_91 (46) = happyGoto action_158+action_91 (48) = happyGoto action_159+action_91 (49) = happyGoto action_160+action_91 (50) = happyGoto action_161+action_91 (82) = happyGoto action_162+action_91 (83) = happyGoto action_163+action_91 (111) = happyGoto action_164+action_91 (112) = happyGoto action_165+action_91 (113) = happyGoto action_166+action_91 (125) = happyGoto action_167+action_91 (127) = happyGoto action_168+action_91 (137) = happyGoto action_13+action_91 (138) = happyGoto action_14+action_91 (139) = happyGoto action_15+action_91 (140) = happyGoto action_16+action_91 (142) = happyGoto action_17+action_91 (150) = happyGoto action_55+action_91 (151) = happyGoto action_19+action_91 _ = happyReduce_13++action_92 (161) = happyShift action_20+action_92 (169) = happyShift action_23+action_92 (170) = happyShift action_24+action_92 (174) = happyShift action_169+action_92 (175) = happyShift action_170+action_92 (176) = happyShift action_171+action_92 (185) = happyShift action_27+action_92 (186) = happyShift action_56+action_92 (188) = happyShift action_29+action_92 (189) = happyShift action_172+action_92 (191) = happyShift action_173+action_92 (196) = happyShift action_58+action_92 (210) = happyShift action_59+action_92 (213) = happyShift action_34+action_92 (214) = happyShift action_35+action_92 (215) = happyShift action_36+action_92 (216) = happyShift action_37+action_92 (217) = happyShift action_174+action_92 (222) = happyShift action_39+action_92 (223) = happyShift action_40+action_92 (224) = happyShift action_41+action_92 (225) = happyShift action_42+action_92 (9) = happyGoto action_152+action_92 (29) = happyGoto action_153+action_92 (31) = happyGoto action_154+action_92 (43) = happyGoto action_155+action_92 (44) = happyGoto action_156+action_92 (45) = happyGoto action_157+action_92 (46) = happyGoto action_158+action_92 (48) = happyGoto action_159+action_92 (49) = happyGoto action_160+action_92 (50) = happyGoto action_161+action_92 (82) = happyGoto action_162+action_92 (83) = happyGoto action_163+action_92 (111) = happyGoto action_164+action_92 (112) = happyGoto action_165+action_92 (113) = happyGoto action_166+action_92 (125) = happyGoto action_167+action_92 (127) = happyGoto action_168+action_92 (137) = happyGoto action_13+action_92 (138) = happyGoto action_14+action_92 (139) = happyGoto action_15+action_92 (140) = happyGoto action_16+action_92 (142) = happyGoto action_17+action_92 (150) = happyGoto action_55+action_92 (151) = happyGoto action_19+action_92 _ = happyReduce_13++action_93 (182) = happyShift action_151+action_93 _ = happyFail++action_94 _ = happyReduce_195++action_95 (161) = happyShift action_20+action_95 (162) = happyShift action_21+action_95 (167) = happyShift action_22+action_95 (169) = happyShift action_23+action_95 (170) = happyShift action_24+action_95 (171) = happyShift action_25+action_95 (178) = happyShift action_148+action_95 (185) = happyShift action_27+action_95 (186) = happyShift action_28+action_95 (188) = happyShift action_29+action_95 (189) = happyShift action_30+action_95 (191) = happyShift action_149+action_95 (196) = happyShift action_31+action_95 (205) = happyShift action_32+action_95 (210) = happyShift action_33+action_95 (213) = happyShift action_34+action_95 (214) = happyShift action_35+action_95 (215) = happyShift action_36+action_95 (216) = happyShift action_37+action_95 (217) = happyShift action_38+action_95 (222) = happyShift action_39+action_95 (223) = happyShift action_40+action_95 (224) = happyShift action_41+action_95 (225) = happyShift action_42+action_95 (8) = happyGoto action_143+action_95 (88) = happyGoto action_144+action_95 (89) = happyGoto action_145+action_95 (90) = happyGoto action_6+action_95 (91) = happyGoto action_7+action_95 (92) = happyGoto action_8+action_95 (98) = happyGoto action_146+action_95 (106) = happyGoto action_150+action_95 (122) = happyGoto action_9+action_95 (123) = happyGoto action_10+action_95 (125) = happyGoto action_11+action_95 (127) = happyGoto action_12+action_95 (137) = happyGoto action_13+action_95 (138) = happyGoto action_14+action_95 (139) = happyGoto action_15+action_95 (140) = happyGoto action_16+action_95 (142) = happyGoto action_17+action_95 (150) = happyGoto action_18+action_95 (151) = happyGoto action_19+action_95 _ = happyFail++action_96 (161) = happyShift action_20+action_96 (162) = happyShift action_21+action_96 (167) = happyShift action_22+action_96 (169) = happyShift action_23+action_96 (170) = happyShift action_24+action_96 (171) = happyShift action_25+action_96 (178) = happyShift action_148+action_96 (185) = happyShift action_27+action_96 (186) = happyShift action_28+action_96 (188) = happyShift action_29+action_96 (189) = happyShift action_30+action_96 (191) = happyShift action_149+action_96 (196) = happyShift action_31+action_96 (205) = happyShift action_32+action_96 (210) = happyShift action_33+action_96 (213) = happyShift action_34+action_96 (214) = happyShift action_35+action_96 (215) = happyShift action_36+action_96 (216) = happyShift action_37+action_96 (217) = happyShift action_38+action_96 (222) = happyShift action_39+action_96 (223) = happyShift action_40+action_96 (224) = happyShift action_41+action_96 (225) = happyShift action_42+action_96 (8) = happyGoto action_143+action_96 (88) = happyGoto action_144+action_96 (89) = happyGoto action_145+action_96 (90) = happyGoto action_6+action_96 (91) = happyGoto action_7+action_96 (92) = happyGoto action_8+action_96 (98) = happyGoto action_146+action_96 (106) = happyGoto action_147+action_96 (122) = happyGoto action_9+action_96 (123) = happyGoto action_10+action_96 (125) = happyGoto action_11+action_96 (127) = happyGoto action_12+action_96 (137) = happyGoto action_13+action_96 (138) = happyGoto action_14+action_96 (139) = happyGoto action_15+action_96 (140) = happyGoto action_16+action_96 (142) = happyGoto action_17+action_96 (150) = happyGoto action_18+action_96 (151) = happyGoto action_19+action_96 _ = happyFail++action_97 (181) = happyShift action_142+action_97 _ = happyFail++action_98 (161) = happyShift action_20+action_98 (169) = happyShift action_23+action_98 (170) = happyShift action_24+action_98 (185) = happyShift action_27+action_98 (186) = happyShift action_28+action_98 (188) = happyShift action_29+action_98 (189) = happyShift action_30+action_98 (196) = happyShift action_31+action_98 (210) = happyShift action_33+action_98 (213) = happyShift action_34+action_98 (214) = happyShift action_35+action_98 (215) = happyShift action_36+action_98 (216) = happyShift action_37+action_98 (222) = happyShift action_39+action_98 (223) = happyShift action_40+action_98 (224) = happyShift action_41+action_98 (225) = happyShift action_42+action_98 (91) = happyGoto action_141+action_98 (92) = happyGoto action_8+action_98 (122) = happyGoto action_9+action_98 (123) = happyGoto action_10+action_98 (125) = happyGoto action_11+action_98 (127) = happyGoto action_12+action_98 (137) = happyGoto action_13+action_98 (138) = happyGoto action_14+action_98 (139) = happyGoto action_15+action_98 (140) = happyGoto action_16+action_98 (142) = happyGoto action_17+action_98 (150) = happyGoto action_18+action_98 (151) = happyGoto action_19+action_98 _ = happyFail++action_99 (161) = happyShift action_20+action_99 (169) = happyShift action_23+action_99 (170) = happyShift action_24+action_99 (185) = happyShift action_27+action_99 (188) = happyShift action_29+action_99 (189) = happyShift action_140+action_99 (213) = happyShift action_34+action_99 (214) = happyShift action_35+action_99 (107) = happyGoto action_136+action_99 (108) = happyGoto action_137+action_99 (109) = happyGoto action_138+action_99 (125) = happyGoto action_139+action_99 (137) = happyGoto action_13+action_99 (138) = happyGoto action_14+action_99 (139) = happyGoto action_15+action_99 _ = happyReduce_246++action_100 (192) = happyShift action_99+action_100 _ = happyReduce_197++action_101 _ = happyReduce_307++action_102 _ = happyReduce_308++action_103 (161) = happyShift action_20+action_103 (162) = happyShift action_21+action_103 (167) = happyShift action_22+action_103 (169) = happyShift action_23+action_103 (170) = happyShift action_24+action_103 (171) = happyShift action_25+action_103 (178) = happyShift action_26+action_103 (185) = happyShift action_27+action_103 (186) = happyShift action_28+action_103 (188) = happyShift action_29+action_103 (189) = happyShift action_30+action_103 (196) = happyShift action_31+action_103 (205) = happyShift action_32+action_103 (210) = happyShift action_33+action_103 (213) = happyShift action_34+action_103 (214) = happyShift action_35+action_103 (215) = happyShift action_36+action_103 (216) = happyShift action_37+action_103 (217) = happyShift action_38+action_103 (222) = happyShift action_39+action_103 (223) = happyShift action_40+action_103 (224) = happyShift action_41+action_103 (225) = happyShift action_42+action_103 (89) = happyGoto action_135+action_103 (90) = happyGoto action_6+action_103 (91) = happyGoto action_7+action_103 (92) = happyGoto action_8+action_103 (122) = happyGoto action_9+action_103 (123) = happyGoto action_10+action_103 (125) = happyGoto action_11+action_103 (127) = happyGoto action_12+action_103 (137) = happyGoto action_13+action_103 (138) = happyGoto action_14+action_103 (139) = happyGoto action_15+action_103 (140) = happyGoto action_16+action_103 (142) = happyGoto action_17+action_103 (150) = happyGoto action_18+action_103 (151) = happyGoto action_19+action_103 _ = happyFail++action_104 _ = happyReduce_303++action_105 _ = happyReduce_297++action_106 _ = happyReduce_331++action_107 (161) = happyShift action_20+action_107 (169) = happyShift action_23+action_107 (170) = happyShift action_24+action_107 (185) = happyShift action_27+action_107 (188) = happyShift action_29+action_107 (213) = happyShift action_34+action_107 (214) = happyShift action_35+action_107 (215) = happyShift action_36+action_107 (216) = happyShift action_37+action_107 (137) = happyGoto action_133+action_107 (138) = happyGoto action_14+action_107 (139) = happyGoto action_15+action_107 (140) = happyGoto action_134+action_107 (142) = happyGoto action_17+action_107 _ = happyFail++action_108 _ = happyReduce_337++action_109 (161) = happyShift action_20+action_109 (169) = happyShift action_129+action_109 (170) = happyShift action_24+action_109 (185) = happyShift action_27+action_109 (188) = happyShift action_29+action_109 (189) = happyShift action_130+action_109 (196) = happyShift action_131+action_109 (213) = happyShift action_34+action_109 (215) = happyShift action_36+action_109 (216) = happyShift action_132+action_109 (51) = happyGoto action_118+action_109 (52) = happyGoto action_119+action_109 (53) = happyGoto action_120+action_109 (56) = happyGoto action_121+action_109 (57) = happyGoto action_122+action_109 (58) = happyGoto action_123+action_109 (138) = happyGoto action_124+action_109 (141) = happyGoto action_125+action_109 (142) = happyGoto action_126+action_109 (157) = happyGoto action_127+action_109 (160) = happyGoto action_128+action_109 _ = happyFail++action_110 _ = happyReduce_336++action_111 _ = happyReduce_335++action_112 _ = happyReduce_334++action_113 _ = happyReduce_351++action_114 (189) = happyShift action_117+action_114 (10) = happyGoto action_115+action_114 (11) = happyGoto action_116+action_114 _ = happyReduce_15++action_115 (184) = happyShift action_318+action_115 _ = happyFail++action_116 _ = happyReduce_14++action_117 (190) = happyShift action_316+action_117 (198) = happyShift action_317+action_117 (12) = happyGoto action_315+action_117 _ = happyReduce_19++action_118 _ = happyReduce_126++action_119 (161) = happyShift action_20+action_119 (170) = happyShift action_24+action_119 (185) = happyShift action_27+action_119 (188) = happyShift action_29+action_119 (189) = happyShift action_130+action_119 (196) = happyShift action_131+action_119 (208) = happyShift action_314+action_119 (211) = happyReduce_127+action_119 (213) = happyShift action_34+action_119 (215) = happyShift action_36+action_119 (216) = happyShift action_132+action_119 (53) = happyGoto action_313+action_119 (56) = happyGoto action_121+action_119 (138) = happyGoto action_124+action_119 (141) = happyGoto action_125+action_119 (142) = happyGoto action_126+action_119 (157) = happyGoto action_127+action_119 (160) = happyGoto action_128+action_119 _ = happyReduce_108++action_120 _ = happyReduce_111++action_121 _ = happyReduce_112++action_122 _ = happyReduce_187++action_123 (211) = happyShift action_312+action_123 _ = happyFail++action_124 _ = happyReduce_356++action_125 _ = happyReduce_120++action_126 _ = happyReduce_353++action_127 _ = happyReduce_323++action_128 _ = happyReduce_113++action_129 (161) = happyShift action_20+action_129 (170) = happyShift action_24+action_129 (185) = happyShift action_27+action_129 (188) = happyShift action_29+action_129 (213) = happyShift action_34+action_129 (42) = happyGoto action_310+action_129 (138) = happyGoto action_124+action_129 (160) = happyGoto action_311+action_129 _ = happyReduce_91++action_130 (161) = happyShift action_20+action_130 (169) = happyShift action_129+action_130 (170) = happyShift action_24+action_130 (185) = happyShift action_27+action_130 (188) = happyShift action_29+action_130 (189) = happyShift action_130+action_130 (190) = happyShift action_308+action_130 (196) = happyShift action_131+action_130 (198) = happyShift action_80+action_130 (208) = happyShift action_309+action_130 (213) = happyShift action_34+action_130 (215) = happyShift action_36+action_130 (216) = happyShift action_132+action_130 (51) = happyGoto action_305+action_130 (52) = happyGoto action_303+action_130 (53) = happyGoto action_120+action_130 (55) = happyGoto action_306+action_130 (56) = happyGoto action_121+action_130 (93) = happyGoto action_307+action_130 (138) = happyGoto action_124+action_130 (141) = happyGoto action_125+action_130 (142) = happyGoto action_126+action_130 (157) = happyGoto action_127+action_130 (160) = happyGoto action_128+action_130 _ = happyFail++action_131 (161) = happyShift action_20+action_131 (169) = happyShift action_129+action_131 (170) = happyShift action_24+action_131 (185) = happyShift action_27+action_131 (188) = happyShift action_29+action_131 (189) = happyShift action_130+action_131 (196) = happyShift action_131+action_131 (197) = happyShift action_304+action_131 (213) = happyShift action_34+action_131 (215) = happyShift action_36+action_131 (216) = happyShift action_132+action_131 (51) = happyGoto action_302+action_131 (52) = happyGoto action_303+action_131 (53) = happyGoto action_120+action_131 (56) = happyGoto action_121+action_131 (138) = happyGoto action_124+action_131 (141) = happyGoto action_125+action_131 (142) = happyGoto action_126+action_131 (157) = happyGoto action_127+action_131 (160) = happyGoto action_128+action_131 _ = happyFail++action_132 _ = happyReduce_324++action_133 (199) = happyShift action_301+action_133 _ = happyFail++action_134 (199) = happyShift action_300+action_134 _ = happyFail++action_135 (129) = happyGoto action_101+action_135 (132) = happyGoto action_102+action_135 (134) = happyGoto action_103+action_135 (135) = happyGoto action_104+action_135 (143) = happyGoto action_72+action_135 (144) = happyGoto action_73+action_135 (145) = happyGoto action_105+action_135 (147) = happyGoto action_76+action_135 (149) = happyGoto action_106+action_135 _ = happyReduce_189++action_136 (193) = happyShift action_299+action_136 _ = happyFail++action_137 (198) = happyShift action_298+action_137 _ = happyReduce_247++action_138 _ = happyReduce_249++action_139 (204) = happyShift action_297+action_139 _ = happyFail++action_140 (200) = happyShift action_108+action_140 (212) = happyShift action_110+action_140 (217) = happyShift action_111+action_140 (218) = happyShift action_112+action_140 (220) = happyShift action_88+action_140 (145) = happyGoto action_74+action_140 (147) = happyGoto action_76+action_140 (149) = happyGoto action_106+action_140 _ = happyFail++action_141 (192) = happyShift action_99+action_141 _ = happyReduce_208++action_142 (192) = happyShift action_296+action_142 (194) = happyShift action_48+action_142 (99) = happyGoto action_294+action_142 (153) = happyGoto action_295+action_142 _ = happyFail++action_143 (161) = happyShift action_20+action_143 (162) = happyShift action_21+action_143 (167) = happyShift action_22+action_143 (169) = happyShift action_23+action_143 (170) = happyShift action_24+action_143 (171) = happyShift action_25+action_143 (178) = happyShift action_148+action_143 (185) = happyShift action_27+action_143 (186) = happyShift action_28+action_143 (188) = happyShift action_29+action_143 (189) = happyShift action_30+action_143 (191) = happyShift action_149+action_143 (196) = happyShift action_31+action_143 (205) = happyShift action_32+action_143 (210) = happyShift action_33+action_143 (213) = happyShift action_34+action_143 (214) = happyShift action_35+action_143 (215) = happyShift action_36+action_143 (216) = happyShift action_37+action_143 (217) = happyShift action_38+action_143 (222) = happyShift action_39+action_143 (223) = happyShift action_40+action_143 (224) = happyShift action_41+action_143 (225) = happyShift action_42+action_143 (8) = happyGoto action_143+action_143 (88) = happyGoto action_144+action_143 (89) = happyGoto action_145+action_143 (90) = happyGoto action_6+action_143 (91) = happyGoto action_7+action_143 (92) = happyGoto action_8+action_143 (98) = happyGoto action_146+action_143 (106) = happyGoto action_293+action_143 (122) = happyGoto action_9+action_143 (123) = happyGoto action_10+action_143 (125) = happyGoto action_11+action_143 (127) = happyGoto action_12+action_143 (137) = happyGoto action_13+action_143 (138) = happyGoto action_14+action_143 (139) = happyGoto action_15+action_143 (140) = happyGoto action_16+action_143 (142) = happyGoto action_17+action_143 (150) = happyGoto action_18+action_143 (151) = happyGoto action_19+action_143 _ = happyFail++action_144 _ = happyReduce_227++action_145 (199) = happyShift action_107+action_145 (200) = happyShift action_108+action_145 (202) = happyShift action_83+action_145 (203) = happyShift action_109+action_145 (207) = happyShift action_292+action_145 (212) = happyShift action_110+action_145 (217) = happyShift action_111+action_145 (218) = happyShift action_112+action_145 (219) = happyShift action_87+action_145 (220) = happyShift action_88+action_145 (221) = happyShift action_89+action_145 (129) = happyGoto action_101+action_145 (132) = happyGoto action_102+action_145 (134) = happyGoto action_103+action_145 (135) = happyGoto action_104+action_145 (143) = happyGoto action_72+action_145 (144) = happyGoto action_73+action_145 (145) = happyGoto action_105+action_145 (147) = happyGoto action_76+action_145 (149) = happyGoto action_106+action_145 _ = happyReduce_188++action_146 (191) = happyShift action_149+action_146 (8) = happyGoto action_291+action_146 _ = happyReduce_244++action_147 (193) = happyShift action_290+action_147 _ = happyFail++action_148 (192) = happyShift action_92+action_148 (194) = happyShift action_48+action_148 (47) = happyGoto action_289+action_148 (153) = happyGoto action_91+action_148 _ = happyFail++action_149 (191) = happyShift action_149+action_149 (8) = happyGoto action_288+action_149 _ = happyReduce_11++action_150 (1) = happyShift action_223+action_150 (195) = happyShift action_224+action_150 (154) = happyGoto action_287+action_150 _ = happyFail++action_151 (161) = happyShift action_20+action_151 (162) = happyShift action_21+action_151 (167) = happyShift action_22+action_151 (169) = happyShift action_23+action_151 (170) = happyShift action_24+action_151 (171) = happyShift action_25+action_151 (178) = happyShift action_26+action_151 (185) = happyShift action_27+action_151 (186) = happyShift action_28+action_151 (188) = happyShift action_29+action_151 (189) = happyShift action_30+action_151 (196) = happyShift action_31+action_151 (205) = happyShift action_32+action_151 (210) = happyShift action_33+action_151 (213) = happyShift action_34+action_151 (214) = happyShift action_35+action_151 (215) = happyShift action_36+action_151 (216) = happyShift action_37+action_151 (217) = happyShift action_38+action_151 (222) = happyShift action_39+action_151 (223) = happyShift action_40+action_151 (224) = happyShift action_41+action_151 (225) = happyShift action_42+action_151 (88) = happyGoto action_286+action_151 (89) = happyGoto action_5+action_151 (90) = happyGoto action_6+action_151 (91) = happyGoto action_7+action_151 (92) = happyGoto action_8+action_151 (122) = happyGoto action_9+action_151 (123) = happyGoto action_10+action_151 (125) = happyGoto action_11+action_151 (127) = happyGoto action_12+action_151 (137) = happyGoto action_13+action_151 (138) = happyGoto action_14+action_151 (139) = happyGoto action_15+action_151 (140) = happyGoto action_16+action_151 (142) = happyGoto action_17+action_151 (150) = happyGoto action_18+action_151 (151) = happyGoto action_19+action_151 _ = happyFail++action_152 _ = happyReduce_94++action_153 _ = happyReduce_100++action_154 (222) = happyShift action_285+action_154 (30) = happyGoto action_284+action_154 _ = happyReduce_59++action_155 (193) = happyShift action_283+action_155 _ = happyFail++action_156 (191) = happyShift action_240+action_156 (8) = happyGoto action_281+action_156 (9) = happyGoto action_282+action_156 _ = happyReduce_13++action_157 _ = happyReduce_96++action_158 _ = happyReduce_97++action_159 _ = happyReduce_99++action_160 (198) = happyShift action_279+action_160 (203) = happyShift action_280+action_160 _ = happyFail++action_161 _ = happyReduce_105++action_162 _ = happyReduce_98++action_163 (152) = happyGoto action_278+action_163 _ = happyReduce_347++action_164 (199) = happyShift action_107+action_164 (200) = happyShift action_108+action_164 (202) = happyShift action_83+action_164 (212) = happyShift action_110+action_164 (217) = happyShift action_111+action_164 (218) = happyShift action_112+action_164 (219) = happyShift action_87+action_164 (220) = happyShift action_88+action_164 (221) = happyShift action_89+action_164 (129) = happyGoto action_276+action_164 (132) = happyGoto action_255+action_164 (135) = happyGoto action_104+action_164 (143) = happyGoto action_72+action_164 (144) = happyGoto action_73+action_164 (145) = happyGoto action_105+action_164 (147) = happyGoto action_76+action_164 (149) = happyGoto action_106+action_164 (152) = happyGoto action_277+action_164 _ = happyReduce_347++action_165 _ = happyReduce_252++action_166 _ = happyReduce_256++action_167 (161) = happyShift action_20+action_167 (169) = happyShift action_23+action_167 (170) = happyShift action_24+action_167 (185) = happyShift action_27+action_167 (186) = happyShift action_56+action_167 (188) = happyShift action_29+action_167 (189) = happyShift action_57+action_167 (196) = happyShift action_58+action_167 (199) = happyReduce_257+action_167 (200) = happyReduce_257+action_167 (202) = happyReduce_257+action_167 (204) = happyReduce_257+action_167 (206) = happyReduce_257+action_167 (209) = happyShift action_202+action_167 (210) = happyShift action_59+action_167 (212) = happyReduce_257+action_167 (213) = happyShift action_34+action_167 (214) = happyShift action_35+action_167 (215) = happyShift action_36+action_167 (216) = happyShift action_37+action_167 (217) = happyReduce_257+action_167 (218) = happyReduce_257+action_167 (219) = happyReduce_257+action_167 (220) = happyReduce_257+action_167 (221) = happyReduce_257+action_167 (222) = happyShift action_39+action_167 (223) = happyShift action_40+action_167 (224) = happyShift action_41+action_167 (225) = happyShift action_42+action_167 (113) = happyGoto action_273+action_167 (114) = happyGoto action_275+action_167 (125) = happyGoto action_53+action_167 (127) = happyGoto action_54+action_167 (137) = happyGoto action_13+action_167 (138) = happyGoto action_14+action_167 (139) = happyGoto action_15+action_167 (140) = happyGoto action_16+action_167 (142) = happyGoto action_17+action_167 (150) = happyGoto action_55+action_167 (151) = happyGoto action_19+action_167 _ = happyReduce_106++action_168 (161) = happyShift action_20+action_168 (169) = happyShift action_23+action_168 (170) = happyShift action_24+action_168 (185) = happyShift action_27+action_168 (186) = happyShift action_56+action_168 (188) = happyShift action_29+action_168 (189) = happyShift action_57+action_168 (192) = happyShift action_201+action_168 (196) = happyShift action_58+action_168 (210) = happyShift action_59+action_168 (213) = happyShift action_34+action_168 (214) = happyShift action_35+action_168 (215) = happyShift action_36+action_168 (216) = happyShift action_37+action_168 (222) = happyShift action_39+action_168 (223) = happyShift action_40+action_168 (224) = happyShift action_41+action_168 (225) = happyShift action_42+action_168 (113) = happyGoto action_273+action_168 (114) = happyGoto action_274+action_168 (125) = happyGoto action_53+action_168 (127) = happyGoto action_54+action_168 (137) = happyGoto action_13+action_168 (138) = happyGoto action_14+action_168 (139) = happyGoto action_15+action_168 (140) = happyGoto action_16+action_168 (142) = happyGoto action_17+action_168 (150) = happyGoto action_55+action_168 (151) = happyGoto action_19+action_168 _ = happyReduce_259++action_169 _ = happyReduce_61++action_170 _ = happyReduce_62++action_171 _ = happyReduce_63++action_172 (161) = happyShift action_20+action_172 (169) = happyShift action_23+action_172 (170) = happyShift action_24+action_172 (185) = happyShift action_27+action_172 (186) = happyShift action_56+action_172 (188) = happyShift action_29+action_172 (189) = happyShift action_172+action_172 (190) = happyShift action_199+action_172 (196) = happyShift action_58+action_172 (200) = happyShift action_108+action_172 (202) = happyShift action_83+action_172 (210) = happyShift action_59+action_172 (212) = happyShift action_110+action_172 (213) = happyShift action_34+action_172 (214) = happyShift action_35+action_172 (215) = happyShift action_36+action_172 (216) = happyShift action_37+action_172 (217) = happyShift action_200+action_172 (218) = happyShift action_112+action_172 (219) = happyShift action_87+action_172 (220) = happyShift action_88+action_172 (221) = happyShift action_89+action_172 (222) = happyShift action_39+action_172 (223) = happyShift action_40+action_172 (224) = happyShift action_41+action_172 (225) = happyShift action_42+action_172 (83) = happyGoto action_270+action_172 (110) = happyGoto action_196+action_172 (111) = happyGoto action_271+action_172 (112) = happyGoto action_165+action_172 (113) = happyGoto action_166+action_172 (119) = happyGoto action_197+action_172 (125) = happyGoto action_272+action_172 (127) = happyGoto action_168+action_172 (135) = happyGoto action_198+action_172 (137) = happyGoto action_13+action_172 (138) = happyGoto action_14+action_172 (139) = happyGoto action_15+action_172 (140) = happyGoto action_16+action_172 (142) = happyGoto action_17+action_172 (143) = happyGoto action_72+action_172 (144) = happyGoto action_73+action_172 (145) = happyGoto action_74+action_172 (147) = happyGoto action_76+action_172 (149) = happyGoto action_106+action_172 (150) = happyGoto action_55+action_172 (151) = happyGoto action_19+action_172 _ = happyFail++action_173 (191) = happyShift action_173+action_173 (9) = happyGoto action_269+action_173 _ = happyReduce_13++action_174 (222) = happyShift action_39+action_174 (223) = happyShift action_40+action_174 (151) = happyGoto action_250+action_174 _ = happyFail++action_175 (1) = happyShift action_223+action_175 (195) = happyShift action_224+action_175 (154) = happyGoto action_268+action_175 _ = happyFail++action_176 (161) = happyShift action_20+action_176 (162) = happyShift action_21+action_176 (167) = happyShift action_22+action_176 (169) = happyShift action_23+action_176 (170) = happyShift action_24+action_176 (171) = happyShift action_25+action_176 (178) = happyShift action_26+action_176 (185) = happyShift action_27+action_176 (186) = happyShift action_28+action_176 (188) = happyShift action_29+action_176 (189) = happyShift action_30+action_176 (196) = happyShift action_31+action_176 (205) = happyShift action_32+action_176 (210) = happyShift action_33+action_176 (213) = happyShift action_34+action_176 (214) = happyShift action_35+action_176 (215) = happyShift action_36+action_176 (216) = happyShift action_37+action_176 (217) = happyShift action_38+action_176 (222) = happyShift action_39+action_176 (223) = happyShift action_40+action_176 (224) = happyShift action_41+action_176 (225) = happyShift action_42+action_176 (88) = happyGoto action_267+action_176 (89) = happyGoto action_5+action_176 (90) = happyGoto action_6+action_176 (91) = happyGoto action_7+action_176 (92) = happyGoto action_8+action_176 (122) = happyGoto action_9+action_176 (123) = happyGoto action_10+action_176 (125) = happyGoto action_11+action_176 (127) = happyGoto action_12+action_176 (137) = happyGoto action_13+action_176 (138) = happyGoto action_14+action_176 (139) = happyGoto action_15+action_176 (140) = happyGoto action_16+action_176 (142) = happyGoto action_17+action_176 (150) = happyGoto action_18+action_176 (151) = happyGoto action_19+action_176 _ = happyFail++action_177 (199) = happyShift action_266+action_177 _ = happyFail++action_178 _ = happyReduce_290++action_179 (190) = happyShift action_265+action_179 (199) = happyShift action_107+action_179 (200) = happyShift action_108+action_179 (202) = happyShift action_83+action_179 (212) = happyShift action_110+action_179 (217) = happyShift action_111+action_179 (218) = happyShift action_112+action_179 (219) = happyShift action_87+action_179 (220) = happyShift action_88+action_179 (221) = happyShift action_89+action_179 (129) = happyGoto action_101+action_179 (132) = happyGoto action_102+action_179 (134) = happyGoto action_103+action_179 (135) = happyGoto action_104+action_179 (143) = happyGoto action_72+action_179 (144) = happyGoto action_73+action_179 (145) = happyGoto action_105+action_179 (147) = happyGoto action_76+action_179 (149) = happyGoto action_106+action_179 _ = happyFail++action_180 _ = happyReduce_294++action_181 _ = happyReduce_204++action_182 _ = happyReduce_286++action_183 _ = happyReduce_211++action_184 (161) = happyShift action_20+action_184 (162) = happyShift action_21+action_184 (167) = happyShift action_22+action_184 (169) = happyShift action_23+action_184 (170) = happyShift action_24+action_184 (171) = happyShift action_25+action_184 (178) = happyShift action_26+action_184 (185) = happyShift action_27+action_184 (186) = happyShift action_28+action_184 (188) = happyShift action_29+action_184 (189) = happyShift action_30+action_184 (190) = happyShift action_264+action_184 (196) = happyShift action_31+action_184 (205) = happyShift action_32+action_184 (210) = happyShift action_33+action_184 (213) = happyShift action_34+action_184 (214) = happyShift action_35+action_184 (215) = happyShift action_36+action_184 (216) = happyShift action_37+action_184 (217) = happyShift action_38+action_184 (222) = happyShift action_39+action_184 (223) = happyShift action_40+action_184 (224) = happyShift action_41+action_184 (225) = happyShift action_42+action_184 (89) = happyGoto action_135+action_184 (90) = happyGoto action_6+action_184 (91) = happyGoto action_7+action_184 (92) = happyGoto action_8+action_184 (122) = happyGoto action_9+action_184 (123) = happyGoto action_10+action_184 (125) = happyGoto action_11+action_184 (127) = happyGoto action_12+action_184 (137) = happyGoto action_13+action_184 (138) = happyGoto action_14+action_184 (139) = happyGoto action_15+action_184 (140) = happyGoto action_16+action_184 (142) = happyGoto action_17+action_184 (150) = happyGoto action_18+action_184 (151) = happyGoto action_19+action_184 _ = happyFail++action_185 (161) = happyShift action_20+action_185 (162) = happyShift action_21+action_185 (167) = happyShift action_22+action_185 (169) = happyShift action_23+action_185 (170) = happyShift action_24+action_185 (171) = happyShift action_25+action_185 (178) = happyShift action_26+action_185 (185) = happyShift action_27+action_185 (186) = happyShift action_28+action_185 (188) = happyShift action_29+action_185 (189) = happyShift action_30+action_185 (196) = happyShift action_31+action_185 (205) = happyShift action_32+action_185 (210) = happyShift action_33+action_185 (213) = happyShift action_34+action_185 (214) = happyShift action_35+action_185 (215) = happyShift action_36+action_185 (216) = happyShift action_37+action_185 (217) = happyShift action_38+action_185 (222) = happyShift action_39+action_185 (223) = happyShift action_40+action_185 (224) = happyShift action_41+action_185 (225) = happyShift action_42+action_185 (88) = happyGoto action_64+action_185 (89) = happyGoto action_5+action_185 (90) = happyGoto action_6+action_185 (91) = happyGoto action_7+action_185 (92) = happyGoto action_8+action_185 (94) = happyGoto action_263+action_185 (122) = happyGoto action_9+action_185 (123) = happyGoto action_10+action_185 (125) = happyGoto action_11+action_185 (127) = happyGoto action_12+action_185 (137) = happyGoto action_13+action_185 (138) = happyGoto action_14+action_185 (139) = happyGoto action_15+action_185 (140) = happyGoto action_16+action_185 (142) = happyGoto action_17+action_185 (150) = happyGoto action_18+action_185 (151) = happyGoto action_19+action_185 _ = happyFail++action_186 (161) = happyShift action_20+action_186 (162) = happyShift action_21+action_186 (167) = happyShift action_22+action_186 (169) = happyShift action_23+action_186 (170) = happyShift action_24+action_186 (171) = happyShift action_25+action_186 (178) = happyShift action_26+action_186 (185) = happyShift action_27+action_186 (186) = happyShift action_28+action_186 (188) = happyShift action_29+action_186 (189) = happyShift action_30+action_186 (196) = happyShift action_31+action_186 (205) = happyShift action_32+action_186 (210) = happyShift action_33+action_186 (213) = happyShift action_34+action_186 (214) = happyShift action_35+action_186 (215) = happyShift action_36+action_186 (216) = happyShift action_37+action_186 (217) = happyShift action_38+action_186 (222) = happyShift action_39+action_186 (223) = happyShift action_40+action_186 (224) = happyShift action_41+action_186 (225) = happyShift action_42+action_186 (88) = happyGoto action_262+action_186 (89) = happyGoto action_5+action_186 (90) = happyGoto action_6+action_186 (91) = happyGoto action_7+action_186 (92) = happyGoto action_8+action_186 (122) = happyGoto action_9+action_186 (123) = happyGoto action_10+action_186 (125) = happyGoto action_11+action_186 (127) = happyGoto action_12+action_186 (137) = happyGoto action_13+action_186 (138) = happyGoto action_14+action_186 (139) = happyGoto action_15+action_186 (140) = happyGoto action_16+action_186 (142) = happyGoto action_17+action_186 (150) = happyGoto action_18+action_186 (151) = happyGoto action_19+action_186 _ = happyFail++action_187 _ = happyReduce_205++action_188 (161) = happyShift action_20+action_188 (162) = happyShift action_21+action_188 (167) = happyShift action_22+action_188 (169) = happyShift action_23+action_188 (170) = happyShift action_24+action_188 (171) = happyShift action_25+action_188 (178) = happyShift action_26+action_188 (185) = happyShift action_27+action_188 (186) = happyShift action_28+action_188 (188) = happyShift action_29+action_188 (189) = happyShift action_30+action_188 (196) = happyShift action_31+action_188 (205) = happyShift action_32+action_188 (210) = happyShift action_33+action_188 (213) = happyShift action_34+action_188 (214) = happyShift action_35+action_188 (215) = happyShift action_36+action_188 (216) = happyShift action_37+action_188 (217) = happyShift action_38+action_188 (222) = happyShift action_39+action_188 (223) = happyShift action_40+action_188 (224) = happyShift action_41+action_188 (225) = happyShift action_42+action_188 (88) = happyGoto action_261+action_188 (89) = happyGoto action_5+action_188 (90) = happyGoto action_6+action_188 (91) = happyGoto action_7+action_188 (92) = happyGoto action_8+action_188 (122) = happyGoto action_9+action_188 (123) = happyGoto action_10+action_188 (125) = happyGoto action_11+action_188 (127) = happyGoto action_12+action_188 (137) = happyGoto action_13+action_188 (138) = happyGoto action_14+action_188 (139) = happyGoto action_15+action_188 (140) = happyGoto action_16+action_188 (142) = happyGoto action_17+action_188 (150) = happyGoto action_18+action_188 (151) = happyGoto action_19+action_188 _ = happyFail++action_189 (161) = happyShift action_20+action_189 (162) = happyShift action_21+action_189 (167) = happyShift action_22+action_189 (169) = happyShift action_23+action_189 (170) = happyShift action_24+action_189 (171) = happyShift action_25+action_189 (178) = happyShift action_26+action_189 (185) = happyShift action_27+action_189 (186) = happyShift action_28+action_189 (188) = happyShift action_29+action_189 (189) = happyShift action_30+action_189 (196) = happyShift action_31+action_189 (205) = happyShift action_32+action_189 (210) = happyShift action_33+action_189 (213) = happyShift action_34+action_189 (214) = happyShift action_35+action_189 (215) = happyShift action_36+action_189 (216) = happyShift action_37+action_189 (217) = happyShift action_38+action_189 (222) = happyShift action_39+action_189 (223) = happyShift action_40+action_189 (224) = happyShift action_41+action_189 (225) = happyShift action_42+action_189 (88) = happyGoto action_260+action_189 (89) = happyGoto action_5+action_189 (90) = happyGoto action_6+action_189 (91) = happyGoto action_7+action_189 (92) = happyGoto action_8+action_189 (122) = happyGoto action_9+action_189 (123) = happyGoto action_10+action_189 (125) = happyGoto action_11+action_189 (127) = happyGoto action_12+action_189 (137) = happyGoto action_13+action_189 (138) = happyGoto action_14+action_189 (139) = happyGoto action_15+action_189 (140) = happyGoto action_16+action_189 (142) = happyGoto action_17+action_189 (150) = happyGoto action_18+action_189 (151) = happyGoto action_19+action_189 _ = happyReduce_217++action_190 (161) = happyShift action_20+action_190 (162) = happyShift action_21+action_190 (167) = happyShift action_22+action_190 (169) = happyShift action_23+action_190 (170) = happyShift action_24+action_190 (171) = happyShift action_25+action_190 (178) = happyShift action_148+action_190 (185) = happyShift action_27+action_190 (186) = happyShift action_28+action_190 (188) = happyShift action_29+action_190 (189) = happyShift action_30+action_190 (196) = happyShift action_31+action_190 (205) = happyShift action_32+action_190 (210) = happyShift action_33+action_190 (213) = happyShift action_34+action_190 (214) = happyShift action_35+action_190 (215) = happyShift action_36+action_190 (216) = happyShift action_37+action_190 (217) = happyShift action_38+action_190 (222) = happyShift action_39+action_190 (223) = happyShift action_40+action_190 (224) = happyShift action_41+action_190 (225) = happyShift action_42+action_190 (88) = happyGoto action_144+action_190 (89) = happyGoto action_145+action_190 (90) = happyGoto action_6+action_190 (91) = happyGoto action_7+action_190 (92) = happyGoto action_8+action_190 (97) = happyGoto action_258+action_190 (98) = happyGoto action_259+action_190 (122) = happyGoto action_9+action_190 (123) = happyGoto action_10+action_190 (125) = happyGoto action_11+action_190 (127) = happyGoto action_12+action_190 (137) = happyGoto action_13+action_190 (138) = happyGoto action_14+action_190 (139) = happyGoto action_15+action_190 (140) = happyGoto action_16+action_190 (142) = happyGoto action_17+action_190 (150) = happyGoto action_18+action_190 (151) = happyGoto action_19+action_190 _ = happyFail++action_191 _ = happyReduce_267++action_192 (198) = happyShift action_257+action_192 _ = happyReduce_281++action_193 (199) = happyShift action_256+action_193 (202) = happyShift action_83+action_193 (219) = happyShift action_87+action_193 (221) = happyShift action_89+action_193 (132) = happyGoto action_255+action_193 (135) = happyGoto action_104+action_193 (143) = happyGoto action_72+action_193 (144) = happyGoto action_73+action_193 _ = happyReduce_251++action_194 (197) = happyShift action_254+action_194 _ = happyFail++action_195 _ = happyReduce_279++action_196 (190) = happyShift action_252+action_196 (198) = happyShift action_253+action_196 _ = happyFail++action_197 (190) = happyShift action_251+action_197 _ = happyFail++action_198 (190) = happyShift action_180+action_198 _ = happyFail++action_199 _ = happyReduce_260++action_200 (222) = happyShift action_39+action_200 (223) = happyShift action_40+action_200 (151) = happyGoto action_250+action_200 _ = happyReduce_335++action_201 (161) = happyShift action_20+action_201 (169) = happyShift action_23+action_201 (170) = happyShift action_24+action_201 (185) = happyShift action_27+action_201 (188) = happyShift action_29+action_201 (189) = happyShift action_140+action_201 (213) = happyShift action_34+action_201 (214) = happyShift action_35+action_201 (116) = happyGoto action_246+action_201 (117) = happyGoto action_247+action_201 (118) = happyGoto action_248+action_201 (125) = happyGoto action_249+action_201 (137) = happyGoto action_13+action_201 (138) = happyGoto action_14+action_201 (139) = happyGoto action_15+action_201 _ = happyReduce_271++action_202 (161) = happyShift action_20+action_202 (169) = happyShift action_23+action_202 (170) = happyShift action_24+action_202 (185) = happyShift action_27+action_202 (186) = happyShift action_56+action_202 (188) = happyShift action_29+action_202 (189) = happyShift action_57+action_202 (196) = happyShift action_58+action_202 (210) = happyShift action_59+action_202 (213) = happyShift action_34+action_202 (214) = happyShift action_35+action_202 (215) = happyShift action_36+action_202 (216) = happyShift action_37+action_202 (222) = happyShift action_39+action_202 (223) = happyShift action_40+action_202 (224) = happyShift action_41+action_202 (225) = happyShift action_42+action_202 (113) = happyGoto action_245+action_202 (125) = happyGoto action_53+action_202 (127) = happyGoto action_54+action_202 (137) = happyGoto action_13+action_202 (138) = happyGoto action_14+action_202 (139) = happyGoto action_15+action_202 (140) = happyGoto action_16+action_202 (142) = happyGoto action_17+action_202 (150) = happyGoto action_55+action_202 (151) = happyGoto action_19+action_202 _ = happyFail++action_203 (161) = happyShift action_20+action_203 (162) = happyShift action_21+action_203 (167) = happyShift action_22+action_203 (169) = happyShift action_23+action_203 (170) = happyShift action_24+action_203 (171) = happyShift action_25+action_203 (178) = happyShift action_26+action_203 (185) = happyShift action_27+action_203 (186) = happyShift action_28+action_203 (188) = happyShift action_29+action_203 (189) = happyShift action_30+action_203 (196) = happyShift action_31+action_203 (205) = happyShift action_32+action_203 (210) = happyShift action_33+action_203 (213) = happyShift action_34+action_203 (214) = happyShift action_35+action_203 (215) = happyShift action_36+action_203 (216) = happyShift action_37+action_203 (217) = happyShift action_38+action_203 (222) = happyShift action_39+action_203 (223) = happyShift action_40+action_203 (224) = happyShift action_41+action_203 (225) = happyShift action_42+action_203 (88) = happyGoto action_244+action_203 (89) = happyGoto action_5+action_203 (90) = happyGoto action_6+action_203 (91) = happyGoto action_7+action_203 (92) = happyGoto action_8+action_203 (122) = happyGoto action_9+action_203 (123) = happyGoto action_10+action_203 (125) = happyGoto action_11+action_203 (127) = happyGoto action_12+action_203 (137) = happyGoto action_13+action_203 (138) = happyGoto action_14+action_203 (139) = happyGoto action_15+action_203 (140) = happyGoto action_16+action_203 (142) = happyGoto action_17+action_203 (150) = happyGoto action_18+action_203 (151) = happyGoto action_19+action_203 _ = happyFail++action_204 _ = happyReduce_270++action_205 (193) = happyShift action_243+action_205 _ = happyFail++action_206 (191) = happyShift action_240+action_206 (8) = happyGoto action_241+action_206 (9) = happyGoto action_242+action_206 _ = happyReduce_13++action_207 _ = happyReduce_33++action_208 (191) = happyShift action_240+action_208 (8) = happyGoto action_238+action_208 (9) = happyGoto action_239+action_208 _ = happyReduce_13++action_209 _ = happyReduce_57++action_210 _ = happyReduce_67++action_211 _ = happyReduce_70++action_212 (161) = happyShift action_20+action_212 (169) = happyShift action_129+action_212 (170) = happyShift action_24+action_212 (185) = happyShift action_27+action_212 (188) = happyShift action_29+action_212 (189) = happyShift action_130+action_212 (196) = happyShift action_131+action_212 (213) = happyShift action_34+action_212 (215) = happyShift action_36+action_212 (216) = happyShift action_132+action_212 (51) = happyGoto action_118+action_212 (52) = happyGoto action_119+action_212 (53) = happyGoto action_120+action_212 (56) = happyGoto action_121+action_212 (57) = happyGoto action_230+action_212 (58) = happyGoto action_123+action_212 (60) = happyGoto action_237+action_212 (138) = happyGoto action_124+action_212 (141) = happyGoto action_125+action_212 (142) = happyGoto action_126+action_212 (157) = happyGoto action_127+action_212 (160) = happyGoto action_128+action_212 _ = happyFail++action_213 (161) = happyShift action_20+action_213 (169) = happyShift action_129+action_213 (170) = happyShift action_24+action_213 (185) = happyShift action_27+action_213 (188) = happyShift action_29+action_213 (189) = happyShift action_130+action_213 (196) = happyShift action_131+action_213 (213) = happyShift action_34+action_213 (215) = happyShift action_36+action_213 (216) = happyShift action_132+action_213 (51) = happyGoto action_118+action_213 (52) = happyGoto action_119+action_213 (53) = happyGoto action_120+action_213 (56) = happyGoto action_121+action_213 (57) = happyGoto action_230+action_213 (58) = happyGoto action_123+action_213 (60) = happyGoto action_236+action_213 (138) = happyGoto action_124+action_213 (141) = happyGoto action_125+action_213 (142) = happyGoto action_126+action_213 (157) = happyGoto action_127+action_213 (160) = happyGoto action_128+action_213 _ = happyFail++action_214 (189) = happyShift action_235+action_214 _ = happyFail++action_215 (185) = happyShift action_234+action_215 (19) = happyGoto action_233+action_215 _ = happyReduce_36++action_216 (161) = happyShift action_20+action_216 (169) = happyShift action_129+action_216 (170) = happyShift action_24+action_216 (185) = happyShift action_27+action_216 (188) = happyShift action_29+action_216 (189) = happyShift action_130+action_216 (196) = happyShift action_131+action_216 (213) = happyShift action_34+action_216 (215) = happyShift action_36+action_216 (216) = happyShift action_132+action_216 (51) = happyGoto action_118+action_216 (52) = happyGoto action_119+action_216 (53) = happyGoto action_120+action_216 (56) = happyGoto action_121+action_216 (57) = happyGoto action_232+action_216 (58) = happyGoto action_123+action_216 (138) = happyGoto action_124+action_216 (141) = happyGoto action_125+action_216 (142) = happyGoto action_126+action_216 (157) = happyGoto action_127+action_216 (160) = happyGoto action_128+action_216 _ = happyFail++action_217 (161) = happyShift action_20+action_217 (169) = happyShift action_129+action_217 (170) = happyShift action_24+action_217 (185) = happyShift action_27+action_217 (188) = happyShift action_29+action_217 (189) = happyShift action_130+action_217 (196) = happyShift action_131+action_217 (213) = happyShift action_34+action_217 (215) = happyShift action_36+action_217 (216) = happyShift action_132+action_217 (51) = happyGoto action_118+action_217 (52) = happyGoto action_119+action_217 (53) = happyGoto action_120+action_217 (56) = happyGoto action_121+action_217 (57) = happyGoto action_230+action_217 (58) = happyGoto action_123+action_217 (60) = happyGoto action_231+action_217 (138) = happyGoto action_124+action_217 (141) = happyGoto action_125+action_217 (142) = happyGoto action_126+action_217 (157) = happyGoto action_127+action_217 (160) = happyGoto action_128+action_217 _ = happyFail++action_218 (215) = happyShift action_36+action_218 (59) = happyGoto action_228+action_218 (142) = happyGoto action_126+action_218 (157) = happyGoto action_229+action_218 _ = happyFail++action_219 (161) = happyShift action_20+action_219 (169) = happyShift action_23+action_219 (170) = happyShift action_24+action_219 (185) = happyShift action_27+action_219 (188) = happyShift action_29+action_219 (189) = happyShift action_140+action_219 (213) = happyShift action_34+action_219 (214) = happyShift action_35+action_219 (49) = happyGoto action_226+action_219 (50) = happyGoto action_161+action_219 (125) = happyGoto action_227+action_219 (137) = happyGoto action_13+action_219 (138) = happyGoto action_14+action_219 (139) = happyGoto action_15+action_219 _ = happyFail++action_220 (172) = happyShift action_225+action_220 _ = happyReduce_318++action_221 (1) = happyShift action_223+action_221 (195) = happyShift action_224+action_221 (154) = happyGoto action_222+action_221 _ = happyFail++action_222 _ = happyReduce_5++action_223 _ = happyReduce_350++action_224 _ = happyReduce_349++action_225 (161) = happyShift action_20+action_225 (169) = happyShift action_23+action_225 (170) = happyShift action_24+action_225 (185) = happyShift action_27+action_225 (188) = happyShift action_29+action_225 (189) = happyShift action_355+action_225 (213) = happyShift action_34+action_225 (36) = happyGoto action_391+action_225 (124) = happyGoto action_392+action_225 (138) = happyGoto action_14+action_225 (139) = happyGoto action_393+action_225 _ = happyFail++action_226 (198) = happyShift action_279+action_226 (225) = happyShift action_390+action_226 (34) = happyGoto action_388+action_226 (38) = happyGoto action_389+action_226 _ = happyReduce_68++action_227 _ = happyReduce_106++action_228 (204) = happyShift action_387+action_228 _ = happyFail++action_229 (161) = happyShift action_20+action_229 (170) = happyShift action_24+action_229 (185) = happyShift action_27+action_229 (188) = happyShift action_29+action_229 (213) = happyShift action_34+action_229 (42) = happyGoto action_386+action_229 (138) = happyGoto action_124+action_229 (160) = happyGoto action_311+action_229 _ = happyReduce_91++action_230 _ = happyReduce_129++action_231 (204) = happyShift action_385+action_231 _ = happyFail++action_232 (184) = happyShift action_384+action_232 (78) = happyGoto action_383+action_232 _ = happyReduce_169++action_233 (215) = happyShift action_36+action_233 (216) = happyShift action_37+action_233 (140) = happyGoto action_113+action_233 (142) = happyGoto action_17+action_233 (155) = happyGoto action_382+action_233 _ = happyFail++action_234 _ = happyReduce_35++action_235 (161) = happyShift action_20+action_235 (169) = happyShift action_129+action_235 (170) = happyShift action_24+action_235 (185) = happyShift action_27+action_235 (188) = happyShift action_29+action_235 (189) = happyShift action_130+action_235 (196) = happyShift action_131+action_235 (213) = happyShift action_34+action_235 (215) = happyShift action_36+action_235 (216) = happyShift action_132+action_235 (51) = happyGoto action_305+action_235 (52) = happyGoto action_303+action_235 (53) = happyGoto action_120+action_235 (54) = happyGoto action_380+action_235 (55) = happyGoto action_381+action_235 (56) = happyGoto action_121+action_235 (138) = happyGoto action_124+action_235 (141) = happyGoto action_125+action_235 (142) = happyGoto action_126+action_235 (157) = happyGoto action_127+action_235 (160) = happyGoto action_128+action_235 _ = happyReduce_116++action_236 (204) = happyShift action_379+action_236 _ = happyReduce_77++action_237 (206) = happyShift action_378+action_237 (39) = happyGoto action_377+action_237 _ = happyReduce_86++action_238 (161) = happyShift action_20+action_238 (163) = happyShift action_212+action_238 (164) = happyShift action_213+action_238 (165) = happyShift action_214+action_238 (169) = happyShift action_23+action_238 (170) = happyShift action_24+action_238 (174) = happyShift action_169+action_238 (175) = happyShift action_170+action_238 (176) = happyShift action_171+action_238 (177) = happyShift action_216+action_238 (180) = happyShift action_217+action_238 (183) = happyShift action_218+action_238 (185) = happyShift action_27+action_238 (186) = happyShift action_56+action_238 (187) = happyShift action_219+action_238 (188) = happyShift action_220+action_238 (189) = happyShift action_172+action_238 (196) = happyShift action_58+action_238 (210) = happyShift action_59+action_238 (213) = happyShift action_34+action_238 (214) = happyShift action_35+action_238 (215) = happyShift action_36+action_238 (216) = happyShift action_37+action_238 (217) = happyShift action_174+action_238 (222) = happyShift action_39+action_238 (223) = happyShift action_40+action_238 (224) = happyShift action_41+action_238 (225) = happyShift action_42+action_238 (29) = happyGoto action_153+action_238 (31) = happyGoto action_154+action_238 (33) = happyGoto action_376+action_238 (35) = happyGoto action_210+action_238 (45) = happyGoto action_211+action_238 (46) = happyGoto action_158+action_238 (48) = happyGoto action_159+action_238 (49) = happyGoto action_160+action_238 (50) = happyGoto action_161+action_238 (82) = happyGoto action_162+action_238 (83) = happyGoto action_163+action_238 (111) = happyGoto action_164+action_238 (112) = happyGoto action_165+action_238 (113) = happyGoto action_166+action_238 (125) = happyGoto action_167+action_238 (127) = happyGoto action_168+action_238 (137) = happyGoto action_13+action_238 (138) = happyGoto action_14+action_238 (139) = happyGoto action_15+action_238 (140) = happyGoto action_16+action_238 (142) = happyGoto action_17+action_238 (150) = happyGoto action_55+action_238 (151) = happyGoto action_19+action_238 _ = happyFail++action_239 _ = happyReduce_7++action_240 (161) = happyReduce_11+action_240 (163) = happyReduce_11+action_240 (164) = happyReduce_11+action_240 (165) = happyReduce_11+action_240 (169) = happyReduce_11+action_240 (170) = happyReduce_11+action_240 (172) = happyReduce_11+action_240 (174) = happyReduce_11+action_240 (175) = happyReduce_11+action_240 (176) = happyReduce_11+action_240 (177) = happyReduce_11+action_240 (180) = happyReduce_11+action_240 (183) = happyReduce_11+action_240 (185) = happyReduce_11+action_240 (186) = happyReduce_11+action_240 (187) = happyReduce_11+action_240 (188) = happyReduce_11+action_240 (189) = happyReduce_11+action_240 (191) = happyShift action_240+action_240 (196) = happyReduce_11+action_240 (210) = happyReduce_11+action_240 (213) = happyReduce_11+action_240 (214) = happyReduce_11+action_240 (215) = happyReduce_11+action_240 (216) = happyReduce_11+action_240 (217) = happyReduce_11+action_240 (222) = happyReduce_11+action_240 (223) = happyReduce_11+action_240 (224) = happyReduce_11+action_240 (225) = happyReduce_11+action_240 (8) = happyGoto action_288+action_240 (9) = happyGoto action_269+action_240 _ = happyReduce_13++action_241 (161) = happyShift action_20+action_241 (163) = happyShift action_212+action_241 (164) = happyShift action_213+action_241 (165) = happyShift action_214+action_241 (169) = happyShift action_23+action_241 (170) = happyShift action_24+action_241 (172) = happyShift action_215+action_241 (174) = happyShift action_169+action_241 (175) = happyShift action_170+action_241 (176) = happyShift action_171+action_241 (177) = happyShift action_216+action_241 (180) = happyShift action_217+action_241 (183) = happyShift action_218+action_241 (185) = happyShift action_27+action_241 (186) = happyShift action_56+action_241 (187) = happyShift action_219+action_241 (188) = happyShift action_220+action_241 (189) = happyShift action_172+action_241 (196) = happyShift action_58+action_241 (210) = happyShift action_59+action_241 (213) = happyShift action_34+action_241 (214) = happyShift action_35+action_241 (215) = happyShift action_36+action_241 (216) = happyShift action_37+action_241 (217) = happyShift action_174+action_241 (222) = happyShift action_39+action_241 (223) = happyShift action_40+action_241 (224) = happyShift action_41+action_241 (225) = happyShift action_42+action_241 (18) = happyGoto action_374+action_241 (28) = happyGoto action_375+action_241 (29) = happyGoto action_153+action_241 (31) = happyGoto action_154+action_241 (33) = happyGoto action_209+action_241 (35) = happyGoto action_210+action_241 (45) = happyGoto action_211+action_241 (46) = happyGoto action_158+action_241 (48) = happyGoto action_159+action_241 (49) = happyGoto action_160+action_241 (50) = happyGoto action_161+action_241 (82) = happyGoto action_162+action_241 (83) = happyGoto action_163+action_241 (111) = happyGoto action_164+action_241 (112) = happyGoto action_165+action_241 (113) = happyGoto action_166+action_241 (125) = happyGoto action_167+action_241 (127) = happyGoto action_168+action_241 (137) = happyGoto action_13+action_241 (138) = happyGoto action_14+action_241 (139) = happyGoto action_15+action_241 (140) = happyGoto action_16+action_241 (142) = happyGoto action_17+action_241 (150) = happyGoto action_55+action_241 (151) = happyGoto action_19+action_241 _ = happyFail++action_242 _ = happyReduce_8++action_243 _ = happyReduce_4++action_244 _ = happyReduce_190++action_245 _ = happyReduce_258++action_246 (193) = happyShift action_373+action_246 _ = happyFail++action_247 _ = happyReduce_272++action_248 (198) = happyShift action_372+action_248 _ = happyReduce_274++action_249 (204) = happyShift action_371+action_249 _ = happyFail++action_250 _ = happyReduce_255++action_251 _ = happyReduce_265++action_252 _ = happyReduce_264++action_253 (161) = happyShift action_20+action_253 (169) = happyShift action_23+action_253 (170) = happyShift action_24+action_253 (185) = happyShift action_27+action_253 (186) = happyShift action_56+action_253 (188) = happyShift action_29+action_253 (189) = happyShift action_57+action_253 (196) = happyShift action_58+action_253 (210) = happyShift action_59+action_253 (213) = happyShift action_34+action_253 (214) = happyShift action_35+action_253 (215) = happyShift action_36+action_253 (216) = happyShift action_37+action_253 (217) = happyShift action_174+action_253 (222) = happyShift action_39+action_253 (223) = happyShift action_40+action_253 (224) = happyShift action_41+action_253 (225) = happyShift action_42+action_253 (110) = happyGoto action_369+action_253 (111) = happyGoto action_193+action_253 (112) = happyGoto action_165+action_253 (113) = happyGoto action_166+action_253 (119) = happyGoto action_370+action_253 (125) = happyGoto action_53+action_253 (127) = happyGoto action_168+action_253 (137) = happyGoto action_13+action_253 (138) = happyGoto action_14+action_253 (139) = happyGoto action_15+action_253 (140) = happyGoto action_16+action_253 (142) = happyGoto action_17+action_253 (150) = happyGoto action_55+action_253 (151) = happyGoto action_19+action_253 _ = happyFail++action_254 _ = happyReduce_266++action_255 (161) = happyShift action_20+action_255 (169) = happyShift action_23+action_255 (170) = happyShift action_24+action_255 (185) = happyShift action_27+action_255 (186) = happyShift action_56+action_255 (188) = happyShift action_29+action_255 (189) = happyShift action_57+action_255 (196) = happyShift action_58+action_255 (210) = happyShift action_59+action_255 (213) = happyShift action_34+action_255 (214) = happyShift action_35+action_255 (215) = happyShift action_36+action_255 (216) = happyShift action_37+action_255 (217) = happyShift action_174+action_255 (222) = happyShift action_39+action_255 (223) = happyShift action_40+action_255 (224) = happyShift action_41+action_255 (225) = happyShift action_42+action_255 (112) = happyGoto action_368+action_255 (113) = happyGoto action_166+action_255 (125) = happyGoto action_53+action_255 (127) = happyGoto action_168+action_255 (137) = happyGoto action_13+action_255 (138) = happyGoto action_14+action_255 (139) = happyGoto action_15+action_255 (140) = happyGoto action_16+action_255 (142) = happyGoto action_17+action_255 (150) = happyGoto action_55+action_255 (151) = happyGoto action_19+action_255 _ = happyFail++action_256 (215) = happyShift action_36+action_256 (216) = happyShift action_37+action_256 (140) = happyGoto action_134+action_256 (142) = happyGoto action_17+action_256 _ = happyFail++action_257 (161) = happyShift action_20+action_257 (169) = happyShift action_23+action_257 (170) = happyShift action_24+action_257 (185) = happyShift action_27+action_257 (186) = happyShift action_56+action_257 (188) = happyShift action_29+action_257 (189) = happyShift action_57+action_257 (196) = happyShift action_58+action_257 (210) = happyShift action_59+action_257 (213) = happyShift action_34+action_257 (214) = happyShift action_35+action_257 (215) = happyShift action_36+action_257 (216) = happyShift action_37+action_257 (217) = happyShift action_174+action_257 (222) = happyShift action_39+action_257 (223) = happyShift action_40+action_257 (224) = happyShift action_41+action_257 (225) = happyShift action_42+action_257 (110) = happyGoto action_192+action_257 (111) = happyGoto action_193+action_257 (112) = happyGoto action_165+action_257 (113) = happyGoto action_166+action_257 (120) = happyGoto action_367+action_257 (121) = happyGoto action_195+action_257 (125) = happyGoto action_53+action_257 (127) = happyGoto action_168+action_257 (137) = happyGoto action_13+action_257 (138) = happyGoto action_14+action_257 (139) = happyGoto action_15+action_257 (140) = happyGoto action_16+action_257 (142) = happyGoto action_17+action_257 (150) = happyGoto action_55+action_257 (151) = happyGoto action_19+action_257 _ = happyReduce_278++action_258 (198) = happyShift action_366+action_258 _ = happyReduce_221++action_259 _ = happyReduce_225++action_260 _ = happyReduce_219++action_261 (201) = happyShift action_365+action_261 _ = happyReduce_223++action_262 _ = happyReduce_222++action_263 _ = happyReduce_213++action_264 _ = happyReduce_206++action_265 _ = happyReduce_207++action_266 _ = happyReduce_300++action_267 _ = happyReduce_191++action_268 _ = happyReduce_102++action_269 _ = happyReduce_12++action_270 (190) = happyShift action_364+action_270 _ = happyFail++action_271 (199) = happyShift action_107+action_271 (200) = happyShift action_108+action_271 (202) = happyShift action_83+action_271 (212) = happyShift action_110+action_271 (217) = happyShift action_111+action_271 (218) = happyShift action_112+action_271 (219) = happyShift action_87+action_271 (220) = happyShift action_88+action_271 (221) = happyShift action_89+action_271 (129) = happyGoto action_276+action_271 (132) = happyGoto action_255+action_271 (135) = happyGoto action_104+action_271 (143) = happyGoto action_72+action_271 (144) = happyGoto action_73+action_271 (145) = happyGoto action_105+action_271 (147) = happyGoto action_76+action_271 (149) = happyGoto action_106+action_271 _ = happyReduce_251++action_272 (161) = happyShift action_20+action_272 (169) = happyShift action_23+action_272 (170) = happyShift action_24+action_272 (185) = happyShift action_27+action_272 (186) = happyShift action_56+action_272 (188) = happyShift action_29+action_272 (189) = happyShift action_57+action_272 (196) = happyShift action_58+action_272 (209) = happyShift action_202+action_272 (210) = happyShift action_59+action_272 (213) = happyShift action_34+action_272 (214) = happyShift action_35+action_272 (215) = happyShift action_36+action_272 (216) = happyShift action_37+action_272 (222) = happyShift action_39+action_272 (223) = happyShift action_40+action_272 (224) = happyShift action_41+action_272 (225) = happyShift action_42+action_272 (113) = happyGoto action_273+action_272 (114) = happyGoto action_275+action_272 (125) = happyGoto action_53+action_272 (127) = happyGoto action_54+action_272 (137) = happyGoto action_13+action_272 (138) = happyGoto action_14+action_272 (139) = happyGoto action_15+action_272 (140) = happyGoto action_16+action_272 (142) = happyGoto action_17+action_272 (150) = happyGoto action_55+action_272 (151) = happyGoto action_19+action_272 _ = happyReduce_257++action_273 (161) = happyShift action_20+action_273 (169) = happyShift action_23+action_273 (170) = happyShift action_24+action_273 (185) = happyShift action_27+action_273 (186) = happyShift action_56+action_273 (188) = happyShift action_29+action_273 (189) = happyShift action_57+action_273 (196) = happyShift action_58+action_273 (210) = happyShift action_59+action_273 (213) = happyShift action_34+action_273 (214) = happyShift action_35+action_273 (215) = happyShift action_36+action_273 (216) = happyShift action_37+action_273 (222) = happyShift action_39+action_273 (223) = happyShift action_40+action_273 (224) = happyShift action_41+action_273 (225) = happyShift action_42+action_273 (113) = happyGoto action_51+action_273 (115) = happyGoto action_363+action_273 (125) = happyGoto action_53+action_273 (127) = happyGoto action_54+action_273 (137) = happyGoto action_13+action_273 (138) = happyGoto action_14+action_273 (139) = happyGoto action_15+action_273 (140) = happyGoto action_16+action_273 (142) = happyGoto action_17+action_273 (150) = happyGoto action_55+action_273 (151) = happyGoto action_19+action_273 _ = happyReduce_269++action_274 _ = happyReduce_254++action_275 _ = happyReduce_177++action_276 (161) = happyShift action_20+action_276 (169) = happyShift action_23+action_276 (170) = happyShift action_24+action_276 (185) = happyShift action_27+action_276 (186) = happyShift action_56+action_276 (188) = happyShift action_29+action_276 (189) = happyShift action_57+action_276 (196) = happyShift action_58+action_276 (210) = happyShift action_59+action_276 (213) = happyShift action_34+action_276 (214) = happyShift action_35+action_276 (215) = happyShift action_36+action_276 (216) = happyShift action_37+action_276 (217) = happyShift action_174+action_276 (222) = happyShift action_39+action_276 (223) = happyShift action_40+action_276 (224) = happyShift action_41+action_276 (225) = happyShift action_42+action_276 (111) = happyGoto action_362+action_276 (112) = happyGoto action_165+action_276 (113) = happyGoto action_166+action_276 (125) = happyGoto action_53+action_276 (127) = happyGoto action_168+action_276 (137) = happyGoto action_13+action_276 (138) = happyGoto action_14+action_276 (139) = happyGoto action_15+action_276 (140) = happyGoto action_16+action_276 (142) = happyGoto action_17+action_276 (150) = happyGoto action_55+action_276 (151) = happyGoto action_19+action_276 _ = happyFail++action_277 (204) = happyShift action_359+action_277 (206) = happyShift action_360+action_277 (85) = happyGoto action_361+action_277 (86) = happyGoto action_357+action_277 (87) = happyGoto action_358+action_277 _ = happyFail++action_278 (204) = happyShift action_359+action_278 (206) = happyShift action_360+action_278 (85) = happyGoto action_356+action_278 (86) = happyGoto action_357+action_278 (87) = happyGoto action_358+action_278 _ = happyFail++action_279 (161) = happyShift action_20+action_279 (169) = happyShift action_23+action_279 (170) = happyShift action_24+action_279 (185) = happyShift action_27+action_279 (188) = happyShift action_29+action_279 (189) = happyShift action_355+action_279 (213) = happyShift action_34+action_279 (124) = happyGoto action_353+action_279 (138) = happyGoto action_14+action_279 (139) = happyGoto action_354+action_279 _ = happyFail++action_280 (161) = happyShift action_20+action_280 (169) = happyShift action_129+action_280 (170) = happyShift action_24+action_280 (185) = happyShift action_27+action_280 (188) = happyShift action_29+action_280 (189) = happyShift action_130+action_280 (196) = happyShift action_131+action_280 (213) = happyShift action_34+action_280 (215) = happyShift action_36+action_280 (216) = happyShift action_132+action_280 (51) = happyGoto action_118+action_280 (52) = happyGoto action_119+action_280 (53) = happyGoto action_120+action_280 (56) = happyGoto action_121+action_280 (57) = happyGoto action_352+action_280 (58) = happyGoto action_123+action_280 (138) = happyGoto action_124+action_280 (141) = happyGoto action_125+action_280 (142) = happyGoto action_126+action_280 (157) = happyGoto action_127+action_280 (160) = happyGoto action_128+action_280 _ = happyFail++action_281 (161) = happyShift action_20+action_281 (169) = happyShift action_23+action_281 (170) = happyShift action_24+action_281 (174) = happyShift action_169+action_281 (175) = happyShift action_170+action_281 (176) = happyShift action_171+action_281 (185) = happyShift action_27+action_281 (186) = happyShift action_56+action_281 (188) = happyShift action_29+action_281 (189) = happyShift action_172+action_281 (196) = happyShift action_58+action_281 (210) = happyShift action_59+action_281 (213) = happyShift action_34+action_281 (214) = happyShift action_35+action_281 (215) = happyShift action_36+action_281 (216) = happyShift action_37+action_281 (217) = happyShift action_174+action_281 (222) = happyShift action_39+action_281 (223) = happyShift action_40+action_281 (224) = happyShift action_41+action_281 (225) = happyShift action_42+action_281 (29) = happyGoto action_153+action_281 (31) = happyGoto action_154+action_281 (45) = happyGoto action_351+action_281 (46) = happyGoto action_158+action_281 (48) = happyGoto action_159+action_281 (49) = happyGoto action_160+action_281 (50) = happyGoto action_161+action_281 (82) = happyGoto action_162+action_281 (83) = happyGoto action_163+action_281 (111) = happyGoto action_164+action_281 (112) = happyGoto action_165+action_281 (113) = happyGoto action_166+action_281 (125) = happyGoto action_167+action_281 (127) = happyGoto action_168+action_281 (137) = happyGoto action_13+action_281 (138) = happyGoto action_14+action_281 (139) = happyGoto action_15+action_281 (140) = happyGoto action_16+action_281 (142) = happyGoto action_17+action_281 (150) = happyGoto action_55+action_281 (151) = happyGoto action_19+action_281 _ = happyFail++action_282 _ = happyReduce_93++action_283 _ = happyReduce_101++action_284 (199) = happyShift action_350+action_284 (200) = happyShift action_108+action_284 (202) = happyShift action_83+action_284 (212) = happyShift action_110+action_284 (217) = happyShift action_111+action_284 (218) = happyShift action_112+action_284 (219) = happyShift action_87+action_284 (32) = happyGoto action_344+action_284 (128) = happyGoto action_345+action_284 (131) = happyGoto action_346+action_284 (133) = happyGoto action_347+action_284 (144) = happyGoto action_348+action_284 (147) = happyGoto action_349+action_284 _ = happyFail++action_285 _ = happyReduce_60++action_286 (168) = happyShift action_343+action_286 _ = happyFail++action_287 _ = happyReduce_241++action_288 _ = happyReduce_10++action_289 (173) = happyShift action_176+action_289 _ = happyReduce_228++action_290 _ = happyReduce_240++action_291 (161) = happyShift action_20+action_291 (162) = happyShift action_21+action_291 (167) = happyShift action_22+action_291 (169) = happyShift action_23+action_291 (170) = happyShift action_24+action_291 (171) = happyShift action_25+action_291 (178) = happyShift action_148+action_291 (185) = happyShift action_27+action_291 (186) = happyShift action_28+action_291 (188) = happyShift action_29+action_291 (189) = happyShift action_30+action_291 (191) = happyShift action_149+action_291 (196) = happyShift action_31+action_291 (205) = happyShift action_32+action_291 (210) = happyShift action_33+action_291 (213) = happyShift action_34+action_291 (214) = happyShift action_35+action_291 (215) = happyShift action_36+action_291 (216) = happyShift action_37+action_291 (217) = happyShift action_38+action_291 (222) = happyShift action_39+action_291 (223) = happyShift action_40+action_291 (224) = happyShift action_41+action_291 (225) = happyShift action_42+action_291 (8) = happyGoto action_143+action_291 (88) = happyGoto action_144+action_291 (89) = happyGoto action_145+action_291 (90) = happyGoto action_6+action_291 (91) = happyGoto action_7+action_291 (92) = happyGoto action_8+action_291 (98) = happyGoto action_146+action_291 (106) = happyGoto action_342+action_291 (122) = happyGoto action_9+action_291 (123) = happyGoto action_10+action_291 (125) = happyGoto action_11+action_291 (127) = happyGoto action_12+action_291 (137) = happyGoto action_13+action_291 (138) = happyGoto action_14+action_291 (139) = happyGoto action_15+action_291 (140) = happyGoto action_16+action_291 (142) = happyGoto action_17+action_291 (150) = happyGoto action_18+action_291 (151) = happyGoto action_19+action_291 _ = happyReduce_245++action_292 (161) = happyShift action_20+action_292 (162) = happyShift action_21+action_292 (167) = happyShift action_22+action_292 (169) = happyShift action_23+action_292 (170) = happyShift action_24+action_292 (171) = happyShift action_25+action_292 (178) = happyShift action_26+action_292 (185) = happyShift action_27+action_292 (186) = happyShift action_28+action_292 (188) = happyShift action_29+action_292 (189) = happyShift action_30+action_292 (196) = happyShift action_31+action_292 (205) = happyShift action_32+action_292 (210) = happyShift action_33+action_292 (213) = happyShift action_34+action_292 (214) = happyShift action_35+action_292 (215) = happyShift action_36+action_292 (216) = happyShift action_37+action_292 (217) = happyShift action_38+action_292 (222) = happyShift action_39+action_292 (223) = happyShift action_40+action_292 (224) = happyShift action_41+action_292 (225) = happyShift action_42+action_292 (88) = happyGoto action_341+action_292 (89) = happyGoto action_5+action_292 (90) = happyGoto action_6+action_292 (91) = happyGoto action_7+action_292 (92) = happyGoto action_8+action_292 (122) = happyGoto action_9+action_292 (123) = happyGoto action_10+action_292 (125) = happyGoto action_11+action_292 (127) = happyGoto action_12+action_292 (137) = happyGoto action_13+action_292 (138) = happyGoto action_14+action_292 (139) = happyGoto action_15+action_292 (140) = happyGoto action_16+action_292 (142) = happyGoto action_17+action_292 (150) = happyGoto action_18+action_292 (151) = happyGoto action_19+action_292 _ = happyFail++action_293 _ = happyReduce_243++action_294 _ = happyReduce_193++action_295 (161) = happyShift action_20+action_295 (169) = happyShift action_23+action_295 (170) = happyShift action_24+action_295 (185) = happyShift action_27+action_295 (186) = happyShift action_56+action_295 (188) = happyShift action_29+action_295 (189) = happyShift action_57+action_295 (196) = happyShift action_58+action_295 (210) = happyShift action_59+action_295 (213) = happyShift action_34+action_295 (214) = happyShift action_35+action_295 (215) = happyShift action_36+action_295 (216) = happyShift action_37+action_295 (217) = happyShift action_174+action_295 (222) = happyShift action_39+action_295 (223) = happyShift action_40+action_295 (224) = happyShift action_41+action_295 (225) = happyShift action_42+action_295 (100) = happyGoto action_340+action_295 (101) = happyGoto action_338+action_295 (111) = happyGoto action_339+action_295 (112) = happyGoto action_165+action_295 (113) = happyGoto action_166+action_295 (125) = happyGoto action_53+action_295 (127) = happyGoto action_168+action_295 (137) = happyGoto action_13+action_295 (138) = happyGoto action_14+action_295 (139) = happyGoto action_15+action_295 (140) = happyGoto action_16+action_295 (142) = happyGoto action_17+action_295 (150) = happyGoto action_55+action_295 (151) = happyGoto action_19+action_295 _ = happyFail++action_296 (161) = happyShift action_20+action_296 (169) = happyShift action_23+action_296 (170) = happyShift action_24+action_296 (185) = happyShift action_27+action_296 (186) = happyShift action_56+action_296 (188) = happyShift action_29+action_296 (189) = happyShift action_57+action_296 (196) = happyShift action_58+action_296 (210) = happyShift action_59+action_296 (213) = happyShift action_34+action_296 (214) = happyShift action_35+action_296 (215) = happyShift action_36+action_296 (216) = happyShift action_37+action_296 (217) = happyShift action_174+action_296 (222) = happyShift action_39+action_296 (223) = happyShift action_40+action_296 (224) = happyShift action_41+action_296 (225) = happyShift action_42+action_296 (100) = happyGoto action_337+action_296 (101) = happyGoto action_338+action_296 (111) = happyGoto action_339+action_296 (112) = happyGoto action_165+action_296 (113) = happyGoto action_166+action_296 (125) = happyGoto action_53+action_296 (127) = happyGoto action_168+action_296 (137) = happyGoto action_13+action_296 (138) = happyGoto action_14+action_296 (139) = happyGoto action_15+action_296 (140) = happyGoto action_16+action_296 (142) = happyGoto action_17+action_296 (150) = happyGoto action_55+action_296 (151) = happyGoto action_19+action_296 _ = happyFail++action_297 (161) = happyShift action_20+action_297 (162) = happyShift action_21+action_297 (167) = happyShift action_22+action_297 (169) = happyShift action_23+action_297 (170) = happyShift action_24+action_297 (171) = happyShift action_25+action_297 (178) = happyShift action_26+action_297 (185) = happyShift action_27+action_297 (186) = happyShift action_28+action_297 (188) = happyShift action_29+action_297 (189) = happyShift action_30+action_297 (196) = happyShift action_31+action_297 (205) = happyShift action_32+action_297 (210) = happyShift action_33+action_297 (213) = happyShift action_34+action_297 (214) = happyShift action_35+action_297 (215) = happyShift action_36+action_297 (216) = happyShift action_37+action_297 (217) = happyShift action_38+action_297 (222) = happyShift action_39+action_297 (223) = happyShift action_40+action_297 (224) = happyShift action_41+action_297 (225) = happyShift action_42+action_297 (88) = happyGoto action_336+action_297 (89) = happyGoto action_5+action_297 (90) = happyGoto action_6+action_297 (91) = happyGoto action_7+action_297 (92) = happyGoto action_8+action_297 (122) = happyGoto action_9+action_297 (123) = happyGoto action_10+action_297 (125) = happyGoto action_11+action_297 (127) = happyGoto action_12+action_297 (137) = happyGoto action_13+action_297 (138) = happyGoto action_14+action_297 (139) = happyGoto action_15+action_297 (140) = happyGoto action_16+action_297 (142) = happyGoto action_17+action_297 (150) = happyGoto action_18+action_297 (151) = happyGoto action_19+action_297 _ = happyFail++action_298 (161) = happyShift action_20+action_298 (169) = happyShift action_23+action_298 (170) = happyShift action_24+action_298 (185) = happyShift action_27+action_298 (188) = happyShift action_29+action_298 (189) = happyShift action_140+action_298 (213) = happyShift action_34+action_298 (214) = happyShift action_35+action_298 (109) = happyGoto action_335+action_298 (125) = happyGoto action_139+action_298 (137) = happyGoto action_13+action_298 (138) = happyGoto action_14+action_298 (139) = happyGoto action_15+action_298 _ = happyFail++action_299 _ = happyReduce_199++action_300 _ = happyReduce_304++action_301 _ = happyReduce_298++action_302 (197) = happyShift action_334+action_302 _ = happyFail++action_303 (161) = happyShift action_20+action_303 (170) = happyShift action_24+action_303 (185) = happyShift action_27+action_303 (188) = happyShift action_29+action_303 (189) = happyShift action_130+action_303 (196) = happyShift action_131+action_303 (208) = happyShift action_314+action_303 (213) = happyShift action_34+action_303 (215) = happyShift action_36+action_303 (216) = happyShift action_132+action_303 (53) = happyGoto action_313+action_303 (56) = happyGoto action_121+action_303 (138) = happyGoto action_124+action_303 (141) = happyGoto action_125+action_303 (142) = happyGoto action_126+action_303 (157) = happyGoto action_127+action_303 (160) = happyGoto action_128+action_303 _ = happyReduce_108++action_304 _ = happyReduce_122++action_305 (198) = happyShift action_333+action_305 _ = happyReduce_119++action_306 (190) = happyShift action_332+action_306 _ = happyFail++action_307 (190) = happyShift action_331+action_307 (198) = happyShift action_183+action_307 _ = happyFail++action_308 _ = happyReduce_121++action_309 (190) = happyShift action_330+action_309 _ = happyFail++action_310 (200) = happyShift action_329+action_310 _ = happyFail++action_311 (161) = happyShift action_20+action_311 (170) = happyShift action_24+action_311 (185) = happyShift action_27+action_311 (188) = happyShift action_29+action_311 (213) = happyShift action_34+action_311 (42) = happyGoto action_328+action_311 (138) = happyGoto action_124+action_311 (160) = happyGoto action_311+action_311 _ = happyReduce_91++action_312 (161) = happyShift action_20+action_312 (169) = happyShift action_129+action_312 (170) = happyShift action_24+action_312 (185) = happyShift action_27+action_312 (188) = happyShift action_29+action_312 (189) = happyShift action_130+action_312 (196) = happyShift action_131+action_312 (213) = happyShift action_34+action_312 (215) = happyShift action_36+action_312 (216) = happyShift action_132+action_312 (51) = happyGoto action_327+action_312 (52) = happyGoto action_303+action_312 (53) = happyGoto action_120+action_312 (56) = happyGoto action_121+action_312 (138) = happyGoto action_124+action_312 (141) = happyGoto action_125+action_312 (142) = happyGoto action_126+action_312 (157) = happyGoto action_127+action_312 (160) = happyGoto action_128+action_312 _ = happyFail++action_313 _ = happyReduce_110++action_314 (161) = happyShift action_20+action_314 (169) = happyShift action_129+action_314 (170) = happyShift action_24+action_314 (185) = happyShift action_27+action_314 (188) = happyShift action_29+action_314 (189) = happyShift action_130+action_314 (196) = happyShift action_131+action_314 (213) = happyShift action_34+action_314 (215) = happyShift action_36+action_314 (216) = happyShift action_132+action_314 (51) = happyGoto action_326+action_314 (52) = happyGoto action_303+action_314 (53) = happyGoto action_120+action_314 (56) = happyGoto action_121+action_314 (138) = happyGoto action_124+action_314 (141) = happyGoto action_125+action_314 (142) = happyGoto action_126+action_314 (157) = happyGoto action_127+action_314 (160) = happyGoto action_128+action_314 _ = happyFail++action_315 (161) = happyShift action_20+action_315 (169) = happyShift action_23+action_315 (170) = happyShift action_24+action_315 (179) = happyShift action_325+action_315 (185) = happyShift action_27+action_315 (188) = happyShift action_29+action_315 (189) = happyShift action_140+action_315 (213) = happyShift action_34+action_315 (214) = happyShift action_35+action_315 (215) = happyShift action_36+action_315 (216) = happyShift action_132+action_315 (13) = happyGoto action_320+action_315 (14) = happyGoto action_321+action_315 (125) = happyGoto action_322+action_315 (137) = happyGoto action_13+action_315 (138) = happyGoto action_14+action_315 (139) = happyGoto action_15+action_315 (141) = happyGoto action_323+action_315 (142) = happyGoto action_126+action_315 (157) = happyGoto action_127+action_315 (158) = happyGoto action_324+action_315 _ = happyFail++action_316 _ = happyReduce_17++action_317 _ = happyReduce_18++action_318 (192) = happyShift action_47+action_318 (194) = happyShift action_48+action_318 (6) = happyGoto action_319+action_318 (153) = happyGoto action_46+action_318 _ = happyFail++action_319 _ = happyReduce_2++action_320 (198) = happyShift action_441+action_320 (12) = happyGoto action_440+action_320 _ = happyReduce_19++action_321 _ = happyReduce_21++action_322 _ = happyReduce_22++action_323 _ = happyReduce_354++action_324 (189) = happyShift action_439+action_324 _ = happyReduce_23++action_325 (215) = happyShift action_36+action_325 (216) = happyShift action_37+action_325 (140) = happyGoto action_113+action_325 (142) = happyGoto action_17+action_325 (155) = happyGoto action_438+action_325 _ = happyFail++action_326 _ = happyReduce_107++action_327 _ = happyReduce_125++action_328 _ = happyReduce_92++action_329 (161) = happyShift action_20+action_329 (169) = happyShift action_129+action_329 (170) = happyShift action_24+action_329 (185) = happyShift action_27+action_329 (188) = happyShift action_29+action_329 (189) = happyShift action_130+action_329 (196) = happyShift action_131+action_329 (213) = happyShift action_34+action_329 (215) = happyShift action_36+action_329 (216) = happyShift action_132+action_329 (51) = happyGoto action_118+action_329 (52) = happyGoto action_119+action_329 (53) = happyGoto action_120+action_329 (56) = happyGoto action_121+action_329 (57) = happyGoto action_437+action_329 (58) = happyGoto action_123+action_329 (138) = happyGoto action_124+action_329 (141) = happyGoto action_125+action_329 (142) = happyGoto action_126+action_329 (157) = happyGoto action_127+action_329 (160) = happyGoto action_128+action_329 _ = happyFail++action_330 _ = happyReduce_123++action_331 _ = happyReduce_124++action_332 _ = happyReduce_115++action_333 (161) = happyShift action_20+action_333 (169) = happyShift action_129+action_333 (170) = happyShift action_24+action_333 (185) = happyShift action_27+action_333 (188) = happyShift action_29+action_333 (189) = happyShift action_130+action_333 (196) = happyShift action_131+action_333 (213) = happyShift action_34+action_333 (215) = happyShift action_36+action_333 (216) = happyShift action_132+action_333 (51) = happyGoto action_305+action_333 (52) = happyGoto action_303+action_333 (53) = happyGoto action_120+action_333 (55) = happyGoto action_436+action_333 (56) = happyGoto action_121+action_333 (138) = happyGoto action_124+action_333 (141) = happyGoto action_125+action_333 (142) = happyGoto action_126+action_333 (157) = happyGoto action_127+action_333 (160) = happyGoto action_128+action_333 _ = happyFail++action_334 _ = happyReduce_114++action_335 _ = happyReduce_248++action_336 _ = happyReduce_250++action_337 (191) = happyShift action_240+action_337 (8) = happyGoto action_432+action_337 (9) = happyGoto action_435+action_337 _ = happyReduce_13++action_338 _ = happyReduce_232++action_339 (199) = happyShift action_256+action_339 (202) = happyShift action_83+action_339 (219) = happyShift action_87+action_339 (221) = happyShift action_89+action_339 (132) = happyGoto action_255+action_339 (135) = happyGoto action_104+action_339 (143) = happyGoto action_72+action_339 (144) = happyGoto action_73+action_339 (152) = happyGoto action_434+action_339 _ = happyReduce_347++action_340 (191) = happyShift action_240+action_340 (8) = happyGoto action_432+action_340 (9) = happyGoto action_433+action_340 _ = happyReduce_13++action_341 _ = happyReduce_226++action_342 _ = happyReduce_242++action_343 (161) = happyShift action_20+action_343 (162) = happyShift action_21+action_343 (167) = happyShift action_22+action_343 (169) = happyShift action_23+action_343 (170) = happyShift action_24+action_343 (171) = happyShift action_25+action_343 (178) = happyShift action_26+action_343 (185) = happyShift action_27+action_343 (186) = happyShift action_28+action_343 (188) = happyShift action_29+action_343 (189) = happyShift action_30+action_343 (196) = happyShift action_31+action_343 (205) = happyShift action_32+action_343 (210) = happyShift action_33+action_343 (213) = happyShift action_34+action_343 (214) = happyShift action_35+action_343 (215) = happyShift action_36+action_343 (216) = happyShift action_37+action_343 (217) = happyShift action_38+action_343 (222) = happyShift action_39+action_343 (223) = happyShift action_40+action_343 (224) = happyShift action_41+action_343 (225) = happyShift action_42+action_343 (88) = happyGoto action_431+action_343 (89) = happyGoto action_5+action_343 (90) = happyGoto action_6+action_343 (91) = happyGoto action_7+action_343 (92) = happyGoto action_8+action_343 (122) = happyGoto action_9+action_343 (123) = happyGoto action_10+action_343 (125) = happyGoto action_11+action_343 (127) = happyGoto action_12+action_343 (137) = happyGoto action_13+action_343 (138) = happyGoto action_14+action_343 (139) = happyGoto action_15+action_343 (140) = happyGoto action_16+action_343 (142) = happyGoto action_17+action_343 (150) = happyGoto action_18+action_343 (151) = happyGoto action_19+action_343 _ = happyFail++action_344 _ = happyReduce_58++action_345 _ = happyReduce_305++action_346 _ = happyReduce_306++action_347 (198) = happyShift action_430+action_347 _ = happyReduce_65++action_348 _ = happyReduce_301++action_349 _ = happyReduce_295++action_350 (161) = happyShift action_20+action_350 (169) = happyShift action_23+action_350 (170) = happyShift action_24+action_350 (185) = happyShift action_27+action_350 (188) = happyShift action_29+action_350 (213) = happyShift action_34+action_350 (215) = happyShift action_36+action_350 (138) = happyGoto action_14+action_350 (139) = happyGoto action_428+action_350 (142) = happyGoto action_429+action_350 _ = happyFail++action_351 _ = happyReduce_95++action_352 _ = happyReduce_103++action_353 _ = happyReduce_104++action_354 _ = happyReduce_287++action_355 (200) = happyShift action_108+action_355 (212) = happyShift action_110+action_355 (217) = happyShift action_111+action_355 (218) = happyShift action_112+action_355 (147) = happyGoto action_427+action_355 _ = happyFail++action_356 (184) = happyShift action_422+action_356 (84) = happyGoto action_426+action_356 _ = happyReduce_181++action_357 (206) = happyShift action_360+action_357 (87) = happyGoto action_425+action_357 _ = happyReduce_183++action_358 _ = happyReduce_185++action_359 (161) = happyShift action_20+action_359 (162) = happyShift action_21+action_359 (167) = happyShift action_22+action_359 (169) = happyShift action_23+action_359 (170) = happyShift action_24+action_359 (171) = happyShift action_25+action_359 (178) = happyShift action_26+action_359 (185) = happyShift action_27+action_359 (186) = happyShift action_28+action_359 (188) = happyShift action_29+action_359 (189) = happyShift action_30+action_359 (196) = happyShift action_31+action_359 (205) = happyShift action_32+action_359 (210) = happyShift action_33+action_359 (213) = happyShift action_34+action_359 (214) = happyShift action_35+action_359 (215) = happyShift action_36+action_359 (216) = happyShift action_37+action_359 (217) = happyShift action_38+action_359 (222) = happyShift action_39+action_359 (223) = happyShift action_40+action_359 (224) = happyShift action_41+action_359 (225) = happyShift action_42+action_359 (88) = happyGoto action_424+action_359 (89) = happyGoto action_5+action_359 (90) = happyGoto action_6+action_359 (91) = happyGoto action_7+action_359 (92) = happyGoto action_8+action_359 (122) = happyGoto action_9+action_359 (123) = happyGoto action_10+action_359 (125) = happyGoto action_11+action_359 (127) = happyGoto action_12+action_359 (137) = happyGoto action_13+action_359 (138) = happyGoto action_14+action_359 (139) = happyGoto action_15+action_359 (140) = happyGoto action_16+action_359 (142) = happyGoto action_17+action_359 (150) = happyGoto action_18+action_359 (151) = happyGoto action_19+action_359 _ = happyFail++action_360 (161) = happyShift action_20+action_360 (162) = happyShift action_21+action_360 (167) = happyShift action_22+action_360 (169) = happyShift action_23+action_360 (170) = happyShift action_24+action_360 (171) = happyShift action_25+action_360 (178) = happyShift action_26+action_360 (185) = happyShift action_27+action_360 (186) = happyShift action_28+action_360 (188) = happyShift action_29+action_360 (189) = happyShift action_30+action_360 (196) = happyShift action_31+action_360 (205) = happyShift action_32+action_360 (210) = happyShift action_33+action_360 (213) = happyShift action_34+action_360 (214) = happyShift action_35+action_360 (215) = happyShift action_36+action_360 (216) = happyShift action_37+action_360 (217) = happyShift action_38+action_360 (222) = happyShift action_39+action_360 (223) = happyShift action_40+action_360 (224) = happyShift action_41+action_360 (225) = happyShift action_42+action_360 (88) = happyGoto action_423+action_360 (89) = happyGoto action_5+action_360 (90) = happyGoto action_6+action_360 (91) = happyGoto action_7+action_360 (92) = happyGoto action_8+action_360 (122) = happyGoto action_9+action_360 (123) = happyGoto action_10+action_360 (125) = happyGoto action_11+action_360 (127) = happyGoto action_12+action_360 (137) = happyGoto action_13+action_360 (138) = happyGoto action_14+action_360 (139) = happyGoto action_15+action_360 (140) = happyGoto action_16+action_360 (142) = happyGoto action_17+action_360 (150) = happyGoto action_18+action_360 (151) = happyGoto action_19+action_360 _ = happyFail++action_361 (184) = happyShift action_422+action_361 (84) = happyGoto action_421+action_361 _ = happyReduce_181++action_362 (199) = happyShift action_256+action_362 (202) = happyShift action_83+action_362 (219) = happyShift action_87+action_362 (221) = happyShift action_89+action_362 (132) = happyGoto action_255+action_362 (135) = happyGoto action_104+action_362 (143) = happyGoto action_72+action_362 (144) = happyGoto action_73+action_362 _ = happyReduce_178++action_363 _ = happyReduce_268++action_364 (161) = happyShift action_20+action_364 (169) = happyShift action_23+action_364 (170) = happyShift action_24+action_364 (185) = happyShift action_27+action_364 (186) = happyShift action_56+action_364 (188) = happyShift action_29+action_364 (189) = happyShift action_57+action_364 (196) = happyShift action_58+action_364 (210) = happyShift action_59+action_364 (213) = happyShift action_34+action_364 (214) = happyShift action_35+action_364 (215) = happyShift action_36+action_364 (216) = happyShift action_37+action_364 (222) = happyShift action_39+action_364 (223) = happyShift action_40+action_364 (224) = happyShift action_41+action_364 (225) = happyShift action_42+action_364 (113) = happyGoto action_51+action_364 (115) = happyGoto action_420+action_364 (125) = happyGoto action_53+action_364 (127) = happyGoto action_54+action_364 (137) = happyGoto action_13+action_364 (138) = happyGoto action_14+action_364 (139) = happyGoto action_15+action_364 (140) = happyGoto action_16+action_364 (142) = happyGoto action_17+action_364 (150) = happyGoto action_55+action_364 (151) = happyGoto action_19+action_364 _ = happyReduce_269++action_365 (161) = happyShift action_20+action_365 (162) = happyShift action_21+action_365 (167) = happyShift action_22+action_365 (169) = happyShift action_23+action_365 (170) = happyShift action_24+action_365 (171) = happyShift action_25+action_365 (178) = happyShift action_26+action_365 (185) = happyShift action_27+action_365 (186) = happyShift action_28+action_365 (188) = happyShift action_29+action_365 (189) = happyShift action_30+action_365 (196) = happyShift action_31+action_365 (205) = happyShift action_32+action_365 (210) = happyShift action_33+action_365 (213) = happyShift action_34+action_365 (214) = happyShift action_35+action_365 (215) = happyShift action_36+action_365 (216) = happyShift action_37+action_365 (217) = happyShift action_38+action_365 (222) = happyShift action_39+action_365 (223) = happyShift action_40+action_365 (224) = happyShift action_41+action_365 (225) = happyShift action_42+action_365 (88) = happyGoto action_419+action_365 (89) = happyGoto action_5+action_365 (90) = happyGoto action_6+action_365 (91) = happyGoto action_7+action_365 (92) = happyGoto action_8+action_365 (122) = happyGoto action_9+action_365 (123) = happyGoto action_10+action_365 (125) = happyGoto action_11+action_365 (127) = happyGoto action_12+action_365 (137) = happyGoto action_13+action_365 (138) = happyGoto action_14+action_365 (139) = happyGoto action_15+action_365 (140) = happyGoto action_16+action_365 (142) = happyGoto action_17+action_365 (150) = happyGoto action_18+action_365 (151) = happyGoto action_19+action_365 _ = happyReduce_218++action_366 (161) = happyShift action_20+action_366 (162) = happyShift action_21+action_366 (167) = happyShift action_22+action_366 (169) = happyShift action_23+action_366 (170) = happyShift action_24+action_366 (171) = happyShift action_25+action_366 (178) = happyShift action_148+action_366 (185) = happyShift action_27+action_366 (186) = happyShift action_28+action_366 (188) = happyShift action_29+action_366 (189) = happyShift action_30+action_366 (196) = happyShift action_31+action_366 (205) = happyShift action_32+action_366 (210) = happyShift action_33+action_366 (213) = happyShift action_34+action_366 (214) = happyShift action_35+action_366 (215) = happyShift action_36+action_366 (216) = happyShift action_37+action_366 (217) = happyShift action_38+action_366 (222) = happyShift action_39+action_366 (223) = happyShift action_40+action_366 (224) = happyShift action_41+action_366 (225) = happyShift action_42+action_366 (88) = happyGoto action_144+action_366 (89) = happyGoto action_145+action_366 (90) = happyGoto action_6+action_366 (91) = happyGoto action_7+action_366 (92) = happyGoto action_8+action_366 (98) = happyGoto action_418+action_366 (122) = happyGoto action_9+action_366 (123) = happyGoto action_10+action_366 (125) = happyGoto action_11+action_366 (127) = happyGoto action_12+action_366 (137) = happyGoto action_13+action_366 (138) = happyGoto action_14+action_366 (139) = happyGoto action_15+action_366 (140) = happyGoto action_16+action_366 (142) = happyGoto action_17+action_366 (150) = happyGoto action_18+action_366 (151) = happyGoto action_19+action_366 _ = happyFail++action_367 _ = happyReduce_280++action_368 _ = happyReduce_253++action_369 (198) = happyShift action_253+action_369 _ = happyReduce_277++action_370 _ = happyReduce_276++action_371 (161) = happyShift action_20+action_371 (169) = happyShift action_23+action_371 (170) = happyShift action_24+action_371 (185) = happyShift action_27+action_371 (186) = happyShift action_56+action_371 (188) = happyShift action_29+action_371 (189) = happyShift action_57+action_371 (196) = happyShift action_58+action_371 (210) = happyShift action_59+action_371 (213) = happyShift action_34+action_371 (214) = happyShift action_35+action_371 (215) = happyShift action_36+action_371 (216) = happyShift action_37+action_371 (217) = happyShift action_174+action_371 (222) = happyShift action_39+action_371 (223) = happyShift action_40+action_371 (224) = happyShift action_41+action_371 (225) = happyShift action_42+action_371 (110) = happyGoto action_417+action_371 (111) = happyGoto action_193+action_371 (112) = happyGoto action_165+action_371 (113) = happyGoto action_166+action_371 (125) = happyGoto action_53+action_371 (127) = happyGoto action_168+action_371 (137) = happyGoto action_13+action_371 (138) = happyGoto action_14+action_371 (139) = happyGoto action_15+action_371 (140) = happyGoto action_16+action_371 (142) = happyGoto action_17+action_371 (150) = happyGoto action_55+action_371 (151) = happyGoto action_19+action_371 _ = happyFail++action_372 (161) = happyShift action_20+action_372 (169) = happyShift action_23+action_372 (170) = happyShift action_24+action_372 (185) = happyShift action_27+action_372 (188) = happyShift action_29+action_372 (189) = happyShift action_140+action_372 (213) = happyShift action_34+action_372 (214) = happyShift action_35+action_372 (117) = happyGoto action_416+action_372 (118) = happyGoto action_248+action_372 (125) = happyGoto action_249+action_372 (137) = happyGoto action_13+action_372 (138) = happyGoto action_14+action_372 (139) = happyGoto action_15+action_372 _ = happyFail++action_373 _ = happyReduce_261++action_374 _ = happyReduce_32++action_375 (191) = happyShift action_240+action_375 (8) = happyGoto action_238+action_375 (9) = happyGoto action_415+action_375 _ = happyReduce_13++action_376 _ = happyReduce_56++action_377 (184) = happyShift action_414+action_377 (74) = happyGoto action_413+action_377 _ = happyReduce_161++action_378 (161) = happyShift action_20+action_378 (170) = happyShift action_24+action_378 (185) = happyShift action_27+action_378 (188) = happyShift action_29+action_378 (213) = happyShift action_34+action_378 (40) = happyGoto action_410+action_378 (41) = happyGoto action_411+action_378 (42) = happyGoto action_412+action_378 (138) = happyGoto action_124+action_378 (160) = happyGoto action_311+action_378 _ = happyReduce_91++action_379 (61) = happyGoto action_408+action_379 (62) = happyGoto action_409+action_379 (152) = happyGoto action_402+action_379 _ = happyReduce_347++action_380 (190) = happyShift action_407+action_380 _ = happyFail++action_381 _ = happyReduce_117++action_382 (161) = happyShift action_406+action_382 (20) = happyGoto action_405+action_382 _ = happyReduce_38++action_383 _ = happyReduce_75++action_384 (192) = happyShift action_404+action_384 (194) = happyShift action_48+action_384 (153) = happyGoto action_403+action_384 _ = happyFail++action_385 (62) = happyGoto action_401+action_385 (152) = happyGoto action_402+action_385 _ = happyReduce_347++action_386 _ = happyReduce_128++action_387 (161) = happyShift action_20+action_387 (169) = happyShift action_129+action_387 (170) = happyShift action_24+action_387 (185) = happyShift action_27+action_387 (188) = happyShift action_29+action_387 (189) = happyShift action_130+action_387 (196) = happyShift action_131+action_387 (213) = happyShift action_34+action_387 (215) = happyShift action_36+action_387 (216) = happyShift action_132+action_387 (51) = happyGoto action_400+action_387 (52) = happyGoto action_303+action_387 (53) = happyGoto action_120+action_387 (56) = happyGoto action_121+action_387 (138) = happyGoto action_124+action_387 (141) = happyGoto action_125+action_387 (142) = happyGoto action_126+action_387 (157) = happyGoto action_127+action_387 (160) = happyGoto action_128+action_387 _ = happyFail++action_388 (203) = happyShift action_399+action_388 _ = happyFail++action_389 _ = happyReduce_69++action_390 _ = happyReduce_85++action_391 (161) = happyShift action_20+action_391 (169) = happyShift action_23+action_391 (170) = happyShift action_24+action_391 (185) = happyShift action_27+action_391 (188) = happyShift action_29+action_391 (189) = happyShift action_355+action_391 (213) = happyShift action_34+action_391 (225) = happyShift action_390+action_391 (37) = happyGoto action_395+action_391 (38) = happyGoto action_396+action_391 (124) = happyGoto action_397+action_391 (138) = happyGoto action_14+action_391 (139) = happyGoto action_398+action_391 _ = happyFail++action_392 (203) = happyShift action_394+action_392 _ = happyFail++action_393 (203) = happyReduce_287+action_393 _ = happyReduce_83++action_394 (161) = happyShift action_20+action_394 (169) = happyShift action_129+action_394 (170) = happyShift action_24+action_394 (185) = happyShift action_27+action_394 (188) = happyShift action_29+action_394 (189) = happyShift action_130+action_394 (196) = happyShift action_131+action_394 (213) = happyShift action_34+action_394 (215) = happyShift action_36+action_394 (216) = happyShift action_132+action_394 (51) = happyGoto action_491+action_394 (52) = happyGoto action_303+action_394 (53) = happyGoto action_120+action_394 (56) = happyGoto action_121+action_394 (138) = happyGoto action_124+action_394 (141) = happyGoto action_125+action_394 (142) = happyGoto action_126+action_394 (157) = happyGoto action_127+action_394 (160) = happyGoto action_128+action_394 _ = happyFail++action_395 (161) = happyShift action_20+action_395 (169) = happyShift action_23+action_395 (170) = happyShift action_24+action_395 (185) = happyShift action_27+action_395 (188) = happyShift action_29+action_395 (189) = happyShift action_355+action_395 (213) = happyShift action_34+action_395 (225) = happyShift action_390+action_395 (38) = happyGoto action_489+action_395 (124) = happyGoto action_490+action_395 (138) = happyGoto action_14+action_395 (139) = happyGoto action_354+action_395 _ = happyFail++action_396 (161) = happyShift action_20+action_396 (169) = happyShift action_23+action_396 (170) = happyShift action_24+action_396 (185) = happyShift action_27+action_396 (188) = happyShift action_29+action_396 (189) = happyShift action_355+action_396 (213) = happyShift action_34+action_396 (124) = happyGoto action_488+action_396 (138) = happyGoto action_14+action_396 (139) = happyGoto action_354+action_396 _ = happyFail++action_397 (203) = happyShift action_487+action_397 _ = happyFail++action_398 (203) = happyReduce_287+action_398 _ = happyReduce_84++action_399 (161) = happyShift action_20+action_399 (169) = happyShift action_129+action_399 (170) = happyShift action_24+action_399 (185) = happyShift action_27+action_399 (188) = happyShift action_29+action_399 (189) = happyShift action_130+action_399 (196) = happyShift action_131+action_399 (213) = happyShift action_34+action_399 (215) = happyShift action_36+action_399 (216) = happyShift action_132+action_399 (51) = happyGoto action_486+action_399 (52) = happyGoto action_303+action_399 (53) = happyGoto action_120+action_399 (56) = happyGoto action_121+action_399 (138) = happyGoto action_124+action_399 (141) = happyGoto action_125+action_399 (142) = happyGoto action_126+action_399 (157) = happyGoto action_127+action_399 (160) = happyGoto action_128+action_399 _ = happyFail++action_400 _ = happyReduce_71++action_401 (166) = happyShift action_470+action_401 (72) = happyGoto action_485+action_401 _ = happyReduce_153++action_402 (169) = happyShift action_484+action_402 (63) = happyGoto action_483+action_402 _ = happyReduce_134++action_403 (161) = happyShift action_20+action_403 (169) = happyShift action_23+action_403 (170) = happyShift action_24+action_403 (185) = happyShift action_27+action_403 (186) = happyShift action_56+action_403 (188) = happyShift action_29+action_403 (189) = happyShift action_172+action_403 (196) = happyShift action_58+action_403 (210) = happyShift action_59+action_403 (213) = happyShift action_34+action_403 (214) = happyShift action_35+action_403 (215) = happyShift action_36+action_403 (216) = happyShift action_37+action_403 (217) = happyShift action_174+action_403 (222) = happyShift action_39+action_403 (223) = happyShift action_40+action_403 (224) = happyShift action_41+action_403 (225) = happyShift action_42+action_403 (79) = happyGoto action_482+action_403 (80) = happyGoto action_479+action_403 (81) = happyGoto action_480+action_403 (82) = happyGoto action_481+action_403 (83) = happyGoto action_163+action_403 (111) = happyGoto action_164+action_403 (112) = happyGoto action_165+action_403 (113) = happyGoto action_166+action_403 (125) = happyGoto action_272+action_403 (127) = happyGoto action_168+action_403 (137) = happyGoto action_13+action_403 (138) = happyGoto action_14+action_403 (139) = happyGoto action_15+action_403 (140) = happyGoto action_16+action_403 (142) = happyGoto action_17+action_403 (150) = happyGoto action_55+action_403 (151) = happyGoto action_19+action_403 _ = happyReduce_170++action_404 (161) = happyShift action_20+action_404 (169) = happyShift action_23+action_404 (170) = happyShift action_24+action_404 (185) = happyShift action_27+action_404 (186) = happyShift action_56+action_404 (188) = happyShift action_29+action_404 (189) = happyShift action_172+action_404 (196) = happyShift action_58+action_404 (210) = happyShift action_59+action_404 (213) = happyShift action_34+action_404 (214) = happyShift action_35+action_404 (215) = happyShift action_36+action_404 (216) = happyShift action_37+action_404 (217) = happyShift action_174+action_404 (222) = happyShift action_39+action_404 (223) = happyShift action_40+action_404 (224) = happyShift action_41+action_404 (225) = happyShift action_42+action_404 (79) = happyGoto action_478+action_404 (80) = happyGoto action_479+action_404 (81) = happyGoto action_480+action_404 (82) = happyGoto action_481+action_404 (83) = happyGoto action_163+action_404 (111) = happyGoto action_164+action_404 (112) = happyGoto action_165+action_404 (113) = happyGoto action_166+action_404 (125) = happyGoto action_272+action_404 (127) = happyGoto action_168+action_404 (137) = happyGoto action_13+action_404 (138) = happyGoto action_14+action_404 (139) = happyGoto action_15+action_404 (140) = happyGoto action_16+action_404 (142) = happyGoto action_17+action_404 (150) = happyGoto action_55+action_404 (151) = happyGoto action_19+action_404 _ = happyReduce_170++action_405 (170) = happyShift action_476+action_405 (189) = happyShift action_477+action_405 (21) = happyGoto action_473+action_405 (22) = happyGoto action_474+action_405 (23) = happyGoto action_475+action_405 _ = happyReduce_40++action_406 (215) = happyShift action_36+action_406 (216) = happyShift action_37+action_406 (140) = happyGoto action_113+action_406 (142) = happyGoto action_17+action_406 (155) = happyGoto action_472+action_406 _ = happyFail++action_407 _ = happyReduce_76++action_408 (166) = happyShift action_470+action_408 (206) = happyShift action_471+action_408 (72) = happyGoto action_469+action_408 _ = happyReduce_153++action_409 _ = happyReduce_131++action_410 _ = happyReduce_87++action_411 (198) = happyShift action_468+action_411 _ = happyReduce_88++action_412 (208) = happyShift action_467+action_412 _ = happyFail++action_413 _ = happyReduce_74++action_414 (192) = happyShift action_466+action_414 (194) = happyShift action_48+action_414 (153) = happyGoto action_465+action_414 _ = happyFail++action_415 _ = happyReduce_6++action_416 _ = happyReduce_273++action_417 _ = happyReduce_275++action_418 _ = happyReduce_224++action_419 _ = happyReduce_220++action_420 _ = happyReduce_179++action_421 _ = happyReduce_176++action_422 (192) = happyShift action_92+action_422 (194) = happyShift action_48+action_422 (47) = happyGoto action_464+action_422 (153) = happyGoto action_91+action_422 _ = happyFail++action_423 (204) = happyShift action_463+action_423 _ = happyFail++action_424 _ = happyReduce_182++action_425 _ = happyReduce_184++action_426 _ = happyReduce_175++action_427 (190) = happyShift action_462+action_427 _ = happyFail++action_428 (199) = happyShift action_461+action_428 _ = happyFail++action_429 (199) = happyShift action_460+action_429 _ = happyFail++action_430 (199) = happyShift action_350+action_430 (200) = happyShift action_108+action_430 (202) = happyShift action_83+action_430 (212) = happyShift action_110+action_430 (217) = happyShift action_111+action_430 (218) = happyShift action_112+action_430 (219) = happyShift action_87+action_430 (32) = happyGoto action_459+action_430 (128) = happyGoto action_345+action_430 (131) = happyGoto action_346+action_430 (133) = happyGoto action_347+action_430 (144) = happyGoto action_348+action_430 (147) = happyGoto action_349+action_430 _ = happyFail++action_431 _ = happyReduce_192++action_432 (161) = happyShift action_20+action_432 (169) = happyShift action_23+action_432 (170) = happyShift action_24+action_432 (185) = happyShift action_27+action_432 (186) = happyShift action_56+action_432 (188) = happyShift action_29+action_432 (189) = happyShift action_57+action_432 (196) = happyShift action_58+action_432 (210) = happyShift action_59+action_432 (213) = happyShift action_34+action_432 (214) = happyShift action_35+action_432 (215) = happyShift action_36+action_432 (216) = happyShift action_37+action_432 (217) = happyShift action_174+action_432 (222) = happyShift action_39+action_432 (223) = happyShift action_40+action_432 (224) = happyShift action_41+action_432 (225) = happyShift action_42+action_432 (101) = happyGoto action_458+action_432 (111) = happyGoto action_339+action_432 (112) = happyGoto action_165+action_432 (113) = happyGoto action_166+action_432 (125) = happyGoto action_53+action_432 (127) = happyGoto action_168+action_432 (137) = happyGoto action_13+action_432 (138) = happyGoto action_14+action_432 (139) = happyGoto action_15+action_432 (140) = happyGoto action_16+action_432 (142) = happyGoto action_17+action_432 (150) = happyGoto action_55+action_432 (151) = happyGoto action_19+action_432 _ = happyFail++action_433 (1) = happyShift action_223+action_433 (195) = happyShift action_224+action_433 (154) = happyGoto action_457+action_433 _ = happyFail++action_434 (206) = happyShift action_455+action_434 (208) = happyShift action_456+action_434 (102) = happyGoto action_452+action_434 (103) = happyGoto action_453+action_434 (104) = happyGoto action_454+action_434 _ = happyFail++action_435 (193) = happyShift action_451+action_435 _ = happyFail++action_436 _ = happyReduce_118++action_437 _ = happyReduce_109++action_438 _ = happyReduce_27++action_439 (161) = happyShift action_20+action_439 (169) = happyShift action_23+action_439 (170) = happyShift action_24+action_439 (185) = happyShift action_27+action_439 (188) = happyShift action_29+action_439 (189) = happyShift action_448+action_439 (190) = happyShift action_449+action_439 (201) = happyShift action_450+action_439 (213) = happyShift action_34+action_439 (214) = happyShift action_35+action_439 (215) = happyShift action_36+action_439 (216) = happyShift action_37+action_439 (15) = happyGoto action_444+action_439 (16) = happyGoto action_445+action_439 (125) = happyGoto action_446+action_439 (127) = happyGoto action_447+action_439 (137) = happyGoto action_13+action_439 (138) = happyGoto action_14+action_439 (139) = happyGoto action_15+action_439 (140) = happyGoto action_16+action_439 (142) = happyGoto action_17+action_439 _ = happyFail++action_440 (190) = happyShift action_443+action_440 _ = happyFail++action_441 (161) = happyShift action_20+action_441 (169) = happyShift action_23+action_441 (170) = happyShift action_24+action_441 (179) = happyShift action_325+action_441 (185) = happyShift action_27+action_441 (188) = happyShift action_29+action_441 (189) = happyShift action_140+action_441 (213) = happyShift action_34+action_441 (214) = happyShift action_35+action_441 (215) = happyShift action_36+action_441 (216) = happyShift action_132+action_441 (14) = happyGoto action_442+action_441 (125) = happyGoto action_322+action_441 (137) = happyGoto action_13+action_441 (138) = happyGoto action_14+action_441 (139) = happyGoto action_15+action_441 (141) = happyGoto action_323+action_441 (142) = happyGoto action_126+action_441 (157) = happyGoto action_127+action_441 (158) = happyGoto action_324+action_441 _ = happyReduce_18++action_442 _ = happyReduce_20++action_443 _ = happyReduce_16++action_444 (190) = happyShift action_534+action_444 (198) = happyShift action_535+action_444 _ = happyFail++action_445 _ = happyReduce_29++action_446 _ = happyReduce_30++action_447 _ = happyReduce_31++action_448 (200) = happyShift action_108+action_448 (202) = happyShift action_83+action_448 (212) = happyShift action_110+action_448 (217) = happyShift action_111+action_448 (218) = happyShift action_112+action_448 (219) = happyShift action_87+action_448 (220) = happyShift action_88+action_448 (221) = happyShift action_89+action_448 (135) = happyGoto action_198+action_448 (143) = happyGoto action_72+action_448 (144) = happyGoto action_73+action_448 (145) = happyGoto action_74+action_448 (147) = happyGoto action_76+action_448 (149) = happyGoto action_106+action_448 _ = happyFail++action_449 _ = happyReduce_25++action_450 (190) = happyShift action_533+action_450 _ = happyFail++action_451 _ = happyReduce_229++action_452 (184) = happyShift action_532+action_452 _ = happyReduce_233++action_453 (206) = happyShift action_455+action_453 (104) = happyGoto action_531+action_453 _ = happyReduce_236++action_454 _ = happyReduce_238++action_455 (161) = happyShift action_20+action_455 (162) = happyShift action_21+action_455 (167) = happyShift action_22+action_455 (169) = happyShift action_23+action_455 (170) = happyShift action_24+action_455 (171) = happyShift action_25+action_455 (178) = happyShift action_26+action_455 (185) = happyShift action_27+action_455 (186) = happyShift action_28+action_455 (188) = happyShift action_29+action_455 (189) = happyShift action_30+action_455 (196) = happyShift action_31+action_455 (205) = happyShift action_32+action_455 (210) = happyShift action_33+action_455 (213) = happyShift action_34+action_455 (214) = happyShift action_35+action_455 (215) = happyShift action_36+action_455 (216) = happyShift action_37+action_455 (217) = happyShift action_38+action_455 (222) = happyShift action_39+action_455 (223) = happyShift action_40+action_455 (224) = happyShift action_41+action_455 (225) = happyShift action_42+action_455 (88) = happyGoto action_530+action_455 (89) = happyGoto action_5+action_455 (90) = happyGoto action_6+action_455 (91) = happyGoto action_7+action_455 (92) = happyGoto action_8+action_455 (122) = happyGoto action_9+action_455 (123) = happyGoto action_10+action_455 (125) = happyGoto action_11+action_455 (127) = happyGoto action_12+action_455 (137) = happyGoto action_13+action_455 (138) = happyGoto action_14+action_455 (139) = happyGoto action_15+action_455 (140) = happyGoto action_16+action_455 (142) = happyGoto action_17+action_455 (150) = happyGoto action_18+action_455 (151) = happyGoto action_19+action_455 _ = happyFail++action_456 (161) = happyShift action_20+action_456 (162) = happyShift action_21+action_456 (167) = happyShift action_22+action_456 (169) = happyShift action_23+action_456 (170) = happyShift action_24+action_456 (171) = happyShift action_25+action_456 (178) = happyShift action_26+action_456 (185) = happyShift action_27+action_456 (186) = happyShift action_28+action_456 (188) = happyShift action_29+action_456 (189) = happyShift action_30+action_456 (196) = happyShift action_31+action_456 (205) = happyShift action_32+action_456 (210) = happyShift action_33+action_456 (213) = happyShift action_34+action_456 (214) = happyShift action_35+action_456 (215) = happyShift action_36+action_456 (216) = happyShift action_37+action_456 (217) = happyShift action_38+action_456 (222) = happyShift action_39+action_456 (223) = happyShift action_40+action_456 (224) = happyShift action_41+action_456 (225) = happyShift action_42+action_456 (88) = happyGoto action_529+action_456 (89) = happyGoto action_5+action_456 (90) = happyGoto action_6+action_456 (91) = happyGoto action_7+action_456 (92) = happyGoto action_8+action_456 (122) = happyGoto action_9+action_456 (123) = happyGoto action_10+action_456 (125) = happyGoto action_11+action_456 (127) = happyGoto action_12+action_456 (137) = happyGoto action_13+action_456 (138) = happyGoto action_14+action_456 (139) = happyGoto action_15+action_456 (140) = happyGoto action_16+action_456 (142) = happyGoto action_17+action_456 (150) = happyGoto action_18+action_456 (151) = happyGoto action_19+action_456 _ = happyFail++action_457 _ = happyReduce_230++action_458 _ = happyReduce_231++action_459 _ = happyReduce_64++action_460 _ = happyReduce_302++action_461 _ = happyReduce_296++action_462 _ = happyReduce_288++action_463 (161) = happyShift action_20+action_463 (162) = happyShift action_21+action_463 (167) = happyShift action_22+action_463 (169) = happyShift action_23+action_463 (170) = happyShift action_24+action_463 (171) = happyShift action_25+action_463 (178) = happyShift action_26+action_463 (185) = happyShift action_27+action_463 (186) = happyShift action_28+action_463 (188) = happyShift action_29+action_463 (189) = happyShift action_30+action_463 (196) = happyShift action_31+action_463 (205) = happyShift action_32+action_463 (210) = happyShift action_33+action_463 (213) = happyShift action_34+action_463 (214) = happyShift action_35+action_463 (215) = happyShift action_36+action_463 (216) = happyShift action_37+action_463 (217) = happyShift action_38+action_463 (222) = happyShift action_39+action_463 (223) = happyShift action_40+action_463 (224) = happyShift action_41+action_463 (225) = happyShift action_42+action_463 (88) = happyGoto action_528+action_463 (89) = happyGoto action_5+action_463 (90) = happyGoto action_6+action_463 (91) = happyGoto action_7+action_463 (92) = happyGoto action_8+action_463 (122) = happyGoto action_9+action_463 (123) = happyGoto action_10+action_463 (125) = happyGoto action_11+action_463 (127) = happyGoto action_12+action_463 (137) = happyGoto action_13+action_463 (138) = happyGoto action_14+action_463 (139) = happyGoto action_15+action_463 (140) = happyGoto action_16+action_463 (142) = happyGoto action_17+action_463 (150) = happyGoto action_18+action_463 (151) = happyGoto action_19+action_463 _ = happyFail++action_464 _ = happyReduce_180++action_465 (161) = happyShift action_20+action_465 (169) = happyShift action_23+action_465 (170) = happyShift action_24+action_465 (174) = happyShift action_169+action_465 (175) = happyShift action_170+action_465 (176) = happyShift action_171+action_465 (185) = happyShift action_27+action_465 (186) = happyShift action_56+action_465 (188) = happyShift action_29+action_465 (189) = happyShift action_172+action_465 (196) = happyShift action_58+action_465 (210) = happyShift action_59+action_465 (213) = happyShift action_34+action_465 (214) = happyShift action_35+action_465 (215) = happyShift action_36+action_465 (216) = happyShift action_37+action_465 (217) = happyShift action_174+action_465 (222) = happyShift action_39+action_465 (223) = happyShift action_40+action_465 (224) = happyShift action_41+action_465 (225) = happyShift action_42+action_465 (29) = happyGoto action_153+action_465 (31) = happyGoto action_154+action_465 (45) = happyGoto action_523+action_465 (46) = happyGoto action_158+action_465 (48) = happyGoto action_159+action_465 (49) = happyGoto action_160+action_465 (50) = happyGoto action_161+action_465 (75) = happyGoto action_527+action_465 (76) = happyGoto action_525+action_465 (77) = happyGoto action_526+action_465 (82) = happyGoto action_162+action_465 (83) = happyGoto action_163+action_465 (111) = happyGoto action_164+action_465 (112) = happyGoto action_165+action_465 (113) = happyGoto action_166+action_465 (125) = happyGoto action_167+action_465 (127) = happyGoto action_168+action_465 (137) = happyGoto action_13+action_465 (138) = happyGoto action_14+action_465 (139) = happyGoto action_15+action_465 (140) = happyGoto action_16+action_465 (142) = happyGoto action_17+action_465 (150) = happyGoto action_55+action_465 (151) = happyGoto action_19+action_465 _ = happyReduce_162++action_466 (161) = happyShift action_20+action_466 (169) = happyShift action_23+action_466 (170) = happyShift action_24+action_466 (174) = happyShift action_169+action_466 (175) = happyShift action_170+action_466 (176) = happyShift action_171+action_466 (185) = happyShift action_27+action_466 (186) = happyShift action_56+action_466 (188) = happyShift action_29+action_466 (189) = happyShift action_172+action_466 (196) = happyShift action_58+action_466 (210) = happyShift action_59+action_466 (213) = happyShift action_34+action_466 (214) = happyShift action_35+action_466 (215) = happyShift action_36+action_466 (216) = happyShift action_37+action_466 (217) = happyShift action_174+action_466 (222) = happyShift action_39+action_466 (223) = happyShift action_40+action_466 (224) = happyShift action_41+action_466 (225) = happyShift action_42+action_466 (29) = happyGoto action_153+action_466 (31) = happyGoto action_154+action_466 (45) = happyGoto action_523+action_466 (46) = happyGoto action_158+action_466 (48) = happyGoto action_159+action_466 (49) = happyGoto action_160+action_466 (50) = happyGoto action_161+action_466 (75) = happyGoto action_524+action_466 (76) = happyGoto action_525+action_466 (77) = happyGoto action_526+action_466 (82) = happyGoto action_162+action_466 (83) = happyGoto action_163+action_466 (111) = happyGoto action_164+action_466 (112) = happyGoto action_165+action_466 (113) = happyGoto action_166+action_466 (125) = happyGoto action_167+action_466 (127) = happyGoto action_168+action_466 (137) = happyGoto action_13+action_466 (138) = happyGoto action_14+action_466 (139) = happyGoto action_15+action_466 (140) = happyGoto action_16+action_466 (142) = happyGoto action_17+action_466 (150) = happyGoto action_55+action_466 (151) = happyGoto action_19+action_466 _ = happyReduce_162++action_467 (161) = happyShift action_20+action_467 (170) = happyShift action_24+action_467 (185) = happyShift action_27+action_467 (188) = happyShift action_29+action_467 (213) = happyShift action_34+action_467 (42) = happyGoto action_522+action_467 (138) = happyGoto action_124+action_467 (160) = happyGoto action_311+action_467 _ = happyReduce_91++action_468 (161) = happyShift action_20+action_468 (170) = happyShift action_24+action_468 (185) = happyShift action_27+action_468 (188) = happyShift action_29+action_468 (213) = happyShift action_34+action_468 (40) = happyGoto action_521+action_468 (41) = happyGoto action_411+action_468 (42) = happyGoto action_412+action_468 (138) = happyGoto action_124+action_468 (160) = happyGoto action_311+action_468 _ = happyReduce_91++action_469 _ = happyReduce_72++action_470 (189) = happyShift action_520+action_470 (215) = happyShift action_36+action_470 (216) = happyShift action_132+action_470 (141) = happyGoto action_518+action_470 (142) = happyGoto action_126+action_470 (157) = happyGoto action_127+action_470 (159) = happyGoto action_519+action_470 _ = happyFail++action_471 (62) = happyGoto action_517+action_471 (152) = happyGoto action_402+action_471 _ = happyReduce_347++action_472 _ = happyReduce_37++action_473 _ = happyReduce_34++action_474 _ = happyReduce_39++action_475 _ = happyReduce_41++action_476 (189) = happyShift action_477+action_476 (23) = happyGoto action_516+action_476 _ = happyFail++action_477 (161) = happyShift action_20+action_477 (169) = happyShift action_23+action_477 (170) = happyShift action_24+action_477 (185) = happyShift action_27+action_477 (188) = happyShift action_29+action_477 (189) = happyShift action_355+action_477 (198) = happyShift action_317+action_477 (213) = happyShift action_34+action_477 (215) = happyShift action_36+action_477 (12) = happyGoto action_510+action_477 (24) = happyGoto action_511+action_477 (25) = happyGoto action_512+action_477 (124) = happyGoto action_513+action_477 (138) = happyGoto action_14+action_477 (139) = happyGoto action_354+action_477 (142) = happyGoto action_514+action_477 (156) = happyGoto action_515+action_477 _ = happyReduce_19++action_478 (193) = happyShift action_509+action_478 _ = happyFail++action_479 (191) = happyShift action_149+action_479 (8) = happyGoto action_508+action_479 _ = happyReduce_171++action_480 _ = happyReduce_172++action_481 _ = happyReduce_174++action_482 (1) = happyShift action_223+action_482 (195) = happyShift action_224+action_482 (154) = happyGoto action_507+action_482 _ = happyFail++action_483 (161) = happyShift action_20+action_483 (170) = happyShift action_24+action_483 (185) = happyShift action_27+action_483 (188) = happyShift action_29+action_483 (189) = happyShift action_505+action_483 (196) = happyShift action_131+action_483 (212) = happyShift action_506+action_483 (213) = happyShift action_34+action_483 (215) = happyShift action_36+action_483 (216) = happyShift action_132+action_483 (52) = happyGoto action_497+action_483 (53) = happyGoto action_120+action_483 (56) = happyGoto action_121+action_483 (58) = happyGoto action_498+action_483 (64) = happyGoto action_499+action_483 (65) = happyGoto action_500+action_483 (66) = happyGoto action_501+action_483 (68) = happyGoto action_502+action_483 (126) = happyGoto action_503+action_483 (138) = happyGoto action_124+action_483 (141) = happyGoto action_125+action_483 (142) = happyGoto action_504+action_483 (157) = happyGoto action_127+action_483 (160) = happyGoto action_128+action_483 _ = happyFail++action_484 (161) = happyShift action_20+action_484 (170) = happyShift action_24+action_484 (185) = happyShift action_27+action_484 (188) = happyShift action_29+action_484 (213) = happyShift action_34+action_484 (42) = happyGoto action_496+action_484 (138) = happyGoto action_124+action_484 (160) = happyGoto action_311+action_484 _ = happyReduce_91++action_485 _ = happyReduce_73++action_486 _ = happyReduce_66++action_487 (161) = happyShift action_20+action_487 (169) = happyShift action_129+action_487 (170) = happyShift action_24+action_487 (185) = happyShift action_27+action_487 (188) = happyShift action_29+action_487 (189) = happyShift action_130+action_487 (196) = happyShift action_131+action_487 (213) = happyShift action_34+action_487 (215) = happyShift action_36+action_487 (216) = happyShift action_132+action_487 (51) = happyGoto action_495+action_487 (52) = happyGoto action_303+action_487 (53) = happyGoto action_120+action_487 (56) = happyGoto action_121+action_487 (138) = happyGoto action_124+action_487 (141) = happyGoto action_125+action_487 (142) = happyGoto action_126+action_487 (157) = happyGoto action_127+action_487 (160) = happyGoto action_128+action_487 _ = happyFail++action_488 (203) = happyShift action_494+action_488 _ = happyFail++action_489 (161) = happyShift action_20+action_489 (169) = happyShift action_23+action_489 (170) = happyShift action_24+action_489 (185) = happyShift action_27+action_489 (188) = happyShift action_29+action_489 (189) = happyShift action_355+action_489 (213) = happyShift action_34+action_489 (124) = happyGoto action_493+action_489 (138) = happyGoto action_14+action_489 (139) = happyGoto action_354+action_489 _ = happyFail++action_490 (203) = happyShift action_492+action_490 _ = happyFail++action_491 _ = happyReduce_78++action_492 (161) = happyShift action_20+action_492 (169) = happyShift action_129+action_492 (170) = happyShift action_24+action_492 (185) = happyShift action_27+action_492 (188) = happyShift action_29+action_492 (189) = happyShift action_130+action_492 (196) = happyShift action_131+action_492 (213) = happyShift action_34+action_492 (215) = happyShift action_36+action_492 (216) = happyShift action_132+action_492 (51) = happyGoto action_563+action_492 (52) = happyGoto action_303+action_492 (53) = happyGoto action_120+action_492 (56) = happyGoto action_121+action_492 (138) = happyGoto action_124+action_492 (141) = happyGoto action_125+action_492 (142) = happyGoto action_126+action_492 (157) = happyGoto action_127+action_492 (160) = happyGoto action_128+action_492 _ = happyFail++action_493 (203) = happyShift action_562+action_493 _ = happyFail++action_494 (161) = happyShift action_20+action_494 (169) = happyShift action_129+action_494 (170) = happyShift action_24+action_494 (185) = happyShift action_27+action_494 (188) = happyShift action_29+action_494 (189) = happyShift action_130+action_494 (196) = happyShift action_131+action_494 (213) = happyShift action_34+action_494 (215) = happyShift action_36+action_494 (216) = happyShift action_132+action_494 (51) = happyGoto action_561+action_494 (52) = happyGoto action_303+action_494 (53) = happyGoto action_120+action_494 (56) = happyGoto action_121+action_494 (138) = happyGoto action_124+action_494 (141) = happyGoto action_125+action_494 (142) = happyGoto action_126+action_494 (157) = happyGoto action_127+action_494 (160) = happyGoto action_128+action_494 _ = happyFail++action_495 _ = happyReduce_79++action_496 (200) = happyShift action_560+action_496 _ = happyFail++action_497 (161) = happyShift action_20+action_497 (170) = happyShift action_24+action_497 (185) = happyShift action_27+action_497 (188) = happyShift action_29+action_497 (189) = happyShift action_130+action_497 (196) = happyShift action_131+action_497 (199) = happyReduce_146+action_497 (202) = happyReduce_146+action_497 (211) = happyReduce_127+action_497 (212) = happyShift action_559+action_497 (213) = happyShift action_34+action_497 (215) = happyShift action_36+action_497 (216) = happyShift action_132+action_497 (219) = happyReduce_146+action_497 (53) = happyGoto action_313+action_497 (56) = happyGoto action_121+action_497 (138) = happyGoto action_124+action_497 (141) = happyGoto action_125+action_497 (142) = happyGoto action_126+action_497 (157) = happyGoto action_127+action_497 (160) = happyGoto action_128+action_497 _ = happyReduce_139++action_498 (211) = happyShift action_558+action_498 _ = happyFail++action_499 _ = happyReduce_132++action_500 _ = happyReduce_136++action_501 (161) = happyShift action_20+action_501 (170) = happyShift action_24+action_501 (185) = happyShift action_27+action_501 (188) = happyShift action_29+action_501 (189) = happyShift action_130+action_501 (196) = happyShift action_131+action_501 (212) = happyShift action_557+action_501 (213) = happyShift action_34+action_501 (215) = happyShift action_36+action_501 (216) = happyShift action_132+action_501 (53) = happyGoto action_555+action_501 (56) = happyGoto action_121+action_501 (67) = happyGoto action_556+action_501 (138) = happyGoto action_124+action_501 (141) = happyGoto action_125+action_501 (142) = happyGoto action_126+action_501 (157) = happyGoto action_127+action_501 (160) = happyGoto action_128+action_501 _ = happyReduce_140++action_502 (199) = happyShift action_554+action_502 (202) = happyShift action_83+action_502 (219) = happyShift action_87+action_502 (131) = happyGoto action_553+action_502 (144) = happyGoto action_348+action_502 _ = happyFail++action_503 (192) = happyShift action_552+action_503 _ = happyFail++action_504 (192) = happyReduce_291+action_504 _ = happyReduce_353++action_505 (161) = happyShift action_20+action_505 (169) = happyShift action_129+action_505 (170) = happyShift action_24+action_505 (185) = happyShift action_27+action_505 (188) = happyShift action_29+action_505 (189) = happyShift action_130+action_505 (190) = happyShift action_308+action_505 (196) = happyShift action_131+action_505 (198) = happyShift action_80+action_505 (202) = happyShift action_83+action_505 (208) = happyShift action_309+action_505 (213) = happyShift action_34+action_505 (215) = happyShift action_36+action_505 (216) = happyShift action_132+action_505 (219) = happyShift action_87+action_505 (51) = happyGoto action_305+action_505 (52) = happyGoto action_303+action_505 (53) = happyGoto action_120+action_505 (55) = happyGoto action_306+action_505 (56) = happyGoto action_121+action_505 (93) = happyGoto action_307+action_505 (138) = happyGoto action_124+action_505 (141) = happyGoto action_125+action_505 (142) = happyGoto action_126+action_505 (144) = happyGoto action_551+action_505 (157) = happyGoto action_127+action_505 (160) = happyGoto action_128+action_505 _ = happyFail++action_506 (161) = happyShift action_20+action_506 (170) = happyShift action_24+action_506 (185) = happyShift action_27+action_506 (188) = happyShift action_29+action_506 (189) = happyShift action_130+action_506 (196) = happyShift action_131+action_506 (213) = happyShift action_34+action_506 (215) = happyShift action_36+action_506 (216) = happyShift action_132+action_506 (53) = happyGoto action_550+action_506 (56) = happyGoto action_121+action_506 (138) = happyGoto action_124+action_506 (141) = happyGoto action_125+action_506 (142) = happyGoto action_126+action_506 (157) = happyGoto action_127+action_506 (160) = happyGoto action_128+action_506 _ = happyFail++action_507 _ = happyReduce_168++action_508 (161) = happyShift action_20+action_508 (169) = happyShift action_23+action_508 (170) = happyShift action_24+action_508 (185) = happyShift action_27+action_508 (186) = happyShift action_56+action_508 (188) = happyShift action_29+action_508 (189) = happyShift action_172+action_508 (196) = happyShift action_58+action_508 (210) = happyShift action_59+action_508 (213) = happyShift action_34+action_508 (214) = happyShift action_35+action_508 (215) = happyShift action_36+action_508 (216) = happyShift action_37+action_508 (217) = happyShift action_174+action_508 (222) = happyShift action_39+action_508 (223) = happyShift action_40+action_508 (224) = happyShift action_41+action_508 (225) = happyShift action_42+action_508 (81) = happyGoto action_549+action_508 (82) = happyGoto action_481+action_508 (83) = happyGoto action_163+action_508 (111) = happyGoto action_164+action_508 (112) = happyGoto action_165+action_508 (113) = happyGoto action_166+action_508 (125) = happyGoto action_272+action_508 (127) = happyGoto action_168+action_508 (137) = happyGoto action_13+action_508 (138) = happyGoto action_14+action_508 (139) = happyGoto action_15+action_508 (140) = happyGoto action_16+action_508 (142) = happyGoto action_17+action_508 (150) = happyGoto action_55+action_508 (151) = happyGoto action_19+action_508 _ = happyFail++action_509 _ = happyReduce_167++action_510 (190) = happyShift action_548+action_510 _ = happyFail++action_511 (198) = happyShift action_547+action_511 (12) = happyGoto action_546+action_511 _ = happyReduce_19++action_512 _ = happyReduce_46++action_513 _ = happyReduce_47++action_514 _ = happyReduce_352++action_515 (189) = happyShift action_545+action_515 _ = happyReduce_48++action_516 _ = happyReduce_42++action_517 _ = happyReduce_130++action_518 _ = happyReduce_355++action_519 _ = happyReduce_154++action_520 (190) = happyShift action_544+action_520 (215) = happyShift action_36+action_520 (216) = happyShift action_132+action_520 (73) = happyGoto action_542+action_520 (141) = happyGoto action_518+action_520 (142) = happyGoto action_126+action_520 (157) = happyGoto action_127+action_520 (159) = happyGoto action_543+action_520 _ = happyFail++action_521 _ = happyReduce_89++action_522 _ = happyReduce_90++action_523 _ = happyReduce_166++action_524 (193) = happyShift action_541+action_524 _ = happyFail++action_525 (191) = happyShift action_149+action_525 (8) = happyGoto action_540+action_525 _ = happyReduce_163++action_526 _ = happyReduce_164++action_527 (1) = happyShift action_223+action_527 (195) = happyShift action_224+action_527 (154) = happyGoto action_539+action_527 _ = happyFail++action_528 _ = happyReduce_186++action_529 _ = happyReduce_235++action_530 (208) = happyShift action_538+action_530 _ = happyFail++action_531 _ = happyReduce_237++action_532 (192) = happyShift action_92+action_532 (194) = happyShift action_48+action_532 (47) = happyGoto action_537+action_532 (153) = happyGoto action_91+action_532 _ = happyFail++action_533 _ = happyReduce_24++action_534 _ = happyReduce_26++action_535 (161) = happyShift action_20+action_535 (169) = happyShift action_23+action_535 (170) = happyShift action_24+action_535 (185) = happyShift action_27+action_535 (188) = happyShift action_29+action_535 (189) = happyShift action_448+action_535 (213) = happyShift action_34+action_535 (214) = happyShift action_35+action_535 (215) = happyShift action_36+action_535 (216) = happyShift action_37+action_535 (16) = happyGoto action_536+action_535 (125) = happyGoto action_446+action_535 (127) = happyGoto action_447+action_535 (137) = happyGoto action_13+action_535 (138) = happyGoto action_14+action_535 (139) = happyGoto action_15+action_535 (140) = happyGoto action_16+action_535 (142) = happyGoto action_17+action_535 _ = happyFail++action_536 _ = happyReduce_28++action_537 _ = happyReduce_234++action_538 (161) = happyShift action_20+action_538 (162) = happyShift action_21+action_538 (167) = happyShift action_22+action_538 (169) = happyShift action_23+action_538 (170) = happyShift action_24+action_538 (171) = happyShift action_25+action_538 (178) = happyShift action_26+action_538 (185) = happyShift action_27+action_538 (186) = happyShift action_28+action_538 (188) = happyShift action_29+action_538 (189) = happyShift action_30+action_538 (196) = happyShift action_31+action_538 (205) = happyShift action_32+action_538 (210) = happyShift action_33+action_538 (213) = happyShift action_34+action_538 (214) = happyShift action_35+action_538 (215) = happyShift action_36+action_538 (216) = happyShift action_37+action_538 (217) = happyShift action_38+action_538 (222) = happyShift action_39+action_538 (223) = happyShift action_40+action_538 (224) = happyShift action_41+action_538 (225) = happyShift action_42+action_538 (88) = happyGoto action_588+action_538 (89) = happyGoto action_5+action_538 (90) = happyGoto action_6+action_538 (91) = happyGoto action_7+action_538 (92) = happyGoto action_8+action_538 (122) = happyGoto action_9+action_538 (123) = happyGoto action_10+action_538 (125) = happyGoto action_11+action_538 (127) = happyGoto action_12+action_538 (137) = happyGoto action_13+action_538 (138) = happyGoto action_14+action_538 (139) = happyGoto action_15+action_538 (140) = happyGoto action_16+action_538 (142) = happyGoto action_17+action_538 (150) = happyGoto action_18+action_538 (151) = happyGoto action_19+action_538 _ = happyFail++action_539 _ = happyReduce_160++action_540 (161) = happyShift action_20+action_540 (169) = happyShift action_23+action_540 (170) = happyShift action_24+action_540 (174) = happyShift action_169+action_540 (175) = happyShift action_170+action_540 (176) = happyShift action_171+action_540 (185) = happyShift action_27+action_540 (186) = happyShift action_56+action_540 (188) = happyShift action_29+action_540 (189) = happyShift action_172+action_540 (196) = happyShift action_58+action_540 (210) = happyShift action_59+action_540 (213) = happyShift action_34+action_540 (214) = happyShift action_35+action_540 (215) = happyShift action_36+action_540 (216) = happyShift action_37+action_540 (217) = happyShift action_174+action_540 (222) = happyShift action_39+action_540 (223) = happyShift action_40+action_540 (224) = happyShift action_41+action_540 (225) = happyShift action_42+action_540 (29) = happyGoto action_153+action_540 (31) = happyGoto action_154+action_540 (45) = happyGoto action_523+action_540 (46) = happyGoto action_158+action_540 (48) = happyGoto action_159+action_540 (49) = happyGoto action_160+action_540 (50) = happyGoto action_161+action_540 (77) = happyGoto action_587+action_540 (82) = happyGoto action_162+action_540 (83) = happyGoto action_163+action_540 (111) = happyGoto action_164+action_540 (112) = happyGoto action_165+action_540 (113) = happyGoto action_166+action_540 (125) = happyGoto action_167+action_540 (127) = happyGoto action_168+action_540 (137) = happyGoto action_13+action_540 (138) = happyGoto action_14+action_540 (139) = happyGoto action_15+action_540 (140) = happyGoto action_16+action_540 (142) = happyGoto action_17+action_540 (150) = happyGoto action_55+action_540 (151) = happyGoto action_19+action_540 _ = happyFail++action_541 _ = happyReduce_159++action_542 (190) = happyShift action_585+action_542 (198) = happyShift action_586+action_542 _ = happyFail++action_543 _ = happyReduce_158++action_544 _ = happyReduce_155++action_545 (161) = happyShift action_20+action_545 (169) = happyShift action_23+action_545 (170) = happyShift action_24+action_545 (185) = happyShift action_27+action_545 (188) = happyShift action_29+action_545 (189) = happyShift action_582+action_545 (190) = happyShift action_583+action_545 (201) = happyShift action_584+action_545 (213) = happyShift action_34+action_545 (215) = happyShift action_36+action_545 (26) = happyGoto action_577+action_545 (27) = happyGoto action_578+action_545 (124) = happyGoto action_579+action_545 (126) = happyGoto action_580+action_545 (138) = happyGoto action_14+action_545 (139) = happyGoto action_354+action_545 (142) = happyGoto action_581+action_545 _ = happyFail++action_546 (190) = happyShift action_576+action_546 _ = happyFail++action_547 (161) = happyShift action_20+action_547 (169) = happyShift action_23+action_547 (170) = happyShift action_24+action_547 (185) = happyShift action_27+action_547 (188) = happyShift action_29+action_547 (189) = happyShift action_355+action_547 (213) = happyShift action_34+action_547 (215) = happyShift action_36+action_547 (25) = happyGoto action_575+action_547 (124) = happyGoto action_513+action_547 (138) = happyGoto action_14+action_547 (139) = happyGoto action_354+action_547 (142) = happyGoto action_514+action_547 (156) = happyGoto action_515+action_547 _ = happyReduce_18++action_548 _ = happyReduce_43++action_549 _ = happyReduce_173++action_550 _ = happyReduce_147++action_551 (190) = happyShift action_574+action_551 _ = happyFail++action_552 (161) = happyShift action_20+action_552 (169) = happyShift action_23+action_552 (170) = happyShift action_24+action_552 (185) = happyShift action_27+action_552 (188) = happyShift action_29+action_552 (189) = happyShift action_140+action_552 (213) = happyShift action_34+action_552 (214) = happyShift action_35+action_552 (49) = happyGoto action_571+action_552 (50) = happyGoto action_161+action_552 (69) = happyGoto action_572+action_552 (70) = happyGoto action_573+action_552 (125) = happyGoto action_227+action_552 (137) = happyGoto action_13+action_552 (138) = happyGoto action_14+action_552 (139) = happyGoto action_15+action_552 _ = happyFail++action_553 (161) = happyShift action_20+action_553 (170) = happyShift action_24+action_553 (185) = happyShift action_27+action_553 (188) = happyShift action_29+action_553 (189) = happyShift action_130+action_553 (196) = happyShift action_131+action_553 (212) = happyShift action_506+action_553 (213) = happyShift action_34+action_553 (215) = happyShift action_36+action_553 (216) = happyShift action_132+action_553 (52) = happyGoto action_569+action_553 (53) = happyGoto action_120+action_553 (56) = happyGoto action_121+action_553 (68) = happyGoto action_570+action_553 (138) = happyGoto action_124+action_553 (141) = happyGoto action_125+action_553 (142) = happyGoto action_126+action_553 (157) = happyGoto action_127+action_553 (160) = happyGoto action_128+action_553 _ = happyFail++action_554 (215) = happyShift action_36+action_554 (142) = happyGoto action_429+action_554 _ = happyFail++action_555 _ = happyReduce_144++action_556 _ = happyReduce_143++action_557 (161) = happyShift action_20+action_557 (170) = happyShift action_24+action_557 (185) = happyShift action_27+action_557 (188) = happyShift action_29+action_557 (189) = happyShift action_130+action_557 (196) = happyShift action_131+action_557 (213) = happyShift action_34+action_557 (215) = happyShift action_36+action_557 (216) = happyShift action_132+action_557 (53) = happyGoto action_568+action_557 (56) = happyGoto action_121+action_557 (138) = happyGoto action_124+action_557 (141) = happyGoto action_125+action_557 (142) = happyGoto action_126+action_557 (157) = happyGoto action_127+action_557 (160) = happyGoto action_128+action_557 _ = happyFail++action_558 (161) = happyShift action_20+action_558 (170) = happyShift action_24+action_558 (185) = happyShift action_27+action_558 (188) = happyShift action_29+action_558 (189) = happyShift action_505+action_558 (196) = happyShift action_131+action_558 (212) = happyShift action_506+action_558 (213) = happyShift action_34+action_558 (215) = happyShift action_36+action_558 (216) = happyShift action_132+action_558 (52) = happyGoto action_566+action_558 (53) = happyGoto action_120+action_558 (56) = happyGoto action_121+action_558 (64) = happyGoto action_567+action_558 (65) = happyGoto action_500+action_558 (66) = happyGoto action_501+action_558 (68) = happyGoto action_502+action_558 (126) = happyGoto action_503+action_558 (138) = happyGoto action_124+action_558 (141) = happyGoto action_125+action_558 (142) = happyGoto action_504+action_558 (157) = happyGoto action_127+action_558 (160) = happyGoto action_128+action_558 _ = happyFail++action_559 (161) = happyShift action_20+action_559 (170) = happyShift action_24+action_559 (185) = happyShift action_27+action_559 (188) = happyShift action_29+action_559 (189) = happyShift action_130+action_559 (196) = happyShift action_131+action_559 (213) = happyShift action_34+action_559 (215) = happyShift action_36+action_559 (216) = happyShift action_132+action_559 (53) = happyGoto action_565+action_559 (56) = happyGoto action_121+action_559 (138) = happyGoto action_124+action_559 (141) = happyGoto action_125+action_559 (142) = happyGoto action_126+action_559 (157) = happyGoto action_127+action_559 (160) = happyGoto action_128+action_559 _ = happyFail++action_560 _ = happyReduce_135++action_561 _ = happyReduce_81++action_562 (161) = happyShift action_20+action_562 (169) = happyShift action_129+action_562 (170) = happyShift action_24+action_562 (185) = happyShift action_27+action_562 (188) = happyShift action_29+action_562 (189) = happyShift action_130+action_562 (196) = happyShift action_131+action_562 (213) = happyShift action_34+action_562 (215) = happyShift action_36+action_562 (216) = happyShift action_132+action_562 (51) = happyGoto action_564+action_562 (52) = happyGoto action_303+action_562 (53) = happyGoto action_120+action_562 (56) = happyGoto action_121+action_562 (138) = happyGoto action_124+action_562 (141) = happyGoto action_125+action_562 (142) = happyGoto action_126+action_562 (157) = happyGoto action_127+action_562 (160) = happyGoto action_128+action_562 _ = happyFail++action_563 _ = happyReduce_80++action_564 _ = happyReduce_82++action_565 _ = happyReduce_142++action_566 (161) = happyShift action_20+action_566 (170) = happyShift action_24+action_566 (185) = happyShift action_27+action_566 (188) = happyShift action_29+action_566 (189) = happyShift action_130+action_566 (196) = happyShift action_131+action_566 (199) = happyReduce_146+action_566 (202) = happyReduce_146+action_566 (212) = happyShift action_559+action_566 (213) = happyShift action_34+action_566 (215) = happyShift action_36+action_566 (216) = happyShift action_132+action_566 (219) = happyReduce_146+action_566 (53) = happyGoto action_313+action_566 (56) = happyGoto action_121+action_566 (138) = happyGoto action_124+action_566 (141) = happyGoto action_125+action_566 (142) = happyGoto action_126+action_566 (157) = happyGoto action_127+action_566 (160) = happyGoto action_128+action_566 _ = happyReduce_139++action_567 _ = happyReduce_133++action_568 _ = happyReduce_145++action_569 (161) = happyShift action_20+action_569 (170) = happyShift action_24+action_569 (185) = happyShift action_27+action_569 (188) = happyShift action_29+action_569 (189) = happyShift action_130+action_569 (196) = happyShift action_131+action_569 (213) = happyShift action_34+action_569 (215) = happyShift action_36+action_569 (216) = happyShift action_132+action_569 (53) = happyGoto action_313+action_569 (56) = happyGoto action_121+action_569 (138) = happyGoto action_124+action_569 (141) = happyGoto action_125+action_569 (142) = happyGoto action_126+action_569 (157) = happyGoto action_127+action_569 (160) = happyGoto action_128+action_569 _ = happyReduce_146++action_570 _ = happyReduce_137++action_571 (198) = happyShift action_279+action_571 (203) = happyShift action_597+action_571 _ = happyFail++action_572 (193) = happyShift action_595+action_572 (198) = happyShift action_596+action_572 _ = happyFail++action_573 _ = happyReduce_149++action_574 (161) = happyShift action_20+action_574 (170) = happyShift action_24+action_574 (185) = happyShift action_27+action_574 (188) = happyShift action_29+action_574 (189) = happyShift action_130+action_574 (196) = happyShift action_131+action_574 (212) = happyShift action_557+action_574 (213) = happyShift action_34+action_574 (215) = happyShift action_36+action_574 (216) = happyShift action_132+action_574 (53) = happyGoto action_555+action_574 (56) = happyGoto action_121+action_574 (67) = happyGoto action_594+action_574 (138) = happyGoto action_124+action_574 (141) = happyGoto action_125+action_574 (142) = happyGoto action_126+action_574 (157) = happyGoto action_127+action_574 (160) = happyGoto action_128+action_574 _ = happyReduce_292++action_575 _ = happyReduce_45++action_576 _ = happyReduce_44++action_577 (190) = happyShift action_592+action_577 (198) = happyShift action_593+action_577 _ = happyFail++action_578 _ = happyReduce_53++action_579 _ = happyReduce_54++action_580 _ = happyReduce_55++action_581 _ = happyReduce_291++action_582 (200) = happyShift action_108+action_582 (202) = happyShift action_83+action_582 (212) = happyShift action_110+action_582 (217) = happyShift action_111+action_582 (218) = happyShift action_112+action_582 (219) = happyShift action_87+action_582 (144) = happyGoto action_591+action_582 (147) = happyGoto action_427+action_582 _ = happyFail++action_583 _ = happyReduce_50++action_584 (190) = happyShift action_590+action_584 _ = happyFail++action_585 _ = happyReduce_156++action_586 (215) = happyShift action_36+action_586 (216) = happyShift action_132+action_586 (141) = happyGoto action_518+action_586 (142) = happyGoto action_126+action_586 (157) = happyGoto action_127+action_586 (159) = happyGoto action_589+action_586 _ = happyFail++action_587 _ = happyReduce_165++action_588 _ = happyReduce_239++action_589 _ = happyReduce_157++action_590 _ = happyReduce_49++action_591 (190) = happyShift action_604+action_591 _ = happyFail++action_592 _ = happyReduce_51++action_593 (161) = happyShift action_20+action_593 (169) = happyShift action_23+action_593 (170) = happyShift action_24+action_593 (185) = happyShift action_27+action_593 (188) = happyShift action_29+action_593 (189) = happyShift action_582+action_593 (213) = happyShift action_34+action_593 (215) = happyShift action_36+action_593 (27) = happyGoto action_603+action_593 (124) = happyGoto action_579+action_593 (126) = happyGoto action_580+action_593 (138) = happyGoto action_14+action_593 (139) = happyGoto action_354+action_593 (142) = happyGoto action_581+action_593 _ = happyFail++action_594 (161) = happyShift action_20+action_594 (170) = happyShift action_24+action_594 (185) = happyShift action_27+action_594 (188) = happyShift action_29+action_594 (189) = happyShift action_130+action_594 (196) = happyShift action_131+action_594 (212) = happyShift action_557+action_594 (213) = happyShift action_34+action_594 (215) = happyShift action_36+action_594 (216) = happyShift action_132+action_594 (53) = happyGoto action_555+action_594 (56) = happyGoto action_121+action_594 (67) = happyGoto action_602+action_594 (138) = happyGoto action_124+action_594 (141) = happyGoto action_125+action_594 (142) = happyGoto action_126+action_594 (157) = happyGoto action_127+action_594 (160) = happyGoto action_128+action_594 _ = happyFail++action_595 _ = happyReduce_138++action_596 (161) = happyShift action_20+action_596 (169) = happyShift action_23+action_596 (170) = happyShift action_24+action_596 (185) = happyShift action_27+action_596 (188) = happyShift action_29+action_596 (189) = happyShift action_140+action_596 (213) = happyShift action_34+action_596 (214) = happyShift action_35+action_596 (49) = happyGoto action_571+action_596 (50) = happyGoto action_161+action_596 (70) = happyGoto action_601+action_596 (125) = happyGoto action_227+action_596 (137) = happyGoto action_13+action_596 (138) = happyGoto action_14+action_596 (139) = happyGoto action_15+action_596 _ = happyFail++action_597 (161) = happyShift action_20+action_597 (169) = happyShift action_129+action_597 (170) = happyShift action_24+action_597 (185) = happyShift action_27+action_597 (188) = happyShift action_29+action_597 (189) = happyShift action_130+action_597 (196) = happyShift action_131+action_597 (212) = happyShift action_600+action_597 (213) = happyShift action_34+action_597 (215) = happyShift action_36+action_597 (216) = happyShift action_132+action_597 (51) = happyGoto action_598+action_597 (52) = happyGoto action_303+action_597 (53) = happyGoto action_120+action_597 (56) = happyGoto action_121+action_597 (71) = happyGoto action_599+action_597 (138) = happyGoto action_124+action_597 (141) = happyGoto action_125+action_597 (142) = happyGoto action_126+action_597 (157) = happyGoto action_127+action_597 (160) = happyGoto action_128+action_597 _ = happyFail++action_598 _ = happyReduce_151++action_599 _ = happyReduce_150++action_600 (161) = happyShift action_20+action_600 (170) = happyShift action_24+action_600 (185) = happyShift action_27+action_600 (188) = happyShift action_29+action_600 (189) = happyShift action_130+action_600 (196) = happyShift action_131+action_600 (213) = happyShift action_34+action_600 (215) = happyShift action_36+action_600 (216) = happyShift action_132+action_600 (53) = happyGoto action_605+action_600 (56) = happyGoto action_121+action_600 (138) = happyGoto action_124+action_600 (141) = happyGoto action_125+action_600 (142) = happyGoto action_126+action_600 (157) = happyGoto action_127+action_600 (160) = happyGoto action_128+action_600 _ = happyFail++action_601 _ = happyReduce_148++action_602 _ = happyReduce_141++action_603 _ = happyReduce_52++action_604 _ = happyReduce_292++action_605 _ = happyReduce_152++happyReduce_2 = happyReduce 5 5 happyReduction_2+happyReduction_2 ((HappyAbsSyn6  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn10  happy_var_3) `HappyStk`+	(HappyAbsSyn155  happy_var_2) `HappyStk`+	(HappyTerminal ((Reservedid,(happy_var_1,"module")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn5+		 (hsModule happy_var_1 happy_var_2 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_3 = happySpecReduce_2  5 happyReduction_3+happyReduction_3 (HappyAbsSyn6  happy_var_2)+	(HappyAbsSyn152  happy_var_1)+	 =  HappyAbsSyn5+		 (hsMainModule happy_var_1 happy_var_2+	)+happyReduction_3 _ _  = notHappyAtAll ++happyReduce_4 = happySpecReduce_3  6 happyReduction_4+happyReduction_4 _+	(HappyAbsSyn6  happy_var_2)+	_+	 =  HappyAbsSyn6+		 (happy_var_2+	)+happyReduction_4 _ _ _  = notHappyAtAll ++happyReduce_5 = happySpecReduce_3  6 happyReduction_5+happyReduction_5 _+	(HappyAbsSyn6  happy_var_2)+	_+	 =  HappyAbsSyn6+		 (happy_var_2+	)+happyReduction_5 _ _ _  = notHappyAtAll ++happyReduce_6 = happyReduce 4 7 happyReduction_6+happyReduction_6 (_ `HappyStk`+	(HappyAbsSyn28  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn17  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn6+		 ((happy_var_1, happy_var_3)+	) `HappyStk` happyRest++happyReduce_7 = happySpecReduce_2  7 happyReduction_7+happyReduction_7 _+	(HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn6+		 (([], happy_var_1)+	)+happyReduction_7 _ _  = notHappyAtAll ++happyReduce_8 = happySpecReduce_2  7 happyReduction_8+happyReduction_8 _+	(HappyAbsSyn17  happy_var_1)+	 =  HappyAbsSyn6+		 ((happy_var_1, [])+	)+happyReduction_8 _ _  = notHappyAtAll ++happyReduce_9 = happySpecReduce_0  7 happyReduction_9+happyReduction_9  =  HappyAbsSyn6+		 (([], [])+	)++happyReduce_10 = happySpecReduce_2  8 happyReduction_10+happyReduction_10 _+	_+	 =  HappyAbsSyn8+		 (()+	)++happyReduce_11 = happySpecReduce_1  8 happyReduction_11+happyReduction_11 _+	 =  HappyAbsSyn8+		 (()+	)++happyReduce_12 = happySpecReduce_2  9 happyReduction_12+happyReduction_12 _+	_+	 =  HappyAbsSyn8+		 (()+	)++happyReduce_13 = happySpecReduce_0  9 happyReduction_13+happyReduction_13  =  HappyAbsSyn8+		 (()+	)++happyReduce_14 = happySpecReduce_1  10 happyReduction_14+happyReduction_14 (HappyAbsSyn11  happy_var_1)+	 =  HappyAbsSyn10+		 (Just happy_var_1+	)+happyReduction_14 _  = notHappyAtAll ++happyReduce_15 = happySpecReduce_0  10 happyReduction_15+happyReduction_15  =  HappyAbsSyn10+		 (Nothing+	)++happyReduce_16 = happyReduce 5 11 happyReduction_16+happyReduction_16 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn11  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn11+		 (reverse happy_var_3+	) `HappyStk` happyRest++happyReduce_17 = happySpecReduce_2  11 happyReduction_17+happyReduction_17 _+	_+	 =  HappyAbsSyn11+		 ([]+	)++happyReduce_18 = happySpecReduce_1  12 happyReduction_18+happyReduction_18 _+	 =  HappyAbsSyn8+		 (()+	)++happyReduce_19 = happySpecReduce_0  12 happyReduction_19+happyReduction_19  =  HappyAbsSyn8+		 (()+	)++happyReduce_20 = happySpecReduce_3  13 happyReduction_20+happyReduction_20 (HappyAbsSyn14  happy_var_3)+	_+	(HappyAbsSyn11  happy_var_1)+	 =  HappyAbsSyn11+		 (happy_var_3 : happy_var_1+	)+happyReduction_20 _ _ _  = notHappyAtAll ++happyReduce_21 = happySpecReduce_1  13 happyReduction_21+happyReduction_21 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn11+		 ([happy_var_1]+	)+happyReduction_21 _  = notHappyAtAll ++happyReduce_22 = happySpecReduce_1  14 happyReduction_22+happyReduction_22 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn14+		 (EntE (Var happy_var_1)+	)+happyReduction_22 _  = notHappyAtAll ++happyReduce_23 = happySpecReduce_1  14 happyReduction_23+happyReduction_23 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn14+		 (EntE (Abs happy_var_1)+	)+happyReduction_23 _  = notHappyAtAll ++happyReduce_24 = happyReduce 4 14 happyReduction_24+happyReduction_24 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn14+		 (EntE (AllSubs happy_var_1)+	) `HappyStk` happyRest++happyReduce_25 = happySpecReduce_3  14 happyReduction_25+happyReduction_25 _+	_+	(HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn14+		 (EntE (ListSubs happy_var_1 [])+	)+happyReduction_25 _ _ _  = notHappyAtAll ++happyReduce_26 = happyReduce 4 14 happyReduction_26+happyReduction_26 (_ `HappyStk`+	(HappyAbsSyn15  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn14+		 (EntE (ListSubs happy_var_1 (reverse happy_var_3))+	) `HappyStk` happyRest++happyReduce_27 = happySpecReduce_2  14 happyReduction_27+happyReduction_27 (HappyAbsSyn155  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (ModuleE happy_var_2+	)+happyReduction_27 _ _  = notHappyAtAll ++happyReduce_28 = happySpecReduce_3  15 happyReduction_28+happyReduction_28 (HappyAbsSyn16  happy_var_3)+	_+	(HappyAbsSyn15  happy_var_1)+	 =  HappyAbsSyn15+		 (happy_var_3 : happy_var_1+	)+happyReduction_28 _ _ _  = notHappyAtAll ++happyReduce_29 = happySpecReduce_1  15 happyReduction_29+happyReduction_29 (HappyAbsSyn16  happy_var_1)+	 =  HappyAbsSyn15+		 ([happy_var_1]+	)+happyReduction_29 _  = notHappyAtAll ++happyReduce_30 = happySpecReduce_1  16 happyReduction_30+happyReduction_30 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn16+		 (HsVar happy_var_1+	)+happyReduction_30 _  = notHappyAtAll ++happyReduce_31 = happySpecReduce_1  16 happyReduction_31+happyReduction_31 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn16+		 (HsCon happy_var_1+	)+happyReduction_31 _  = notHappyAtAll ++happyReduce_32 = happySpecReduce_3  17 happyReduction_32+happyReduction_32 (HappyAbsSyn18  happy_var_3)+	_+	(HappyAbsSyn17  happy_var_1)+	 =  HappyAbsSyn17+		 (happy_var_3 : happy_var_1+	)+happyReduction_32 _ _ _  = notHappyAtAll ++happyReduce_33 = happySpecReduce_1  17 happyReduction_33+happyReduction_33 (HappyAbsSyn18  happy_var_1)+	 =  HappyAbsSyn17+		 ([happy_var_1]+	)+happyReduction_33 _  = notHappyAtAll ++happyReduce_34 = happyReduce 5 18 happyReduction_34+happyReduction_34 ((HappyAbsSyn21  happy_var_5) `HappyStk`+	(HappyAbsSyn20  happy_var_4) `HappyStk`+	(HappyAbsSyn155  happy_var_3) `HappyStk`+	(HappyAbsSyn19  happy_var_2) `HappyStk`+	(HappyTerminal ((Reservedid,(happy_var_1,"import")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn18+		 (HsImportDecl happy_var_1 happy_var_3 happy_var_2 happy_var_4 happy_var_5+	) `HappyStk` happyRest++happyReduce_35 = happySpecReduce_1  19 happyReduction_35+happyReduction_35 _+	 =  HappyAbsSyn19+		 (True+	)++happyReduce_36 = happySpecReduce_0  19 happyReduction_36+happyReduction_36  =  HappyAbsSyn19+		 (False+	)++happyReduce_37 = happySpecReduce_2  20 happyReduction_37+happyReduction_37 (HappyAbsSyn155  happy_var_2)+	_+	 =  HappyAbsSyn20+		 (Just happy_var_2+	)+happyReduction_37 _ _  = notHappyAtAll ++happyReduce_38 = happySpecReduce_0  20 happyReduction_38+happyReduction_38  =  HappyAbsSyn20+		 (Nothing+	)++happyReduce_39 = happySpecReduce_1  21 happyReduction_39+happyReduction_39 (HappyAbsSyn22  happy_var_1)+	 =  HappyAbsSyn21+		 (Just happy_var_1+	)+happyReduction_39 _  = notHappyAtAll ++happyReduce_40 = happySpecReduce_0  21 happyReduction_40+happyReduction_40  =  HappyAbsSyn21+		 (Nothing+	)++happyReduce_41 = happySpecReduce_1  22 happyReduction_41+happyReduction_41 (HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn22+		 ((False, reverse happy_var_1)+	)+happyReduction_41 _  = notHappyAtAll ++happyReduce_42 = happySpecReduce_2  22 happyReduction_42+happyReduction_42 (HappyAbsSyn23  happy_var_2)+	_+	 =  HappyAbsSyn22+		 ((True,  reverse happy_var_2)+	)+happyReduction_42 _ _  = notHappyAtAll ++happyReduce_43 = happySpecReduce_3  23 happyReduction_43+happyReduction_43 _+	_+	_+	 =  HappyAbsSyn23+		 ([]+	)++happyReduce_44 = happyReduce 4 23 happyReduction_44+happyReduction_44 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn23  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn23+		 (happy_var_2+	) `HappyStk` happyRest++happyReduce_45 = happySpecReduce_3  24 happyReduction_45+happyReduction_45 (HappyAbsSyn25  happy_var_3)+	_+	(HappyAbsSyn23  happy_var_1)+	 =  HappyAbsSyn23+		 (happy_var_3 : happy_var_1+	)+happyReduction_45 _ _ _  = notHappyAtAll ++happyReduce_46 = happySpecReduce_1  24 happyReduction_46+happyReduction_46 (HappyAbsSyn25  happy_var_1)+	 =  HappyAbsSyn23+		 ([happy_var_1]+	)+happyReduction_46 _  = notHappyAtAll ++happyReduce_47 = happySpecReduce_1  25 happyReduction_47+happyReduction_47 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn25+		 (Var happy_var_1+	)+happyReduction_47 _  = notHappyAtAll ++happyReduce_48 = happySpecReduce_1  25 happyReduction_48+happyReduction_48 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn25+		 (Abs happy_var_1+	)+happyReduction_48 _  = notHappyAtAll ++happyReduce_49 = happyReduce 4 25 happyReduction_49+happyReduction_49 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn25+		 (AllSubs happy_var_1+	) `HappyStk` happyRest++happyReduce_50 = happySpecReduce_3  25 happyReduction_50+happyReduction_50 _+	_+	(HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn25+		 (ListSubs happy_var_1 []+	)+happyReduction_50 _ _ _  = notHappyAtAll ++happyReduce_51 = happyReduce 4 25 happyReduction_51+happyReduction_51 (_ `HappyStk`+	(HappyAbsSyn15  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn25+		 (ListSubs happy_var_1 (reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_52 = happySpecReduce_3  26 happyReduction_52+happyReduction_52 (HappyAbsSyn16  happy_var_3)+	_+	(HappyAbsSyn15  happy_var_1)+	 =  HappyAbsSyn15+		 (happy_var_3 : happy_var_1+	)+happyReduction_52 _ _ _  = notHappyAtAll ++happyReduce_53 = happySpecReduce_1  26 happyReduction_53+happyReduction_53 (HappyAbsSyn16  happy_var_1)+	 =  HappyAbsSyn15+		 ([happy_var_1]+	)+happyReduction_53 _  = notHappyAtAll ++happyReduce_54 = happySpecReduce_1  27 happyReduction_54+happyReduction_54 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn16+		 (HsVar happy_var_1+	)+happyReduction_54 _  = notHappyAtAll ++happyReduce_55 = happySpecReduce_1  27 happyReduction_55+happyReduction_55 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn16+		 (HsCon happy_var_1+	)+happyReduction_55 _  = notHappyAtAll ++happyReduce_56 = happySpecReduce_3  28 happyReduction_56+happyReduction_56 (HappyAbsSyn28  happy_var_3)+	_+	(HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (foldl (flip funCons) happy_var_1 happy_var_3+	)+happyReduction_56 _ _ _  = notHappyAtAll ++happyReduce_57 = happySpecReduce_1  28 happyReduction_57+happyReduction_57 (HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (happy_var_1+	)+happyReduction_57 _  = notHappyAtAll ++happyReduce_58 = happySpecReduce_3  29 happyReduction_58+happyReduction_58 (HappyAbsSyn15  happy_var_3)+	(HappyAbsSyn30  happy_var_2)+	(HappyAbsSyn31  happy_var_1)+	 =  HappyAbsSyn29+		 (hsInfixDecl (fst happy_var_1) (HsFixity (snd happy_var_1) happy_var_2) happy_var_3+	)+happyReduction_58 _ _ _  = notHappyAtAll ++happyReduce_59 = happySpecReduce_0  30 happyReduction_59+happyReduction_59  =  HappyAbsSyn30+		 (9+	)++happyReduce_60 = happySpecReduce_1  30 happyReduction_60+happyReduction_60 (HappyTerminal ((IntLit,happy_var_1)))+	 =  HappyAbsSyn30+		 (fromInteger (readInteger (snd happy_var_1))+	)+happyReduction_60 _  = notHappyAtAll ++happyReduce_61 = happySpecReduce_1  31 happyReduction_61+happyReduction_61 (HappyTerminal ((Reservedid,(happy_var_1,"infix"))))+	 =  HappyAbsSyn31+		 ((happy_var_1,HsAssocNone)+	)+happyReduction_61 _  = notHappyAtAll ++happyReduce_62 = happySpecReduce_1  31 happyReduction_62+happyReduction_62 (HappyTerminal ((Reservedid,(happy_var_1,"infixl"))))+	 =  HappyAbsSyn31+		 ((happy_var_1,HsAssocLeft)+	)+happyReduction_62 _  = notHappyAtAll ++happyReduce_63 = happySpecReduce_1  31 happyReduction_63+happyReduction_63 (HappyTerminal ((Reservedid,(happy_var_1,"infixr"))))+	 =  HappyAbsSyn31+		 ((happy_var_1,HsAssocRight)+	)+happyReduction_63 _  = notHappyAtAll ++happyReduce_64 = happySpecReduce_3  32 happyReduction_64+happyReduction_64 (HappyAbsSyn15  happy_var_3)+	_+	(HappyAbsSyn16  happy_var_1)+	 =  HappyAbsSyn15+		 (happy_var_1 : happy_var_3+	)+happyReduction_64 _ _ _  = notHappyAtAll ++happyReduce_65 = happySpecReduce_1  32 happyReduction_65+happyReduction_65 (HappyAbsSyn16  happy_var_1)+	 =  HappyAbsSyn15+		 ([happy_var_1]+	)+happyReduction_65 _  = notHappyAtAll ++happyReduce_66 = happyReduce 5 33 happyReduction_66+happyReduction_66 ((HappyAbsSyn51  happy_var_5) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn42  happy_var_2) `HappyStk`+	(HappyTerminal ((Varid     ,(happy_var_1,"primitive")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn28+		 ([hsPrimitiveBind happy_var_1 v happy_var_5|v<-happy_var_2]+	) `HappyStk` happyRest++happyReduce_67 = happySpecReduce_1  33 happyReduction_67+happyReduction_67 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn28+		 ([happy_var_1]+	)+happyReduction_67 _  = notHappyAtAll ++happyReduce_68 = happySpecReduce_0  34 happyReduction_68+happyReduction_68  =  HappyAbsSyn34+		 (Nothing+	)++happyReduce_69 = happySpecReduce_1  34 happyReduction_69+happyReduction_69 (HappyAbsSyn38  happy_var_1)+	 =  HappyAbsSyn34+		 (Just happy_var_1+	)+happyReduction_69 _  = notHappyAtAll ++happyReduce_70 = happySpecReduce_1  35 happyReduction_70+happyReduction_70 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn29+		 (happy_var_1+	)+happyReduction_70 _  = notHappyAtAll ++happyReduce_71 = happyReduce 4 35 happyReduction_71+happyReduction_71 ((HappyAbsSyn51  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn51  happy_var_2) `HappyStk`+	(HappyTerminal ((Reservedid,(happy_var_1,"type")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (hsTypeDecl happy_var_1 happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_72 = happyReduce 5 35 happyReduction_72+happyReduction_72 ((HappyAbsSyn42  happy_var_5) `HappyStk`+	(HappyAbsSyn61  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn60  happy_var_2) `HappyStk`+	(HappyTerminal ((Reservedid,(happy_var_1,"data")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (uncurry (hsDataDecl happy_var_1) happy_var_2 (reverse happy_var_4) happy_var_5+	) `HappyStk` happyRest++happyReduce_73 = happyMonadReduce 5 35 happyReduction_73+happyReduction_73 ((HappyAbsSyn42  happy_var_5) `HappyStk`+	(HappyAbsSyn62  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn60  happy_var_2) `HappyStk`+	(HappyTerminal ((Reservedid,(happy_var_1,"newtype")))) `HappyStk`+	happyRest) tk+	 = happyThen (( chkNewtype happy_var_4 >> return (uncurry (hsNewTypeDecl happy_var_1) happy_var_2 happy_var_4 happy_var_5))+	) (\r -> happyReturn (HappyAbsSyn29 r))++happyReduce_74 = happyReduce 4 35 happyReduction_74+happyReduction_74 ((HappyAbsSyn28  happy_var_4) `HappyStk`+	(HappyAbsSyn39  happy_var_3) `HappyStk`+	(HappyAbsSyn60  happy_var_2) `HappyStk`+	(HappyTerminal ((Reservedid,(happy_var_1,"class")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (uncurry (hsClassDecl happy_var_1) happy_var_2 happy_var_3 happy_var_4+	) `HappyStk` happyRest++happyReduce_75 = happySpecReduce_3  35 happyReduction_75+happyReduction_75 (HappyAbsSyn28  happy_var_3)+	(HappyAbsSyn57  happy_var_2)+	(HappyTerminal ((Reservedid,(happy_var_1,"instance"))))+	 =  HappyAbsSyn29+		 (uncurry (hsInstDecl happy_var_1 Nothing) happy_var_2 happy_var_3+	)+happyReduction_75 _ _ _  = notHappyAtAll ++happyReduce_76 = happyReduce 4 35 happyReduction_76+happyReduction_76 (_ `HappyStk`+	(HappyAbsSyn54  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyTerminal ((Reservedid,(happy_var_1,"default")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (hsDefaultDecl happy_var_1 happy_var_3+	) `HappyStk` happyRest++happyReduce_77 = happySpecReduce_2  35 happyReduction_77+happyReduction_77 (HappyAbsSyn60  happy_var_2)+	(HappyTerminal ((Reservedid,(happy_var_1,"data"))))+	 =  HappyAbsSyn29+		 (uncurry (hsPrimitiveTypeDecl happy_var_1) happy_var_2+	)+happyReduction_77 _ _  = notHappyAtAll ++happyReduce_78 = happyReduce 5 35 happyReduction_78+happyReduction_78 ((HappyAbsSyn51  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyTerminal ((Varid     ,(happy_var_1,"foreign")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (hsPrimitiveBind happy_var_1 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_79 = happyReduce 6 35 happyReduction_79+happyReduction_79 ((HappyAbsSyn51  happy_var_6) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_4) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal ((Varid     ,(happy_var_1,"foreign")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (hsPrimitiveBind happy_var_1 happy_var_4 happy_var_6+	) `HappyStk` happyRest++happyReduce_80 = happyReduce 7 35 happyReduction_80+happyReduction_80 ((HappyAbsSyn51  happy_var_7) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_5) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal ((Varid     ,(happy_var_1,"foreign")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (hsPrimitiveBind happy_var_1 happy_var_5 happy_var_7+	) `HappyStk` happyRest++happyReduce_81 = happyReduce 7 35 happyReduction_81+happyReduction_81 ((HappyAbsSyn51  happy_var_7) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_5) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal ((Varid     ,(happy_var_1,"foreign")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (hsPrimitiveBind happy_var_1 happy_var_5 happy_var_7+	) `HappyStk` happyRest++happyReduce_82 = happyReduce 8 35 happyReduction_82+happyReduction_82 ((HappyAbsSyn51  happy_var_8) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_6) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal ((Varid     ,(happy_var_1,"foreign")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (hsPrimitiveBind happy_var_1 happy_var_6 happy_var_8+	) `HappyStk` happyRest++happyReduce_83 = happySpecReduce_1  36 happyReduction_83+happyReduction_83 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_83 _  = notHappyAtAll ++happyReduce_84 = happySpecReduce_1  37 happyReduction_84+happyReduction_84 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_84 _  = notHappyAtAll ++happyReduce_85 = happySpecReduce_1  38 happyReduction_85+happyReduction_85 (HappyTerminal ((StringLit,happy_var_1)))+	 =  HappyAbsSyn38+		 (snd happy_var_1+	)+happyReduction_85 _  = notHappyAtAll ++happyReduce_86 = happySpecReduce_0  39 happyReduction_86+happyReduction_86  =  HappyAbsSyn39+		 ([]+	)++happyReduce_87 = happySpecReduce_2  39 happyReduction_87+happyReduction_87 (HappyAbsSyn39  happy_var_2)+	_+	 =  HappyAbsSyn39+		 (happy_var_2+	)+happyReduction_87 _ _  = notHappyAtAll ++happyReduce_88 = happySpecReduce_1  40 happyReduction_88+happyReduction_88 (HappyAbsSyn41  happy_var_1)+	 =  HappyAbsSyn39+		 ([happy_var_1]+	)+happyReduction_88 _  = notHappyAtAll ++happyReduce_89 = happySpecReduce_3  40 happyReduction_89+happyReduction_89 (HappyAbsSyn39  happy_var_3)+	_+	(HappyAbsSyn41  happy_var_1)+	 =  HappyAbsSyn39+		 (happy_var_1:happy_var_3+	)+happyReduction_89 _ _ _  = notHappyAtAll ++happyReduce_90 = happySpecReduce_3  41 happyReduction_90+happyReduction_90 (HappyAbsSyn42  happy_var_3)+	_+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn41+		 ((happy_var_1,happy_var_3)+	)+happyReduction_90 _ _ _  = notHappyAtAll ++happyReduce_91 = happySpecReduce_0  42 happyReduction_91+happyReduction_91  =  HappyAbsSyn42+		 ([]+	)++happyReduce_92 = happySpecReduce_2  42 happyReduction_92+happyReduction_92 (HappyAbsSyn42  happy_var_2)+	(HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn42+		 (happy_var_1:happy_var_2+	)+happyReduction_92 _ _  = notHappyAtAll ++happyReduce_93 = happySpecReduce_2  43 happyReduction_93+happyReduction_93 _+	(HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (reverse happy_var_1+	)+happyReduction_93 _ _  = notHappyAtAll ++happyReduce_94 = happySpecReduce_1  43 happyReduction_94+happyReduction_94 _+	 =  HappyAbsSyn28+		 ([]+	)++happyReduce_95 = happySpecReduce_3  44 happyReduction_95+happyReduction_95 (HappyAbsSyn29  happy_var_3)+	_+	(HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (funCons happy_var_3 happy_var_1+	)+happyReduction_95 _ _ _  = notHappyAtAll ++happyReduce_96 = happySpecReduce_1  44 happyReduction_96+happyReduction_96 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn28+		 ([happy_var_1]+	)+happyReduction_96 _  = notHappyAtAll ++happyReduce_97 = happySpecReduce_1  45 happyReduction_97+happyReduction_97 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn29+		 (happy_var_1+	)+happyReduction_97 _  = notHappyAtAll ++happyReduce_98 = happySpecReduce_1  45 happyReduction_98+happyReduction_98 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn29+		 (happy_var_1+	)+happyReduction_98 _  = notHappyAtAll ++happyReduce_99 = happySpecReduce_1  46 happyReduction_99+happyReduction_99 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn29+		 (happy_var_1+	)+happyReduction_99 _  = notHappyAtAll ++happyReduce_100 = happySpecReduce_1  46 happyReduction_100+happyReduction_100 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn29+		 (happy_var_1+	)+happyReduction_100 _  = notHappyAtAll ++happyReduce_101 = happySpecReduce_3  47 happyReduction_101+happyReduction_101 _+	(HappyAbsSyn28  happy_var_2)+	_+	 =  HappyAbsSyn28+		 (happy_var_2+	)+happyReduction_101 _ _ _  = notHappyAtAll ++happyReduce_102 = happySpecReduce_3  47 happyReduction_102+happyReduction_102 _+	(HappyAbsSyn28  happy_var_2)+	_+	 =  HappyAbsSyn28+		 (happy_var_2+	)+happyReduction_102 _ _ _  = notHappyAtAll ++happyReduce_103 = happySpecReduce_3  48 happyReduction_103+happyReduction_103 (HappyAbsSyn57  happy_var_3)+	(HappyTerminal ((Reservedop,(happy_var_2,"::"))))+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn29+		 (uncurry (hsTypeSig happy_var_2 (reverse happy_var_1)) happy_var_3+	)+happyReduction_103 _ _ _  = notHappyAtAll ++happyReduce_104 = happySpecReduce_3  49 happyReduction_104+happyReduction_104 (HappyAbsSyn36  happy_var_3)+	_+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn42+		 (happy_var_3 : happy_var_1+	)+happyReduction_104 _ _ _  = notHappyAtAll ++happyReduce_105 = happySpecReduce_1  49 happyReduction_105+happyReduction_105 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn42+		 ([happy_var_1]+	)+happyReduction_105 _  = notHappyAtAll ++happyReduce_106 = happyMonadReduce 1 50 happyReduction_106+happyReduction_106 ((HappyAbsSyn36  happy_var_1) `HappyStk`+	happyRest) tk+	 = happyThen (( if isQualified happy_var_1+				   then fail "Qualified names not allowed here ."+				   else return happy_var_1)+	) (\r -> happyReturn (HappyAbsSyn36 r))++happyReduce_107 = happySpecReduce_3  51 happyReduction_107+happyReduction_107 (HappyAbsSyn51  happy_var_3)+	_+	(HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn51+		 (hsTyFun happy_var_1 happy_var_3+	)+happyReduction_107 _ _ _  = notHappyAtAll ++happyReduce_108 = happySpecReduce_1  51 happyReduction_108+happyReduction_108 (HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn51+		 (happy_var_1+	)+happyReduction_108 _  = notHappyAtAll ++happyReduce_109 = happyReduce 4 51 happyReduction_109+happyReduction_109 ((HappyAbsSyn57  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn42  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn51+		 (uncurry (hsTyForall happy_var_2) happy_var_4+	) `HappyStk` happyRest++happyReduce_110 = happySpecReduce_2  52 happyReduction_110+happyReduction_110 (HappyAbsSyn51  happy_var_2)+	(HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn51+		 (hsTyApp happy_var_1 happy_var_2+	)+happyReduction_110 _ _  = notHappyAtAll ++happyReduce_111 = happySpecReduce_1  52 happyReduction_111+happyReduction_111 (HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn51+		 (happy_var_1+	)+happyReduction_111 _  = notHappyAtAll ++happyReduce_112 = happySpecReduce_1  53 happyReduction_112+happyReduction_112 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn51+		 (hsTyCon happy_var_1+	)+happyReduction_112 _  = notHappyAtAll ++happyReduce_113 = happySpecReduce_1  53 happyReduction_113+happyReduction_113 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn51+		 (hsTyVar happy_var_1+	)+happyReduction_113 _  = notHappyAtAll ++happyReduce_114 = happySpecReduce_3  53 happyReduction_114+happyReduction_114 _+	(HappyAbsSyn51  happy_var_2)+	(HappyTerminal ((Special,(happy_var_1,"["))))+	 =  HappyAbsSyn51+		 (hsTyApp (list_tycon happy_var_1) happy_var_2+	)+happyReduction_114 _ _ _  = notHappyAtAll ++happyReduce_115 = happySpecReduce_3  53 happyReduction_115+happyReduction_115 _+	(HappyAbsSyn54  happy_var_2)+	(HappyTerminal ((Special,(happy_var_1,"("))))+	 =  HappyAbsSyn51+		 (case happy_var_2 of+					    [t] -> t+					    ts -> hsTyTuple happy_var_1 ts+	)+happyReduction_115 _ _ _  = notHappyAtAll ++happyReduce_116 = happySpecReduce_0  54 happyReduction_116+happyReduction_116  =  HappyAbsSyn54+		 ([]+	)++happyReduce_117 = happySpecReduce_1  54 happyReduction_117+happyReduction_117 (HappyAbsSyn54  happy_var_1)+	 =  HappyAbsSyn54+		 (happy_var_1+	)+happyReduction_117 _  = notHappyAtAll ++happyReduce_118 = happySpecReduce_3  55 happyReduction_118+happyReduction_118 (HappyAbsSyn54  happy_var_3)+	_+	(HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn54+		 (happy_var_1 : happy_var_3+	)+happyReduction_118 _ _ _  = notHappyAtAll ++happyReduce_119 = happySpecReduce_1  55 happyReduction_119+happyReduction_119 (HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn54+		 ([happy_var_1]+	)+happyReduction_119 _  = notHappyAtAll ++happyReduce_120 = happySpecReduce_1  56 happyReduction_120+happyReduction_120 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_120 _  = notHappyAtAll ++happyReduce_121 = happySpecReduce_2  56 happyReduction_121+happyReduction_121 _+	(HappyTerminal ((Special,(happy_var_1,"("))))+	 =  HappyAbsSyn36+		 (unit_tycon_name happy_var_1+	)+happyReduction_121 _ _  = notHappyAtAll ++happyReduce_122 = happySpecReduce_2  56 happyReduction_122+happyReduction_122 _+	(HappyTerminal ((Special,(happy_var_1,"["))))+	 =  HappyAbsSyn36+		 (list_tycon_name happy_var_1+	)+happyReduction_122 _ _  = notHappyAtAll ++happyReduce_123 = happySpecReduce_3  56 happyReduction_123+happyReduction_123 _+	_+	(HappyTerminal ((Special,(happy_var_1,"("))))+	 =  HappyAbsSyn36+		 (fun_tycon_name happy_var_1+	)+happyReduction_123 _ _ _  = notHappyAtAll ++happyReduce_124 = happySpecReduce_3  56 happyReduction_124+happyReduction_124 _+	(HappyAbsSyn30  happy_var_2)+	(HappyTerminal ((Special,(happy_var_1,"("))))+	 =  HappyAbsSyn36+		 (tuple_tycon_name happy_var_2 happy_var_1+	)+happyReduction_124 _ _ _  = notHappyAtAll ++happyReduce_125 = happySpecReduce_3  57 happyReduction_125+happyReduction_125 (HappyAbsSyn51  happy_var_3)+	_+	(HappyAbsSyn54  happy_var_1)+	 =  HappyAbsSyn57+		 ((happy_var_1, happy_var_3)+	)+happyReduction_125 _ _ _  = notHappyAtAll ++happyReduce_126 = happySpecReduce_1  57 happyReduction_126+happyReduction_126 (HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn57+		 (([], happy_var_1)+	)+happyReduction_126 _  = notHappyAtAll ++happyReduce_127 = happySpecReduce_1  58 happyReduction_127+happyReduction_127 (HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn54+		 (tupleTypeToContext happy_var_1+	)+happyReduction_127 _  = notHappyAtAll ++happyReduce_128 = happySpecReduce_2  59 happyReduction_128+happyReduction_128 (HappyAbsSyn42  happy_var_2)+	(HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn51+		 (foldl1 hsTyApp (hsTyCon happy_var_1:map hsTyVar happy_var_2)+	)+happyReduction_128 _ _  = notHappyAtAll ++happyReduce_129 = happyMonadReduce 1 60 happyReduction_129+happyReduction_129 ((HappyAbsSyn57  happy_var_1) `HappyStk`+	happyRest) tk+	 = happyThen (( chkTypeLhs happy_var_1)+	) (\r -> happyReturn (HappyAbsSyn60 r))++happyReduce_130 = happySpecReduce_3  61 happyReduction_130+happyReduction_130 (HappyAbsSyn62  happy_var_3)+	_+	(HappyAbsSyn61  happy_var_1)+	 =  HappyAbsSyn61+		 (happy_var_3 : happy_var_1+	)+happyReduction_130 _ _ _  = notHappyAtAll ++happyReduce_131 = happySpecReduce_1  61 happyReduction_131+happyReduction_131 (HappyAbsSyn62  happy_var_1)+	 =  HappyAbsSyn61+		 ([happy_var_1]+	)+happyReduction_131 _  = notHappyAtAll ++happyReduce_132 = happySpecReduce_3  62 happyReduction_132+happyReduction_132 (HappyAbsSyn64  happy_var_3)+	(HappyAbsSyn42  happy_var_2)+	(HappyAbsSyn152  happy_var_1)+	 =  HappyAbsSyn62+		 (happy_var_3 happy_var_1 happy_var_2 []+	)+happyReduction_132 _ _ _  = notHappyAtAll ++happyReduce_133 = happyReduce 5 62 happyReduction_133+happyReduction_133 ((HappyAbsSyn64  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn54  happy_var_3) `HappyStk`+	(HappyAbsSyn42  happy_var_2) `HappyStk`+	(HappyAbsSyn152  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn62+		 (happy_var_5 happy_var_1 happy_var_2 happy_var_3+	) `HappyStk` happyRest++happyReduce_134 = happySpecReduce_0  63 happyReduction_134+happyReduction_134  =  HappyAbsSyn42+		 ([]+	)++happyReduce_135 = happySpecReduce_3  63 happyReduction_135+happyReduction_135 _+	(HappyAbsSyn42  happy_var_2)+	_+	 =  HappyAbsSyn42+		 (happy_var_2+	)+happyReduction_135 _ _ _  = notHappyAtAll ++happyReduce_136 = happySpecReduce_1  64 happyReduction_136+happyReduction_136 (HappyAbsSyn65  happy_var_1)+	 =  HappyAbsSyn64+		 (conD happy_var_1+	)+happyReduction_136 _  = notHappyAtAll ++happyReduce_137 = happySpecReduce_3  64 happyReduction_137+happyReduction_137 (HappyAbsSyn67  happy_var_3)+	(HappyAbsSyn36  happy_var_2)+	(HappyAbsSyn67  happy_var_1)+	 =  HappyAbsSyn64+		 (conD (happy_var_2,[happy_var_1,happy_var_3])+	)+happyReduction_137 _ _ _  = notHappyAtAll ++happyReduce_138 = happyReduce 4 64 happyReduction_138+happyReduction_138 (_ `HappyStk`+	(HappyAbsSyn69  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn64+		 (fconD happy_var_1 (reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_139 = happyMonadReduce 1 65 happyReduction_139+happyReduction_139 ((HappyAbsSyn51  happy_var_1) `HappyStk`+	happyRest) tk+	 = happyThen (( do { (c, ts) <- splitTyConApp happy_var_1 ;+					    return (c, map HsUnBangedType ts)+					  })+	) (\r -> happyReturn (HappyAbsSyn65 r))++happyReduce_140 = happySpecReduce_1  65 happyReduction_140+happyReduction_140 (HappyAbsSyn65  happy_var_1)+	 =  HappyAbsSyn65+		 (happy_var_1+	)+happyReduction_140 _  = notHappyAtAll ++happyReduce_141 = happyReduce 5 65 happyReduction_141+happyReduction_141 ((HappyAbsSyn67  happy_var_5) `HappyStk`+	(HappyAbsSyn67  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn65+		 ((happy_var_2,[happy_var_4,happy_var_5])+	) `HappyStk` happyRest++happyReduce_142 = happyMonadReduce 3 66 happyReduction_142+happyReduction_142 ((HappyAbsSyn51  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn51  happy_var_1) `HappyStk`+	happyRest) tk+	 = happyThen (( do { (c, ts) <- splitTyConApp happy_var_1 ;+		      return (c, map HsUnBangedType ts ++ [HsBangedType happy_var_3])+		    })+	) (\r -> happyReturn (HappyAbsSyn65 r))++happyReduce_143 = happySpecReduce_2  66 happyReduction_143+happyReduction_143 (HappyAbsSyn67  happy_var_2)+	(HappyAbsSyn65  happy_var_1)+	 =  HappyAbsSyn65+		 ((fst happy_var_1, snd happy_var_1 ++ [happy_var_2] )+	)+happyReduction_143 _ _  = notHappyAtAll ++happyReduce_144 = happySpecReduce_1  67 happyReduction_144+happyReduction_144 (HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn67+		 (HsUnBangedType happy_var_1+	)+happyReduction_144 _  = notHappyAtAll ++happyReduce_145 = happySpecReduce_2  67 happyReduction_145+happyReduction_145 (HappyAbsSyn51  happy_var_2)+	_+	 =  HappyAbsSyn67+		 (HsBangedType   happy_var_2+	)+happyReduction_145 _ _  = notHappyAtAll ++happyReduce_146 = happySpecReduce_1  68 happyReduction_146+happyReduction_146 (HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn67+		 (HsUnBangedType happy_var_1+	)+happyReduction_146 _  = notHappyAtAll ++happyReduce_147 = happySpecReduce_2  68 happyReduction_147+happyReduction_147 (HappyAbsSyn51  happy_var_2)+	_+	 =  HappyAbsSyn67+		 (HsBangedType   happy_var_2+	)+happyReduction_147 _ _  = notHappyAtAll ++happyReduce_148 = happySpecReduce_3  69 happyReduction_148+happyReduction_148 (HappyAbsSyn70  happy_var_3)+	_+	(HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (happy_var_3 : happy_var_1+	)+happyReduction_148 _ _ _  = notHappyAtAll ++happyReduce_149 = happySpecReduce_1  69 happyReduction_149+happyReduction_149 (HappyAbsSyn70  happy_var_1)+	 =  HappyAbsSyn69+		 ([happy_var_1]+	)+happyReduction_149 _  = notHappyAtAll ++happyReduce_150 = happySpecReduce_3  70 happyReduction_150+happyReduction_150 (HappyAbsSyn67  happy_var_3)+	_+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn70+		 ((reverse happy_var_1, happy_var_3)+	)+happyReduction_150 _ _ _  = notHappyAtAll ++happyReduce_151 = happySpecReduce_1  71 happyReduction_151+happyReduction_151 (HappyAbsSyn51  happy_var_1)+	 =  HappyAbsSyn67+		 (HsUnBangedType happy_var_1+	)+happyReduction_151 _  = notHappyAtAll ++happyReduce_152 = happySpecReduce_2  71 happyReduction_152+happyReduction_152 (HappyAbsSyn51  happy_var_2)+	_+	 =  HappyAbsSyn67+		 (HsBangedType   happy_var_2+	)+happyReduction_152 _ _  = notHappyAtAll ++happyReduce_153 = happySpecReduce_0  72 happyReduction_153+happyReduction_153  =  HappyAbsSyn42+		 ([]+	)++happyReduce_154 = happySpecReduce_2  72 happyReduction_154+happyReduction_154 (HappyAbsSyn36  happy_var_2)+	_+	 =  HappyAbsSyn42+		 ([happy_var_2]+	)+happyReduction_154 _ _  = notHappyAtAll ++happyReduce_155 = happySpecReduce_3  72 happyReduction_155+happyReduction_155 _+	_+	_+	 =  HappyAbsSyn42+		 ([]+	)++happyReduce_156 = happyReduce 4 72 happyReduction_156+happyReduction_156 (_ `HappyStk`+	(HappyAbsSyn42  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn42+		 (reverse happy_var_3+	) `HappyStk` happyRest++happyReduce_157 = happySpecReduce_3  73 happyReduction_157+happyReduction_157 (HappyAbsSyn36  happy_var_3)+	_+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn42+		 (happy_var_3 : happy_var_1+	)+happyReduction_157 _ _ _  = notHappyAtAll ++happyReduce_158 = happySpecReduce_1  73 happyReduction_158+happyReduction_158 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn42+		 ([happy_var_1]+	)+happyReduction_158 _  = notHappyAtAll ++happyReduce_159 = happyReduce 4 74 happyReduction_159+happyReduction_159 (_ `HappyStk`+	(HappyAbsSyn28  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn28+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_160 = happyReduce 4 74 happyReduction_160+happyReduction_160 (_ `HappyStk`+	(HappyAbsSyn28  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn28+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_161 = happySpecReduce_0  74 happyReduction_161+happyReduction_161  =  HappyAbsSyn28+		 ([]+	)++happyReduce_162 = happySpecReduce_0  75 happyReduction_162+happyReduction_162  =  HappyAbsSyn28+		 ([]+	)++happyReduce_163 = happySpecReduce_1  75 happyReduction_163+happyReduction_163 (HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (reverse happy_var_1+	)+happyReduction_163 _  = notHappyAtAll ++happyReduce_164 = happySpecReduce_1  76 happyReduction_164+happyReduction_164 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn28+		 ([happy_var_1]+	)+happyReduction_164 _  = notHappyAtAll ++happyReduce_165 = happySpecReduce_3  76 happyReduction_165+happyReduction_165 (HappyAbsSyn29  happy_var_3)+	_+	(HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (funCons happy_var_3 happy_var_1+	)+happyReduction_165 _ _ _  = notHappyAtAll ++happyReduce_166 = happySpecReduce_1  77 happyReduction_166+happyReduction_166 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn29+		 (happy_var_1+	)+happyReduction_166 _  = notHappyAtAll ++happyReduce_167 = happyReduce 4 78 happyReduction_167+happyReduction_167 (_ `HappyStk`+	(HappyAbsSyn28  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn28+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_168 = happyReduce 4 78 happyReduction_168+happyReduction_168 (_ `HappyStk`+	(HappyAbsSyn28  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn28+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_169 = happySpecReduce_0  78 happyReduction_169+happyReduction_169  =  HappyAbsSyn28+		 ([]+	)++happyReduce_170 = happySpecReduce_0  79 happyReduction_170+happyReduction_170  =  HappyAbsSyn28+		 ([]+	)++happyReduce_171 = happySpecReduce_1  79 happyReduction_171+happyReduction_171 (HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (reverse happy_var_1+	)+happyReduction_171 _  = notHappyAtAll ++happyReduce_172 = happySpecReduce_1  80 happyReduction_172+happyReduction_172 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn28+		 ([happy_var_1]+	)+happyReduction_172 _  = notHappyAtAll ++happyReduce_173 = happySpecReduce_3  80 happyReduction_173+happyReduction_173 (HappyAbsSyn29  happy_var_3)+	_+	(HappyAbsSyn28  happy_var_1)+	 =  HappyAbsSyn28+		 (funCons happy_var_3 happy_var_1+	)+happyReduction_173 _ _ _  = notHappyAtAll ++happyReduce_174 = happySpecReduce_1  81 happyReduction_174+happyReduction_174 (HappyAbsSyn29  happy_var_1)+	 =  HappyAbsSyn29+		 (happy_var_1+	)+happyReduction_174 _  = notHappyAtAll ++happyReduce_175 = happyReduce 4 82 happyReduction_175+happyReduction_175 ((HappyAbsSyn28  happy_var_4) `HappyStk`+	(HappyAbsSyn85  happy_var_3) `HappyStk`+	(HappyAbsSyn152  happy_var_2) `HappyStk`+	(HappyAbsSyn83  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (mkFunDef' happy_var_1 happy_var_2 happy_var_3 happy_var_4+	) `HappyStk` happyRest++happyReduce_176 = happyReduce 4 82 happyReduction_176+happyReduction_176 ((HappyAbsSyn28  happy_var_4) `HappyStk`+	(HappyAbsSyn85  happy_var_3) `HappyStk`+	(HappyAbsSyn152  happy_var_2) `HappyStk`+	(HappyAbsSyn110  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn29+		 (hsPatBind happy_var_2 happy_var_1 happy_var_3 happy_var_4+	) `HappyStk` happyRest++happyReduce_177 = happySpecReduce_2  83 happyReduction_177+happyReduction_177 (HappyAbsSyn114  happy_var_2)+	(HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn83+		 ((happy_var_1,happy_var_2)+	)+happyReduction_177 _ _  = notHappyAtAll ++happyReduce_178 = happySpecReduce_3  83 happyReduction_178+happyReduction_178 (HappyAbsSyn110  happy_var_3)+	(HappyAbsSyn36  happy_var_2)+	(HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn83+		 ((happy_var_2,[happy_var_1,happy_var_3])+	)+happyReduction_178 _ _ _  = notHappyAtAll ++happyReduce_179 = happyReduce 4 83 happyReduction_179+happyReduction_179 ((HappyAbsSyn114  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn83  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn83+		 ((fst happy_var_2,snd happy_var_2++happy_var_4)+	) `HappyStk` happyRest++happyReduce_180 = happySpecReduce_2  84 happyReduction_180+happyReduction_180 (HappyAbsSyn28  happy_var_2)+	_+	 =  HappyAbsSyn28+		 (happy_var_2+	)+happyReduction_180 _ _  = notHappyAtAll ++happyReduce_181 = happySpecReduce_0  84 happyReduction_181+happyReduction_181  =  HappyAbsSyn28+		 ([]+	)++happyReduce_182 = happySpecReduce_2  85 happyReduction_182+happyReduction_182 (HappyAbsSyn88  happy_var_2)+	_+	 =  HappyAbsSyn85+		 (HsBody happy_var_2+	)+happyReduction_182 _ _  = notHappyAtAll ++happyReduce_183 = happySpecReduce_1  85 happyReduction_183+happyReduction_183 (HappyAbsSyn86  happy_var_1)+	 =  HappyAbsSyn85+		 (HsGuard (reverse happy_var_1)+	)+happyReduction_183 _  = notHappyAtAll ++happyReduce_184 = happySpecReduce_2  86 happyReduction_184+happyReduction_184 (HappyAbsSyn87  happy_var_2)+	(HappyAbsSyn86  happy_var_1)+	 =  HappyAbsSyn86+		 (happy_var_2 : happy_var_1+	)+happyReduction_184 _ _  = notHappyAtAll ++happyReduce_185 = happySpecReduce_1  86 happyReduction_185+happyReduction_185 (HappyAbsSyn87  happy_var_1)+	 =  HappyAbsSyn86+		 ([happy_var_1]+	)+happyReduction_185 _  = notHappyAtAll ++happyReduce_186 = happyReduce 4 87 happyReduction_186+happyReduction_186 ((HappyAbsSyn88  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn88  happy_var_2) `HappyStk`+	(HappyTerminal ((Reservedop,(happy_var_1,"|")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn87+		 ((happy_var_1, happy_var_2, happy_var_4)+	) `HappyStk` happyRest++happyReduce_187 = happySpecReduce_3  88 happyReduction_187+happyReduction_187 (HappyAbsSyn57  happy_var_3)+	(HappyTerminal ((Reservedop,(happy_var_2,"::"))))+	(HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (hsExpTypeSig happy_var_2 happy_var_1 (fst happy_var_3) (snd happy_var_3)+	)+happyReduction_187 _ _ _  = notHappyAtAll ++happyReduce_188 = happySpecReduce_1  88 happyReduction_188+happyReduction_188 (HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (happy_var_1+	)+happyReduction_188 _  = notHappyAtAll ++happyReduce_189 = happySpecReduce_3  89 happyReduction_189+happyReduction_189 (HappyAbsSyn88  happy_var_3)+	(HappyAbsSyn16  happy_var_2)+	(HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (hsInfixApp happy_var_1 happy_var_2 happy_var_3+	)+happyReduction_189 _ _ _  = notHappyAtAll ++happyReduce_190 = happyReduce 4 89 happyReduction_190+happyReduction_190 ((HappyAbsSyn88  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn114  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn88+		 (hsLambda happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_191 = happyReduce 4 89 happyReduction_191+happyReduction_191 ((HappyAbsSyn88  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn28  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn88+		 (hsLet happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_192 = happyReduce 6 89 happyReduction_192+happyReduction_192 ((HappyAbsSyn88  happy_var_6) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn88  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn88  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn88+		 (hsIf happy_var_2 happy_var_4 happy_var_6+	) `HappyStk` happyRest++happyReduce_193 = happyReduce 4 89 happyReduction_193+happyReduction_193 ((HappyAbsSyn99  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn88  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn88+		 (hsCase happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_194 = happySpecReduce_2  89 happyReduction_194+happyReduction_194 (HappyAbsSyn88  happy_var_2)+	(HappyTerminal ((Varsym,(happy_var_1,"-"))))+	 =  HappyAbsSyn88+		 (hsNegApp happy_var_1 happy_var_2+	)+happyReduction_194 _ _  = notHappyAtAll ++happyReduce_195 = happyMonadReduce 2 89 happyReduction_195+happyReduction_195 ((HappyAbsSyn105  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest) tk+	 = happyThen (( hsDo `fmap` atoms2Stmt happy_var_2)+	) (\r -> happyReturn (HappyAbsSyn88 r))++happyReduce_196 = happySpecReduce_1  89 happyReduction_196+happyReduction_196 (HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (happy_var_1+	)+happyReduction_196 _  = notHappyAtAll ++happyReduce_197 = happySpecReduce_2  90 happyReduction_197+happyReduction_197 (HappyAbsSyn88  happy_var_2)+	(HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (hsApp happy_var_1 happy_var_2+	)+happyReduction_197 _ _  = notHappyAtAll ++happyReduce_198 = happySpecReduce_1  90 happyReduction_198+happyReduction_198 (HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (happy_var_1+	)+happyReduction_198 _  = notHappyAtAll ++happyReduce_199 = happyReduce 4 91 happyReduction_199+happyReduction_199 (_ `HappyStk`+	(HappyAbsSyn107  happy_var_3) `HappyStk`+	(HappyTerminal ((Special,(happy_var_2,"{")))) `HappyStk`+	(HappyAbsSyn88  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn88+		 (mkRecord happy_var_2 happy_var_1 (reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_200 = happySpecReduce_1  91 happyReduction_200+happyReduction_200 (HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (happy_var_1+	)+happyReduction_200 _  = notHappyAtAll ++happyReduce_201 = happySpecReduce_1  92 happyReduction_201+happyReduction_201 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn88+		 (hsEVar (happy_var_1 :: HsName)+	)+happyReduction_201 _  = notHappyAtAll ++happyReduce_202 = happySpecReduce_1  92 happyReduction_202+happyReduction_202 (HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (happy_var_1+	)+happyReduction_202 _  = notHappyAtAll ++happyReduce_203 = happySpecReduce_1  92 happyReduction_203+happyReduction_203 (HappyAbsSyn150  happy_var_1)+	 =  HappyAbsSyn88+		 (uncurry hsLit happy_var_1+	)+happyReduction_203 _  = notHappyAtAll ++happyReduce_204 = happySpecReduce_3  92 happyReduction_204+happyReduction_204 _+	(HappyAbsSyn94  happy_var_2)+	_+	 =  HappyAbsSyn88+		 (case happy_var_2 of+                                         [e] -> hsParen e+				         es -> hsTuple es+	)+happyReduction_204 _ _ _  = notHappyAtAll ++happyReduce_205 = happySpecReduce_3  92 happyReduction_205+happyReduction_205 _+	(HappyAbsSyn88  happy_var_2)+	_+	 =  HappyAbsSyn88+		 (happy_var_2+	)+happyReduction_205 _ _ _  = notHappyAtAll ++happyReduce_206 = happyReduce 4 92 happyReduction_206+happyReduction_206 (_ `HappyStk`+	(HappyAbsSyn16  happy_var_3) `HappyStk`+	(HappyAbsSyn88  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn88+		 (hsLeftSection happy_var_2 happy_var_3+	) `HappyStk` happyRest++happyReduce_207 = happyReduce 4 92 happyReduction_207+happyReduction_207 (_ `HappyStk`+	(HappyAbsSyn88  happy_var_3) `HappyStk`+	(HappyAbsSyn16  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn88+		 (hsRightSection happy_var_2 happy_var_3+	) `HappyStk` happyRest++happyReduce_208 = happySpecReduce_3  92 happyReduction_208+happyReduction_208 (HappyAbsSyn88  happy_var_3)+	_+	(HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn88+		 (hsAsPat happy_var_1 happy_var_3+	)+happyReduction_208 _ _ _  = notHappyAtAll ++happyReduce_209 = happySpecReduce_1  92 happyReduction_209+happyReduction_209 _+	 =  HappyAbsSyn88+		 (hsWildCard+	)++happyReduce_210 = happySpecReduce_2  92 happyReduction_210+happyReduction_210 (HappyAbsSyn88  happy_var_2)+	_+	 =  HappyAbsSyn88+		 (hsIrrPat happy_var_2+	)+happyReduction_210 _ _  = notHappyAtAll ++happyReduce_211 = happySpecReduce_2  93 happyReduction_211+happyReduction_211 _+	(HappyAbsSyn30  happy_var_1)+	 =  HappyAbsSyn30+		 (happy_var_1 + 1+	)+happyReduction_211 _ _  = notHappyAtAll ++happyReduce_212 = happySpecReduce_1  93 happyReduction_212+happyReduction_212 _+	 =  HappyAbsSyn30+		 (1+	)++happyReduce_213 = happySpecReduce_3  94 happyReduction_213+happyReduction_213 (HappyAbsSyn94  happy_var_3)+	_+	(HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn94+		 (happy_var_1 : happy_var_3+	)+happyReduction_213 _ _ _  = notHappyAtAll ++happyReduce_214 = happySpecReduce_1  94 happyReduction_214+happyReduction_214 (HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn94+		 ([happy_var_1]+	)+happyReduction_214 _  = notHappyAtAll ++happyReduce_215 = happySpecReduce_1  95 happyReduction_215+happyReduction_215 (HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (hsList [happy_var_1]+	)+happyReduction_215 _  = notHappyAtAll ++happyReduce_216 = happySpecReduce_1  95 happyReduction_216+happyReduction_216 (HappyAbsSyn94  happy_var_1)+	 =  HappyAbsSyn88+		 (hsList (reverse happy_var_1)+	)+happyReduction_216 _  = notHappyAtAll ++happyReduce_217 = happySpecReduce_2  95 happyReduction_217+happyReduction_217 _+	(HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (hsEnumFrom happy_var_1+	)+happyReduction_217 _ _  = notHappyAtAll ++happyReduce_218 = happyReduce 4 95 happyReduction_218+happyReduction_218 (_ `HappyStk`+	(HappyAbsSyn88  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn88  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn88+		 (hsEnumFromThen happy_var_1 happy_var_3+	) `HappyStk` happyRest++happyReduce_219 = happySpecReduce_3  95 happyReduction_219+happyReduction_219 (HappyAbsSyn88  happy_var_3)+	_+	(HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (hsEnumFromTo happy_var_1 happy_var_3+	)+happyReduction_219 _ _ _  = notHappyAtAll ++happyReduce_220 = happyReduce 5 95 happyReduction_220+happyReduction_220 ((HappyAbsSyn88  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn88  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn88  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn88+		 (hsEnumFromThenTo happy_var_1 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_221 = happyMonadReduce 3 95 happyReduction_221+happyReduction_221 ((HappyAbsSyn97  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn88  happy_var_1) `HappyStk`+	happyRest) tk+	 = happyThen (( hsListComp `fmap` atoms2Stmt (reverse happy_var_3 ++ [HsQualifierAtom happy_var_1]))+	) (\r -> happyReturn (HappyAbsSyn88 r))++happyReduce_222 = happySpecReduce_3  96 happyReduction_222+happyReduction_222 (HappyAbsSyn88  happy_var_3)+	_+	(HappyAbsSyn94  happy_var_1)+	 =  HappyAbsSyn94+		 (happy_var_3 : happy_var_1+	)+happyReduction_222 _ _ _  = notHappyAtAll ++happyReduce_223 = happySpecReduce_3  96 happyReduction_223+happyReduction_223 (HappyAbsSyn88  happy_var_3)+	_+	(HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn94+		 ([happy_var_3,happy_var_1]+	)+happyReduction_223 _ _ _  = notHappyAtAll ++happyReduce_224 = happySpecReduce_3  97 happyReduction_224+happyReduction_224 (HappyAbsSyn98  happy_var_3)+	_+	(HappyAbsSyn97  happy_var_1)+	 =  HappyAbsSyn97+		 (happy_var_3 : happy_var_1+	)+happyReduction_224 _ _ _  = notHappyAtAll ++happyReduce_225 = happySpecReduce_1  97 happyReduction_225+happyReduction_225 (HappyAbsSyn98  happy_var_1)+	 =  HappyAbsSyn97+		 ([happy_var_1]+	)+happyReduction_225 _  = notHappyAtAll ++happyReduce_226 = happyMonadReduce 3 98 happyReduction_226+happyReduction_226 ((HappyAbsSyn88  happy_var_3) `HappyStk`+	(HappyTerminal ((Reservedop,(happy_var_2,"<-")))) `HappyStk`+	(HappyAbsSyn88  happy_var_1) `HappyStk`+	happyRest) tk+	 = happyThen (( do { p <- expToPat happy_var_1 ; +                                                return (HsGeneratorAtom happy_var_2 p happy_var_3)+					      })+	) (\r -> happyReturn (HappyAbsSyn98 r))++happyReduce_227 = happySpecReduce_1  98 happyReduction_227+happyReduction_227 (HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn98+		 (HsQualifierAtom happy_var_1+	)+happyReduction_227 _  = notHappyAtAll ++happyReduce_228 = happySpecReduce_2  98 happyReduction_228+happyReduction_228 (HappyAbsSyn28  happy_var_2)+	_+	 =  HappyAbsSyn98+		 (HsLetStmtAtom   happy_var_2+	)+happyReduction_228 _ _  = notHappyAtAll ++happyReduce_229 = happyReduce 4 99 happyReduction_229+happyReduction_229 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn99  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn99+		 (reverse happy_var_2+	) `HappyStk` happyRest++happyReduce_230 = happyReduce 4 99 happyReduction_230+happyReduction_230 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn99  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn99+		 (reverse happy_var_2+	) `HappyStk` happyRest++happyReduce_231 = happySpecReduce_3  100 happyReduction_231+happyReduction_231 (HappyAbsSyn101  happy_var_3)+	_+	(HappyAbsSyn99  happy_var_1)+	 =  HappyAbsSyn99+		 (happy_var_3 : happy_var_1+	)+happyReduction_231 _ _ _  = notHappyAtAll ++happyReduce_232 = happySpecReduce_1  100 happyReduction_232+happyReduction_232 (HappyAbsSyn101  happy_var_1)+	 =  HappyAbsSyn99+		 ([happy_var_1]+	)+happyReduction_232 _  = notHappyAtAll ++happyReduce_233 = happySpecReduce_3  101 happyReduction_233+happyReduction_233 (HappyAbsSyn85  happy_var_3)+	(HappyAbsSyn152  happy_var_2)+	(HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn101+		 (HsAlt happy_var_2 happy_var_1 happy_var_3 []+	)+happyReduction_233 _ _ _  = notHappyAtAll ++happyReduce_234 = happyReduce 5 101 happyReduction_234+happyReduction_234 ((HappyAbsSyn28  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn85  happy_var_3) `HappyStk`+	(HappyAbsSyn152  happy_var_2) `HappyStk`+	(HappyAbsSyn110  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn101+		 (HsAlt happy_var_2 happy_var_1 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_235 = happySpecReduce_2  102 happyReduction_235+happyReduction_235 (HappyAbsSyn88  happy_var_2)+	_+	 =  HappyAbsSyn85+		 (HsBody happy_var_2+	)+happyReduction_235 _ _  = notHappyAtAll ++happyReduce_236 = happySpecReduce_1  102 happyReduction_236+happyReduction_236 (HappyAbsSyn86  happy_var_1)+	 =  HappyAbsSyn85+		 (HsGuard (reverse happy_var_1)+	)+happyReduction_236 _  = notHappyAtAll ++happyReduce_237 = happySpecReduce_2  103 happyReduction_237+happyReduction_237 (HappyAbsSyn87  happy_var_2)+	(HappyAbsSyn86  happy_var_1)+	 =  HappyAbsSyn86+		 (happy_var_2 : happy_var_1+	)+happyReduction_237 _ _  = notHappyAtAll ++happyReduce_238 = happySpecReduce_1  103 happyReduction_238+happyReduction_238 (HappyAbsSyn87  happy_var_1)+	 =  HappyAbsSyn86+		 ([happy_var_1]+	)+happyReduction_238 _  = notHappyAtAll ++happyReduce_239 = happyReduce 4 104 happyReduction_239+happyReduction_239 ((HappyAbsSyn88  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn88  happy_var_2) `HappyStk`+	(HappyTerminal ((Reservedop,(happy_var_1,"|")))) `HappyStk`+	happyRest)+	 = HappyAbsSyn87+		 ((happy_var_1, happy_var_2, happy_var_4)+	) `HappyStk` happyRest++happyReduce_240 = happySpecReduce_3  105 happyReduction_240+happyReduction_240 _+	(HappyAbsSyn105  happy_var_2)+	_+	 =  HappyAbsSyn105+		 (happy_var_2+	)+happyReduction_240 _ _ _  = notHappyAtAll ++happyReduce_241 = happySpecReduce_3  105 happyReduction_241+happyReduction_241 _+	(HappyAbsSyn105  happy_var_2)+	_+	 =  HappyAbsSyn105+		 (happy_var_2+	)+happyReduction_241 _ _ _  = notHappyAtAll ++happyReduce_242 = happySpecReduce_3  106 happyReduction_242+happyReduction_242 (HappyAbsSyn105  happy_var_3)+	_+	(HappyAbsSyn98  happy_var_1)+	 =  HappyAbsSyn105+		 (happy_var_1 : happy_var_3+	)+happyReduction_242 _ _ _  = notHappyAtAll ++happyReduce_243 = happySpecReduce_2  106 happyReduction_243+happyReduction_243 (HappyAbsSyn105  happy_var_2)+	_+	 =  HappyAbsSyn105+		 (happy_var_2+	)+happyReduction_243 _ _  = notHappyAtAll ++happyReduce_244 = happySpecReduce_1  106 happyReduction_244+happyReduction_244 (HappyAbsSyn98  happy_var_1)+	 =  HappyAbsSyn105+		 ([happy_var_1]+	)+happyReduction_244 _  = notHappyAtAll ++happyReduce_245 = happySpecReduce_2  106 happyReduction_245+happyReduction_245 _+	(HappyAbsSyn98  happy_var_1)+	 =  HappyAbsSyn105+		 ([happy_var_1]+	)+happyReduction_245 _ _  = notHappyAtAll ++happyReduce_246 = happySpecReduce_0  107 happyReduction_246+happyReduction_246  =  HappyAbsSyn107+		 ([]+	)++happyReduce_247 = happySpecReduce_1  107 happyReduction_247+happyReduction_247 (HappyAbsSyn107  happy_var_1)+	 =  HappyAbsSyn107+		 (happy_var_1+	)+happyReduction_247 _  = notHappyAtAll ++happyReduce_248 = happySpecReduce_3  108 happyReduction_248+happyReduction_248 (HappyAbsSyn109  happy_var_3)+	_+	(HappyAbsSyn107  happy_var_1)+	 =  HappyAbsSyn107+		 (happy_var_3 : happy_var_1+	)+happyReduction_248 _ _ _  = notHappyAtAll ++happyReduce_249 = happySpecReduce_1  108 happyReduction_249+happyReduction_249 (HappyAbsSyn109  happy_var_1)+	 =  HappyAbsSyn107+		 ([happy_var_1]+	)+happyReduction_249 _  = notHappyAtAll ++happyReduce_250 = happySpecReduce_3  109 happyReduction_250+happyReduction_250 (HappyAbsSyn88  happy_var_3)+	_+	(HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn109+		 (HsField happy_var_1 happy_var_3+	)+happyReduction_250 _ _ _  = notHappyAtAll ++happyReduce_251 = happySpecReduce_1  110 happyReduction_251+happyReduction_251 (HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn110+		 (happy_var_1+	)+happyReduction_251 _  = notHappyAtAll ++happyReduce_252 = happySpecReduce_1  111 happyReduction_252+happyReduction_252 (HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn110+		 (happy_var_1+	)+happyReduction_252 _  = notHappyAtAll ++happyReduce_253 = happySpecReduce_3  111 happyReduction_253+happyReduction_253 (HappyAbsSyn110  happy_var_3)+	(HappyAbsSyn36  happy_var_2)+	(HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn110+		 (hsPInfixApp happy_var_1 happy_var_2 happy_var_3+	)+happyReduction_253 _ _ _  = notHappyAtAll ++happyReduce_254 = happySpecReduce_2  112 happyReduction_254+happyReduction_254 (HappyAbsSyn114  happy_var_2)+	(HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn110+		 (hsPApp happy_var_1 happy_var_2+	)+happyReduction_254 _ _  = notHappyAtAll ++happyReduce_255 = happySpecReduce_2  112 happyReduction_255+happyReduction_255 (HappyAbsSyn150  happy_var_2)+	(HappyTerminal ((Varsym,(happy_var_1,"-"))))+	 =  HappyAbsSyn110+		 (hsPNeg happy_var_1 (snd happy_var_2)+	)+happyReduction_255 _ _  = notHappyAtAll ++happyReduce_256 = happySpecReduce_1  112 happyReduction_256+happyReduction_256 (HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn110+		 (happy_var_1+	)+happyReduction_256 _  = notHappyAtAll ++happyReduce_257 = happySpecReduce_1  113 happyReduction_257+happyReduction_257 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn110+		 (hsPVar happy_var_1+	)+happyReduction_257 _  = notHappyAtAll ++happyReduce_258 = happySpecReduce_3  113 happyReduction_258+happyReduction_258 (HappyAbsSyn110  happy_var_3)+	_+	(HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn110+		 (hsPAsPat happy_var_1 happy_var_3+	)+happyReduction_258 _ _ _  = notHappyAtAll ++happyReduce_259 = happySpecReduce_1  113 happyReduction_259+happyReduction_259 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn110+		 (hsPCon happy_var_1+	)+happyReduction_259 _  = notHappyAtAll ++happyReduce_260 = happySpecReduce_2  113 happyReduction_260+happyReduction_260 _+	(HappyTerminal ((Special,(happy_var_1,"("))))+	 =  HappyAbsSyn110+		 (hsPCon (qunit happy_var_1)+	)+happyReduction_260 _ _  = notHappyAtAll ++happyReduce_261 = happyReduce 4 113 happyReduction_261+happyReduction_261 (_ `HappyStk`+	(HappyAbsSyn116  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn36  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn110+		 (hsPRec happy_var_1 happy_var_3+	) `HappyStk` happyRest++happyReduce_262 = happySpecReduce_1  113 happyReduction_262+happyReduction_262 (HappyAbsSyn150  happy_var_1)+	 =  HappyAbsSyn110+		 (uncurry hsPLit happy_var_1+	)+happyReduction_262 _  = notHappyAtAll ++happyReduce_263 = happySpecReduce_1  113 happyReduction_263+happyReduction_263 _+	 =  HappyAbsSyn110+		 (hsPWildCard+	)++happyReduce_264 = happySpecReduce_3  113 happyReduction_264+happyReduction_264 _+	(HappyAbsSyn110  happy_var_2)+	_+	 =  HappyAbsSyn110+		 (hsPParen happy_var_2+	)+happyReduction_264 _ _ _  = notHappyAtAll ++happyReduce_265 = happySpecReduce_3  113 happyReduction_265+happyReduction_265 _+	(HappyAbsSyn114  happy_var_2)+	(HappyTerminal ((Special,(happy_var_1,"("))))+	 =  HappyAbsSyn110+		 (hsPTuple happy_var_1 happy_var_2+	)+happyReduction_265 _ _ _  = notHappyAtAll ++happyReduce_266 = happySpecReduce_3  113 happyReduction_266+happyReduction_266 _+	(HappyAbsSyn114  happy_var_2)+	(HappyTerminal ((Special,(happy_var_1,"["))))+	 =  HappyAbsSyn110+		 (hsPList happy_var_1 happy_var_2+	)+happyReduction_266 _ _ _  = notHappyAtAll ++happyReduce_267 = happySpecReduce_2  113 happyReduction_267+happyReduction_267 (HappyAbsSyn110  happy_var_2)+	_+	 =  HappyAbsSyn110+		 (hsPIrrPat happy_var_2+	)+happyReduction_267 _ _  = notHappyAtAll ++happyReduce_268 = happySpecReduce_2  114 happyReduction_268+happyReduction_268 (HappyAbsSyn114  happy_var_2)+	(HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn114+		 (happy_var_1 : happy_var_2+	)+happyReduction_268 _ _  = notHappyAtAll ++happyReduce_269 = happySpecReduce_0  115 happyReduction_269+happyReduction_269  =  HappyAbsSyn114+		 ([]+	)++happyReduce_270 = happySpecReduce_2  115 happyReduction_270+happyReduction_270 (HappyAbsSyn114  happy_var_2)+	(HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn114+		 (happy_var_1 : happy_var_2+	)+happyReduction_270 _ _  = notHappyAtAll ++happyReduce_271 = happySpecReduce_0  116 happyReduction_271+happyReduction_271  =  HappyAbsSyn116+		 ([]+	)++happyReduce_272 = happySpecReduce_1  116 happyReduction_272+happyReduction_272 (HappyAbsSyn116  happy_var_1)+	 =  HappyAbsSyn116+		 (happy_var_1+	)+happyReduction_272 _  = notHappyAtAll ++happyReduce_273 = happySpecReduce_3  117 happyReduction_273+happyReduction_273 (HappyAbsSyn116  happy_var_3)+	_+	(HappyAbsSyn118  happy_var_1)+	 =  HappyAbsSyn116+		 (happy_var_1 : happy_var_3+	)+happyReduction_273 _ _ _  = notHappyAtAll ++happyReduce_274 = happySpecReduce_1  117 happyReduction_274+happyReduction_274 (HappyAbsSyn118  happy_var_1)+	 =  HappyAbsSyn116+		 ([happy_var_1]+	)+happyReduction_274 _  = notHappyAtAll ++happyReduce_275 = happySpecReduce_3  118 happyReduction_275+happyReduction_275 (HappyAbsSyn110  happy_var_3)+	_+	(HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn118+		 (HsField happy_var_1 happy_var_3+	)+happyReduction_275 _ _ _  = notHappyAtAll ++happyReduce_276 = happySpecReduce_3  119 happyReduction_276+happyReduction_276 (HappyAbsSyn114  happy_var_3)+	_+	(HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn114+		 (happy_var_1 : happy_var_3+	)+happyReduction_276 _ _ _  = notHappyAtAll ++happyReduce_277 = happySpecReduce_3  119 happyReduction_277+happyReduction_277 (HappyAbsSyn110  happy_var_3)+	_+	(HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn114+		 ([happy_var_1, happy_var_3]+	)+happyReduction_277 _ _ _  = notHappyAtAll ++happyReduce_278 = happySpecReduce_0  120 happyReduction_278+happyReduction_278  =  HappyAbsSyn114+		 ([]+	)++happyReduce_279 = happySpecReduce_1  120 happyReduction_279+happyReduction_279 (HappyAbsSyn114  happy_var_1)+	 =  HappyAbsSyn114+		 (happy_var_1+	)+happyReduction_279 _  = notHappyAtAll ++happyReduce_280 = happySpecReduce_3  121 happyReduction_280+happyReduction_280 (HappyAbsSyn114  happy_var_3)+	_+	(HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn114+		 (happy_var_1 : happy_var_3+	)+happyReduction_280 _ _ _  = notHappyAtAll ++happyReduce_281 = happySpecReduce_1  121 happyReduction_281+happyReduction_281 (HappyAbsSyn110  happy_var_1)+	 =  HappyAbsSyn114+		 ([happy_var_1]+	)+happyReduction_281 _  = notHappyAtAll ++happyReduce_282 = happySpecReduce_2  122 happyReduction_282+happyReduction_282 _+	_+	 =  HappyAbsSyn88+		 (hsList []+	)++happyReduce_283 = happySpecReduce_1  122 happyReduction_283+happyReduction_283 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn88+		 (hsECon happy_var_1+	)+happyReduction_283 _  = notHappyAtAll ++happyReduce_284 = happySpecReduce_1  122 happyReduction_284+happyReduction_284 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn88+		 (hsECon happy_var_1+	)+happyReduction_284 _  = notHappyAtAll ++happyReduce_285 = happySpecReduce_2  123 happyReduction_285+happyReduction_285 _+	(HappyTerminal ((Special,(happy_var_1,"("))))+	 =  HappyAbsSyn36+		 (qunit happy_var_1+	)+happyReduction_285 _ _  = notHappyAtAll ++happyReduce_286 = happySpecReduce_3  123 happyReduction_286+happyReduction_286 _+	(HappyAbsSyn30  happy_var_2)+	(HappyTerminal ((Special,(happy_var_1,"("))))+	 =  HappyAbsSyn36+		 (qtuple happy_var_2 happy_var_1+	)+happyReduction_286 _ _ _  = notHappyAtAll ++happyReduce_287 = happySpecReduce_1  124 happyReduction_287+happyReduction_287 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_287 _  = notHappyAtAll ++happyReduce_288 = happySpecReduce_3  124 happyReduction_288+happyReduction_288 _+	(HappyAbsSyn36  happy_var_2)+	_+	 =  HappyAbsSyn36+		 (happy_var_2+	)+happyReduction_288 _ _ _  = notHappyAtAll ++happyReduce_289 = happySpecReduce_1  125 happyReduction_289+happyReduction_289 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_289 _  = notHappyAtAll ++happyReduce_290 = happySpecReduce_3  125 happyReduction_290+happyReduction_290 _+	(HappyAbsSyn36  happy_var_2)+	_+	 =  HappyAbsSyn36+		 (happy_var_2+	)+happyReduction_290 _ _ _  = notHappyAtAll ++happyReduce_291 = happySpecReduce_1  126 happyReduction_291+happyReduction_291 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_291 _  = notHappyAtAll ++happyReduce_292 = happySpecReduce_3  126 happyReduction_292+happyReduction_292 _+	(HappyAbsSyn36  happy_var_2)+	_+	 =  HappyAbsSyn36+		 (happy_var_2+	)+happyReduction_292 _ _ _  = notHappyAtAll ++happyReduce_293 = happySpecReduce_1  127 happyReduction_293+happyReduction_293 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_293 _  = notHappyAtAll ++happyReduce_294 = happySpecReduce_3  127 happyReduction_294+happyReduction_294 _+	(HappyAbsSyn36  happy_var_2)+	_+	 =  HappyAbsSyn36+		 (happy_var_2+	)+happyReduction_294 _ _ _  = notHappyAtAll ++happyReduce_295 = happySpecReduce_1  128 happyReduction_295+happyReduction_295 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_295 _  = notHappyAtAll ++happyReduce_296 = happySpecReduce_3  128 happyReduction_296+happyReduction_296 _+	(HappyAbsSyn36  happy_var_2)+	_+	 =  HappyAbsSyn36+		 (happy_var_2+	)+happyReduction_296 _ _ _  = notHappyAtAll ++happyReduce_297 = happySpecReduce_1  129 happyReduction_297+happyReduction_297 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_297 _  = notHappyAtAll ++happyReduce_298 = happySpecReduce_3  129 happyReduction_298+happyReduction_298 _+	(HappyAbsSyn36  happy_var_2)+	_+	 =  HappyAbsSyn36+		 (happy_var_2+	)+happyReduction_298 _ _ _  = notHappyAtAll ++happyReduce_299 = happySpecReduce_1  130 happyReduction_299+happyReduction_299 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_299 _  = notHappyAtAll ++happyReduce_300 = happySpecReduce_3  130 happyReduction_300+happyReduction_300 _+	(HappyAbsSyn36  happy_var_2)+	_+	 =  HappyAbsSyn36+		 (happy_var_2+	)+happyReduction_300 _ _ _  = notHappyAtAll ++happyReduce_301 = happySpecReduce_1  131 happyReduction_301+happyReduction_301 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_301 _  = notHappyAtAll ++happyReduce_302 = happySpecReduce_3  131 happyReduction_302+happyReduction_302 _+	(HappyAbsSyn36  happy_var_2)+	_+	 =  HappyAbsSyn36+		 (happy_var_2+	)+happyReduction_302 _ _ _  = notHappyAtAll ++happyReduce_303 = happySpecReduce_1  132 happyReduction_303+happyReduction_303 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_303 _  = notHappyAtAll ++happyReduce_304 = happySpecReduce_3  132 happyReduction_304+happyReduction_304 _+	(HappyAbsSyn36  happy_var_2)+	_+	 =  HappyAbsSyn36+		 (happy_var_2+	)+happyReduction_304 _ _ _  = notHappyAtAll ++happyReduce_305 = happySpecReduce_1  133 happyReduction_305+happyReduction_305 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn16+		 (hsVar happy_var_1+	)+happyReduction_305 _  = notHappyAtAll ++happyReduce_306 = happySpecReduce_1  133 happyReduction_306+happyReduction_306 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn16+		 (hsCon happy_var_1+	)+happyReduction_306 _  = notHappyAtAll ++happyReduce_307 = happySpecReduce_1  134 happyReduction_307+happyReduction_307 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn16+		 (hsVar happy_var_1+	)+happyReduction_307 _  = notHappyAtAll ++happyReduce_308 = happySpecReduce_1  134 happyReduction_308+happyReduction_308 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn16+		 (hsCon happy_var_1+	)+happyReduction_308 _  = notHappyAtAll ++happyReduce_309 = happySpecReduce_1  135 happyReduction_309+happyReduction_309 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_309 _  = notHappyAtAll ++happyReduce_310 = happySpecReduce_1  136 happyReduction_310+happyReduction_310 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn16+		 (hsVar happy_var_1+	)+happyReduction_310 _  = notHappyAtAll ++happyReduce_311 = happySpecReduce_1  136 happyReduction_311+happyReduction_311 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn16+		 (hsCon happy_var_1+	)+happyReduction_311 _  = notHappyAtAll ++happyReduce_312 = happySpecReduce_1  137 happyReduction_312+happyReduction_312 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_312 _  = notHappyAtAll ++happyReduce_313 = happySpecReduce_1  137 happyReduction_313+happyReduction_313 (HappyTerminal ((Qvarid,happy_var_1)))+	 =  HappyAbsSyn36+		 (qualid happy_var_1+	)+happyReduction_313 _  = notHappyAtAll ++happyReduce_314 = happySpecReduce_1  138 happyReduction_314+happyReduction_314 (HappyTerminal ((Varid,happy_var_1)))+	 =  HappyAbsSyn36+		 (unqualid happy_var_1+	)+happyReduction_314 _  = notHappyAtAll ++happyReduce_315 = happySpecReduce_1  138 happyReduction_315+happyReduction_315 (HappyTerminal ((Varid     ,(happy_var_1,"as"))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,"as")+	)+happyReduction_315 _  = notHappyAtAll ++happyReduce_316 = happySpecReduce_1  138 happyReduction_316+happyReduction_316 (HappyTerminal ((Varid     ,(happy_var_1,"qualified"))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,"qualified")+	)+happyReduction_316 _  = notHappyAtAll ++happyReduce_317 = happySpecReduce_1  138 happyReduction_317+happyReduction_317 (HappyTerminal ((Varid     ,(happy_var_1,"hiding"))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,"hiding")+	)+happyReduction_317 _  = notHappyAtAll ++happyReduce_318 = happySpecReduce_1  138 happyReduction_318+happyReduction_318 (HappyTerminal ((Varid     ,(happy_var_1,"foreign"))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,"foreign")+	)+happyReduction_318 _  = notHappyAtAll ++happyReduce_319 = happySpecReduce_1  139 happyReduction_319+happyReduction_319 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_319 _  = notHappyAtAll ++happyReduce_320 = happySpecReduce_1  139 happyReduction_320+happyReduction_320 (HappyTerminal ((Varid     ,(happy_var_1,"forall"))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,"forall")+	)+happyReduction_320 _  = notHappyAtAll ++happyReduce_321 = happySpecReduce_1  140 happyReduction_321+happyReduction_321 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_321 _  = notHappyAtAll ++happyReduce_322 = happySpecReduce_1  140 happyReduction_322+happyReduction_322 (HappyTerminal ((Qconid,happy_var_1)))+	 =  HappyAbsSyn36+		 (qualid happy_var_1+	)+happyReduction_322 _  = notHappyAtAll ++happyReduce_323 = happySpecReduce_1  141 happyReduction_323+happyReduction_323 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_323 _  = notHappyAtAll ++happyReduce_324 = happySpecReduce_1  141 happyReduction_324+happyReduction_324 (HappyTerminal ((Qconid,happy_var_1)))+	 =  HappyAbsSyn36+		 (qualid happy_var_1+	)+happyReduction_324 _  = notHappyAtAll ++happyReduce_325 = happySpecReduce_1  142 happyReduction_325+happyReduction_325 (HappyTerminal ((Conid,happy_var_1)))+	 =  HappyAbsSyn36+		 (unqualid happy_var_1+	)+happyReduction_325 _  = notHappyAtAll ++happyReduce_326 = happySpecReduce_1  143 happyReduction_326+happyReduction_326 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_326 _  = notHappyAtAll ++happyReduce_327 = happySpecReduce_1  143 happyReduction_327+happyReduction_327 (HappyTerminal ((Qconsym,happy_var_1)))+	 =  HappyAbsSyn36+		 (qualid happy_var_1+	)+happyReduction_327 _  = notHappyAtAll ++happyReduce_328 = happySpecReduce_1  144 happyReduction_328+happyReduction_328 (HappyTerminal ((Consym,happy_var_1)))+	 =  HappyAbsSyn36+		 (unqualid happy_var_1+	)+happyReduction_328 _  = notHappyAtAll ++happyReduce_329 = happySpecReduce_1  144 happyReduction_329+happyReduction_329 (HappyTerminal ((Reservedop,(happy_var_1,":"))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,":")+	)+happyReduction_329 _  = notHappyAtAll ++happyReduce_330 = happySpecReduce_1  145 happyReduction_330+happyReduction_330 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_330 _  = notHappyAtAll ++happyReduce_331 = happySpecReduce_1  145 happyReduction_331+happyReduction_331 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_331 _  = notHappyAtAll ++happyReduce_332 = happySpecReduce_1  146 happyReduction_332+happyReduction_332 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_332 _  = notHappyAtAll ++happyReduce_333 = happySpecReduce_1  146 happyReduction_333+happyReduction_333 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_333 _  = notHappyAtAll ++happyReduce_334 = happySpecReduce_1  147 happyReduction_334+happyReduction_334 (HappyTerminal ((Varsym,happy_var_1)))+	 =  HappyAbsSyn36+		 (unqualid happy_var_1+	)+happyReduction_334 _  = notHappyAtAll ++happyReduce_335 = happySpecReduce_1  147 happyReduction_335+happyReduction_335 (HappyTerminal ((Varsym,(happy_var_1,"-"))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,"-")+	)+happyReduction_335 _  = notHappyAtAll ++happyReduce_336 = happySpecReduce_1  147 happyReduction_336+happyReduction_336 (HappyTerminal ((Varsym    ,(happy_var_1,"!"))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,"!")+	)+happyReduction_336 _  = notHappyAtAll ++happyReduce_337 = happySpecReduce_1  147 happyReduction_337+happyReduction_337 (HappyTerminal ((Varsym, (happy_var_1,"."))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,".")+	)+happyReduction_337 _  = notHappyAtAll ++happyReduce_338 = happySpecReduce_1  148 happyReduction_338+happyReduction_338 (HappyTerminal ((Varsym,happy_var_1)))+	 =  HappyAbsSyn36+		 (unqualid happy_var_1+	)+happyReduction_338 _  = notHappyAtAll ++happyReduce_339 = happySpecReduce_1  148 happyReduction_339+happyReduction_339 (HappyTerminal ((Varsym    ,(happy_var_1,"!"))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,"!")+	)+happyReduction_339 _  = notHappyAtAll ++happyReduce_340 = happySpecReduce_1  148 happyReduction_340+happyReduction_340 (HappyTerminal ((Varsym, (happy_var_1,"."))))+	 =  HappyAbsSyn36+		 (unqualid (happy_var_1,".")+	)+happyReduction_340 _  = notHappyAtAll ++happyReduce_341 = happySpecReduce_1  149 happyReduction_341+happyReduction_341 (HappyTerminal ((Qvarsym,happy_var_1)))+	 =  HappyAbsSyn36+		 (qualid happy_var_1+	)+happyReduction_341 _  = notHappyAtAll ++happyReduce_342 = happySpecReduce_1  150 happyReduction_342+happyReduction_342 (HappyAbsSyn150  happy_var_1)+	 =  HappyAbsSyn150+		 (happy_var_1+	)+happyReduction_342 _  = notHappyAtAll ++happyReduce_343 = happySpecReduce_1  150 happyReduction_343+happyReduction_343 (HappyTerminal ((CharLit,happy_var_1)))+	 =  HappyAbsSyn150+		 ((fst happy_var_1,HsChar (read (snd happy_var_1)))+	)+happyReduction_343 _  = notHappyAtAll ++happyReduce_344 = happySpecReduce_1  150 happyReduction_344+happyReduction_344 (HappyTerminal ((StringLit,happy_var_1)))+	 =  HappyAbsSyn150+		 ((fst happy_var_1,HsString (read (snd happy_var_1)))+	)+happyReduction_344 _  = notHappyAtAll ++happyReduce_345 = happySpecReduce_1  151 happyReduction_345+happyReduction_345 (HappyTerminal ((IntLit,happy_var_1)))+	 =  HappyAbsSyn150+		 (let (s,l)=happy_var_1 in (s,HsInt (readInteger l))+	)+happyReduction_345 _  = notHappyAtAll ++happyReduce_346 = happySpecReduce_1  151 happyReduction_346+happyReduction_346 (HappyTerminal ((FloatLit,happy_var_1)))+	 =  HappyAbsSyn150+		 (let (s,l)=happy_var_1 in (s,HsFrac (readRational l))+	)+happyReduction_346 _  = notHappyAtAll ++happyReduce_347 = happyMonadReduce 0 152 happyReduction_347+happyReduction_347 (happyRest) tk+	 = happyThen (( getSrcLoc)+	) (\r -> happyReturn (HappyAbsSyn152 r))++happyReduce_348 = happySpecReduce_1  153 happyReduction_348+happyReduction_348 _+	 =  HappyAbsSyn8+		 (()+	)++happyReduce_349 = happySpecReduce_1  154 happyReduction_349+happyReduction_349 _+	 =  HappyAbsSyn8+		 (()+	)++happyReduce_350 = happyMonadReduce 1 154 happyReduction_350+happyReduction_350 (_ `HappyStk`+	happyRest) tk+	 = happyThen (( popContext)+	) (\r -> happyReturn (HappyAbsSyn8 r))++happyReduce_351 = happyMonadReduce 1 155 happyReduction_351+happyReduction_351 ((HappyAbsSyn36  happy_var_1) `HappyStk`+	happyRest) tk+	 = happyThen (( hsName2modName happy_var_1)+	) (\r -> happyReturn (HappyAbsSyn155 r))++happyReduce_352 = happySpecReduce_1  156 happyReduction_352+happyReduction_352 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_352 _  = notHappyAtAll ++happyReduce_353 = happySpecReduce_1  157 happyReduction_353+happyReduction_353 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_353 _  = notHappyAtAll ++happyReduce_354 = happySpecReduce_1  158 happyReduction_354+happyReduction_354 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_354 _  = notHappyAtAll ++happyReduce_355 = happySpecReduce_1  159 happyReduction_355+happyReduction_355 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_355 _  = notHappyAtAll ++happyReduce_356 = happySpecReduce_1  160 happyReduction_356+happyReduction_356 (HappyAbsSyn36  happy_var_1)+	 =  HappyAbsSyn36+		 (happy_var_1+	)+happyReduction_356 _  = notHappyAtAll ++happyNewToken action sts stk+	= lexer(\tk -> +	let cont i = action i i tk (HappyState action) sts stk in+	case tk of {+	(GotEOF,_) -> action 227 227 tk (HappyState action) sts stk;+	(Varid     ,(happy_dollar_dollar,"as")) -> cont 161;+	(Reservedid,(happy_dollar_dollar,"case")) -> cont 162;+	(Reservedid,(happy_dollar_dollar,"class")) -> cont 163;+	(Reservedid,(happy_dollar_dollar,"data")) -> cont 164;+	(Reservedid,(happy_dollar_dollar,"default")) -> cont 165;+	(Reservedid,(happy_dollar_dollar,"deriving")) -> cont 166;+	(Reservedid,(happy_dollar_dollar,"do")) -> cont 167;+	(Reservedid,(happy_dollar_dollar,"else")) -> cont 168;+	(Varid     ,(happy_dollar_dollar,"forall")) -> cont 169;+	(Varid     ,(happy_dollar_dollar,"hiding")) -> cont 170;+	(Reservedid,(happy_dollar_dollar,"if")) -> cont 171;+	(Reservedid,(happy_dollar_dollar,"import")) -> cont 172;+	(Reservedid,(happy_dollar_dollar,"in")) -> cont 173;+	(Reservedid,(happy_dollar_dollar,"infix")) -> cont 174;+	(Reservedid,(happy_dollar_dollar,"infixl")) -> cont 175;+	(Reservedid,(happy_dollar_dollar,"infixr")) -> cont 176;+	(Reservedid,(happy_dollar_dollar,"instance")) -> cont 177;+	(Reservedid,(happy_dollar_dollar,"let")) -> cont 178;+	(Reservedid,(happy_dollar_dollar,"module")) -> cont 179;+	(Reservedid,(happy_dollar_dollar,"newtype")) -> cont 180;+	(Reservedid,(happy_dollar_dollar,"of")) -> cont 181;+	(Reservedid,(happy_dollar_dollar,"then")) -> cont 182;+	(Reservedid,(happy_dollar_dollar,"type")) -> cont 183;+	(Reservedid,(happy_dollar_dollar,"where")) -> cont 184;+	(Varid     ,(happy_dollar_dollar,"qualified")) -> cont 185;+	(Reservedid,(happy_dollar_dollar,"_")) -> cont 186;+	(Varid     ,(happy_dollar_dollar,"primitive")) -> cont 187;+	(Varid     ,(happy_dollar_dollar,"foreign")) -> cont 188;+	(Special,(happy_dollar_dollar,"(")) -> cont 189;+	(Special,(happy_dollar_dollar,")")) -> cont 190;+	(Special,(happy_dollar_dollar,";")) -> cont 191;+	(Special,(happy_dollar_dollar,"{")) -> cont 192;+	(Special,(happy_dollar_dollar,"}")) -> cont 193;+	(Layout ,(happy_dollar_dollar,"{")) -> cont 194;+	(Layout ,(happy_dollar_dollar,"}")) -> cont 195;+	(Special,(happy_dollar_dollar,"[")) -> cont 196;+	(Special,(happy_dollar_dollar,"]")) -> cont 197;+	(Special,(happy_dollar_dollar,",")) -> cont 198;+	(Special,(happy_dollar_dollar,"`")) -> cont 199;+	(Varsym, (happy_dollar_dollar,".")) -> cont 200;+	(Reservedop,(happy_dollar_dollar,"..")) -> cont 201;+	(Reservedop,(happy_dollar_dollar,":")) -> cont 202;+	(Reservedop,(happy_dollar_dollar,"::")) -> cont 203;+	(Reservedop,(happy_dollar_dollar,"=")) -> cont 204;+	(Reservedop,(happy_dollar_dollar,"\\")) -> cont 205;+	(Reservedop,(happy_dollar_dollar,"|")) -> cont 206;+	(Reservedop,(happy_dollar_dollar,"<-")) -> cont 207;+	(Reservedop,(happy_dollar_dollar,"->")) -> cont 208;+	(Reservedop,(happy_dollar_dollar,"@")) -> cont 209;+	(Reservedop,(happy_dollar_dollar,"~")) -> cont 210;+	(Reservedop,(happy_dollar_dollar,"=>")) -> cont 211;+	(Varsym    ,(happy_dollar_dollar,"!")) -> cont 212;+	(Varid,happy_dollar_dollar) -> cont 213;+	(Qvarid,happy_dollar_dollar) -> cont 214;+	(Conid,happy_dollar_dollar) -> cont 215;+	(Qconid,happy_dollar_dollar) -> cont 216;+	(Varsym,(happy_dollar_dollar,"-")) -> cont 217;+	(Varsym,happy_dollar_dollar) -> cont 218;+	(Consym,happy_dollar_dollar) -> cont 219;+	(Qvarsym,happy_dollar_dollar) -> cont 220;+	(Qconsym,happy_dollar_dollar) -> cont 221;+	(IntLit,happy_dollar_dollar) -> cont 222;+	(FloatLit,happy_dollar_dollar) -> cont 223;+	(CharLit,happy_dollar_dollar) -> cont 224;+	(StringLit,happy_dollar_dollar) -> cont 225;+	happy_dollar_dollar -> cont 226;+	_ -> happyError' tk+	})++happyError_ tk = happyError' tk++happyThen :: () => PM a -> (a -> PM b) -> PM b+happyThen = (thenPM)+happyReturn :: () => a -> PM a+happyReturn = (returnPM)+happyThen1 = happyThen+happyReturn1 :: () => a -> PM a+happyReturn1 = happyReturn+happyError' :: () => (HToken) -> PM a+happyError' tk = (\token -> happyError) tk++parse = happySomeParser where+  happySomeParser = happyThen (happyParse action_0) (\x -> case x of {HappyAbsSyn5 z -> happyReturn z; _other -> notHappyAtAll })++parseExp = happySomeParser where+  happySomeParser = happyThen (happyParse action_1) (\x -> case x of {HappyAbsSyn88 z -> happyReturn z; _other -> notHappyAtAll })++happySeq = happyDontSeq+++qtuple n pos = qualify mod_Prelude (tuple n) pos+qunit = qualify mod_Prelude "()"++conD (con,ts) s vs ctx = HsConDecl s vs ctx con ts+fconD con fs  s vs ctx  = HsRecDecl s vs ctx con fs+++happyError = parseError "syntax error"+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 28 "templates/GenericTemplate.hs" #-}+++++++++{-# LINE 49 "templates/GenericTemplate.hs" #-}++{-# LINE 59 "templates/GenericTemplate.hs" #-}++{-# LINE 68 "templates/GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is (1), it means we've just accepted a partial+-- parse (a %partial parser).  We must ignore the saved token on the top of+-- the stack in this case.+happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) =+	happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = +	 (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++{-# LINE 155 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++++newtype HappyState b c = HappyState+        (Int ->                    -- token number+         Int ->                    -- token number (yes, again)+         b ->                           -- token semantic value+         HappyState b c ->              -- current state+         [HappyState b c] ->            -- state stack+         c)++++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =+     let i = (case x of { HappyErrorToken (i) -> i }) in+--     trace "shifting the error token" $+     new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)++happyShift new_state i tk st sts stk =+     happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk+     = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')+     = let r = fn v1 in+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')+     = let r = fn v1 v2 in+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+     = let r = fn v1 v2 v3 in+       happySeq r (action nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happyReduce k nt fn j tk st sts stk+     = case happyDrop (k - ((1) :: Int)) sts of+	 sts1@(((st1@(HappyState (action))):(_))) ->+        	let r = fn stk in  -- it doesn't hurt to always seq here...+       		happyDoSeq r (action nt j tk st1 sts1 r)++happyMonadReduce k nt fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+        happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))+       where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))+             drop_stk = happyDropStk k stk++happyMonad2Reduce k nt fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+       happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))+       where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))+             drop_stk = happyDropStk k stk++++++             new_state = action+++happyDrop (0) l = l+happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t++happyDropStk (0) l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction++{-# LINE 253 "templates/GenericTemplate.hs" #-}+happyGoto action j tk st = action j j tk (HappyState action)+++-----------------------------------------------------------------------------+-- Error recovery ((1) is the error token)++-- parse error if we are in recovery and we fail again+happyFail  (1) tk old_st _ stk =+--	trace "failing" $ +    	happyError_ tk++{-  We don't need state discarding for our restricted implementation of+    "error".  In fact, it can cause some bogus parses, so I've disabled it+    for now --SDM++-- discard a state+happyFail  (1) tk old_st (((HappyState (action))):(sts)) +						(saved_tok `HappyStk` _ `HappyStk` stk) =+--	trace ("discarding state, depth " ++ show (length stk))  $+	action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+--                       save the old token and carry on.+happyFail  i tk (HappyState (action)) sts stk =+--      trace "entering error recovery" $+	action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions++++++++-----------------------------------------------------------------------------+-- Seq-ing.  If the --strict flag is given, then Happy emits +--	happySeq = happyDoSeq+-- otherwise it emits+-- 	happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq   a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template.  GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.++{-# LINE 317 "templates/GenericTemplate.hs" #-}+{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ tools/base/parse2/Parser/HsParser.y view
@@ -0,0 +1,1092 @@++-- Low-level Haskell Parser+-- Bill Harrison and Emir Pasalic and Andrew Moran and Thomas Hallgren+--+-- Note: +--   This parser is based on Simon Marlow and Sven Panne's (1997,1998) Haskell+--   grammar for Happy. +--   The parser does not correspond strictly to the grammar of standard+--   Haskell.  Rather, it relies on a number of postprocessing steps that +--    (1) validate the rather leaky terms produced by the and discard invalid +--        programs +--    (2) perform a small amount of rewriting (e.g., for infix operator+--        precedences)++{+module HsParser (parse,parseExp) where+ +import PosSyntax+--import SyntaxUtil+import HsTokens(Token(..))+import ParseMonad+import HsLexer+import LexUtil(readInteger, readRational)+import ParseUtil+--import IOExts++}++%token+--- Reserved Ids ----------------------+	'as'		{ (Varid     ,($$,"as")) }+	'case'		{ (Reservedid,($$,"case")) }+	'class'		{ (Reservedid,($$,"class")) }+	'data'		{ (Reservedid,($$,"data")) }+	'default'	{ (Reservedid,($$,"default")) }+	'deriving'	{ (Reservedid,($$,"deriving")) }+	'do'		{ (Reservedid,($$,"do")) }+	'else'		{ (Reservedid,($$,"else")) }++        -- higher rank poly extension+        'forall'        { (Varid     ,($$,"forall")) }++	'hiding'	{ (Varid     ,($$,"hiding")) }+	'if'		{ (Reservedid,($$,"if")) }+	'import'	{ (Reservedid,($$,"import")) }+	'in'		{ (Reservedid,($$,"in")) }+	'infix'		{ (Reservedid,($$,"infix")) }+	'infixl'	{ (Reservedid,($$,"infixl")) }+	'infixr'	{ (Reservedid,($$,"infixr")) }+	'instance'	{ (Reservedid,($$,"instance")) }+	'let'		{ (Reservedid,($$,"let")) }+	'module'	{ (Reservedid,($$,"module")) }+	'newtype'	{ (Reservedid,($$,"newtype")) }+	'of'		{ (Reservedid,($$,"of")) }+	'then'		{ (Reservedid,($$,"then")) }+	'type'		{ (Reservedid,($$,"type")) }+	'where'		{ (Reservedid,($$,"where")) }+	'qualified'	{ (Varid     ,($$,"qualified")) }+	'_'		{ (Reservedid,($$,"_")) }+	'primitive'     { (Varid     ,($$,"primitive")) } -- Hugs extension+	'foreign'       { (Varid     ,($$,"foreign")) } -- FFI extension+--- Symbols --------------------------+	'('	{ (Special,($$,"(")) }+	')'	{ (Special,($$,")")) }+	';'	{ (Special,($$,";")) }+	'{'	{ (Special,($$,"{")) }+	'}'	{ (Special,($$,"}")) }+	VLCURLY { (Layout ,($$,"{")) }	      -- a virtual open brace+	VRCURLY { (Layout ,($$,"}")) }	      -- a virtual close brace+	'['	{ (Special,($$,"[")) }+	']'	{ (Special,($$,"]")) }+  	','	{ (Special,($$,",")) }+	'`'	{ (Special,($$,"`")) }++        '.'     { (Varsym, ($$,".")) } -- must be a token so it can matched in+	                               -- property quantifier expressions; it+                                       -- must be turned into an id when not+                                       -- matched thus, or used in a float.+++--- Reserved operators ----------------++	'..'	{ (Reservedop,($$,"..")) }+	':'	{ (Reservedop,($$,":")) }+	'::'	{ (Reservedop,($$,"::")) }+	'='	{ (Reservedop,($$,"=")) }+	'\\'	{ (Reservedop,($$,"\\")) }+	'|'	{ (Reservedop,($$,"|")) }+	'<-'	{ (Reservedop,($$,"<-")) }+	'->'	{ (Reservedop,($$,"->")) }+	'@'	{ (Reservedop,($$,"@")) }+	'~'	{ (Reservedop,($$,"~")) }+	'=>'	{ (Reservedop,($$,"=>")) }+	'!'	{ (Varsym    ,($$,"!")) }++--- Open token classes:+        VARID 	 { (Varid,$$) }+	QVARID 	 { (Qvarid,$$) }+	CONID	 { (Conid,$$) }+	QCONID   { (Qconid,$$) }+	'-'	 { (Varsym,($$,"-")) }+	VARSYM	 { (Varsym,$$) }+	CONSYM	 { (Consym,$$) }+	QVARSYM	 { (Qvarsym,$$) }+	QCONSYM  { (Qconsym,$$) }+	INT	 { (IntLit,$$) }+	RATIONAL { (FloatLit,$$) }+	CHAR	 { (CharLit,$$) }+	STRING   { (StringLit,$$) }++        BADTOKEN { $$ } -- This is reported as an unused terminal.+		        -- It is included to turn lexical errors into syntax+		        -- errors, rather than pattern match failures in +			-- the generated parser.++%monad { PM } { thenPM } { returnPM }+%lexer { lexer } { (GotEOF,_) }+%name parse+%name parseExp exp+%tokentype { HToken }++-- Precedences, from lowest to highest+%right '->' 'in' 'else'+%right '::'+%left VARSYM '-' QVARSYM CONSYM QCONSYM '`' '!' ':' '.' -- FIRST(qop)+%left 'as' 'hiding' 'qualified' 'foreign' VARID CONID QCONID '(' '[' -- FIRST(atype)+%%+{-++-----------------------------------------------------------------------------+Module Header++-}+module :: { HsModuleR }+        : 'module' modid maybeexports 'where' body+			     { hsModule $1 $2 $3 $5 }+        | srcloc body	     { hsMainModule $1 $2 }++body :: { ([HsImportDecl], [HsDecl]) }+	:   '{' bodyaux '}'			{ $2 }+ 	| open  bodyaux close			{ $2 }++bodyaux :: { ([HsImportDecl], [HsDecl]) }+	: impdecls semis1 topdecls semis    { ($1, $3) }+	|                 topdecls semis    { ([], $1) }+	| impdecls                 semis    { ($1, []) }+	| {- empty -}	  		   { ([], []) }++semis1 :: { () }+        : ';' semis1                    { () }+        | ';'                           { () }++semis :: { () }+        : ';' semis                         { () }+        | {- empty -}                       { () }++++{-++-----------------------------------------------------------------------------+The Export List++-}+maybeexports :: { Maybe [HsExportSpec] }+ 	:  exports				{ Just $1 }+ 	|  {- empty -}				{ Nothing }++exports :: { [HsExportSpec] }+	: '(' optcomma exportlist optcomma ')'		{ reverse $3 }+	| '(' ')'				{ [] }++optcomma :: { () }+	: ','					{ () }+	| {- empty -}				{ () }++exportlist :: { [HsExportSpec] }+ 	:  exportlist ',' export		{ $3 : $1 }+ 	|  export				{ [$1]  }++export :: { HsExportSpec }+ 	:  qvar				     { EntE (Var $1) }+ 	|  qtyconorcls			     { EntE (Abs $1) }+ 	|  qtyconorcls '(' '..' ')'	     { EntE (AllSubs $1) }+ 	|  qtyconorcls '(' ')'		     { EntE (ListSubs $1 []) }+ 	|  qtyconorcls '(' qcnames ')'	     { EntE (ListSubs $1 (reverse $3)) }+ 	|  'module' modid		     { ModuleE $2 }++qcnames :: { [HsIdent] }+ 	:  qcnames ',' qcname			{ $3 : $1 }+ 	|  qcname				{ [$1]  }++qcname :: { HsIdent }+	:  qvar					{ HsVar $1 }+ 	|  qcon					{ HsCon $1 }+{-++-----------------------------------------------------------------------------+Import Declarations++-}+impdecls :: { [HsImportDecl] }+	: impdecls semis1 impdecl		{ $3 : $1 }+	| impdecl				{ [$1] }++impdecl :: { HsImportDecl }+	: 'import' optqualified modid maybeas maybeimpspec+ 		  		{ HsImportDecl $1 $3 $2 $4 $5 }++optqualified :: { Bool }+        : 'qualified'                            { True  }+        | {- empty -}				{ False }++maybeas :: { Maybe ModuleName }+        : 'as' modid                             { Just $2 }+        | {- empty -}				{ Nothing }++maybeimpspec :: { Maybe (Bool, [HsImportSpec]) }+	: impspec				{ Just $1 }+	| {- empty -}				{ Nothing }++impspec :: { (Bool, [HsImportSpec]) }+ 	: optimportlist  	          { (False, reverse $1) }+ 	| 'hiding' optimportlist          { (True,  reverse $2) }++optimportlist :: { [HsImportSpec] }+        : '(' optcomma ')'		  { [] }+	| '(' importlist optcomma ')'	  { $2 }+	      +importlist :: { [HsImportSpec] }+ 	:  importlist ',' import		{ $3 : $1 }+ 	|  import				{ [$1]  }++import :: { HsImportSpec }+ 	:  var				      { Var $1 }+ 	|  tyconorcls			      { Abs $1 }+ 	|  tyconorcls '(' '..' ')'	      { AllSubs $1 }+ 	|  tyconorcls '(' ')'		      { ListSubs $1 [] }+ 	|  tyconorcls '(' cnames ')'	      { ListSubs $1 (reverse $3) }++cnames :: { [HsIdent] }+ 	:  cnames ',' cname			{ $3 : $1 }+ 	|  cname				{ [$1]  }++cname :: { HsIdent }+	:  var					{ HsVar $1 }+ 	|  con					{ HsCon $1 }++{-++-----------------------------------------------------------------------------+Top-level declarations.++-}++topdecls :: { [HsDecl] }+	: topdecls semis1 topdecl     { foldl (flip funCons) $1 $3 }+	| topdecl		      { $1 }++{-++-----------------------------------------------------------------------------+Fixity Declarations++checkPrec has been eliminated; fixities may now be negative => must be added+to the static check.++-}++fixitydecl :: { HsDecl }+ 	: infix prec ops   { hsInfixDecl (fst $1) (HsFixity (snd $1) $2) $3 }+	                +prec :: { Int }+	: {- empty -}		  { 9 }+	| INT		          { fromInteger (readInteger (snd $1)) }++infix :: { (SrcLoc,HsAssoc) }+	: 'infix'				{ ($1,HsAssocNone)  }+	| 'infixl'				{ ($1,HsAssocLeft)  }+	| 'infixr'				{ ($1,HsAssocRight) }++ops   :: { [HsIdent] }+	: op ',' ops				{ $1 : $3 }+	| op					{ [$1] }++{-++-----------------------------------------------------------------------------+Top-Level Declarations++Note: The report allows topdecls to be empty. This would result in another+shift/reduce-conflict, so we don't handle this case here, but in bodyaux.++-}++topdecl :: { [HsDecl] }+  -- Hugs compatibility (quick hack)+  : 'primitive' vars optimpent '::' type     { [hsPrimitiveBind $1 v $5|v<-$2] }+  | topdecl1	{ [$1] }++optimpent :: { Maybe String }+	  :        { Nothing }+	  | impent { Just $1 }++topdecl1 :: { HsDecl }+  : decl                                            { $1 }+  | 'type' simpletype '=' type                      { hsTypeDecl $1 $2 $4 }+  | 'data' ctyconparams '=' constrs deriving        { uncurry (hsDataDecl $1) $2 (reverse $4) $5 } +  | 'newtype' ctyconparams '=' constr deriving      {% chkNewtype $4 >> return (uncurry (hsNewTypeDecl $1) $2 $4 $5) }+  | 'class' ctyconparams optfundeps optcbody        { uncurry (hsClassDecl $1) $2 $3 $4 }+  | 'instance' ctype optibody                       { uncurry (hsInstDecl $1 Nothing) $2 $3 }+  | 'default' '(' opttypes ')'                      { hsDefaultDecl $1 $3 }++  -- Hugs compatibility+  | 'data' ctyconparams            { uncurry (hsPrimitiveTypeDecl $1) $2 }+  -- Old FFI+  | 'foreign' 'import' var '::' type          { hsPrimitiveBind $1 $3 $5 }+  -- FFI, see http://www.cse.unsw.edu.au/~chak/haskell/ffi/+  | 'foreign' 'import' callconv var '::' type { hsPrimitiveBind $1 $4 $6 }+  | 'foreign' 'import' callconv safety var '::' type { hsPrimitiveBind $1 $5 $7 }+  | 'foreign' 'import' callconv impent var '::' type { hsPrimitiveBind $1 $5 $7 }+  | 'foreign' 'import' callconv safety impent var '::' type { hsPrimitiveBind $1 $6 $8 }++callconv :: { HsName }+         : varid        { $1 }++safety   :: { HsName }+          : varid        { $1 }++impent 	 :: { String }+          : STRING       { snd $1 }++optfundeps :: { HsFunDeps HsName }+	   :			 	{ [] }+	   | '|' fundeps		{ $2 }++fundeps	   :: { HsFunDeps HsName }+	   : fundep			{ [$1] }+	   | fundep ',' fundeps		{ $1:$3 }++fundep	   :: { HsFunDep HsName }+	   : tyvars '->' tyvars		{ ($1,$3) }++tyvars	   :: { [HsName] }+	   :				{ [] }+	   | tyvar tyvars		{ $1:$2 }++decls :: { [HsDecl] }+	: decls1 semis                  { reverse $1 }+	| semis                         { [] }++decls1 :: { [HsDecl] }+	: decls1 semis1 decl		{ funCons $3 $1 }+	| decl				{ [$1] }++decl :: { HsDecl }+        : gendecl                       { $1 }+        | valdef			{ $1 }+{-+        -- Property declarations+        | propdecl                      { $1 }+-}++gendecl :: { HsDecl }+        : signdecl              { $1 }+        | fixitydecl            { $1 }++decllist :: { [HsDecl] }+	:  '{' decls '}'	{ $2 }+	| open decls close	{ $2 }++signdecl :: { HsDecl }+	: vars '::' ctype+	      { uncurry (hsTypeSig $2 (reverse $1)) $3 }+{-+++ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var+instead of qvar, we get another shift/reduce-conflict. Consider the+following programs:++   { (+) :: ... }          A "signdecl" where everything to the left of the+                           :: is parsed as "vars" which should allow only var++   { (+) x y  = ... }      A "valdef" where everything to the left of the+                           = is parsed as an "exp0" which (incorrectly+                           in this context) allows a "qvar", since "exp0"+                           is also used to parse patterns where "qvar" is+                           allowed++This leads to a shift/reduce-conflict. The parser must decide without too much+lookahead.  By allowing a qvar as the first thing in "vars" the parser shifts+(until it sees a "," or a "::") and doesn't get confused.  Without this,+deciding what to do with requires more lookahead.  So let's allow "qvar" in+"vars" and then check for ourselves afterwards that this didn't happen.++-}+vars	:: { [HsName] }+	: vars ',' var		{ $3 : $1 }+	| unqvar		{ [$1] }++unqvar	:: { HsName }+        : qvar			{% if isQualified $1+				   then fail "Qualified names not allowed here ."+				   else return $1+				}+{-+-----------------------------------------------------------------------------+Types+-}++type :: { HsType }+	: btype '->' type           { hsTyFun $1 $3 }+	| btype         %prec '->'  { $1 }+        -- higher rank poly extension -------------------+        | 'forall' tyvars '.' ctype { uncurry (hsTyForall $2) $4 }++btype :: { HsType }+        : btype atype   %prec '->'  { hsTyApp $1 $2 }+        | atype                     { $1 }++atype :: { HsType }+	: gtycon			{ hsTyCon $1 }+	| tyvar				{ hsTyVar $1 }+	| '[' type ']'			{ hsTyApp (list_tycon $1) $2 }+	| '(' types ')'			{ case $2 of+					    [t] -> t+					    ts -> hsTyTuple $1 ts }++opttypes :: { [HsType] }+	 :			   { [] }+	 | types		   { $1 }++types	:: { [HsType] }+	: type ',' types	   { $1 : $3 }+	| type	                   { [$1] }++gtycon :: { HsName }+	: qtycon			{ $1 }+	| '(' ')'			{ unit_tycon_name $1 }+	| '[' ']'			{ list_tycon_name $1 }+	| '(' '->' ')'	                { fun_tycon_name $1 }+	| '(' commas ')'		{ tuple_tycon_name $2 $1 }+{-++(Slightly edited) Comment from GHC's hsparser.y:+"context => type" vs  "type" is a problem, because you can't distinguish+between:++	foo :: (Baz a, Baz a)++	bar :: (Baz a, Baz a) => [a] -> [a] -> [a]++with one token of lookahead.  The HACK is to parse the context as a btype+(more specifically as a tuple type), then check that it has the right form+C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!++-}+ctype :: { ([HsType],HsType) }+	: context '=>' type      { ($1, $3) }+	| type		       { ([], $1) }++context :: { [HsType] }+	: btype		       { tupleTypeToContext $1 }+++simpletype :: { HsType }+	: tycon tyvars         { foldl1 hsTyApp (hsTyCon $1:map hsTyVar $2) }++ctyconparams :: { ([HsType], HsType) }+        : ctype                {% chkTypeLhs $1 }++{-+ctyconparams :: { ([HsType], [HsType]) }+--	: type '=>' tyconparams     { (reverse (tupleTypeToContext $1), $3) }+	: tyconparams               { ([], $1) }++-- Replacing tycon with gtycon as an experiment: /TH+tyconparams :: { [HsType] }+        : gtycon typarams           { hsTyCon $1 : reverse $2 }+--	| gtycon		    { [hsTyCon $1] }++typarams :: { [HsType] }+	: typarams tyvar            { hsTyVar $2 : $1 }+	|			    { [] }+-}+{-+ctybinding :: { ([HsType], HsName) }+	: ctyconparams  {% case snd $1 of+		             Typ (HsTyCon nm) -> return (fst $1,nm)+			     _ -> fail "Primitive types are not allowed to have parameters" }+-}+{-++-----------------------------------------------------------------------------+Datatype declarations++-}+constrs :: { [HsConDecl HsType [HsType]] }+	: constrs '|' constr		{ $3 : $1 }+	| constr			{ [$1] }++-- Constructor with (optional) existential quantification:+constr :: { HsConDecl HsType [HsType] }+	: srcloc existq plain_constr	           { $3 $1 $2 [] }+	| srcloc existq context '=>' plain_constr  { $5 $1 $2 $3 }++-- Extension for existentially quantified types (with GHC compatible syntax):+existq :: { [HsName] }+       :				   { [] }+       | 'forall' tyvars '.'               { $2 }++plain_constr :: { SrcLoc -> [HsName] -> [HsType] -> HsConDecl HsType [HsType] }+	: scontype	         { conD $1 }+	| sbtype conop sbtype    { conD ($2,[$1,$3]) }+	| con '{' fielddecls '}' { fconD $1 (reverse $3) }++scontype :: { (HsName, [HsBangType HsType]) }+	: btype			    {% do { (c, ts) <- splitTyConApp $1 ;+					    return (c, map HsUnBangedType ts)+					  }+				    }+	| scontype1		    { $1 }+        | '(' consym ')' satype satype   { ($2,[$4,$5]) }++scontype1 :: { (HsName, [HsBangType HsType]) }+	: btype '!' atype+	      {% do { (c, ts) <- splitTyConApp $1 ;+		      return (c, map HsUnBangedType ts ++ [HsBangedType $3])+		    }+	      }+	| scontype1 satype		+              { (fst $1, snd $1 ++ [$2] ) }+{-+satypes :: { [HsBangType HsType] }+	:				{ [] }+	| satype satypes		{ $1:$2 }+-}+satype :: { HsBangType HsType }+	: atype				{ HsUnBangedType $1 }+	| '!' atype			{ HsBangedType   $2 }++sbtype :: { HsBangType HsType }+	: btype				{ HsUnBangedType $1 }+	| '!' atype			{ HsBangedType   $2 }++fielddecls :: { [([HsName], HsBangType HsType)] }+	: fielddecls ',' fielddecl	{ $3 : $1 }+	| fielddecl			{ [$1] }++fielddecl :: { ([HsName], HsBangType HsType) }+	: vars '::' stype		{ (reverse $1, $3) }++stype :: { HsBangType HsType}+	: type				{ HsUnBangedType $1 }	+	| '!' atype			{ HsBangedType   $2 }++deriving :: { [HsName] }+	: {- empty -}			{ [] }+	| 'deriving' qtycls		{ [$2] }+	| 'deriving' '('          ')'	{ [] }+	| 'deriving' '(' dclasses ')'	{ reverse $3 }++dclasses :: { [HsName] }+	: dclasses ',' qtycls		{ $3 : $1 }+        | qtycls			{ [$1] }++--- Class declarations ---------------------------------------------------------++optcbody :: { [HsDecl] }+	: 'where'  '{' cdecls '}'		{ $3 }+	| 'where' open cdecls close		{ $3 }+	| {- empty -}				{ [] }++cdecls :: { [HsDecl] }+	:                                       { [] }+	| cdecls1                               { reverse $1 }++cdecls1 :: { [HsDecl] }+	: cdecl                                 { [$1] }+	| cdecls1 semis1 cdecl                  { funCons $3 $1 }++cdecl :: { HsDecl }+      : decl                                    { $1 }+         {- except that pattern bindings aren't allowed! -}+++--- Instance declarations ------------------------------------------------------++optibody :: { [HsDecl] }+	: 'where'  '{' idecls '}'	{ $3 }+	| 'where' open idecls close	{ $3 }+	| {- empty -}			{ [] }++idecls :: { [HsDecl] }+	:                                       { [] }+	| idecls1                               { reverse $1 }++idecls1 :: { [HsDecl] }+	: idecl                                 { [$1] }+	| idecls1 semis1 idecl                  { funCons $3 $1 }++idecl :: { HsDecl }+	: valdef	       	                { $1 }++{-++-----------------------------------------------------------------------------+Value definitions++-}++{-+valdef :: { HsDecl }+	: exp0 srcloc rhs optwheredecls+				    {% if isPatternExp $1 +                                       then mkValDef $1 $2 $3 $4+                                       else mkFunDef $1 $2 $3 $4+				    }+-}++valdef :: { HsDecl }+	: funlhs srcloc rhs optwheredecls   { mkFunDef' $1 $2 $3 $4 }+        | pat0 srcloc rhs optwheredecls { hsPatBind $2 $1 $3 $4 }++funlhs :: { (HsName,[HsPat]) }+        : qvar apats1               { ($1,$2) }+        | pat0 qvarop pat0          { ($2,[$1,$3]) }+        | '(' funlhs ')' apats      { (fst $2,snd $2++$4) }+	              -- ^ Haskell 98 requires apats1 (at least one apat)++optwheredecls :: { [HsDecl] }+        : 'where' decllist          { $2 }+        | {- empty -}               { [] }++rhs	:: { HsRhs HsExp }+	: '=' exp		    { HsBody $2 }+	| gdrhss		    { HsGuard (reverse $1) }++gdrhss :: { [(SrcLoc, HsExp, HsExp)] }+	: gdrhss gdrhs		    { $2 : $1 }+	| gdrhs			    { [$1] }++gdrhs :: { (SrcLoc, HsExp, HsExp) }+	: '|' exp '=' exp    { ($1, $2, $4) }++{-++-----------------------------------------------------------------------------+Expressions++-}+exp   :: { HsExp }+	: exp0 '::' ctype      	{ hsExpTypeSig $2 $1 (fst $3) (snd $3) }+        | exp0	     %prec '::' { $1 }++exp0 :: { HsExp }+	: exp0 qop exp0     %prec VARSYM { hsInfixApp $1 $2 $3 }+	| '\\' apats '->' exp            { hsLambda $2 $4 }+  	| 'let' decllist 'in' exp	 { hsLet $2 $4 }+	| 'if' exp 'then' exp 'else' exp { hsIf $2 $4 $6 }+   	| 'case' exp 'of' altslist	 { hsCase $2 $4 } +	| '-' fexp			 { hsNegApp $1 $2 }+  	| 'do' stmtlist			 {% hsDo `fmap` atoms2Stmt $2 }+	| fexp				 { $1 }++fexp :: { HsExp }+	: fexp aexp			{ hsApp $1 $2 }+  	| aexp				{ $1 }++{-++Note: The first alternative of aexp is not neccessarily a record update, it+could be a labeled construction, too.++-}+aexp	:: { HsExp }+  	: aexp '{' fbinds '}'        { mkRecord $2 $1 (reverse $3) }+  	| aexp1			     { $1 }++aexp1	:: { HsExp }+	: qvar			     { hsEVar ($1 :: HsName) }+	| gcon			     { $1 }+  	| literal		     { uncurry hsLit $1 }+--	| '(' exp ')'		     { hsParen $2 }+	| '(' exps ')'		     { case $2 of+                                         [e] -> hsParen e+				         es -> hsTuple es }+	| '[' list ']'               { $2 }+	| '(' exp0 qop ')'	     { hsLeftSection $2 $3 }+	| '(' qopm exp0 ')'	     { hsRightSection $2 $3 }+{-+	| '(' qvar '=' ')'	     { undefined {- record update -} }+	| '(' qvar '=' exp ')'	     { undefined {- record update -} }+-}+	| qvar '@' aexp	             { hsAsPat $1 $3 }+	| '_'			     { hsWildCard }+	| '~' aexp1		     { hsIrrPat $2 }++commas :: { Int }+	: commas ','		     { $1 + 1 }+	| ','			     { 1 }++exps :: { [HsExp] }+	: exp ',' exps		     { $1 : $3 }+	| exp		             { [$1] }++{-++-----------------------------------------------------------------------------+List expressions++The rules below are little bit contorted to keep lexps left-recursive while+avoiding another shift/reduce-conflict.++-}+list :: { HsExp }+	: exp				{ hsList [$1] }+	| lexps 			{ hsList (reverse $1) }+	| exp '..'			{ hsEnumFrom $1 }+	| exp ',' exp '..' 		{ hsEnumFromThen $1 $3 }+	| exp '..' exp	 		{ hsEnumFromTo $1 $3 }+	| exp ',' exp '..' exp		{ hsEnumFromThenTo $1 $3 $5 }+	| exp '|' quals			+          {% hsListComp `fmap` atoms2Stmt (reverse $3 ++ [HsQualifierAtom $1]) }++lexps :: { [HsExp] }+	: lexps ',' exp 		{ $3 : $1 }+	| exp ',' exp			{ [$3,$1] }+{-++-----------------------------------------------------------------------------+List comprehensions++-}+quals :: { [HsStmtAtom HsExp HsPat [HsDecl] ] }+	: quals ',' qual		{ $3 : $1 }+	| qual				{ [$1] }++qual  :: { HsStmtAtom HsExp HsPat [HsDecl] }+	: exp0 '<-' exp	                {% do { p <- expToPat $1 ; +                                                return (HsGeneratorAtom $2 p $3)+					      }+					}+	| exp			  	{ HsQualifierAtom $1 }+  	| 'let' decllist		{ HsLetStmtAtom   $2 }++{-++-----------------------------------------------------------------------------+Case alternatives++-}+altslist :: { [HsAlt HsExp HsPat [HsDecl]] }+	: '{'   alts semis '}'	{ reverse $2 }+	| open  alts semis close	{ reverse $2 }+++alts :: { [HsAlt HsExp HsPat [HsDecl]] }+	: alts semis1 alt				{ $3 : $1 }+	| alt					{ [$1] }++alt :: { HsAlt HsExp HsPat [HsDecl] }+	: pat0 srcloc rhscasealts { HsAlt $2 $1 $3 [] }+	      {-% do { p <- expToPat $1 ;+	              return (HsAlt $2 p $3 [])+		    }+	      -} +        | pat0 srcloc rhscasealts 'where' decllist { HsAlt $2 $1 $3 $5 }+	      {-% do { p <- expToPat $1 ;+		      return (HsAlt $2 p $3 $5)+		    }+	      -}++rhscasealts :: { HsRhs HsExp }+	: '->' exp		            { HsBody $2 }+	| gdcaserhss		            { HsGuard (reverse $1) }++gdcaserhss :: { [(SrcLoc, HsExp, HsExp)] }+	: gdcaserhss gdcaserhs		    { $2 : $1 }+	| gdcaserhs			    { [$1] }++gdcaserhs :: { (SrcLoc, HsExp, HsExp) }+	: '|' exp  '->' exp          { ($1, $2, $4) }++{-++-----------------------------------------------------------------------------+Statement sequences++-}+stmtlist :: { [HsStmtAtom HsExp HsPat [HsDecl]] }+	:   '{' stmts '}'	{ $2 }+	| open  stmts close	{ $2 }++stmts :: { [HsStmtAtom HsExp HsPat [HsDecl]] }+  	:  qual semis1 stmts  	      { $1 : $3 }+        | semis1 stmts                   { $2 }+        | qual			      { [$1] }+        | qual semis1                 { [$1] }++--- Record Field Update/Construction -------------------------------------------++fbinds :: { [HsField HsExp] }+	  :				{ [] }+	  | fbinds1			{ $1 }++fbinds1 :: { [HsField HsExp] }+	: fbinds1 ',' fbind		{ $3 : $1 }+	| fbind				{ [$1] }++fbind	:: { HsField HsExp }+	: qvar '=' exp			{ HsField $1 $3 }+--	| qvar				{ HsFieldBind $1 }++--- Patterns -------------------------------------------------------------------++pat :: { HsPat }+        : pat0                    { $1 }+--      | qvar '+' integer        { let (s,i) = $3 in hsPSucc s $1 i }++pat0 :: { HsPat }+	: pat10                   { $1 }+	| pat0 qconop pat10       { hsPInfixApp $1 $2 $3 }++pat10 :: { HsPat }+        : qcon apats1             { hsPApp $1 $2 } -- should be gcon...+	| '-' numlit		  { hsPNeg $1 (snd $2) }+        | apat                    { $1 }++apat :: { HsPat }+        : qvar                    { hsPVar $1 }+        | qvar '@' apat           { hsPAsPat $1 $3 }+        | qcon                    { hsPCon $1 } -- should be gcon...+	| '(' ')'                 { hsPCon (qunit $1) }+        | qcon '{' fpats '}'      { hsPRec $1 $3 }+        | literal                 { uncurry hsPLit $1 }+        | '_'                     { hsPWildCard }+	| '(' pat ')'             { hsPParen $2 }+	| '(' tpats ')'           { hsPTuple $1 $2 }+	| '[' lpats ']'           { hsPList $1 $2 }+        | '~' apat                { hsPIrrPat $2 }++apats1 :: { [HsPat] }+        : apat apats              { $1 : $2 }++apats :: { [HsPat] }+	:                         { [] }+	| apat apats              { $1 : $2 }++fpats :: { [HsField HsPat] }+        :                         { [] }+        | fpats1                  { $1 }++fpats1 :: { [HsField HsPat] }+        : fpat ',' fpats1         { $1 : $3 }+	| fpat                    { [$1] }++fpat :: { HsField HsPat }+        : qvar '=' pat            { HsField $1 $3 }++tpats :: { [HsPat] }+        : pat ',' tpats           { $1 : $3 }+        | pat ',' pat             { [$1, $3] }++lpats :: { [HsPat] }+        :                         { [] }+	| lpats1                  { $1 }++lpats1 :: { [HsPat] }+        : pat ',' lpats           { $1 : $3 }+        | pat                     { [$1] }++{-++-----------------------------------------------------------------------------+Variables, Constructors and Operators.++-}+gcon :: { HsExp }+	: '[' ']'		     { hsList [] }+        | tupcon		     { hsECon $1 }+  	| qcon			     { hsECon $1 }++tupcon :: { HsName }+        : '(' ')'		     { qunit $1 }+	| '(' commas ')'	     { qtuple $2 $1 }++var 	:: { HsName }+	: varid			{ $1 }+	| '(' varsym ')'	{ $2 }++qvar 	:: { HsName }+	: qvarid		{ $1 }+	| '(' qvarsym ')'	{ $2 }++con	:: { HsName }+	: conid			{ $1 }+	| '(' consym ')'        { $2 }++qcon	:: { HsName }+	: qconid		{ $1 }+	| '(' gconsym ')'	{ $2 }++varop	:: { HsName }+	: varsym		{ $1 }+	| '`' varid '`'		{ $2 }++qvarop :: { HsName }+	: qvarsym		{ $1 }+	| '`' qvarid '`'	{ $2 }++qvaropm :: { HsName }+	: qvarsymm		{ $1 }+	| '`' qvarid '`'	{ $2 }++conop :: { HsName }+	: consym		{ $1 }	+	| '`' conid '`'		{ $2 }++qconop :: { HsName }+	: gconsym		{ $1 }+	| '`' qconid '`'	{ $2 }++op	:: { HsIdent }+	: varop			{ hsVar $1 }+	| conop 		{ hsCon $1 }++qop	:: { HsIdent }+	: qvarop		{ hsVar $1 }+	| qconop		{ hsCon $1 }++gconsym :: { HsName }+	: qconsym		{ $1 }++qopm	:: { HsIdent }+	: qvaropm		{ hsVar $1 }+	| qconop		{ hsCon $1 }++qvarid :: { HsName }+	: varid			{ $1 }+	| QVARID		{ qualid $1 }++varid1 :: { HsName }+	: VARID			{ unqualid $1 }+	| 'as'			{ unqualid ($1,"as") }+	| 'qualified'           { unqualid ($1,"qualified") }+	| 'hiding'		{ unqualid ($1,"hiding") }+        | 'foreign'	        { unqualid ($1,"foreign") }+--      | 'primitive'	        { primitive_name $1 }+--      | 'forall'	        { forall_name $1 }++varid :: { HsName }+        : varid1                { $1 }+        | 'forall'              { unqualid ($1,"forall") }+++qconid :: { HsName }+	: conid			{ $1 }+        | QCONID		{ qualid $1 }++qtycon :: { HsName }+	: tycon			{ $1 }+	| QCONID		{ qualid $1 }++conid :: { HsName }+	: CONID			{ unqualid $1 }++qconsym :: { HsName }+	: consym		{ $1 }+	| QCONSYM		{ qualid $1 }++consym :: { HsName }+	: CONSYM		{ unqualid $1 }+	| ':'			{ unqualid ($1,":") }+	 -- ':' should really be part fo gconsym...++qvarsym :: { HsName }+	: varsym		{ $1 }+	| qvarsym1		{ $1 }++qvarsymm :: { HsName }+	: varsymm		{ $1 }+	| qvarsym1		{ $1 }++varsym :: { HsName }+        : VARSYM		{ unqualid $1 }+        | '-'			{ unqualid ($1,"-") }+        | '!'			{ unqualid ($1,"!") }+        | '.'                   { unqualid ($1,".") }++varsymm :: { HsName } -- varsym not including '-'+        : VARSYM		{ unqualid $1 }+        | '!'			{ unqualid ($1,"!") }+        | '.'                   { unqualid ($1,".") }++qvarsym1 :: { HsName }+	: QVARSYM		{ qualid $1 }++literal :: { (SrcLoc,HsLiteral) }+	: numlit		{ $1 }+	| CHAR 			{ (fst $1,HsChar (read (snd $1))) }+	| STRING		{ (fst $1,HsString (read (snd $1))) }++numlit :: { (SrcLoc,HsLiteral) }+	: INT	       	{ let (s,l)=$1 in (s,HsInt (readInteger l)) }+	| RATIONAL	{ let (s,l)=$1 in (s,HsFrac (readRational l)) }+        +srcloc :: { SrcLoc }	:	{% getSrcLoc }++--- Layout ---------------------------------------------------------------------++open  :: { () }+       : VLCURLY		{ () }++close :: { () }+	: VRCURLY		{ () } -- context popped in lexer.+	| error			{% popContext }++--- Miscellaneous (mostly renamings) -------------------------------------------++modid :: { ModuleName }+--      : CONID			{ Module (snd $1) }+        : qconid                {% hsName2modName $1 }++tyconorcls :: { HsName }+	: conid			{ $1 }++tycon :: { HsName }+	: conid			{ $1 }++qtyconorcls :: { HsName }+	: qtycon		{ $1 }++qtycls :: { HsName }+	: qtycon		{ $1 }++tyvar :: { HsName }+	: varid1                { $1 }+{-++-----------------------------------------------------------------------------++     Property declarations++-----------------------------------------------------------------------------++From MPJ's Tool0 Hugs98 parser.y file:++gendecl   : PROPERTY pLhs '=' exp	{$$ = gc4(ap(PROP,ap($2,ap($3,$4))));}+	  | PROPERTY error		{syntaxError("property decl");}+	  ;+pLhs	  : pLhs varid			{$$ = gc2(ap($1,$2));}+	  | CONID			{$$ = $1;}+	  | error			{syntaxError("property defn lhs");}+	  ;+qfier	  : QALL			{$$ = gc1(quantAll);}+	  | QEX				{$$ = gc1(quantEx);}+	  | QALLDEF			{$$ = gc1(quantAlldef);}+	  | QEXU			{$$ = gc1(quantExu);}+	  ;++-}++{-++propdecl :: { HsDecl }+	: 'property' quant pLhs '=' exp  { hsProp $2 $3 $5 }++quant :: { HsQuantifier } +	: 'All'                          { hsPropForall } +        | 'Ex'                           { hsPropExists }+	| 'AllDef'                       { hsPropForallDefined }+	| 'ExU'                          { hsPropExistsUnique }++pLhs :: { [HsName] }+        : pLhs varid                     { $2 : $1 }+        | conid                          { [$1] }++-}++----------------------------------------------------------------------------+{+qtuple n pos = qualify mod_Prelude (tuple n) pos+qunit = qualify mod_Prelude "()"++conD (con,ts) s vs ctx = HsConDecl s vs ctx con ts+fconD con fs  s vs ctx  = HsRecDecl s vs ctx con fs+++happyError = parseError "syntax error"+}
+ tools/base/parse2/Parser/ParseUtil.hs view
@@ -0,0 +1,158 @@+{-+Utilities for the parser.++Author(s): Simon Marlow 1997, 1998;+           Emir Pasalic, Bill Harrison, Andrew Moran 2001+           Thomas Hallgren 2001, 2002+-}++module ParseUtil (chkTypeLhs,        -- ([HsType],HsType) -> m ([HsType],HsType)+		  splitTyConApp,     -- HsType -> m (HsName, [HsType])+		  mkValDef,          -- HsExp -> SrcLoc -> HsRhs HsExp+		                     --   -> [HsDecl] -> m HsDecl+                  mkFunDef,          -- HsExp -> SrcLoc -> HsRhs HsExp+                                     --   -> [HsDecl] -> m HsDecl+                  mkFunDef',+                  expToPat,          -- HsExp -> m HsPat+                  hsName2modName)    -- HsName -> ModuleName+                       -- Monad m => ...+		       -- The monad is used for error handling only+where++--import HsAssoc+import Syntax+--import SyntaxUtil(isConE)+import HsName+import SourceNames+import PrettyPrint+--import HsConstants(plus_name)+import MUtils++-- The LHSs of data/newtype/class declaration is parsed like a ctype (c=>t),+-- so this additional check is needed to ensure that they are well formed.+chkTypeLhs ct@(ctx,t) =+  do (c,as) <- splitTyConApp t+     if all isTyVar as+       then return ct+       else fail "bad lhs in data/newtype/class declaration"+  where+    isTyVar (Typ (HsTyVar _)) = True+    isTyVar _ = False++--splitTyConApp :: HsType -> m (HsName, [HsType])+splitTyConApp t = split t []+    where+    --split :: HsType -> [HsType] -> m (HsName, [HsType])+    split (Typ (HsTyApp t u)) ts = split t (u:ts)+    split (Typ (HsTyCon t))   ts = return (t, ts)+    split _                   _+        = fail "illegal data/newtype declaration"++--mkValDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> m HsDecl+mkValDef lhs sloc (HsBody b) wheres = +    do { lpat <- expToPat lhs ;+	 return $ hsPatBind sloc lpat (HsBody b) wheres+       }+mkValDef lhs sloc (HsGuard gds) wheres = +    do { lpat <- expToPat lhs ;+	 return $ hsPatBind sloc lpat (HsGuard gds) wheres+       }++--mkFunDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> m HsDecl+mkFunDef lhs sloc rhs wheres = +    do { (fnamePat, ps) <- getFundefPats lhs ; +	 case fnamePat of +         Pat (HsPId (HsVar nm)) ->+              return $ hsFunBind sloc [HsMatch sloc nm ps rhs  wheres]+         _                      ->+              fail $ "invalid function name in:\n\n" ++ pp lhs+       }++mkFunDef' (nm,ps) sloc rhs wheres =+    hsFunBind sloc [HsMatch sloc nm ps rhs wheres]++--getFundefPats :: HsExp -> m (HsPat, [HsPat])+getFundefPats (Exp pexp) = + case pexp of +   HsId (HsVar nm) -> return (hsPVar nm, [])+   HsApp l r ->  +     do { (pv, ps) <- getFundefPats l ;+          p        <- expToPat r ;+          return (pv, ps ++ [p])+	}+   HsInfixApp l (HsVar n) r -> +     do { lp  <- expToPat l ;+          rp  <- expToPat r ;+          return (hsPVar n, [lp, rp])+	}+   HsInfixApp l (HsCon n) r -> +     do { lp  <- expToPat l ;+          rp  <- expToPat r ;+          return (hsPCon n, [lp, rp])+	}+   HsParen e -> getFundefPats e+   _     -> fail $+	    "cannot use\n\n" ++ pp pexp +++	   "\n\nas a function definition pattern."++expToPat l@(Exp lhexp)  = +    case lhexp of +      HsId (HsVar n) -> return $ hsPVar n+      HsId (HsCon n) -> return $ hsPCon n+      HsLit s literal -> return $ hsPLit s literal+      HsNegApp s e   -> do p <- expToPat e+			   case p of+			     Pat (HsPLit s l) -> return (hsPNeg s l)+			     _ -> fail "only literals can be negated in patterns"+      HsLambda _ _   -> fail "lambdas not allowed in patterns."+      HsList es      -> do { ps <- sequence (map expToPat es) ;+			     return $ hsPList loc0 ps -- !! loc0+			   }+      HsTuple es     -> do { ps <- sequence (map expToPat es) ;+			     return $ hsPTuple loc0 ps -- !! loc0+			   }+      HsWildCard     -> return hsPWildCard+      HsIrrPat e     -> do { p <- expToPat e ; return $ hsPIrrPat p }+      HsAsPat nm e   -> do { p <- expToPat e ; return $ hsPAsPat nm p}+      HsApp (Exp (HsId (HsCon n))) r -> +                      do { rp <- expToPat r ;+			   return $ hsPApp n [rp]+			 }+      HsApp l r -> +                      do { lp <- expToPat l ;+                           rp <- expToPat r ;+                           case lp of +                           Pat (HsPApp n ps) ->+			        return $ hsPApp n (ps ++ [rp])+                           _                 ->+			        fail $+			        "Cannot use:\n\n" +++			        pp lhexp +++			        "\n\n as a pattern."+                          }+      HsInfixApp l (HsCon n) r -> +                       do { lp <- expToPat l ;+                            rp <- expToPat r ;+                            return $ hsPInfixApp lp n rp +			  }+      HsInfixApp ne (HsVar (SN op _)) ke | op==UnQual "+" -> -- n+k patterns!!!+                     do np <- expToPat ne+                        kp <- expToPat ke+                        case (np,kp) of+                          (Pat (HsPId (HsVar n)),Pat (HsPLit s l)) ->+                               return $ hsPSucc s n l+                          _ -> fail$ pp $ "Mailformed n+k pattern:"<+>lhexp++      -- HsParen e      -> expToPat e+      HsParen e      -> do+                           e1 <- expToPat e+                           return (Pat (HsPParen e1))++      HsRecConstr s con fields ->+                       do { pfs <- mapM fieldToPat fields ;+			    return $ hsPRec con pfs+			  }+      _              ->+          fail $ "ParseUtil.expToPat: not a valid/supported pattern:\n\n"+                       ++ pp lhexp+    where fieldToPat (HsField f e) = HsField f # expToPat e
+ tools/base/parse2/Parser/PosSyntax.hs view
@@ -0,0 +1,54 @@+module PosSyntax(module PosSyntax,module PosName,module Hs,SN) where+import Syntax hiding (ModuleName,HsName,Id,hsMainModule,hsTyTuple,main_name,is_unit_tycon_name,tupleTypeToContext)+import qualified Syntax as Hs hiding (ModuleName,HsName,Id,hsTyTuple)+import HsConstants(main_mod,tuple,mod_Prelude')+import qualified HsConstants as Hs+--import PrettyPrint+import SourceNames+import PosName+--import SpecialNames+import QualNames(isQual)+-- import Entity++pos i p = SN i p++type HsExp = HsExpI HsName+type HsPat = HsPatI HsName+type HsDecl = HsDeclI HsName+type HsType = HsTypeI HsName++type HsField = HsFieldI HsName+type HsImportDecl = HsImportDeclI ModuleName HsName+type HsConDecl = HsConDeclI HsName+type HsExportSpec = HsExportSpecI ModuleName HsName+type HsImportSpec = HsImportSpecI HsName+type HsModuleR = HsModuleI ModuleName HsName [HsDecl]++qualid (p,s) = pos (splitQualName (srcFile p) s) p++unqualid (p,s) = pos (UnQual s) p++qualify m n = pos (Qual m n)++tuple_con_name arity = qualify mod_Prelude' $ tuple arity+unit_tycon_name = pos Hs.unit_tycon_name+list_tycon_name = qualify mod_Prelude' "[]"+fun_tycon_name = qualify mod_Prelude' "->"+tuple_tycon_name arity = tuple_con_name arity++list_tycon = hsTyCon . list_tycon_name :: SrcLoc -> HsType+tuple_tycon n = hsTyCon . tuple_tycon_name n :: SrcLoc -> HsType++hsTyTuple p ts = foldl hsTyApp (tuple_tycon (length ts-1) p) ts++isQualified = isQual :: HsName -> Bool++tupleTypeToContext t = tupleTypeToContext' is_unit_tycon_name is_tuple_tycon_name t+is_tuple_tycon_name arity n = n==tuple_tycon_name arity undefined+is_unit_tycon_name n = n==unit_tycon_name undefined++-- An omitted module header is equivalent to module Main(main) where ...+hsMainModule loc body =+    hsModule loc (pos (main_mod (srcFile loc)) loc)+             (Just [exportVar (main_name loc)]) body+main_name = pos Hs.main_name
+ tools/base/parse2/ParserOptions.hs view
@@ -0,0 +1,23 @@+module ParserOptions where++data Flags+  = Flags {+      prel::Bool,       -- Should all modules implicitly import Prelude?+      plogic::Bool,     -- Recognize extra keywords for Plogic?+      cpp::Maybe String -- Should the C preprocessor be used?+    }+    deriving (Eq,Show,Read)++flags0 = Flags True True Nothing+cpp1= "/lib/cpp -traditional -P -D__HASKELL98__ -D__PFE__"++parserOptions flags args =+  case args of+    "noprelude":args         -> parserOptions flags{prel=False   } args+    "prelude"  :args         -> parserOptions flags{prel=True    } args+    "noplogic" :args         -> parserOptions flags{plogic=False } args+    "plogic"   :args         -> parserOptions flags{plogic=True  } args+    "cpp"      :args         -> parserOptions flags{cpp=Just cpp1} args+    ('c':'p':'p':'=':s):args -> parserOptions flags{cpp=Just s   } args+    "nocpp"    :args         -> parserOptions flags{cpp=Nothing  } args+    _                        -> (flags,args)
+ tools/base/parse2/PosName.hs view
@@ -0,0 +1,9 @@+module PosName(module PosName,ModuleName,HsIdentI(..)) where+import SourceNames+import qualified HsName as Hs+import HsIdent++type ModuleName = SN Hs.ModuleName+type HsName = SN Hs.HsName+type Id = SN Hs.Id+type HsIdent = HsIdentI HsName
+ tools/base/parse2/README.html view
@@ -0,0 +1,78 @@+<title>Extensible Haskell front-end for the Programatica project -+        directory base/parse2</title>++<h1>Extensible Haskell front-end for the Programatica project</h1>++<h2>What is in this directory (base/parse2)</h2>++This directory contains a new version of the base language lexer and+parser. There are two main differences from the old version.++<h4>Changes to the parser</h4>++The new parser produces a variant av the abstract syntax where every+identifier is paired with its position in the source file. This+variant of the syntax is defined in module <code>PosSyntax</code>. It+reuses the names of all types from the plain abstract syntax, to+minimize the number of changes required in the grammar file. The type+used for identifiers with source position is called <code>SN</code>+and defined in module <code>SourceNames</code>.++<h4><a name=lexer>Changes to the lexer</a></h4>++(See also the slides from the talk+ <a href="http://www.cse.ogi.edu/~hallgren/Talks/LHiH/">A Lexer for  Haskell+ in Haskell</a>).+<p>+Instead of being handwritten in Haskell, the new lexer is generated from a+lexical syntax specification. The advantages with this approach are that++      <ul>+        <li>it allows the lexer to be implemented in a modular way, closely+            resembling the specification in the Haskell report, so it should be+            much easier to verify that the implementation agrees with what the+            Haskell report specifies. (The old lexer was buggy.)++        <li>it should be much easier to adapt the implementation to changes of+	    the Haskell report (and there has been subtle changes in the lexical+	    syntax in every new version of the Haskell report, I believe).+	    (The old lexer was outdated.)++	<li>it is still as efficient as the old handwritten, monolithic lexer.+      </ul>+	+      <p>+      The specification is expressed in Haskell, using simple regular+      expression combinators, and then compiled to a+      <abbr title="Deterministic Finite Automaton">DFA</abbr>+      using standard text book algorithms. The regular expression compiler is+      implemented in Haskell, and the DFAs it generates are output in the form+      of Haskell source code.++      <p>+      Two pieces of handwritten code accompany the automatically generated+      code:+      <ul>+        <li>A small function to recognize nested comments, since these can't be+	    described using regular expressions.+	<li>Functions to implement Haskell's layout convention.+	    The structure of the implementation of these closely follow the+	    specifications in the Haskell report+	    (<a href="http://www.haskell.org/onlinereport/syntax-iso.html#sectB.3">appendix B.3</a>).+      </ul>++<h3>Subdirectories</h3>++<dl>+<dt><a href="Lexer/"><code>Lexer</code></a>+<dd>Handwritten and automatically generated code for the lexer.++<dt><a href="LexerGen/"><code>LexerGen</code></a>+<dd>The regular expression compiler.++<dt><a href="LexerSpec/"><code>LexerSpec</code></a>+<dd>The lexical syntax specification for Haskell 98 (based on appendix B.2).++<dt><a href="Parser/"><code>Parser</code></a>+<dd>The Happy parser for the context free grammar (based on appendix B.4).+</dl>
+ tools/base/parse2/SourceNames.hs view
@@ -0,0 +1,80 @@+module SourceNames where+import HsName(Id,HsName(..),hsUnQual,ModuleName(..),moduleName)+import SrcLoc1(SrcLoc,loc0,srcFile)+import qualified SrcLoc1 as L+import PrettyPrint+import HasBaseName+import UniqueNames+import QualNames+import SpecialNames++import Char(isUpper)++import Data.Generics++data SN i = SN i SrcLoc deriving (Data, Typeable)++instance Show i => Show (SN i) where+  showsPrec p (SN i _) = showsPrec p i++instance Read i => Read (SN i) where+  readsPrec p s = [(SN i loc0,r)|(i,r)<-readsPrec p s]++instance Unique (SN HsName) where+  unique m (SN n p) = G m (hsUnQual n) (srcLoc p)++instance Unique (SN Id) where+  unique m (SN n p) = G m n (srcLoc p)++--srcName (PN n _) = SN n loc0 -- a temporary hack (I hope)+srcName n = SN (getBaseName n) (L.srcLoc n)+fakeSN n = SN n loc0++instance HasBaseName (SN i) i where getBaseName (SN i _) = i++instance Eq i  => Eq  (SN i) where SN n1 _==SN n2 _ = n1==n2+instance Ord i => Ord (SN i) where compare (SN n1 _) (SN n2 _) = compare n1 n2++instance Functor SN where fmap f (SN i o) = SN (f i) o++instance QualNames qn m n => QualNames (SN qn) m (SN n) where+    getQualifier                = getQualifier . getBaseName+    getQualified                = fmap getQualified++    mkUnqual                    = fmap mkUnqual+    mkQual m                    = fmap (mkQual m)++instance HasSpecialNames i => HasSpecialNames (SrcLoc->SN i) where+  list_tycon_name = SN list_tycon_name+  fun_tycon_name = SN fun_tycon_name+  char_tycon_name = SN char_tycon_name+  tuple_tycon_name = SN . tuple_tycon_name++instance IsSpecialName i => IsSpecialName (SN i) where+  is_list_tycon_name (SN i _) = is_list_tycon_name i+  is_fun_tycon_name (SN i _) = is_fun_tycon_name i+  is_char_tycon_name (SN i _) = is_char_tycon_name i+  is_tuple_tycon_name n (SN i _) = is_tuple_tycon_name n i++---++instance Printable   i => Printable   (SN i) where+  ppi (SN n p) = ppi n<>ppIfDebug ("<<"<>p<>">>")+  wrap (SN n p) = wrap n<>ppIfDebug ("<<"<>p<>">>")++            -- positions ends up outside parenthesis...++instance PrintableOp i => PrintableOp (SN i) where+  isOp (SN n p) = isOp n+  ppiOp (SN n p) = ppiOp n<>ppIfDebug ("<<"<>p<>">>")+++hsName2modName (SN hs loc) =+  case hs of+    UnQual m -> return (SN (moduleName (srcFile loc) m) loc)+    Qual m n@(c:_) ->+	 if isUpper c+         then return (SN (PlainModule (mn m++"."++n)) loc)+         else fail "Invalid hierarchical module name"+       where mn (PlainModule s) = s+             mn (MainModule _) = "Main"
+ tools/base/parse2/lexgen view
@@ -0,0 +1,16 @@+#!/bin/sh++out=$1+tmp=$1.tmp++update() {+  if cmp $1 $2 ; then+    rm $1+  else+    mv $1 $2+  fi+}+++LexerGen/HsLexerGen >$tmp+update $tmp $out
+ tools/base/pfei.hs view
@@ -0,0 +1,37 @@+import System(system)+import Monad(when)+import IO(stdout,hFlush)++import PFE+import HsParser(parse)+import Unlit(readHaskellFile)+import ParseMonad(parseFile)+import ReAssocBase()+import ScopeNamesBase()+import NameMapsBase()+import PrettyPrint+import HsModule+import HsName(ModuleName(..))++import HasIO+import CmdLineParser+import qualified AbstractIO as FU++main =+    do putStr "PFE> "+       hFlush stdout -- just because GHC is stupid+       s <- getLine+       when (s/="quit") $+         do pfe' cmds parse (words s) `catch` print+            main+  where+    cmds = pfeCmds++icmds++    icmds = [("prepp",Args "<module>" ppModule),+             ("!",Args "<shell command>" shell)]++    shell args = io $ print =<< system (unwords args)++    ppModule (arg:_) =+       do m <- preparseSourceFile =<< findFile (Module arg)+	  FU.putStrLn (pp m)
+ tools/base/pretty/._PrettyPrint2.hs view
binary file changed (absent → 167 bytes)
+ tools/base/pretty/Flags.ghc view
@@ -0,0 +1,4 @@+PPU.hs: -fno-monomorphism-restriction+PrettyPrint2.hs: -fno-monomorphism-restriction+NewPrettyPrint.hs: -fno-monomorphism-restriction+PrettyDoc.hs: -fno-monomorphism-restriction
+ tools/base/pretty/NewPrettyPrint.hs view
@@ -0,0 +1,37 @@+-- Glue to the usual Huges/SimonPJ pretty printer+module NewPrettyPrint(pp,render,quickrender,module PrettyPrint2,module PrettyEnv) where+import PrettyPrint2+import PrettyDoc+import PrettyEnv+import PrettyStd+import qualified Text.PrettyPrint as P++pp x = render (ppi x)++render = P.renderStyle normalstyle . toPretty . runEnv defaultMode++quickrender = P.renderStyle qstyle . toPretty .+              runEnv defaultMode{layoutType=PPNoLayout}++qstyle      = normalstyle{P.mode=P.OneLineMode}+normalstyle = P.style{P.lineLength=80}++toPretty d =+  case d of+    Empty -> P.empty+    Char c -> P.char c+    Text s -> P.text s+    Attr _ d -> toPretty d+    Nest n d -> P.nest n (toPretty d)+    Group l ds -> group l (map toPretty ds)+      where+	group l =+	  case l of+	    Horiz Cat -> P.hcat+	    Horiz Sep -> P.hsep+	    Vert -> P.vcat+	    HorizOrVert Cat -> P.cat+	    HorizOrVert Sep -> P.sep+	    Fill Cat -> P.fcat+	    Fill Sep -> P.fsep+
+ tools/base/pretty/OldPrettyPrint.hs view
@@ -0,0 +1,93 @@+--- This uses PrettyM, rather than Pretty, as its starting point.++module OldPrettyPrint(module PrettyM,module OldPrettyPrint) where++import PrettyM+import Ratio++-- class Printable is defined in PrettyM++-- A class to make it easier to print Haskell infix operators correctly:+class Printable a => PrintableOp a where+    ppiOp :: a -> Doc+{-      How to print operators "mod"   and "+":++	  ppi   should produce "mod"   and "+".+	  wrap  should produce "mod"   and "(+)".+	  ppiOp should produce "`mod`" and "+".      -}++-- A class to make it easier to print type applications like (,) a b and+-- [] Int in the normal way, (a,b) and [Int].+class Printable fun => PrintableApp fun arg where+  wrapApp,ppiApp :: fun -> [arg] -> Doc++-- Predefined instances:++instance Printable Char where+    ppi	    = char+    ppiList = text -- this defines how strings are printed, since String=[Char]+    wrap    = ppi++instance Printable Bool    where wrap = ppi+instance Printable Int     where wrap = ppi+instance Printable Integer where wrap = ppi+instance Printable Float   where wrap = ppi+instance Printable Double  where wrap = ppi+instance Integral a => Printable (Ratio a) where wrap = ppi++instance Printable a => Printable [a] where+    ppi  = ppiList+    ppis = map ppi+    wrap = ppi++instance Printable a => Printable (Maybe a) where+    ppi = maybe empty ppi+    wrap = maybe empty wrap++instance (Printable a, Printable b) => Printable (a, b) where+    ppi (a,b) = ppiFTuple [ppi a,ppi b]+    wrap = ppi++instance (Printable a, Printable b, Printable c) => Printable (a, b, c) where+    ppi (a,b,c) = ppiFTuple [ppi a,ppi b,ppi c]+    wrap = ppi++instance (Printable a, Printable b, Printable c, Printable d)+      => Printable (a, b, c, d) where+    ppi (a,b,c,d) = ppiFTuple [ppi a,ppi b,ppi c,ppi d]+    wrap = ppi++instance (Printable a, Printable b, Printable c, Printable d, Printable e)+      => Printable (a, b, c, d, e) where+    ppi (a,b,c,d,e) = ppiFTuple [ppi a,ppi b,ppi c,ppi d,ppi e]+    wrap = ppi++ppiTuple,ppiFTuple,wrapTuple,wrapSeq,wrapFTuple,wrapFSeq+    :: Printable a => [a] -> Doc++ppiTuple   = parens . ppiSeq+ppiFTuple  = parens . ppiFSeq+wrapTuple  = parens . wrapSeq+wrapSeq    = wrapSet comma+wrapFTuple = parens . wrapFSeq+wrapFSeq   = wrapFSet comma++wrapSet,wrapFSet :: Printable a => Doc -> [a] -> Doc++wrapSet  = wrapSep0 sep+wrapFSet = wrapSep0 fsep+++wrapSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc+wrapSep0 sepOp separator []  = empty+wrapSep0 sepOp separator [d] = wrap d+wrapSep0 sepOp separator ds  = sepOp $ punctuate separator $ map wrap ds+++maybepp :: (a -> Doc) -> Maybe a -> Doc+maybepp pf (Just a) = pf a+maybepp _  Nothing  = empty++ppiBinOp lhs op rhs = sep [lhs<+>op,letNest rhs]++optpp b x = if b then ppi x else empty
+ tools/base/pretty/PPU.hs view
@@ -0,0 +1,44 @@+-- Pretty printing with Unicode (and other) options...++module PPU(module PPU,module PrettyPrint) where+import Prelude hiding (catch)+import PrettyPrint+import PrettyEnv+import UTF8Util+import MUtils(( # ))+import List(isSuffixOf)+import AbstractIO++type PPOpts = (Bool,PPHsMode)+ppOpts0 = (False,defaultMode)++ppu :: Printable a => (Bool, PPHsMode) -> a -> String+ppu (u,opts) = (if u then utf8 else id) . pp . withPPEnv opts . ppi++ucatch u io = if u then io `catch` utf8err else io++getPPopts =+    do --u <- utf8env+       let u=False+       name <- getProgName+       (ppOpts,args) <- opts defaultMode{useUnicode=u} # getArgs+       return ((useUnicode ppOpts,ppOpts),name,args)+  where+    opts o ("+debug":args) = opts o{debugInfo =True } args+    opts o ("-debug":args) = opts o{debugInfo =False} args+    opts o ("+tinfo":args) = opts o{typeInfo  =True } args+    opts o ("-tinfo":args) = opts o{typeInfo  =False} args+    opts o ("+utf8" :args) = opts o{useUnicode=True } args+    opts o ("-utf8" :args) = opts o{useUnicode=False} args+    opts o args@(('l':'a':'y':'o':'u':'t':'=':lts):args1) =+      case reads lts of+	(lt,_):_ ->          opts o{layoutType=lt   } args1+	_        -> (o,args)+    opts o args   = (o,args)++{-	 +-- A quick hack. Find a better way to test if UTF-8 output is appropriate!+utf8env =+   do lang <- getEnv "LANG" `catch` const (return "")+      return (any (`isSuffixOf` lang) ["utf8","UTF-8"])+-}
+ tools/base/pretty/PrettyDoc.hs view
@@ -0,0 +1,30 @@+module PrettyDoc where+import TokenTags++data Layout = Horiz Sep | Vert | HorizOrVert Sep | Fill Sep deriving (Show)+data Sep = Cat | Sep deriving (Show)++nonEmpty Empty = False+nonEmpty d = True++data Doc+  = Empty+  | Char Char+  | Text String+  | Attr TokenTag Doc+  | Nest Int Doc+  | Group Layout [Doc]+  deriving (Show)++{-+class Doc doc where+  -- Required methods:+  empty :: doc+  text :: String->doc+  nest :: Int->doc->doc+  group :: Layout->[doc]->doc++  -- Methods with default implementations:+  char :: Char->doc+  char c = text [c]+-}
+ tools/base/pretty/PrettyEnv.hs view
@@ -0,0 +1,69 @@+module PrettyEnv where++newtype DocM a = DocM (PPHsMode -> a)++instance Functor DocM where fmap f (DocM d) = DocM (f.d)++instance Monad DocM where+  return = DocM . const+  DocM d1>>=xd2 = DocM $ \ e -> let DocM d2 = xd2 (d1 e) in d2 e++runEnv = flip unDocM+unDocM (DocM f) = f+getPPEnv = DocM id++-- Layout environment to pass around++data PPLayout+    = PPOffsideRule  -- classical layout+    | PPSemiColon    -- classical layout made explicit: { d ;+		     --					  d ;+		     --					  d }+    | PPUtrecht      -- Utrecht-style explicit layout:  { d+		     --					; d+		     --					; d+		     --					}+    | PPInLine	     -- inline decls, \n between them +    | PPNoLayout     -- everything on a single line+      deriving (Eq,Show,Read)++type Indent = Int++data PPHsMode+  = PPHsMode { classIndent,            -- class, instance indent level+	       doIndent,               -- do notation indent level+	       doElseIndent,           -- else inside do indent level+	       caseIndent,             -- case expression indent level+	       letIndent,              -- let indent level+	       funIndent,              -- function defn indent level+	       dataIndent :: Indent,   -- data and type indent level+	       spacing    :: Bool,     -- blank lines between statements?+	       layoutType :: PPLayout, -- to do+	       comments   :: Bool,     -- to come later+	       insideDo   :: Bool,     -- to enable correct printing of+				       -- if-then-else inside a do+--	       insideApp  :: Bool,     -- to enable correct printing of+--				       -- type applications+	       infixParens :: Bool,    -- print parens for infix operators+	       debugInfo   :: Bool,    -- print extra debugging info+	       typeInfo    :: Bool,    -- print extra type info+	       useUnicode  :: Bool     -- ok to use of Unicode characters+	     }++defaultMode = PPHsMode { classIndent  = 4,+			 doIndent     = 3,+			 doElseIndent = 2,+			 caseIndent   = 4,+			 letIndent    = 4,+			 funIndent    = 4,+			 dataIndent   = 4,+			 spacing      = True,+			 layoutType   = PPOffsideRule, +			 comments     = True,+			 insideDo     = False,+--			 insideApp    = False,+			 infixParens  = True,+			 debugInfo    = False,+			 typeInfo     = True,+			 useUnicode   = False+		       }
+ tools/base/pretty/PrettyM.hs view
@@ -0,0 +1,289 @@+{-++PrettyM redefines the combinators in Pretty, so that they pass an+environment around.  This can be used to adust the behaviour of the layout,+spacing etc., without parameterising the whole pretty printer.  To the user+it all appears the same.++May be useful to rewrite this as a state transformer, rather than a+state reader monad.  Could then set different display conditions for+subsections of the Parser.++See Pretty.lhs for description of the combinators.+-}+module PrettyM (module PrettyM, module PrettyEnv, P.Mode, P.TextDetails) where++import qualified Pretty as P+import Ratio+import Monad(liftM2,liftM)+import MUtils+import PrettyEnv++-- So that pp code still looks the same +-- this means we lose some generality though+type Doc = DocM P.Doc++-- The pretty printing combinators++empty :: Doc+empty = return P.empty++isEmpty :: Doc -> Bool+isEmpty d = P.isEmpty $ unDocM d defaultMode++nest :: Int -> Doc -> Doc+nest i m = fmap (P.nest i) m++classNest, doNest, caseNest, letNest, funNest, dataNest+  :: Printable a => a -> Doc+classNest = nest' classIndent+doNest    = nest' doIndent+caseNest  = nest' caseIndent+letNest   = nest' letIndent+funNest   = nest' funIndent+dataNest  = nest' dataIndent++nest' p d = do { e <- getPPEnv ; nest (p e) (ppi d) }++-- Literals++text, ptext :: String -> Doc+text  = return . P.text+ptext = return . P.text++char :: Char -> Doc+char = return . P.char++litChar :: Char -> Doc+litChar = return . P.litChar++litString :: String -> Doc+litString = return . P.litString++int :: Int -> Doc+int = return . P.int++integer :: Integer -> Doc+integer = return . P.integer++float :: Float -> Doc+float = return . P.float++double :: Double -> Doc+double = return . P.double++rational :: Integral a => Ratio a -> Doc+rational = return . P.rational++-- Simple Combining Forms++quotes, charQuotes, backQuotes, doubleQuotes, parens, brackets, curlies, braces+  :: Printable a => a -> Doc+quotes       = lift1 P.quotes+charQuotes   = lift1 P.charQuotes+backQuotes   = lift1 P.backQuotes+doubleQuotes = lift1 P.doubleQuotes+parens       = lift1 P.parens+brackets     = lift1 P.brackets+curlies      = lift1 P.curlies+braces       = curlies++lift1 f d = fmap f (ppi d)++-- Constants++quote, backQuote, doubleQuote :: Doc+quote       = return P.quote+backQuote   = return P.backQuote+doubleQuote = return P.doubleQuote++semi, comma, colon, space, equals :: Doc+semi   = return P.semi+comma  = return P.comma+colon  = return P.colon+space  = return P.space+equals = return P.equals++lparen, rparen, lbrack, rbrack, lcurly, rcurly :: Doc+lparen = return P.lparen+rparen = return P.rparen+lbrack = return P.lbrack+rbrack = return P.rbrack+lcurly = return P.lcurly+rcurly = return P.rcurly++-- Combinators++(<>), (<+>), ($$), ($+$) :: (Printable a,Printable b) => a -> b -> Doc+(<>) = lift2 (P.<>)+(<+>) = lift2 (P.<+>)+($$) = lift2 (P.$$)+($+$) = lift2 (P.$+$)++lift2 op m1 m2 = liftM2 op (ppi m1) (ppi m2)++hcat, hsep, vcat, sep, cat, fsep, fcat :: Printable a => [a] -> Doc+hcat  = liftList P.hcat+hsep  = liftList P.hsep+vcat  = liftList P.vcat+sep   = liftList P.sep+cat   = liftList P.cat+fsep  = liftList P.fsep+fcat  = liftList P.fcat++liftList f ds = fmap f (mapM ppi ds)++-- Some More++hang :: Doc -> Int -> Doc -> Doc+hang dM i rM = do { d <- dM ; r <- rM ; return $ P.hang d i r }++-- Yuk, had to cut-n-paste this one from Pretty.hs+--punctuate :: Doc -> [Doc] -> [Doc]+punctuate p []     = []+punctuate p (d:ds) = go d ds+    where go d []     = [ppi d]+          go d (e:es) = (d <> p) : go e es++++-- this is the equivalent of runM now.+renderWithMode :: PPHsMode -> Doc -> String+renderWithMode ppMode d = P.render . unDocM d $ ppMode++render :: Doc -> String+render = renderWithMode defaultMode++fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float -> +		      (P.TextDetails -> a -> a) -> a -> Doc -> a+fullRenderWithMode ppMode m i f fn e mD = +		   P.fullRender m i f fn e $ (unDocM mD) ppMode+++fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) +	      -> a -> Doc -> a+fullRender = fullRenderWithMode defaultMode++withPPEnv :: PPHsMode -> Doc -> Doc+withPPEnv mode d = return $ (unDocM d) mode++updPPEnv f d = do e <- getPPEnv; withPPEnv (f e) d++doNotation :: Doc -> Doc+doNotation = updPPEnv (\e->e { insideDo = True })+++doElseNest d = do e <- getPPEnv+		  if insideDo e then nest (doElseIndent e) (ppi d) else ppi d++-- An attempt at intelligent recovery of parentheses in applications (used+-- currently only for types).  The first time appParens is called, it does not+-- parenthesize the given document, but changes the environment to ensure that+-- subsequent applications are. +{-+appParens d = do e <- getPPEnv+		 if insideApp e+		    then parens d+		    else withPPEnv (e { insideApp = True }) d+-}++-- This sets insideApp to True without adding parens as well.+--appParensOn = id --updPPEnv (\e->e { insideApp = True })++-- This sets insideApp to False without adding parens as well.  Used when other+-- forms serve to parenthesize, e.g., to prevent [(M a)].+--appParensOff = id -- updPPEnv (\e->e { insideApp = False })+++-- This is only used for lists where people most commonly put their _own_+-- curlies and semis.  It is not intended to recreate correct explicit layout+-- for Haskell programs, but merely to allow for pretty printing with curlies+-- and semis.  It might possibly be extendible into something to create+-- explicit layout.+{-+layout :: [Doc] -> Doc+layout []   = empty+layout docs = do e <- getPPEnv+		 case layoutType e of+		     PPSemiColon   ->+		         let (ds, d) = (init docs, last docs)+		         in+			     lcurly <+>+			     (vcat $+		              (map (\ d -> d <+> semi) ds) ++ [ d <+> rcurly ])+		     PPUtrecht     ->+		         let (d:ds) = docs+		         in+		             vcat $+			     (lcurly <+> d) :+			     map (semi <+>) ds +++			     [ rcurly ]+		     _             ->+		         vcat docs+			 -- all others done as for classic (for the moment)+-}++blankline :: Doc -> Doc+blankline d = do e <- getPPEnv+		 if spacing e && layoutType e /= PPNoLayout+		     then d+			  $$ space+		     else d+++ppIfDebug debug = ifM (debugInfo # getPPEnv) (ppi debug) empty++ppIfUnicode unicode ascii =+    ifM (useUnicode # getPPEnv)+        (ppi unicode)+        (ppi ascii)++withUnicode d = updPPEnv (\e->e{useUnicode=True}) d+withDebug   d = updPPEnv (\e->e{debugInfo=True}) d+--------------------------------------------------------------------------------++{-+  The Printable class is due to Urban Boquist.  We define instances for those+  types we want to pretty print.  It should also make the job of extensiblilty+  much easier.+-}++class (Show a{-, Eq a-}) => Printable a where+--  pp      :: a   -> String               -- Prettyprint+    ppi     :: a   -> Doc                  -- Prettyprint Intelligently+    ppiList :: [a] -> Doc                  -- Specialized for Char/String+    ppis    :: a   -> [Doc]                -- To allow for cases in which we+					   -- can generate a list of Docs from+					   -- a given type+    wrap    :: a   -> Doc		   -- for bracketing+++--  pp      = render . ppi+    ppi     = text . show++    ppiList = brackets . ppiFSeq+    ppis a  = [ ppi a ]+    wrap    = parens . ppi++pp d = render (ppi d) -- pp used to be a method, but no instance defined it...++instance Show Doc where show = render++instance Printable Doc  where+    ppi = id++ppiSeq :: Printable a => [a] -> Doc+ppiSeq = ppiSet comma++ppiSet :: Printable a => Doc -> [a] -> Doc+ppiSet = ppiSep0 sep++ppiSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc+ppiSep0 sepOp separator []  = empty+ppiSep0 sepOp separator [d] = ppi d+ppiSep0 sepOp separator ds  = sepOp $ punctuate separator $ map ppi ds++ppiFSeq :: Printable a => [a] -> Doc+ppiFSeq = ppiFSet comma++ppiFSet :: Printable a => Doc -> [a] -> Doc+ppiFSet = ppiSep0 fsep
+ tools/base/pretty/PrettyPrint.hs view
@@ -0,0 +1,3 @@+module PrettyPrint(module P) where+--import OldPrettyPrint as P+import NewPrettyPrint as P
+ tools/base/pretty/PrettyPrint2.hs view
@@ -0,0 +1,231 @@+module PrettyPrint2 where+import qualified PrettyDoc as P(Doc)+import PrettyDoc hiding (Doc)+import PrettyEnv+import TokenTags+import MUtils++type Doc = DocM P.Doc++class Show a => Printable a where+  ppi     :: a   -> Doc    -- Prettyprint Intelligently+  ppiList :: [a] -> Doc    -- Specialized for Char/String+  ppis    :: a   -> [Doc]  -- To allow for cases in which we can generate+                           -- a list of Docs from a given type+  wrap    :: a   -> Doc	   -- for bracketing++  ppi     = plain++  ppiList = brackets . ppiFSeq+  ppis a  = [ ppi a ]+  wrap    = parens . ppi++-- Essential instances:+instance Show Doc where show (DocM d) = show (d defaultMode) -- useless?+instance Printable Doc  where ppi = id++instance Printable Char where+    ppi	c   = char c+    ppiList = text -- this defines how strings are printed, since String=[Char]+    wrap    = ppi++instance Printable a => Printable [a] where+    ppi  = ppiList+    ppis = map ppi+    wrap = ppi++-- A class to make it easier to print Haskell infix operators correctly:+class Printable a => PrintableOp a where+    isOp :: a -> Bool+    ppiOp :: a -> Doc+{-      How to print operators "mod"   and "+":++	  ppi   should produce "mod"   and "+".+	  wrap  should produce "mod"   and "(+)".+	  ppiOp should produce "`mod`" and "+".      -}++-- A class to make it easier to print type applications like (,) a b and+-- [] Int in the normal way, (a,b) and [Int].+class Printable fun => PrintableApp fun arg where+  wrapApp,ppiApp :: fun -> [arg] -> Doc+++cdoc = DocM . const++-- Hughes/SimonPJ style pretty printing operators:++char   = cdoc . Char+text   = cdoc . Text+empty  = cdoc Empty+group l ds = DocM $ \e->Group l [de|DocM d<-map ppi ds,let de=d e,nonEmpty de]+nest n = fmap (nest' n) . ppi+  where+    nest' n (Nest n' d) = nest' (n+n') d+    nest' n d = Nest n d++-- Eta expansions because of the annying monomorphism restriction!+attr a = fmap (Attr a) . ppi+kw   d = attr Reserved d+var  d = attr Var d+con  d = attr Con d+varop d = attr VarOp d+conop d = attr ConOp d+tcon d = attr TCon d+lit  d = attr Lit d+cmnt d = attr Comment d+modn d = attr ModName d++a<>b = hcat [ppi a,ppi b]+a<+>b = hsep [ppi a,ppi b]+a$$b = vcat [ppi a,ppi b]++hcat ds = group (Horiz Cat) ds+hsep ds = group (Horiz Sep) ds+vcat ds = group Vert ds+cat  ds = group (HorizOrVert Cat) ds+sep  ds = group (HorizOrVert Sep) ds+fcat ds = group (Fill Cat) ds+fsep ds = group (Fill Sep) ds++plain x = text (show x)++punctuate p []     = []+punctuate p (d:ds) = go d ds+    where go d []     = [ppi d]+          go d (e:es) = (d <> p) : go e es++-- Additional pretty printing functions:+{-+ppiSeq :: Printable a => [a] -> Doc+ppiSet :: Printable a => Doc -> [a] -> Doc+ppiSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc+ppiFSeq :: Printable a => [a] -> Doc+ppiFSet :: Printable a => Doc -> [a] -> Doc+ppiTuple :: Printable a => [a] -> Doc+ppiFTuple :: Printable a => [a] -> Doc+wrapTuple :: Printable a => [a] -> Doc+wrapSeq :: Printable a => [a] -> Doc+wrapSet :: Printable a => Doc -> [a] -> Doc+wrapFTuple :: Printable a => [a] -> Doc+wrapFSeq :: Printable a => [a] -> Doc+wrapFSet :: Printable a => Doc -> [a] -> Doc+wrapSep0 :: Printable a => ([Doc] -> Doc) -> Doc -> [a] -> Doc+-}++ppiSeq ds = ppiSet ',' ds++ppiSet s ds = ppiSep0 sep s ds++ppiSep0 sepOp separator []  = empty+ppiSep0 sepOp separator [d] = ppi d+ppiSep0 sepOp separator ds  = sepOp $ punctuate separator $ map ppi ds++ppiFSeq ds = ppiFSet ',' ds+ppiFSet s ds = ppiSep0 fsep s ds++ppiTuple ds = parens (ppiSeq ds)+ppiFTuple ds = parens (ppiFSeq ds)+wrapTuple ds = parens (wrapSeq ds)+wrapSeq ds = wrapSet ',' ds+wrapSet s ds = wrapSep0 sep s ds+wrapFTuple ds = parens (wrapFSeq ds)+wrapFSeq ds = wrapFSet ',' ds+wrapFSet s ds = wrapSep0 fsep s ds++wrapSep0 sepOp separator []  = empty+wrapSep0 sepOp separator [d] = wrap d+wrapSep0 sepOp separator ds  = sepOp $ punctuate separator $ map wrap ds+++--maybepp :: (a -> Doc) -> Maybe a -> Doc+maybepp pf (Just a) = pf a+maybepp _  Nothing  = empty++optpp b x = if b then ppi x else empty++ppiBinOp lhs op rhs = sep [lhs<+>op,letNest rhs]++parenBinOp x op y = parens (ppiBinOp x op y) -- should consult infixParens!!++-- These are rather pointless, but kept around for backwards compatibility:+lparen = kw '('+rparen = kw ')'+lbrack = kw '['+rbrack = kw ']'+lbrace = kw '{'+rbrace = kw '}'+quote = kw '\''+dquote = kw '"'+bquote = kw '`'+equals = kw '='+comma = kw ','+float = plain :: Float->Doc+double = plain :: Double->Doc+space = ppi ' '++parens d = lparen<>d<>rparen+brackets d = lbrack<>d<>rbrack+braces d = lbrace<>d<>rbrace+doubleQuotes d = dquote<>d<>dquote+backQuotes d = bquote<>d<>bquote+{-+	quotes, charQuotes, backQuotes, doubleQuotes,+        quote, backQuote, doubleQuote, semi, comma, colon, space, equals,++        hang, punctuate,+-}++-- Environment manipulating functions:++withPPEnv :: PPHsMode -> Doc -> Doc+withPPEnv mode d = return $ (unDocM d) mode++updPPEnv f d = do e <- getPPEnv; withPPEnv (f e) d++doNotation :: Doc -> Doc+doNotation = updPPEnv (\e->e { insideDo = True })+++doElseNest d = do e <- getPPEnv+		  if insideDo e then nest (doElseIndent e) (ppi d) else ppi d++ppIfDebug debug = ifM (debugInfo # getPPEnv) (ppi debug) empty+ppIfTypeInfo tinfo = ifM (typeInfo # getPPEnv) (ppi tinfo) empty++ppIfUnicode unicode ascii =+    ifM (useUnicode # getPPEnv)+        (ppi unicode)+        (ppi ascii)++withUnicode d = updPPEnv (\e->e{useUnicode=True}) d+withDebug   d = updPPEnv (\e->e{debugInfo=True}) d++classNest, doNest, caseNest, letNest, funNest, dataNest+  :: Printable a => a -> Doc+classNest = nest' classIndent+doNest    = nest' doIndent+caseNest  = nest' caseIndent+letNest   = nest' letIndent+funNest   = nest' funIndent+dataNest  = nest' dataIndent++nest' p d = do { e <- getPPEnv ; nest (p e) (ppi d) }++blankline :: Doc -> Doc+blankline d = do e <- getPPEnv+		 if spacing e && layoutType e /= PPNoLayout+		     then d+			  $$ space+		     else d++layout ds = do e <- getPPEnv+	       case layoutType e of+		 --PPSemiColon   ->+		 --PPUtrecht     ->+		 PPNoLayout    -> braces . hsep . punctuate ';' $ ds+		 _             -> vcat ds++-- Obsolete:+appParensOn = id+appParensOff = id+
+ tools/base/pretty/PrettyStd.hs view
@@ -0,0 +1,51 @@+module PrettyStd where+import PrettyPrint2+import Ratio++-- Predefined instances:+++instance Printable Bool    where wrap = ppi+instance Printable Int     where wrap = ppi+instance Printable Integer where wrap = ppi+instance Printable Float   where wrap = ppi+instance Printable Double  where wrap = ppi+instance Integral a => Printable (Ratio a) where wrap = ppi++instance Printable a => Printable (Maybe a) where+    ppi (Just a) = ppi a+    ppi Nothing  = empty++    wrap (Just a) = wrap a+    wrap Nothing  = empty++instance Printable () where+    ppi () = parens empty+    wrap = ppi++instance (Printable a, Printable b) => Printable (a, b) where+    ppi (a, b) = parens $ ppi a <> ',' <+> ppi b+    wrap = ppi++instance (Printable a, Printable b, Printable c) => Printable (a, b, c) where+    ppi (a, b, c) = parens $ ppi a <> ',' <+>+                             ppi b <> ',' <+>+                             ppi c+    wrap = ppi++instance (Printable a, Printable b, Printable c, Printable d) =>+    Printable (a, b, c, d) where+    ppi (a, b, c, d) = parens $ ppi a <> ',' <+>+                                ppi b <> ',' <+>+                                ppi c <> ',' <+>+				ppi d+    wrap = ppi++instance (Printable a, Printable b, Printable c, Printable d, Printable e) =>+    Printable (a, b, c, d, e) where+    ppi (a, b, c, d, e) = parens $ ppi a <> ',' <+>+                                   ppi b <> ',' <+>+                                   ppi c <> ',' <+>+				   ppi d <> ',' <+>+				   ppi e+    wrap = ppi
+ tools/base/pretty/PrettySymbols.hs view
@@ -0,0 +1,28 @@+module PrettySymbols where+import PrettyPrint++kwIfUnicode a u = kw (ppIfUnicode a u)++-- Smileys and other useful symbols:+happy   = kwIfUnicode '\x263a' ":-)"+sad     = kwIfUnicode '\x2639' ":-("+forall' = kwIfUnicode '\x2200' "forall"+all     = kwIfUnicode '\x2200' "All"+exist   = kwIfUnicode '\x2203' "Exist"+--el      = kwIfUnicode '\x220a' "::" -- looks ugly in times+el      = kwIfUnicode '\x2208' "::"+imp     = kwIfUnicode '\x21d2' "=>"+lambda  = kwIfUnicode '\x03bb' "\\"+larrow  = kwIfUnicode '\x2190' "<-"+rarrow  = kwIfUnicode '\x2192' "->"+and     = kwIfUnicode '\x2227' "/\\"+or      = kwIfUnicode '\x2228' "\\/"+not     = kwIfUnicode '\x00ac' "-/"+implies = kwIfUnicode '\x21d2' "==>"+equiv   = kwIfUnicode '\x21d4' "<==>"+mu      = kwIfUnicode '\x03bc' "Lfp"+nu      = kwIfUnicode '\x03bd' "Gfp"+--star    = kwIfUnicode '\x2605' "*" -- not present in times+--moon    = kwIfUnicode '\x263e' "C" -- not present in times+star    = kw "*"+moon    = kw "C"
+ tools/base/pretty/PrettyUtil.hs view
@@ -0,0 +1,17 @@+module PrettyUtil (ppWhere,ppContext) where++--import SrcLoc+import PrettyPrint+import PrettySymbols(imp)+++-- Pretty prints where declaration lists, also used in multiple places.+--ppWhere :: [Doc] -> Doc+ppWhere [] = empty+ppWhere ds = sep [kw "where",letNest (layout ds)]++-- Pretty prints contexts, if they are present+ppContext []  = empty+ppContext [c] = c <+> imp+ppContext cs  = ppiFTuple cs <+> imp+
+ tools/base/pretty/TokenTags.hs view
@@ -0,0 +1,6 @@+module TokenTags where+import Ix++data TokenTag+  = Comment | Reserved | Var | Con | TCon | VarOp | ConOp | Lit | ModName+  deriving (Eq,Ord,Ix,Bounded,Show)
+ tools/base/syntax/Flags.ghc view
@@ -0,0 +1,1 @@+SyntaxRecPretty.hs: -fallow-undecidable-instances
+ tools/base/syntax/OldSyntaxRec.hs view
@@ -0,0 +1,19 @@+module OldSyntaxRec where+import SyntaxRec++-- For backward compatibility:+type HsPat = HsPatI HsName+type HsType = HsTypeI HsName+type HsExp  = HsExpI HsName+type HsDecl = HsDeclI HsName+type HsModuleR = HsModuleRI HsName++type BaseDecl = BaseDeclI HsName+type BaseExp  = BaseExpI  HsName+type BasePat  = BasePatI  HsName+type BaseType = BaseTypeI HsName++type HsModuleRI i = HsModuleI i [HsDeclI i]++type HsStmtR   = HsStmt HsExp HsPat [HsDecl]+type HsAltR    = HsAlt HsExp HsPat [HsDecl]
+ tools/base/syntax/Rewrite.hs view
@@ -0,0 +1,52 @@+-- $Id: Rewrite.hs,v 1.4 2001/07/30 05:57:46 hallgren Exp $++module Rewrite(rewriteModule, rewriteDecs, rewriteExp) where+{-+   This module supports rewriting of Haskell programs, mostly w.r.t., +   operator fixity and association.  In particular, the function rewriteExp+   takes an operator environment and reassociates the infix expressions +   as necessary.+-}++import Syntax+import SyntaxUtil+import HsAssoc(extend)+--import HsExpStruct +--import HsDeclStruct+import HsModule+import HsName++rewriteModule env (HsModule m ex im decls) =+    HsModule m ex im (rewriteDecs env decls)++rewriteDecs env ds = map (rewriteDec env') ds+  where+    env' = foldl extend env fs+    fs = fixitiesD [d | Dec d <- ds]+  {- To be Haskell 98 compliant, this function also needs to reset the+     fixities of all names defined in ds without a fixity declaration in ds to+     the default, infixl 9.+     Also, for local definitions, the fixity environment should be in scope+     not only in the declarations themselves, but also in the expression(s)+     where the declarations are in scope...+   -}++rewriteDec env (Dec d) =+    Dec $ rewriteAllD (rewriteExp env)+	              (rewritePat env)+		      (rewriteDecs env)+		      d++rewriteExp env = reassociateExp env+rewritePat env = reassociatePat env++reassociateExp env (Exp e) =+    Exp $ reassociateE isInfixApp hsInfixApp getOpAndArgs+                       reassociateExp reassociatePat rewriteDecs env e++reassociatePat env (Pat p) =+    Pat $ reassociateP isPInfixApp hsPInfixApp getPOpAndArgs+                       reassociatePat env p++removeParens :: HsExp -> HsExp+removeParens (Exp e) = removeParensE Exp removeParens e
+ tools/base/syntax/Syntax.hs view
@@ -0,0 +1,5 @@+module Syntax (module S) where++import BaseSyntax as S+import SyntaxRec  as S+import SyntaxRecPretty as S
+ tools/base/syntax/SyntaxRec.hs view
@@ -0,0 +1,110 @@+module SyntaxRec(module SyntaxRec,module HasBaseStruct,module Recursive,module HsConstants) where+import Maybe(fromMaybe)+import SrcLoc1+import BaseSyntax+import HasBaseStruct+import SpecialNames+import Recursive+import HsConstants(main_mod,main_name,mod_Prelude,is_unit_tycon_name)++import Data.Generics++-- Tie the recursive knots:++type BaseDeclI i+  = DI i+      (HsExpI i)+      (HsPatI i)+      [HsDeclI i] -- nested declarations+      (HsTypeI i) -- type expressions+      [HsTypeI i] -- contexts are lists of types+      (HsTypeI i) -- lhs of type defs++type BaseExpI i = EI i (HsExpI i) (HsPatI i) [HsDeclI i] (HsTypeI i) [HsTypeI i]+type BasePatI i = PI i (HsPatI i)+type BaseTypeI i = TI i (HsTypeI i)++newtype HsDeclI i = Dec (BaseDeclI i)   deriving (Ord,Read, Eq, Show, Data, Typeable)+newtype HsExpI i  = Exp (BaseExpI  i)   deriving (Ord, Read, Eq, Show, Data, Typeable)+newtype HsPatI i  = Pat (BasePatI  i)   deriving (Ord, Read, Eq, Show, Data, Typeable)+newtype HsTypeI i = Typ (BaseTypeI i)   deriving (Ord, Eq, Show ,Data, Typeable)+newtype HsKind    = Knd (K HsKind)      deriving (Ord,Eq, Show, Data, Typeable)++instance Rec (HsDeclI i) (BaseDeclI i)      where r = Dec; struct (Dec d) = d+instance Rec (HsExpI i)  (BaseExpI i)       where r = Exp; struct (Exp e) = e+instance Rec (HsPatI i)  (PI i (HsPatI i))  where r = Pat; struct (Pat p) = p+instance Rec (HsTypeI i) (TI i (HsTypeI i)) where r = Typ; struct (Typ t) = t+instance Rec HsKind      (K HsKind)         where r = Knd; struct (Knd k) = k++-- This makes all the convenience constructor functions available for+-- the base syntax (There is some overlap with the Rec class, but for+-- extensions to the syntax, base will be different from rec...):+instance HasBaseStruct (HsDeclI i) (BaseDeclI i)  where base = Dec+instance HasBaseStruct (HsExpI i)  (BaseExpI i)   where base = Exp+instance HasBaseStruct (HsPatI i)  (BasePatI i)   where base = Pat+instance HasBaseStruct (HsTypeI i) (BaseTypeI i)  where base = Typ+instance HasBaseStruct HsKind      (K HsKind)     where base = Knd++instance GetBaseStruct (HsDeclI i) (BaseDeclI i)  where+   basestruct = Just . struct++instance GetBaseStruct (HsPatI i) (BasePatI i) where+    basestruct = Just . struct++instance GetBaseStruct (HsExpI i) (BaseExpI i) where+  basestruct = Just . struct++instance HasSrcLoc (HsDeclI i) where srcLoc = srcLoc . struct++++-- Module building+hsModule s m es (imp, decls) = HsModule s m es (reverse imp) (reverse decls)++-- An omitted module header is equivalent to module Main(main) where ...+hsMainModule loc body =+  hsModule loc (main_mod (srcFile loc)) (Just [exportVar main_name]) body++-- When consing a Decl onto a Decl list if the new Decl and the Decl on the+-- front of the list are for the same function, we can merge the Match lists+-- rather than just cons the new decl to the front of the list.+--funCons :: HsDecl -> [HsDecl] -> [HsDecl]+funCons (d1 @ (Dec (HsFunBind s1 m1)))+    (ds @ ((d2 @ (Dec (HsFunBind s2 m2))) : more)) =+    if same m1 m2+    then Dec (HsFunBind s2 (m2 ++ m1)) : more+    else d1 : ds+    where same ((HsMatch _ n1 _ _ _):_) ((HsMatch _ n2 _ _ _):_) = n1 == n2+          same _                        _                        = False+funCons d ds = d : ds+++-- Exp building+hsVar name                  = HsVar name+hsCon name                  = HsCon name++--mkRecord :: HsExp -> [HsFieldUpdate HsExp] -> HsExp+mkRecord s (Exp (HsId (HsCon c))) fbinds = hsRecConstr s c fbinds+mkRecord s e                      fbinds = hsRecUpdate s e fbinds++-- Used to construct contexts in the parser+--tupleTypeToContext :: HsType -> [HsType]+tupleTypeToContext t = tupleTypeToContext' is_unit_tycon_name is_tuple_tycon_name t++tupleTypeToContext' is_unit_tycon_name is_tuple_tycon_name t =+    fromMaybe [t] (ctx t [])+  where+    ctx (Typ t) ts =+      case t of+        HsTyApp t1 t2 -> ctx t1 (t2:ts)+        HsTyCon c -> if if null ts+			then is_unit_tycon_name c+			else is_tuple_tycon_name (length ts-1) c+		     then Just ts+		     else Nothing+        _ -> Nothing+++-- instance Show i => Show (HsTypeI i) where showsPrec p (Typ x) = (showsPrec p x)+instance Read i => Read (HsTypeI i) where+    readsPrec p s = [(Typ t,r)|(t,r)<-readsPrec p s]
+ tools/base/syntax/SyntaxRecPretty.hs view
@@ -0,0 +1,78 @@+module SyntaxRecPretty where+import SyntaxRec+import PrettyPrint+import SpecialNames+import HsTypeStruct+import PrettySymbols(rarrow)++instance (PrintableOp i,IsSpecialName i) => Printable (HsDeclI i) where+    ppi (Dec d) = ppi d++    ppiList []  = empty+    ppiList ds  = vcat $ (map (blankline . ppi) (init ds)) ++ [ppi (last ds)]++    wrap (Dec d) = wrap d+++{- We want something like this,++   instance Rec rec struct => Printable rec where+     ppi = ppi . struct+     wrap = ppi . struct++   but we have to repeat it for each type in the Rec class, since otherwise+   we get an instance that "overlaps" with everything else... /TH+-}++instance (PrintableOp i,IsSpecialName i) => Printable (HsExpI i) where+    ppi = ppi . struct+    wrap = wrap . struct++instance PrintableOp i => Printable (HsPatI i) where+    ppi = ppi . struct+    wrap = wrap . struct++instance (Printable i,IsSpecialName i) => Printable (HsTypeI i) where+    --ppi (Typ (HsTyApp (Typ (HsTyCon (Qual (Module "Prelude") "[]"))) t)) =+    --    brackets $ appParensOff $ ppi t+    ppi (Typ t) = ppi t++--  ppiList [] = empty+--  ppiList ts = {-appParensOn $-} ppiSet space $ map struct ts++    --wrap (Typ (HsTyApp (Typ (HsTyCon (Qual (Module "Prelude") "[]"))) t)) =+    --	brackets $ appParensOff $ ppi t+    wrap (Typ t) = wrap t++instance (Printable i,IsSpecialName i) => PrintableApp (HsTypeI i) (HsTypeI i) where+   ppiApp = ppiApp . struct+   wrapApp = wrapApp . struct++instance Printable HsKind where+    ppi = ppi . struct+    wrap = wrap . struct+++instance (Printable i,IsSpecialName i) => PrintableApp i (HsTypeI i) where+  ppiApp i ts = -- i is always a  constructor, not a type variable+      case ts of+        [t]     | is_list_tycon_name i -> ppListType t+        [t1,t2] | is_fun_tycon_name  i -> sep [wrap t1<+>rarrow,ppi t2]+        _       | n>=2 && is_tuple_tycon_name (n-1) i -> ppiFTuple ts+	_                              -> tcon (wrap i)<+>fsep (map wrap ts)+    where+      n=length ts++  wrapApp i ts =+      case ts of+        [t]     | is_list_tycon_name i -> ppListType t+        [t1,t2] | is_fun_tycon_name  i -> parens (sep [wrap t1<+>rarrow,ppi t2])+        _       | n>=2 && is_tuple_tycon_name (n-1) i -> ppiFTuple ts+	_                         -> parens (tcon (wrap i)<+>fsep (map wrap ts))+    where+      n=length ts++ppListType t =+  case t of+    Typ (HsTyCon i) | is_char_tycon_name i -> tcon "String"+    _ -> brackets t
+ tools/base/syntax/SyntaxUtil.hs view
@@ -0,0 +1,69 @@+module SyntaxUtil(module SyntaxUtil,module HsConstants) where+import HsConstants+import Syntax+import PrettyPrint++-- Built-in type constructors/names++unit_tycon          = hsTyCon unit_tycon_name :: HsType+fun_tycon           = hsTyCon fun_tycon_name  :: HsType+list_tycon          = hsTyCon list_tycon_name :: HsType+tuple_tycon i       = hsTyCon $ tuple_tycon_name i :: HsType+++-- Test functions (used by the parser)+isPatternExp :: HsExp -> Bool+isPatternExp (Exp pe) = isPatternE isConE isVarE isPatternExp pe++isFundefLhs :: HsExp -> Bool -> Bool+isFundefLhs (Exp pe) p = isFundefLhsE isPatternExp isFundefLhs pe p++isInfixApp :: HsExp -> Bool+isInfixApp (Exp (HsInfixApp _ _ _)) = True+isInfixApp _                        = False++isPInfixApp :: HsPat -> Bool+isPInfixApp (Pat (HsPInfixApp _ _ _)) = True+isPInfixApp _                         = False++isConE (Exp (HsId (HsCon _))) = True+isConE _                      = False++isVarE (Exp (HsId (HsVar _))) = True+isVarE _                      = False++isTyVar (Typ (HsTyVar _)) = True+isTyVar _                 = False+++-- Extractor functions++getOpAndArgs :: HsExp -> (HsIdent, HsExp, HsExp)+getOpAndArgs (Exp (HsInfixApp a op b)) = (op, a, b)+getOpAndArgs e                         =+    error ("BaseSyntaxUtil.getOpAndArgs: not an infix application:\n\n"+	   ++ pp e ++ "\n")++getPOpAndArgs :: HsPat -> (HsIdent, HsPat, HsPat)+getPOpAndArgs (Pat (HsPInfixApp a op b)) = (op, a, b)+getPOpAndArgs p                         =+    error ("BaseSyntaxUtil.getPOpAndArgs: not an infix application:\n\n"+	   ++ pp p ++ "\n")++getTyVar (Typ (HsTyVar v)) = v+getTyCon (Typ (HsTyCon c)) = c++getTyName (Typ (HsTyVar v)) = v+getTyName (Typ (HsTyCon c)) = c+++{-+-- Produces a nub'd list of type variable names in the list++namesTyp (Typ t) = namesT namesTyp t+namesT acct t = reverse $ accNamesT t []+    where accNamesT (HsTyVar n) ans | n `elem` ans = ans+				    | otherwise    = n : ans+          accNamesT t           ans = accT acct t ans+-}+
+ tools/base/testparse view
@@ -0,0 +1,4 @@++for FILE in *.hs */*.hs ; do+    ./hsparse $FILE > tests/parser/`basename $FILE`.parsed 2>&1+done
+ tools/base/testparse2 view
@@ -0,0 +1,6 @@+#!/bin/sh++for FILE in *.hs */*.hs ; do+    printf "$FILE                 \r"+   ./ParseOld $FILE > tests/parser/`basename $FILE`.parsed # 2>&1+done
+ tools/base/tests/Defaults.hs view
@@ -0,0 +1,6 @@+module Defaults where++default(Int)++--f :: b -> (b,String)+f x = (x,show (1+read "2"))
+ tools/base/tests/Derivings.hs view
@@ -0,0 +1,17 @@+module Deriving where++data A = A1 A | A2 B deriving (Eq)++data B = B1 Int | B2 A deriving (Eq)+++--s = show (B2 (A2 (B1 5)))+++data T1 a b c = C1 a (T2 a b c) deriving (Eq,Show)+data T2 a b c = C2 (T3 a b c) | C2b (N b) deriving (Eq,Show)+data T3 a b c = C3 (N c) (T1 a c b) deriving (Eq,Show)+++data N b = N b deriving Show+instance Eq (N b) where _==_=True
+ tools/base/tests/Errors.hs view
@@ -0,0 +1,45 @@+module Errors (totallyUnknownEntity)  where+import Errors (Foo)+import Prelude (foobar)+import Bubba   (foobar)++infixr 3 %%+++data P x = Foo (x,x)+data Q x = Bar (x,x)+++class BarBar x where+  a :: x -> x++data C = P Q++data P x = PP x++data BarBar x = BB x++instance BarBar P where+  a x = x++c = B.f++data YY x x = PPPP x -- repeaated type variable on lhs+type Q x = Q x -- recursive type synonym+++data P x = Q (x -> x) +  deriving Show+{- ^ Cannot derive instances for types with polymorphic or qualified components+ -}++data P x = Q (x -> z -> x)+    deriving Show++newtype P x = A (x,x) -- Variable "x" in constraint is not locally bound+newtype P a b = X a b -- A newtype constructor must have exactly one argument+newtype P a b = X !a --  Illegal strictess annotation for newtype constructor+data Foo x = Bar x+           | Foo x+           | Bar x --  Repeated definition for constructor function "Bar"+data P x = Foo { a :: x, b :: String, a :: String } --Repeated field name "a" for constructor "Foo" 
+ tools/base/tests/Existential.hs view
@@ -0,0 +1,22 @@+module Existential where++-- Hmm, this is universal quantification, not existential.+data U = U (forall a . (a,a->Int,Int->a,a->a->a))++-- This is existential quantification+data E = forall a . {-Eq a =>-} E (a,a->Int,Int->a,a->a->a)++e = E (1,id,id,(+))++-- OK:+f (E (x,toint,fromint,op)) = toint (x `op` x)++-- Error: it assumes that the existentially quantified type is Bool+--g (E (x,toint,fromint,op)) = toint (False `op` x)++-- Error: assuming two different existentially quantifier variables are the same+--h (E (_,toint,_,_)) (E (x,_,_,_)) = toint x++-- Error: the existentially quantified type variable escapes+-- (and becomes universally quantified)+--j (E (x,_,_,_)) = x
+ tools/base/tests/FunDep.hs view
@@ -0,0 +1,18 @@+module FunDep where+import Maybe++class C a b | a->b where f :: a->b++instance C [a] a where f = head++instance C a b => C (Maybe a) (Maybe b) where f = fmap f+--instance (Functor f,C a b) => C (f a) (f b) where f = fmap f++instance C Bool Int where f = fromEnum+instance C Int String where f = show+++f2 x = f (f x)++z = f False+s = f2 False
+ tools/base/tests/FunDep2.hs view
@@ -0,0 +1,52 @@+module FunDep2 where+import FunDep ++--instance C (a,Int) a where f = fst++--instance C (Int,b) b where f = snd++instance (C a d,C d c)  => C (a,b) (a,b,c) where f (x,y) = (x,y,f (f x))++--instance C a c => C (a,b) (a,b,c)++g x = f (x, x)++bla = g False++class QualNames qn m n | qn -> m n, m n -> qn where+  getQualifier  :: qn -> Maybe m+  getQualified  :: qn -> n+  mkUnqual      :: n -> qn+  mkQual        :: m -> n -> qn++class HasBaseName ie ib | ie->ib           where getBaseName :: ie -> ib++bq n =  getQualifier (getBaseName n)++newtype M = M String+newtype Id = Id String+data Q = Q M Id | U Id++data PN i = PN i++instance Functor PN where fmap f (PN x) = PN (f x)++instance HasBaseName (PN i) i where getBaseName (PN i) = i++instance QualNames Q M Id where+  getQualifier (Q m x) = Just m+  getQualifier _       = Nothing+  getQualified (Q m x) = x+  getQualified (U   x) = x+  mkUnqual x = U x+  mkQual q x = Q q x++instance QualNames qn m n => QualNames (PN qn) m (PN n) where+    getQualifier                = bq+    getQualified                = fmap getQualified++    mkUnqual                    = fmap mkUnqual+    mkQual m                    = fmap (mkQual m)++bla2 :: QualNames q m n => PN q -> Maybe m+bla2 x = bq x
+ tools/base/tests/FunDep3.hs view
@@ -0,0 +1,29 @@+module FunDep3 where++data Zero = Zero deriving (Show)+newtype Succ n = Succ n deriving (Show)++one = Succ Zero+two = Succ one++class Add a b c | a b -> c where add :: a -> b -> c++instance Add Zero b b where add _ b = b+instance Add a b c => Add (Succ a) b (Succ c) where+    add (Succ a) b = Succ (add a b)++double n = add n n++three = add one two+four = double two+eight = double four++class Mul a b c | a b -> c where mul :: a -> b -> c++instance Mul Zero b Zero where mul _ _ = Zero+instance (Mul a b c1,Add b c1 c) => Mul (Succ a) b c where+  mul (Succ a) b = add b (mul a b)++nine = mul three three++n36 = mul four nine
+ tools/base/tests/FunDep4.hs view
@@ -0,0 +1,11 @@+module FunDep4 where+++class A e a | a->e where a :: a->a; e :: a->e+class B a where b :: a->a++class (A e a,B a) => C e a+instance (A e a,B a) => C e a++f :: C e a => a->a+f x = a (b x)
+ tools/base/tests/GhcLibraries/Concurrent.hs view
@@ -0,0 +1,54 @@+-- Dummy Concurrent module+module Concurrent where++data Chan a+data ThreadId+data MVar a++instance Show ThreadId++forkIO :: IO () -> IO ThreadId+forkIO = undefined++threadDelay :: Int -> IO ()+threadDelay = undefined++yield :: IO ()+yield = undefined++killThread :: ThreadId -> IO ()+killThread = undefined++writeChan :: Chan a -> a -> IO ()+writeChan = undefined++newChan :: IO (Chan a)+newChan = undefined++--isEmptyChan ::+isEmptyChan = undefined++--readChan ::+readChan = undefined++getChanContents :: Chan a -> IO [a]+getChanContents = undefined++newEmptyMVar :: IO (MVar a)+newEmptyMVar = undefined++newMVar :: a -> IO (MVar a)+newMVar = undefined++putMVar :: MVar a -> a -> IO ()+putMVar = undefined++readMVar :: MVar a -> IO a+readMVar = undefined++takeMVar :: MVar a -> IO a+takeMVar = undefined++swapMVar :: MVar a -> a -> IO a+swapMVar = undefined+
+ tools/base/tests/GhcLibraries/Dynamic.hs view
@@ -0,0 +1,26 @@+-- Dummy Dynamic module+module Dynamic where++data Dynamic+data TypeRep+data TyCon++instance Show Dynamic++class Typeable a where+  typeOf :: a -> TypeRep++fromDyn :: (Typeable a) => Dynamic -> a -> a+fromDyn = undefined++toDyn :: (Typeable a) => a -> Dynamic+toDyn = undefined++mkTyCon :: String -> TyCon+mkTyCon = undefined++mkAppTy :: TyCon   -> [TypeRep] -> TypeRep+mkAppTy = undefined++instance Typeable Int where+    typeOf = undefined
+ tools/base/tests/GhcLibraries/Exception.hs view
@@ -0,0 +1,13 @@+-- Dummy Exception module+module Exception where++data Exception++finally :: IO a -> IO b -> IO a+finally = undefined++catch   :: IO a -> (Exception -> IO a) -> IO a+catch   = undefined++instance Show Exception where+    show _ = "*"
+ tools/base/tests/GhcLibraries/FiniteMap.hs view
@@ -0,0 +1,44 @@+-- Dummy FiniteMap module+module FiniteMap where++data FiniteMap key elt++emptyFM             :: FiniteMap key elt+unitFM              :: key -> elt -> FiniteMap key elt+lookupFM            :: Ord key => FiniteMap key elt -> key -> Maybe elt+listToFM            :: Ord key => [(key,elt)] -> FiniteMap key elt+fmToList            :: FiniteMap key elt -> [(key,elt)]+keysFM              :: FiniteMap key alt -> [key]+eltsFM              :: FiniteMap key alt -> [alt]+addListToFM         :: Ord key => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt+addListToFM_C :: Ord key => (elt -> elt -> elt) -> FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt+lookupWithDefaultFM :: Ord key =>FiniteMap key elt -> elt -> key -> elt+mapFM               ::  (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2+isEmptyFM           :: FiniteMap key elt -> Bool+filterFM            :: Ord key => (key -> elt -> Bool)-> FiniteMap key elt -> FiniteMap key elt+delListFromFM       :: Ord key => FiniteMap key elt -> [key] -> FiniteMap key elt+plusFM              :: Ord key => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt+elemFM              ::  Ord key => key -> FiniteMap key elt -> Bool+delFromFM           ::  Ord key => FiniteMap key elt -> key -> FiniteMap key elt+addToFM             ::  Ord key => FiniteMap key elt -> key -> elt -> FiniteMap key elt+sizeFM              ::   Ord key => FiniteMap key elt -> Int++emptyFM             = undefined+unitFM              = undefined+lookupFM            = undefined+listToFM            = undefined+fmToList            = undefined+keysFM              = undefined+eltsFM              = undefined+addListToFM         = undefined+addListToFM_C       = undefined+lookupWithDefaultFM = undefined+mapFM               = undefined+isEmptyFM           = undefined+filterFM            = undefined+delListFromFM       = undefined+plusFM              = undefined+elemFM              = undefined+delFromFM           = undefined+addToFM             = undefined+sizeFM              = undefined
+ tools/base/tests/GhcLibraries/GetOpt.hs view
@@ -0,0 +1,299 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Console.GetOpt+-- Copyright   :  (c) Sven Panne Oct. 1996 (small changes Feb. 2003)+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- This library provides facilities for parsing the command-line options+-- in a standalone program.  It is essentially a Haskell port of the GNU +-- @getopt@ library.+--+-----------------------------------------------------------------------------++{-+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small+changes Dec. 1997)++Two rather obscure features are missing: The Bash 2.0 non-option hack+(if you don't already know it, you probably don't want to hear about+it...) and the recognition of long options with a single dash+(e.g. '-help' is recognised as '--help', as long as there is no short+option 'h').++Other differences between GNU's getopt and this implementation:++* To enforce a coherent description of options and arguments, there+  are explanation fields in the option/argument descriptor.++* Error messages are now more informative, but no longer POSIX+  compliant... :-(++And a final Haskell advertisement: The GNU C implementation uses well+over 1100 lines, we need only 195 here, including a 46 line example! +:-)+-}++module GetOpt (+	-- * GetOpt+	getOpt,+	usageInfo,+	ArgOrder(..),+	OptDescr(..),+	ArgDescr(..),++	-- * Example+		+	-- $example+  ) where++import Prelude+import List 	( isPrefixOf )++-- |What to do with options following non-options+data ArgOrder a+  = RequireOrder                -- ^ no option processing after first non-option+  | Permute                     -- ^ freely intersperse options and non-options+  | ReturnInOrder (String -> a) -- ^ wrap non-options into options++{-|+Each 'OptDescr' describes a single option.++The arguments to 'Option' are:++* list of short option characters++* list of long option strings (without \"--\")++* argument descriptor++* explanation of option for user+-}+data OptDescr a =              -- description of a single options:+   Option [Char]                --    list of short option characters+          [String]              --    list of long option strings (without "--")+          (ArgDescr a)          --    argument descriptor+          String                --    explanation of option for user++-- |Describes whether an option takes an argument or not, and if so+-- how the argument is injected into a value of type @a@.+data ArgDescr a+   = NoArg                   a         -- ^   no argument expected+   | ReqArg (String       -> a) String -- ^   option requires argument+   | OptArg (Maybe String -> a) String -- ^   optional argument++data OptKind a                -- kind of cmd line arg (internal use only):+   = Opt       a                --    an option+   | NonOpt    String           --    a non-option+   | EndOfOpts                  --    end-of-options marker (i.e. "--")+   | OptErr    String           --    something went wrong...++-- | Return a string describing the usage of a command, derived from+-- the header (first argument) and the options described by the +-- second argument.+usageInfo :: String                    -- header+          -> [OptDescr a]              -- option descriptors+          -> String                    -- nicely formatted decription of options+usageInfo header optDescr = unlines (header:table)+   where (ss,ls,ds)     = (unzip3 . map fmtOpt) optDescr+         table          = zipWith3 paste (sameLen ss) (sameLen ls) ds+         paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z+         sameLen xs     = flushLeft ((maximum . map length) xs) xs+         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]++fmtOpt :: OptDescr a -> (String,String,String)+fmtOpt (Option sos los ad descr) = (sepBy ',' (map (fmtShort ad) sos),+                                    sepBy ',' (map (fmtLong  ad) los),+                                    descr)+   where sepBy _  []     = ""+         sepBy _  [x]    = x+         sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs++fmtShort :: ArgDescr a -> Char -> String+fmtShort (NoArg  _   ) so = "-" ++ [so]+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg  _   ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"++{-|+Process the command-line, and return the list of values that matched+(and those that didn\'t). The arguments are:++* The order requirements (see 'ArgOrder')++* The option descriptions (see 'OptDescr')++* The actual command line arguments (presumably got from +  'System.Environment.getArgs').++'getOpt' returns a triple, consisting of the argument values, a list+of options that didn\'t match, and a list of error messages.+-}+getOpt :: ArgOrder a                   -- non-option handling+       -> [OptDescr a]                 -- option descriptors+       -> [String]                     -- the commandline arguments+       -> ([a],[String],[String])      -- (options,non-options,error messages)+getOpt _        _        []         =  ([],[],[])+getOpt ordering optDescr (arg:args) = procNextOpt opt ordering+   where procNextOpt (Opt o)    _                 = (o:os,xs,es)+         procNextOpt (NonOpt x) RequireOrder      = ([],x:rest,[])+         procNextOpt (NonOpt x) Permute           = (os,x:xs,es)+         procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es)+         procNextOpt EndOfOpts  RequireOrder      = ([],rest,[])+         procNextOpt EndOfOpts  Permute           = ([],rest,[])+         procNextOpt EndOfOpts  (ReturnInOrder f) = (map f rest,[],[])+         procNextOpt (OptErr e) _                 = (os,xs,e:es)++         (opt,rest) = getNext arg args optDescr+         (os,xs,es) = getOpt ordering optDescr rest++-- take a look at the next cmd line arg and decide what to do with it+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr+getNext a            rest _        = (NonOpt a,rest)++-- handle long option+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])+longOpt ls rs optDescr = long ads arg rs+   where (opt,arg) = break (=='=') ls+         getWith p = [ o  | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `p` l ]+         exact     = getWith (==)+         options   = if null exact then getWith isPrefixOf else exact+         ads       = [ ad | Option _ _ ad _ <- options ]+         optStr    = ("--"++opt)++         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)+         long [NoArg  a  ] []       rest     = (Opt a,rest)+         long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)+         long [ReqArg _ d] []       []       = (errReq d optStr,[])+         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)+         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)+         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)+         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)+         long _            _        rest     = (errUnrec optStr,rest)++-- handle short option+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])+shortOpt x xs rest optDescr = short ads xs rest+  where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]+        ads     = [ ad | Option _ _ ad _ <- options ]+        optStr  = '-':[x]++        short (_:_:_)        _  rest     = (errAmbig options optStr,rest)+        short (NoArg  a  :_) [] rest     = (Opt a,rest)+        short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)+        short (ReqArg _ d:_) [] []       = (errReq d optStr,[])+        short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)+        short (ReqArg f _:_) xs rest     = (Opt (f xs),rest)+        short (OptArg f _:_) [] rest     = (Opt (f Nothing),rest)+        short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)+        short []             [] rest     = (errUnrec optStr,rest)+        short []             xs rest     = (errUnrec optStr,('-':xs):rest)++-- miscellaneous error formatting++errAmbig :: [OptDescr a] -> String -> OptKind a+errAmbig ods optStr = OptErr (usageInfo header ods)+   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"++errReq :: String -> String -> OptKind a+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")++errUnrec :: String -> OptKind a+errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n")++errNoArg :: String -> OptKind a+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")++{-+-----------------------------------------------------------------------------------------+-- and here a small and hopefully enlightening example:++data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show++options :: [OptDescr Flag]+options =+   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",+    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",+    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",+    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]++out :: Maybe String -> Flag+out Nothing  = Output "stdout"+out (Just o) = Output o++test :: ArgOrder Flag -> [String] -> String+test order cmdline = case getOpt order options cmdline of+                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"+                        (_,_,errs) -> concat errs ++ usageInfo header options+   where header = "Usage: foobar [OPTION...] files..."++-- example runs:+-- putStr (test RequireOrder ["foo","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["foo","-v"])+--    ==> options=[Verbose]  args=["foo"]+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])+--    ==> options=[Arg "foo", Verbose]  args=[]+-- putStr (test Permute ["foo","--","-v"])+--    ==> options=[]  args=["foo", "-v"]+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])+--    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]+-- putStr (test Permute ["--ver","foo"])+--    ==> option `--ver' is ambiguous; could be one of:+--          -v      --verbose             verbosely list files+--          -V, -?  --version, --release  show version info   +--        Usage: foobar [OPTION...] files...+--          -v        --verbose             verbosely list files  +--          -V, -?    --version, --release  show version info     +--          -o[FILE]  --output[=FILE]       use FILE for dump     +--          -n USER   --name=USER           only dump USER's files+-----------------------------------------------------------------------------------------+-}++{- $example++To hopefully illuminate the role of the different data+structures, here\'s the command-line options for a (very simple)+compiler:++>    module Opts where+>    +>    import System.Console.GetOpt+>    import Data.Maybe ( fromMaybe )+>    +>    data Flag +>     = Verbose  | Version +>     | Input String | Output String | LibDir String+>    	deriving Show+>    +>    options :: [OptDescr Flag]+>    options =+>     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"+>     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"+>     , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"+>     , Option ['c']     []          (OptArg inp  "FILE")  "input FILE"+>     , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"+>     ]+>    +>    inp,outp :: Maybe String -> Flag+>    outp = Output . fromMaybe "stdout"+>    inp  = Input  . fromMaybe "stdout"+>    +>    compilerOpts :: [String] -> IO ([Flag], [String])+>    compilerOpts argv = +>    	case (getOpt Permute options argv) of+>    	   (o,n,[]  ) -> return (o,n)+>    	   (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+>      where header = "Usage: ic [OPTION...] files..."++-}
+ tools/base/tests/GhcLibraries/IOExts.hs view
@@ -0,0 +1,19 @@+-- A minimal dummy IOExts module+module IOExts where++data IORef a++foreign import trace :: String -> a -> a+foreign import unsafePerformIO :: IO a -> a+foreign import unsafeInterleaveIO :: IO a -> IO a++foreign import newIORef :: a -> IO (IORef a)+foreign import readIORef :: IORef a -> IO a+foreign import writeIORef :: IORef a -> a -> IO ()++foreign import fixIO :: (a -> IO a) -> IO a+++data IOArray ix el++instance Eq (IORef a)
+ tools/base/tests/GhcLibraries/Int.hs view
@@ -0,0 +1,52 @@+-- Dummy Int module+module Int where+import Ix++data Int8+data Int16+data Int32+data Int64++instance Eq Int8 where (==) = undefined+instance Ord Int8 where compare = undefined+instance Num Int8 where negate = undefined+instance Bounded Int8+instance Real Int8+instance Integral Int8+instance Ix Int8+instance Enum Int8+instance Read Int8+instance Show Int8 where showsPrec = undefined++instance Eq Int16 where (==) = undefined+instance Ord Int16 where compare = undefined+instance Num Int16 where negate = undefined+instance Bounded Int16+instance Real Int16+instance Integral Int16+instance Ix Int16+instance Enum Int16+instance Read Int16+instance Show Int16 where showsPrec = undefined++instance Eq Int32 where (==) = undefined+instance Ord Int32 where compare = undefined+instance Num Int32 where negate = undefined+instance Bounded Int32+instance Real Int32+instance Integral Int32+instance Ix Int32+instance Enum Int32+instance Read Int32+instance Show Int32 where showsPrec = undefined++instance Eq Int64 where (==) = undefined+instance Ord Int64 where compare = undefined+instance Num Int64 where negate = undefined+instance Bounded Int64+instance Real Int64+instance Integral Int64+instance Ix Int64+instance Enum Int64+instance Read Int64+instance Show Int64 where showsPrec = undefined
+ tools/base/tests/GhcLibraries/LazyST.hs view
@@ -0,0 +1,11 @@+-- Dummy LazyST module+module LazyST where++data ST s a+data STRef s a++foreign import newSTRef :: a -> ST s (STRef s a)+foreign import readSTRef :: STRef s a -> ST s a+foreign import writeSTRef :: STRef s a -> a -> ST s a++foreign import fixST :: (a -> ST s a) -> ST s a
+ tools/base/tests/GhcLibraries/LeftistHeap.hs view
@@ -0,0 +1,29 @@+-- Dummny LeftistHeap module+module LeftistHeap where++import Sequence+data Heap a++maxElem :: Ord a => Heap a -> a+maxElem = undefined++null :: Ord a => Heap a -> Bool+null = undefined++delete :: Ord a => a -> Heap a -> Heap a+delete = undefined++insert :: Ord a => a -> Heap a -> Heap a+insert = undefined++empty :: Ord a => Heap a+empty = undefined++deleteMax :: Ord a => Heap a -> Heap a+deleteMax = undefined++toSeq :: (Ord a, Sequence seq) => Heap a -> seq a+toSeq = undefined++filter :: Ord a => (a -> Bool) -> Heap a -> Heap a+filter = undefined
+ tools/base/tests/GhcLibraries/MArray.hs view
@@ -0,0 +1,9 @@+module MArray where++--writeArray::+--readArray::+--newArray :: +writeArray=undefined+readArray=undefined+newArray=undefined+bounds=undefined -- same as Array.bounds?
+ tools/base/tests/GhcLibraries/Network.hs view
@@ -0,0 +1,21 @@+module Network where+++data PortID = PortNumber PortNumber+            | UnixSocket String+         -- | ...+data Socket+type PortNumber=Int+type HostName=String++accept::Socket->IO (Handle,HostName,PortNumber)+accept=undefined++listenOn::PortId->IO Socket+listenOn=undefined++connectTo :: HostName->PortId->IO Handle+connectTo = undefined++withSocketsDo :: IO a -> IO a+withSocketsDo = id
+ tools/base/tests/GhcLibraries/PackedString.hs view
@@ -0,0 +1,14 @@+module PackedString where+import qualified Prelude as P+import Prelude hiding (null)++newtype PackedString = PS String deriving (Eq,Ord)++instance Show PackedString where+  showsPrec n (PS s) r = s++r++packString = PS+unpackPS (PS s) = s++null (PS s) = P.null s+
+ tools/base/tests/GhcLibraries/Parsec.hs view
@@ -0,0 +1,56 @@+-- Dummy Parsec module+module Parsec where++import Monad++type Parser a           = GenParser Char () a+newtype GenParser tok st a = Parser (State tok st -> Consumed (Reply tok st a))+data Consumed a         = Consumed a                --input is consumed+                        | Empty !a                  --no input is consumed+                    +data Reply tok st a     = Ok a (State tok st) ParseError      --parsing succeeded with "a"+                        | Error ParseError                    --parsing failed++data State tok st       = State { stateInput :: [tok]+                                , statePos   :: SourcePos+                                , stateUser  :: !st+                                }+data ParseError     = ParseError !SourcePos [Message]+instance Show ParseError where+    show _ = "*"++type SourceName     = String+type Line           = Int+type Column         = Int++data SourcePos      = SourcePos SourceName !Line !Column+		     deriving (Eq,Ord)+data Message        = SysUnExpect !String   --library generated unexpect            +                    | UnExpect    !String   --unexpected something     +                    | Expect      !String   --expecting something+                    | Message     !String   --raw message++instance Monad (GenParser tok st) where+    return = undefined+    a >>= b = undefined++instance MonadPlus (GenParser tok st) where+    mzero = undefined++(<|>) :: GenParser tok st a -> GenParser tok st a -> GenParser tok st a+p1 <|> p2           = undefined++parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a)+parseFromFile = undefined++many :: GenParser tok st a -> GenParser tok st [a]+many = undefined++try :: GenParser tok st a -> GenParser tok st a+try = undefined++runParser :: GenParser tok st a -> st -> SourceName -> [tok] -> Either ParseError a+runParser = undefined++option :: a -> GenParser tok st a -> GenParser tok st a+option = undefined
+ tools/base/tests/GhcLibraries/ParsecChar.hs view
@@ -0,0 +1,14 @@+-- Dummy ParsecCombinator module+module ParsecChar where++import Parsec+type CharParser st a    = GenParser Char st a++alphaNum :: CharParser st Char+alphaNum = undefined++char :: Char -> CharParser st Char+char = undefined++newline :: CharParser st Char+newline = undefined
+ tools/base/tests/GhcLibraries/ParsecCombinator.hs view
@@ -0,0 +1,10 @@+-- Dummy ParsecCombinator module+module ParsecCombinator where++import Parsec++sepBy :: GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a]+sepBy = undefined++between :: GenParser tok st open -> GenParser tok st close +between = undefined
+ tools/base/tests/GhcLibraries/ParsecLanguage.hs view
@@ -0,0 +1,10 @@+-- Dummy ParsecToken module+module ParsecLanguage where++import ParsecToken++haskellDef :: LanguageDef st+haskellDef = undefined++haskellStyle :: LanguageDef st+haskellStyle = undefined
+ tools/base/tests/GhcLibraries/ParsecToken.hs view
@@ -0,0 +1,70 @@+-- Dummy ParsecToken module+module ParsecToken where++import ParsecChar++data LanguageDef st+    = LanguageDef +    { commentStart   :: String+    , commentEnd     :: String+    , commentLine    :: String+    , nestedComments :: Bool                  +    , identStart     :: CharParser st Char+    , identLetter    :: CharParser st Char+    , opStart        :: CharParser st Char+    , opLetter       :: CharParser st Char+    , reservedNames  :: [String]+    , reservedOpNames:: [String]+    , caseSensitive  :: Bool+    }                           +           +data TokenParser st+    = TokenParser{ identifier       :: CharParser st String+                 , reserved         :: String -> CharParser st ()+                 , operator         :: CharParser st String+                 , reservedOp       :: String -> CharParser st ()+                        +                 , charLiteral      :: CharParser st Char+                 , stringLiteral    :: CharParser st String+                 , natural          :: CharParser st Integer+                 , integer          :: CharParser st Integer+                 , float            :: CharParser st Double+                 , naturalOrFloat   :: CharParser st (Either Integer Double)+                 , decimal          :: CharParser st Integer+                 , hexadecimal      :: CharParser st Integer+                 , octal            :: CharParser st Integer+            +                 , symbol           :: String -> CharParser st String++                 , whiteSpace       :: CharParser st ()     +             ++                 , semi             :: CharParser st String+                 , comma            :: CharParser st String+                 , colon            :: CharParser st String+                 , dot              :: CharParser st String+                 }++makeTokenParser :: LanguageDef st -> TokenParser st+makeTokenParser = undefined++lexeme           :: TokenParser st -> CharParser st a -> CharParser st a+lexeme = undefined+semiSep          :: TokenParser st -> CharParser st a -> CharParser st [a]+semiSep = undefined+semiSep1         :: TokenParser st -> CharParser st a -> CharParser st [a]+semiSep1 = undefined+commaSep         :: TokenParser st -> CharParser st a -> CharParser st [a]+commaSep = undefined+commaSep1        :: TokenParser st -> CharParser st a -> CharParser st [a]+commaSep1 = undefined+parens           :: TokenParser st -> CharParser st a -> CharParser st a +parens = undefined+braces           :: TokenParser st -> CharParser st a -> CharParser st a+braces = undefined+angles           :: TokenParser st -> CharParser st a -> CharParser st a+angles = undefined+brackets         :: TokenParser st -> CharParser st a -> CharParser st a+brackets = undefined+squares          :: TokenParser st -> CharParser st a -> CharParser st a +squares = undefined
+ tools/base/tests/GhcLibraries/Posix.hs view
@@ -0,0 +1,31 @@+module Posix where++import Prelude hiding (FilePath)+data Handler = Ignore+data DirStream+data FileStatus+type FilePath = String++--installHandler::+--sigPIPE::++installHandler = undefined+sigPIPE = undefined++openDirStream :: FilePath -> IO DirStream+openDirStream = undefined++readDirStream :: DirStream -> IO String+readDirStream = undefined++rewindDirStream :: DirStream -> IO ()+rewindDirStream = undefined++closeDirStream :: DirStream -> IO ()+closeDirStream = undefined++getFileStatus :: FilePath -> IO FileStatus+getFileStatus = undefined++isDirectory :: FileStatus -> Bool+isDirectory = undefined
+ tools/base/tests/GhcLibraries/PosixProcEnv.hs view
@@ -0,0 +1,9 @@+module PosixProcEnv where++data SysVar = ArgumentLimit | ChildLimit | ClockTick | GroupLimit | OpenFileLimit | PosixVersion | HasSavedIDs | HasJobControl++data ProcessTimes -- (PosixUtil.ClockTick, PrelByteArr.ByteArray Int)+type ClockTick = Int -- from PosixUtil++foreign import getProcessTimes :: IO ProcessTimes+foreign import elapsedTime :: ProcessTimes -> ClockTick
+ tools/base/tests/GhcLibraries/Pretty.hs view
@@ -0,0 +1,867 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.PrettyPrint.HughesPJ+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators+-- +-- Based on /The Design of a Pretty-printing Library/+-- in Advanced Functional Programming,+-- Johan Jeuring and Erik Meijer (eds), LNCS 925+-- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>+--+-- Heavily modified by Simon Peyton Jones, Dec 96+--+-----------------------------------------------------------------------------++{-+Version 3.0     28 May 1997+  * Cured massive performance bug.  If you write++        foldl <> empty (map (text.show) [1..10000])++    you get quadratic behaviour with V2.0.  Why?  For just the same+    reason as you get quadratic behaviour with left-associated (++)+    chains.++    This is really bad news.  One thing a pretty-printer abstraction+    should certainly guarantee is insensivity to associativity.  It+    matters: suddenly GHC's compilation times went up by a factor of+    100 when I switched to the new pretty printer.++    I fixed it with a bit of a hack (because I wanted to get GHC back+    on the road).  I added two new constructors to the Doc type, Above+    and Beside:++         <> = Beside+         $$ = Above++    Then, where I need to get to a "TextBeside" or "NilAbove" form I+    "force" the Doc to squeeze out these suspended calls to Beside and+    Above; but in so doing I re-associate. It's quite simple, but I'm+    not satisfied that I've done the best possible job.  I'll send you+    the code if you are interested.++  * Added new exports:+        punctuate, hang+        int, integer, float, double, rational,+        lparen, rparen, lbrack, rbrack, lbrace, rbrace,++  * fullRender's type signature has changed.  Rather than producing a+    string it now takes an extra couple of arguments that tells it how+    to glue fragments of output together:++        fullRender :: Mode+                   -> Int                       -- Line length+                   -> Float                     -- Ribbons per line+                   -> (TextDetails -> a -> a)   -- What to do with text+                   -> a                         -- What to do at the end+                   -> Doc+                   -> a                         -- Result++    The "fragments" are encapsulated in the TextDetails data type:++        data TextDetails = Chr  Char+                         | Str  String+                         | PStr FAST_STRING++    The Chr and Str constructors are obvious enough.  The PStr+    constructor has a packed string (FAST_STRING) inside it.  It's+    generated by using the new "ptext" export.++    An advantage of this new setup is that you can get the renderer to+    do output directly (by passing in a function of type (TextDetails+    -> IO () -> IO ()), rather than producing a string that you then+    print.++Version 2.0     24 April 1997+  * Made empty into a left unit for <> as well as a right unit;+    it is also now true that+        nest k empty = empty+    which wasn't true before.++  * Fixed an obscure bug in sep that occassionally gave very weird behaviour++  * Added $+$++  * Corrected and tidied up the laws and invariants++======================================================================+Relative to John's original paper, there are the following new features:++1.  There's an empty document, "empty".  It's a left and right unit for +    both <> and $$, and anywhere in the argument list for+    sep, hcat, hsep, vcat, fcat etc.++    It is Really Useful in practice.++2.  There is a paragraph-fill combinator, fsep, that's much like sep,+    only it keeps fitting things on one line until it can't fit any more.++3.  Some random useful extra combinators are provided.  +        <+> puts its arguments beside each other with a space between them,+            unless either argument is empty in which case it returns the other++        hcat is a list version of <>+        hsep is a list version of <+>+        vcat is a list version of $$++        sep (separate) is either like hsep or like vcat, depending on what fits++        cat  behaves like sep,  but it uses <> for horizontal conposition+        fcat behaves like fsep, but it uses <> for horizontal conposition++        These new ones do the obvious things:+                char, semi, comma, colon, space,+                parens, brackets, braces, +                quotes, doubleQuotes++4.  The "above" combinator, $$, now overlaps its two arguments if the+    last line of the top argument stops before the first line of the+    second begins.++        For example:  text "hi" $$ nest 5 "there"+        lays out as+                        hi   there+        rather than+                        hi+                             there++        There are two places this is really useful++        a) When making labelled blocks, like this:+                Left ->   code for left+                Right ->  code for right+                LongLongLongLabel ->+                          code for longlonglonglabel+           The block is on the same line as the label if the label is+           short, but on the next line otherwise.++        b) When laying out lists like this:+                [ first+                , second+                , third+                ]+           which some people like.  But if the list fits on one line+           you want [first, second, third].  You can't do this with+           John's original combinators, but it's quite easy with the+           new $$.++        The combinator $+$ gives the original "never-overlap" behaviour.++5.      Several different renderers are provided:+                * a standard one+                * one that uses cut-marks to avoid deeply-nested documents +                        simply piling up in the right-hand margin+                * one that ignores indentation (fewer chars output; good for machines)+                * one that ignores indentation and newlines (ditto, only more so)++6.      Numerous implementation tidy-ups+        Use of unboxed data types to speed up the implementation+-}++module Pretty (++	-- * The document type+        Doc,            -- Abstract++	-- * Primitive Documents+        empty,+        semi, comma, colon, space, equals,+        lparen, rparen, lbrack, rbrack, lbrace, rbrace,++	-- * Converting values into documents+        text, char, ptext,+        int, integer, float, double, rational,++	-- * Wrapping documents in delimiters+        parens, brackets, braces, quotes, doubleQuotes,++	-- * Combining documents+        (<>), (<+>), hcat, hsep, +        ($$), ($+$), vcat, +        sep, cat, +        fsep, fcat, +	nest,+        hang, punctuate,+        +	-- * Predicates on documents+	isEmpty,++	-- * Rendering documents++	-- ** Default rendering+	render, ++	-- ** Rendering with a particular style+	Style(..),+	style,+        renderStyle,++	-- ** General rendering+        fullRender,+        Mode(..), TextDetails(..),++  ) where++import Prelude++infixl 6 <> +infixl 6 <+>+infixl 5 $$, $+$++-- ---------------------------------------------------------------------------+-- The interface++-- The primitive Doc values++isEmpty :: Doc    -> Bool;  -- ^ Returns 'True' if the document is empty++empty   :: Doc;			-- ^ An empty document+semi	:: Doc;			-- ^ A ';' character+comma	:: Doc;			-- ^ A ',' character+colon	:: Doc;			-- ^ A ':' character+space	:: Doc;			-- ^ A space character+equals	:: Doc;			-- ^ A '=' character+lparen	:: Doc;			-- ^ A '(' character+rparen	:: Doc;			-- ^ A ')' character+lbrack	:: Doc;			-- ^ A '[' character+rbrack	:: Doc;			-- ^ A ']' character+lbrace	:: Doc;			-- ^ A '{' character+rbrace	:: Doc;			-- ^ A '}' character++text	 :: String   -> Doc+ptext	 :: String   -> Doc+char 	 :: Char     -> Doc+int      :: Int      -> Doc+integer  :: Integer  -> Doc+float    :: Float    -> Doc+double   :: Double   -> Doc+rational :: Rational -> Doc++parens       :: Doc -> Doc; 	-- ^ Wrap document in @(...)@+brackets     :: Doc -> Doc;  	-- ^ Wrap document in @[...]@+braces	     :: Doc -> Doc;   	-- ^ Wrap document in @{...}@+quotes	     :: Doc -> Doc;	-- ^ Wrap document in @'...'@+doubleQuotes :: Doc -> Doc;	-- ^ Wrap document in @\"...\"@++-- Combining @Doc@ values++(<>)   :: Doc -> Doc -> Doc;     -- ^Beside+hcat   :: [Doc] -> Doc;          -- ^List version of '<>'+(<+>)  :: Doc -> Doc -> Doc;     -- ^Beside, separated by space+hsep   :: [Doc] -> Doc;          -- ^List version of '<+>'++($$)   :: Doc -> Doc -> Doc;     -- ^Above; if there is no+                                -- overlap it \"dovetails\" the two+vcat   :: [Doc] -> Doc;          -- ^List version of '$$'++cat    :: [Doc] -> Doc;          -- ^ Either hcat or vcat+sep    :: [Doc] -> Doc;          -- ^ Either hsep or vcat+fcat   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of cat+fsep   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of sep++nest   :: Int -> Doc -> Doc;     -- ^ Nested++-- GHC-specific ones.++hang :: Doc -> Int -> Doc -> Doc;	-- ^ @hang d1 n d2 = sep [d1, nest n d2]@+punctuate :: Doc -> [Doc] -> [Doc];      -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@++-- Displaying @Doc@ values. ++instance Show Doc where+  showsPrec prec doc cont = showDoc doc cont++-- | Renders the document as a string using the default style+render     :: Doc -> String++-- | The general rendering interface+fullRender :: Mode			-- ^Rendering mode+           -> Int                       -- ^Line length+           -> Float                     -- ^Ribbons per line+           -> (TextDetails -> a -> a)   -- ^What to do with text+           -> a                         -- ^What to do at the end+           -> Doc			-- ^The document+           -> a                         -- ^Result++-- | Render the document as a string using a specified style+renderStyle  :: Style -> Doc -> String++-- | A rendering style+data Style+ = Style { mode           :: Mode     -- ^ The rendering mode+ 	 , lineLength     :: Int      -- ^ Length of line, in chars+         , ribbonsPerLine :: Float    -- ^ Ratio of ribbon length to line length+         }++-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@)+style :: Style+style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }++-- | Rendering mode+data Mode = PageMode            -- ^Normal +          | ZigZagMode          -- ^With zig-zag cuts+          | LeftMode            -- ^No indentation, infinitely long lines+          | OneLineMode         -- ^All on one line++-- ---------------------------------------------------------------------------+-- The Doc calculus++-- The Doc combinators satisfy the following laws:++{-+Laws for $$+~~~~~~~~~~~+<a1>    (x $$ y) $$ z   = x $$ (y $$ z)+<a2>    empty $$ x      = x+<a3>    x $$ empty      = x++        ...ditto $+$...++Laws for <>+~~~~~~~~~~~+<b1>    (x <> y) <> z   = x <> (y <> z)+<b2>    empty <> x      = empty+<b3>    x <> empty      = x++        ...ditto <+>...++Laws for text+~~~~~~~~~~~~~+<t1>    text s <> text t        = text (s++t)+<t2>    text "" <> x            = x, if x non-empty++Laws for nest+~~~~~~~~~~~~~+<n1>    nest 0 x                = x+<n2>    nest k (nest k' x)      = nest (k+k') x+<n3>    nest k (x <> y)         = nest k z <> nest k y+<n4>    nest k (x $$ y)         = nest k x $$ nest k y+<n5>    nest k empty            = empty+<n6>    x <> nest k y           = x <> y, if x non-empty++** Note the side condition on <n6>!  It is this that+** makes it OK for empty to be a left unit for <>.++Miscellaneous+~~~~~~~~~~~~~+<m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$ +                                         nest (-length s) y)++<m2>    (x $$ y) <> z = x $$ (y <> z)+        if y non-empty++Laws for list versions+~~~~~~~~~~~~~~~~~~~~~~+<l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)+        ...ditto hsep, hcat, vcat, fill...++<l2>    nest k (sep ps) = sep (map (nest k) ps)+        ...ditto hsep, hcat, vcat, fill...++Laws for oneLiner+~~~~~~~~~~~~~~~~~+<o1>    oneLiner (nest k p) = nest k (oneLiner p)+<o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y ++You might think that the following verion of <m1> would+be neater:++<3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$ +                                         nest (-length s) y)++But it doesn't work, for if x=empty, we would have++        text s $$ y = text s <> (empty $$ nest (-length s) y)+                    = text s <> nest (-length s) y+-}++-- ---------------------------------------------------------------------------+-- Simple derived definitions++semi  = char ';'+colon = char ':'+comma = char ','+space = char ' '+equals = char '='+lparen = char '('+rparen = char ')'+lbrack = char '['+rbrack = char ']'+lbrace = char '{'+rbrace = char '}'++int      n = text (show n)+integer  n = text (show n)+float    n = text (show n)+double   n = text (show n)+rational n = text (show n)+-- SIGBJORN wrote instead:+-- rational n = text (show (fromRationalX n))++quotes p        = char '`' <> p <> char '\''+doubleQuotes p  = char '"' <> p <> char '"'+parens p        = char '(' <> p <> char ')'+brackets p      = char '[' <> p <> char ']'+braces p        = char '{' <> p <> char '}'++hcat = foldr (<>)  empty+hsep = foldr (<+>) empty+vcat = foldr ($$)  empty++hang d1 n d2 = sep [d1, nest n d2]++punctuate p []     = []+punctuate p (d:ds) = go d ds+                   where+                     go d [] = [d]+                     go d (e:es) = (d <> p) : go e es++-- ---------------------------------------------------------------------------+-- The Doc data type++-- A Doc represents a *set* of layouts.  A Doc with+-- no occurrences of Union or NoDoc represents just one layout.++-- | The abstract type of documents+data Doc+ = Empty                                -- empty+ | NilAbove Doc                         -- text "" $$ x+ | TextBeside TextDetails !Int Doc      -- text s <> x  + | Nest !Int Doc                        -- nest k x+ | Union Doc Doc                        -- ul `union` ur+ | NoDoc                                -- The empty set of documents+ | Beside Doc Bool Doc                  -- True <=> space between+ | Above  Doc Bool Doc                  -- True <=> never overlap++type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside++reduceDoc :: Doc -> RDoc+reduceDoc (Beside p g q) = beside p g (reduceDoc q)+reduceDoc (Above  p g q) = above  p g (reduceDoc q)+reduceDoc p              = p++data TextDetails = Chr  Char+                 | Str  String+                 | PStr String+space_text = Chr ' '+nl_text    = Chr '\n'++{-+  Here are the invariants:+  +  * The argument of NilAbove is never Empty. Therefore+    a NilAbove occupies at least two lines.+  +  * The arugment of @TextBeside@ is never @Nest@.+  +  +  * The layouts of the two arguments of @Union@ both flatten to the same +    string.+  +  * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.+  +  * The right argument of a union cannot be equivalent to the empty set+    (@NoDoc@).  If the left argument of a union is equivalent to the+    empty set (@NoDoc@), then the @NoDoc@ appears in the first line.+  +  * An empty document is always represented by @Empty@.  It can't be+    hidden inside a @Nest@, or a @Union@ of two @Empty@s.+  +  * The first line of every layout in the left argument of @Union@ is+    longer than the first line of any layout in the right argument.+    (1) ensures that the left argument has a first line.  In view of+    (3), this invariant means that the right argument must have at+    least two lines.+-}++        -- Arg of a NilAbove is always an RDoc+nilAbove_ p = NilAbove p++        -- Arg of a TextBeside is always an RDoc+textBeside_ s sl p = TextBeside s sl p++        -- Arg of Nest is always an RDoc+nest_ k p = Nest k p++        -- Args of union are always RDocs+union_ p q = Union p q++-- Notice the difference between+-- 	   * NoDoc (no documents)+-- 	   * Empty (one empty document; no height and no width)+-- 	   * text "" (a document containing the empty string;+-- 		      one line high, but has no width)++-- ---------------------------------------------------------------------------+-- @empty@, @text@, @nest@, @union@++empty = Empty++isEmpty Empty = True+isEmpty _     = False++char  c = textBeside_ (Chr c) 1 Empty+text  s = case length   s of {sl -> textBeside_ (Str s)  sl Empty}+ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}++nest k  p = mkNest k (reduceDoc p)        -- Externally callable version++-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it+mkNest k       _           | k `seq` False = undefined+mkNest k       (Nest k1 p) = mkNest (k + k1) p+mkNest k       NoDoc       = NoDoc+mkNest k       Empty       = Empty+mkNest 0       p           = p                  -- Worth a try!+mkNest k       p           = nest_ k p++-- mkUnion checks for an empty document+mkUnion Empty q = Empty+mkUnion p q     = p `union_` q++-- ---------------------------------------------------------------------------+-- Vertical composition @$$@++p $$  q = Above p False q+p $+$ q = Above p True q++above :: Doc -> Bool -> RDoc -> RDoc+above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)+above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)+above p g q                  = aboveNest p             g 0 (reduceDoc q)++aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc+-- Specfication: aboveNest p g k q = p $g$ (nest k q)++aboveNest _                   _ k _ | k `seq` False = undefined+aboveNest NoDoc               g k q = NoDoc+aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_` +                                      aboveNest p2 g k q+                                +aboveNest Empty               g k q = mkNest k q+aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k - k1) q)+                                  -- p can't be Empty, so no need for mkNest+                                +aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)+aboveNest (TextBeside s sl p) g k q = k1 `seq` textBeside_ s sl rest+                                    where+                                      k1   = k - sl+                                      rest = case p of+                                                Empty -> nilAboveNest g k1 q+                                                other -> aboveNest  p g k1 q++nilAboveNest :: Bool -> Int -> RDoc -> RDoc+-- Specification: text s <> nilaboveNest g k q +--              = text s <> (text "" $g$ nest k q)++nilAboveNest _ k _           | k `seq` False = undefined+nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q++nilAboveNest g k q           | (not g) && (k > 0)        -- No newline if no overlap+                             = textBeside_ (Str (spaces k)) k q+                             | otherwise                        -- Put them really above+                             = nilAbove_ (mkNest k q)++-- ---------------------------------------------------------------------------+-- Horizontal composition @<>@++p <>  q = Beside p False q+p <+> q = Beside p True  q++beside :: Doc -> Bool -> RDoc -> RDoc+-- Specification: beside g p q = p <g> q+ +beside NoDoc               g q   = NoDoc+beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)+beside Empty               g q   = q+beside (Nest k p)          g q   = nest_ k (beside p g q)       -- p non-empty+beside p@(Beside p1 g1 q1) g2 q2 +           {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2 +                                                 [ && (op1 == <> || op1 == <+>) ] -}+         | g1 == g2              = beside p1 g1 (beside q1 g2 q2)+         | otherwise             = beside (reduceDoc p) g2 q2+beside p@(Above _ _ _)     g q   = beside (reduceDoc p) g q+beside (NilAbove p)        g q   = nilAbove_ (beside p g q)+beside (TextBeside s sl p) g q   = textBeside_ s sl rest+                               where+                                  rest = case p of+                                           Empty -> nilBeside g q+                                           other -> beside p g q++nilBeside :: Bool -> RDoc -> RDoc+-- Specification: text "" <> nilBeside g p +--              = text "" <g> p++nilBeside g Empty      = Empty  -- Hence the text "" in the spec+nilBeside g (Nest _ p) = nilBeside g p+nilBeside g p          | g         = textBeside_ space_text 1 p+                       | otherwise = p++-- ---------------------------------------------------------------------------+-- Separate, @sep@, Hughes version++-- Specification: sep ps  = oneLiner (hsep ps)+--                         `union`+--                          vcat ps++sep = sepX True         -- Separate with spaces+cat = sepX False        -- Don't++sepX x []     = empty+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps++-- Specification: sep1 g k ys = sep (x : map (nest k) ys)+--                            = oneLiner (x <g> nest k (hsep ys))+--                              `union` x $$ nest k (vcat ys)++sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc+sep1 g _                   k ys | k `seq` False = undefined+sep1 g NoDoc               k ys = NoDoc+sep1 g (p `Union` q)       k ys = sep1 g p k ys+                                  `union_`+                                  (aboveNest q False k (reduceDoc (vcat ys)))++sep1 g Empty               k ys = mkNest k (sepX g ys)+sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k - n) ys)++sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)++-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys+-- Called when we have already found some text in the first item+-- We have to eat up nests++sepNB g (Nest _ p)  k ys  = sepNB g p k ys++sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))+                                `mkUnion` +                            nilAboveNest False k (reduceDoc (vcat ys))+                          where+                            rest | g         = hsep ys+                                 | otherwise = hcat ys++sepNB g p k ys            = sep1 g p k ys++-- ---------------------------------------------------------------------------+-- @fill@++fsep = fill True+fcat = fill False++-- Specification: +--   fill []  = empty+--   fill [p] = p+--   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) +--                                          (fill (oneLiner p2 : ps))+--                     `union`+--                      p1 $$ fill ps++fill g []     = empty+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps++fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc+fill1 g _                   k ys | k `seq` False = undefined+fill1 g NoDoc               k ys = NoDoc+fill1 g (p `Union` q)       k ys = fill1 g p k ys+                                   `union_`+                                   (aboveNest q False k (fill g ys))++fill1 g Empty               k ys = mkNest k (fill g ys)+fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)++fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)++fillNB g _           k ys | k `seq` False = undefined+fillNB g (Nest _ p)  k ys  = fillNB g p k ys+fillNB g Empty k []        = Empty+fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)+                             `mkUnion` +                             nilAboveNest False k (fill g (y:ys))+                           where+                             k1 | g         = k - 1+                                | otherwise = k++fillNB g p k ys            = fill1 g p k ys++-- ---------------------------------------------------------------------------+-- Selecting the best layout++best :: Mode+     -> Int             -- Line length+     -> Int             -- Ribbon length+     -> RDoc+     -> RDoc            -- No unions in here!++best OneLineMode w r p+  = get p+  where+    get Empty               = Empty+    get NoDoc               = NoDoc+    get (NilAbove p)        = nilAbove_ (get p)+    get (TextBeside s sl p) = textBeside_ s sl (get p)+    get (Nest k p)          = get p             -- Elide nest+    get (p `Union` q)       = first (get p) (get q)++best mode w r p+  = get w p+  where+    get :: Int          -- (Remaining) width of line+        -> Doc -> Doc+    get w _ | w==0 && False   = undefined+    get w Empty               = Empty+    get w NoDoc               = NoDoc+    get w (NilAbove p)        = nilAbove_ (get w p)+    get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)+    get w (Nest k p)          = nest_ k (get (w - k) p)+    get w (p `Union` q)       = nicest w r (get w p) (get w q)++    get1 :: Int         -- (Remaining) width of line+         -> Int         -- Amount of first line already eaten up+         -> Doc         -- This is an argument to TextBeside => eat Nests+         -> Doc         -- No unions in here!++    get1 w _ _ | w==0 && False = undefined+    get1 w sl Empty               = Empty+    get1 w sl NoDoc               = NoDoc+    get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)+    get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)+    get1 w sl (Nest k p)          = get1 w sl p+    get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p) +                                                   (get1 w sl q)++nicest w r p q = nicest1 w r 0 p q+nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p+                   | otherwise                   = q++fits :: Int     -- Space available+     -> Doc+     -> Bool    -- True if *first line* of Doc fits in space available+ +fits n p    | n < 0 = False+fits n NoDoc               = False+fits n Empty               = True+fits n (NilAbove _)        = True+fits n (TextBeside _ sl p) = fits (n - sl) p++minn x y | x < y    = x+         | otherwise = y++-- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.+-- @first@ returns its first argument if it is non-empty, otherwise its second.++first p q | nonEmptySet p = p +          | otherwise     = q++nonEmptySet NoDoc           = False+nonEmptySet (p `Union` q)      = True+nonEmptySet Empty              = True+nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line+nonEmptySet (TextBeside _ _ p) = nonEmptySet p+nonEmptySet (Nest _ p)         = nonEmptySet p++-- @oneLiner@ returns the one-line members of the given set of @Doc@s.++oneLiner :: Doc -> Doc+oneLiner NoDoc               = NoDoc+oneLiner Empty               = Empty+oneLiner (NilAbove p)        = NoDoc+oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)+oneLiner (Nest k p)          = nest_ k (oneLiner p)+oneLiner (p `Union` q)       = oneLiner p++-- ---------------------------------------------------------------------------+-- Displaying the best layout++renderStyle style doc +  = fullRender (mode style)+               (lineLength style)+	       (ribbonsPerLine style)+	       string_txt+	       ""+	       doc++render doc       = showDoc doc ""+showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc++string_txt (Chr c)   s  = c:s+string_txt (Str s1)  s2 = s1 ++ s2+string_txt (PStr s1) s2 = s1 ++ s2++fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)+fullRender LeftMode    _ _ txt end doc = easy_display nl_text    txt end (reduceDoc doc)++fullRender mode line_length ribbons_per_line txt end doc+  = display mode line_length ribbon_length txt end best_doc+  where +    best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)++    hacked_line_length, ribbon_length :: Int+    ribbon_length = round (fromIntegral line_length / ribbons_per_line)+    hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }++display mode page_width ribbon_width txt end doc+  = case page_width - ribbon_width of { gap_width ->+    case gap_width `quot` 2 of { shift ->+    let+        lay k _            | k `seq` False = undefined+        lay k (Nest k1 p)  = lay (k + k1) p+        lay k Empty        = end+    +        lay k (NilAbove p) = nl_text `txt` lay k p+    +        lay k (TextBeside s sl p)+            = case mode of+                    ZigZagMode |  k >= gap_width+                               -> nl_text `txt` (+                                  Str (multi_ch shift '/') `txt` (+                                  nl_text `txt` (+                                  lay1 (k - shift) s sl p)))++                               |  k < 0+                               -> nl_text `txt` (+                                  Str (multi_ch shift '\\') `txt` (+                                  nl_text `txt` (+                                  lay1 (k + shift) s sl p )))++                    other -> lay1 k s sl p+    +        lay1 k _ sl _ | k+sl `seq` False = undefined+        lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)+    +        lay2 k _ | k `seq` False = undefined+        lay2 k (NilAbove p)        = nl_text `txt` lay k p+        lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)+        lay2 k (Nest _ p)          = lay2 k p+        lay2 k Empty               = end+    in+    lay 0 doc+    }}++cant_fail = error "easy_display: NoDoc"+easy_display nl_text txt end doc +  = lay doc cant_fail+  where+    lay NoDoc               no_doc = no_doc+    lay (Union p q)         no_doc = {- lay p -} (lay q cant_fail)              -- Second arg can't be NoDoc+    lay (Nest k p)          no_doc = lay p no_doc+    lay Empty               no_doc = end+    lay (NilAbove p)        no_doc = nl_text `txt` lay p cant_fail      -- NoDoc always on first line+    lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc++indent n | n >= 8 = '\t' : indent (n - 8)+         | otherwise      = spaces n++multi_ch 0 ch = ""+multi_ch n       ch = ch : multi_ch (n - 1) ch++spaces 0 = ""+spaces n       = ' ' : spaces (n - 1)+
+ tools/base/tests/GhcLibraries/QuickCheck.hs view
@@ -0,0 +1,351 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Debug.QuickCheck+-- Copyright   :  (c) Koen Claessen, John Hughes 2001+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- QuickCheck v.0.2+-- DRAFT implementation; last update 000104.+-- Koen Claessen, John Hughes.+-- This file represents work in progress, and might change at a later date.+--+-----------------------------------------------------------------------------++module QuickCheck+  -- testing functions+  ( quickCheck    -- :: prop -> IO ()+  , verboseCheck  -- :: prop -> IO ()+  , test          -- :: prop -> IO ()  -- = quickCheck+  +  , Config(..)    -- :: *+  , check         -- :: Config -> prop -> IO ()+ +  -- property combinators+  , forAll        -- :: Gen a -> (a -> prop) -> prop+  , (==>)         -- :: Bool -> prop -> prop+  +  -- gathering test-case information+  , label         -- :: String         -> prop -> prop+  , collect       -- :: Show a => a    -> prop -> prop+  , classify      -- :: Bool -> String -> prop -> prop+  , trivial       -- :: Bool           -> prop -> prop+  +  -- generator combinators+  , Gen           -- :: * -> * ; Functor, Monad+  +  , elements      -- :: [a] -> Gen a+  , two           -- :: Gen a -> Gen (a,a)+  , three         -- :: Gen a -> Gen (a,a,a)+  , four          -- :: Gen a -> Gen (a,a,a,a)+  +  , sized         -- :: (Int -> Gen a) -> Gen a+  , resize        -- :: Int -> Gen a -> Gen a+  , choose        -- :: Random a => (a, a) -> Gen a+  , oneof         -- :: [Gen a] -> Gen a+  , frequency     -- :: [(Int, Gen a)] -> Gen a+  +  , vector        -- :: Arbitrary a => Int -> Gen [a]++  -- default generators+  , Arbitrary(..) -- :: class+  , rand          -- :: Gen StdGen+  , promote       -- :: (a -> Gen b) -> Gen (a -> b)+  , variant       -- :: Int -> Gen a -> Gen a++  -- testable+  , Testable(..)  -- :: class+  , Property      -- :: *++  -- For writing your own driver+  , Result(..)	 -- :: data+  , generate	 -- :: Int -> StdGen -> Gen a -> a+  , evaluate     -- :: Testable a => a -> Gen Result+  )+ where++import Prelude++import Random+import List( group, sort, intersperse )+import Monad( liftM2, liftM3, liftM4 )++infixr 0 ==>+infix  1 `classify`++--------------------------------------------------------------------+-- Generator++newtype Gen a+  = Gen (Int -> StdGen -> a)++sized :: (Int -> Gen a) -> Gen a+sized fgen = Gen (\n r -> let Gen m = fgen n in m n r)++resize :: Int -> Gen a -> Gen a+resize n (Gen m) = Gen (\_ r -> m n r)++rand :: Gen StdGen+rand = Gen (\n r -> r)++promote :: (a -> Gen b) -> Gen (a -> b)+promote f = Gen (\n r -> \a -> let Gen m = f a in m n r)++variant :: Int -> Gen a -> Gen a+variant v (Gen m) = Gen (\n r -> m n (rands r !! (v+1)))+ where+  rands r0 = r1 : rands r2 where (r1, r2) = split r0++generate :: Int -> StdGen -> Gen a -> a+generate n rnd (Gen m) = m size rnd'+ where+  (size, rnd') = randomR (0, n) rnd++instance Functor Gen where+  fmap f m = m >>= return . f++instance Monad Gen where+  return a    = Gen (\n r -> a)+  Gen m >>= k =+    Gen (\n r0 -> let (r1,r2) = split r0+                      Gen m'  = k (m n r1)+                   in m' n r2)++-- derived++choose :: Random a => (a, a) -> Gen a+choose bounds = (fst . randomR bounds) `fmap` rand++elements :: [a] -> Gen a+elements xs = (xs !!) `fmap` choose (0, length xs - 1)++vector :: Arbitrary a => Int -> Gen [a]+vector n = sequence [ arbitrary | i <- [1..n] ]++oneof :: [Gen a] -> Gen a+oneof gens = elements gens >>= id++frequency :: [(Int, Gen a)] -> Gen a+frequency xs = choose (1, tot) >>= (`pick` xs)+ where+  tot = sum (map fst xs)++  pick n ((k,x):xs)+    | n <= k    = x+    | otherwise = pick (n-k) xs++-- general monadic++two :: Monad m => m a -> m (a, a)+two m = liftM2 (,) m m++three :: Monad m => m a -> m (a, a, a)+three m = liftM3 (,,) m m m++four :: Monad m => m a -> m (a, a, a, a)+four m = liftM4 (,,,) m m m m++--------------------------------------------------------------------+-- Arbitrary++class Arbitrary a where+  arbitrary   :: Gen a+  coarbitrary :: a -> Gen b -> Gen b++instance Arbitrary () where+  arbitrary     = return ()+  coarbitrary _ = variant 0++instance Arbitrary Bool where+  arbitrary     = elements [True, False]+  coarbitrary b = if b then variant 0 else variant 1++instance Arbitrary Int where+  arbitrary     = sized $ \n -> choose (-n,n)+  coarbitrary n = variant (if n >= 0 then 2*n else 2*(-n) + 1)++instance Arbitrary Integer where+  arbitrary     = sized $ \n -> choose (-fromIntegral n,fromIntegral n)+  coarbitrary n = variant (fromInteger (if n >= 0 then 2*n else 2*(-n) + 1))++instance Arbitrary Float where+  arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary +  coarbitrary x = coarbitrary (decodeFloat x)++instance Arbitrary Double where+  arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary +  coarbitrary x = coarbitrary (decodeFloat x)++fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1))++instance (Arbitrary aa, Arbitrary bb) => Arbitrary (aa, bb) where+  arbitrary          = liftM2 (,) arbitrary arbitrary+  coarbitrary (a, b) = coarbitrary a . coarbitrary b++instance (Arbitrary aa, Arbitrary bb, Arbitrary cc) => Arbitrary (aa, bb, cc) where+  arbitrary             = liftM3 (,,) arbitrary arbitrary arbitrary+  coarbitrary (a, b, c) = coarbitrary a . coarbitrary b . coarbitrary c++instance (Arbitrary aa, Arbitrary bb, Arbitrary cc, Arbitrary dd)+      => Arbitrary (aa, bb, cc, dd)+ where+  arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary+  coarbitrary (a, b, c, d) =+    coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d++instance Arbitrary aa => Arbitrary [aa] where+  arbitrary          = sized (\n -> choose (0,n) >>= vector)+  coarbitrary []     = variant 0+  coarbitrary (a:as) = coarbitrary a . variant 1 . coarbitrary as++instance (Arbitrary aa, Arbitrary bb) => Arbitrary (aa -> bb) where+  arbitrary         = promote (`coarbitrary` arbitrary)+  coarbitrary f gen = arbitrary >>= ((`coarbitrary` gen) . f)++--------------------------------------------------------------------+-- Testable++data Result+  = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] }++nothing :: Result+nothing = Result{ ok = Nothing, stamp = [], arguments = [] }++newtype Property+  = Prop (Gen Result)++result :: Result -> Property+result res = Prop (return res)++evaluate :: Testable a => a -> Gen Result+evaluate a = gen where Prop gen = toProperty a++class Testable a where+  toProperty :: a -> Property++instance Testable () where+  toProperty _ = result nothing++instance Testable Bool where+  toProperty b = result (nothing{ ok = Just b })++instance Testable Result where+  toProperty res = result res++instance Testable Property where+  toProperty prop = prop++instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where+  toProperty f = forAll arbitrary f++forAll :: (Show a, Testable b) => Gen a -> (a -> b) -> Property+forAll gen body = Prop $+  do a   <- gen+     res <- evaluate (body a)+     return (argument a res)+ where+  argument a res = res{ arguments = show a : arguments res }++(==>) :: Testable a => Bool -> a -> Property+True  ==> a = toProperty a+False ==> a = toProperty ()++label :: Testable a => String -> a -> Property+label s a = Prop (add `fmap` evaluate a)+ where+  add res = res{ stamp = s : stamp res }++classify :: Testable a => Bool -> String -> a -> Property+classify True  name = label name+classify False _    = toProperty++trivial :: Testable a => Bool -> a -> Property+trivial = (`classify` "trivial")++collect :: (Show a, Testable b) => a -> b -> Property+collect v = label (show v)++--------------------------------------------------------------------+-- Testing++data Config = Config+  { configMaxTest :: Int+  , configMaxFail :: Int+  , configSize    :: Int -> Int+  , configEvery   :: Int -> [String] -> String+  }++quick :: Config+quick = Config+  { configMaxTest = 100+  , configMaxFail = 1000+  , configSize    = (+ 3) . (`div` 2)+  , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+  }+         +verbose :: Config+verbose = quick+  { configEvery = \n args -> show n ++ ":\n" ++ unlines args+  }++test, quickCheck, verboseCheck :: Testable a => a -> IO ()+test         = check quick+quickCheck   = check quick+verboseCheck = check verbose+         +check :: Testable a => Config -> a -> IO ()+check config a =+  do rnd <- newStdGen+     tests config (evaluate a) rnd 0 0 []++tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () +tests config gen rnd0 ntest nfail stamps+  | ntest == configMaxTest config = do done "OK, passed" ntest stamps+  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps+  | otherwise               =+      do putStr (configEvery config ntest (arguments result))+         case ok result of+           Nothing    ->+             tests config gen rnd1 ntest (nfail+1) stamps+           Just True  ->+             tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)+           Just False ->+             putStr ( "Falsifiable, after "+                   ++ show ntest+                   ++ " tests:\n"+                   ++ unlines (arguments result)+                    )+     where+      result      = generate (configSize config ntest) rnd2 gen+      (rnd1,rnd2) = split rnd0++done :: String -> Int -> [[String]] -> IO ()+done mesg ntest stamps =+  do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )+ where+  table = display+        . map entry+        . reverse+        . sort+        . map pairLength+        . group+        . sort+        . filter (not . null)+        $ stamps++  display []  = ".\n"+  display [x] = " (" ++ x ++ ").\n"+  display xs  = ".\n" ++ unlines (map (++ ".") xs)++  pairLength xss@(xs:_) = (length xss, xs)+  entry (n, xs)         = percentage n ntest+                       ++ " "+                       ++ concat (intersperse ", " xs)++  percentage n m        = show ((100 * n) `div` m) ++ "%"++--------------------------------------------------------------------+-- the end.
+ tools/base/tests/GhcLibraries/ST.hs view
@@ -0,0 +1,15 @@+-- A dummy ST module+module ST where++data ST s a     = ST+data STRef s a = STRef++foreign import newSTRef :: a -> ST s (STRef s a)+foreign import readSTRef :: STRef s a -> ST s a+foreign import writeSTRef :: STRef s a -> a -> ST s ()++foreign import fixST :: (a -> ST s a) -> ST s a++instance Eq (STRef s a)+instance Functor (ST s)+instance Monad (ST s)
+ tools/base/tests/GhcLibraries/Sequence.hs view
@@ -0,0 +1,10 @@+-- Dummy Sequence module+module Sequence where++import Monad++class (Functor s, MonadPlus s) => Sequence s where+  empty     :: s a++instance Sequence [] where+  empty = []
+ tools/base/tests/GhcLibraries/Set.hs view
@@ -0,0 +1,22 @@+-- A dummy Set module...+module Set where++newtype Set a = Set [a]++emptySet :: Set a+mkSet :: Ord a => [a] -> Set a+setToList :: Set a -> [a]+unionManySets :: Ord a => [Set a] -> Set a+intersect, union, minusSet :: Ord a => Set a -> Set a -> Set a+mapSet :: Ord b => (a->b) -> Set a -> Set b+elementOf :: Ord a => a -> Set a -> Bool++emptySet = undefined+mkSet = undefined+setToList = undefined+unionManySets = undefined+minusSet = undefined+mapSet = undefined+intersect = undefined+union = undefined+elementOf = undefined
+ tools/base/tests/GhcLibraries/SocketPrim.hs view
@@ -0,0 +1,7 @@+module SocketPrim where++--accept::+--socketToHandle::++accept = undefined+socketToHandle = undefined
+ tools/base/tests/HaskellLibraries/Array.hs view
@@ -0,0 +1,81 @@+module  Array ( +    module Ix,  -- export all of Ix +    Array, array, listArray, (!), bounds, indices, elems, assocs, +    accumArray, (//), accum, ixmap ) where++import Prelude+import Ix+import List( (\\) )++infixl 9  !, //++data (Ix a) => Array a b = MkArray (a,a) (a -> b)++--array       :: (Ix a) => (a,a) -> [(a,b)] -> Array a b+array b ivs =+    if and [inRange b i | (i,_) <- ivs]+        then MkArray b $+                     \j -> let vs = [v | (i,v) <- ivs, i == j]+                           in case vs of+                                [v]   -> v+                                []    -> error "Array.!: undefined array element"+                                _     -> error "Array.!: multiply defined array element"+                     +        else error "Array.array: out-of-range array association"++--listArray             :: (Ix a) => (a,a) -> [b] -> Array a b+listArray b vs        =  array b (zipWith (\ a b -> (a,b)) (range b) vs)++(!)                   :: (Ix a) => Array a b -> a -> b+(!) (MkArray _ f)     =  f++bounds                :: (Ix a) => Array a b -> (a,a)+bounds (MkArray b _)  =  b++indices               :: (Ix a) => Array a b -> [a]+indices               =  range . bounds++elems                 :: (Ix a) => Array a b -> [b]+elems a               =  [a!i | i <- indices a]++assocs                :: (Ix a) => Array a b -> [(a,b)]+assocs a              =  [(i, a!i) | i <- indices a]++--(//)                  :: (Ix a) => Array a b -> [(a,b)] -> Array a b+a // us               =  array (bounds a)+                            ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]+                             ++ us)++--accum                 :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)]+--                                   -> Array a b+accum f               =  foldl (\a (i,v) -> a // [(i,f (a!i) v)])++--accumArray            :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)]+--                                   -> Array a b+accumArray f z b      =  accum f (array b [(i,z) | i <- range b])++--ixmap                 :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c+--                                         -> Array a c+ixmap b f a           = array b [(i, a ! f i) | i <- range b]+++instance  (Ix ix)         => Functor (Array ix) where+    fmap fn (MkArray b f) =  MkArray b (fn . f) ++instance  (Eq a,Ix a, Eq b)  => Eq (Array a b)  where+    a == a'             =  assocs a == assocs a'++instance  (Ix a,Ord a, Ord b) => Ord (Array a b)  where+    a <=  a'            =  assocs a <=  assocs a'++instance  (Ix a, Show a, Show b) => Show (Array a b)  where+    showsPrec p a = showParen (p > 9) (+                    showString "array " .+                    shows (bounds a) . showChar ' ' .+                    shows (assocs a)                  )++instance  (Eq a,Ix a, Read a, Read b) => Read (Array a b)  where+    readsPrec p = readParen (p > 9)+           (\r -> [(array b as, u) | ("array",s) <- lex r,+                                     (b,t)       <- reads s,+                                     (as,u)      <- reads t   ])
+ tools/base/tests/HaskellLibraries/CPUTime.hs view
@@ -0,0 +1,5 @@+module CPUTime where+import Prelude++foreign import getCPUTime :: IO Integer+foreign import cpuTimePrecision :: Integer
+ tools/base/tests/HaskellLibraries/Char.hs view
@@ -0,0 +1,149 @@+module Char(+    isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower, +    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, +    digitToInt, intToDigit,+    toUpper, toLower,+    ord, chr,+    readLitChar, showLitChar, lexLitChar,+    Char,String+ )+where+import Prelude+import PreludeBuiltin+import Numeric(readDec, readOct, lexDigits, readHex)+import Array+import Ix++isAscii, isControl, isPrint, isSpace            :: Char -> Bool+isUpper, isLower, isAlpha, isDigit, isAlphanum  :: Char -> Bool++isAscii c     =  c < '\x80'++isLatin1 c = c <= '\xff'++isControl c   =  c < ' ' || c >= '\DEL' && c <= '\x9f'++isPrint c     =  c >= ' '   &&  c <= '~' || c >= '\xa0'++isSpace c     =  c == ' '   || c == '\t'  || c == '\n'  || c == '\r'  ||+                               c == '\f'  || c == '\v' || c=='\xa0'++isUpper c     =+        c >= 'A' && c <= 'Z' ++isLower c     =+        c >= 'a' && c <= 'z'++isAlpha c     =  isUpper c  ||  isLower c+isDigit c     =  c >= '0'   &&  c <= '9'+isAlphanum c  =  isAlpha c  ||  isDigit c+isAlphaNum = isAlphanum++toUpper, toLower      :: Char -> Char++toUpper c | isLower c  = chr (ord c - ord 'a' + ord 'A')+          | otherwise  = c++toLower c | isUpper c  = chr (ord c - ord 'A' + ord 'a')+          | otherwise  = c++minChar, maxChar      :: Char+minChar                = chr 0+maxChar                = chr 255+++isOctDigit c             =  c >= '0' && c <= '7'++isHexDigit c             =  isDigit c || c >= 'A' && c <= 'F' ||+                                         c >= 'a' && c <= 'f'+-- Digit conversion operations+digitToInt :: Char -> Int+digitToInt c+  | isDigit c            =  fromEnum c - fromEnum '0'+  | c >= 'a' && c <= 'f' =  fromEnum c - fromEnum 'a' + 10+  | c >= 'A' && c <= 'F' =  fromEnum c - fromEnum 'A' + 10+  | otherwise            =  error "Char.digitToInt: not a digit"++intToDigit :: Int -> Char+intToDigit i+  | i >= 0  && i <=  9   =  toEnum (fromEnum '0' + i)+  | i >= 10 && i <= 15   =  toEnum (fromEnum 'a' + i - 10)+  | otherwise            =  error "Char.intToDigit: not a digit"++ord c = primCharToInt c+chr n = primIntToChar n+++-- Text functions+--readLitChar             :: ReadS Char+readLitChar ('\\':s)    =  readEsc s+        where+        readEsc ('a':s)  = [('\a',s)]+        readEsc ('b':s)  = [('\b',s)]+        readEsc ('f':s)  = [('\f',s)]+        readEsc ('n':s)  = [('\n',s)]+        readEsc ('r':s)  = [('\r',s)]+        readEsc ('t':s)  = [('\t',s)]+        readEsc ('v':s)  = [('\v',s)]+        readEsc ('\\':s) = [('\\',s)]+        readEsc ('"':s)  = [('"',s)]+        readEsc ('\'':s) = [('\'',s)]+        readEsc ('^':c:s) | c >= '@' && c <= '_'+                         = [(chr (ord c - ord '@'), s)]+        readEsc s@(d:_) | isDigit d+                         = [(chr n, t) | (n,t) <- readDec s]+        readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]+        readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]+        readEsc s@(c:_) | isUpper c+                         = let table = ('\DEL', "DEL") : assocs asciiTab+                           in case [(c,s') | (c, mne) <- table,+                                             ([],s') <- [match mne s]]+                              of (pr:_) -> [pr]+                                 []     -> []+        readEsc _        = []++	match                         :: (Eq a) => [a] -> [a] -> ([a],[a])+	match (x:xs) (y:ys) | x == y  =  match xs ys+	match xs     ys               =  (xs,ys)++readLitChar (c:s)       =  [(c,s)]+--}+showLitChar               :: Char -> ShowS+showLitChar c | c > '\DEL' =  showChar '\\' . +                              protectEsc isDigit (shows (ord c))+showLitChar '\DEL'         =  showString "\\DEL"+showLitChar '\\'           =  showString "\\\\"+showLitChar c | c >= ' '   =  showChar c+showLitChar '\a'           =  showString "\\a"+showLitChar '\b'           =  showString "\\b"+showLitChar '\f'           =  showString "\\f"+showLitChar '\n'           =  showString "\\n"+showLitChar '\r'           =  showString "\\r"+showLitChar '\t'           =  showString "\\t"+showLitChar '\v'           =  showString "\\v"+showLitChar '\SO'          =  protectEsc (== 'H') (showString "\\SO")+showLitChar c              =  showString ('\\' : asciiTab!c)++protectEsc p f             = f . cont+                             where cont s@(c:_) | p c = "\\&" ++ s+                                   cont s             = s+asciiTab = listArray ('\NUL', ' ')+           ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",+            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI", +            "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",+            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US", +            "SP"] ++--lexLitChar          :: ReadS String+lexLitChar ('\\':s) =  [('\\':esc, t) | (esc,t) <- lexEsc s]+        where+          lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]+          lexEsc s@(d:_)   | isDigit d               = lexDigits s+          lexEsc ('^':c:s) | c >= '@' && c <= '_'    = [(['^',c],s)]+          -- Very crude approximation to \XYZ.  Let readers work this out.+          lexEsc s@(c:_)   | isUpper c               = [span isCharName s]+          lexEsc _                                   = []+          isCharName c = isUpper c || isDigit c++lexLitChar (c:s)    =  [([c],s)]+lexLitChar ""       =  []
+ tools/base/tests/HaskellLibraries/Complex.hs view
@@ -0,0 +1,95 @@+module Complex(Complex((:+)), realPart, imagPart, conjugate, mkPolar,+               cis, polar, magnitude, phase)  where+--import Prelude++infix  6  :+++data  (RealFloat a)     => Complex a = !a :+ !a  deriving (Eq,Read,Show)+++realPart, imagPart :: (RealFloat a) => Complex a -> a+realPart (x:+y)  =  x+imagPart (x:+y)  =  y++conjugate  :: (RealFloat a) => Complex a -> Complex a+conjugate (x:+y) =  x :+ (-y)++mkPolar  :: (RealFloat a) => a -> a -> Complex a+mkPolar r theta  =  r * cos theta :+ r * sin theta++cis  :: (RealFloat a) => a -> Complex a+cis theta  =  cos theta :+ sin theta++polar  :: (RealFloat a) => Complex a -> (a,a)+polar z  =  (magnitude z, phase z)++magnitude :: (RealFloat a) => Complex a -> a+magnitude (x:+y) =  scaleFloat k+     (sqrt ((scaleFloat mk x)^(2::Int) + (scaleFloat mk y)^(2::Int)))+    where k  = max (exponent x) (exponent y)+          mk = - k++phase :: (RealFloat a) => Complex a -> a+phase (0 :+ 0) = 0+phase (x :+ y) = atan2 y x+++instance  (RealFloat a) => Num (Complex a)  where+    (x:+y) + (x':+y') =  (x+x') :+ (y+y')+    (x:+y) - (x':+y') =  (x-x') :+ (y-y')+    (x:+y) * (x':+y') =  (x*x'-y*y') :+ (x*y'+y*x')+    negate (x:+y) =  negate x :+ negate y+    abs z =  magnitude z :+ 0+    signum 0 =  0+    signum z@(x:+y) =  (x/r) :+ (y/r)  where r = magnitude z+    fromInteger n =  fromInteger n :+ 0++instance  (RealFloat a) => Fractional (Complex a)  where+    (x:+y) / (x':+y') =  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d+       where x'' = scaleFloat k x'+	     y'' = scaleFloat k y'+	     k   = - max (exponent x') (exponent y')+	     d   = x'*x'' + y'*y''++    fromRational a =  fromRational a :+ 0++instance  (RealFloat a) => Floating (Complex a) where+    pi             =  pi :+ 0+    exp (x:+y)     =  expx * cos y :+ expx * sin y+                      where expx = exp x+    log z          =  log (magnitude z) :+ phase z++    sqrt 0         =  0+    sqrt z@(x:+y)  =  u :+ (if y < 0 then -v else v)+                      where (u,v) = if x < 0 then (v',u') else (u',v')+                            v'    = abs y / (u'*2)+                            u'    = sqrt ((magnitude z + abs x) / 2)++    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y+    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)+    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))+                      where sinx  = sin x+                            cosx  = cos x+                            sinhy = sinh y+                            coshy = cosh y++    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x+    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x+    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)+                      where siny  = sin y+                            cosy  = cos y+                            sinhx = sinh x+                            coshx = cosh x++    asin z@(x:+y)  =  y':+(-x')+                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))+    acos z@(x:+y)  =  y'':+(-x'')+                      where (x'':+y'') = log (z + ((-y'):+x'))+                            (x':+y')   = sqrt (1 - z*z)+    atan z@(x:+y)  =  y':+(-x')+                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))++    asinh z        =  log (z + sqrt (1+z*z))+    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))+    atanh z        =  log ((1+z) / sqrt (1-z*z))+
+ tools/base/tests/HaskellLibraries/Directory.hs view
@@ -0,0 +1,25 @@+module Directory where+import Prelude+import Time(ClockTime)++data Permissions+  = Permissions { readable, writable, executable, searchable :: Bool }+  deriving ( Eq, Ord, Read, Show )++foreign import createDirectory :: FilePath -> IO ()+foreign import removeDirectory :: FilePath -> IO ()+foreign import removeFile :: FilePath -> IO ()+foreign import renameDirectory  :: FilePath -> FilePath -> IO ()+foreign import renameFile  :: FilePath -> FilePath -> IO ()++foreign import getDirectoryContents  :: FilePath -> IO [FilePath]+foreign import getCurrentDirectory  :: IO FilePath+foreign import setCurrentDirectory  :: FilePath -> IO ()++foreign import doesFileExist :: FilePath -> IO Bool+foreign import doesDirectoryExist :: FilePath -> IO Bool++foreign import getPermissions :: FilePath -> IO Permissions+foreign import setPermissions :: FilePath -> Permissions -> IO ()++foreign import getModificationTime :: FilePath -> IO ClockTime
+ tools/base/tests/HaskellLibraries/IO.hs view
@@ -0,0 +1,76 @@+module IO(module IO,module PreludeIO) where+import Prelude+import PreludeIO++data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode+                    deriving (Eq, Ord, {-Ix,-} Bounded, Enum, Read, Show)+data BufferMode  =  NoBuffering | LineBuffering +                 |  BlockBuffering (Maybe Int)+                    deriving (Eq, Ord, Read, Show)+data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd+                    deriving (Eq, Ord, {-Ix,-} Bounded, Enum, Read, Show)++--- Unimplemented things:+hSetBuffering mode handle = return ()+---++data PrimHandle+instance Eq PrimHandle+instance Show PrimHandle++foreign import prim_stdin :: PrimHandle+foreign import prim_stdout :: PrimHandle+foreign import prim_stderr :: PrimHandle+foreign import primHPutChar :: PrimHandle -> Char -> IO ()+foreign import primHPutStr :: PrimHandle -> String -> IO ()+foreign import primHFlush :: PrimHandle -> IO ()++newtype Handle = Handle PrimHandle deriving (Eq,Show)++stdin = Handle prim_stdin+stdout = Handle prim_stdout+stderr = Handle prim_stderr++foreign import openFile :: FilePath -> IOMode -> IO Handle+foreign import hClose :: Handle -> IO ()+foreign import hGetLine :: Handle -> IO String+foreign import hGetContents :: Handle -> IO String++hPutChar (Handle h) c = primHPutChar h c+hPutStr (Handle h) s = primHPutStr h s+hPutStrLn h s = hPutStr h s >> hPutChar h '\n'+hPrint h x = hPutStrLn h (show x)++hFlush (Handle h) = primHFlush h++---++ioeGetErrorString (IOE k s) = s++ioErrorKind (IOE k _) = k++isEOFError e = ioErrorKind e == EOFError+isUserError e = ioErrorKind e == UserError+isDoesNotExistError e = ioErrorKind e == DoesNotExistError++---+try            :: IO a -> IO (Either IOError a)+try f          =  catch (fmap Right f) (return . Left)++bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c+bracket before after m =+  do    x  <- before+        rs <- try (m x)+        after x+	returnTry rs++-- variant of the above where middle computation doesn't want x+bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c+bracket_ before after m =+  do     x  <- before+         rs <- try m+         after x+	 returnTry rs++returnTry (Right r) = return r+returnTry (Left  e) = ioError e
+ tools/base/tests/HaskellLibraries/Ix.hs view
@@ -0,0 +1,55 @@+module Ix ( Ix(range, index, inRange), rangeSize ) where+import Prelude++class  (Ord a) => Ix a  where+    range               :: (a,a) -> [a]+    index               :: (a,a) -> a -> Int+    inRange             :: (a,a) -> a -> Bool++rangeSize :: Ix a => (a,a) -> Int+rangeSize b@(l,h) | null (range b) = 0+                  | otherwise      = index b h + 1 +-- NB: replacing "null (range b)" by  "l > h" fails if+-- the bounds are tuples.  For example,+--  (2,1) > (1,2), +-- but +-- range ((2,1),(1,2)) = []+++instance  Ix Char  where+    range (m,n) = [m..n]+    index b@(c,c') ci+        | inRange b ci  =  fromEnum ci - fromEnum c+        | otherwise     =  error "Ix.index: Index out of range."+    inRange (c,c') i    =  c <= i && i <= c'++instance  Ix Int  where+    range (m,n) = [m..n]+    index b@(m,n) i+        | inRange b i   =  i - m+        | otherwise     =  error "Ix.index: Index out of range."+    inRange (m,n) i     =  m <= i && i <= n+++instance  Ix Integer  where+    range (m,n) = [m..n]+    index b@(m,n) i+        | inRange b i   =  fromInteger (i - m)+        | otherwise     =  error "Ix.index: Index out of range."+    inRange (m,n) i     =  m <= i && i <= n+++--instance (Ix a,Ix b) => Ix (a, b) -- as derived, for all tuples+--instance Ix Bool                  -- as derived+--instance Ix Ordering              -- as derived+--instance Ix ()                    -- as derived++++instance  (Ix a, Ix b)  => Ix (a,b) where+    range ((l,l'),(u,u'))+         = [(i,i') | i <- range (l,u), i' <- range (l',u')]+    index ((l,l'),(u,u')) (i,i')+         =  index (l,u) i * rangeSize (l',u') + index (l',u') i'+    inRange ((l,l'),(u,u')) (i,i')+         = inRange (l,u) i && inRange (l',u') i'
+ tools/base/tests/HaskellLibraries/List.hs view
@@ -0,0 +1,273 @@+module List (+    elemIndex, elemIndices,+    find, findIndex, findIndices,+    nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy,+    union, unionBy, intersect, intersectBy,+    intersperse, transpose, partition, group, groupBy,+    inits, tails, isPrefixOf, isSuffixOf,+    mapAccumL, mapAccumR,+    sort, sortBy, insert, insertBy, maximumBy, minimumBy,+    genericLength, genericTake, genericDrop,+    genericSplitAt, genericIndex, genericReplicate,+    zip4, zip5, zip6, zip7,+    zipWith4, zipWith5, zipWith6, zipWith7,+    unzip4, unzip5, unzip6, unzip7, unfoldr,++    -- ...and what the Prelude exports+    --[]((:), []),+    map, (++), concat, filter,+    head, last, tail, init, null, length, (!!),+    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,+    iterate, repeat, replicate, cycle,+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    lines, words, unlines, unwords, reverse, and, or,+    any, all, elem, notElem, lookup,+    sum, product, maximum, minimum, concatMap,+    zip, zip3, zipWith, zipWith3, unzip, unzip3+    ) where++import Prelude+import Maybe( listToMaybe )++infix 5 \\ --++elemIndex               :: Eq a => a -> [a] -> Maybe Int+elemIndex x             =  findIndex (x ==)++elemIndices             :: Eq a => a -> [a] -> [Int]+elemIndices x           =  findIndices (x ==)++find                    :: (a -> Bool) -> [a] -> Maybe a+find p                  =  listToMaybe . filter p++findIndex               :: (a -> Bool) -> [a] -> Maybe Int+findIndex p             =  listToMaybe . findIndices p++findIndices             :: (a -> Bool) -> [a] -> [Int]+findIndices p xs        =  [ i | (x,i) <- zip xs [0..], p x ]++nub                     :: Eq a => [a] -> [a]+nub                     =  nubBy (==)++nubBy                   :: (a -> a -> Bool) -> [a] -> [a]+nubBy eq []             =  []+nubBy eq (x:xs)         =  x : nubBy eq (filter (\y -> not (eq x y)) xs)++delete                  :: Eq a => a -> [a] -> [a]+delete                  =  deleteBy (==)++deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]+deleteBy eq x []        = []+deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys++(\\)                    :: Eq a => [a] -> [a] -> [a]+(\\)                    =  foldl (flip delete)++deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]+deleteFirstsBy eq       =  foldl (flip (deleteBy eq))++union                   :: Eq a => [a] -> [a] -> [a]+union                   =  unionBy (==)++unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]+unionBy eq xs ys        =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs++intersect               :: Eq a => [a] -> [a] -> [a]+intersect               =  intersectBy (==)++intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]+intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]++intersperse             :: a -> [a] -> [a]+intersperse sep []      =  []+intersperse sep [x]     =  [x]+intersperse sep (x:xs)  =  x : sep : intersperse sep xs++-- transpose is lazy in both rows and columns,+--   and works for non-rectangular 'matrices'+-- For example, transpose [[1,2],[3,4,5],[]]  =  [[1,3],[2,4],[5]]+-- Note that [h | (h:t) <- xss] is not the same as (map head xss)+-- because the former discards empty sublists inside xss+transpose                :: [[a]] -> [[a]]+transpose []  = []+transpose ([]     : xss) = transpose xss+transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) :+   transpose (xs : [t | (h:t) <- xss])++partition               :: (a -> Bool) -> [a] -> ([a],[a])+partition p xs          =  foldr select ([],[]) xs+                           where select x (ts,fs) | p x       = (x:ts,fs)+                                                  | otherwise = (ts, x:fs)++-- group splits its list argument into a list of lists of equal, adjacent+-- elements.  e.g.,+-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]+group                   :: Eq a => [a] -> [[a]]+group                   =  groupBy (==)++groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]+groupBy eq []           =  []+groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs+                           where (ys,zs) = span (eq x) xs++-- inits xs returns the list of initial segments of xs, shortest first.+-- e.g., inits "abc" == ["","a","ab","abc"]+inits                   :: [a] -> [[a]]+inits []                =  [[]]+inits (x:xs)            =  [[]] ++ map (x:) (inits xs)++-- tails xs returns the list of all final segments of xs, longest first.+-- e.g., tails "abc" == ["abc", "bc", "c",""]+tails                   :: [a] -> [[a]]+tails []                =  [[]]+tails xxs@(_:xs)        =  xxs : tails xs++isPrefixOf               :: Eq a => [a] -> [a] -> Bool+isPrefixOf []     _      =  True+isPrefixOf _      []     =  False+isPrefixOf (x:xs) (y:ys) =  x == y && isPrefixOf xs ys++isSuffixOf              :: Eq a => [a] -> [a] -> Bool+isSuffixOf x y          =  reverse x `isPrefixOf` reverse y++mapAccumL               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccumL f s []        =  (s, [])+mapAccumL f s (x:xs)    =  (s'',y:ys)+                           where (s', y ) = f s x+                                 (s'',ys) = mapAccumL f s' xs++mapAccumR               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccumR f s []        =  (s, [])+mapAccumR f s (x:xs)    =  (s'', y:ys)+                           where (s'',y ) = f s' x+                                 (s', ys) = mapAccumR f s xs++unfoldr :: (b -> Maybe (a,b)) -> b -> [a]+unfoldr f b = case f b of+	        Nothing    -> []+		Just (a,b) -> a : unfoldr f b++sort                    :: (Ord a) => [a] -> [a]+sort                    =  sortBy compare++sortBy                  :: (a -> a -> Ordering) -> [a] -> [a]+sortBy cmp              =  foldr (insertBy cmp) []++insert :: (Ord a) => a -> [a] -> [a]+insert = insertBy compare++insertBy                :: (a -> a -> Ordering) -> a -> [a] -> [a]+insertBy cmp x []       =  [x]+insertBy cmp x ys@(y:ys')+                        =  case cmp x y of+                                GT -> y : insertBy cmp x ys'+                                _  -> x : ys++maximumBy               :: (a -> a -> Ordering) -> [a] -> a+maximumBy cmp []        =  error "List.maximumBy: empty list"+maximumBy cmp xs        =  foldl1 max xs+                        where+                           max x y = case cmp x y of+                                        GT -> x+                                        _  -> y++minimumBy               :: (a -> a -> Ordering) -> [a] -> a+minimumBy cmp []        =  error "List.minimumBy: empty list"+minimumBy cmp xs        =  foldl1 min xs+                        where+                           min x y = case cmp x y of+                                        GT -> y+                                        _  -> x++--genericLength           :: (Integral a) => [b] -> a+genericLength []        =  0+genericLength (x:xs)    =  1 + genericLength xs++--genericTake             :: (Integral a) => a -> [b] -> [b]+genericTake _ []        =  []+genericTake 0 _         =  []+genericTake n (x:xs)+   | n > 0              =  x : genericTake (n-1) xs+   | otherwise          =  error "List.genericTake: negative argument"++--genericDrop             :: (Integral a) => a -> [b] -> [b]+genericDrop 0 xs        =  xs+genericDrop _ []        =  []+genericDrop n (_:xs)+   | n > 0              =  genericDrop (n-1) xs+   | otherwise          =  error "List.genericDrop: negative argument"++--genericSplitAt          :: (Integral a) => a -> [b] -> ([b],[b])+genericSplitAt 0 xs     =  ([],xs)+genericSplitAt _ []     =  ([],[])+genericSplitAt n (x:xs)+   | n > 0              =  (x:xs',xs'')+   | otherwise          =  error "List.genericSplitAt: negative argument"+       where (xs',xs'') =  genericSplitAt (n-1) xs++--genericIndex            :: (Integral a) => [b] -> a -> b+genericIndex (x:_)  0   =  x+genericIndex (x:xs) n+        | n > 0         =  genericIndex xs (n-1)+        | otherwise     =  error "List.genericIndex: negative argument"+genericIndex _ _        =  error "List.genericIndex: index too large"++--genericReplicate        :: (Integral a) => a -> b -> [b]+genericReplicate n x    =  genericTake n (repeat x)++zip4                    :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]+zip4                    =  zipWith4 (,,,)++zip5                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]+zip5                    =  zipWith5 (,,,,)++zip6                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [(a,b,c,d,e,f)]+zip6                    =  zipWith6 (,,,,,)++zip7                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [g] -> [(a,b,c,d,e,f,g)]+zip7                    =  zipWith7 (,,,,,,)++zipWith4                :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]+zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)+                        =  z a b c d : zipWith4 z as bs cs ds+zipWith4 _ _ _ _ _      =  []++zipWith5                :: (a->b->c->d->e->f) ->+                           [a]->[b]->[c]->[d]->[e]->[f]+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)+                        =  z a b c d e : zipWith5 z as bs cs ds es+zipWith5 _ _ _ _ _ _    =  []++zipWith6                :: (a->b->c->d->e->f->g) ->+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]+zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)+                        =  z a b c d e f : zipWith6 z as bs cs ds es fs+zipWith6 _ _ _ _ _ _ _  =  []++zipWith7                :: (a->b->c->d->e->f->g->h) ->+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]+zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)+                   =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs+zipWith7 _ _ _ _ _ _ _ _ = []++unzip4                  :: [(a,b,c,d)] -> ([a],[b],[c],[d])+unzip4                  =  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->+                                        (a:as,b:bs,c:cs,d:ds))+                                 ([],[],[],[])++unzip5                  :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])+unzip5                  =  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->+                                        (a:as,b:bs,c:cs,d:ds,e:es))+                                 ([],[],[],[],[])++unzip6                  :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])+unzip6                  =  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->+                                        (a:as,b:bs,c:cs,d:ds,e:es,f:fs))+                                 ([],[],[],[],[],[])++unzip7          :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])+unzip7          =  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->+                                (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))+                         ([],[],[],[],[],[],[])
+ tools/base/tests/HaskellLibraries/Locale.hs view
@@ -0,0 +1,32 @@+module Locale(TimeLocale(..), defaultTimeLocale) where+import Prelude++data TimeLocale = TimeLocale {+        wDays  :: [(String, String)],   -- full and abbreviated week days+        months :: [(String, String)],   -- full and abbreviated months+        amPm   :: (String, String),     -- AM/PM symbols+        dateTimeFmt, dateFmt,           -- formatting strings+          timeFmt, time12Fmt :: String     +        } --deriving (Eq, Ord, Show)++defaultTimeLocale :: TimeLocale +defaultTimeLocale =  TimeLocale { +        wDays  = [("Sunday",   "Sun"),  ("Monday",    "Mon"),   +                  ("Tuesday",  "Tue"),  ("Wednesday", "Wed"), +                  ("Thursday", "Thu"),  ("Friday",    "Fri"), +                  ("Saturday", "Sat")],++        months = [("January",   "Jan"), ("February",  "Feb"),+                  ("March",     "Mar"), ("April",     "Apr"),+                  ("May",       "May"), ("June",      "Jun"),+                  ("July",      "Jul"), ("August",    "Aug"),+                  ("September", "Sep"), ("October",   "Oct"),+                  ("November",  "Nov"), ("December",  "Dec")],++        amPm = ("AM", "PM"),+        dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y",+        dateFmt = "%m/%d/%y",+        timeFmt = "%H:%M:%S",+        time12Fmt = "%I:%M:%S %p"+        }+
+ tools/base/tests/HaskellLibraries/Maybe.hs view
@@ -0,0 +1,40 @@+module Maybe(+    isJust, isNothing,+    fromJust, fromMaybe, listToMaybe, maybeToList,+    catMaybes, mapMaybe,++    -- ...and what the Prelude exports+    Maybe(Nothing, Just),+    maybe+  ) where+import Prelude --(Maybe(..))++isJust                 :: Maybe a -> Bool+isJust (Just a)        =  True+isJust Nothing         =  False++isNothing        :: Maybe a -> Bool+isNothing        =  not . isJust++fromJust               :: Maybe a -> a+fromJust (Just a)      =  a+fromJust Nothing       =  error "Maybe.fromJust: Nothing"++fromMaybe              :: a -> Maybe a -> a+fromMaybe d Nothing    =  d+fromMaybe d (Just a)   =  a++maybeToList            :: Maybe a -> [a]+maybeToList Nothing    =  []+maybeToList (Just a)   =  [a]++listToMaybe            :: [a] -> Maybe a+listToMaybe []         =  Nothing+listToMaybe (a:_)      =  Just a+ +catMaybes              :: [Maybe a] -> [a]+catMaybes ms           =  [ m | Just m <- ms ]++mapMaybe               :: (a -> Maybe b) -> [a] -> [b]+mapMaybe f             =  catMaybes . map f+
+ tools/base/tests/HaskellLibraries/Monad.hs view
@@ -0,0 +1,95 @@+module Monad {-(+    MonadPlus(mzero, mplus),+    join, guard, when, unless, ap,+    msum,+    filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM, +    liftM, liftM2, liftM3, liftM4, liftM5,++    -- ...and what the Prelude exports+    Monad((>>=), (>>), return, fail),+    Functor(fmap),+    mapM, mapM_, sequence, sequence_, (=<<), +    ) -} where+import Prelude++-- The MonadPlus class definition++class  (Monad m) => MonadPlus m  where+    mzero  :: m a+    mplus  :: m a -> m a -> m a+++-- Instances of MonadPlus++instance  MonadPlus Maybe  where+    mzero                 = Nothing++    Nothing `mplus` ys    =  ys+    xs      `mplus` ys    =  xs++instance  MonadPlus []  where+    mzero =  []+    mplus = (++)+++-- Functions    +++msum  :: MonadPlus m => [m a] -> m a+msum xs  =  foldr mplus mzero xs++join             :: (Monad m) => m (m a) -> m a+join x           =  x >>= id++when             :: (Monad m) => Bool -> m () -> m ()+when p s         =  if p then s else return ()++unless           :: (Monad m) => Bool -> m () -> m ()+unless p s       =  when (not p) s++ap               :: (Monad m) => m (a -> b) -> m a -> m b+ap               =  liftM2 ($)++--guard            :: MonadPlus m => Bool -> m ()+guard p          =  if p then return () else mzero++mapAndUnzipM     :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])+mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip++zipWithM         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+zipWithM f xs ys =  sequence (zipWith f xs ys)++zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)++foldM            :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a+foldM f a []     =  return a+foldM f a (x:xs) =  f a x >>= \ y -> foldM f y xs++filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]+filterM p []     = return []+filterM p (x:xs) = do { b  <- p x;+			ys <- filterM p xs; +			return (if b then (x:ys) else ys)+		   }++liftM            :: (Monad m) => (a -> b) -> (m a -> m b)+liftM f          =  \a -> do { a' <- a; return (f a') }++liftM2           :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)+liftM2 f         =  \a b -> do { a' <- a; b' <- b; return (f a' b') }++liftM3           :: (Monad m) => (a -> b -> c -> d) ->+                                 (m a -> m b -> m c -> m d)+liftM3 f         =  \a b c -> do { a' <- a; b' <- b; c' <- c;+				   return (f a' b' c') }++liftM4           :: (Monad m) => (a -> b -> c -> d -> e) ->+                                 (m a -> m b -> m c -> m d -> m e)+liftM4 f         =  \a b c d -> do { a' <- a; b' <- b; c' <- c; d' <- d;+				     return (f a' b' c' d') }++liftM5           :: (Monad m) => (a -> b -> c -> d -> e -> f) ->+                                 (m a -> m b -> m c -> m d -> m e -> m f)+liftM5 f         =  \a b c d e -> do { a' <- a; b' <- b; c' <- c; d' <- d;+				       e' <- e; return (f a' b' c' d' e') }
+ tools/base/tests/HaskellLibraries/Numeric.hs view
@@ -0,0 +1,309 @@+module Numeric(fromRat,+               showSigned, showInt,+               readSigned, readInt,+               readDec, readOct, readHex,+               floatToDigits,+               showEFloat, showFFloat, showGFloat, showFloat, +               readFloat, lexDigits) where++import Prelude+import Char+import Ratio+import Array++default()++-- This converts a rational to a floating.  This should be used in the+-- Fractional instances of Float and Double.++fromRat :: (RealFloat a) => Rational -> a+fromRat x = +    if x == 0 then encodeFloat 0 0              -- Handle exceptional cases+    else if x < 0 then - fromRat' (-x)          -- first.+    else fromRat' x++-- Conversion process:+-- Scale the rational number by the RealFloat base until+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).+-- Then round the rational to an Integer and encode it with the exponent+-- that we got from the scaling.+-- To speed up the scaling process we compute the log2 of the number to get+-- a first guess of the exponent.+fromRat' :: (RealFloat a) => Rational -> a+fromRat' x = undefined{-r+  where b = floatRadix r+        p = floatDigits r+        (minExp0, _) = floatRange r+        minExp = minExp0 - p            -- the real minimum exponent+        xMin = toRational (expt b (p-1))+        xMax = toRational (expt b p)+        p0 = (integerLogBase b (numerator x) -+              integerLogBase b (denominator x) - p) `max` minExp+        f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1+        (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)+        r = encodeFloat (round x') p'-}++-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.+scaleRat :: Rational -> Int -> Rational -> Rational -> +             Int -> Rational -> (Rational, Int)+scaleRat b minExp xMin xMax p x =+    if p <= minExp then+        (x, p)+    else if x >= xMax then+        scaleRat b minExp xMin xMax (p+1) (x/b)+    else if x < xMin  then+        scaleRat b minExp xMin xMax (p-1) (x*b)+    else+        (x, p)++-- Exponentiation with a cache for the most common numbers.+minExpt = 0::Int+maxExpt = 1100::Int+expt :: Integer -> Int -> Integer+expt base n =+    if base == 2 && n >= minExpt && n <= maxExpt then+        expts!n+    else+        base^n++expts :: Array Int Integer+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]++-- Compute the (floor of the) log of i in base b.+-- Simplest way would be just divide i by b until it's smaller then b,+-- but that would be very slow!  We are just slightly more clever.+integerLogBase :: Integer -> Integer -> Int+integerLogBase b i =+     if i < b then+        0+     else+        -- Try squaring the base first to cut down the number of divisions.+        let l = 2 * integerLogBase (b*b) i+            doDiv :: Integer -> Int -> Int+            doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)+        in  doDiv (i `div` (b^l)) l+++-- Misc utilities to show integers and floats ++showSigned    :: Real a => (a -> ShowS) -> Int -> a -> ShowS+showSigned showPos p x | x < 0 = showParen (p > 6)+                                           (showChar '-' . showPos (-x))+                       | otherwise = showPos x++-- showInt is used for positive numbers only+showInt    :: Integral a => a -> ShowS+--showInt    :: Integral a => a -> String->String -- for hs2alfa+showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers"+            | otherwise =+              let (n',d) = quotRem n 10+                  r'     = chr (fromEnum '0' + fromIntegral d) : r+              in  if n' == 0 then r' else showInt n' r'+++readSigned :: (Real a) => ReadS a -> ReadS a+readSigned readPos = readParen False read'+                     where read' r  = read'' r +++                                      [(-x,t) | ("-",s) <- lex r,+                                                (x,t)   <- read'' s]+                           read'' r = [(n,s)  | (str,s) <- lex r,+                                                (n,"")  <- readPos str]+++-- readInt reads a string of digits using an arbitrary base.  +-- Leading minus signs must be handled elsewhere.++readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a+readInt radix isDig digToInt s =+   [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)+          | (ds,r) <- nonnull isDig s ]++-- Unsigned readers for various bases+readDec, readOct, readHex :: (Integral a) => ReadS a+readDec = readInt 10 isDigit digitToInt+readOct = readInt  8 isOctDigit digitToInt+readHex = readInt 16 isHexDigit digitToInt++showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS+showFloat      :: (RealFloat a) => a -> ShowS++showEFloat d x =  showString (formatRealFloat FFExponent d x)+showFFloat d x =  showString (formatRealFloat FFFixed d x)+showGFloat d x =  showString (formatRealFloat FFGeneric d x)+showFloat      =  showGFloat Nothing ++-- These are the format types.  This type is not exported.++data FFFormat = FFExponent | FFFixed | FFGeneric++formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String+formatRealFloat fmt decs x = s+  where base = 10+        s = if isNaN x then +                "NaN"+            else if isInfinite x then +                if x < 0 then "-Infinity" else "Infinity"+            else if x < 0 || isNegativeZero x then +                '-' : doFmt fmt (floatToDigits (toInteger base) (-x))+            else +                doFmt fmt (floatToDigits (toInteger base) x)+        doFmt fmt (is, e) =+            let ds = map intToDigit is+            in  case fmt of+                FFGeneric -> +                    doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)+                          (is, e)+--{ -+                FFExponent ->+                    case decs of+                    Nothing ->+                        case ds of+                         ['0'] -> "0.0e0"+                         [d]   -> d : ".0e" ++ show (e-1)+                         d:ds  -> d : '.' : ds ++ 'e':show (e-1)+                    Just dec ->+                        let dec' = max dec 1 in+                        case is of+                         [0] -> '0':'.':take dec' (repeat '0') ++ "e0"+                         _ ->+                          let (ei, is') = roundTo base (dec'+1) is+                              d:ds = map intToDigit+                                         (if ei > 0 then init is' else is')+                          in d:'.':ds  ++ "e" ++ show (e-1+ei)+                FFFixed ->+                    case decs of+                    Nothing ->+                        let f 0 s ds = mk0 s ++ "." ++ mk0 ds+                            f n s "" = f (n-1) (s++"0") ""+                            f n s (d:ds) = f (n-1) (s++[d]) ds+                            mk0 "" = "0"+                            mk0 s = s+                        in  f e "" ds+                    Just dec ->+                        let dec' = max dec 0 in+                        if e >= 0 then+                            let (ei, is') = roundTo base (dec' + e) is+                                (ls, rs) = splitAt (e+ei) (map intToDigit is')+                            in  (if null ls then "0" else ls) ++ +                                (if null rs then "" else '.' : rs)+                        else+                            let (ei, is') = roundTo base dec'+                                              (replicate (-e) 0 ++ is)+                                d : ds = map intToDigit+                                            (if ei > 0 then is' else 0:is')+                            in  d : '.' : ds+--}++roundTo :: Int -> Int -> [Int] -> (Int, [Int])+roundTo base d is = case f d is of+		     (x, is)+			 | x==0 -> (0, is)+			 | x==1 -> (1, 1 : is)+  where b2 = base `div` 2+        f n [] = (0, replicate n 0)+        f 0 (i:_) = (if i >= b2 then 1 else 0, [])+        f d (i:is) = +            let (c, ds) = f (d-1) is+                i' = c + i+            in  if i' == base then (1, 0:ds) else (0, i':ds)++--+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"+-- by R.G. Burger and R. K. Dybvig, in PLDI 96.+-- This version uses a much slower logarithm estimator.  It should be improved.++-- This function returns a list of digits (Ints in [0..base-1]) and an+-- exponent.++floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)++floatToDigits _ 0 = ([0], 0)+floatToDigits base x =+    let (f0, e0) = decodeFloat x+        (minExp0, _) = floatRange x+        p = floatDigits x+        b = floatRadix x+        minExp = minExp0 - p            -- the real minimum exponent+        -- Haskell requires that f be adjusted so denormalized numbers+        -- will have an impossibly low exponent.  Adjust for this.+        (f, e) = let n = minExp - e0+                 in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)++        (r, s, mUp, mDn) =+           if e >= 0 then+               let be = b^e in+               if f == b^(p-1) then+                   (f*be*b*2, 2*b, be*b, b)+               else+                   (f*be*2, 2, be, be)+           else+               if e > minExp && f == b^(p-1) then+                   (f*b*2, b^(-e+1)*2, b, 1)+               else+                   (f*2, b^(-e)*2, 1, 1)+        k = +            let k0 =+                    if b==2 && base==10 then+                        -- logBase 10 2 is slightly bigger than 3/10 so+                        -- the following will err on the low side.  Ignoring+                        -- the fraction will make it err even more.+                        -- Haskell promises that p-1 <= logBase b f < p.+                        (p - 1 + e0) * 3 `div` 10+                    else+                        ceiling ((log (fromInteger (f+1)::Double) + +                                 fromIntegral e * log (fromInteger b)) / +                                  log (fromInteger base))+                fixup n =+                    if n >= 0 then+                        if r + mUp <= expt base n * s then n else fixup (n+1)+                    else+                        if expt base (-n) * (r + mUp) <= s then n+                                                           else fixup (n+1)+            in  fixup k0++        gen ds rn sN mUpN mDnN =+            let (dn, rn') = (rn * base) `divMod` sN+                mUpN' = mUpN * base+                mDnN' = mDnN * base+            in  case (rn' < mDnN', rn' + mUpN' > sN) of+                (True,  False) -> dn : ds+                (False, True)  -> dn+1 : ds+                (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds+                (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'+        rds =+            if k >= 0 then+                gen [] r (s * expt base k) mUp mDn+            else+                let bk = expt base (-k)+                in  gen [] (r * bk) s (mUp * bk) (mDn * bk)+    in  (map fromIntegral (reverse rds), k)++++-- This floating point reader uses a less restrictive syntax for floating+-- point than the Haskell lexer.  The `.' is optional.++readFloat     :: (RealFloat a) => ReadS a+readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,+                                                       (k,t)   <- readExp s]+                 where readFix r = [(read (ds++ds'), length ds', t)+                                        | (ds,d) <- lexDigits r,+                                          (ds',t) <- lexFrac d ]++                       lexFrac ('.':ds) = lexDigits ds+                       lexFrac s        = [("",s)]        ++                       readExp (e:s) | e `elem` "eE" = readExp' s+                       readExp s                     = [(0,s)]++                       readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]+                       readExp' ('+':s) = readDec s+                       readExp' s       = readDec s++lexDigits        :: ReadS String +lexDigits        =  nonnull isDigit++nonnull          :: (Char -> Bool) -> ReadS String+nonnull p s      =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
+ tools/base/tests/HaskellLibraries/Prelude.hs view
@@ -0,0 +1,686 @@+module Prelude (+    module PreludeList, module PreludeText, module PreludeIO,+    module Prelude{-+    Bool(False, True),+    Maybe(Nothing, Just),+    Either(Left, Right),+    Ordering(LT, EQ, GT),+    Char, String, Int, Integer, Float, Double, Rational, IO,++--      These built-in types are defined in the Prelude, but+--      are denoted by built-in syntax, and cannot legally+--      appear in an export list.+--  List type:+     []((:), [])+--  Tuple types: (,), (,,), etc.+--  Trivial type: ()+--  Functions: (->)++    Eq((==), (/=)),+    Ord(compare, (<), (<=), (>=), (>), max, min),+    Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,+         enumFromTo, enumFromThenTo),+    Bounded(minBound, maxBound),+    Num((+), (-), (*), negate, abs, signum, fromInteger),+    Real(toRational),+    Integral(quot, rem, div, mod, quotRem, divMod, toInteger),+    Fractional((/), recip, fromRational),+    Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,+             asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),+    RealFrac(properFraction, truncate, round, ceiling, floor),+    RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,+              encodeFloat, exponent, significand, scaleFloat, isNaN,+              isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2),+    Monad((>>=), (>>), return, fail),+    Functor(fmap),+    mapM, mapM_, sequence, sequence_, (=<<),+    maybe, either,+    (&&), (||), not, otherwise,+    subtract, even, odd, gcd, lcm, (^), (^^),+    fromIntegral, realToFrac,+    fst, snd, curry, uncurry, id, const, (.), flip, ($), until,+    asTypeOf, error, undefined,+    seq, ($!)-}+  ) where++import PreludeBuiltin  -- Contains all `prim' values+import PreludeList+import PreludeText+import PreludeIO(FilePath, IOError, ioError, userError, catch,+		 putChar, putStr, putStrLn, print,+		 getChar, getLine, getContents, interact,+		 readFile, writeFile, appendFile, readIO, readLn)+import Ratio( Ratio )+import Ix++type Rational =  Ratio Integer -- the type checker refers to Prelude.Rational!!!++infixr 9  .+infixr 8  ^, ^^, **+infixl 7  *, /, `quot`, `rem`, `div`, `mod`+infixl 6  +, -++-- The (:) operator is built-in syntax, and cannot legally be given+-- a fixity declaration; but its fixity is given by:+infixr 5  :++infix  4  ==, /=, <, <=, >=, >+infixr 3  &&+infixr 2  ||+infixl 1  >>, >>=+infixr 1  =<<+infixr 0  $, $!, `seq`++-- Standard types, classes, instances and related functions++-- Equality and Ordered classes++class  Eq a  where+    (==), (/=)       :: a -> a -> Bool++        -- Minimal complete definition:+        --      (==) or (/=)+    x /= y           =  not (x == y)+    x == y           =  not (x /= y)++class  (Eq a) => Ord a  where+    compare              :: a -> a -> Ordering+    (<), (<=), (>=), (>) :: a -> a -> Bool+    max, min             :: a -> a -> a++        -- Minimal complete definition:+        --      (<=) or compare+        -- Using compare can be more efficient for complex types.+    compare x y+         | x == y    =  EQ+         | x <= y    =  LT+         | otherwise =  GT++    x <= y           =  compare x y /= GT+    x <  y           =  compare x y == LT+    x >= y           =  compare x y /= LT+    x >  y           =  compare x y == GT++-- note that (min x y, max x y) = (x,y) or (y,x)+    max x y+         | x <= y    =  y+         | otherwise =  x+    min x y+         | x <= y    =  x+         | otherwise =  y++-- Enumeration and Bounded classes++class  Enum a  where+    succ, pred       :: a -> a+    toEnum           :: Int -> a+    fromEnum         :: a -> Int+    enumFrom         :: a -> [a]             -- [n..]+    enumFromThen     :: a -> a -> [a]        -- [n,n'..]+    enumFromTo       :: a -> a -> [a]        -- [n..m]+    enumFromThenTo   :: a -> a -> a -> [a]   -- [n,n'..m]++        -- Minimal complete definition:+        --      toEnum, fromEnum+--+-- NOTE: these default methods only make sense for types+--   that map injectively into Int using fromEnum+--  and toEnum.+    succ             =  toEnum . (+1) . fromEnum+    pred             =  toEnum . (subtract 1) . fromEnum+    enumFrom x       =  map toEnum [fromEnum x ..]+    enumFromTo x y   =  map toEnum [fromEnum x .. fromEnum y]+    enumFromThen x y =  map toEnum [fromEnum x, fromEnum y ..]+    enumFromThenTo x y z =+                        map toEnum [fromEnum x, fromEnum y .. fromEnum z]++class  Bounded a  where+    minBound         :: a+    maxBound         :: a++-- Numeric classes++class  (Eq a, Show a) => Num a  where+    (+), (-), (*)    :: a -> a -> a+    negate           :: a -> a+    abs, signum      :: a -> a+    fromInteger      :: Integer -> a++        -- Minimal complete definition:+        --      All, except negate or (-)+    x - y            =  x + negate y+    negate x         =  0 - x++class  (Num a, Ord a) => Real a  where+    toRational       ::  a -> Rational++class  (Real a, Enum a) => Integral a  where+    quot, rem        :: a -> a -> a+    div, mod         :: a -> a -> a+    quotRem, divMod  :: a -> a -> (a,a)+    toInteger        :: a -> Integer++        -- Minimal complete definition:+        --      quotRem, toInteger+    n `quot` d       =  q  where (q,r) = quotRem n d+    n `rem` d        =  r  where (q,r) = quotRem n d+    n `div` d        =  q  where (q,r) = divMod n d+    n `mod` d        =  r  where (q,r) = divMod n d+    divMod n d       =  if signum r == - signum d then (q-1, r+d) else qr+                        where qr@(q,r) = quotRem n d++class  (Num a) => Fractional a  where+    (/)              :: a -> a -> a+    recip            :: a -> a+    fromRational     :: Rational -> a++        -- Minimal complete definition:+        --      fromRational and (recip or (/))+    recip x          =  1 / x+    x / y            =  x * recip y++class  (Fractional a) => Floating a  where+    pi                  :: a+    exp, log, sqrt      :: a -> a+    (**), logBase       :: a -> a -> a+    sin, cos, tan       :: a -> a+    asin, acos, atan    :: a -> a+    sinh, cosh, tanh    :: a -> a+    asinh, acosh, atanh :: a -> a++        -- Minimal complete definition:+        --      pi, exp, log, sin, cos, sinh, cosh+        --      asin, acos, atan+        --      asinh, acosh, atanh+    x ** y           =  exp (log x * y)+    logBase x y      =  log y / log x+    sqrt x           =  x ** 0.5+    tan  x           =  sin  x / cos  x+    tanh x           =  sinh x / cosh x++class  (Real a, Fractional a) => RealFrac a  where+    properFraction   :: (Integral b) => a -> (b,a)+    truncate, round  :: (Integral b) => a -> b+    ceiling, floor   :: (Integral b) => a -> b++        -- Minimal complete definition:+        --      properFraction+    truncate x       =  m  where (m,_) = properFraction x++    round x          =  let (n,r) = properFraction x+                            m     = if r < 0 then n - 1 else n + 1+                          in case signum (abs r - 0.5) of+                                -1 -> n+                                0  -> if even n then n else m+                                1  -> m++    ceiling x        =  if r > 0 then n + 1 else n+                        where (n,r) = properFraction x++    floor x          =  if r < 0 then n - 1 else n+                        where (n,r) = properFraction x++class  (RealFrac a, Floating a) => RealFloat a  where+    floatRadix       :: a -> Integer+    floatDigits      :: a -> Int+    floatRange       :: a -> (Int,Int)+    decodeFloat      :: a -> (Integer,Int)+    encodeFloat      :: Integer -> Int -> a+    exponent         :: a -> Int+    significand      :: a -> a+    scaleFloat       :: Int -> a -> a+    isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE+                     :: a -> Bool+    atan2            :: a -> a -> a++        -- Minimal complete definition:+        --      All except exponent, significand,+        --                 scaleFloat, atan2+    exponent x       =  if m == 0 then 0 else n + floatDigits x+                        where (m,n) = decodeFloat x++    significand x    =  encodeFloat m (- floatDigits x)+                        where (m,_) = decodeFloat x++    scaleFloat k x   =  encodeFloat m (n+k)+                        where (m,n) = decodeFloat x++    atan2 y x+      | x>0           =  atan (y/x)+      | x==0 && y>0   =  pi/2+      | x<0  && y>0   =  pi + atan (y/x)+      |(x<=0 && y<0)  ||+       (x<0 && isNegativeZero y) ||+       (isNegativeZero x && isNegativeZero y)+                      = -atan2 (-y) x+      | y==0 && (x<0 || isNegativeZero x)+                      =  pi    -- must be after the previous test on zero y+      | x==0 && y==0  =  y     -- must be after the other double zero tests+      | otherwise     =  x + y -- x or y is a NaN, return a NaN (via +)++-- Numeric functions++subtract         :: (Num a) => a -> a -> a+subtract         =  flip (-)++even, odd        :: (Integral a) => a -> Bool+even n           =  n `rem` 2 == 0+odd n            =  not (even n)++gcd              :: (Integral a) => a -> a -> a+gcd 0 0          =  error "Prelude.gcd: gcd 0 0 is undefined"+gcd x y          =  gcd' (abs x) (abs y)+                    where gcd' x 0  =  x+                          gcd' x y  =  gcd' y (x `rem` y)++lcm              :: (Integral a) => a -> a -> a+lcm _ 0          =  0+lcm 0 _          =  0+lcm x y          =  abs ((x `quot` (gcd x y)) * y)++(^)              :: (Num a, Integral b) => a -> b -> a+x ^ 0            =  1+x ^ n | n > 0    =  f x (n-1) x+                    where f _ 0 y = y+                          f x n y = if n==0 then y else g x n  where+                                    g x n | even n  = g (x*x) (n `quot` 2)+                                          | otherwise = f x (n-1) (x*y)+_ ^ _            = error "Prelude.^: negative exponent"++(^^)             :: (Fractional a, Integral b) => a -> b -> a+x ^^ n           =  if n >= 0 then x^n else recip (x^(-n))++fromIntegral     :: (Integral a, Num b) => a -> b+fromIntegral     =  fromInteger . toInteger++realToFrac     :: (Real a, Fractional b) => a -> b+realToFrac      =  fromRational . toRational++-- Monadic classes++class  Functor f  where+    fmap              :: (a -> b) -> f a -> f b++class  Monad m  where+    (>>=)  :: m a -> (a -> m b) -> m b+    (>>)   :: m a -> m b -> m b+    return :: a -> m a+    fail   :: String -> m a++        -- Minimal complete definition:+        --      (>>=), return+    m >> k  =  m >>= \ x -> k+    fail s  = error s++sequence       :: Monad m => [m a] -> m [a]+sequence       =  foldr mcons (return [])+                    where mcons p q = p >>= \x -> q >>= \y -> return (x:y)++sequence_      :: Monad m => [m a] -> m ()+sequence_      =  foldr (>>) (return ())++-- The xxxM functions take list arguments, but lift the function or+-- list element to a monad type++mapM             :: Monad m => (a -> m b) -> [a] -> m [b]+mapM f as        =  sequence (map f as)++mapM_            :: Monad m => (a -> m b) -> [a] -> m ()+mapM_ f as       =  sequence_ (map f as)++(=<<)            :: Monad m => (a -> m b) -> m a -> m b+f =<< x          =  x >>= f++-- Trivial type++data  ()  =  ()  deriving (Eq, Ord, Enum, Bounded, Ix)++-- Function type++--data a -> b  -- No constructor for functions is exported.+data (->) a b++-- identity function++id               :: a -> a+id x             =  x++-- constant function++const            :: a -> b -> a+const x _        =  x++-- function composition++(.)              :: (b -> c) -> (a -> b) -> a -> c+f . g            =  \ x -> f (g x)++-- flip f  takes its (first) two arguments in the reverse order of f.++flip             :: (a -> b -> c) -> b -> a -> c+flip f x y       =  f y x++seq = primSeq++-- right-associating infix application operators+-- (useful in continuation-passing style)++($), ($!) :: (a -> b) -> a -> b+f $  x    =  f x+f $! x    =  x `seq` f x++-- Boolean type++data  Bool  =  False | True    deriving (Eq, Ord, Enum, Read, Show, Bounded, Ix)++-- Boolean functions++(&&), (||)       :: Bool -> Bool -> Bool+True  && x       =  x+False && _       =  False+True  || _       =  True+False || x       =  x+++not              :: Bool -> Bool+not True         =  False+not False        =  True++otherwise        :: Bool+otherwise        =  True++-- Character type++data Char -- = ... 'a' | 'b' ... -- 2^16 unicode values++instance  Eq Char  where+    c == c'          =  fromEnum c == fromEnum c'++instance  Ord Char  where+    c <= c'          =  fromEnum c <= fromEnum c'++instance  Enum Char  where+    toEnum            = primIntToChar+    fromEnum          = primCharToInt+    enumFrom c        = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]+    enumFromThen c c' = map toEnum [fromEnum c, fromEnum c' .. fromEnum lastChar]+                      where lastChar :: Char+                            lastChar | c' < c    = minBound+                                     | otherwise = maxBound++instance  Bounded Char  where+    minBound            =  '\0'+    maxBound            =  primUnicodeMaxChar++type  String = [Char]++-- Maybe type++data  Maybe a  =  Nothing | Just a      deriving (Eq, Ord, Read, Show)++maybe              :: b -> (a -> b) -> Maybe a -> b+maybe n f Nothing  =  n+maybe n f (Just x) =  f x++instance  Functor Maybe  where+    fmap f Nothing    =  Nothing+    fmap f (Just x)   =  Just (f x)+++instance  Monad Maybe  where+    (Just x) >>= k   =  k x+    Nothing  >>= k   =  Nothing+    return           =  Just+    fail s           =  Nothing++-- Either type++data  Either a b  =  Left a | Right b   deriving (Eq, Ord, Read, Show)++either               :: (a -> c) -> (b -> c) -> Either a b -> c+either f g (Left x)  =  f x+either f g (Right y) =  g y++-- IO type++data  IO a -- abstract++instance  Functor IO where+   fmap f x           =  x >>= (return . f)++instance Monad IO where+   (>>=)  = undefined -- ...+   return = undefined -- ...+   fail s = ioError (userError s)++-- Ordering type++data  Ordering  =  LT | EQ | GT+          deriving (Eq, Ord, Enum, Read, Show, Bounded, Ix)+--instance Eq Ordering++-- For use in derived Ord instances:+lexOrder EQ o = o+lexOrder o  _ = o++-- Standard numeric types.  The data declarations for these types cannot+-- be expressed directly in Haskell since the constructor lists would be+-- far too large.++data  Int  -- =  minBound ... -1 | 0 | 1 ... maxBound++instance  Eq       Int  where (==) = primIntEq+instance  Ord      Int  where (<=) = primIntLte+instance  Num      Int  where+  (+) = primIntAdd; (-) = primIntSub; (*) = primIntMul+  negate = primIntNegate; abs = primIntAbs; signum = primIntSignum+  fromInteger = primInteger2Int++instance  Real     Int  --where ...++instance  Integral Int  where+   toInteger = primInt2Integer+   n `quotRem` d = (n `primIntQuot` d,n `primIntRem` d)++instance  Enum     Int  where toEnum = id; fromEnum = id+  +instance  Bounded  Int  --where ...++data  Integer  -- =  ... -1 | 0 | 1 ...++instance  Eq       Integer  where (==) = primIntegerEq+instance  Ord      Integer  where (<=) = primIntegerLte+instance  Num      Integer  where+  (+) = primIntegerAdd; (-) = primIntegerSub; (*) = primIntegerMul+  negate = primIntegerNegate; abs = primIntegerAbs; signum = primIntegerSignum+  fromInteger = id++instance  Enum     Integer  where+  succ x = x+1+  pred x = x-1+  toEnum = primInt2Integer+  fromEnum = fromInteger+  enumFrom x = x:enumFrom (succ x)+  enumFromTo x y = if x<=y then x:enumFromTo (succ x) y else []++instance  Real     Integer  --where ...+instance  Integral Integer  where+   toInteger = id+   n `quotRem` d = (n `primIntegerQuot` d,n `primIntegerRem` d)++data  Float++instance  Eq         Float  where (==) = undefined -- avoid looping+instance  Ord        Float  where (<=) = undefined -- avoid looping+instance  Num        Float  --where ...+instance  Real       Float  --where ...+instance  Fractional Float  --where ...+instance  Floating   Float  --where ...+instance  RealFrac   Float  --where ...+instance  RealFloat  Float  --where ...++data  Double++instance  Eq         Double  where (==) = undefined -- avoid looping+instance  Ord        Double  where (<=) = undefined -- avoid looping+instance  Num        Double  --where ...+instance  Real       Double  --where ...+instance  Fractional Double  --where ...+instance  Floating   Double  --where ...+instance  RealFrac   Double  --where ...+instance  RealFloat  Double  --where ...++-- The Enum instances for Floats and Doubles are slightly unusual.+-- The `toEnum' function truncates numbers to Int.  The definitions+-- of enumFrom and enumFromThen allow floats to be used in arithmetic+-- series: [0,0.1 .. 0.95].  However, roundoff errors make these somewhat+-- dubious.  This example may have either 10 or 11 elements, depending on+-- how 0.1 is represented.++instance  Enum Float  where+    succ x           =  x+1+    pred x           =  x-1+    toEnum           =  fromIntegral+    fromEnum         =  fromInteger . truncate   -- may overflow+    enumFrom         =  numericEnumFrom+    enumFromThen     =  numericEnumFromThen+    enumFromTo       =  numericEnumFromTo+    enumFromThenTo   =  numericEnumFromThenTo++instance  Enum Double  where+    succ x           =  x+1+    pred x           =  x-1+    toEnum           =  fromIntegral+    fromEnum         =  fromInteger . truncate   -- may overflow+    enumFrom         =  numericEnumFrom+    enumFromThen     =  numericEnumFromThen+    enumFromTo       =  numericEnumFromTo+    enumFromThenTo   =  numericEnumFromThenTo+++numericEnumFrom         :: (Fractional a) => a -> [a]+numericEnumFromThen     :: (Fractional a) => a -> a -> [a]+numericEnumFromTo       :: (Fractional a, Ord a) => a -> a -> [a]+numericEnumFromThenTo   :: (Fractional a, Ord a) => a -> a -> a -> [a]++numericEnumFrom         =  iterate (+1)+numericEnumFromThen n m =  iterate (+(m-n)) n+numericEnumFromTo n m   =  takeWhile (<= m+1/2) (numericEnumFrom n)+numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')+                             where+                               p | n' > n    = (<= m + (n'-n)/2)+                                 | otherwise = (>= m + (n'-n)/2)++-- Lists++-- This data declaration is not legal Haskell+-- but it indicates the idea++data [a] =  [] | a : [a]  deriving (Eq, Ord)+--instance Eq a => Eq [a]+--instance Ord a => Ord [a]++instance Functor [] where+    fmap = map++instance  Monad []  where+    m >>= k          = concat (map k m)+    return x         = [x]+    fail s           = []++-- Tuples (supported upto size 15, as required by the Haskell 98 report)++data  (a,b)+   =  (,) a b+   deriving (Eq, Ord, Bounded) -- Show/Read in PreludeText, Ix in Ix+data  (a,b,c)+   =  (,,) a b c+   deriving (Eq, Ord, Bounded, Show, Read, Ix)+data  (a,b,c,d)+   =  (,,,) a b c d+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e)+   =  (,,,,) a b c d e+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f)+   =  (,,,,,) a b c d e f+  deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g)+   =  (,,,,,,) a b c d e f g+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h)+   =  (,,,,,,,) a b c d e f g h+  deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i)+   =  (,,,,,,,,) a b c d e f g h i+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j)+   =  (,,,,,,,,,) a b c d e f g h i j+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j,k)+   =  (,,,,,,,,,,) a b c d e f g h i j k+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j,k,l)+   =  (,,,,,,,,,,,) a b c d e f g h i j k l+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j,k,l,m)+   =  (,,,,,,,,,,,,) a b c d e f g h i j k l m+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j,k,l,m,n)+   =  (,,,,,,,,,,,,,) a b c d e f g h i j k l m n+   deriving (Eq, Ord, Bounded, Show, Read)+data  (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)+   =  (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o+   deriving (Eq, Ord, Bounded, Show, Read)+++-- component projections for pairs:+-- (NB: not provided for triples, quadruples, etc.)++fst              :: (a,b) -> a+fst (x,y)        =  x++snd              :: (a,b) -> b+snd (x,y)        =  y++-- curry converts an uncurried function to a curried function;+-- uncurry converts a curried function to a function on pairs.++curry            :: ((a, b) -> c) -> a -> b -> c+curry f x y      =  f (x, y)++uncurry          :: (a -> b -> c) -> ((a, b) -> c)+uncurry f p      =  f (fst p) (snd p)++-- Misc functions++-- until p f  yields the result of applying f until p holds.++until            :: (a -> Bool) -> (a -> a) -> a -> a+until p f x+     | p x       =  x+     | otherwise =  until p f (f x)++-- asTypeOf is a type-restricted version of const.  It is usually used+-- as an infix operator, and its typing forces its first argument+-- (which is usually overloaded) to have the same type as the second.++asTypeOf         :: a -> a -> a+asTypeOf         =  const++-- error stops execution and displays an error message++error            :: String -> a+error            =  primError++-- It is expected that compilers will recognize this and insert error+-- messages that are more appropriate to the context in which undefined+-- appears.++undefined        :: a+undefined        =  error "Prelude.undefined"++{-P:+-- For the P-Logic extension:+data Prop+-}
+ tools/base/tests/HaskellLibraries/PreludeBuiltin.hs view
@@ -0,0 +1,42 @@+module PreludeBuiltin where++foreign import primIntToChar   :: Int -> Char+foreign import primCharToInt   :: Char -> Int+foreign import primInteger2Int :: Integer -> Int+foreign import primUnicodeMaxChar :: Char -- = '\xffff'++foreign import primIntEq       :: Int -> Int -> Bool+foreign import primIntLte      :: Int -> Int -> Bool++foreign import primIntAdd      :: Int -> Int -> Int+foreign import primIntSub      :: Int -> Int -> Int+foreign import primIntMul      :: Int -> Int -> Int+foreign import primIntQuot     :: Int -> Int -> Int+foreign import primIntRem      :: Int -> Int -> Int+foreign import primIntNegate   :: Int -> Int+foreign import primIntAbs      :: Int -> Int+foreign import primIntSignum   :: Int -> Int++foreign import primError       :: String -> a++foreign import primSeq         :: a -> b -> b++primIntQuotRem x y = (x `primIntQuot` y,x `primIntRem` y)++primCharEq c c' = primCharToInt c `primIntEq` primCharToInt c'+primCharLte c c' = primCharToInt c `primIntLte` primCharToInt c'++foreign import primInteger2Int     :: Integer -> Int+foreign import primInt2Integer     :: Int -> Integer++foreign import primIntegerLte      :: Integer -> Integer -> Bool+foreign import primIntegerEq       :: Integer -> Integer -> Bool++foreign import primIntegerAdd      :: Integer -> Integer -> Integer+foreign import primIntegerSub      :: Integer -> Integer -> Integer+foreign import primIntegerMul      :: Integer -> Integer -> Integer+foreign import primIntegerQuot     :: Integer -> Integer -> Integer+foreign import primIntegerRem      :: Integer -> Integer -> Integer+foreign import primIntegerNegate   :: Integer -> Integer+foreign import primIntegerAbs      :: Integer -> Integer+foreign import primIntegerSignum   :: Integer -> Integer
+ tools/base/tests/HaskellLibraries/PreludeIO.hs view
@@ -0,0 +1,84 @@+module PreludeIO {-(+    FilePath, IOError(..), ioError, userError, catch,+    putChar, putStr, putStrLn, print,+    getChar, getLine, getContents, interact,+    readFile, writeFile, appendFile, readIO, readLn+  )-} where++import PreludeBuiltin++type  FilePath = String++data IOErrorKind+  = EOFError          +  | OtherError+  | UserError+  | AlreadyExistsError +  | DoesNotExistError +  | AlreadyInUseError +  | FullError         +  | IllegalOperation  +  | PermissionError   +  deriving (Eq)+--instance Eq IOErrorKind++-- The internals of this type are system dependent:+data IOError = IOE IOErrorKind String --deriving (Eq)++instance  Show IOError  --where ...+instance  Eq IOError  --where ...++ioError          ::  IOError -> IO a+ioError          =   undefined--primIOError++userError        ::  String -> IOError+userError        =   IOE UserError++catch            ::  IO a -> (IOError -> IO a) -> IO a+catch            =   undefined--primCatch++putChar          :: Char -> IO ()+putChar          =  undefined--primPutChar++putStr           :: String -> IO ()+putStr s         =  mapM_ putChar s++putStrLn         :: String -> IO ()+putStrLn s       =  do putStr s+                       putStr "\n"++print            :: Show a => a -> IO ()+print x          =  putStrLn (show x)++getChar          :: IO Char+getChar          =  undefined--primGetChar++getLine          :: IO String+getLine          =  do c <- getChar+                       if c == '\n' then return "" else+                          do s <- getLine+                             return (c:s)+++foreign import getContents      :: IO String+foreign import readFile         :: FilePath -> IO String+foreign import writeFile        :: FilePath -> String -> IO ()+foreign import appendFile       :: FilePath -> String -> IO ()++interact         ::  (String -> String) -> IO ()+interact f       =  do s <- getContents+                       putStr (f s)+++  -- raises an exception instead of an error++readIO   :: Read a => String -> IO a+readIO s =  case [x | (x,t) <- reads s, ("","") <- lex t] of+              [x] -> return x+              []  -> ioError (userError "Prelude.readIO: no parse")+              _   -> ioError (userError "Prelude.readIO: ambiguous parse")++readLn           :: Read a => IO a+readLn           =  do l <- getLine+                       r <- readIO l+                       return r
+ tools/base/tests/HaskellLibraries/PreludeList.hs view
@@ -0,0 +1,316 @@++-- Standard list functions++module PreludeList (+    map, (++), filter, concat,+    head, last, tail, init, null, length, (!!),+    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,+    iterate, repeat, replicate, cycle,+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    lines, words, unlines, unwords, reverse, and, or,+    any, all, elem, notElem, lookup,+    sum, product, maximum, minimum, concatMap,+    zip, zip3, zipWith, zipWith3, unzip, unzip3)+  where++import qualified Char(isSpace)++infixl 9  !!+infixr 5  +++infix  4  `elem`, `notElem`++-- Map and append++map :: (a -> b) -> [a] -> [b]+map f []     = []+map f (x:xs) = f x : map f xs++(++) :: [a] -> [a] -> [a]+[]     ++ ys = ys+(x:xs) ++ ys = x : (xs ++ ys)++filter :: (a -> Bool) -> [a] -> [a]+filter p [] = []+filter p (x:xs) | p x       = x : filter p xs+                | otherwise = filter p xs++concat :: [[a]] -> [a]+concat xss = foldr (++) [] xss++-- head and tail extract the first element and remaining elements,+-- respectively, of a list, which must be non-empty.  last and init+-- are the dual functions working from the end of a finite list,+-- rather than the beginning.++head             :: [a] -> a+head (x:_)       =  x+head []          =  error "Prelude.head: empty list"++last             :: [a] -> a+last [x]         =  x+last (_:xs)      =  last xs+last []          =  error "Prelude.last: empty list"++tail             :: [a] -> [a]+tail (_:xs)      =  xs+tail []          =  error "Prelude.tail: empty list"++init             :: [a] -> [a]+init [x]         =  []+init (x:xs)      =  x : init xs+init []          =  error "Prelude.init: empty list"++null             :: [a] -> Bool+null []          =  True+null (_:_)       =  False++-- length returns the length of a finite list as an Int.++length           :: [a] -> Int+length []        =  0+length (_:l)     =  1 + length l++-- List index (subscript) operator, 0-origin++(!!)                :: [a] -> Int -> a+xs     !! n | n < 0 =  error "Prelude.!!: negative index"+[]     !! _         =  error "Prelude.!!: index too large"+(x:_)  !! n | n==0  =  x+(_:xs) !! n         =  xs !! (n-1)++-- foldl, applied to a binary operator, a starting value (typically the+-- left-identity of the operator), and a list, reduces the list using+-- the binary operator, from left to right:+--  foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn+-- foldl1 is a variant that has no starting value argument, and  thus must+-- be applied to non-empty lists.  scanl is similar to foldl, but returns+-- a list of successive reduced values from the left:+--      scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]+-- Note that  last (scanl f z xs) == foldl f z xs.+-- scanl1 is similar, again without the starting element:+--      scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]++foldl            :: (a -> b -> a) -> a -> [b] -> a+foldl f z []     =  z+foldl f z (x:xs) =  foldl f (f z x) xs++foldl1           :: (a -> a -> a) -> [a] -> a+foldl1 f (x:xs)  =  foldl f x xs+foldl1 _ []      =  error "Prelude.foldl1: empty list"++scanl            :: (a -> b -> a) -> a -> [b] -> [a]+scanl f q xs     =  q : (case xs of+                            []   -> []+                            x:xs -> scanl f (f q x) xs)++scanl1           :: (a -> a -> a) -> [a] -> [a]+scanl1 f (x:xs)  =  scanl f x xs+scanl1 _ []      =  []++-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the+-- above functions.++foldr            :: (a -> b -> b) -> b -> [a] -> b+foldr f z []     =  z+foldr f z (x:xs) =  f x (foldr f z xs)++foldr1           :: (a -> a -> a) -> [a] -> a+foldr1 f [x]     =  x+foldr1 f (x:xs)  =  f x (foldr1 f xs)+foldr1 _ []      =  error "Prelude.foldr1: empty list"++scanr             :: (a -> b -> b) -> b -> [a] -> [b]+scanr f q0 []     =  [q0]+scanr f q0 (x:xs) =  f x q : qs+                     where qs@(q:_) = scanr f q0 xs++scanr1          :: (a -> a -> a) -> [a] -> [a]+scanr1 f []     =  []+scanr1 f [x]    =  [x]+scanr1 f (x:xs) =  f x q : qs+                   where qs@(q:_) = scanr1 f xs++-- iterate f x returns an infinite list of repeated applications of f to x:+-- iterate f x == [x, f x, f (f x), ...]++iterate          :: (a -> a) -> a -> [a]+iterate f x      =  x : iterate f (f x)++-- repeat x is an infinite list, with x the value of every element.++repeat           :: a -> [a]+repeat x         =  xs where xs = x:xs++-- replicate n x is a list of length n with x the value of every element++replicate        :: Int -> a -> [a]+replicate n x    =  take n (repeat x)++-- cycle ties a finite list into a circular one, or equivalently,+-- the infinite repetition of the original list.  It is the identity+-- on infinite lists.++cycle            :: [a] -> [a]+cycle []         =  error "Prelude.cycle: empty list"+cycle xs         =  xs' where xs' = xs ++ xs'++-- take n, applied to a list xs, returns the prefix of xs of length n,+-- or xs itself if n > length xs.  drop n xs returns the suffix of xs+-- after the first n elements, or [] if n > length xs.  splitAt n xs+-- is equivalent to (take n xs, drop n xs).++take                   :: Int -> [a] -> [a]+take n _      | n <= 0 =  []+take _ []              =  []+take n (x:xs)          =  x : take (n-1) xs++drop                   :: Int -> [a] -> [a]+drop n xs     | n <= 0 =  xs+drop _ []              =  []+drop n (_:xs)          =  drop (n-1) xs++splitAt                  :: Int -> [a] -> ([a],[a])+splitAt n xs             =  (take n xs, drop n xs)++-- takeWhile, applied to a predicate p and a list xs, returns the longest+-- prefix (possibly empty) of xs of elements that satisfy p.  dropWhile p xs+-- returns the remaining suffix.  span p xs is equivalent to+-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.++takeWhile               :: (a -> Bool) -> [a] -> [a]+takeWhile p []          =  []+takeWhile p (x:xs)+            | p x       =  x : takeWhile p xs+            | otherwise =  []++dropWhile               :: (a -> Bool) -> [a] -> [a]+dropWhile p []          =  []+dropWhile p xs@(x:xs')+            | p x       =  dropWhile p xs'+            | otherwise =  xs++span, break             :: (a -> Bool) -> [a] -> ([a],[a])+span p []            = ([],[])+span p xs@(x:xs')+            | p x       =  (x:ys,zs)+            | otherwise =  ([],xs)+                           where (ys,zs) = span p xs'++break p                 =  span (not . p)++-- lines breaks a string up into a list of strings at newline characters.+-- The resulting strings do not contain newlines.  Similary, words+-- breaks a string up into a list of words, which were delimited by+-- white space.  unlines and unwords are the inverse operations.+-- unlines joins lines with terminating newlines, and unwords joins+-- words with separating spaces.++lines            :: String -> [String]+lines ""         =  []+lines s          =  let (l, s') = break (== '\n') s+                      in  l : case s' of+                                []      -> []+                                (_:s'') -> lines s''++words            :: String -> [String]+words s          =  case dropWhile Char.isSpace s of+                      "" -> []+                      s' -> w : words s''+                            where (w, s'') = break Char.isSpace s'++unlines          :: [String] -> String+unlines          =  concatMap (++ "\n")++unwords          :: [String] -> String+unwords []       =  ""+unwords ws       =  foldr1 (\w s -> w ++ ' ':s) ws++-- reverse xs returns the elements of xs in reverse order.  xs must be finite.++reverse          :: [a] -> [a]+reverse          =  foldl (flip (:)) []++-- and returns the conjunction of a Boolean list.  For the result to be+-- True, the list must be finite; False, however, results from a False+-- value at a finite index of a finite or infinite list.  or is the+-- disjunctive dual of and.++and, or          :: [Bool] -> Bool+and              =  foldr (&&) True+or               =  foldr (||) False++-- Applied to a predicate and a list, any determines if any element+-- of the list satisfies the predicate.  Similarly, for all.++any, all         :: (a -> Bool) -> [a] -> Bool+any p            =  or . map p+all p            =  and . map p++-- elem is the list membership predicate, usually written in infix form,+-- e.g., x `elem` xs.  notElem is the negation.++elem, notElem    :: (Eq a) => a -> [a] -> Bool+elem x           =  any (== x)+notElem x        =  all (/= x)++-- lookup key assocs looks up a key in an association list.++lookup           :: (Eq a) => a -> [(a,b)] -> Maybe b+lookup key []    =  Nothing+lookup key ((x,y):xys)+    | key == x   =  Just y+    | otherwise  =  lookup key xys++-- sum and product compute the sum or product of a finite list of numbers.++sum, product     :: (Num a) => [a] -> a+sum              =  foldl (+) 0+product          =  foldl (*) 1++-- maximum and minimum return the maximum or minimum value from a list,+-- which must be non-empty, finite, and of an ordered type.++maximum, minimum :: (Ord a) => [a] -> a+maximum []       =  error "Prelude.maximum: empty list"+maximum xs       =  foldl1 max xs++minimum []       =  error "Prelude.minimum: empty list"+minimum xs       =  foldl1 min xs++concatMap        :: (a -> [b]) -> [a] -> [b]+concatMap f      =  concat . map f++-- zip takes two lists and returns a list of corresponding pairs.  If one+-- input list is short, excess elements of the longer list are discarded.+-- zip3 takes three lists and returns a list of triples.  Zips for larger+-- tuples are in the List library++zip              :: [a] -> [b] -> [(a,b)]+zip              =  zipWith (,)++zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]+zip3             =  zipWith3 (,,)++-- The zipWith family generalises the zip family by zipping with the+-- function given as the first argument, instead of a tupling function.+-- For example, zipWith (+) is applied to two lists to produce the list+-- of corresponding sums.++zipWith          :: (a->b->c) -> [a]->[b]->[c]+zipWith z (a:as) (b:bs)+                 =  z a b : zipWith z as bs+zipWith _ _ _    =  []++zipWith3         :: (a->b->c->d) -> [a]->[b]->[c]->[d]+zipWith3 z (a:as) (b:bs) (c:cs)+                 =  z a b c : zipWith3 z as bs cs+zipWith3 _ _ _ _ =  []++-- unzip transforms a list of pairs into a pair of lists.++unzip            :: [(a,b)] -> ([a],[b])+unzip            =  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])++unzip3           :: [(a,b,c)] -> ([a],[b],[c])+unzip3           =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))+                          ([],[],[])
+ tools/base/tests/HaskellLibraries/PreludeText.hs view
@@ -0,0 +1,230 @@+module PreludeText {-(+    ReadS, ShowS,+    Read(readsPrec, readList),+    Show(showsPrec, showList),+    reads, shows, show, read, lex,+    showChar, showString, readParen, showParen )-} where++-- The instances of Read and Show for+-- Bool, Char, Maybe, Either, Ordering+-- are done via "deriving" clauses in Prelude.hs++import Char(isSpace, isAlpha, isDigit, isAlphaNum,+            showLitChar, readLitChar, lexLitChar)++import Numeric(showSigned, showInt, readSigned, readDec, showFloat,+               readFloat, lexDigits)++type  ReadS a  = String -> [(a,String)]++type  ShowS    = String -> String++class  Read a  where+    readsPrec        :: Int -> ReadS a+    readList         :: ReadS [a]++-- Minimal complete definition:+-- readsPrec+    readList         = readParen False (\r -> [pr | ("[",s)  <- lex r,+                                                    pr       <- readl s])+                       where readl  s = [([],t)   | ("]",t)  <- lex s] +++                                        [(x:xs,u) | (x,t)    <- reads s,+                                                    (xs,u)   <- readl' t]+                             readl' s = [([],t)   | ("]",t)  <- lex s] +++                                        [(x:xs,v) | (",",t)  <- lex s,+                                                    (x,u)    <- reads t,+                                                    (xs,v)   <- readl' u]++class  Show a  where+    showsPrec        :: Int -> a -> ShowS+    show             :: a -> String+    showList         :: [a] -> ShowS++-- Mimimal complete definition:+-- show or showsPrec+    showsPrec _ x s   = show x ++ s++    show x        = showsPrec 0 x ""++    showList []       = showString "[]"+    showList (x:xs)   = showChar '[' . shows x . showl xs+                        where showl []     = showChar ']'+                              showl (x:xs) = showChar ',' . shows x .+                                             showl xs++reads            :: (Read a) => ReadS a+reads            =  readsPrec 0++shows            :: (Show a) => a -> ShowS+shows            =  showsPrec 0++read             :: (Read a) => String -> a+read s           =  case parses of+                         [x] -> x+                         []  -> error "Prelude.read: no parse"+                         _   -> error "Prelude.read: ambiguous parse"+  where parses = [x | (x,t) <- reads s, ("","") <- lex t]++showChar         :: Char -> ShowS+showChar         =  (:)++showString       :: String -> ShowS+showString       =  (++)++showParen        :: Bool -> ShowS -> ShowS+showParen b p    =  if b then showChar '(' . p . showChar ')' else p++-- Basic printing combinators (nonstd, for use in derived Show instances):++showParenArg :: Int -> ShowS -> ShowS+showParenArg d = showParen (10<=d)++showArgument x = showChar ' ' . showsPrec 10 x++-- Basic parsing combinators (nonstd, for use in derived Read instances):++readToken x t s = [(x,r)|(t',r)<-lex s,t'==t]++readParenArg :: Int -> ReadS a -> ReadS a+readParenArg d = readParen (10<=d)+readArgument s = readsPrec 10 s++rf `readAp` rx = \ s0 -> [(f x,s2) | (f,s1)<-rf s0,(x,s2)<-rx s1]++readChoice rd1 rd2 s = rd1 s ++ rd2 s++---+readParen        :: Bool -> ReadS a -> ReadS a+readParen b g    =  if b then mandatory else optional+                    where optional r  = g r ++ mandatory r+                          mandatory r = [(x,u) | ("(",s) <- lex r,+                                                 (x,t)   <- optional s,+                                                 (")",u) <- lex t    ]++-- This lexer is not completely faithful to the Haskell lexical syntax.+-- Current limitations:+--    Qualified names are not handled properly+--    Octal and hexidecimal numerics are not recognized as a single token+--    Comments are not treated properly++--lex              :: ReadS String+lex ""           =  [("","")]+lex (c:s)+   | isSpace c   =  lex (dropWhile isSpace s)+lex ('\'':s)     =  [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,+                                         ch /= "'" ]+lex ('"':s)      =  [('"':str, t)      | (str,t) <- lexString s]+                    where+                    lexString ('"':s) = [("\"",s)]+                    lexString s = [(ch++str, u)+                                         | (ch,t)  <- lexStrItem s,+                                           (str,u) <- lexString t  ]++                    lexStrItem ('\\':'&':s) =  [("\\&",s)]+                    lexStrItem ('\\':c:s) | isSpace c+                                           =  [("\\&",t) |+                                               '\\':t <-+                                                   [dropWhile isSpace s]]+                    lexStrItem s           =  lexLitChar s++lex (c:s) | isSingle c = [([c],s)]+          | isSym c    = [(c:sym,t)       | (sym,t) <- [span isSym s]]+          | isAlpha c  = [(c:nam,t)       | (nam,t) <- [span isIdChar s]]+          | isDigit c  = [(c:ds++fe,t)    | (ds,s)  <- [span isDigit s],+                                            (fe,t)  <- lexFracExp s     ]+          | otherwise  = []    -- bad character+             where+              isSingle c =  c `elem` ",;()[]{}_`"+              isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"+              isIdChar c =  isAlphaNum c || c `elem` "_'"++              lexFracExp ('.':c:cs) | isDigit c+                            = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),+                                               (e,u)  <- lexExp t]+              lexFracExp s  = lexExp s++              lexExp (e:s) | e `elem` "eE"+                       = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",+                                                 (ds,u) <- lexDigits t] +++                         [(e:ds,t)   | (ds,t) <- lexDigits s]+              lexExp s = [("",s)]++instance  Show Int  where+    showsPrec n = showsPrec n . toInteger+-- Converting to Integer avoids+-- possible difficulty with minInt++instance  Read Int  where+  readsPrec p r = [(fromInteger i, t) | (i,t) <- readsPrec p r]+-- Reading at the Integer type avoids+-- possible difficulty with minInt++instance  Show Integer  where+    showsPrec           = showSigned showInt++instance  Read Integer  where+    readsPrec p         = readSigned readDec++instance  Show Float  where+    showsPrec p         = showFloat+++instance  Read Float  where+    readsPrec p         = readFloat++instance  Show Double  where+    showsPrec p         = showFloat++instance  Read Double  where+    readsPrec p         = readFloat++instance  Show ()  where+    showsPrec p () = showString "()"++instance Read () where+    readsPrec p    = readParen False+                            (\r -> [((),t) | ("(",s) <- lex r,+                                             (")",t) <- lex s ] )++instance  Show Char  where+    showsPrec p '\'' = showString "'\\''"+    showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''++    showList cs = showChar '"' . showl cs+                 where showl ""       = showChar '"'+                       showl ('"':cs) = showString "\\\"" . showl cs+                       showl (c:cs)   = showLitChar c . showl cs++instance  Read Char  where+    readsPrec p      = readParen False+                            (\r -> [(c,t) | ('\'':s,t)<- lex r,+                                            (c,"\'")  <- readLitChar s])++    readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,+                                               (l,_)      <- readl s ])+        where readl ('"':s)      = [("",s)]+              readl ('\\':'&':s) = readl s+              readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,+                                               (cs,u) <- readl t       ]++instance  (Show a) => Show [a]  where+    showsPrec p      = showList++instance  (Read a) => Read [a]  where+    readsPrec p      = readList++-- Tuples++instance  (Show a, Show b) => Show (a,b)  where+    showsPrec p (x,y) = showChar '(' . shows x . showChar ',' .+                                       shows y . showChar ')'++instance  (Read a, Read b) => Read (a,b)  where+    readsPrec p       = readParen False+                            (\r -> [((x,y), w) | ("(",s) <- lex r,+                                                 (x,t)   <- reads s,+                                                 (",",u) <- lex t,+                                                 (y,v)   <- reads u,+                                                 (")",w) <- lex v ] )++-- Other tuples have similar Read and Show instances
+ tools/base/tests/HaskellLibraries/Random.hs view
@@ -0,0 +1,234 @@+------------------------------------------------------------------------------+-- Standard Library: Random numbers+--+-- Suitable for use with Hugs 98+--+-- The code in this file draws heavily from several different sources,+-- including the implementations in previous Hugs and GHC implementations.+-- Much of this was done by Sigbjorn Finne.  If there are mistakes here,+-- blame me.  The random number generation itself is based on a published+-- article by L'Ecuyer that was transliterated into Haskell by Lennart+-- Augustsson.  See the comments below for further details.+------------------------------------------------------------------------------++module Random(+	RandomGen(next, split),+	StdGen, mkStdGen,+	Random( random,   randomR,+		randoms,  randomRs,+		randomIO, randomRIO ),+	getStdRandom, getStdGen, setStdGen, newStdGen+  ) where++import IOExts  ( IORef, newIORef, writeIORef, readIORef,+		 unsafePerformIO+	       )+import Numeric ( showInt, showSigned, readDec )+import Char(ord,chr,isSpace)++-- The RandomGen class: ------------------------------------------------------++class RandomGen g where+   next  :: g -> (Int, g)+   split :: g -> (g, g)+++-- An efficient and portable combined random number generator: ---------------+--+-- The June 1988 (v31 #6) issue of the Communications of the ACM has an+-- article by Pierre L'Ecuyer called, "Efficient and Portable Combined+-- Random Number Generators".  Here is the Portable Combined Generator of+-- L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.+-- +-- Transliterator: Lennart Augustsson+-- sof 1/99 - code brought (kicking and screaming) into the new Random+-- world..+------------------------------------------------------------------------------++data StdGen = StdGen Int Int++mkStdGen	      :: Int -> StdGen+mkStdGen seed          = StdGen (s1+1) (s2+1)+                         where s       = abs seed+			       (q, s1) = s `divMod` 2147483562+			       s2      = q `mod` 2147483398++stdFromString         :: String -> (StdGen, String)+stdFromString s        = (mkStdGen num, rest)+	where (cs, rest) = splitAt 6 s+              num        = foldl (\a x -> x + 3 * a) 1 (map ord cs)++stdNext               :: StdGen -> (Int, StdGen)+stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')+	where	z'   = if z < 1 then z + 2147483562 else z+		z    = s1'' - s2''++		k    = s1 `quot` 53668+		s1'  = 40014 * (s1 - k * 53668) - k * 12211+		s1'' = if s1' < 0 then s1' + 2147483563 else s1'+    +		k'   = s2 `quot` 52774+		s2'  = 40692 * (s2 - k' * 52774) - k' * 3791+		s2'' = if s2' < 0 then s2' + 2147483399 else s2'++stdSplit            :: StdGen -> (StdGen, StdGen)+stdSplit std@(StdGen s1 s2)+                     = (left, right)+                       where+                        -- no statistical foundation for this!+                        left    = StdGen new_s1 t2+                        right   = StdGen t1 new_s2++                        new_s1 | s1 == 2147483562 = 1+                               | otherwise        = s1 + 1++                        new_s2 | s2 == 1          = 2147483398+                               | otherwise        = s2 - 1++                        StdGen t1 t2 = snd (next std)++-- A standard instance of RandomGen: -----------------------------------------++instance RandomGen StdGen where+  next  = stdNext+  split = stdSplit++instance Show StdGen where+  showsPrec p (StdGen s1 s2)+    = showSigned showInt p s1 .  showChar ' ' . showSigned showInt p s2++instance Read StdGen where+  readsPrec p = \ r ->+    case try_read r of+       r@[_] -> r+       _     -> [stdFromString r] -- because it shouldn't ever fail.+    where +      try_read r = do+         (s1, r1) <- readDec (dropWhile isSpace r)+	 (s2, r2) <- readDec (dropWhile isSpace r1)+	 return (StdGen s1 s2, r2)+++-- The Random class: ---------------------------------------------------------++class Random a where+  -- Minimal complete definition: random and randomR+  random          :: RandomGen g => g -> (a, g)+  randomR         :: RandomGen g => (a,a) -> g -> (a,g)+  +  randoms         :: RandomGen g => g -> [a]++  randomRs        :: RandomGen g => (a,a) -> g -> [a]++  randomIO        :: IO a++  randomRIO       :: (a,a) -> IO a++  randomRIO range  = getStdRandom (randomR range)+  randomRs ival g  = x : randomRs ival g' where (x,g') = randomR ival g+  randomIO	   = getStdRandom random+  randoms  g       = x : randoms g' where (x,g') = random g++instance Random Int where+  random g        = randomR (minBound,maxBound) g+  randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g++instance Random Char where+  random g	  = randomR (minBound,maxBound) g+  randomR (a,b) g = +      case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of+        (x,g) -> (chr x, g)++instance Random Bool where+  random g	  = randomR (minBound,maxBound) g+  randomR (a,b) g = +      case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of+        (x, g) -> (int2Bool x, g)+       where+         bool2Int False = 0+         bool2Int True  = 1++	 int2Bool 0	= False+	 int2Bool _	= True+ +instance Random Integer where+  random g	 = randomR (toInteger (minBound::Int),+                            toInteger (maxBound::Int)) g+  randomR ival g = randomIvalInteger ival g++instance Random Double where+  random g       = randomR (0::Double,1) g+  randomR ival g = randomIvalDouble ival id g+  +-- hah, so you thought you were saving cycles by using Float?+instance Random Float where+  random g        = randomIvalDouble (0::Double,1) realToFrac g+  randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g+++-- Auxiliary functions: ------------------------------------------------------++randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)+randomIvalInteger (l,h) rng+ | l > h     = randomIvalInteger (h,l) rng+ | otherwise = case (f n 1 rng) of+                 (v, rng') -> (fromInteger (l + v `mod` k), rng')+   where+     k = h - l + 1+     b = 2147483561+     n = iLogBase b k++     f 0 acc g = (acc, g)+     f n acc g = let (x,g') = next g+		 in f (n-1) (fromIntegral x + acc * b) g'++randomIvalDouble :: (RandomGen g, Fractional a)+			=> (Double, Double) -> (Double -> a) -> g -> (a, g)+randomIvalDouble (l,h) fromDouble rng +  | l > h     = randomIvalDouble (h,l) fromDouble rng+  | otherwise = +       case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of+         (x, rng') -> +	    let+	     scaled_x = +		fromDouble ((l+h)/2) + +                fromDouble ((h-l) / realToFrac intRange) *+		fromIntegral (x::Int)+	    in+	    (scaled_x, rng')++intRange :: Integer+intRange  = toInteger (maxBound::Int) - toInteger (minBound::Int)++iLogBase :: Integer -> Integer -> Integer+iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)+++-- The global standard random number generator: ------------------------------++foreign import getRandomSeed :: IO Integer++global_rng    :: IORef StdGen+global_rng     = unsafePerformIO (do seed <- getRandomSeed+                                     newIORef (mkStdGen (fromIntegral seed)))++setStdGen     :: StdGen -> IO ()+setStdGen sgen = writeIORef global_rng sgen++getStdGen     :: IO StdGen+getStdGen      = readIORef global_rng++newStdGen     :: IO StdGen+newStdGen      = do rng <- getStdGen+                    let (a,b) = split rng+                    setStdGen a+                    return b++getStdRandom  :: (StdGen -> (a,StdGen)) -> IO a+getStdRandom f = do rng	<- getStdGen+                    let (v, new_rng) = f rng+                    setStdGen new_rng+                    return v+++------------------------------------------------------------------------------
+ tools/base/tests/HaskellLibraries/Ratio.hs view
@@ -0,0 +1,107 @@+-- Standard functions on rational numbers++module  Ratio (+    Ratio, Rational, (%), numerator, denominator, approxRational ) where+import Prelude++infixl 7  %++prec = 7 :: Int++data  (Integral a)      => Ratio a = !a :% !a  deriving (Eq)+--instance Eq a => Eq (Ratio a)+--type  Rational          =  Ratio Integer++intRat x = x % 1++instance  (Show a{-Integral a-})  => Show (Ratio a)  where+    showsPrec p (x:%y)  =  showParen (p > prec)+                               (shows x . showString " % " . shows y)++--instance Eq a => Eq (Ratio a) where  n1:%d1 == n2:%d2 = n1==n2 && d1==d2++--(%)                     :: (Integral a) => a -> a -> Ratio a+numerator, denominator  :: (Integral a) => Ratio a -> a+--approxRational          :: (RealFrac a) => a -> a -> Rational+++-- "reduce" is a subsidiary function used only in this module.+-- It normalises a ratio by dividing both numerator+-- and denominator by their greatest common divisor.+--+-- E.g., 12 `reduce` 8    ==  3 :%   2+--       12 `reduce` (-8) ==  3 :% (-2)++reduce _ 0              =  error "Ratio.% : zero denominator"+reduce x y              =  (x `quot` d) :% (y `quot` d)+                           where d = gcd x y++x % y                   =  reduce (x * signum y) (abs y)++numerator (x :% _)      =  x++denominator (_ :% y)    =  y+++instance  (Ord a,Num a{-Integral a-})  => Ord (Ratio a)  where+    (x:%y) <= (x':%y')  =  x * y' <= x' * y+    (x:%y) <  (x':%y')  =  x * y' <  x' * y++instance  (Num a,Integral a)  => Num (Ratio a)  {-where+    (x:%y) + (x':%y')   =  reduce (x*y' + x'*y) (y*y')+    (x:%y) * (x':%y')   =  reduce (x * x') (y * y')+    negate (x:%y)       =  (-x) :% y+    abs (x:%y)          =  abs x :% y+    signum (x:%y)       =  signum x :% 1+    fromInteger x       =  fromInteger x :% 1-}++instance  (Integral a)  => Real (Ratio a)  where+    toRational (x:%y)   =  toInteger x :% toInteger y++instance  (Ord a,Num a,Integral a)  => Fractional (Ratio a){-  where+    (x:%y) / (x':%y')   =  (x*y') % (y*x')+    recip (x:%y)        =  if x < 0 then (-y) :% (-x) else y :% x+    fromRational (x:%y) =  fromInteger x :% fromInteger y-}++{-+properFractionRatio (x:%y) = case quotRem x y of+	                      (q,r) -> (fromIntegral q, r:%y)+-}+++instance  (Integral a)  => RealFrac (Ratio a) where+    properFraction (x:%y) = case quotRem x y of+	                      (q,r) -> (fromIntegral q, r:%y)++instance  (Integral a)  => Enum (Ratio a) {- where+    toEnum           =  fromIntegral+    fromEnum         =  fromInteger . truncate -- May overflow+    enumFrom         =  numericEnumFrom -- These numericEnumXXX functions+    enumFromThen     =  numericEnumFromThen -- are as defined in Prelude.hs+    enumFromTo       =  numericEnumFromTo -- but not exported from it!+    enumFromThenTo   =  numericEnumFromThenTo+-}++instance  (Read a, Integral a)  => Read (Ratio a) {- where+    readsPrec p  =  readParen (p > prec)+                              (\r -> [(x%y,u) | (x,s)   <- reads r,+                                                ("%",t) <- lex s,+                                                (y,u)   <- reads t ])+-}++approxRational x eps    =  simplest (x-eps) (x+eps)+        where simplest x y | y < x      =  simplest y x+                           | x == y     =  xr+                           | x > 0      =  simplest' n d n' d'+                           | y < 0      =  - simplest' (-n') d' (-n) d+                           | otherwise  =  0 :% 1+                                        where xr@(n:%d) = toRational x+                                              (n':%d')  = toRational y++              simplest' n d n' d'       -- assumes 0 < n%d < n'%d'+                        | r == 0     =  q :% 1+                        | q /= q'    =  (q+1) :% 1+                        | otherwise  =  (q*n''+d'') :% n''+                                     where (q,r)      =  quotRem n d+                                           (q',r')    =  quotRem n' d'+                                           (n'':%d'') =  simplest' d' r' d r
+ tools/base/tests/HaskellLibraries/System.hs view
@@ -0,0 +1,24 @@+module System where+import Prelude++foreign import system :: String -> IO ExitCode+foreign import progLine :: [String]+foreign import getEnv :: String -> IO String+++data ExitCode = ExitSuccess | ExitFailure Int deriving (Eq,Ord,Show,Read)+--instance Show ExitCode++getArgs :: IO [String]+getProgName :: IO String++getArgs = return progArgs+getProgName = return progName++exitWith :: ExitCode -> IO a+exitWith e = error ("exithWith "++show e)++exitFailure :: IO a+exitFailure = exitWith (ExitFailure 1) -- system dependent...++progName:progArgs=progLine
+ tools/base/tests/HaskellLibraries/Time.hs view
@@ -0,0 +1,139 @@+module Time {-(+        ClockTime, +        Month(January,February,March,April,May,June,+              July,August,September,October,November,December),+        Day(Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday),+	CalendarTime(CalendarTime, ctYear, ctMonth, ctDay, ctHour, ctMin,+     ctPicosec, ctWDay, ctYDay, ctTZName, ctTZ, ctIsDST),+	TimeDiff(TimeDiff, tdYear, tdMonth, tdDay, +	 tdHour, tdMin, tdSec, tdPicosec),+        getClockTime, addToClockTime, diffClockTimes,+        toCalendarTime, toUTCTime, toClockTime,+        calendarTimeToString, formatCalendarTime )-} where++import Prelude+import Ix(Ix)+import Locale --(TimeLocale(..),defaultTimeLocale)+import Char ( intToDigit )++newtype ClockTime+   = ClockTime Int+  deriving (Eq,Ord,Show)+  -- The Show instance is a deviation from Haskell 98, provided for+  -- compatibility with Hugs and GHC.++data Month =  January   | February | March    | April+           |  May       | June     | July     | August+           |  September | October  | November | December+           deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)+--instance Enum Month++data Day   =  Sunday | Monday  | Tuesday  | Wednesday | Thursday +           |  Friday | Saturday+           deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)+--instance Enum Day++data CalendarTime = CalendarTime {+                ctYear                          :: Int,+                ctMonth                         :: Month,+                ctDay, ctHour, ctMin, ctSec     :: Int,+                ctPicosec                       :: Integer,+                ctWDay                          :: Day,+                ctYDay                          :: Int,+                ctTZName                        :: String,+                ctTZ                            :: Int,+                ctIsDST                         :: Bool+        } deriving (Eq, Ord, Read, Show)++data TimeDiff = TimeDiff {+                tdYear, tdMonth, tdDay, tdHour, tdMin, tdSec :: Int,+                tdPicosec                                    :: Integer+        } deriving (Eq, Ord, Read, Show)+++getClockTime            :: IO ClockTime+getClockTime            = undefined           -- Implementation-dependent++addToClockTime          :: TimeDiff     -> ClockTime -> ClockTime+addToClockTime td ct    =  undefined          -- Implementation-dependent++diffClockTimes          :: ClockTime    -> ClockTime -> TimeDiff+diffClockTimes ct1 ct2  =  undefined          -- Implementation-dependent++toCalendarTime          :: ClockTime    -> IO CalendarTime+toCalendarTime ct       =  undefined          -- Implementation-dependent++toUTCTime               :: ClockTime    -> CalendarTime+toUTCTime ct            =  undefined          -- Implementation-dependent++toClockTime             :: CalendarTime -> ClockTime+toClockTime cal         =  undefined          -- Implementation-dependent++calendarTimeToString    :: CalendarTime -> String+calendarTimeToString    =  formatCalendarTime defaultTimeLocale "%c"++formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String+formatCalendarTime l fmt ct@(CalendarTime year mon day hour min sec sdec +                                           wday yday tzname _ _) =+        doFmt fmt+  where doFmt ('%':c:cs) = decode c ++ doFmt cs+        doFmt (c:cs) = c : doFmt cs+        doFmt "" = ""++        to12 :: Int -> Int+        to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'++        decode 'A' = fst (wDays l  !! fromEnum wday)+        decode 'a' = snd (wDays l  !! fromEnum wday)+        decode 'B' = fst (months l !! fromEnum mon)+        decode 'b' = snd (months l !! fromEnum mon)+        decode 'h' = snd (months l !! fromEnum mon)+        decode 'C' = show2 (year `quot` 100)+        decode 'c' = doFmt (dateTimeFmt l)+        decode 'D' = doFmt "%m/%d/%y"+        decode 'd' = show2 day+        decode 'e' = show2' day+        decode 'H' = show2 hour+        decode 'I' = show2 (to12 hour)+        decode 'j' = show3 yday+        decode 'k' = show2' hour+        decode 'l' = show2' (to12 hour)+        decode 'M' = show2 min+        decode 'm' = show2 (fromEnum mon+1)+        decode 'n' = "\n"+        decode 'p' = (if hour < 12 then fst else snd) (amPm l)+        decode 'R' = doFmt "%H:%M"+        decode 'r' = doFmt (time12Fmt l)+        decode 'T' = doFmt "%H:%M:%S"+        decode 't' = "\t"+        decode 'S' = show2 sec+        --decode 's' = undefined                -- Implementation-dependent+        decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7)+        decode 'u' = show (let n = fromEnum wday in +                           if n == 0 then 7 else n)+        decode 'V' = +            let (week, days) = +                   (yday + 7 - if fromEnum wday > 0 then +                               fromEnum wday - 1 else 6) `divMod` 7+            in  show2 (if days >= 4 then+                          week+1 +                       else if week == 0 then 53 else week)++        decode 'W' = +            show2 ((yday + 7 - if fromEnum wday > 0 then +                               fromEnum wday - 1 else 6) `div` 7)+        decode 'w' = show (fromEnum wday)+        decode 'X' = doFmt (timeFmt l)+        decode 'x' = doFmt (dateFmt l)+        decode 'Y' = show year+        decode 'y' = show2 (year `rem` 100)+        decode 'Z' = tzname+        decode '%' = "%"+        decode c   = [c]++show2, show2', show3 :: Int -> String+show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)]++show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x++show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100)
+ tools/base/tests/HbcLibraries/IntMap.hs view
@@ -0,0 +1,195 @@+-- Copyright (c) 1982-1999 Lennart Augustsson, Thomas Johnsson+-- See LICENSE for the full license.+--+module IntMap (+	IntMap, +	empty, singleton, union, unionMany, add, (//), addKeep,+	-- union_C, unionMany_C, addMany_C,+	add_C,+	-- intersect, +	delete, deleteMany, +	--minus, +	foldr, imap, filter,+	-- partition, foldl,+	toList, fromList,+	length,+	null, isSingleton,+	-- intersecting, subset+	elems, indices,+	(!),+	lookup, lookupWithDefault --, lookupWithContinuation+	) where++-- @@ Mapping from Int to any type.  Similar to an array with Int index, but+-- @@ without any bounds on the index.++import Prelude hiding (foldr,length,lookup,filter,null)+import qualified Prelude++data IntMap a = Nil | Leaf !Int a | Fork !(IntMap a) !(IntMap a)+instance (Show a) => Show (IntMap a) where+	--showsType _ = showString "IntMap a"+	showsPrec _ Nil = showString "{}"+	showsPrec _ s = showString "{" . f (toList s) . showString "}"+		where f [x] = g x+		      f (x:xs) = g x . showString ", " . f xs+		      g (i, r) = shows i . showString "->" . shows r++instance (Eq a) => Eq (IntMap a) where+	Nil == Nil = True+	Leaf x y == Leaf x' y' = x == x' && y == y'+	Fork l r == Fork l' r' = l == l' && r == r'+	_ == _ = False++empty :: IntMap a+empty = Nil++singleton :: (Int, a) -> IntMap a+singleton (x, y) = Leaf x y++null :: IntMap a -> Bool+null Nil = True+null (Leaf _ _) = False+null (Fork _ _) = False++add :: (Int, a) -> IntMap a -> IntMap a+add (x, y) t = add' x y t+add' :: Int -> a -> IntMap a -> IntMap a+add' x y Nil = Leaf x y+add' x y (Leaf x' y') =+	if x == x' then+	    Leaf x y+	else+	    add' x y (add' x' y' (Fork Nil Nil))+add' x y (Fork l r) =+	if odd x then+	    Fork l (add' (x `div` 2) y r)+	else+	    Fork (add' (x `div` 2) y l) r++-- similar to add, but does not overwrite the old contents+addKeep :: (Int, a) -> IntMap a -> IntMap a+addKeep (x, y) t = addKeep' x y t+addKeep' :: Int -> a -> IntMap a -> IntMap a+addKeep' x y Nil = Leaf x y+addKeep' x y t@(Leaf x' y') =+	if x == x' then+	    t+	else+	    addKeep' x y (addKeep' x' y' (Fork Nil Nil))+addKeep' x y (Fork l r) =+	if odd x then+	    Fork l (addKeep' (x `div` 2) y r)+	else+	    Fork (addKeep' (x `div` 2) y l) r++lookupWithDefault :: IntMap a -> a -> Int -> a+lookupWithDefault Nil d x = if x==x then d else d			-- force it to be strict in x+lookupWithDefault (Leaf x' y) d x = if x == x' then y else d+lookupWithDefault (Fork l r) d x =+	if odd x then+	    lookupWithDefault r d (x `div` 2)+	else+	    lookupWithDefault l d (x `div` 2)++lookup :: Int -> IntMap a -> Maybe a+lookup x Nil = Nothing+lookup x (Leaf x' y) = if x == x' then Just y else Nothing+lookup x (Fork l r) =+	if odd x then+	    lookup (x `div` 2) r+	else+	    lookup (x `div` 2) l++(!) :: IntMap a -> Int -> a+t ! x = case lookup x t of Nothing -> error "IntMap.!: index not found"; Just y -> y+++union :: IntMap a -> IntMap a -> IntMap a+union Nil t = t+union (Leaf x y) t = add' x y t+union t Nil = t+union t (Leaf x y) = addKeep' x y t+union (Fork l r) (Fork l' r') = Fork (union l l') (union r r')++unionMany :: [IntMap a] -> IntMap a+unionMany = Prelude.foldr union empty++fromList :: [(Int, a)] -> IntMap a+fromList xs = Prelude.foldr (\ (x,y) -> \ m -> add' x y m) empty xs++toList :: IntMap a -> [(Int, a)]+toList t = foldr (:) [] t+{-+toList :: IntMap a -> [(Int, a)]+toList Nil = []+toList (Leaf x y) = [(x, y)]+toList (Fork l r) = [(2*x, y) | (x, y) <- toList l] ++ [ (2*x+1, y) | (x, y) <- toList r]+-}++elems :: IntMap a -> [a]+elems = Prelude.map snd . toList++indices :: IntMap a -> [Int]+indices = Prelude.map fst . toList++length :: IntMap a -> Int+length Nil = 0+length (Leaf _ _) = 1+length (Fork l r) = length l + length r++isSingleton :: IntMap a -> Bool+isSingleton t = length t == 1++add_C :: (a->a->a) -> (Int, a) -> IntMap a -> IntMap a+add_C comb (x, y) t = add_C' comb x y t+add_C' :: (a->a->a) -> Int -> a -> IntMap a -> IntMap a+add_C' comb x y Nil = Leaf x y+add_C' comb x y (Leaf x' y') =+	if x == x' then+	    Leaf x (comb y y')+	else+	    add_C' comb x y (add_C' comb x' y' (Fork Nil Nil))+add_C' comb x y (Fork l r) =+	if odd x then+	    Fork l (add_C' comb (x `div` 2) y r)+	else+	    Fork (add_C' comb (x `div` 2) y l) r++(//) :: IntMap a -> [(Int, a)] -> IntMap a+t // [] = t+t // ((x,y):xys) = add' x y t // xys++instance Functor IntMap where+    fmap f Nil = Nil+    fmap f (Leaf x y) = Leaf x (f y)+    fmap f (Fork l r) = Fork (fmap f l) (fmap f r)++delete :: Int -> IntMap a -> IntMap a+delete x Nil           = Nil+delete x t@(Leaf x' y) = if x == x' then Nil else t+delete x (Fork l r)    = if odd x then+                             fork l (delete (x `div` 2) r)+			 else+			     fork (delete (x `div` 2) l) r++deleteMany :: [Int] -> IntMap a -> IntMap a+deleteMany is s = Prelude.foldr delete s is++fork Nil        Nil        = Nil+fork Nil        (Leaf x y) = Leaf (x*2+1) y+fork (Leaf x y) Nil        = Leaf (x*2) y+fork l          r          = Fork l r++foldr :: ((Int, a) -> b -> b) -> b -> IntMap a -> b+foldr f z Nil = z+foldr f z (Leaf x y) = f (x,y) z+foldr f z (Fork l r) = foldr g (foldr h z r) l+    where g (x,y) z = f (2*x,y) z+          h (x,y) z = f (2*x+1,y) z++imap :: ((Int, a) -> (Int, b)) -> IntMap a -> IntMap b+imap f t = foldr (add . f) empty t++filter :: ((Int, a) -> Bool) -> IntMap a -> IntMap a+filter p t = foldr (\x l -> if p x then add x l else l) empty t
+ tools/base/tests/HbcLibraries/IntSet.hs view
@@ -0,0 +1,129 @@+-- Copyright (c) 1982-1999 Lennart Augustsson, Thomas Johnsson+-- See LICENSE for the full license.+--+module IntSet (+	IntSet,+	empty, singleton, union, unionMany, add, addMany,+	intersect, delete, deleteMany, minus, +	-- map, partition, filter, foldl, foldr,+	toList, fromList,+	length, +	null, isSingleton, intersecting, isSubsetOf, elem+	-- replaceMaybe, substitute+	) where+import Prelude hiding (null,length,elem)+import List(sort)++data IntSet = Nil | Leaf !Int | Fork !IntSet !IntSet+instance Show IntSet where+	--showsType _ = showString "IntSet"+	showsPrec _ Nil = showString "{}"+	showsPrec _ s = showString "{" . f (sort (toList s)) . showString "}"+		where f [x] = shows x+		      f (x:xs) = shows x . showString ", " . f xs++instance Eq IntSet where+	Nil == Nil = True+	Leaf x == Leaf x' = x == x'+	Fork l r == Fork l' r' = l == l' && r == r'+	_ == _ = False++empty :: IntSet+empty = Nil++singleton :: Int -> IntSet+singleton x = Leaf x++null :: IntSet -> Bool+null Nil = True+null (Leaf _) = False+null (Fork _ _) = False++add :: Int -> IntSet -> IntSet+add x Nil = Leaf x+add x s@(Leaf x') =+	if x == x' then+	    s+	else+	    add x (add x' (Fork Nil Nil))+add x (Fork l r) =+	if odd x then+	    Fork l (add (x `div` 2) r)+	else+	    Fork (add (x `div` 2) l) r++addMany :: [Int] -> IntSet -> IntSet+addMany is s = foldr add s is++elem :: Int -> IntSet -> Bool+elem x Nil = False+elem x (Leaf x') = x == x'+elem x (Fork l r) =+	if odd x then+	    elem (x `div` 2) r+	else+	    elem (x `div` 2) l++union :: IntSet -> IntSet -> IntSet+union Nil t = t+union (Leaf x) t = add x t+union t Nil = t+union t (Leaf x) = add x t+union (Fork l r) (Fork l' r') = Fork (union l l') (union r r')++unionMany :: [IntSet] -> IntSet+unionMany ss = foldr union empty ss++delete :: Int -> IntSet -> IntSet+delete x Nil = Nil+delete x t@(Leaf x') = if x == x' then Nil else t+delete x (Fork l r) =+	if odd x then+	    fork l (delete (x `div` 2) r)+	else+	    fork (delete (x `div` 2) l) r++deleteMany :: [Int] -> IntSet -> IntSet+deleteMany is s = foldr delete s is++fork Nil Nil = Nil+fork Nil (Leaf x) = Leaf (x*2+1)+fork (Leaf x) Nil = Leaf (x*2)+fork l r = Fork l r++intersect :: IntSet -> IntSet -> IntSet+intersect Nil _ = Nil+intersect t@(Leaf x) t' = if elem x t' then t else Nil+intersect _ Nil = Nil+intersect t t'@(Leaf x) = if elem x t then t' else Nil+intersect (Fork l r) (Fork l' r') = fork (intersect l l') (intersect r r')++fromList :: [Int] -> IntSet+fromList xs = foldr add empty xs++toList :: IntSet -> [Int]+toList Nil = []+toList (Leaf x) = [x]+toList (Fork l r) = map (2*) (toList l) ++ map ((1+).(2*)) (toList r)++isSubsetOf :: IntSet -> IntSet -> Bool+isSubsetOf Nil _ = True+isSubsetOf (Leaf x) t = elem x t+isSubsetOf (Fork l r) (Fork l' r') = isSubsetOf l l' && isSubsetOf r r'+isSubsetOf _ _ = False++minus :: IntSet -> IntSet -> IntSet+minus t Nil = t+minus t (Leaf x) = delete x t+minus Nil _ = Nil+minus t@(Leaf x) t' = if elem x t' then Nil else t+minus (Fork l r) (Fork l' r') = fork (minus l l') (minus r r')++length :: IntSet -> Int+length Nil = 0+length (Leaf _) = 1+length (Fork l r) = length l + length r++isSingleton s = length s == 1++intersecting x y = not (null (intersect x y))
+ tools/base/tests/HbcLibraries/ListUtil.hs view
@@ -0,0 +1,144 @@+module ListUtil{-(+	assoc, concatMap, unfoldr, mapAccuml, union, intersection,+	chopList, assocDef, lookup, module Maybe,+        rept, tails, groupEq, group, readListLazily, nubEq, elemEq,+	mix, mapFst,mapSnd)-} where++--   Now report says that it is not ok to hide not exported entries+import Prelude -- hiding (unfoldr) +               +import Maybe+import List hiding (union,tails,unfoldr)++breakAt :: (Eq a) => a -> [a] -> ([a], [a])+breakAt _ [] = ([], [])+breakAt x (x':xs) =+	if x == x' then+	    ([], xs)+	else+	    let (ys, zs) = breakAt x xs+	    in  (x':ys, zs)++-- Read a list lazily (in contrast with reads which requires+-- to see the ']' before returning the list.+readListLazily :: (Read a) => String -> [a]+readListLazily cs = +    case lex cs of+      [("[",cs)] -> readl' cs+      _          -> error "No leading '['"+    where readl' cs  =+                case reads cs of+                  [(x,cs)]  -> x : readl cs+                  []        -> error "No parse for list element"+                  _         -> error "Ambigous parse for list element"+          readl cs =+                case lex cs of+                  [("]",_)]  -> []+                  [(",",cs)] -> readl' cs+                  _          -> error "No ',' or ']'"++-- Lookup an item in an association list.  Apply a function to it if it is found, otherwise return a default value.+assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b+assoc f d [] x                       = d+assoc f d ((x',y):xys) x | x' == x   = f y+                         | otherwise = assoc f d xys x++-- Repeatedly extract (and transform) values until a predicate hold.  Return the list of values.+unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]+unfoldr f p x | p x       = []+	      | otherwise = y:unfoldr f p x'+			      where (y, x') = f x++-- Map, but plumb a state through the map operation.+mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccuml f s []     = (s, [])+mapAccuml f s (x:xs) = (s'', y:ys)+		       where (s',  y)  = f s x+			     (s'', ys) = mapAccuml f s' xs++-- Union of sets as lists.+union :: (Eq a) => [a] -> [a] -> [a]+union xs ys = xs ++ (ys \\ xs)++-- Intersection of sets as lists.+intersection :: (Eq a) => [a] -> [a] -> [a]+--intersection xs ys = [x | x<-xs, x `elem` ys]+intersection xs ys = filter (\x -> x `elem` ys) xs++--- Functions derived from those above++chopList :: ([a] -> (b, [a])) -> [a] -> [b]+chopList f l = unfoldr f null l++assocDef :: (Eq a) => [(a, b)] -> b -> a -> b+assocDef l d x = assoc id d l x++--lookup :: (Eq a) => [(a, b)] -> a -> Maybe b+--lookup l x = assoc (\x -> Just x) Nothing l x++-- Repeat an element n times+--rept :: (Integral a) => a -> b -> [b]+rept 0 _ = []+rept n x = x : rept (n-1) x+--rept n x = if n<=0 then [] else x:rept (n-1) x++-- Take all the tails+tails :: [a] -> [[a]]+tails []         = []+tails xxs@(_:xs) = xxs : tails xs++{-+-- group list elements according to an equality predicate+groupEq :: (a->a->Bool) -> [a] -> [[a]]+groupEq eq xs = chopList f xs+		where f xs@(x:_) = span (eq x) xs++group :: (Eq a) => [a] -> [[a]]+group xs = groupEq (==) xs++-- Read a list lazily (in contrast with reads which requires+-- to see the ']' before returning the list.+readListLazily :: (Text a) => String -> [a]+readListLazily cs = +    case lex cs of+      [("[",cs)] -> readl' cs+      _          -> error "No leading '['"+    where readl' cs  =+                case reads cs of+                  [(x,cs)]  -> x : readl cs+                  []        -> error "No parse for list element"+                  _         -> error "Ambigous parse for list element"+          readl cs =+                case lex cs of+                  [("]",_)]  -> []+                  [(",",cs)] -> readl' cs+                  _          -> error "No ',' or ']'"+++nubEq :: (a->a->Bool) -> [a] -> [a]+nubEq eq l = nub' l []+	where nub' [] _	    = []+	      nub' (x:xs) l = if elemEq eq x l then nub' xs l else x : nub' xs (x:l)+-}+elemEq :: (a->a->Bool) -> a -> [a] -> Bool+elemEq eq _ []	   = False+elemEq eq x (y:ys) = eq x y || elemEq eq x ys++{-+--{-# SPECIALIZE average :: [Float] -> Float, [Double] -> Double #-}+average :: (Fractional a) => [a] -> a+average xs = f xs 0 0+	where f []     s l = s / fromInt l+	      f (x:xs) s l = f xs (s+x) (l+1)+fromInt = id+-}++mix [] y = []+mix [x] y = x+mix (x:xs) y = x ++ y ++ mix xs y++mapFst f [] = []+mapFst f ((x,y):zs) = (f x,y):mapFst f zs++mapSnd f [] = []+mapSnd f ((x,y):zs) = (x,f y):mapSnd f zs
+ tools/base/tests/HbcLibraries/OrdMap.hs view
@@ -0,0 +1,172 @@+-- Copyright (c) 1982-1999 Lennart Augustsson, Thomas Johnsson+-- See LICENSE for the full license.+--+module OrdMap(+	OrdMap,+	empty, singleton, union, unionMany, add, (//),+	-- addKeep, union_C, unionMany_C, addMany_C, add_C,+	-- intersect, delete, deleteMany, minus, +	-- partition, filter, foldl, foldr+	toList, fromList,+	length,+	null, isSingleton,+	-- intersecting, subset+	elems, indices,+	--(!),+	lookup, lookupWithDefault --, lookupWithContinuation+	) where+import Prelude hiding (lookup,length,null)+	+-- @@ Finite mappings with ordered keys.++-- Red-Black trees.+-- Implementation based on work by Norris Boyd, Andrew W. Appel,+-- David R. Tarditi, and Stephen J. Bevan.++data Colour = Red | Black++data OrdMap a b+    = Empty+    | Node a b Colour (OrdMap a b) (OrdMap a b)++instance (Ord a, Show a, Show b) => Show (OrdMap a b) where+{-  #ifdef __HBC__+	showsType x = showString "(OrdMap " . showsType (f x) . showString " " . showsType (g x) . showString ")"+		where f :: (Ord a) => OrdMap a b -> a+		      f _ = error "OrdMap.f"+		      g :: (Ord a) => OrdMap a b -> b+		      g _ = error "OrdMap.g"+-}+-- #else+        showsPrec _ om = showString "<OrdMap>"+-- #endif++instance (Ord a, Eq b) => Eq (OrdMap a b) where+	x == y  =  toList x == toList y++rbiR :: a -> b -> OrdMap a b -> OrdMap a b -> OrdMap a b+rbiR k v (Node sk sv Red sl@(Node _ _ Red _ _) sr) (Node lk lv Red ll lr) =+    Node k v Red (Node lk lv Black ll lr) (Node sk sv Black sl sr)++rbiR k v (Node sk sv Red sl sr@(Node _ _ Red _ _)) (Node lk lv Red ll lr) =+    Node k v Red (Node lk lv Black ll lr) (Node sk sv Black sl sr)++rbiR k v (Node sk sv Red sl@(Node slk slv Red sll slr) sr) l =+    Node slk slv Black (Node k v Red l sll) (Node sk sv Red slr sr)++rbiR k v (Node sk sv Red sl sr@(Node _ _ Red _ _)) l =+    Node sk sv Black (Node k v Red l sl) sr++rbiR k v t l = Node k v Black l t++rbiL :: a -> b -> OrdMap a b -> OrdMap a b -> OrdMap a b+rbiL k v (Node lk lv Red ll lr@(Node _ _ Red _ _)) (Node rk rv Red rl rr) =+    Node k v Red (Node lk lv Black ll lr) (Node rk rv Black rl rr)++rbiL k v (Node lk lv Red ll@(Node _ _ Red _ _) lr) (Node rk rv Red rl rr) =+    Node k v Red (Node lk lv Black ll lr) (Node rk rv Black rl rr)++rbiL k v (Node lk lv Red ll lr@(Node lrk lrv Red lrl lrr)) r =+    Node lrk lrv Black (Node lk lv Red ll lrl) (Node k v Red lrr r)++rbiL k v (Node lk lv Red ll@(Node llk llv Red lll llr) lr) r =+    Node lk lv Black ll (Node k v Red lr r)++rbiL k v t r = Node k v Black t r++rbi :: (Ord a) => a -> b -> OrdMap a b -> OrdMap a b+rbi e v Empty = Node e v Red Empty Empty+rbi e v t@(Node k w Black l r) =+	if e <= k then+	    if e == k then+		Node e v Black l r+	    else+		rbiL k w (rbi e v l) r+	else+	    rbiR k w (rbi e v r) l+rbi e v t@(Node k w Red l r) =+	if e <= k then+	    if e == k then+		Node e v Red l r+	    else+		Node k w Red (rbi e v l) r+	else+	    Node k w Red l (rbi e v r)++-- Empty table.+empty :: OrdMap a b+empty = Empty++singleton :: (Ord a) => (a, b) -> OrdMap a b+singleton (k, v) = Node k v Black Empty Empty++null :: OrdMap a b -> Bool+null Empty = True+null _ = False++length :: OrdMap a b -> Int+length Empty = 0+length (Node _ _ _ l r) = 1 + length l + length r++isSingleton :: OrdMap a b -> Bool+isSingleton (Node _ _ _ Empty Empty) = True+isSingleton _ = False++elems :: OrdMap a b -> [b]+elems Empty = []+elems (Node k v _ l r) = elems l ++ v : elems r++indices :: OrdMap a b -> [a]+indices Empty = []+indices (Node k v _ l r) = indices l ++ k : indices r++union :: (Ord a) => OrdMap a b -> OrdMap a b -> OrdMap a b+union t1 t2 = union' t1 (toList t2)+union' t [] = t+union' t (xy:xys) = union' (add xy t) xys++unionMany :: (Ord a) => [OrdMap a b] -> OrdMap a b+unionMany = foldr union empty++-- Insert an element overwriting an existing one with the same key.+add :: (Ord a) => (a,  b) -> OrdMap a b -> OrdMap a b+add (e, v) t =+    case rbi e v t of+        Node k v Red l@(Node _ _ Red _ _) r -> Node k v Black l r+        Node k v Red l r@(Node _ _ Red _ _) -> Node k v Black l r+        x                                   -> x++(//) :: (Ord a) => OrdMap a b -> [(a, b)] -> OrdMap a b+t // [] = t+t // (xy:xys) = add xy t // xys++-- Look up an element.+lookup :: (Ord a) => a -> OrdMap a b -> Maybe b+lookup _ Empty = Nothing+lookup e (Node k v _ l r) =+	if e <= k then+	    if e == k then Just v+	    else lookup e l+	else lookup e r++-- Map a function over the values.+instance (Ord a) => Functor (OrdMap a) where+    --map :: (b->c) -> OrdMap a b -> OrdMap a c+    fmap f Empty = Empty+    fmap f (Node k v c l r) = Node k (f v) c (fmap f l) (fmap f r)++lookupWithDefault :: (Ord a) => OrdMap a b -> b -> a -> b+lookupWithDefault Empty d _ = d+lookupWithDefault (Node k v _ l r) d e =+	if e <= k then +	    if e == k then v+	    else lookupWithDefault l d e+	else lookupWithDefault r d e++fromList :: (Ord a) => [(a,b)] -> OrdMap a b+fromList l = union' empty l++toList :: OrdMap a b -> [(a, b)]+toList Empty = []+toList (Node k v _ l r) = toList l ++ (k,v) : toList r+
+ tools/base/tests/HbcLibraries/OrdSet.hs view
@@ -0,0 +1,143 @@+-- Copyright (c) 1982-1999 Lennart Augustsson, Thomas Johnsson+-- See LICENSE for the full license.+--+module OrdSet (+	OrdSet,+	empty, singleton, union, unionMany, add, addMany,+	-- intersect, delete, deleteMany, minus, +	-- map, partition, filter, foldl, foldr,+	toList, fromList,+	length, +	null, isSingleton, +	-- intersecting, isSubsetOf, +	elem+	-- replaceMaybe, substitute+	) where+import Prelude hiding (null,length,elem)++-- @@ Sets of ordered items.++-- Red-Black trees.+-- Implementation based on work by Norris Boyd, Andrew W. Appel,+-- David R. Tarditi, and Stephen J. Bevan.++data Colour = Red | Black deriving (Eq)++data OrdSet a+    = Empty+    | Node a Colour (OrdSet a) (OrdSet a)++instance (Eq a) => Eq (OrdSet a) where -- different trees may represent equal sets (XX ?)+    s1 == s2 = toList s1 == toList s2++instance (Ord a, Show a) => Show (OrdSet a) where+	showsPrec p x = showString "OrdSet:" . showsPrec p (toList x)+{-+	showsType x = showString "(OrdSet " . showsType (f x) . showString ")"+		where f :: (Ord a) => OrdSet a -> a+		      f _ = error "OrdSet.f"+-}+rbiR :: a -> OrdSet a -> OrdSet a -> OrdSet a+rbiR k (Node sk Red sl@(Node _ ed _ _) sr) (Node lk Red ll lr) =+    Node k Red (Node lk Black ll lr) (Node sk Black sl sr)++rbiR k (Node sk Red sl sr@(Node _ Red _ _)) (Node lk Red ll lr) =+    Node k Red (Node lk Black ll lr) (Node sk Black sl sr)++rbiR k (Node sk Red sl@(Node slk Red sll slr) sr) l =+    Node slk Black (Node k Red l sll) (Node sk Red slr sr)++rbiR k (Node sk Red sl sr@(Node _ Red _ _)) l =+    Node sk Black (Node k Red l sl) sr++rbiR k t l = Node k Black l t++rbiL :: a -> OrdSet a -> OrdSet a -> OrdSet a+rbiL k (Node lk Red ll lr@(Node _ Red _ _)) (Node rk Red rl rr) =+    Node k Red (Node lk Black ll lr) (Node rk Black rl rr)++rbiL k (Node lk Red ll@(Node _ Red _ _) lr) (Node rk Red rl rr) =+    Node k Red (Node lk Black ll lr) (Node rk Black rl rr)++rbiL k (Node lk Red ll lr@(Node lrk Red lrl lrr)) r =+    Node lrk Black (Node lk Red ll lrl) (Node k Red lrr r)++rbiL k (Node lk Red ll@(Node llk Red lll llr) lr) r =+    Node lk Black ll (Node k Red lr r)++rbiL k t r = Node k Black t r++rbi :: (Ord a) => a -> OrdSet a -> OrdSet a+rbi e Empty = Node e Red Empty Empty+rbi e t@(Node k Black l r) =+	if e <= k then+	    if e == k then+		Node e Black l r+	    else+		rbiL k (rbi e l) r+	else+	    rbiR k (rbi e r) l+rbi e t@(Node k Red l r) =+	if e <= k then+	    if e == k then+		Node e Red l r+	    else+		Node k Red (rbi e l) r+	else+	    Node k Red l (rbi e r)++-- Empty table.+empty :: OrdSet a+empty = Empty++singleton :: a -> OrdSet a+singleton k = Node k Black Empty Empty++-- XXX awful!+union :: (Ord a) => OrdSet a -> OrdSet a -> OrdSet a+union t1 t2 =+	f t2 (toList' t1 [])+	where f t [] = t+	      f t (x:xs) =+		case add x t of	-- just to force evaluation to avoid space leak+		Empty -> error "union"+		t' -> f t' xs++unionMany :: (Ord a) => [OrdSet a] -> OrdSet a+unionMany ts = foldr union empty ts++add :: (Ord a) => a -> OrdSet a -> OrdSet a+add e t =+    case rbi e t of+        Node k Red l@(Node _ Red _ _) r -> Node k Black l r+        Node k Red l r@(Node _ Red _ _) -> Node k Black l r+        x                               -> x++addMany :: (Ord a) => [a] -> OrdSet a -> OrdSet a+addMany is s = foldr add s is++-- Look up an element.+elem :: (Ord a) => a -> OrdSet a -> Bool+elem _ Empty = False+elem e (Node k _ l r) =+	if e <= k then+	    e == k || elem e l+	else elem e r++fromList :: (Ord a) => [a] -> OrdSet a+fromList l = foldr add Empty l++toList t = toList' t []+toList' Empty xs = xs+toList' (Node k _ l r) xs = toList' l (k : toList' r xs)++null Empty = True+null _ = False++isSingleton :: OrdSet a -> Bool+isSingleton (Node _ _ Empty Empty) = True+isSingleton _ = False++length :: OrdSet a -> Int+length Empty = 0+length (Node _ _ l r) = 1 + length l + length r
+ tools/base/tests/HbcLibraries/Sort.hs view
@@ -0,0 +1,34 @@+module Sort(sort,sortLe) where++sort xs = sortLe (<=) xs++sortLe :: (a -> a -> Bool) -> [a] -> [a]+sortLe le l = tmsort le l++--sort :: (Ord a) => [a] -> [a]+--sort l = tmsort (<=) l++tmsort _ [] = []+tmsort _ [x] = [x]		-- just for speed+tmsort le (x:xs) = msort le (upSeq le xs [x])++upSeq _  [] xs = [reverse xs]+upSeq le (y:ys) xxs@(x:xs) =+	if le x y then+	    upSeq le ys (y:xxs)+	else+	    reverse xxs : upSeq le ys [y]++msort _ [xs] = xs+msort le xss = msort le (mergePairs le xss)++mergePairs le (xs:ys:xss) = merge le xs ys : mergePairs le xss+mergePairs _  xss = xss++merge le xxs@(x:xs) yys@(y:ys) =+	if le x y then+	    x:merge le xs yys+	else+	    y:merge le xxs ys+merge _  []         yys = yys+merge _  xxs        []  = xxs
+ tools/base/tests/HbcLibraries/Subsequences.hs view
@@ -0,0 +1,47 @@+module Subsequences(suffixes, prefixes, subsequences, permutations, subsequence, isPrefixOf, isSuffixOf, isSubsequenceOf, isPermutationOf, isPrefixOfBy, isSuffixOfBy, isSubsequenceOfBy, isPermutationOfBy, locateSubsequences) where++suffixes :: [a] -> [[a]]+suffixes []         = []+suffixes xxs@(_:xs) = xxs : suffixes xs++prefixes :: [a] -> [[a]]+prefixes [] = []+prefixes xs = xs : prefixes (init xs)++subsequences :: [a] -> [[a]]+subsequences = concatMap prefixes . suffixes++permutations :: [a] -> [[a]]+permutations [] = [[]]+permutations (x:xs) = [ zs | ys <- permutations xs, zs <- insertAll x ys ]+	where insertAll x [] = [[x]]+	      insertAll x yys@(y:ys) = (x:yys) : map (y:) (insertAll x ys)++subsequence :: Int -> Int -> [a] -> [a]+subsequence start end xs = take (end - start) (drop start xs)++isPrefixOf, isSuffixOf :: Eq a => [a] -> [a] -> Bool+isSubsequenceOf, isPermutationOf :: Eq a => [a] -> [a] -> Bool+isPrefixOf = isPrefixOfBy (==)+isSuffixOf = isSuffixOfBy (==)+isSubsequenceOf = isSubsequenceOfBy (==)+isPermutationOf = isPermutationOfBy (==)++isPrefixOfBy, isSuffixOfBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool+isSubsequenceOfBy, isPermutationOfBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool+isPrefixOfBy eq []     ys = True+isPrefixOfBy eq (x:xs) (y:ys) | eq x y = isPrefixOfBy eq xs ys+isPrefixOfBy eq _      _ = False+isSuffixOfBy eq xs ys = isPrefixOfBy eq (reverse xs) (reverse ys)+isSubsequenceOfBy eq xs ys = any (isPrefixOfBy eq xs) (suffixes ys)+isPermutationOfBy eq [] [] = True+isPermutationOfBy eq (x:xs) ys = del x ys []+	where del x [] _ = False+	      del x (y:ys) r =  if eq x y then isPermutationOfBy eq xs (reverse r ++ ys) +	      			else del x ys (y:r)++locateSubsequences   :: Eq a => [a] -> [a] -> [Int]+locateSubsequences xs ys = locateSubsequencesBy (==) xs ys+locateSubsequencesBy :: (a -> a -> Bool) -> [a] -> [a] -> [Int]+locateSubsequencesBy eq xs ys =+	map fst (filter (isPrefixOfBy eq xs . snd) (zip [0..] (suffixes ys)))
+ tools/base/tests/HbcLibraries/Trace.hs view
@@ -0,0 +1,2 @@+module Trace(trace) where+import Debug.Trace(trace)
+ tools/base/tests/NplusK.hs view
@@ -0,0 +1,29 @@+module NplusK where+++pow 0 = 1+pow (n+1) = 2*pow n+++f [x,1,y,2] = x+y++g (x,1,y,2) = x+y++(zero+1)=1++z = 0++seven = 6+1+  where n+1 = succ n++{-+instance Eq (a->b)+instance Show (a->b)++instance Num b => Num (a->b) where+  (f+g) x = f x + g x+  (f-g) x = f x - g x+  (f*g) x = f x * g x+  negate f = negate . f+  fromInteger = const . fromInteger+-}
+ tools/base/tests/Overlap.hs view
@@ -0,0 +1,54 @@+module Overlap where+--{-+class S a where+  s :: a -> String++instance S String where+  s _ = "String"++instance S a => S [a] where+  s ~[x] = "["++s x++"]"++instance S Char where+  s _ = "Char"++bla = s "Hello"++t x = s [x]++bla2 = t 'a'+--}++data T = T++instance Show [T] where  show _ = "Ts"++instance Show T where show _ = "T"++u :: Show a => a -> String+u x = show ([x],x)++u1 :: Show [a] => a -> String+u1 x = show [x]++bl3 = show [T,T]++bla4 = u T++class    Inject a b where inj :: a -> b+instance Inject a (Either a b) where inj = Left+instance Inject a b => Inject a (Either c b) where inj = Right . inj++type R = Either Char (Either Bool ())++i :: R+i = inj 'a'++b :: R+b = inj False++{-+Inject Bool (Either Char Bool)+<= Inject Bool Bool++-}
+ tools/base/tests/RecSyn.hs view
@@ -0,0 +1,20 @@+module RecSyn where++--type K = L+--type L a = Maybe (a,L a)++nil = Nothing+cons x xs = Just (x,xs)++single x = cons x nil++type Rec a = [Circ a]+--data Circ a = Tag [Rec a]+type Circ a = [Rec a]+++class A a => B a where+  b :: a->a++class B a => A a where+  a :: a->a
+ tools/base/tests/infix/A.hs view
@@ -0,0 +1,5 @@+module A where++infixl 6 +++a+b = undefined
+ tools/base/tests/infix/B.hs view
@@ -0,0 +1,7 @@+module B(module A,module B) where+import A+infixl 7 *+infixr 8 ^++a*b = undefined+a^b = undefined
+ tools/base/tests/infix/C.hs view
@@ -0,0 +1,18 @@+module C where+import B++x = a+b*c+d*e^f^g++y = (x , a+b*c+d*e^f^g)+  where+    infixl 0 ^+    a^b=undefined+    y = (x , a+b*c+d*e^f^g)++z = do x <- a+b*x^9+       (+) <- blaha+       x <- a+b*x^9+       let infix 4 ^+	   (^) = bla+       x <- a+b*x^9+       return x
+ tools/base/tests/lit.hs view
@@ -0,0 +1,4 @@+module Lit where++c = '\''+s = "as\""
+ tools/base/tests/literate.lhs view
@@ -0,0 +1,12 @@++> main = print message {-++How about literate text inside a nested comment?++> text in nested comment -}++> message = "Hello, \++How about literate text inside string literals with gaps++>   \world!"
+ tools/base/tests/pTest1.hs view
@@ -0,0 +1,22 @@++class P a where+ foo :: a +++instance P () where+  foo  = ()+++data (P a, Q a) => X a = B [a]++++a = B[()]++(a,b) = B[()]+[C a b, A (b,B c), c,b] = B[()]++f x y = x + y+x + y = x * y+(x+y) = 4+
+ tools/base/tests/prelude/Prelude.hs view
@@ -0,0 +1,1675 @@+{----------------------------------------------------------------------------+__   __ __  __  ____   ___    _______________________________________________+||   || ||  || ||  || ||__    Hugs 98: The Nottingham and Yale Haskell system+||___|| ||__|| ||__||  __||   Copyright (c) 1994-1999+||---||         ___||         World Wide Web: http://haskell.org/hugs+||   ||                       Report bugs to: hugs-bugs@haskell.org+||   || Version: February 1999_______________________________________________++ This is the Hugs 98 Standard Prelude, based very closely on the Standard+ Prelude for Haskell 98.++ WARNING: This file is an integral part of the Hugs source code.  Changes to+ the definitions in this file without corresponding modifications in other+ parts of the program may cause the interpreter to fail unexpectedly.  Under+ normal circumstances, you should not attempt to modify this file in any way!++-----------------------------------------------------------------------------+ The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the+ Yale Haskell Group, and the Oregon Graduate Institute of Science and+ Technology, 1994-1999, All rights reserved.  It is distributed as+ free software under the license in the file "License", which is+ included in the distribution.+----------------------------------------------------------------------------}++module Prelude {- (+--  module PreludeList,+    map, (++), concat, filter,+    head, last, tail, init, null, length, (!!),+    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,+    iterate, repeat, replicate, cycle,+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    lines, words, unlines, unwords, reverse, and, or,+    any, all, elem, notElem, lookup,+    sum, product, maximum, minimum, concatMap, +    zip, zip3, zipWith, zipWith3, unzip, unzip3,+--  module PreludeText, +    ReadS, ShowS,+    Read(readsPrec, readList),+    Show(show, showsPrec, showList),+    reads, shows, read, lex,+    showChar, showString, readParen, showParen,+--  module PreludeIO,+    FilePath, IOError, ioError, userError, catch,+    putChar, putStr, putStrLn, print,+    getChar, getLine, getContents, interact,+    readFile, writeFile, appendFile, readIO, readLn,+--  module Ix,+    Ix(range, index, inRange, rangeSize),+--  module Char,+    isAscii, isControl, isPrint, isSpace, isUpper, isLower,+    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,+    digitToInt, intToDigit,+    toUpper, toLower,+    ord, chr,+    readLitChar, showLitChar, lexLitChar,+--  module Numeric+    showSigned, showInt,+    readSigned, readInt,+    readDec, readOct, readHex, readSigned,+    readFloat, lexDigits, +--  module Ratio,+    Ratio, Rational, (%), numerator, denominator, approxRational,+--  Non-standard exports+    IO(..), IOResult(..), primExitWith, Addr,++    Bool(False, True),+    Maybe(Nothing, Just),+    Either(Left, Right),+    Ordering(LT, EQ, GT),+    Char, String, Int, Integer, Float, Double, IO,+--  List type: []((:), [])+--  (:),+--  Tuple types: (,), (,,), etc.+--  Trivial type: ()+--  Functions: (->)+    Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX+    Eq((==), (/=)),+    Ord(compare, (<), (<=), (>=), (>), max, min),+    Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,+         enumFromTo, enumFromThenTo),+    Bounded(minBound, maxBound),+--  Num((+), (-), (*), negate, abs, signum, fromInteger),+    Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),+    Real(toRational),+--  Integral(quot, rem, div, mod, quotRem, divMod, toInteger),+    Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),+--  Fractional((/), recip, fromRational),+    Fractional((/), recip, fromRational, fromDouble),+    Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,+             asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),+    RealFrac(properFraction, truncate, round, ceiling, floor),+    RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,+              encodeFloat, exponent, significand, scaleFloat, isNaN,+              isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2),+    Monad((>>=), (>>), return, fail),+    Functor(fmap),+    mapM, mapM_, sequence, sequence_, (=<<),+    maybe, either,+    (&&), (||), not, otherwise,+    subtract, even, odd, gcd, lcm, (^), (^^), +    fromIntegral, realToFrac,+    fst, snd, curry, uncurry, id, const, (.), flip, ($), until,+    asTypeOf, error, undefined,+    seq, ($!)+  ) -} where++-- Standard value bindings {Prelude} ----------------------------------------++infixr 9  .+infixl 9  !!+infixr 8  ^, ^^, **+infixl 7  *, /, `quot`, `rem`, `div`, `mod`, :%, %+infixl 6  +, -+--infixr 5  :    -- this fixity declaration is hard-wired into Hugs+infixr 5  +++infix  4  ==, /=, <, <=, >=, >, `elem`, `notElem`+infixr 3  &&+infixr 2  ||+infixl 1  >>, >>=+infixr 1  =<<+infixr 0  $, $!, `seq`++-- Equality and Ordered classes ---------------------------------------------++class Eq a where+    (==), (/=) :: a -> a -> Bool++    -- Minimal complete definition: (==) or (/=)+    x == y      = not (x/=y)+    x /= y      = not (x==y)++class (Eq a) => Ord a where+    compare                :: a -> a -> Ordering+    (<), (<=), (>=), (>)   :: a -> a -> Bool+    max, min               :: a -> a -> a++    -- Minimal complete definition: (<=) or compare+    -- using compare can be more efficient for complex types+    compare x y | x==y      = EQ+		| x<=y      = LT+		| otherwise = GT++    x <= y                  = compare x y /= GT+    x <  y                  = compare x y == LT+    x >= y                  = compare x y /= LT+    x >  y                  = compare x y == GT++    max x y   | x >= y      = x+	      | otherwise   = y+    min x y   | x <= y      = x+	      | otherwise   = y++class Bounded a where+    minBound, maxBound :: a+    -- Minimal complete definition: All++-- Numeric classes ----------------------------------------------------------++class (Eq a, Show a) => Num a where+    (+), (-), (*)  :: a -> a -> a+    negate         :: a -> a+    abs, signum    :: a -> a+    fromInteger    :: Integer -> a+    fromInt        :: Int -> a++    -- Minimal complete definition: All, except negate or (-)+    x - y           = x + negate y+    fromInt         = fromIntegral+    negate x        = 0 - x++class (Num a, Ord a) => Real a where+    toRational     :: a -> Rational++class (Real a, Enum a) => Integral a where+    quot, rem, div, mod :: a -> a -> a+    quotRem, divMod     :: a -> a -> (a,a)+    even, odd           :: a -> Bool+    toInteger           :: a -> Integer+    toInt               :: a -> Int++    -- Minimal complete definition: quotRem and toInteger+    n `quot` d           = q where (q,r) = quotRem n d+    n `rem` d            = r where (q,r) = quotRem n d+    n `div` d            = q where (q,r) = divMod n d+    n `mod` d            = r where (q,r) = divMod n d+    divMod n d           = if signum r == - signum d then (q-1, r+d) else qr+			   where qr@(q,r) = quotRem n d+    even n               = n `rem` 2 == 0+    odd                  = not . even+    toInt                = toInt . toInteger++class (Num a) => Fractional a where+    (/)          :: a -> a -> a+    recip        :: a -> a+    fromRational :: Rational -> a+    fromDouble   :: Double -> a++    -- Minimal complete definition: fromRational and ((/) or recip)+    recip x       = 1 / x+    fromDouble    = fromRational . toRational+    x / y         = x * recip y+++class (Fractional a) => Floating a where+    pi                  :: a+    exp, log, sqrt      :: a -> a+    (**), logBase       :: a -> a -> a+    sin, cos, tan       :: a -> a+    asin, acos, atan    :: a -> a+    sinh, cosh, tanh    :: a -> a+    asinh, acosh, atanh :: a -> a++    -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,+    --				    asinh, acosh, atanh+    pi                   = 4 * atan 1+    x ** y               = exp (log x * y)+    logBase x y          = log y / log x+    sqrt x               = x ** 0.5+    tan x                = sin x / cos x+    sinh x               = (exp x - exp (-x)) / 2+    cosh x               = (exp x + exp (-x)) / 2+    tanh x               = sinh x / cosh x+    asinh x              = log (x + sqrt (x*x + 1))+    acosh x              = log (x + sqrt (x*x - 1))+    atanh x              = (log (1 + x) - log (1 - x)) / 2++class (Real a, Fractional a) => RealFrac a where+    properFraction   :: (Integral b) => a -> (b,a)+    truncate, round  :: (Integral b) => a -> b+    ceiling, floor   :: (Integral b) => a -> b++    -- Minimal complete definition: properFraction+    truncate x        = m where (m,_) = properFraction x++    round x           = let (n,r) = properFraction x+			    m     = if r < 0 then n - 1 else n + 1+			in case signum (abs r - 0.5) of+			    -1 -> n+			    0  -> if even n then n else m+			    1  -> m++    ceiling x         = if r > 0 then n + 1 else n+			where (n,r) = properFraction x++    floor x           = if r < 0 then n - 1 else n+			where (n,r) = properFraction x++class (RealFrac a, Floating a) => RealFloat a where+    floatRadix       :: a -> Integer+    floatDigits      :: a -> Int+    floatRange       :: a -> (Int,Int)+    decodeFloat      :: a -> (Integer,Int)+    encodeFloat      :: Integer -> Int -> a+    exponent         :: a -> Int+    significand      :: a -> a+    scaleFloat       :: Int -> a -> a+    isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE+		     :: a -> Bool+    atan2	     :: a -> a -> a++    -- Minimal complete definition: All, except exponent, signficand,+    --				    scaleFloat, atan2+    exponent x        = if m==0 then 0 else n + floatDigits x+			where (m,n) = decodeFloat x+    significand x     = encodeFloat m (- floatDigits x)+			where (m,_) = decodeFloat x+    scaleFloat k x    = encodeFloat m (n+k)+			where (m,n) = decodeFloat x+    atan2 y x+      | x>0           = atan (y/x)+      | x==0 && y>0   = pi/2+      | x<0 && y>0    = pi + atan (y/x)+      | (x<=0 && y<0) ||+        (x<0 && isNegativeZero y) ||+        (isNegativeZero x && isNegativeZero y)+		      = - atan2 (-y) x+      | y==0 && (x<0 || isNegativeZero x)+		      = pi    -- must be after the previous test on zero y+      | x==0 && y==0  = y     -- must be after the other double zero tests+      | otherwise     = x + y -- x or y is a NaN, return a NaN (via +)++-- Numeric functions --------------------------------------------------------++subtract       :: Num a => a -> a -> a+subtract        = flip (-)++gcd            :: Integral a => a -> a -> a+gcd 0 0         = error "Prelude.gcd: gcd 0 0 is undefined"+gcd x y         = gcd' (abs x) (abs y)+		  where gcd' x 0 = x+			gcd' x y = gcd' y (x `rem` y)++lcm            :: (Integral a) => a -> a -> a+lcm _ 0         = 0+lcm 0 _         = 0+lcm x y         = abs ((x `quot` gcd x y) * y)++(^)            :: (Num a, Integral b) => a -> b -> a+x ^ 0           = 1+x ^ n  | n > 0  = f x (n-1) x+		  where f _ 0 y = y+			f x n y = g x n where+				  g x n | even n    = g (x*x) (n`quot`2)+					| otherwise = f x (n-1) (x*y)+_ ^ _           = error "Prelude.^: negative exponent"++(^^)           :: (Fractional a, Integral b) => a -> b -> a+x ^^ n          = if n >= 0 then x ^ n else recip (x^(-n))++fromIntegral   :: (Integral a, Num b) => a -> b+fromIntegral    = fromInteger . toInteger++realToFrac     :: (Real a, Fractional b) => a -> b+realToFrac      = fromRational . toRational++-- Index and Enumeration classes --------------------------------------------++class (Ord a) => Ix a where+    range                :: (a,a) -> [a]+    index                :: (a,a) -> a -> Int+    inRange              :: (a,a) -> a -> Bool+    rangeSize            :: (a,a) -> Int++    rangeSize r@(l,u)+             | l > u      = 0+             | otherwise  = index r u + 1++class Enum a where+    succ, pred           :: a -> a+    toEnum               :: Int -> a+    fromEnum             :: a -> Int+    enumFrom             :: a -> [a]              -- [n..]+    enumFromThen         :: a -> a -> [a]         -- [n,m..]+    enumFromTo           :: a -> a -> [a]         -- [n..m]+    enumFromThenTo       :: a -> a -> a -> [a]    -- [n,n'..m]++    -- Minimal complete definition: toEnum, fromEnum+    succ                  = toEnum . (1+)       . fromEnum+    pred                  = toEnum . subtract 1 . fromEnum+    enumFromTo x y        = map toEnum [ fromEnum x .. fromEnum y ]+    enumFromThenTo x y z  = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]++-- Read and Show classes ------------------------------------------------------++type ReadS a = String -> [(a,String)]+type ShowS   = String -> String++class Read a where+    readsPrec :: Int -> ReadS a+    readList  :: ReadS [a]++    -- Minimal complete definition: readsPrec+    readList   = readParen False (\r -> [pr | ("[",s) <- lex r,+					      pr      <- readl s ])+		 where readl  s = [([],t)   | ("]",t) <- lex s] +++				  [(x:xs,u) | (x,t)   <- reads s,+					      (xs,u)  <- readl' t]+		       readl' s = [([],t)   | ("]",t) <- lex s] +++				  [(x:xs,v) | (",",t) <- lex s,+					      (x,u)   <- reads t,+					      (xs,v)  <- readl' u]++class Show a where+    show      :: a -> String+    showsPrec :: Int -> a -> ShowS+    showList  :: [a] -> ShowS++    -- Minimal complete definition: show or showsPrec+    show x          = showsPrec 0 x ""+    showsPrec _ x s = show x ++ s+    showList []     = showString "[]"+    showList (x:xs) = showChar '[' . shows x . showl xs+		      where showl []     = showChar ']'+			    showl (x:xs) = showChar ',' . shows x . showl xs++-- Monad classes ------------------------------------------------------------++class Functor f where+    fmap :: (a -> b) -> (f a -> f b)++class Monad m where+    return :: a -> m a+    (>>=)  :: m a -> (a -> m b) -> m b+    (>>)   :: m a -> m b -> m b+    fail   :: String -> m a++    -- Minimal complete definition: (>>=), return+    p >> q  = p >>= \ _ -> q+    fail s  = error s++sequence       :: Monad m => [m a] -> m [a]+sequence []     = return []+sequence (c:cs) = do x  <- c+		     xs <- sequence cs+		     return (x:xs)++sequence_        :: Monad m => [m a] -> m ()+sequence_         = foldr (>>) (return ())++mapM             :: Monad m => (a -> m b) -> [a] -> m [b]+mapM f            = sequence . map f++mapM_            :: Monad m => (a -> m b) -> [a] -> m ()+mapM_ f           = sequence_ . map f++(=<<)            :: Monad m => (a -> m b) -> m a -> m b+f =<< x           = x >>= f++-- Evaluation and strictness ------------------------------------------------++primitive seq           :: a -> b -> b++primitive ($!)  :: (a -> b) -> a -> b+-- f $! x                = x `seq` f x++-- Trivial type -------------------------------------------------------------++-- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)++instance Eq () where+    () == ()  =  True++instance Ord () where+    compare () () = EQ++instance Ix () where+    range ((),())      = [()]+    index ((),()) ()   = 0+    inRange ((),()) () = True++instance Enum () where+    toEnum 0           = ()+    fromEnum ()        = 0+    enumFrom ()        = [()]+    enumFromThen () () = [()]++instance Read () where+    readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,+						   (")",t) <- lex s ])++instance Show () where+    showsPrec p () = showString "()"++instance Bounded () where+    minBound = ()+    maxBound = ()++-- Boolean type -------------------------------------------------------------++data Bool    = False | True+	       deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)++(&&), (||)  :: Bool -> Bool -> Bool+False && x   = False+True  && x   = x+False || x   = x+True  || x   = True++not         :: Bool -> Bool+not True     = False+not False    = True++otherwise   :: Bool+otherwise    = True++-- Character type -----------------------------------------------------------++data Char               -- builtin datatype of ISO Latin characters+type String = [Char]    -- strings are lists of characters++primitive primEqChar    :: Char -> Char -> Bool+primitive primCmpChar   :: Char -> Char -> Ordering++instance Eq Char  where (==)    = primEqChar+instance Ord Char where compare = primCmpChar++primitive primCharToInt :: Char -> Int+primitive primIntToChar :: Int -> Char++instance Enum Char where+    toEnum           = primIntToChar+    fromEnum         = primCharToInt+    enumFrom c       = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]+    enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]+		       where lastChar = if d < c then minBound else maxBound++instance Ix Char where+    range (c,c')      = [c..c']+    index b@(c,c') ci+       | inRange b ci = fromEnum ci - fromEnum c+       | otherwise    = error "Ix.index: Index out of range."+    inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'+			where i = fromEnum ci++instance Read Char where+    readsPrec p      = readParen False+			    (\r -> [(c,t) | ('\'':s,t) <- lex r,+					    (c,"\'")   <- readLitChar s ])+    readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,+					       (l,_)      <- readl s ])+	       where readl ('"':s)      = [("",s)]+		     readl ('\\':'&':s) = readl s+		     readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,+						      (cs,u) <- readl t ]+instance Show Char where+    showsPrec p '\'' = showString "'\\''"+    showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''++    showList cs   = showChar '"' . showl cs+		    where showl ""       = showChar '"'+			  showl ('"':cs) = showString "\\\"" . showl cs+			  showl (c:cs)   = showLitChar c . showl cs++instance Bounded Char where+    minBound = 'a'+    maxBound = 'z'++isAscii, isControl, isPrint, isSpace            :: Char -> Bool+isUpper, isLower, isAlpha, isDigit, isAlphaNum  :: Char -> Bool++isAscii c              =  fromEnum c < 128+isControl c            =  c < ' ' ||  c == '\DEL'+isPrint c              =  c >= ' ' &&  c <= '~'+isSpace c              =  c == ' ' || c == '\t' || c == '\n' ||+			  c == '\r' || c == '\f' || c == '\v'+isUpper c              =  c >= 'A'   &&  c <= 'Z'+isLower c              =  c >= 'a'   &&  c <= 'z'+isAlpha c              =  isUpper c  ||  isLower c+isDigit c              =  c >= '0'   &&  c <= '9'+isAlphaNum c           =  isAlpha c  ||  isDigit c++-- Digit conversion operations+digitToInt :: Char -> Int+digitToInt c+  | isDigit c            =  fromEnum c - fromEnum '0'+  | c >= 'a' && c <= 'f' =  fromEnum c - fromEnum 'a' + 10+  | c >= 'A' && c <= 'F' =  fromEnum c - fromEnum 'A' + 10+  | otherwise            =  error "Char.digitToInt: not a digit"++intToDigit :: Int -> Char+intToDigit i+  | i >= 0  && i <=  9   =  toEnum (fromEnum '0' + i)+  | i >= 10 && i <= 15   =  toEnum (fromEnum 'a' + i - 10)+  | otherwise            =  error "Char.intToDigit: not a digit"++toUpper, toLower      :: Char -> Char+toUpper c | isLower c  = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')+	  | otherwise  = c++toLower c | isUpper c  = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')+	  | otherwise  = c++ord         	      :: Char -> Int+ord         	       = fromEnum++chr                   :: Int -> Char+chr                    = toEnum++-- Maybe type ---------------------------------------------------------------++data Maybe a = Nothing | Just a+	       deriving (Eq, Ord, Read, Show)++maybe             :: b -> (a -> b) -> Maybe a -> b+maybe n f Nothing  = n+maybe n f (Just x) = f x++instance Functor Maybe where+    fmap f Nothing  = Nothing+    fmap f (Just x) = Just (f x)++instance Monad Maybe where+    Just x  >>= k = k x+    Nothing >>= k = Nothing+    return        = Just+    fail s        = Nothing++-- Either type --------------------------------------------------------------++data Either a b = Left a | Right b+		  deriving (Eq, Ord, Read, Show)++either              :: (a -> c) -> (b -> c) -> Either a b -> c+either l r (Left x)  = l x+either l r (Right y) = r y++-- Ordering type ------------------------------------------------------------++data Ordering = LT | EQ | GT+		deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)++-- Lists --------------------------------------------------------------------++-- data [a] = [] | a : [a] deriving (Eq, Ord)++instance Eq a => Eq [a] where+    []     == []     =  True+    (x:xs) == (y:ys) =  x==y && xs==ys+    _      == _      =  False++instance Ord a => Ord [a] where+    compare []     (_:_)  = LT+    compare []     []     = EQ+    compare (_:_)  []     = GT+    compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)++instance Functor [] where+    fmap = map++instance Monad [ ] where+    (x:xs) >>= f = f x ++ (xs >>= f)+    []     >>= f = []+    return x     = [x]+    fail s       = []++instance Read a => Read [a]  where+    readsPrec p = readList++instance Show a => Show [a]  where+    showsPrec p = showList++-- Tuples -------------------------------------------------------------------++-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)+-- etc..++-- Standard Integral types --------------------------------------------------++data Int      -- builtin datatype of fixed size integers+data Integer  -- builtin datatype of arbitrary size integers++primitive primEqInt      :: Int -> Int -> Bool+primitive primCmpInt     :: Int -> Int -> Ordering+primitive primEqInteger  :: Integer -> Integer -> Bool+primitive primCmpInteger :: Integer -> Integer -> Ordering++instance Eq  Int     where (==)    = primEqInt+instance Eq  Integer where (==)    = primEqInteger+instance Ord Int     where compare = primCmpInt+instance Ord Integer where compare = primCmpInteger++primitive primPlusInt      :: Int -> Int -> Int+primitive primMinusInt     :: Int -> Int -> Int+primitive primMulInt	   :: Int -> Int -> Int+primitive primNegInt	   :: Int -> Int+primitive primIntegerToInt :: Integer -> Int++instance Num Int where+    (+)           = primPlusInt+    (-)           = primMinusInt+    negate        = primNegInt+    (*)           = primMulInt+    abs           = absReal+    signum        = signumReal+    fromInteger   = primIntegerToInt+    fromInt x     = x++primitive primMinInt :: Int+primitive primMaxInt :: Int++instance Bounded Int where+    minBound = primMinInt+    maxBound = primMaxInt++primitive primPlusInteger  :: Integer -> Integer -> Integer+primitive primMinusInteger :: Integer -> Integer -> Integer+primitive primMulInteger   :: Integer -> Integer -> Integer+primitive primNegInteger   :: Integer -> Integer+primitive primIntToInteger :: Int -> Integer++instance Num Integer where+    (+)           = primPlusInteger+    (-)           = primMinusInteger+    negate        = primNegInteger+    (*)           = primMulInteger+    abs           = absReal+    signum        = signumReal+    fromInteger x = x+    fromInt       = primIntToInteger++absReal x    | x >= 0    = x+	     | otherwise = -x++signumReal x | x == 0    =  0+	     | x > 0     =  1+	     | otherwise = -1++instance Real Int where+    toRational x = toInteger x % 1++instance Real Integer where+    toRational x = x % 1++primitive primDivInt  :: Int -> Int -> Int+primitive primQuotInt :: Int -> Int -> Int+primitive primRemInt  :: Int -> Int -> Int+primitive primModInt  :: Int -> Int -> Int+primitive primQrmInt  :: Int -> Int -> (Int,Int)+primitive primEvenInt :: Int -> Bool++instance Integral Int where+    div       = primDivInt+    quot      = primQuotInt+    rem       = primRemInt+    mod       = primModInt+    quotRem   = primQrmInt+    even      = primEvenInt+    toInteger = primIntToInteger+    toInt x   = x++primitive primQrmInteger  :: Integer -> Integer -> (Integer,Integer)+primitive primEvenInteger :: Integer -> Bool++instance Integral Integer where+    quotRem     = primQrmInteger+    even        = primEvenInteger+    toInteger x = x+    toInt       = primIntegerToInt++instance Ix Int where+    range (m,n)          = [m..n]+    index b@(m,n) i+	   | inRange b i = i - m+	   | otherwise   = error "index: Index out of range"+    inRange (m,n) i      = m <= i && i <= n++instance Ix Integer where+    range (m,n)          = [m..n]+    index b@(m,n) i+	   | inRange b i = fromInteger (i - m)+	   | otherwise   = error "index: Index out of range"+    inRange (m,n) i      = m <= i && i <= n++instance Enum Int where+    toEnum               = id+    fromEnum             = id+    enumFrom       = numericEnumFrom+    enumFromTo     = numericEnumFromTo+    enumFromThen   = numericEnumFromThen+    enumFromThenTo = numericEnumFromThenTo++instance Enum Integer where+    toEnum         = primIntToInteger+    fromEnum       = primIntegerToInt+    enumFrom       = numericEnumFrom+    enumFromTo     = numericEnumFromTo+    enumFromThen   = numericEnumFromThen+    enumFromThenTo = numericEnumFromThenTo++numericEnumFrom        :: Real a => a -> [a]+numericEnumFromThen    :: Real a => a -> a -> [a]+numericEnumFromTo      :: Real a => a -> a -> [a]+numericEnumFromThenTo  :: Real a => a -> a -> a -> [a]+numericEnumFrom n            = n : (numericEnumFrom $! (n+1))+numericEnumFromThen n m      = iterate ((m-n)+) n+numericEnumFromTo n m        = takeWhile (<= m) (numericEnumFrom n)+numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')+                               where p | n' >= n   = (<= m)+				       | otherwise = (>= m)++primitive primShowsInt :: Int -> Int -> ShowS++instance Read Int where+    readsPrec p = readSigned readDec++instance Show Int where+    showsPrec   = primShowsInt++primitive primShowsInteger :: Int -> Integer -> ShowS++instance Read Integer where+    readsPrec p = readSigned readDec++instance Show Integer where+    showsPrec   = primShowsInteger++-- Standard Floating types --------------------------------------------------++data Float     -- builtin datatype of single precision floating point numbers+data Double    -- builtin datatype of double precision floating point numbers++primitive primEqFloat   :: Float -> Float -> Bool+primitive primCmpFloat  :: Float -> Float -> Ordering+primitive primEqDouble  :: Double -> Double -> Bool+primitive primCmpDouble :: Double -> Double -> Ordering++instance Eq  Float  where (==) = primEqFloat+instance Eq  Double where (==) = primEqDouble++instance Ord Float  where compare = primCmpFloat+instance Ord Double where compare = primCmpDouble++primitive primPlusFloat      :: Float -> Float -> Float+primitive primMinusFloat     :: Float -> Float -> Float+primitive primMulFloat       :: Float -> Float -> Float+primitive primNegFloat       :: Float -> Float+primitive primIntToFloat     :: Int -> Float+primitive primIntegerToFloat :: Integer -> Float++instance Num Float where+    (+)           = primPlusFloat+    (-)           = primMinusFloat+    negate        = primNegFloat+    (*)           = primMulFloat+    abs           = absReal+    signum        = signumReal+    fromInteger   = primIntegerToFloat+    fromInt       = primIntToFloat++primitive primPlusDouble      :: Double -> Double -> Double+primitive primMinusDouble     :: Double -> Double -> Double+primitive primMulDouble       :: Double -> Double -> Double+primitive primNegDouble       :: Double -> Double+primitive primIntToDouble     :: Int -> Double+primitive primIntegerToDouble :: Integer -> Double++instance Num Double where+    (+)         = primPlusDouble+    (-)         = primMinusDouble+    negate      = primNegDouble+    (*)         = primMulDouble+    abs         = absReal+    signum      = signumReal+    fromInteger = primIntegerToDouble+    fromInt     = primIntToDouble++instance Real Float where+    toRational = floatToRational++instance Real Double where+    toRational = doubleToRational++-- Calls to these functions are optimised when passed as arguments to+-- fromRational.+floatToRational  :: Float  -> Rational+doubleToRational :: Double -> Rational+floatToRational  x = realFloatToRational x +doubleToRational x = realFloatToRational x++realFloatToRational x = (m%1)*(b%1)^^n+			where (m,n) = decodeFloat x+			      b     = floatRadix x++primitive primDivFloat      :: Float -> Float -> Float+primitive doubleToFloat     :: Double -> Float++instance Fractional Float where+    (/)          = primDivFloat+    fromRational = primRationalToFloat+    fromDouble   = doubleToFloat++primitive primDivDouble :: Double -> Double -> Double++instance Fractional Double where+    (/)          = primDivDouble+    fromRational = primRationalToDouble+    fromDouble x = x++-- These primitives are equivalent to (and are defined using) +-- rationalTo{Float,Double}.  The difference is that they test to see+-- if their argument is of the form (fromDouble x) - which allows a much+-- more efficient implementation.+primitive primRationalToFloat  :: Rational -> Float+primitive primRationalToDouble :: Rational -> Double++-- These functions are used by Hugs - don't change their types.+rationalToFloat  :: Rational -> Float+rationalToDouble :: Rational -> Double+rationalToFloat  = rationalToRealFloat+rationalToDouble = rationalToRealFloat++rationalToRealFloat x = x'+ where x'    = f e+       f e   = if e' == e then y else f e'+	       where y      = encodeFloat (round (x * (1%b)^^e)) e+		     (_,e') = decodeFloat y+       (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'+			     / fromInteger (denominator x))+       b     = floatRadix x'++primitive primSinFloat	:: Float -> Float  +primitive primAsinFloat :: Float -> Float +primitive primCosFloat	:: Float -> Float+primitive primAcosFloat :: Float -> Float+primitive primTanFloat  :: Float -> Float+primitive primAtanFloat	:: Float -> Float+primitive primLogFloat  :: Float -> Float+primitive primExpFloat  :: Float -> Float+primitive primSqrtFloat :: Float -> Float++instance Floating Float where+    exp   = primExpFloat+    log   = primLogFloat+    sqrt  = primSqrtFloat+    sin   = primSinFloat+    cos   = primCosFloat+    tan   = primTanFloat+    asin  = primAsinFloat+    acos  = primAcosFloat+    atan  = primAtanFloat++primitive primSinDouble   :: Double -> Double+primitive primAsinDouble  :: Double -> Double+primitive primCosDouble   :: Double -> Double+primitive primAcosDouble  :: Double -> Double+primitive primTanDouble   :: Double -> Double+primitive primAtanDouble  :: Double -> Double+primitive primLogDouble   :: Double -> Double+primitive primExpDouble   :: Double -> Double+primitive primSqrtDouble  :: Double -> Double+++instance Floating Double where+    exp   = primExpDouble+    log   = primLogDouble+    sqrt  = primSqrtDouble+    sin   = primSinDouble+    cos   = primCosDouble+    tan   = primTanDouble+    asin  = primAsinDouble+    acos  = primAcosDouble+    atan  = primAtanDouble++instance RealFrac Float where+    properFraction = floatProperFraction++instance RealFrac Double where+    properFraction = floatProperFraction++floatProperFraction x+   | n >= 0      = (fromInteger m * fromInteger b ^ n, 0)+   | otherwise   = (fromInteger w, encodeFloat r n)+		   where (m,n) = decodeFloat x+			 b     = floatRadix x+			 (w,r) = quotRem m (b^(-n))++primitive primFloatRadix  :: Integer+primitive primFloatDigits :: Int+primitive primFloatMinExp :: Int+primitive primFloatMaxExp :: Int+primitive primFloatEncode :: Integer -> Int -> Float+primitive primFloatDecode :: Float -> (Integer, Int)++instance RealFloat Float where+    floatRadix  _ = primFloatRadix+    floatDigits _ = primFloatDigits+    floatRange  _ = (primFloatMinExp, primFloatMaxExp)+    encodeFloat = primFloatEncode+    decodeFloat = primFloatDecode+    isNaN       _ = False+    isInfinite  _ = False+    isDenormalized _ = False+    isNegativeZero _ = False+    isIEEE      _ = False++primitive primDoubleRadix  :: Integer+primitive primDoubleDigits :: Int+primitive primDoubleMinExp :: Int+primitive primDoubleMaxExp :: Int+primitive primDoubleEncode :: Integer -> Int -> Double+primitive primDoubleDecode :: Double -> (Integer, Int)++instance RealFloat Double where+    floatRadix  _ = primDoubleRadix+    floatDigits _ = primDoubleDigits+    floatRange  _ = (primDoubleMinExp, primDoubleMaxExp)+    encodeFloat   = primDoubleEncode+    decodeFloat   = primDoubleDecode+    isNaN       _ = False+    isInfinite  _ = False+    isDenormalized _ = False+    isNegativeZero _ = False+    isIEEE      _ = False++instance Enum Float where+    toEnum		  = primIntToFloat+    fromEnum		  = truncate+    enumFrom		  = numericEnumFrom+    enumFromThen	  = numericEnumFromThen+    enumFromTo n m	  = numericEnumFromTo n (m+1/2)+    enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)++instance Enum Double where+    toEnum		  = primIntToDouble+    fromEnum		  = truncate+    enumFrom		  = numericEnumFrom+    enumFromThen	  = numericEnumFromThen+    enumFromTo n m	  = numericEnumFromTo n (m+1/2)+    enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)++primitive primShowsFloat :: Int -> Float -> ShowS++instance Read Float where+    readsPrec p = readSigned readFloat++-- Note that showFloat in Numeric isn't used here+instance Show Float where+    showsPrec   = primShowsFloat++primitive primShowsDouble :: Int -> Double -> ShowS++instance Read Double where+    readsPrec p = readSigned readFloat++-- Note that showFloat in Numeric isn't used here+instance Show Double where+    showsPrec   = primShowsDouble++-- Some standard functions --------------------------------------------------++fst            :: (a,b) -> a+fst (x,_)       = x++snd            :: (a,b) -> b+snd (_,y)       = y++curry          :: ((a,b) -> c) -> (a -> b -> c)+curry f x y     = f (x,y)++uncurry        :: (a -> b -> c) -> ((a,b) -> c)+uncurry f p     = f (fst p) (snd p)++id             :: a -> a+id    x         = x++const          :: a -> b -> a+const k _       = k++(.)            :: (b -> c) -> (a -> b) -> (a -> c)+(f . g) x       = f (g x)++flip           :: (a -> b -> c) -> b -> a -> c+flip f x y      = f y x++($)            :: (a -> b) -> a -> b+f $ x           = f x++until          :: (a -> Bool) -> (a -> a) -> a -> a+until p f x     = if p x then x else until p f (f x)++asTypeOf       :: a -> a -> a+asTypeOf        = const++primitive error  :: String -> a++undefined        :: a+undefined | False = undefined++-- Standard functions on rational numbers {PreludeRatio} --------------------++data (Integral a) => Ratio a = a :% a deriving (Eq)+type Rational              = Ratio Integer++(%)                       :: Integral a => a -> a -> Ratio a+x % y                      = reduce (x * signum y) (abs y)++reduce                    :: Integral a => a -> a -> Ratio a+reduce x y | y == 0        = error "Ratio.%: zero denominator"+	   | otherwise     = (x `quot` d) :% (y `quot` d)+			     where d = gcd x y++numerator, denominator    :: Integral a => Ratio a -> a+numerator (x :% y)         = x+denominator (x :% y)       = y++instance Integral a => Ord (Ratio a) where+    compare (x:%y) (x':%y') = compare (x*y') (x'*y)++instance Integral a => Num (Ratio a) where+    (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')+    (x:%y) * (x':%y') = reduce (x*x') (y*y')+    negate (x :% y)   = negate x :% y+    abs (x :% y)      = abs x :% y+    signum (x :% y)   = signum x :% 1+    fromInteger x     = fromInteger x :% 1+    fromInt           = intToRatio++-- Hugs optimises code of the form fromRational (intToRatio x)+intToRatio :: Integral a => Int -> Ratio a+intToRatio x = fromInt x :% 1++instance Integral a => Real (Ratio a) where+    toRational (x:%y) = toInteger x :% toInteger y++instance Integral a => Fractional (Ratio a) where+    (x:%y) / (x':%y')   = (x*y') % (y*x')+    recip (x:%y)        = if x < 0 then (-y) :% (-x) else y :% x+    fromRational (x:%y) = fromInteger x :% fromInteger y+    fromDouble 		= doubleToRatio++-- Hugs optimises code of the form fromRational (doubleToRatio x)+doubleToRatio :: Integral a => Double -> Ratio a+doubleToRatio x+	    | n>=0      = (fromInteger m * fromInteger b ^ n) % 1+	    | otherwise = fromInteger m % (fromInteger b ^ (-n))+			  where (m,n) = decodeFloat x+				b     = floatRadix x++instance Integral a => RealFrac (Ratio a) where+    properFraction (x:%y) = (fromIntegral q, r:%y)+			    where (q,r) = quotRem x y++instance Integral a => Enum (Ratio a) where+    toEnum       = fromInt+    fromEnum     = truncate+    enumFrom     = numericEnumFrom+    enumFromThen = numericEnumFromThen++instance (Read a, Integral a) => Read (Ratio a) where+    readsPrec p = readParen (p > 7)+			    (\r -> [(x%y,u) | (x,s)   <- reads r,+					      ("%",t) <- lex s,+					      (y,u)   <- reads t ])++instance Integral a => Show (Ratio a) where+    showsPrec p (x:%y) = showParen (p > 7)+			     (shows x . showString " % " . shows y)++approxRational      :: RealFrac a => a -> a -> Rational+approxRational x eps = simplest (x-eps) (x+eps)+ where simplest x y | y < x     = simplest y x+		    | x == y    = xr+		    | x > 0     = simplest' n d n' d'+		    | y < 0     = - simplest' (-n') d' (-n) d+		    | otherwise = 0 :% 1+				  where xr@(n:%d) = toRational x+					(n':%d')  = toRational y+       simplest' n d n' d'        -- assumes 0 < n%d < n'%d'+		    | r == 0    = q :% 1+		    | q /= q'   = (q+1) :% 1+		    | otherwise = (q*n''+d'') :% n''+				  where (q,r)      = quotRem n d+					(q',r')    = quotRem n' d'+					(n'':%d'') = simplest' d' r' d r++-- Standard list functions {PreludeList} ------------------------------------++head             :: [a] -> a+head (x:_)        = x++last             :: [a] -> a+last [x]          = x+last (_:xs)       = last xs++tail             :: [a] -> [a]+tail (_:xs)       = xs++init             :: [a] -> [a]+init [x]          = []+init (x:xs)       = x : init xs++null             :: [a] -> Bool+null []           = True+null (_:_)        = False++(++)             :: [a] -> [a] -> [a]+[]     ++ ys      = ys+(x:xs) ++ ys      = x : (xs ++ ys)++map              :: (a -> b) -> [a] -> [b]+map f xs          = [ f x | x <- xs ]++filter           :: (a -> Bool) -> [a] -> [a]+filter p xs       = [ x | x <- xs, p x ]++concat           :: [[a]] -> [a]+concat            = foldr (++) []++length           :: [a] -> Int+length            = foldl' (\n _ -> n + 1) 0++(!!)             :: [b] -> Int -> b+(x:_)  !! 0       = x+(_:xs) !! n | n>0 = xs !! (n-1)+(_:_)  !! _       = error "Prelude.!!: negative index"+[]     !! _       = error "Prelude.!!: index too large"++foldl            :: (a -> b -> a) -> a -> [b] -> a+foldl f z []      = z+foldl f z (x:xs)  = foldl f (f z x) xs++foldl'           :: (a -> b -> a) -> a -> [b] -> a+foldl' f a []     = a+foldl' f a (x:xs) = (foldl' f $! f a x) xs++foldl1           :: (a -> a -> a) -> [a] -> a+foldl1 f (x:xs)   = foldl f x xs++scanl            :: (a -> b -> a) -> a -> [b] -> [a]+scanl f q xs      = q : (case xs of+			 []   -> []+			 x:xs -> scanl f (f q x) xs)++scanl1           :: (a -> a -> a) -> [a] -> [a]+scanl1 f (x:xs)   = scanl f x xs++foldr            :: (a -> b -> b) -> b -> [a] -> b+foldr f z []      = z+foldr f z (x:xs)  = f x (foldr f z xs)++foldr1           :: (a -> a -> a) -> [a] -> a+foldr1 f [x]      = x+foldr1 f (x:xs)   = f x (foldr1 f xs)++scanr            :: (a -> b -> b) -> b -> [a] -> [b]+scanr f q0 []     = [q0]+scanr f q0 (x:xs) = f x q : qs+		    where qs@(q:_) = scanr f q0 xs++scanr1           :: (a -> a -> a) -> [a] -> [a]+scanr1 f [x]      = [x]+scanr1 f (x:xs)   = f x q : qs+		    where qs@(q:_) = scanr1 f xs++iterate          :: (a -> a) -> a -> [a]+iterate f x       = x : iterate f (f x)++repeat           :: a -> [a]+repeat x          = xs where xs = x:xs++replicate        :: Int -> a -> [a]+replicate n x     = take n (repeat x)++cycle            :: [a] -> [a]+cycle []          = error "Prelude.cycle: empty list"+cycle xs          = xs' where xs'=xs++xs'++take                :: Int -> [a] -> [a]+take 0 _             = []+take _ []            = []+take n (x:xs) | n>0  = x : take (n-1) xs+take _ _             = error "Prelude.take: negative argument"++drop                :: Int -> [a] -> [a]+drop 0 xs            = xs+drop _ []            = []+drop n (_:xs) | n>0  = drop (n-1) xs+drop _ _             = error "Prelude.drop: negative argument"++splitAt               :: Int -> [a] -> ([a], [a])+splitAt 0 xs           = ([],xs)+splitAt _ []           = ([],[])+splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs+splitAt _ _            = error "Prelude.splitAt: negative argument"++takeWhile           :: (a -> Bool) -> [a] -> [a]+takeWhile p []       = []+takeWhile p (x:xs)+	 | p x       = x : takeWhile p xs+	 | otherwise = []++dropWhile           :: (a -> Bool) -> [a] -> [a]+dropWhile p []       = []+dropWhile p xs@(x:xs')+	 | p x       = dropWhile p xs'+	 | otherwise = xs++span, break         :: (a -> Bool) -> [a] -> ([a],[a])+span p []            = ([],[])+span p xs@(x:xs')+	 | p x       = (x:ys, zs)+	 | otherwise = ([],xs)+                       where (ys,zs) = span p xs'+break p              = span (not . p)++lines     :: String -> [String]+lines ""   = []+lines s    = let (l,s') = break ('\n'==) s+             in l : case s' of []      -> []+                               (_:s'') -> lines s''++words     :: String -> [String]+words s    = case dropWhile isSpace s of+		  "" -> []+		  s' -> w : words s''+			where (w,s'') = break isSpace s'++unlines   :: [String] -> String+unlines    = concatMap (\l -> l ++ "\n")++unwords   :: [String] -> String+unwords [] = []+unwords ws = foldr1 (\w s -> w ++ ' ':s) ws++reverse   :: [a] -> [a]+reverse    = foldl (flip (:)) []++and, or   :: [Bool] -> Bool+and        = foldr (&&) True+or         = foldr (||) False++any, all  :: (a -> Bool) -> [a] -> Bool+any p      = or  . map p+all p      = and . map p++elem, notElem    :: Eq a => a -> [a] -> Bool+elem              = any . (==)+notElem           = all . (/=)++lookup           :: Eq a => a -> [(a,b)] -> Maybe b+lookup k []       = Nothing+lookup k ((x,y):xys)+      | k==x      = Just y+      | otherwise = lookup k xys++sum, product     :: Num a => [a] -> a+sum               = foldl' (+) 0+product           = foldl' (*) 1++maximum, minimum :: Ord a => [a] -> a+maximum           = foldl1 max+minimum           = foldl1 min++concatMap        :: (a -> [b]) -> [a] -> [b]+concatMap f       = concat . map f++zip              :: [a] -> [b] -> [(a,b)]+zip               = zipWith  (\a b -> (a,b))++zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]+zip3              = zipWith3 (\a b c -> (a,b,c))++zipWith                  :: (a->b->c) -> [a]->[b]->[c]+zipWith z (a:as) (b:bs)   = z a b : zipWith z as bs+zipWith _ _      _        = []++zipWith3                 :: (a->b->c->d) -> [a]->[b]->[c]->[d]+zipWith3 z (a:as) (b:bs) (c:cs)+			  = z a b c : zipWith3 z as bs cs+zipWith3 _ _ _ _          = []++unzip                    :: [(a,b)] -> ([a],[b])+unzip                     = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])++unzip3                   :: [(a,b,c)] -> ([a],[b],[c])+unzip3                    = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))+				  ([],[],[])++-- PreludeText ----------------------------------------------------------------++reads        :: Read a => ReadS a+reads         = readsPrec 0++shows        :: Show a => a -> ShowS+shows         = showsPrec 0++read         :: Read a => String -> a+read s        =  case [x | (x,t) <- reads s, ("","") <- lex t] of+		      [x] -> x+		      []  -> error "Prelude.read: no parse"+		      _   -> error "Prelude.read: ambiguous parse"++showChar     :: Char -> ShowS+showChar      = (:)++showString   :: String -> ShowS+showString    = (++)++showParen    :: Bool -> ShowS -> ShowS+showParen b p = if b then showChar '(' . p . showChar ')' else p++showField    :: Show a => String -> a -> ShowS+showField m v = showString m . showChar '=' . shows v++readParen    :: Bool -> ReadS a -> ReadS a+readParen b g = if b then mandatory else optional+		where optional r  = g r ++ mandatory r+		      mandatory r = [(x,u) | ("(",s) <- lex r,+					     (x,t)   <- optional s,+					     (")",u) <- lex t    ]++readField    :: Read a => String -> ReadS a+readField m s0 = [ r | (t,  s1) <- lex s0, t == m,+                       ("=",s2) <- lex s1,+                       r        <- reads s2 ]++lex                    :: ReadS String+lex ""                  = [("","")]+lex (c:s) | isSpace c   = lex (dropWhile isSpace s)+lex ('\'':s)            = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,+					       ch /= "'"                ]+lex ('"':s)             = [('"':str, t)      | (str,t) <- lexString s]+			  where+			  lexString ('"':s) = [("\"",s)]+			  lexString s = [(ch++str, u)+						| (ch,t)  <- lexStrItem s,+						  (str,u) <- lexString t  ]++			  lexStrItem ('\\':'&':s) = [("\\&",s)]+			  lexStrItem ('\\':c:s) | isSpace c+			      = [("",t) | '\\':t <- [dropWhile isSpace s]]+			  lexStrItem s            = lexLitChar s++lex (c:s) | isSingle c  = [([c],s)]+	  | isSym c     = [(c:sym,t)         | (sym,t) <- [span isSym s]]+	  | isAlpha c   = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]+	  | isDigit c   = [(c:ds++fe,t)      | (ds,s)  <- [span isDigit s],+					       (fe,t)  <- lexFracExp s     ]+	  | otherwise   = []    -- bad character+		where+		isSingle c  =  c `elem` ",;()[]{}_`"+		isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:-~"+		isIdChar c  =  isAlphaNum c || c `elem` "_'"++		lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,+						      (e,u)  <- lexExp t    ]+		lexFracExp s       = [("",s)]++		lexExp (e:s) | e `elem` "eE"+			 = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",+						   (ds,u) <- lexDigits t] +++			   [(e:ds,t)   | (ds,t) <- lexDigits s]+		lexExp s = [("",s)]++lexDigits               :: ReadS String+lexDigits               =  nonnull isDigit++nonnull                 :: (Char -> Bool) -> ReadS String+nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]++lexLitChar              :: ReadS String+lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s] +	where+	lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]+        lexEsc ('^':c:s) | c >= '@' && c <= '_'    = [(['^',c],s)]+	lexEsc s@(d:_)   | isDigit d               = lexDigits s+        lexEsc s@(c:_)   | isUpper c+                          = let table = ('\DEL',"DEL") : asciiTab+			    in case [(mne,s') | (c, mne) <- table,+				 	        ([],s') <- [lexmatch mne s]]+			       of (pr:_) -> [pr]+			          []     -> []+	lexEsc _                                   = []+lexLitChar (c:s)        =  [([c],s)]+lexLitChar ""           =  []++isOctDigit c  =  c >= '0' && c <= '7'+isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'+			   || c >= 'a' && c <= 'f'++lexmatch                   :: (Eq a) => [a] -> [a] -> ([a],[a])+lexmatch (x:xs) (y:ys) | x == y  =  lexmatch xs ys+lexmatch xs     ys               =  (xs,ys)++asciiTab = zip ['\NUL'..' ']+	   ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",+	    "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",+	    "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",+	    "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",+	    "SP"]++readLitChar            :: ReadS Char+readLitChar ('\\':s)    = readEsc s+ where+       readEsc ('a':s)  = [('\a',s)]+       readEsc ('b':s)  = [('\b',s)]+       readEsc ('f':s)  = [('\f',s)]+       readEsc ('n':s)  = [('\n',s)]+       readEsc ('r':s)  = [('\r',s)]+       readEsc ('t':s)  = [('\t',s)]+       readEsc ('v':s)  = [('\v',s)]+       readEsc ('\\':s) = [('\\',s)]+       readEsc ('"':s)  = [('"',s)]+       readEsc ('\'':s) = [('\'',s)]+       readEsc ('^':c:s) | c >= '@' && c <= '_'+			= [(toEnum (fromEnum c - fromEnum '@'), s)]+       readEsc s@(d:_) | isDigit d+			= [(toEnum n, t) | (n,t) <- readDec s]+       readEsc ('o':s)  = [(toEnum n, t) | (n,t) <- readOct s]+       readEsc ('x':s)  = [(toEnum n, t) | (n,t) <- readHex s]+       readEsc s@(c:_) | isUpper c+			= let table = ('\DEL',"DEL") : asciiTab+			  in case [(c,s') | (c, mne) <- table,+					    ([],s') <- [lexmatch mne s]]+			     of (pr:_) -> [pr]+				[]     -> []+       readEsc _        = []+readLitChar (c:s)       = [(c,s)]++showLitChar               :: Char -> ShowS+showLitChar c | c > '\DEL' = showChar '\\' .+			     protectEsc isDigit (shows (fromEnum c))+showLitChar '\DEL'         = showString "\\DEL"+showLitChar '\\'           = showString "\\\\"+showLitChar c | c >= ' '   = showChar c+showLitChar '\a'           = showString "\\a"+showLitChar '\b'           = showString "\\b"+showLitChar '\f'           = showString "\\f"+showLitChar '\n'           = showString "\\n"+showLitChar '\r'           = showString "\\r"+showLitChar '\t'           = showString "\\t"+showLitChar '\v'           = showString "\\v"+showLitChar '\SO'          = protectEsc ('H'==) (showString "\\SO")+showLitChar c              = showString ('\\' : snd (asciiTab!!fromEnum c))++protectEsc p f             = f . cont+ where cont s@(c:_) | p c  = "\\&" ++ s+       cont s              = s++-- Unsigned readers for various bases+readDec, readOct, readHex :: Integral a => ReadS a+readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')+readOct = readInt  8 isOctDigit (\d -> fromEnum d - fromEnum '0')+readHex = readInt 16 isHexDigit hex+	  where hex d = fromEnum d -+			(if isDigit d+			   then fromEnum '0'+			   else fromEnum (if isUpper d then 'A' else 'a') - 10)++-- readInt reads a string of digits using an arbitrary base.  +-- Leading minus signs must be handled elsewhere.++readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a+readInt radix isDig digToInt s =+    [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)+	| (ds,r) <- nonnull isDig s ]++-- showInt is used for positive numbers only+showInt    :: Integral a => a -> ShowS+showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers"+            | otherwise =+              let (n',d) = quotRem n 10+		  r'     = toEnum (fromEnum '0' + fromIntegral d) : r+	      in  if n' == 0 then r' else showInt n' r'++readSigned:: Real a => ReadS a -> ReadS a+readSigned readPos = readParen False read'+		     where read' r  = read'' r +++				      [(-x,t) | ("-",s) <- lex r,+						(x,t)   <- read'' s]+			   read'' r = [(n,s)  | (str,s) <- lex r,+						(n,"")  <- readPos str]++showSigned    :: Real a => (a -> ShowS) -> Int -> a -> ShowS+showSigned showPos p x = if x < 0 then showParen (p > 6)+						 (showChar '-' . showPos (-x))+				  else showPos x++readFloat     :: RealFloat a => ReadS a+readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,+						       (k,t)   <- readExp s]+		 where readFix r = [(read (ds++ds'), length ds', t)+					| (ds, s) <- lexDigits r+                                        , (ds',t) <- lexFrac s   ]++                       lexFrac ('.':s) = lexDigits s+		       lexFrac s       = [("",s)]++		       readExp (e:s) | e `elem` "eE" = readExp' s+		       readExp s                     = [(0,s)]++		       readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]+		       readExp' ('+':s) = readDec s+		       readExp' s       = readDec s++-- Monadic I/O: --------------------------------------------------------------++--data IO a             -- builtin datatype of IO actions+data IOError            -- builtin datatype of IO error codes+type FilePath = String  -- file pathnames are represented by strings++instance Show (IO a) where+    showsPrec p f = showString "<<IO action>>"++primitive primbindIO             :: IO a -> (a -> IO b) -> IO b+primitive primretIO              :: a -> IO a+primitive catch                  :: IO a -> (IOError -> IO a) -> IO a+primitive ioError                :: IOError -> IO a+primitive putChar		 :: Char -> IO ()+primitive putStr		 :: String -> IO ()+primitive getChar   		 :: IO Char+primitive userError    		 :: String -> IOError++print     :: Show a => a -> IO ()+print      = putStrLn . show++putStrLn  :: String -> IO ()+putStrLn s = do putStr s+		putChar '\n'++getLine   :: IO String+getLine    = do c <- getChar+		if c=='\n' then return ""+			   else do cs <- getLine+				   return (c:cs)++-- raises an exception instead of an error+readIO          :: Read a => String -> IO a+readIO s         = case [x | (x,t) <- reads s, ("","") <- lex t] of+                        [x] -> return x+                        []  -> ioError (userError "PreludeIO.readIO: no parse")+                        _   -> ioError (userError +                                       "PreludeIO.readIO: ambiguous parse")++readLn          :: Read a => IO a+readLn           = do l <- getLine+                      r <- readIO l+                      return r++primitive getContents 		 :: IO String+primitive writeFile   		 :: FilePath -> String -> IO ()+primitive appendFile  		 :: FilePath -> String -> IO ()+primitive readFile    		 :: FilePath -> IO String++interact  :: (String -> String) -> IO ()+interact f = getContents >>= (putStr . f)++instance Functor IO where+    fmap f x = x >>= (return . f)++instance Monad IO where+    (>>=)  = primbindIO+    return = primretIO+++-- Hooks for primitives: -----------------------------------------------------+-- Do not mess with these!++data Addr     -- builtin datatype of C pointers++newtype IO a = IO ((IOError -> IOResult a) -> (a -> IOResult a) -> IOResult a)+data IOResult a +  = Hugs_ExitWith Int+  | Hugs_SuspendThread+  | Hugs_Error    IOError+  | Hugs_Return   a++hugsPutStr :: String -> IO ()+hugsPutStr  = putStr++hugsIORun  :: IO a -> Either Int a+hugsIORun m = performIO (runAndShowError m)+ where+  performIO       :: IO a -> Either Int a+  performIO (IO m) = case m Hugs_Error Hugs_Return of+	             Hugs_Return a   -> Right a+		     Hugs_ExitWith e -> Left  e+		     _               -> Left  1++  runAndShowError :: IO a -> IO a+  runAndShowError m =+    m `catch` \err -> do +	putChar '\n'+	putStr (ioeGetErrorString err)+	primExitWith 1 -- alternatively: (IO (\f s -> Hugs_SuspendThread))++primExitWith     :: Int -> IO a+primExitWith c    = IO (\ f s -> Hugs_ExitWith c)++primitive ioeGetErrorString                   :: IOError -> String++instance Show IOError where+  showsPrec p x = showString (ioeGetErrorString x)++primCompAux      :: Ord a => a -> a -> Ordering -> Ordering+primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT++primPmInt        :: Num a => Int -> a -> Bool+primPmInt n x     = fromInt n == x++primPmInteger    :: Num a => Integer -> a -> Bool+primPmInteger n x = fromInteger n == x++primPmFlt        :: Fractional a => Double -> a -> Bool+primPmFlt n x     = fromDouble n == x++-- The following primitives are only needed if (n+k) patterns are enabled:+primPmNpk        :: Integral a => Int -> a -> Maybe a+primPmNpk n x     = if n'<=x then Just (x-n') else Nothing+		    where n' = fromInt n++primPmSub        :: Integral a => Int -> a -> a+primPmSub n x     = x - fromInt n++-- End of Hugs standard prelude ----------------------------------------------
+ tools/base/tests/prelude/noPrelude.hs view
@@ -0,0 +1,1 @@+module Prelude where
+ tools/base/tests/prelude/p1.hs view
@@ -0,0 +1,143 @@+module TestPrelude1  where++infix  6  &&++++----------------- BOOLEANS +data Bool = True | False+otherwise = True++not True =  False +not False = True++True  && b = b+False && _ = False++instance Eq Bool where +   True  == True  = True+   False == False = True+   _     == _     = False+++instance Bounded Bool where+   minBound = True+   maxBound = False+++++------------------------------+class Eq a where+    (==), (/=) :: a -> a -> Bool++    -- Minimal complete definition: (==) or (/=)+    x == y      = not (x/=y)+    x /= y      = not (x==y)++++-------------------------- ORDERING+data Ordering  = EQ | LT | GT +instance Eq Ordering  where+   EQ == EQ = True+   LT == LT = True+   GT == GT = True+   _  == _  = False++---------------------------------------+++---------------------------------------- Ints+data Int+primitive primIntEq      :: Int -> Int -> Bool+primitive intPrimBinop   :: Int -> Int -> Int+primitive primCompareInt :: Int -> Int -> Ordering++instance Eq Int where+    i1 == i2 = primIntEq i1 i2++instance Num Int where+     x + y = intPrimBinop x y +     x * y = intPrimBinop x y+     abs x    = x+     signum x = x+instance Ord Int where+   compare x y = primCompareInt x y +------------------------------------------++++------------------------------------------- Integers+data Integer++primitive primIntegerEq      :: Integer -> Integer -> Bool+primitive integerPrimBinop   :: Integer -> Integer -> Integer+primitive primCompareInteger :: Integer -> Integer -> Ordering++instance Eq Integer where+    i1 == i2 = primIntegerEq i1 i2+++instance Num Integer where+     x + y = integerPrimBinop x y +     x * y = integerPrimBinop x y+     abs x    = x+     signum x = x++instance Ord Integer where+   compare x y = primCompareInteger x y +------------------------------------------------+++class (Eq a) => Ord a where+    compare                :: a -> a -> Ordering+    (<), (<=), (>=), (>)   :: a -> a -> Bool+    max, min               :: a -> a -> a++    -- Minimal complete definition: (<=) or compare+    -- using compare can be more efficient for complex types+    compare x y | x==y      = EQ+		| x<=y      = LT+		| otherwise = GT++    x <= y                  = compare x y /= GT+    x <  y                  = compare x y == LT+    x >= y                  = compare x y /= LT+    x >  y                  = compare x y == GT++    max x y   | x >= y      = x+	      | otherwise   = y+    min x y   | x <= y      = x+	      | otherwise   = y++class Bounded a where+    minBound, maxBound :: a+    -- Minimal complete definition: All++z = [1,2,3] == [1,2,3]+++-----------------------------+class (Eq a) => Num a where+    (+), (-), (*)  :: a -> a -> a+    negate         :: a -> a+    abs, signum    :: a -> a++    -- Minimal complete definition: All, except negate or (-)+    x - y           = x + negate y+    negate x        = 0 - x++++------------------------------- LIST+instance Eq a => Eq [a] where+    [] == [] = True+    (x:xs) == (y:ys) = (x==y) && (xs == ys)+    _  == _ = False+++--------------------------------------------------------+--------------------------------------------------------+--------------------------------------------------------+
+ tools/base/tests/scopeTest0.hs view
@@ -0,0 +1,15 @@+module ScopeTest0 where++id x = x++skk = id++bla = blaha++not True = False+not False = True++f = \ x -> \ x -> x+  where+    g = \ x -> x+    x = True
+ tools/base/tests/test1.hs view
@@ -0,0 +1,30 @@+++infixr 6 :<+infixl 5 +++infixl 9 **++data  Int = Z | S Int++data MyList a = Nil+              | a :< (MyList a)++Nil ++ x = x+(a :< as) ++ x = a :< (as ++ x)++Nil ** x = Nil+(a :< as) ** x = a :< (x ** as)++++class VC a where+   rpl :: a -> (MyList a)++instance VC a => VC (MyList a) where+  rpl x = (rpl x) :< rpl x++instance VC Int where+  rpl x = x :< (rpl x)++p12 = S (S Z)+q12 = rpl p12
+ tools/base/tests/tiAmbig.hs view
@@ -0,0 +1,11 @@+module TiAmbig where+++--f x = show (read x)++g = show . read+++four = 4++y = case undefined of 1 -> True
+ tools/base/tests/tiBig.hs view
@@ -0,0 +1,21 @@+module TiBig where+++-- Type checking the generated selector functions takes a lot of time.++data Big = B {x1,x2,x3,x4,x5,x6,x7,x8,x9,z1,z2,z3,z4,z5,z6,z7,z8,z9,+	      y1,y2,y3,y4,y5,y6,y7,y8,y9::Big}+++{-+f _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _+  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _+  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _+  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _+  _ _ _ _ _ _ _ _ _ x _ _ _ _ _ _ _ _ _ _+  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _+  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _+  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _+  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _+  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = x+-}
+ tools/base/tests/tiFields.hs view
@@ -0,0 +1,17 @@+module TiFields where+-- Type checking fields+++data R = A {a::Int} | B {b::Bool}++-- These are all type correct, but additional checks are needed to make+-- sure that labels are used in a sensible way...++upd r = r{a=1,b=False}++r = A{b=True,a=2}++upd' r@A{a=x} = r{b=x/=0}++f A{a=a,b=b} = (a,b)+g r = (a r,b r)
+ tools/base/tests/tiFun.hs view
@@ -0,0 +1,9 @@+module TiFun where++-- Some tests to make sure that (->) a b = a->b and (,) a b = (a,b).++f :: (->) a a+f = id++pair :: a -> b -> (,) a b+pair x y = (x,y)
+ tools/base/tests/tiHello.hs view
@@ -0,0 +1,1 @@+main = putStrLn "Hello, world!"
+ tools/base/tests/tiLit.hs view
@@ -0,0 +1,4 @@+module TiLit where++fac 0 = 1+fac n = n*fac(n-1)
+ tools/base/tests/tiPolyRec.hs view
@@ -0,0 +1,11 @@+module PolyRec where++data A a = A a (A a) | B (A Int)+++poly :: Show a => A a -> String+poly (A x a) = "A "++show x++poly a+poly (B a) = "B "++poly a++mono (A x a) = "A "++show x++mono a+mono (B a) = "B "++mono a
+ tools/base/tests/tiPrelude.hs view
@@ -0,0 +1,174 @@+module Prelude(module Prelude,module PreludeText) where+import PreludeText++default (Int)++-- Primitive types+data Char+data Int+data Integer+data Float+data Double++data () = () deriving (Eq,Show,Bounded,Ord,Read)+data (,) a b = (,) a b deriving (Eq,Show,Bounded,Ord)+data (,,) a b c = (,,) a b c+data (,,,) a b c d = (,,,) a b c d++data (->) a b++data [] a = [] | a : [a] deriving (Eq,Show,Ord,Read)+data Bool = False | True deriving (Eq,Show,Bounded,Enum,Ord,Read)+data Either a b = Left a | Right b deriving (Eq,Show,Ord,Read)+data Maybe a = Nothing | Just a deriving (Eq,Show,Ord,Read)++type String = [Char]++undefined | False = undefined+error s = undefined++either f g (Left x) = f x+either f g (Right y) = g y++maybe n j Nothing = n+maybe n j (Just x) = j x++--foldr :: (a->b->b)->b->[a]->b+foldr c n [] = n+foldr c n (x:xs) = c x (foldr c n xs)++filter p xs = [x|x<-xs,p x]++infixr 3 &&+True && b = b+_ && _ = False++infix 4 ==,/=++class Eq a where+  (==),(/=) :: a -> a -> Bool++  a/=b = not (a==b)+++not False = True+not True  = False++lexOrder EQ o = o+lexOrder o  _ = o++class (Eq a,Show a) => Num a where+  fromInteger :: Integer -> a+  fromInt :: Int -> a+  (+),(-),(*) :: a -> a -> a+  negate :: a->a+-- ...++class Enum a where+  succ, pred :: a -> a+  toEnum :: Int -> a+  fromEnum :: a -> Int+  enumFrom :: a -> [a]+  enumFromThen,enumFromTo :: a -> a -> [a]+  enumFromThenTo :: a -> a -> a -> [a]++class Monad m where+  return :: a -> m a+  (>>) :: m a -> m b -> m b+  (>>=) :: m a -> (a -> m b) -> m b+  fail :: String -> m a++  --m1>>m2 = m1 >>= const m2++m2 =<< m1 = m1 >>= m2++id x = x+const x y = x+flip f x y = f y x++infixr 9 .+--(.) :: (b->c)->(a->b)->(a->c)+(f . g) x = f (g x)++instance Show Int+instance Read Int+instance Enum Int+instance Num Int+instance Enum Char+instance Eq Char+instance Eq Int+instance Ord Int++{-+instance Eq Bool where+  True==True = True+  False==False = True+  _ == _ = False+-}+{-+instance Eq a => Eq [a] where+  [] == [] = True+  (x:xs) == (y:ys) = (x==y) && (xs==ys)+--}+class Functor f where fmap :: (a->b) -> f a -> f b++--(++) :: [a] -> [a] -> [a]+[] ++ ys = ys+(x:xs) ++ ys = x:(xs++ys)++length :: [a]->Int+length [] = 0+length (x:xs) = 1 + length xs+++--map :: (a->b)->[a]->[b]++map f = foldr ((:).f) []+concatMap f = foldr ((++).f) []++--map f [] = []+--map f (x:xs) = f x:map f xs+++instance Functor [] where+  fmap = map++fst (x,y) = x+snd = \ p -> case p of+               (x,y) -> y++--until            :: (a -> Bool) -> (a -> a) -> a -> a+until p f x +     | p x       =  x+     | otherwise =  until p f (f x)++otherwise = True++------+data World+data IO a = IO (World->(a,World)) -- for example++instance Monad IO++print x = putStrLn (show x)++foreign import putStr :: String -> IO ()+foreign import putStrLn :: String -> IO ()++class (Real a,Enum a) => Integral a where+  toInteger :: a->Integer++class (Num a,Ord a) => Real a where+  toRational :: a -> Rational++type Rational = Ratio Integer++data Ratio a = a :% a++class Eq a => Ord a where+  compare :: a -> a -> Ordering+  (<),(<=),(>=),(>) :: a -> a -> Bool++data Ordering = LT | EQ | GT deriving (Eq,Bounded,Enum,Ord,Show,Read)++class Bounded a where minBound,maxBound::a
+ tools/base/tests/tiPreludeText.hs view
@@ -0,0 +1,49 @@+module PreludeText where+++type ShowS = String->String+class Show a where+   show :: a -> String+   showsPrec :: Int -> a -> ShowS++showString = (++)+showChar   =  (:)++-- Basic printing combinators (nonstd):+showParenArg :: Int -> ShowS -> ShowS+showParenArg d = showParen (10<=d)++showArgument x = showChar ' ' . showsPrec 10 x++showParen :: Bool -> ShowS -> ShowS+showParen b p    =  if b then showChar '(' . p . showChar ')' else p+++lex :: ReadS String+lex = undefined++type ReadS a = String -> [(a,String)]+class Read a where+  read :: String -> a+  readsPrec :: Int -> ReadS a++-- Basic parsing combinators (nonstd):++readToken x t s = [(x,r)|(t',r)<-lex s,t'==t]++readParenArg :: Int -> ReadS a -> ReadS a+readParenArg d = readParen (10<=d)+readArgument s = readsPrec 10 s++readParen        :: Bool -> ReadS a -> ReadS a+readParen b g    =  if b then mandatory else optional+                    where optional r  = g r ++ mandatory r+                          mandatory r = [(x,u) | ("(",s) <- lex r,+                                                 (x,t)   <- optional s,+                                                 (")",u) <- lex t    ]++++rf `readAp` rx = \ s0 -> [(f x,s2) | (f,s1)<-rf s0,(x,s2)<-rx s1]++readChoice rd1 rd2 s = rd1 s ++ rd2 s
+ tools/base/tests/tiSum.hs view
@@ -0,0 +1,1 @@+main = interact (show.sum.map read.lines)
+ tools/base/tests/tiSuper.hs view
@@ -0,0 +1,19 @@+module TiSuper where++-- Testing the use of the superclass relation in context reduction++f :: Real a => a -> a -> (a,Bool)+f x y = (x+y,x>y)+{-+convert :: Integral a => a->a+convert x = fromInteger (toInteger x)++--showSigned    :: Real a => (a -> ShowS) -> Int -> a -> ShowS+showSigned showPos p x | x < 0 = showParen ((p::Int) > 6)+                                           (showChar '-' . showPos (-x))+                       | otherwise = showPos x++primitive showParen :: Bool -> ShowS -> ShowS+type ShowS = String->String+primitive showChar :: Char->ShowS+-}
+ tools/base/tests/tiTest0.hs view
@@ -0,0 +1,112 @@+module TiTest0 where++default(Int)++newtype Id = Id String+newtype F f = F (f Prelude.Int)+newtype F2 f = F2 (f Int Int)+++--liftM :: Monad m => (a->b) -> m a -> m b+liftM f m = do x<-m; return (f x)+++lnil = length []++data Tags f1 f2 a = (f1 a) :&: (f2 a)++hello = "Hello, world!\n"+hello_again = fmap id hello -- unification when type synonyms are present?++lmap f xs = [f x|x<-xs]+--bla = blaha++a = Id "a"++n = 1+fn = F [n]+fm = F (Just n)+f2a x = F2 (x, x)+f2b x = F2 (Left x)+isNothing x = x==Nothing++--{-+instance Eq a => Eq (Maybe a) where+  Nothing == Nothing = True+  Just x  == Just y  = x==y+  _       == _       = False+--}++--tst = 1==2++l = \ x y z -> let f x = (x,z)+               in let s = f hello+               in (z 'a',f x,f y,s)++not' t = t==False++fnot x = fmap not x++i b x y = if b then x else y++--id :: a -> a++apply = \ f x -> f x++twice f x = f (f x)++--dup :: a -> (a,a)+dup = \ x -> (x,x)++--(id1,id2) = dup id++three = \ x -> [x,x,x]++--ones = (ones,1)++--nomatch = fromJust Nothing :: a++ints = id [1..]++ng b x = let f y = if b then x else y+         in (f, f)+++data A a = A a | A2 B+data B = B (A Int)++instance Show a => Show (A a) where+  show (A a) = show a+  show (A2 b) = show b++instance Show B where show (B a) = show a++++isZero x | x==0 = True+         | x/=0 = False+++happy = [toEnum 0x263a] -- ::String+sad = [toEnum 0x2639]++happy2 = "\x263a"+sad2 = "\x2639"++{-+eq = (==) :: Eq a => a->a->Bool+addff = fst ff+snd ff+-}++ff :: Num a => (a,a)+ff = (four,four)+  where four = 4++++fib 0 = 0+fib 1 = 0+fib n = fib (n-1) + fib(n-2)++fac 0 = 1+fac n = n * fac(n-1)
+ tools/base/tests/tiTest1.hs view
@@ -0,0 +1,19 @@+module Test1 where++class C a where+  op :: a -> Bool++instance C [a] where op _ = True++{-+f xs = (let g :: a->Bool+            g y = op (xs>>return y)+        in True,+        xs++[])+--}+--{-+g xs = (xs++[],+        let g :: a->Bool+            g y = op (xs>>return y)+        in True)+--}
+ tools/base/tests/tiTest2.hs view
@@ -0,0 +1,26 @@+module TiTest2 where++--id x = x++--length [] = 0++z x = length (id [])++--l xs = length xs++l = \ x y z -> let f x = (x,z)+               in let s = f "hello"+               in (z 'a',f x,f y,s)++ng b x = let f y = if b then x else y+         in (f, f)++{-+id(a::Set) (x::a)::a = x;++length(a::Set)(xs::List a)::Int = Zero@_;++z(a::Set)(b::Set)(x::b)::Int = length a (id (List a) Nil@_);++l(a::Set)(xs::List a)::Int = length a xs;+-}
+ tools/base/tests/tiTest5.hs view
@@ -0,0 +1,42 @@+module Prelude where++data Bool = False | True+data Int+data Maybe a = Nothing | Just a+data (,) a b = (,) a b++not False = True+not True = False++data [] a = [] | a : [a]++map f [] = []+map f (x:xs) = f x:map f xs++null = f+  where+    f [] = True+    f _ = False++t = null []+f = not t++{-+data P = P { x,y::Int }+++origin P{x=0,y=0} = True+origin _ = False+-}++class Functor f where+  fmap :: (a->b) -> f a -> f b++instance Functor [] where fmap = map++ys = fmap id []++(id,const)  = (\x->x,\x y->x)++error s = undefined+undefined | False = undefined
+ tools/base/tests/tiTest8.hs view
@@ -0,0 +1,23 @@+module Prelude where++data Bool = False | True++not False = True+not True = False++data [] a = [] | a : [a]++map f [] = []+map f (x:xs) = f x:map f xs++null [] = True+null _ = False++--b::Bool+b = null []++id = \ x -> x++const x y = let z = False in x++type B = Bool
+ tools/base/tests/tiTest9.hs view
@@ -0,0 +1,8 @@+module Prelude where++data Int+data Bool = False|True++--f x = (x::Int,x::Bool)++g = \ x->x::Int
+ tools/base/transforms/Deriving/Deriving.hs view
@@ -0,0 +1,48 @@+module Deriving where+import DerivingEq+import DerivingShow+import DerivingBounded+import DerivingEnum+import DerivingOrd+import DerivingRead+import DerivingIx+import DerivingUtils+import PrettyPrint+import Lift(lift)+import SrcLoc1(srcLoc)++derive stdnames cl t =+    case lookup cl derivers of+      Nothing -> fail $ pp $"Don't know how to derive"<+>cl+      Just d -> d stdnames' (srcLoc cl) =<< tinfo+  where+    stdnames' m n = lift (stdnames m n)+    tinfo =+      case idTy t of+	Type tinfo@TypeInfo{defType=Just tkind}+           | tkind `elem` [Data,Newtype] -> return (idName t,tinfo)+	_ -> fail $ pp $ "Deriving"<+>cl<>": this is not a data/newtype:"<+>t+{-+    conv tinfo@(TypeInfo d cs fs) = TypeInfo d (map convc cs) [] -- !!fields+      where+        convc (ConInfo c n optfs) =+          ConInfo (PNT (mkUnqual c) ConstrOf{} noSrcLoc)+		  n+		  Nothing -- !! field names are discarded+-}+    derivers =+	concat+	[pc "Eq"  deriveEq,+	 pc "Show" deriveShow,+	 pc "Bounded" deriveBounded,+	 pc "Enum" deriveEnum,+	 pc "Ord" deriveOrd,+	 pc "Read" deriveRead,+	 ixc "Ix" deriveIx]++    pc = stdc mod_Prelude+    ixc = stdc mod_Ix+    stdc m n d = either ignore keep (stdclass stdnames m n)+      where+        keep (HsCon c) = [(c,d)]+	ignore _ = []
+ tools/base/transforms/Deriving/DerivingBounded.hs view
@@ -0,0 +1,22 @@+module DerivingBounded where+import DerivingUtils++deriveBounded stdnames src t@(_,TypeInfo{constructors=cs}) =+  do let pv = stdvalue stdnames mod_Prelude+     HsVar minBound <- pv "minBound"+     HsVar maxBound <- pv "maxBound"+     let enumBounds cs@(c:_) = [b minBound c,b maxBound (last cs)]+	 b m ci = fun0 src m (con c)+	   where+	     c=convCon t (conName ci)++	 tupleBounds [ConInfo{conName=c0,conArity=n}] =+	     [tb minBound,tb maxBound]+	   where+	     tb m = fun0 src m (apps (con c:replicate n (var m)))+	     c=convCon t c0+     if isEnum cs+       then return (enumBounds cs)+       else if length cs == 1+            then return (tupleBounds cs)+            else fail "Deriving Bounded: the type is neither an enumeration nor a single constructor type."
+ tools/base/transforms/Deriving/DerivingEnum.hs view
@@ -0,0 +1,25 @@+module DerivingEnum where+import DerivingUtils++deriveEnum stdnames src t@(_,TypeInfo{constructors=cs}) =+  do let pv = stdvalue stdnames mod_Prelude+     HsVar fromEnum <- pv "fromEnum"+     HsVar toEnum <- pv "toEnum"+     if isEnum cs+       then return (fromToEnum src fromEnum toEnum t id)+       else fail "Deriving Enum: the type is not an enumeration."++fromToEnum src fromEnum toEnum t@(_,TypeInfo{constructors=cs}) sig =+   [fromEnumDef,toEnumDef]+ where+  cns = zip [0..] cs++  fromEnumDef = fun src (map fromAlt cns)+  toEnumDef = fun src (map toAlt cns)++  fromAlt (n,ci) = alt1 src fromEnum (con c)+			((if n==0 then sig else id) (hsLit src (HsInt n)))+    where c = convCon t (conName ci)++  toAlt (n,ci) = alt1 src toEnum (hsPLit src (HsInt n)) (con c)+    where c = convCon t (conName ci)
+ tools/base/transforms/Deriving/DerivingEq.hs view
@@ -0,0 +1,24 @@+module DerivingEq where+import DerivingUtils++deriveEq stdnames src t@(_,TypeInfo{constructors=cs}) =+  do let pv = stdvalue stdnames mod_Prelude+     HsVar eq <- pv "=="+     true <- pv "True"+     false <- pv "False"+     andand <- pv "&&"+     let def = if length cs>1+	       then [alt2 src eq wild wild (ident false)]+	       else []+	 eqalt ConInfo{conName=c0,conArity=n} =+	    alt2 (srcLoc c0) eq (p xs) (p ys) rhs+	   where+	     c = convCon t c0+	     p vs = hsPApp c vs+	     rhs = conj andand true comps+	     comps = zipWith eqtst xs ys+	     eqtst = opapp (HsVar eq)+	     xs=take n (vars "x")+	     ys=take n (vars "y")++     return [fun src (map eqalt cs++def)]
+ tools/base/transforms/Deriving/DerivingIx.hs view
@@ -0,0 +1,104 @@+module DerivingIx where+import DerivingUtils+import DerivingEnum(fromToEnum)++{-++When deriving #Ix# for an enumerations, the three operations (#range#, #index#,+ #inRange#) can easily be defined assuming you have auxiliary functions to+convert to and from Int. If there is a derived Enum instance,+toEnum and fromEnum could be used, but since we don't know if there is an+Enum instance, we define the same functions locally in each method definition.+This produces some code duplication. Grr!++Alternatively, the #inRange# method could be defined using (<=) from+the Ord class. We know that there is an Ord instance, since Ord is a+superclass of Ix, but we don't know if it is the derived Ord. A user+defined Ord instance can not be used. Grr again!+-}++deriveIx stdnames src t@(_,TypeInfo{constructors=cs}) =+  do let pv = stdvalue stdnames mod_Prelude+         pt = stdtype stdnames mod_Prelude+	 ixv = stdvalue stdnames mod_Ix+     int <- hsTyId # pt "Int"+     HsVar range <- ixv "range"+     HsVar index <- ixv "index"+     HsVar inRange <- ixv "inRange"+     rangeSize <- ixv "rangeSize"++     fromEnum@(HsVar fromE) <- pv "fromEnum"+     toEnum@(HsVar toE) <- pv "toEnum"+     true <- pv "True"+     andand <- pv "&&"+     map <- pv "map"+     plus  <- opapp # pv "+"+     times <- opapp # pv "*"+     let enumIx cs@(c:_) = [erange,eindex,einRange]+	   where+	     erange = pfun' range (l,u)+			    (mapE (ident toEnum)+				(apps [var range,pair (fromEnumE l) (fromEnumE u)]))+			    (toDefs fromto)++	     eindex = pfun2' index (l,u) i+			     (apps [var index,pair (fromEnumE l) (fromEnumE u),+					      fromEnumE i])+			     (oneDef from)++	     einRange = pfun2' inRange (l,u) i+			     (apps [var inRange,pair (fromEnumE l) (fromEnumE u),+						fromEnumE i])+			     (oneDef from)++	     fromto@[from,to] = fromToEnum src fromE toE t ( -:: int)++	     l = var (localVal "l")+	     u = var (localVal "u")+	     i = var (localVal "i")++	     fromEnumE = app (ident fromEnum)++	 -- pre: n>=1+	 tupleIx [ConInfo{conName=c0,conArity=n}] = [trange,tindex,tinRange]+	    where+	     trange = pfun range rpat $ hsListComp (foldr gen last (zip [1..] luis))+	       where+		 gen (n,(l,u,i)) =+		   HsGenerator (fakePos src n) i (var range `app` pair l u)+		 last = HsLast (apps (con c:is))++	     tindex = ilhs index $+		      case luis of+		       [lui] -> ix1 lui+		       _ -> foldl ix zero luis+	       where+		 ix1 (l,u,i) = apps [var index,pair l u,i]+		 ix acc (l,u,i) = ix1 (l,u,i) `plus`+				  ((ident rangeSize `app` pair l u) `times` acc)++	     tinRange = ilhs inRange $+			conj andand true [apps [var inRange,pair l u,i]|(l,u,i)<-luis]++	     ilhs f = pfun2 f rpat (hsPApp c is)+	     rpat = (hsPApp c ls,hsPApp c us)++	     c = convCon t c0+	     luis = zip3 ls us is+	     ls = take n (vars "l")+	     us = take n (vars "u")+	     is = take n (vars "i")++	 pfun f p rhs = pfun' f p rhs noDef+	 pfun' f (x,y) rhs ds = fun src [alt1' src f (pair x y) rhs ds]+	 pfun2 f p z rhs = pfun2' f p z rhs noDef+	 pfun2' f (x,y) z rhs ds = fun src [alt2' src f (pair x y) z rhs ds]++	 zero  = hsLit src (HsInt 0)++	 mapE f xs = apps [ident map,f,xs]++     if isEnum cs+       then return (enumIx cs)+       else if length cs == 1+            then return (tupleIx cs)+            else fail "Deriving Ix: the type is neither an enumeration nor a single constructor type."
+ tools/base/transforms/Deriving/DerivingOrd.hs view
@@ -0,0 +1,47 @@+module DerivingOrd where+import Maybe(mapMaybe)+import DerivingUtils++deriveOrd stdnames src t@(_,TypeInfo{constructors=cs}) =+  do let pv = stdvalue stdnames mod_Prelude+         pt = stdtype stdnames mod_Prelude+     HsVar compare <- pv "compare"+     lexOrder <- pv "lexOrder" -- nonstandard entity!+     int <- hsTyId # pt "Int"+     let branches = mapMaybe eqbranch cs `asTypeOf` def+	 n = length cs+	 def = if n<2 && length branches==n+	       then []+	       else [alt x y cmpcno]+	   where+	     x = var (localVal "x")+	     y = var (localVal "y")+	     cmpcno = hsLet cnodef (compareE (cnoE x) (cnoE y))+	     cnodef = oneDef (fun src (zipWith cnoalt [0..] cs))+	     cno = localVal "cno"+	     cnoE a = var cno `app` a+	     cnoalt i ConInfo{conName=c0,conArity=n} = +		  alt1 src cno (hsPApp c xs) (l i)+		where xs = replicate n wild+		      c = convCon t c0+	     l 0 = intlit 0 -:: int -- add type restriction to the first branch+	     l i = intlit i+	     intlit = hsLit src . HsInt+	 eqbranch ConInfo{conName=c0,conArity=n} =+	     if n==0+	     then Nothing+	     else Just (alt (p xs) (p ys) rhs)+	   where+	     c = convCon t c0+	     p = hsPApp c+	     rhs = conj comps+	     conj = foldr1 (opapp lexOrder)+	     comps = zipWith compareE xs ys+	     xs = take n (vars "x")+	     ys = take n (vars "y")++	 compareE = opapp (HsVar compare)++	 alt = alt2 src compare++     return [fun src (branches++def)]
+ tools/base/transforms/Deriving/DerivingRead.hs view
@@ -0,0 +1,34 @@+module DerivingRead where+import DerivingUtils++deriveRead stdnames src t@(_,TypeInfo{constructors=cs}) =+  do let pv = stdvalue stdnames mod_Prelude+     readParenArg <- pv "readParenArg"+     readArgument <- pv "readArgument"+     readToken <- pv "readToken"+     HsVar readsPrec <- pv "readsPrec"+     readAp <- pv "readAp"+     readChoice <- pv "readChoice"++     let d = var (localVal "d")++	 alt = alt1 src readsPrec d++	 rdCon ConInfo{conName=c0,conArity=n} =+	   case n of+	     0 -> rdConName cn c+	     _ -> rdParenArg (comp (rdConName cn c:replicate n rdArg))+	   where+	     c = convCon t c0+	     cn = getBaseName c0++	 rdConName cn c = rdToken (con c) (str src cn)+	 rdToken = opapp readToken+	 rdParenArg a = opapp readParenArg d a+	 rdArg = ident readArgument++	 comp = foldl1 (opapp readAp)+	 choice = foldr1 (opapp readChoice)+++     return [fun src [alt (choice (map rdCon cs))]]
+ tools/base/transforms/Deriving/DerivingShow.hs view
@@ -0,0 +1,31 @@+module DerivingShow where+import DerivingUtils++deriveShow stdnames src t@(_,TypeInfo{constructors=cs}) =+  do let pv = stdvalue stdnames mod_Prelude+     showParenArg <- pv "showParenArg"+     showArgument <- pv "showArgument"+     showString <- pv "showString"+     HsVar showsPrec <- pv "showsPrec"+     comp2 <- opapp # pv "."++     let showAlt ConInfo{conName=c0,conArity=n} =+	   case n of+	     0 -> alt (con c) (showConName cn)+	     _ -> alt (hsPApp c xs)+		      (paren (showConName cn `comp2` comp (map showArg xs)))+	   where+	     c = convCon t c0+	     cn = getBaseName c0+	     xs = take n (vars "x")++	 paren arg = ident showParenArg `app` d `app` arg+	 showArg v = ident showArgument `app` v+	 showConName c = ident showString `app` str src c++	 comp = foldr1 comp2++	 alt = alt2 src showsPrec d+	 d = var (localVal "d")++     return [fun src (map showAlt cs)]
+ tools/base/transforms/Deriving/DerivingUtils.hs view
@@ -0,0 +1,76 @@+module DerivingUtils(+    TypeInfo(..),DefTy(..),ConInfo(..),HsIdentI(..),IdTy(..),+    idTy,idName,+    fun,alt1,alt2,fun0,alt1',alt2',+    vars,app,apps,opapp,con,var,ident,wild,(-::),str,pair,+    hsLet,hsPApp,hsTyId,hsLit,hsPLit,HsLiteral(..),hsListComp,HsStmt(..),+    oneDef,toDefs,noDef,localVal,+    getBaseName,convCon,ModuleName(..),srcLoc,fakePos,+    isEnum,+    conj,+    --eq,bool,false,+    stdvalue,stdtype,stdclass,+    ( # ),+    module ModNames+  ) where+import TiNames as TI(conName,localVal,idName)+import TiClasses(var,con,ident,app,tuple,noDef,oneDef,toDefs)+import HasBaseStruct(hsInfixApp,hsPWildCard,hsFunBind,hsExpTypeSig,hsLit,+		     hsListComp,hsPLit,hsTyId,hsPApp,hsLet)+import HasBaseName(getBaseName)+import BaseSyntax+import TypedIds+import HsConstants as ModNames(mod_Prelude,mod_Ix)+import UniqueNames(origModule)+import SrcLoc1+import TiPNT()+import TiHsName()+import MUtils++default(Int)++vars x = [var (localVal (x++show n))|n<-[1..]]+apps args = foldl1 app args+pair x y = tuple [x,y]++opapp op e1 e2 = hsInfixApp e1 op e2+wild=hsPWildCard++fun = hsFunBind+alt2' src f p1 p2 e = HsMatch src f [p1,p2] (HsBody e) +alt1' src f p e = HsMatch src f [p] (HsBody e) ++alt2 src f p1 p2 e = alt2' src f p1 p2 e noDef+alt1 src f p e = alt1' src f p e noDef++fun0 src f e = fun src [HsMatch src f [] (HsBody e) noDef]++isEnum = all isNullary+  where isNullary c = conArity c==0++convCon (t,ty) c0 = TI.conName (origModule c0) (getBaseName c0) t ty++e-::t = hsExpTypeSig loc0 e [] t+str s = hsLit s . HsString +{-+andand = pv "&&"++bool = prelType "Bool"+false = prelCon "False" bool boolInfo+true = prelCon "True" bool boolInfo+boolInfo = TypeInfo {defType=Just Data,+		     fields=[],+		     constructors=[bc "False",bc "True"]}+  where+    bc c = ConInfo (prelCon c bool boolInfo) 0 Nothing+-}+conj andand true [] = ident true+conj andand true tsts = foldr1 (opapp andand) tsts++fakePos :: SrcLoc -> Int -> SrcLoc+fakePos (SrcLoc path char line col) n =+    SrcLoc (path++":derived_"++show col) char line n++stdvalue stdnames m n = stdnames ValueNames (m,n)+stdtype stdnames m n = stdnames ClassOrTypeNames (m,n)+stdclass = stdtype
+ tools/base/transforms/Deriving/Flags.ghc view
@@ -0,0 +1,9 @@+DerivingUtils.hs: -fno-monomorphism-restriction+DerivingEq.hs: -fno-monomorphism-restriction+DerivingShow.hs: -fno-monomorphism-restriction+DerivingBounded.hs: -fno-monomorphism-restriction+DerivingEnum.hs: -fno-monomorphism-restriction+DerivingOrd.hs: -fno-monomorphism-restriction+DerivingRead.hs: -fno-monomorphism-restriction+DerivingIx.hs: -fno-monomorphism-restriction+Deriving.hs: -fno-monomorphism-restriction
+ tools/base/transforms/Deriving/HEADER.html view
@@ -0,0 +1,20 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!-- This file is included by the web server in the automatically generated+     directory index.+-->+<head>+<title>Programatica Tools, tools/base/transforms/parse2</title>+<link rel=parent href="../" title="Directory tools/base/transforms/">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../../../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../../../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../../../web/icon1.png">+</head>++<base>+<h1><img align=right src="../../../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/base/transforms/Deriving</h2>++<p>+The README file is displayed below the directory index.
+ tools/base/transforms/Deriving/README.html view
@@ -0,0 +1,13 @@+<title>Extensible Haskell front-end for the Programatica project -+       directory base/transforms/Deriving</title>++<h1>Extensible Haskell front-end for the Programatica project</h1>++<h2>What is in this directory (base/transforms/Deriving)</h2>++This directory contains the code that implements Haskell's deriving+mechanism.+<p>+The derived instances refer to various functions defined in the+<code>Prelude</code> and <code>PreludeText</code> (including some+nonstandard functions to reduce the amount of code duplication).
+ tools/base/transforms/FieldSelectors.hs view
@@ -0,0 +1,26 @@+-- Generate selector functions for data constructors with labelled fields+module FieldSelectors where+import List(nub)+import HsDeclStruct+import HasBaseStruct(hsPApp,hsPVar,hsPWildCard,hsEVar,hsFunBind)+import HsGuardsStruct(HsRhs(..))+import TiNames(localVal')++{-++Haskell 98 Report, section 3.15.1 Field Selection+-}+fieldSelectors noDef cds = map selector fields +  where+    conFields = nub [((src,c),[n|(ns,_)<-fs,n<-ns])|HsRecDecl src _ _ c fs<-cds]+    fields = nub [(src,n)|((src,_),ns)<-conFields,n<-ns]++    selector (src,field) =+       hsFunBind src+         [HsMatch src field [hsPApp c (map pat fs)]+                            (HsBody (hsEVar x)) noDef+            |((src,c),fs)<-conFields,field `elem` fs]+      where+        x = localVal' "x" (Just src)+        pat f = if f==field+		then hsPVar x+		else hsPWildCard
+ tools/base/transforms/Flags.ghc view
@@ -0,0 +1,4 @@+RemoveIrrefPatsBaseStruct.hs: -fallow-undecidable-instances+RemoveListComp.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+Substitute.hs: -fno-monomorphism-restriction+SubstituteBaseStruct.hs: -fallow-undecidable-instances -fno-monomorphism-restriction
+ tools/base/transforms/HEADER.html view
@@ -0,0 +1,20 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!-- This file is included by the web server in the automatically generated+     directory index.+-->+<head>+<title>Programatica Tools, tools/base/transforms</title>+<link rel=parent href="../" title="Directory tools/base/">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../../web/icon1.png">+</head>++<base>+<h1><img align=right src="../../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/base/transforms/Deriving</h2>++<p>+The README file is displayed below the directory index.
+ tools/base/transforms/MapDeclM.hs view
@@ -0,0 +1,24 @@+module MapDeclM where++import Recursive+import IdM++{-++A class to apply a monadic function to all declarations in a+structure.  The type of the structure is #s#, the type of the declarations+is #d#.  The functional dependency ensures that we can determine the+type of declarations from the type of the structure.+-}++class MapDeclM s d | s -> d where+    mapDeclM :: (Functor m, Monad m) => (d -> m d) -> s -> m s++instance MapDeclM s ds => MapDeclM [s] ds where+    mapDeclM = mapM . mapDeclM++{- A convinient function, when the definition is in terms of+the underlying structure. -}++std_mapDeclM f = fmap r . mapDeclM f . struct++mapDecls f m = removeId $ mapDeclM (return.map f) m
+ tools/base/transforms/MapDeclMBase.hs view
@@ -0,0 +1,15 @@+module MapDeclMBase (module MapDeclM) where++import MapDeclM+import MapDeclMBaseStruct() -- get the instances+import Syntax++instance MapDeclM (HsDeclI i) [HsDeclI i] where+    mapDeclM = std_mapDeclM++instance MapDeclM (HsExpI i) [HsDeclI i] where+    mapDeclM = std_mapDeclM++++
+ tools/base/transforms/MapDeclMBaseStruct.hs view
@@ -0,0 +1,17 @@+module MapDeclMBaseStruct where++import MapDeclM(MapDeclM,mapDeclM)+import HsDecl+import HsExp+import HsModule(HsModuleI)+import HsModuleMaps(seqDecls,mapDecls)++-- we assume only "expressions" & "declarations" may contain declarations+instance MapDeclM e ds => MapDeclM (DI i e p ds t c tp) ds where+    mapDeclM f = seqDI . mapDI return (mapDeclM f) return f return return return++instance MapDeclM e ds => MapDeclM (EI i e p ds t c) ds where+    mapDeclM f = seqEI . mapEI return (mapDeclM f) return f return return++instance MapDeclM (HsModuleI m i ds) ds where+    mapDeclM f = seqDecls . mapDecls f
+ tools/base/transforms/README.html view
@@ -0,0 +1,44 @@+<title>Extensible Haskell front-end for the Programatica project -+       directory base/transforms/Deriving</title>++<h1>Extensible Haskell front-end for the Programatica project</h1>++<h2>What is in this directory (base/transforms)</h2>++<p>+This directory contains implementations of various source level+program transformations.+The subdirectory <a href="Deriving/"><code>Deriving/</code></a> contains+modules that generate code for derived instances.++<!--+<p>+We use overloading to allow the same function names to be reused in extended+versions of the syntax. Each transformation is thus a method in a class.+The class, re-usable instances for the base language structure, knot-tying+-->++<table>+<tr><th>Modules<th>Purpose+<tr><td>FieldSelectors+    <td>A function that+        generates selector functions for data constructors with labelled fields+<tr><td>MapDeclM, MapDeclMBase, MapDeclMBaseStruct+    <td>Monadic traversal of all declarations in an abstract syntax tree+<tr><td>RemoveIrrefPats, RemoveIrrefPatsBase, RemoveIrrefPatsBaseStruct+    <td>Transform away irrefutable patterns+<tr><td>RemoveListComp, RemoveListCompBase+    <td>Transform away list comprehensions+        (section 3.11 in the Haskell 98 report)+<tr><td>RemovePatBinds+    <td>Transform away pattern bindings+<tr><td>SimpFunBinds+    <td>Simplify function bindings+        (similar to section 4.4.3.1 in the Haskell 98 report)+<tr><td>SimpPatMatch, SimpPatMatchBase+    <td>Pattern match simplification (as described in section 3.17.3 of the+        Haskell 98 report)+<tr><td>Substitute, SubstituteBase, SubstituteBaseStruct+    <td>Substitute expressions for variables in expressions.+        Apply a function to all expressions in a larger structure.+</table>
+ tools/base/transforms/RemoveIrrefPats.hs view
@@ -0,0 +1,50 @@+module RemoveIrrefPats +  ( module RemoveIrrefPats+  , module StateM+  , module OutputMT+  , module EnvMT+  , module MT+  )where++import MT (MT(..))+import StateM+import OutputMT+import EnvMT+import SrcLoc(SrcLoc)+import HasBaseStruct(base)+import Recursive(struct)+import MUtils (( # ))++-- Monads:+-- *) the state is used as a source of new names+-- *) the environment is used for structures, that do not have a source +--      location (e.g. expressions).  They inherit the source location +--      of the closest enclosing them structure with a location+-- *) output is to generate pattern bindings, which delay the matching+-- *) output is also used when processing (lists of) declarations,+--    to output additional declarations generated+++-- NOTE: the base monad can be generalized to be anything with state++type M i        = StateM [i]+type EM i       = WithEnv SrcLoc (M i)+type OM i ds    = WithOutput ds (M i)+type OEM i d    = WithOutput d (EM i)++++-- type OEM i d    = WithOutput d (WithEnv SrcLoc (StateM [i]))+++class Monad m => RemIrrefPats t m | t -> m where+    remIrrefPats :: t -> m t++-- a generic instance for lists+instance RemIrrefPats a m => RemIrrefPats [a] m where+    remIrrefPats = mapM remIrrefPats++remIrrefPatsRec p = base # remIrrefPats (struct p)++removeIrrefPats xs = withSt xs . remIrrefPats+
+ tools/base/transforms/RemoveIrrefPatsBase.hs view
@@ -0,0 +1,18 @@+module RemoveIrrefPatsBase+    ( module RemoveIrrefPatsBase+    , module RemoveIrrefPats+    ) where++import RemoveIrrefPats+import RemoveIrrefPatsBaseStruct+import Syntax+--import TiClasses(HasDef(..))+import TiBase()++instance RemIrrefPats (HsDeclI i) (OM i [HsDeclI i]) +                                        where remIrrefPats = remIrrefPatsRec+instance RemIrrefPats (HsExpI i) (EM i) where remIrrefPats = remIrrefPatsRec+instance RemIrrefPats (HsPatI i) (OEM i (HsDeclI i)) +                                        where remIrrefPats = remIrrefPatsRec++
+ tools/base/transforms/RemoveIrrefPatsBaseStruct.hs view
@@ -0,0 +1,140 @@+module RemoveIrrefPatsBaseStruct where++import RemoveIrrefPats ++import HasBaseStruct+import TiClasses(HasDef(..))+import HsPat+import HsExp+import HsDecl+import HsGuards+import HsModule+import HsIdent+import SrcLoc++import MUtils+import Monad(liftM)+++-- replaces listOutput, to handle generic lists of declarations+getDecls o = foldOutput noDef (`consDef` noDef) appendDef o+getDDecls o = foldOutput noDef id appendDef o++procDs :: (RemIrrefPats ds (OM i ds), HasDef ds d) => ds -> M i ds+procDs ds = uncurry appendDef # getDDecls (remIrrefPats ds)++-- we translate the patterns, and output pattern bindings,+-- which essentially delay the matching++instance ( GetBaseStruct p (PI i p)+         , HasBaseStruct d (DI i e p ds t c tp) +         , HasBaseStruct e (EI i e p ds t c)+         , HasDef ds d +         , RemIrrefPats p (OEM i d)++        ) => RemIrrefPats (PI i p) (OEM i d) where++    remIrrefPats p = do+        p1 <- seqPI (mapPI return remIrrefPats p)+        case p1 of+            HsPIrrPat p2 -> case basestruct p2 of+                Just p3 -> case p3 of+                    HsPWildCard     -> return p3+                    HsPId (HsVar _) -> return p3+                    HsPAsPat i p    -> decl i+                    _               -> decl . head =<< updSt tail +                    where+                    decl x = do+                        s <- getEnv+                        output $ hsPatBind s p2 (HsBody (hsEVar x)) noDef+                        return (HsPId (HsVar x))+                Nothing -> return p1++            _ -> return p1+++-- PRE: e & ds have been processed+instance (RemIrrefPats p (OEM i d), HasDef ds d)+    => RemIrrefPats (HsAlt e p ds) (M i) where++    remIrrefPats (HsAlt s p rhs ds) = do+        (p',ds')   <- withEnv s $ getDecls $ remIrrefPats p+        return (HsAlt s p' rhs (ds `appendDef` ds'))+++-- PRE: e & ds have been processed+instance (RemIrrefPats p (OEM i d), HasDef ds d) +    => RemIrrefPats (HsStmt e p ds) (EM i) where++    remIrrefPats = atoms2Stmt @@ liftM concat . mapM rem  . getStmtList +        where+        rem (HsGeneratorAtom s p e) = do+            (p',ds) <- getDecls (remIrrefPats p)+            return [HsGeneratorAtom s p' e, HsLetStmtAtom ds]+        rem x = return [x]+++-- PRE: e & ds have been processed+instance (RemIrrefPats p (OEM i d), HasDef ds d)+    => RemIrrefPats (HsMatchI i e p ds) (M i) where++    remIrrefPats (HsMatch s i ps rhs ds) = do+        (ps',ds')  <- withEnv s $ getDecls $ remIrrefPats ps+        return (HsMatch s i ps' rhs (ds `appendDef` ds'))+ ++-- Expressions+instance ( RemIrrefPats e (EM i)+         , RemIrrefPats p (OEM i d)+         , RemIrrefPats ds (OM i ds)+         , HasBaseStruct e (EI i e p ds t c)+         , HasDef ds d+         )++    => RemIrrefPats (EI i e p ds t c) (EM i) where+    remIrrefPats e = do+        e1 <- seqEI (mapEI return remIrrefPats return (lift . procDs) +                                                            return return e)++        case e1 of+            HsLambda ps e   -> do+                (ps',ds) <- getDecls (remIrrefPats ps)+                return (HsLambda ps' (hsLet ds e))  -- check null ds?+            HsCase e alts   -> HsCase e # lift (remIrrefPats alts)+            HsDo stms       -> HsDo # remIrrefPats stms +            HsListComp stms -> HsListComp # remIrrefPats stms+            _               -> return e1+++++-- Declarations+instance ( RemIrrefPats e (EM i)+         , RemIrrefPats p (OEM i d)+         , RemIrrefPats ds (OM i ds)+         , HasDef ds d+         ) => RemIrrefPats (DI i e p ds t c tp) (OM i ds) where++    remIrrefPats d = do+        d1 <- lift $ seqDI (mapDI return (withEnv (srcLoc d) . remIrrefPats)+                           return procDs return return return d)+        case d1 of+            HsFunBind s ms      -> lift $ HsFunBind s # remIrrefPats ms+            HsPatBind s p r ds  -> do+                (p',ds1) <- lift $ withEnv s $ getDecls $ remIrrefPats p+                output ds1+                return (HsPatBind s p' r ds) ++            _   -> return d1++  +-- Modules++-- Note the i and j !!!  It looks like some mappings over identifiers,+-- do not quite change all identifiers++instance (RemIrrefPats ds (OM j ds), HasDef ds d) +    => RemIrrefPats (HsModuleI i ds) (M j) where+    remIrrefPats (HsModule s n es is ds) +        = HsModule s n es is # procDs ds+
+ tools/base/transforms/RemoveListComp.hs view
@@ -0,0 +1,54 @@+module RemoveListComp where+import Substitute+import Recursive+import HasBaseStruct+import BaseSyntax+import SrcLoc1+import HsConstants(mod_PreludeList)+import DerivingUtils(alt1,oneDef)+import TiNames(ValueId,localVal',topVal)+import TiClasses(HasDef)++rmAllListComp cm m = mapExp (rmListComp cm) m++class RmListComp i s | s->i where+  rmListComp :: HsIdentI i -> s -> s++instance RmListComp i s => RmListComp i [s] where rmListComp = map . rmListComp++rmListCompE concatMap e = rmListCompE' r concatMap e++rmListCompE' r cm e0 =+    case mapEI id (rmListComp cm) id (rmAllListComp cm) id id e0 of+      HsListComp stmt -> compileListComp cm stmt+      e -> r e++{-++Translation of list comprehensions, as described in section 3.11+of the Haskell 98 report+-}+{-+compileListComp ::+   (ValueId i,+    HasBaseStruct e (EI i e p ds t c),+    HasBaseStruct p (PI i p),+    HasBaseStruct d (DI i e p ds t c tp),+    HasDef ds d)+  => HsStmt e p ds -> e+-}+compileListComp concatMap = comp+  where +    comp stmt =+      case stmt of+	HsGenerator s p e stmt ->+	     hsLet okDef (hsId concatMap `hsApp` hsEVar ok `hsApp` e)+	   where+	     ok = localVal' "ok" (Just s) -- should be a fresh variable+	     okDef = oneDef (hsFunBind loc0 okEqns)+	     okEqns = [okM p (comp stmt),+		       okM hsPWildCard (hsList [])]+	     okM = alt1 loc0 ok++	HsQualifier e stmt -> hsIf e (comp stmt) (hsList []) +	HsLetStmt ds stmt -> hsLet ds (comp stmt)+	HsLast e -> hsList [e]
+ tools/base/transforms/RemoveListCompBase.hs view
@@ -0,0 +1,9 @@+module RemoveListCompBase where+import RemoveListComp+import Recursive+import SyntaxRec(HsExpI)+import TiNames(ValueId)+import TiBase() -- HasDef [HsDeclI i] (HsDeclI i)++instance ValueId i => RmListComp i (HsExpI i) where+  rmListComp cm = rmListCompE cm . struct
+ tools/base/transforms/RemovePatBinds.hs view
@@ -0,0 +1,99 @@+module RemovePatBinds where++--import SrcLoc+import HasBaseStruct+import HsDeclStruct+import HsPatStruct+import HsPatUtil(isPVar)+import HsExpStruct+import HsGuardsStruct+import HsLiteral +--import HsModule+import HsModuleMaps(mapDecls)+import DefinedNames+import MapDeclM+import HsIdent+import TiNames(ValueId,localVal)++import Maybe(isNothing)+import Monad(liftM)+import StateM+import PrettyPrint(pp,(<>))++-- should add a class here...++remPats pErr = remPatBinds' pErr names+  where names = [ localVal ("patbind__" ++ show n) | n <- [0..] ]++remPatBinds' pErr names = {-mapDecls-} (removePatBinds pErr names)++-- a perhaps more convinient version...+removePatBinds pErr names = withSt names . removePatBinds' err+  where+    -- the error we give if a pattern binding fails+    err pos =+      hsApp (hsId pErr) +            (hsLit pos $ HsString $ pp $ pos<>": pattern binding failed")++-- removes all pattern bindings from a list of declarations (recursively)+{-+removePatBinds' :: +    ( GetBaseStruct d (DI i e p [d] t c tp)+    , GetBaseStruct p (PI i p)+    , HasBaseStruct d (DI i e p [d] t c tp)+    , HasBaseStruct p (PI i p)+    , HasBaseStruct e (EI i e p [d] t c)+    , DefinedNames i p+    , ValueId i+    , MapDeclM d [d] )+    => [d] -> StateM [i] [d]+-}+removePatBinds' err ds = liftM concat $ mapM remPB ds+    where+    remPB d = do+        d' <- mapDeclM (removePatBinds' err) d+        case basestruct d' of+            Just d''@(HsPatBind _ pat _ _) +                | isNothing (isPVar pat) -> do+                    n:_ <- updSt tail+                    return (remPatBind err n d'')+            _ -> return [d']++-- remove pattern bindings in a single declaration, non-recursive +{-+remPatBind :: +    ( HasBaseStruct d (DI i e p [d] t c tp)+    , HasBaseStruct p (PI i p)+    , HasBaseStruct e (EI i e p [d] t c)+    , ValueId i+    , DefinedNames i p+    )+    => i -> DI i e p [d] t c tp -> [d]+-}+remPatBind err n (HsPatBind pos pat rhs ds) +    | nVars == 1 = [hsPatBind pos (hsPId (head vars)) tple ds]+    | otherwise = hsPatBind pos (hsPVar n) tple ds+                    : zipWith (mkDecl pos n nVars) [1..] vars+    where +    vars    = definedVars pat +    nVars   = length vars+    caseBody+        | nVars == 1    = hsId (head vars)+        | otherwise     = hsTuple (map hsId vars)++    toCase e = hsCase e +        [ HsAlt pos pat (HsBody caseBody) ds+        , HsAlt pos hsPWildCard (HsBody (err pos)) []+        ]++    mkDecl pos n nVars x v = hsPatBind pos (hsPId v) (HsBody body) []+        where+        body = hsCase (hsEVar n) [ HsAlt pos pat (HsBody (hsEVar i)) [] ]+        i    = localVal "x"+        wcs  = repeat hsPWildCard +        pat  = hsPTuple pos $ take (x - 1) wcs ++ [hsPVar i] ++ take (nVars - x) wcs+++    tple = HsBody $ case rhs of+        HsBody e -> toCase e+        HsGuard gs -> foldr (\(_,g,e) -> hsIf g (toCase e)) (err pos) gs
+ tools/base/transforms/SimpFieldLabels.hs view
@@ -0,0 +1,112 @@+module SimpFieldLabels(simpFieldLabels) where+import HsDeclStruct+import HsExpStruct+import HsFieldsStruct+import HsGuardsStruct+import HsLiteral+import SrcLoc1 as S(loc0,srcLoc)+import HasBaseStruct(basestruct,base,hsId,hsECon,hsApp,hsPApp,hsLit,hsPVar,hsEVar,hsCase)+import FieldSelectors(fieldSelectors)+import UniqueNames as U(orig,srcLoc)+import TiClasses(noDef,consDef,concatDefs)+import TypedIds+import QualNames+import PNT+--import TiPrelude(prelError)+import TiPNT()+import Substitute(mapExp)+import SimpPatMatch(conFields',confields,freshnames)+import PrettyPrint(pp,fsep,(<+>),(<>))++simpFieldLabels pErr = addFieldSelectors . simpAllFieldUpdates pErr++addFieldSelectors ds = concatDefs (map addFieldSelectors' ds)++addFieldSelectors' d =+  consDef d $+  case basestruct d of+    Just (HsDataDecl    s ctx tp cds drv) -> fieldSelectors noDef cds+    Just (HsNewTypeDecl s ctx tp cd drv)  -> fieldSelectors noDef [cd]+    _ -> noDef++simpAllFieldUpdates pErr m = mapExp (simpFieldUpdates pErr) m+++simpFieldUpdates prelError e0 =+    case basestruct e of+      Just (HsRecConstr s c fields) | okConstr c fields+	  -> simpFieldConstruction bf s c fields+      Just (HsRecUpdate s e []) -> e+      Just (HsRecUpdate s e fields@(field1:_)) | okUpdate ucs+	  -> simpFieldUpdate bf s e ucs fields+	where+	  cfs = consfields s field1+	  ucs = updcons cfs (map (orig.fieldName) fields)++      _ -> e+  where+    bf = badfield prelError+    e = mapExp (simpFieldUpdates prelError) e0 -- simplify all subexpressions first++   --Only field labels declared with the specified constructor may be mentioned.+    okConstr c fields =+       map (orig.fieldName) fields `isSubsetOf` map orig (confields c)++    okUpdate = not . null++    consfields s field =+      case idTy (fieldName field) of+        FieldOf t ti ->+          [(con s ci t ti,conFields' ci)|ci<-constructors ti]+	_ -> []++    updcons cfs ufs = [c|c@(_,fs)<-cfs,ufs `isSubsetOf` map orig fs]++    con s ci t ti = PNT (mkUnqual (conName ci)) (ConstrOf t ti) (U.srcLoc s)++{-++Haskell 98 Report, section 3.15.2 Construction Using Field Labels:+-}+simpFieldConstruction badfield s c fields =+    conApp c (map (pick badfield s fields (missingField badfield s)) fs)+  where+    fs = confields c++{-++The funciton #pick# defined in section 3.15.2 of the Haskell 98 Report:+-}+pick badfield s fields d f =+  case [field|field<-fields,orig (fieldName field)==orig f] of+    [HsField _ e] -> e+    [] -> d f+    fs -> badfield $ pp $ dupmsg<+>f<+>"at"<+>+		          fsep (map (S.srcLoc.fieldName) fs) --compile-time error!+  where+    dupmsg = "H98 3.15 A field label may not be mentioned more than once:"++missingField badfield s f =+    -- compile-time error for strict fields, run-time error otherwise!+    badfield $ pp $ s<>":"<+>missing<+>f+  where+    missing ="H98 3.15 Fields not mentioned are initialized to _|_:"++{-++Haskell 98 Report, section 3.15.3 Updates Using Field Labels:+-}+simpFieldUpdate badfield s e ufs fields =+    hsCase e (map branch ufs)+  where+    branch (c,fs) = HsAlt s (hsPApp c ps) (HsBody rhs) noDef+     where+      rhs = conApp c (zipWith (pick badfield s fields.const) es fs)+      es = map hsEVar vs+      ps = map hsPVar vs+      vs = freshnames s 'x' fs++---++badfield prelError msg = hsId prelError `hsApp` hsLit loc0 (HsString msg)++xs `isSubsetOf` ys = all (`elem` ys) xs++conApp c es = foldl hsApp (hsECon c) es
+ tools/base/transforms/SimpFunBind.hs view
@@ -0,0 +1,50 @@+module SimpFunBind where+import Maybe(isJust)+import HasBaseStruct+--import BaseSyntaxStruct(EI,PI,DI)+import SrcLoc1(HasSrcLoc,srcLoc)+import HsDeclStruct+import HsGuardsStruct+import TiNames(ValueId,localVal')+import TiClasses(HasDef,noDef)+import HsPatUtil(isPVar)+import MapDeclM(MapDeclM,mapDecls)++simpAllFunBind m = map simpFunBind m++{-++Simplify function bindings to move patterns from the lhs of the definition into+a case expression in the rhs. This is similar to the translation described+in section 4.4.3.1 of the (revised) Haskell 98 report, except that we don't+produce a pattern binding with lambdas in the rhs, but a simple function+binding with variables on the lhs, to preserve type correctness.+(You have to avoid the annoying monomorphism restriction!)+-}+{-+simpFunBind ::+ (ValueId i,HasSrcLoc i,+  HasBaseStruct e (EI i e p [d] t c),+  HasBaseStruct p (PI i p), GetBaseStruct p (PI i p),+  HasDef [d] d,MapDeclM d [d],+  HasBaseStruct d (DI i e p [d] t c tp), GetBaseStruct d (DI i e p [d] t c tp))+  => d -> d+-}+simpFunBind d0 =+  case basestruct d of+    Just (HsFunBind s1 ms@(HsMatch s2 f ps rhs ds:ms')) | not trivial ->+         hsFunBind s1 [HsMatch s2 f (map hsPVar xs) (HsBody body) noDef]+       where+         --s2 = srcLoc f -- a more accurate position with the current parser+         trivial = null ms' && all (isJust.isPVar) ps+	 xs = [localVal' ("fx"++show n) (Just s2)|n<-[1..length ps]]+	 body = hsCase (hsTuple' (map hsEVar xs)) (map match2alt ms)+    _ -> d+  where d = mapDecls simpFunBind d0++match2alt (HsMatch s f ps rhs ds) = HsAlt s (hsPTuple' s ps) rhs ds++-- There are no tuples of arity 1, so...+hsTuple' [e] = e+hsTuple' es = hsTuple es+hsPTuple' s [e] = e+hsPTuple' s es = hsPTuple s es
+ tools/base/transforms/SimpPatMatch.hs view
@@ -0,0 +1,310 @@+module SimpPatMatch(module SimpPatMatch,HasOrig,HasIdTy,HasSrcLoc,ValueId) where+import Maybe(isJust,fromMaybe)+import Substitute+import Recursive+import HasBaseStruct+import BaseSyntax hiding (Var)+import DefinedNames(definedVars)+import TiNames(ValueId,localVal')+--import TiPrelude(prelError,prelEqual,prelGE,prelMinus)+import TiClasses(HasDef,noDef,nullDef)+import TypedIds+import UniqueNames(orig,HasOrig)+import FreeNames+--import DefinedNames+import PrettyPrint(pp)+import MUtils(( # ),( <# ),apFst)++simpAllPatMatch ids m = mapExp (simpPatMatch ids) m++data SimpPatIds i = Ids {prelError,prelEqual,prelGE,prelMinus::HsIdentI i}+getSimpPatIds pv = Ids # pv "error" <# pv "==" <# pv ">=" <# pv "-"++class SimpPatMatch i s | s->i where+  simpPatMatch :: SimpPatIds i -> s -> s++instance SimpPatMatch i s => SimpPatMatch i [s] where+  simpPatMatch = map . simpPatMatch++simpPatMatchE ids e = simpPatMatchE' ids r e++simpPatMatchE' ids r e0 =+    case mapEI id (simpPatMatch ids) id (simpAllPatMatch ids) id id e0 of+      HsCase e alts -> convMatch ids (compilePatMatch ids e alts)+      e -> r e++{-++Pattern match simplification, as described in section 3.17.3+of the Haskell 98 report.+-}+{-+compilePatMatch ::+   (ValueId i,HasSrcLoc i,HasIdTy n i,HasOrig i,HasOrig n,+    HasBaseStruct e (EI i e p ds t c),GetBaseStruct e (EI i e p ds t c),+    FreeNames i e,--DefinedNames i p,+    HasBaseStruct p (PI i p),GetBaseStruct p (PI i p),+    HasBaseStruct d (DI i e p ds t c tp),+    HasDef ds d)+  => SimpPatIds i -> e -> [HsAlt e p ds] -> Match i e p+--}+compilePatMatch ids = patMatch_a+  where+    Ids prelError prelEqual prelGE prelMinus = ids++    -- Rule (a)+    patMatch_a e alts =+        mustBeVar' "v0" (srcLoc alts) (Match e) (patMatch_b alts)++    -- Rule (b)+    patMatch_b alts v = foldr (patMatch_c v) err alts+      where+	err = nomatch s "No match"+	s = srcLoc alts++    nomatch s msg = NoMatch s msg++    -- Rule (c)+    patMatch_c v (HsAlt s p rhs ds) e' =+	case rhs of+	  HsBody e -> patMatch_c' v s p e ds e'+	  HsGuard gdrhss -> mustBeVar s e' rhs+	    where+	      rhs y = patMatch_c' v s p (ifGuards (hsEVar y) gdrhss) ds (Var y)+	      ifGuards = foldr ifGuard+	      ifGuard (s,g,e) = hsIf g e+      where+	-- Rule (c), after the guards have been handled+	patMatch_c' v s p e ds e' =+            patMatch_defghij v s p (hsLet' ds e) e'++    -- Introduce a variable to avoid code duplication, if necessary:+    mustBeVarM s e cont = mustBeVar s e (cont. Var)+    --mustBeVarE s e cont = mustBeVar s e (cont. hsEVar)+    mustBeVar s = mustBeVar' "y0" s+    mustBeVar' n s e cont =+      case isHsIdVar =<< basestruct =<< isMatch e of+	Just y -> cont y+	_ -> monoLet y e (cont y)+	  where+	    y = localVal' n (Just s)++    -- Rule (d)-(j)+    patMatch_defghij v s p rhs e' =+      case basestruct p of+	Just bp ->+	  case bp of+	    HsPIrrPat p' -> patMatch_d v s p' rhs -- rule (d)+	    HsPAsPat x p' -> patMatch_defghij v s p' (monoLetVar x v rhs) e' -- rule (e)+	    HsPWildCard -> rhs -- rule (f)+	    HsPApp k ps@(_:_) -> patMatch_g (srcLoc k) v (hsPApp k) ps rhs e' -- rule (g)+	    HsPTuple s ps -> patMatch_g s v (hsPTuple s) ps rhs e' -- rule (g)+	    HsPInfixApp p1 k p2 -> patMatch_g (srcLoc k) v k' [p1,p2] rhs e' -- rule (g)+	      where k' [p1,p2] = hsPInfixApp p1 k p2+	    HsPLit s lit -> -- rule (h) +			  If (hsEVar v `eqTest` hsLit s lit) rhs e'+	    HsPNeg s lit ->+		If (hsEVar v `eqTest` hsNegApp s (hsLit s lit)) rhs e'+	    HsPSucc s n k -> -- rule (s), horror!!+		If (ve `geTest` ke) (monoLet n (Match (ve `minus` ke)) rhs) e'+	      where ve = hsEVar v ; ke = hsLit s k+	    HsPId (HsVar x) -> monoLetVar x v rhs -- rules (i) and (j)+	    HsPParen p' -> patMatch_defghij v s p' rhs e'+	    HsPList s ps -> patMatch_g s v (hsPList s) ps rhs e' -- rule (g), hmm!!+	    HsPRec k lps -> patMatch_mno v k lps rhs e'++	    _ -> keep+	_ -> keep+      where+	keep = patMatch_keep v s p rhs e'++	eqTest = binop prelEqual+	geTest = binop prelGE+	minus  = binop prelMinus++	binop op e1 e2 = hsId op `hsApp` e1 `hsApp` e2++    -- Rule (d)+    patMatch_d v s p' rhs =+	 monoLets xs (map proj xs) rhs+      where+	xs = map getHSName (definedVars p')+	proj x = patMatch_defghij v s p' (Match (hsEVar x))+					 (nomatch s "Irrefutable pattern failed")++    -- Rule (g)+    patMatch_g s v k ps rhs e' = mustBeVarM s e' (patMatch_g' s v k ps rhs)+    patMatch_g' s v k ps rhs e' =+	simpleCase v s p' body e'+      where+	 p' = k (map hsPVar xs)+	 xs = zipWith reuse ps (freshnames s 'x' ps)+	 body = foldr submatch rhs (zip xs ps)+	 submatch (x,p) rest = patMatch_defghij x s p rest e'++	 reuse p x = fromMaybe x (isPVar p)++    -- Rules (m)-(o), labelled fields+    patMatch_mno v k lps rhs e' =+      case lps of+	[] -> patMatch_o v k rhs e'+	[HsField f p] -> patMatch_n v k f p rhs e'+	HsField f p:lps' -> -- rule (m)+	   mustBeVarM (srcLoc k) e' $ \ ey ->+	   patMatch_n v k f p (patMatch_mno v k lps' rhs ey) ey++    -- Rule (n)+    patMatch_n v k f p rhs e' = simpleCase v (srcLoc k) p' rhs e'+      where p' = hsPApp k (map posPat fs)+	    posPat f' = if orig f'==orig f then p else hsPWildCard+	    fs = confields k++    -- Rule (o)+    patMatch_o v k rhs e' = simpleCase v (srcLoc k) p' rhs e'+      where p' = hsPApp k (replicate n hsPWildCard)+	    n = conarity k++patMatch_keep v = simpleCase v -- remaining cases and unimplemented rules++isMatch (Match e) = Just e+isMatch _ = Nothing++{-++A data types to represent the output from the pattern match simplififier.+This makes further transformation easier.+-}+data Match i e p+  = NoMatch SrcLoc String+  | Match e+  | Var i -- special case for Match (hsEVar x)+  | MonoLets [i] [Match i e p] (Match i e p)+  | SimpleCase SrcLoc i p (Match i e p) (Match i e p)+  | If e (Match i e p) (Match i e p)++convMatch ::+  (HasBaseStruct p (PI i p),GetBaseStruct p (PI i p),HasDef ds d,HasIdTy n i,+   FreeNames i e,HasBaseStruct e (EI i e p ds t c))+  => SimpPatIds i -> Match i e p -> e+convMatch ids = conv . simp+  where+    Ids prelError prelEqual prelGE prelMinus = ids++    conv m =+      case m of+	NoMatch s msg -> nomatch s msg+	Match rhs -> rhs+	Var x -> hsEVar x+	MonoLets xs es m' -> monoLets xs (map conv es) (conv m')+	SimpleCase s v p rhs def -> simpleCase v s p rhs (flatten v def)+	If e m1 m2 -> hsIf e (conv m1) (conv m2)++    nomatch s msg = hsId prelError `hsApp` hsLit s (HsString (pp s++": "++msg))++    monoLets [] [] e' = e'+    monoLets xs0 es0 e' =+        hsParen (hsLambda' [hsPVar x|x<-xs] e') `apps` es+      where+	apps e es = foldl hsApp e es+	-- Omit bindings for variables that aren't used:+	(xs,es) = unzip . filter (keep.fst) $ zip xs0 es0+	keep x = x `elem` fvs_e'+	fvs_e' = fvs e'++    flatten v (SimpleCase s v' p rhs def) | v'==v =+        apFst ((s,p,rhs):) (flatten v def)+    flatten v m = ([],m)++    simpleCase v s p rhs ([],NoMatch{}) | irrefutable p =+	hsCase (hsEVar v) [alt (s,p,rhs)]+    simpleCase v s p rhs (alts,def) =+	hsCase (hsEVar v) (map alt ((s,p,rhs):alts)++default_alt)+      where+	default_alt = [alt (s,hsPWildCard,def)]++    alt (s,p,rhs) = HsAlt s p (HsBody (conv rhs)) noDef++    simp m =+      case m of+	MonoLets xs es m' -> case simpLet xs (map simp es) (simp m') of+                               ([], [] ,m') -> m'+			       (xs',es',m') -> MonoLets xs' es' m'+	SimpleCase s v p rhs def -> SimpleCase s v p (simp rhs) def'+          where def' = if irrefutable p+		       then NoMatch s "unreachable"+		       else simp def+	If e m1 m2 -> If e (simp m1) (simp m2)+	_ -> m++    simpLet xs es m = foldr simp1 ([],[],m) (zip xs es)+      where+        simp1 (x,e) (xs,es,m) =+	  case count x m of+	    0 -> (xs,es,m)+	    --1 -> (xs,es,subst e x m) -- causes code explosion in hs2alfa+	    _ -> (x:xs,e:es,m)++    -- Does x occur zero, one or many times in m?+    count x m =+      case m of+	NoMatch s msg -> 0+	Match rhs -> if x `elem` fvs rhs then 2 else 0::Int+	Var y -> if y==x then 1 else 0+	MonoLets xs es m' -> sum (map (count x) es)+count x m' -- x not in xs+	SimpleCase s v p rhs def ->+	    if v==x then 2 else count x rhs+count x def+	If e m1 m2 -> if x `elem` fvs e then 2 else count x m1+count x m2+{-+    -- pre: x occurs as Var x in one place+    subst e x m =+	case m of+	  NoMatch s msg -> m+	  Match rhs -> m+	  Var y -> if y==x then e else m+	  MonoLets xs es m' -> MonoLets xs (map su es) (su m')+	  SimpleCase s v p rhs def -> SimpleCase s v p (su rhs) (su def)+	  If e m1 m2 -> If e (su m1) (su m2)+      where su = subst e x+-}+    fvs e = [v|(HsVar v,ValueNames)<-freeNames e]++hsLambda' [] e = e+hsLambda' xs e = hsLambda xs e++simpleCase v s p rhs e' = SimpleCase s v p rhs e'++monoLetVar x y = if x==y then id else monoLet x (Match (hsEVar y))++-- Monomorphic, nonrecursive variants of let x = e in e'+-- (The Haskell report uses two versions)+--monoLet s x e e' = hsCase e [HsAlt s (hsPVar x) (HsBody e') noDef]+monoLet x e = MonoLets [x] [e]+monoLets [] [] e' = e'+monoLets xs es e' = MonoLets xs es e'++hsLet' ds e = Match (if nullDef ds then e else hsLet ds e)++irrefutable p =+  isJust (isPVar p) || isJust (isIrrPat p) || isWildCardPat p ||+  case isAsPat p of+    Just (_,p) -> irrefutable p+    _ -> False+  ||+  case basestruct p of+    Just (HsPTuple _ ps) -> all irrefutable ps+    Just (HsPInfixApp p1 k p2) -> concount k==1 && all irrefutable [p1,p2]+    Just (HsPApp k ps) -> concount k==1 && all irrefutable ps+    _ -> False++conarity k= conArity . conInfo $ k+confields k = conFields' . conInfo $ k++conFields' = fromMaybe [] . conFields++conInfo k = head [con|con<-constrs k,orig (conName con)==orig k]++concount k = length (constrs k)++constrs k =+  case idTy k of+    ConstrOf _ ti -> constructors ti++freshnames s x ps = [localVal' (x:show n) (Just s)|n<-[1..length ps]]
+ tools/base/transforms/SimpPatMatchBase.hs view
@@ -0,0 +1,11 @@+module SimpPatMatchBase where+import SimpPatMatch+import Recursive(struct)+import SyntaxRec(HsExpI)+import TiBase() -- HasDef [HsDeclI i] (HsDeclI i)+import PrettyPrint2(PrintableOp)+++instance (PrintableOp i, Eq i,HasSrcLoc i,ValueId i,HasIdTy n i,HasOrig i,HasOrig n)+      => SimpPatMatch i (HsExpI i) where+  simpPatMatch ids = simpPatMatchE ids . struct
+ tools/base/transforms/Substitute.hs view
@@ -0,0 +1,40 @@+module Substitute where+import Recursive++{-++The intention with class #Subst# is that #subst s e# applies the+subsitution #s# to all variables occuring in #e#.++It is assumed that name capture will not happen, i.e., #s# does not+affect variables that are bound in (parts of) #e#, and if #x# is free+in e, #s x# does not contain variables that become bound when+substituted into #e#.+-}++class Subst i e | e->i where+  subst :: (i->e) -> e->e++{-++The intention with class #MapExp# is that #mapExp f e# applies the+function #f# to every expression occuring in a larger structure (e.g.,+a list of declarations). Instances of #Subst# will typically make use of+instances of #MapExp#.+-}++class MapExp e s | s->e where+  mapExp :: (e->e) -> s->s++instance MapExp e s => MapExp e [s] where mapExp = map . mapExp++esubst = mapExp . subst++esubst1 var e x = esubst s+  where+    s y = if y==x then e else var y++mapExpRec = mapRec . mapExp++{-+class Subst i e s1 s2 | e->i,s1->i, where+  subst :: (i->e)->s1->s2+-}
+ tools/base/transforms/SubstituteBase.hs view
@@ -0,0 +1,12 @@+module SubstituteBase where+import SubstituteBaseStruct+import Substitute+import Recursive+import Syntax++instance Subst i (HsExpI i) where subst s = substE s . struct++instance MapExp (HsExpI i) (HsDeclI i) where mapExp = mapExpRec+instance MapExp (HsExpI i) (HsExpI i)  where mapExp = mapExpRec++--instance MapExp e ds => MapExp (HsModuleI i ds) where ...
+ tools/base/transforms/SubstituteBaseStruct.hs view
@@ -0,0 +1,29 @@+module SubstituteBaseStruct where+import Substitute+import Recursive+import HasBaseStruct+import BaseSyntax++substE = substE' r++substE' r s e0 =+    case mapEI id (subst s) id (esubst s) id id e0 of+      HsId (HsVar x) -> s x+      HsInfixApp e1 (HsVar x) e2 -> s x `hsApp` e1 `hsApp` e2+      HsLeftSection e (HsVar x) -> s x `hsApp` e+      HsRightSection (HsVar x) e -> error "SubstituteBaseStruct.subst HsRightSection"+      e -> r e++instance MapExp e ds => MapExp e (DI i e p ds t c tp) where mapExp = mapExpD+instance MapExp e ds => MapExp e (EI i e p ds t c)    where mapExp = mapExpE++mapExpD f = mapDI id f id (mapExp f) id id id+mapExpE f = mapEI id f id (mapExp f) id id++instance MapExp e ds => MapExp e (HsMatchI i e p ds) where+  mapExp f = mapMatchI id f id (mapExp f)++instance MapExp e ds => MapExp e (HsModuleI m i ds) where+  mapExp = mapDecls . mapExp++
+ tools/base/transforms/tests/1.hs view
@@ -0,0 +1,4 @@+module A where++~(Just x) = Nothing+
+ tools/base/transforms/tstRemPatBind.hs view
@@ -0,0 +1,25 @@+import RemovePatBinds+import System (getArgs)+import PrettyPrint+import ParseHaskellProgram++import TiNames(ValueId(..))+import HsConstants(prelude_mod)+import PosSyntax+import MapDeclMBase++main = do+    files <- getArgs+    (modss, wms) <- parseHaskellProgram files +    putStrLn $ render+             $ vcat +             $ map (ppi . remPats)+             $ concat modss++apos = SrcLoc "???" 0 0++-- not complete, should probably be somewhere else...+instance ValueId HsName where+    prelVal x = qualid (apos,"Prelude." ++ x)+    localVal x = unqualid (apos,x)+
+ tools/base/tstModules.hs view
@@ -0,0 +1,165 @@+import TypedIds+import WorkModule(WorkModuleI(..))+import HsParser(parse)+import ReAssocBase+import ReAssoc(getInfixes)+import MUtils(collectByFst)--,unlessM+import List(partition,nub)+--import Maybe(fromJust)+import ParseProgram+import ParserOptions+import DefinedNames(definedNames)+import ReAssoc(getInfixes)+import HsIdent(getHSName)+import NamesEntities+import Ents++import UniqueNames+import NoEq+--import UTF8Util+--import PrettyPrint+import PPU+import MUtils+import ScopeProgram+import TiPNT()+import ScopeNamesBase()+import NameMapsBase()+import NameMaps(Role(..),Context(..))+import Unlit(readHaskellFile)+import ParsedSyntax+import DirUtils+import ConvRefsTypes+import Relations() -- for show instances++import TiModule()++main = tstModules =<< getPPopts++tstModules (o,prog,args) = test flags0 args+  where+    test flags args =+	case args of+	  "noprelude":args         -> test flags{prel=False}    args+	  "cpp"      :args         -> test flags{cpp=Just cpp1} args+	  ('c':'p':'p':'=':s):args -> test flags{cpp=Just s}    args++	  "test"     :fs -> tstModules           =<< analyzePrg =<< expand fs+	  "create"   :fs -> do fs' <- expand fs+			       createInterfaceFiles fs' =<< analyzePrg fs'+	  "parse"    :fs -> tstParse             =<< parsePrg   =<< expand fs+	  "preparse" :fs -> tstParse'            =<< parseSrc   =<< expand fs+	  "preparse0":fs -> const (return ())    =<< parseSrc   =<< expand fs+	  "lex"      :fs -> tstLex               =<< readHFiles =<< expand fs+	  "unlit"    :fs -> mapM_ putStr         =<< readHFiles =<< expand fs+	  "defined"  :fs -> tstDefinedNames      =<< parseSrc   =<< expand fs+	  "infixes"  :fs -> tstInfixes           =<< parseSrc   =<< expand fs+	  "scope"    :fs -> tstScope             =<< scopePrg   =<< expand fs+	  "xrefs"    :fs -> createCrossRefs      =<< scopePrg   =<< expand fs+	--"update":[] -> ...+	  _ -> fail "Usage: tstModules [+utf8] [+debug] [cpp[=<cmd>]] [noprelude] (test|create|parse|preparse|lex|unlit|defined|infixes|scope|xrefs) <files>"+      where+	analyzePrg = analyzeFiles' flags parse+	parseSrc = parseSourceFiles (cpp flags) parse+	parsePrg = parseProgram' flags parse+	scopePrg files = scopeProgram' # parsePrg files++	tstModules = pput . ppAssoc . snd++	tstParse  = tstParse' . concat . fst+	tstParse' = pput . vcat++	tstDefinedNames = pput . definedNames+	tstInfixes = putStr . unlines . map (showl.getInfixes)++	tstScope (mss,_) = pput mss++	readHFiles = mapM (readHaskellFile (cpp flags))+	tstLex = mapM_ (print.lexerPass0)++    pput x = putStrLn $ ppu o x+--------------------------------------------------------------------------------++createInterfaceFiles files (modss,amods) =+    do optCreateDirectory "hi"+       writeFile "hi/SourceFiles.txt" (unlines files)+       writeModuleGraphInfo modss+       mapM_ createInterfaceFile amods++  where++    createInterfaceFile (m,wm) =+        writeFile (hiFile m) (render . vcat . interface . exports $ wm)++--    ent2Pair (m,n,s)         = (m,(n,s))+    ent2Pair (Ent m n s)         = (m,(n,s))+    ++    interface = map iface . collectByFst . map (ent2Pair.snd)+      where+        iface (m,allns) = hsModule loc0 m (Just exports) ([],infixes)+        -- :: HsModuleI (HsIdentI (Src HsName)) [HsDeclI (HsIdentI (Src HsName))]+          where+            exports     = toExp `map` oth +            (subs,oth)  = partition (subordinate.snd) allns   +            toExp (n,ty)+                | isClassOrType ty  = HsEThingWith n elems+                | otherwise         = HsEAbs n +                where+                elems = [x | (x,idty) <- subs, idty `belongsTo` getHSName n]++            infixes = [Dec (HsInfixDecl loc0 f [qn']) |+                        mods<-modss, mod<-mods, hsModName mod==m,+                        (qn,f) <- getInfixes mod,+                        let n = getQualified qn; -- Because of Prelude.: etc+		                    qn' = mkUnqual n `asTypeOf` qn+                        ]++    hiFile (Module s) = hiDir++"/"++s++".hi"+    hiDir = "hi" -- name of directory where interface files are put++--------------------------------------------------------------------------------++createCrossRefs (mss,mrs) =+    do optCreateDirectory "hi"+       writeModuleGraphInfo mss+       mapM_ writeRefs (simplifyRefsTypes mrs)+  where+    writeRefs (m,rs) = writeFile ("hi/"++m++".refs") (showl rs)++--- Module graph info ----------------------------------------------------------++writeModuleGraphInfo mss =+    do writeFile "hi/ModuleSourceFiles.hv" (show mfs)+       writeFile "hi/ModuleSourceFiles.txt" (txt2 mfs)+       writeFile "hi/Modules.txt" (showModuleNames mss)+       writeFile "hi/ModuleGraph.hv" (pp g)+       writeFile "hi/ModuleGraph.txt" (txtn g)+       writeFile "hi/ModuleGraphRev.hv" (pp revg)+       writeFile "hi/ModuleGraphRev.txt" (txtn revg)+  where+    mfs = map modfile (concat mss)+    g = moduleGraph mss+    revg = collectByFst [(i,m)|(m,is)<-g,i<-is]++    modfile m = (srcFile m,pp (hsModName m))++    txt2 = unlines . map (\(f,m)->m++" "++f)+    txtn = unlines . map (\(m,is)->pp m++" "++unwords (map pp is))++    -- One strongly connected component per line:+    showModuleNames = unlines . map (unwords . map (pp . hsModName))++    moduleGraph = map moduleImports . concat +    moduleImports m = (hsModName m,nub . map hsImpFrom . hsModImports $ m)++--- Pretty printing ------------------------------------------------------------++ppAssoc x = vcat . map cbn $ x+    where   +    cbn (k,v) = k <> ":" <+> v++--ppResult = ppAssoc . snd++--- Utils ----------------------------------------------------------------------++showl x = unlines . map show $ x
+ tools/base/tstScopeNames.hs view
@@ -0,0 +1,60 @@+import ParseHaskellProgram(parseHaskellProgram)+import ScopeHaskellProgram(scopeHaskellProgram)+import ScopeProgram+import PrettyPrint+import UTF8Util+import MUtils+import ParsedSyntax+import UniqueNames+import TypedIds++import List(sort)+import System(getArgs)+import Directory(doesDirectoryExist,createDirectory)++main = (test=<<getArgs) `catch` utf8err++test args =+  case args of+    "test":files -> tstScope files+    "xrefs":files -> crossRefs files+    _ -> fail "Usage: tstScopeNames (test|xrefs) <files>"++tstScope = putStrLn.upp.fst @@ scopeHaskellProgram @@ parseHaskellProgram+  where upp x = utf8 . pp $ x+++crossRefs files = writeIt.scopeProgram' =<< parseHaskellProgram files+  where+    writeIt (mrs,mss) =+      do optCreateDirectory "hi"+         mapM_ writeRefs (simpmods mrs)+	 writeFile "hi/ModuleSourceFiles.txt" (show (map modfile (concat mss)))++    writeRefs (m,rs) = writeFile ("hi/"++m++".refs") (showl (sort rs))++    optCreateDirectory d = unlessM (doesDirectoryExist d) (createDirectory d)++    simpmods ms = [(m,simprefs refs)|(Module m,refs)<-ms]+    simprefs rs = [(simpp p,(show n,simpsp sp,map (simpos.getHSName) os))|+                    (sp,i,os)<-rs,+		    let PN n p=getHSName i]++    modfile m = (srcFile m,pp (hsModName m))+    +    simpsp ValueNames = V+    simpsp ClassOrTypeNames = T++    simpp (S s) = simpls s++    simpls (SrcLoc f r c) = (r,c)+    simpes (SrcLoc f r c) = (f,(r,c))++    simpos (PN n o) = simpo o+      where+        simpo (G (Module m) n) = Left (m,n)+        simpo (S s) = Right (simpes s)++data SP = V | T deriving (Show,Eq,Ord)++showl x = unlines . map show $ x
+ tools/base/tstTI.hs view
@@ -0,0 +1,43 @@+{-+This is a main program for testing the type checker. You can run it like this++  tstTI [flags] file_1 ... file_n++where flags include++   -debug +debug: turn off/on verbose output+   -utf8 +utf8: turn off/on the use of unicode characters in the output++The files should contain the Haskell modules to be type checked. All modules+implicitly import the Prelude, so one of the files must contain a module+called Prelude.++Mutually recursive modules are accepted.+-}++import HsParser(parse)+import HsModule(HsModuleI(..))+import TiDecorate(TiDecls)+--import TiBase+--import ParsedSyntax(HsModuleR)+import TiHsName()+import ReAssocBase()+import ScopeNamesBase()+import NameMapsBase()+import PPU(ppu,getPPopts,ucatch)+import PrettySymbols(happy)+import PrettyPrint(($$))+import TiProgram(tcProgramFiles)+import MUtils(( # ))+import DirUtils(expand)++main =+  do (o@(u,_),_,args) <- getPPopts+     ucatch u (tstTi o =<< expand args)++tstTi o files =+  putStrLn =<< (ppu o.($$happy).r.fst # tcProgramFiles parse files)++r = id :: I [[HsModuleI i1 (TiDecls i2)]]+--r = id :: I [[HsModuleR]]+type I a = a->a
+ tools/base/tstTI.srclist view
@@ -0,0 +1,67 @@+pretty/Pretty.lhs tests/HaskellLibraries/Ratio.hs tests/HaskellLibraries/Monad.hs tests/GhcLibraries/IOExts.hs tests/HaskellLibraries/Ix.hs tests/HaskellLibraries/Maybe.hs lib/AccList.hs AST/HsGuardsUtil.hs AST/HsTypeStruct.hs AST/HsKindStruct.hs lib/Recursive.hs TI/TiEnv.hs TI/TiConstraints.hs lib/OpTypes.hs lib/Products.hs lib/Monads/HasEnv.lhs lib/Monads/MonadRec.hs lib/Monads/HasState.hs parse2/Lexer/HsTokens.hs tests/GhcLibraries/FiniteMap.hs lib/NoEq.hs tests/HaskellLibraries/System.hs tests/HaskellLibraries/Directory.hs lib/UTF8.hs tests/HaskellLibraries/IO.hs+pretty/PrettyM.hs tests/HaskellLibraries/List.hs AST/HsAssoc.hs AST/HsTypeUtil.hs AST/HsKindUtil.hs lib/Monads/EnvM.hs lib/Monads/StateM.hs lib/Monads/HasOutput.hs parse2/Lexer/HsLayoutPre.hs parse2/Lexer/HsLexUtils.hs lib/Assoc1.hs lib/UTF8Util.hs+pretty/PrettyPrint.hs tests/HaskellLibraries/Array.hs lib/MUtils.hs lib/Assoc.hs lib/NewSCC.hs lib/Lists.hs lib/Monads/OutputM.hs+AST/SrcLoc.hs tests/HaskellLibraries/Numeric.hs tests/HaskellLibraries/Char.hs AST/HsIdent.hs AST/HsLiteral.hs AST/HsTypeMaps.hs AST/HsKindPretty.hs AST/HsKindMaps.hs TI/Unification.hs lib/Lift.hs lib/DirUtils.hs+pretty/PrettyUtil.hs AST/HsName.hs AST/HsGuardsStruct.hs AST/HsPatStruct.hs AST/HsTypePretty.hs AST/HsKind.hs parse2/Lexer/HsLex.hs lib/Unlit.hs defs/ReAssoc.hs+AST/HsModule.hs AST/HsDeclStruct.hs AST/HsGuardsPretty.hs AST/HsGuardsMaps.hs AST/HsExpStruct.hs AST/HsPatPretty.hs AST/HsPatMaps.hs AST/HsType.hs TI/TiNames.hs Modules/TypedIds.hs AST/HasBaseName.hs parse2/Lexer/HsLexerPass1.hs parse2/LexUtil.hs+AST/HsDeclPretty.hs AST/HsDeclMaps.hs AST/HsExpMaps.hs AST/HsGuards.hs AST/HsPatUtil.hs defs/DefinedNames.hs AST/HsConstants.hs Modules/NamesEntities.lhs defs/NameMaps.hs parse2/ParseMonad.hs+AST/HsDeclUtil.hs AST/HsExpUtil.hs AST/HsPat.hs TI/TiDefinedNames.hs defs/FreeNames.hs Modules/Modules.lhs defs/ScopeNames.hs parse2/Lexer/HsLexer.hs+AST/HsDecl.hs AST/HsExpPretty.hs TI/TiFreeNames.hs Modules/AST4ModSys.hs Modules/CheckModules.lhs+AST/HsExp.hs Modules/PPModules.hs+AST/BaseSyntaxStruct.hs+AST/HasBaseStruct.hs defs/DefinedNamesBaseStruct.hs Modules/SCMs.hs defs/FreeNamesBaseStruct.hs defs/NameMapsBaseStruct.hs defs/ReAssocBaseStruct.hs+syntax/SyntaxRec.hs TI/TiPrelude.hs Modules/WorkModule.hs defs/ScopeNamesBaseStruct.hs+syntax/Syntax.hs ParseProgram.hs+TI/TiTypes.hs defs/DefinedNamesBase.hs defs/UniqueNames.hs+TI/TiKinds.hs defs/FreeNamesBase.hs syntax/SyntaxUtil.hs parse2/SourceNames.hs defs/NameMapsBase.hs defs/ReAssocBase.hs+TI/TiSolve.hs TI/TiPretty.hs parse2/Parser/PosSyntax.hs parse2/NumberNames.hs parse2/Parser/ParseUtil.hs defs/ScopeNamesBase.hs+TI/TiBySuper.hs TI/TiInstanceDB.hs parse2/ParsedSyntax.hs parse2/Parser/HsParser.hs+TI/TiMonad.hs ScopeProgram.hs+TI/TiClasses.hs TI/TiHsName.hs+TI/TiContextReduction.hs TI/TiSCC.hs+TI/TiUtil.hs+TI/TI.hs+TI/TiRhs.hs TI/TiLit.hs TI/TiT.hs+TI/TiP.hs TI/TiE.hs+TI/TiD.hs+TI/TiBaseStruct.hs+TI/TiBase.hs TiProgram.hs+TI/TiDecorate.hs+tstTI.hs++tests/HaskellLibraries/Prelude.hs+tests/HaskellLibraries/PreludeBuiltin.hs+tests/HaskellLibraries/PreludeList.hs+tests/HaskellLibraries/PreludeIO.hs+tests/HaskellLibraries/PreludeText.hs+tests/HaskellLibraries/Time.hs+tests/HaskellLibraries/Locale.hs++tests/GhcLibraries/Int.hs+pretty/PPU.hs+lib/Monads/Tree.hs+lib/Monads/MT.hs+Modules/Entity.hs+Modules/Relations.lhs+AST/HsFieldsStruct.hs+AST/HsFieldsPretty.hs+AST/HsFieldsMaps.hs+AST/HsFields.hs+TI/TiFields.hs+parse2/ParserOptions.hs+AST/HsAssocStruct.hs+AST/HsAssocPretty.hs+AST/HsAssocUtil.hs+AST/HsIdentPretty.hs+AST/HsLiteralPretty.hs+AST/BaseSyntax.hs+AST/BaseSyntaxMaps.hs+AST/BaseSyntaxPretty.hs+AST/BaseSyntaxUtil.hs+AST/SrcLocPretty.hs+lib/AbstractIO.hs+defs/ReAssocModule.hs+defs/ScopeModule.hs+pretty/PrettySymbols.hs+tests/GhcLibraries/Set.hs+TI/TiModule.hs
+ tools/configure view
@@ -0,0 +1,100 @@+#!/bin/sh++## Note: The Makefile automatically invokes this script if necessary.++## This configure script does two things at the moment:+##+##   1. Checks that GHC is available (should also check for version >=5)+##+##   2. Picks a make tool. Humake is preferred if available+##      (except under Darwin), ghc --make is used otherwise.+##+## The result is recorded as links to scripts in the script/ subdirectory.+## Various Makefiles refer to these scripts.++### Auxiliary functions ########################################################+giveup() {+  echo "$@"+  echo "Giving up."+  exit 1+}++qwhich() {+  which "$@" 2>/dev/null+}++### Check that GHC is available ################################################+GHC=${GHC-ghc}+ghc=`${GHC} --numeric-version`++[ -n "$ghc" ] || giveup "${GHC} doesn't seem to work."+# Check that the version number is >=5...++echo "Using GHC version $ghc (the command is ${GHC})"++### Check which make tools are available #######################################++ghcxmake=`qwhich ghcxmake`++if [ "${USE_HUMAKE-yes}" != "yes" ] ; then+  echo "Not using Humake"+elif [ `uname` = Darwin ]; then+  echo "Humake is broken under Darwin (Mac OS X), skipping test."+else+  humake=`qwhich humake`+fi+[ -n "$humake" ] && ghumake=`qwhich ghumake`+[ -n "$ghumake" ] && ghuxmake=`qwhich ghuxmake`+++### Pick make scripts ##########################################################++echo -n "Compiling plain Haskell programs with: "+if [ -n "$ghumake" ] ; then+  hsmake=myghumake+  echo "ghumake (Humake)"+else+  hsmake=myghc--make+  echo "ghc --make"+fi++echo -n "Compiling Haskell programs that use Fudgets with: "++if [ -n "$ghuxmake" ] ; then+  hsfudmake=myghuxmake+  echo "ghuxmake (Humake)"+elif [ -n "$ghcxmake" ] ; then+  hsfudmake=myghcxmake+  echo "ghcxmake (ghc --make)"+else+  echo "found no suitable tool!"+  #giveup ...+fi++### Checking for InternetLib ###################################################++I=InternetLib+B=pfe/Browser+L=/usr/local/lib+P=package.conf+[ -r "$B/$I/$P" ] || {+  if [ -r "$L/$I/$P" ] ; then+    echo "Using InternetLib found in $L"+    ln -s $L/$I $B/$I+  else+    echo "Didn't find InternetLib (in $L)."+    echo "Manually install it (in $L) or create a link to it in $B"+  fi+}++### Creating links to scripts ##################################################+cd scripts++rm -f hsmake.sh+ln -s "$hsmake" hsmake.sh++[ -n "$hsfudmake" ] && {+  rm -f hsfudmake.sh+  ln -s "$hsfudmake" hsfudmake.sh+}+### Done! ######################################################################
+ tools/evman/HEADER.html view
@@ -0,0 +1,15 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<head>+<title>Programatica Tools, tools/pfe</title>+<link rel=parent href="../" title="Programatica Tools">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../web/icon1.png">+</head>+<body>+<h1><img align=right src="../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/evman</h2>++The README file is displayed below the directory index.
+ tools/evman/Makefile view
@@ -0,0 +1,60 @@+all: extra_files++extra_files: I_say_so_icons QuickCheckIcons AlfaFiles TestCaseIcons++L=../lib/Programatica+C=$L/types/certificate+S=../../../../../evman/servers++SERVERS=I_say_so QuickCheck Alfa Plover TestCase Cut Isabelle+# Mono++lib::+	@$(MAKE) extra_files+	@sh install.sh $(SERVERS)+	@cd $L; ln -s ../../evman/functions.sh .+	@cd $L; ln -s ../../evman/validation.sh .+++################################################################################++I=servers/I_say_so+I_say_so_icons: $I/valid.gif $I/invalid.gif $I/unknown.gif++$I/valid.gif: ;	@ln -sf ../../icons/blue.gif $I/valid.gif+$I/invalid.gif: ; @ln -sf ../../icons/blue_X.gif $I/invalid.gif+$I/unknown.gif: ; @ln -sf ../../icons/blue_Question.gif $I/unknown.gif++################################################################################++Q=servers/QuickCheck+QuickCheckIcons: $Q/valid.gif $Q/invalid.gif $Q/unknown.gif++$Q/unknown.gif: ; @ln -sf icons/quick_check_Unknown.gif $Q/unknown.gif+$Q/invalid.gif: ; @ln -sf icons/quick_check_Fail.gif $Q/invalid.gif+$Q/valid.gif: ; @ln -sf icons/quick_check_OK.gif $Q/valid.gif++################################################################################++A=servers/Alfa+AS=../../../hs2alfa/tests++AlfaFiles: $A/Haskell.alfa $A/Logic.alfa $A/Integer.alfa++$A/Haskell.alfa: ; @cd $A; ln -s $(AS)/Haskell.alfa .+$A/Logic.alfa: ; @cd $A; ln -s $(AS)/Logic.alfa .+$A/Integer.alfa: ; @cd $A; ln -s $(AS)/Integer.alfa .+++################################################################################+T=servers/TestCase+TestCaseIcons: $T/valid.gif $T/invalid.gif $T/unknown.gif++$T/unknown.gif: ; @ln -sf ../../icons/testcase_unknown.gif $T/unknown.gif+$T/invalid.gif: ; @ln -sf ../../icons/testcase_invalid.gif $T/invalid.gif+$T/valid.gif: ; @ln -sf ../../icons/testcase_valid.gif $T/valid.gif+++################################################################################++clean:
+ tools/evman/README.html view
@@ -0,0 +1,232 @@+<!-- This file included by the web server in the automatically generated+     directory index.+-->+<h2>What is in this directory (evman)</h2>++This directory contains files relating to evidence (certificate)+management, in particular the command line tool <code>cert</code> and+the implementation of the certificate servers.++<p>+The code for certificate managment provided here is mostly inteded to+serve as <strong>glue</strong> between the main Programatica tools+(pfe) and external tools, such as theorem provers, and is implemented+as shell scripts (but perhaps it would be better to do all of this in+Haskell...).++<h3>Files</h3>++<dl>+<dt><a href="cert.sh"><code>cert.sh</code></a>+<dd>This is the main command-line based certificate management tool.+    It is also used from pfebrowser, so interaction with the user has to+    be designed so that it works both from the command line and in the+    GUI provided by pfebrowser.+    <p>+    Some generic certificate management functionality is implemented directly+    in <code>cert.sh</code>, while certificate type specific work is delegated+    to scripts in the <code>servers</code> subdirectory.+    At present, two functions are delegated: <code>new</code> to create new+    certificate and <code>validate</code> to validate certificates.+<dt><a href="functions.sh"><code>functions.sh</code></a>,+    <a href="validation.sh"><code>validation.sh</code></a>+<dd>Auxiliary shell functions used by many of the certificate management+    scripts.+<dt><code>Makefile</code>+<dd>Guess what...+</dl>++<h3>Subdirectories</h3>++<dl>+<dt>icons+<dd>A collection of certificate icons provided by Mark P. Jones.+<dt>servers+<dd>This directory contains implementation of servers for specific+    certificate types, with one subdirectory per server.+</dl>++<h3>Certificate server implementation</h3>++The following is required for each certificate server (some of these+things might be created automatically, using the Makefile):++<ol>+<li>Certificate type description file: <code>server.attr</code>+    (more details are given below),+<li>Certificate icons: <code>invalid.gif</code>,+    <code>unknown.gif</code>, <code>valid.gif</code>,+<li>The program <code>new</code> for creating new certificates, invoked+    from <code>cert.sh</code>,+<li>The program <code>validate</code> for validating certificates, invoked+    from <code>cert.sh</code>.+</ol>++The existing servers have <code>new</code> and <code>validate</code>+programs that are implemented as fairly short shell scripts.+An easy way to create a new server is to copy and modify an existing+one. When common patterns emerge, functions can be moved to the+<code>funtions.sh</code> or <code>validation.sh</code> files.+<p>+There is no requirement that the programs <code>new</code> and+<code>validate</code> are implemented as shell scripts. All that is+required is that the files are executable and behave as expected.++<h4>Certificate files maintained by certificate servers</h4>+<p>+Certificate servers are expected to create and maintain a number of+files for each certificate:++<table>+<tr><th>File<th>What it is used for+<tr>+<td><code>cert.attrs</code>+<td>This file holds various certificate attributes. Attribute files and+    certificate attributes are described in more detail below.+<tr><td><code>valid</code><br><code>invalid</code>+<td>These files are datestamps to indicate when the certificate was last+    marked valid or invalid. This helps tools quickly determine if a+    certificate is valid, invalid or if a more thorough test is needed to+    determine its status.+<tr><td><code>deps</code>+<td>This file records a signature of the parts of the source code that+    the certified assertion depends on. It can be generated with the+    command+    <blockquote><code>pfe tasig <var>M.A</var> >.../deps</code></blockquote>+    It allows tools to tell the+    difference between source code changes that affect the validity of+    an assertion from irrelevant changes, so that needless revalidation+    can be avoided.  It also allows the <code>I_say_so</code>+    certificate server to use the command <code>pfe tadiff ...</code> to+    present a list of relevant changes to the user.+<tr><td><code>srclist.txt</code>+<td>This file caches the list of source files containing code that the+    certified assertion depends on. Together with the <code>valid</code>+    and <code>invalid</code> datestamp files, it is often possible to+    determine the validity of a certificate just by consulting+    the last modification date of files. It is used by the command+    <code>cert ls</code>.+<tr><td><code>output.txt</code>+    <td>This is the standard place for diagnostic output from the certificate+        server. The user can consult this, for example to find out why+        certificate validation failed.+</table>++<h3>Attribute files</h3>++Both servers and the certificates they create are described by a set of+attributes that are stored in <em>attribute files</em>. There are both+Haskell functions and shell script functions to parse attribute+files.++<h4>Attribute file format</h4>++ Attribute files use a textual file format for association lists.+ Each line in an attribute file may specify a binding of a tag+ string to a value string using a single colon to separate the+ two.  If the colon is omitted, then a value of "" is assumed.+ Leading whitespace at the beginning of each line and preceding+ the value (i.e., after the first, if any, colon) is ignored.+ Lines containing only whitespace, or in which the first+ non-whitespace character is a '#' are treated as comments.+ (Despite this, we do not intend attribute files to be a+ human-readable format under normal circumstances.)++<p>+Here is a sample attribute file:++<blockquote><pre>+ # This is a comment+ + foo: your name here!+ date:today+ + # here is a line with no value ...+ set filec+ + foo:bar+ # if the same tag is used more than once, then+ # we simply get multiple attribute values with+ # the same tag.+</pre></blockquote>++<h3>Server attributes</h3>++Certificate <strong>server attributes</strong> are stored in a file called+<code>server.attr</code> in the server's directory. For an example,+see <a href="servers/Alfa/server.attr">servers/Alfa/server.attr</a>++<p>+<p>The tools currently assumes the following attributes to be present:</p>++<table>+<tr><th>Attribute name<th>Attribute meaning+<tr><td><code>name</code>+<td>The name of the server+<tr><td><code>description</code>+<td>A one-line explanation of what kind of certificates the server creates.+<tr><td><code>attribute</code>+<td>Certificate attribute description. This can be given any number of times+to describe what user editable attributes are present in certificates created+by this server. (These have a specific syntax that should be documented+in more detail!)++</table>++<p>Additional fields can be present.++<h3>Certificate attributes</h3>++<p>+<strong>Certificate attributes</strong> are (to some extent) defined by the+different certificate servers. However, some attributes are expected to have+the same meaning in all certificates:</p>++<table>+<tr><th>Attribute name<th>Attribute meaning+<tr><td><code>type</code>+    <td>The name of the server that created the certificate.+<tr><td><code>conc</code>+<td>Conclusion. This is the name of the assertion that the certificate serves+    as evidence for. It should be an <em>unqualified</em> assertion identifer.+    (This is not meaningful in all certificate types.)+<tr><td><code>hyp<code>+    <td>Hypotheses. This is either <code>..</code> or a list of <em>qualified</em>+        identifiers. A more detailed description is given below.+<tr><td><code>file</code><br><code>file/</code><var>type</var>+    <td>Names of auxiliary files used to establish the validity of+        the certificate. For example, for Alfa certificates, the name of the+	file containing the proof is recorded in the attribute+        <code>file/proof</code>.+</table>++<p>Additional fields can be present.++<h4>Hypotheses</h4>++For certificates that certify a sequent+ <code><var>hyp</var>|-<var>conc</var></code>, the <code>hyp</code>+ has the following forms:++<ul>+<li><p><code>..</code>, which means that the validity of the certificate+	can depend on <em>everything</em> referenced (directly or indirectly) from the+	assertion named in the <code>conc</code> attribute.++<li>A list of qualified identifiers.+    Each identifier in the list should denote either an assertion or a value.+     <ul>+	<li>For assertion names, the hypothesis is that the+	named assertion is valid.+        <li>For value names, the validity of the+	certificate can depend on the definition of that name.+     </ul>+     	Definitions of names that are free in the assertion, or in+	definitions of explicitly listed names, do not influence the validity+	of the assertion. (In effect, free names are implicitly universally+	quantified.)++</ul>+<hr>+<address>Authors: various</address>+<address>Contact: <a href="/~hallgren/">Thomas Hallgren</a></address>
+ tools/evman/cert.sh view
@@ -0,0 +1,270 @@+#!/bin/bash++defaultPROGRAMATICA="/home/project/pacsoft/tools/lib/Programatica"+PROGRAMATICA="${PROGRAMATICA-$defaultPROGRAMATICA}"++###+# Should agree with the corresponding definitions in property/pfe/PFE_Certs.hs:+certsDir=hi/cert/ # Also change function outofdate below if you change this!+certTypesDir="$PROGRAMATICA/types/certificate/"+export PROGRAMATICA certsDir certTypesDir++. "$PROGRAMATICA/functions.sh"++types() {+  cd "$certTypesDir"+  fmt="%-11.11s %-5.5s %-16s\n"+  l="----------------"+  printf "$fmt" Type Ver Description+  printf "$fmt" $l $l $l+  for type in * ; do+    attrs="$type/server.attr"+    if [ -r "$type/server.attr" ] ; then+      desc="`getattr description "$attrs"`"+      ver="`getattr version "$attrs"`"+      printf "$fmt" "$type" "$ver" "$desc"+    fi+  done+}++assertions() {+  #find . -name assert.txt | sed -e 's%^./%%' -e 's%/assert.txt$%%' | sort -u+  pfe assertions "$@" | sed 's% %/%' | sort -u+}+++todo() {+  checkproject+  #pfe certscan && cd "$certsDir" || abort "Something went wrong."+  +  certified() {+    [ -d "$certsDir" ] && cd "$certsDir" && grep ^conc: `find . -name cert.attr` /dev/null |+      sed -e 's%^./%%' -e 's%[^/]*/cert.attr:conc: %%' | sort -u+  }++  diff <(certified) <(assertions "$@") | grep '^> '+}++no_certs()+{+  errmsg "Found no certificates. Try 'cert todo'."+  exit 0+}++lscert() {+  checkproject+  cd "$certsDir" 2>/dev/null || no_certs+  fmt="%-16.16s %-16.16s %-10.10s %-8.8s %-18s\n"+  l="--------------------------"+  printf "$fmt" Module Certificate Type Status Assertion+  printf "$fmt" $l $l $l $l $l+  find . -name cert.attr | while read certattrs; do+    echo "$certattrs" | {+      IFS=/ read dot module name rest+      type=`getattr type "$certattrs"`+      conc=`getattr conc "$certattrs"`+      hyp=`getattr hyp "$certattrs"`+      valid="`quickvalidate $module/$name`"+      printf "$fmt" "$module" "$name" "${type-?}" "$valid" "$hyp|-${conc--}"+    }+  done+}++dotgraph() {+  checkproject+  cd "$certsDir" 2>/dev/null || no_certs+  echo "digraph CertGraph {"+  find . -name cert.attr | while read certattrs; do+    echo "$certattrs" | {+      IFS=/ read dot module name rest+      conc=`getattr conc "$certattrs"`+      hyp=`getattr hyp "$certattrs"`+      echo "\"$conc\"->{"+      for h in $hyp ; do+        echo -n "\"$h\"; "+      done+      echo "}"+    }+  done+  echo "}"+}++info() {+  cert="$1"+  [ -n "$cert" ] || abort "Usage: cert info <cert>"+  checkproject+  checkcert "$cert" # sets $attr+  type=`getattr type "$attr"`+  infocmd="$certTypesDir$type/info"+  if [ -x "$infocmd" ] ; then+    "$infocmd" "$attr"+  else+    echo "Generic certificate info:"+    cat "$attr"+    certpath="$certsDir$cert"+    status=`cd $certsDir && quickvalidate $cert`+    echo "Status: $status (use 'cert validate' to be certain)"+    case "$status" in+      Valid*) echo "Last validated: `cat $certpath/valid`" ;;+      Invalid*) echo "Marked invalid on: `cat $certpath/invalid`" ;;+    esac+    #echo Files: `certsDir="" certfiles $certpath` # Can be very long!+  fi+}++rmcert() {+  checkproject+  for cert2 in "$@" ; do+    echo "$cert2" | {+      IFS=/. read module certname bla+      certpath="$certsDir$module/$certname"+      if [ -d "$certpath" ] ; then+	checkmodule "$module" && {+	  pfe pragmas "$module" | grep -q "cert:$certname" &&+	    warning "certiticate annotation still present for $certname in $module."+	  rm -r "$certpath"+	}+      else+        warning "$module/$certname does not seem to exists."+      fi+    }+  done+}++sign() {+  [ -n "$1" ] || abort "Usage: cert sign <cert>"+  checkproject+  certpath="$certsDir$1"+  checkcert "$1" # Sets $attr+  sig="$certpath/cert.attr.sig"+  [ -f "$sig" ] && abort "$1 is already signed."+  gpg -b -a <"$attr" -o "$sig"+}++verify() {+  [ -n "$1" ] || abort "Usage: cert verify <cert>"+  checkproject+  certpath="$certsDir$1"+  checkcert "$1" # Sets  $attr+  sig="$certpath/cert.attr.sig"+  [ -r "$sig" ] || abort  "Didn't find signature for certificate $1"+  gpg --verify "$sig" "$attr"+}++check_certtype() {+  dir="$certTypesDir$1/"+  [ -r "${dir}server.attr" ] ||+    abort "cert $cmd: unknown certificate type: $type"+}++delegate_type() {+  cmd="$1";type="$2"+  [ -n "$type" ] || abort "Usage: cert $cmd <type> ..."+  check_certtype "$type" # sets $dir+  cmdpath="${dir}${cmd}"+  [ -x "$cmdpath" ] || abort "cert $cmd: command not supported by type $type"+  shift;shift+  SERVERDIR="$dir"+  export SERVERDIR+  "$cmdpath" "$@"+}++delegate_cert() {+  cmd="$1"; cert="$2"+  [ -n "$cert" ] || abort "Usage: cert $1 <cert>"+  checkproject+  certpath="$certsDir$cert"+  checkcert "$cert" # Sets $attr+  type=`getattr type "$attr"`+  shift+  delegate_type "$cmd" "$type" "$@"+}++certnames() {+  ( cd "$certsDir" 2>/dev/null || no_certs &&+  find . -name cert.attr ) | while IFS=/ read dot module name rest; do+    echo "$module/$name"+  done+}++validate_all() {+  checkproject+  for cert in `certnames` ; do+    echo "*** $cert"+    delegate_cert validate "$cert"+  done+}++validate() {+  case "$2" in+    -all) validate_all ;;+    *) delegate_cert "$@"+  esac+}++new_all() {+  checkproject+  type="$1" ; shift+  check_certtype "$type" # sets $dir+  attrs="${dir}server.attr"+  case "`getattr has_sequent "$attrs"`" in+    no) abort "'cert new -all' is not implemented for $type certificates."+  esac+  abbr="`getattr abbrev ${dir}/server.attr`"+  [ -n "$abbr" ] || abbr="$type"+  #echo "new_all type=$type $@"+  pfe assertions "$@" | while read module conc ; do+    delegate_type new "$type" "$module/$abbr$conc" "$conc"+  done+}++new() {+  case "$2" in+    -all) shift; shift ; new_all "$@" ;;+    *) delegate_type "$@"+  esac+}++recreate() {+  checkproject+  for cert in `certnames` ; do+    checkcert "$cert" # Sets $attr+    c=$certsDir$cert/cert.attr+    type=`getattr type $c`+    conc=`getattr conc $c`+    hyp=`getattr hyp $c`+    [ "$hyp" = ".." ] && hyp=""+    echo "cert new $type $cert $conc $hyp"+  done+}++setcertattr() {+  checkproject+  cert="$1"+  attrname="$2"+  attrval="$3"+  [ -n "$cert" ] && [ -n "$attrname" ] && [ -n "$attrval" ] ||+    abort "Usage: cert setattr <cert> <attr> <value>"+  checkcert "$cert" # Sets $attr+  setattr "$attrname" "$attrval" "$attr"+}++usage() {+  abort "Usage: cert types|ls|dotgraph|todo|new|info|validate|sign|verify|rm|recreate|setattr ..."+}++case "${1-help}" in+  types) types ;;+  todo) shift; todo "$@" ;;+  ls) lscert ;;+  dotgraph) dotgraph ;;+  new) new "$@" ;;+  info) shift; info "$@" ;;+  validate) validate "$@" ;;+  rm) shift; rmcert "$@" ;;+  recreate) recreate ;;+  sign) shift; sign "$@" ;;+  verify) shift; verify "$@" ;;+  setattr) shift; setcertattr "$@" ;;+  *) usage+esac
+ tools/evman/functions.sh view
@@ -0,0 +1,159 @@++### Functions for use in shell scripts #########################################++errmsg() {+  echo >&2 "$*"+}++warning() {+  echo >&2 "Warning: $*"+}++abort() {+  errmsg "$*"+  exit 1+}++# Reading certificate/server attributes:+getattr() {+  egrep "^$1:" <"$2" | sed "s%^[a-zA-Z/._]*: *%%"+}++getcertattr() {+  getattr $1 "$certsDir$2/cert.attr"+}++listcertattr() {+  for w in `getcertattr "$1" "$2"` ; do+    echo $w+  done+}++getserverattr() {+  getattr "$1" "$SERVERDIR/server.attr"+}++setattr() {+  grep -v "^$1:" <"$3" | { cat ; echo "$1: $2" ; } >"$3.new"+  mv "$3.new" "$3"+}++certauxfiles() {+  attrs="$1/cert.attr"+  echo "$certsDir$attrs"+  getattr "file(/[a-z]*)?" "$attrs"+}++certfiles() {+  certauxfiles "$1"+  cat "$1/srclist.txt"+}++# Check that a module exists:+checkmodule() {+  pfe pragmas "$1" >/dev/null || { echo "$1"; exit 1; }+}++# Check that a project exists:+checkproject() {+  [ -d hi ] ||+    abort "No pfe project in this directory. (Use pfesetup or pfe new.)"++  if pfeclient >/dev/null  2>&1 ; then+    pfe() {+     pfeclient "$@"+    }+  elif [ "$WARNSLOW" != "no" ] ; then+    warning "PFE server not found. Things can get slow..."+    WARNSLOW=no+    export WARNSLOW+  fi+}++# Check that a certificate exists and set $attr:+checkcert() {+  attr="$certsDir$1/cert.attr"+  [ -r "$attr" ] ||+    abort "Didn't find certificate $1. (Use 'cert new' to create certificates.)"+}++checkassertion() {+  m="${1%.*}"+  a="${1##*.}"+  # Check that the argument is a qualified name and that the assertion exists.+  [ "$a" != "$1" ] && pfe assertions "$m" | grep -q "^$m $a\$"+}++checkcertannot() {+  checkmodule "$1"+  pfe pragmas "$1" | grep -q "cert:$2" || {+    warning "found no certiticate annotation for $2 in $1."+  }+}++# List of modules that a specified modules depends on+subgraph() {+  pfe modules $* | tail +2+}++# The list of source files that a specified module depends on+subgraphfiles() {+  pfe file `subgraph $*` | sed 's/^.*: //'+}++# Create a datestamp file when a certificate is marked valid/invalid+# Also save the list of source files that the certificate depends on+datestamp() {+  valid="${1-valid}"+  certpath=$2 # the path of a certificate directory+  module=$3 # the name of the module containing the certificate+  echo -n "Certificate marked $valid on "+  date | tee "$certpath/$valid"+  subgraphfiles $module >$certpath/srclist.txt+}++outofdate() {+  srcs="$1/srclist.txt"+  attrs="$1/cert.attr"+  datestamp="$2"+  if [ -r "$srcs" ] && [ -r "$attrs" ] ; then+    certfiles "$1" |+    while read path ; do+      # Grr. ../../ below is to reverse the effect of cd $certsDir in lscert+      if [ "../../$path" -nt "$datestamp" ] ; then+        echo '?'+	break+      fi+    done+  else+    echo '??'+  fi+}++quickvalidate() {+  # A quick (unreliable) test if a certificate is valid+  certpath="$1"+  valid="$certpath/valid"+  invalid="$certpath/invalid"+  if [ -f "$valid" ] ; then+    if [ -f "$invalid" ] && [ "$invalid" -nt "$valid" ] ; then+      echo Invalid`outofdate $certpath $invalid`+    else+      echo Valid`outofdate $certpath $valid`+    fi+  elif [ -f "$invalid" ] ; then+   echo Invalid`outofdate $certpath $invalid`+  else +   echo New+  fi+}++# Ask the user to confirm somthing (answer a yes-or-no question)+user_confirmation() {+  tty -s || echo >&2 "+-+ Yes No" # For pfebrowser+  read ans+  case "$ans" in+    [Yy]es) true ;;+    *) false+  esac+}
+ tools/evman/icons/blue.gif view
binary file changed (absent → 1004 bytes)
+ tools/evman/icons/blue_Question.gif view
binary file changed (absent → 973 bytes)
+ tools/evman/icons/blue_X.gif view
binary file changed (absent → 982 bytes)
+ tools/evman/icons/certs.gif view
binary file changed (absent → 5428 bytes)
+ tools/evman/icons/progcert.gif view
binary file changed (absent → 1134 bytes)
+ tools/evman/icons/smblue.gif view
binary file changed (absent → 955 bytes)
+ tools/evman/icons/smiley.sad.gif view
binary file changed (absent → 97 bytes)
+ tools/evman/icons/smprogcert.gif view
binary file changed (absent → 989 bytes)
+ tools/evman/icons/smtestcase.gif view
binary file changed (absent → 889 bytes)
+ tools/evman/icons/template.gif view
binary file changed (absent → 1015 bytes)
+ tools/evman/icons/testcase.gif view
binary file changed (absent → 1023 bytes)
+ tools/evman/icons/testcase_invalid.gif view
binary file changed (absent → 1037 bytes)
+ tools/evman/icons/testcase_unknown.gif view
binary file changed (absent → 1052 bytes)
+ tools/evman/icons/testcase_valid.gif view
binary file changed (absent → 1039 bytes)
+ tools/evman/install.sh view
@@ -0,0 +1,10 @@+#!/bin/sh++L=../lib/Programatica+C=$L/types/certificate+S=../../../../../evman/servers++for server ; do+  mkdir -p $C/$server+  (cd $C/$server; ln -s $S/$server/* .; rm -f CVS)+done
+ tools/evman/servers/Alfa/invalid.gif view
binary file changed (absent → 1284 bytes)
+ tools/evman/servers/Alfa/new view
@@ -0,0 +1,58 @@+#!/bin/sh++# This script should be invoked from cert+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/functions.sh"+[ -n "$certsDir" ] || abort 'Bug: $certsDir is not set'++type=Alfa++usage() { abort "Usage: cert new $type <module/cert> <conc> [<hyp>]"; }++createcert() {+  mkdir -p "$1"+  cat >"$1/cert.attr" <<EOF+type: $type+version: `getserverattr version`+conc: $2+hyp: $3+who: $USER+date: `LANG=C date`+EOF+}++checkhyps() {+  oldIFS="$IFS"+  IFS=", "+  err=0+  for h in $* ; do+    [ "$h" = ".." ] || checkassertion "$h" || { err=1; echo "$h ??"; }+  done+  IFS="$oldIFS"+  return $err+}++[ -n "$1" ] || usage+cert="$1"++[ -n "$2" ] || usage+conc="$2"+shift;shift;+#[ -n "$*" ] && usage # Hypotheses are not supported (yet).+hyp="$*"+[ -n "$hyp" ] || hyp=".."++checkproject++module="${cert%/*}"+certname="${cert##*/}"+#checkcertannot "$module" "$certname"+certpath="$module/$certname"+[ -d "$certsDir$certpath" ] && abort "$cert already exists"+checkassertion "$module.$conc" ||+  abort "Error: $conc is not a named assertion in module $module"+checkhyps "$hyp" || abort "Error: malformed hypothesis"++createcert "$certsDir$certpath" "$conc" "$hyp"
+ tools/evman/servers/Alfa/server.attr view
@@ -0,0 +1,15 @@+name: Alfa+version: 0.05+release: January 5, 2005+src: http://www.cse.ogi.edu/~hallgren/Programatica/+description: Formal proof by shallow embedding of Haskell in Alfa++# Some ideas on how to specify what attributes certificates have,+# to allow generic tools (pfebrowser in particular) to create and+# manipulate certificates.+attribute: name=conc, type=string/assertion, label=Conclusion, required+attribute: name=hyp, type=string, label="Depends on", optional+attribute: name=file/proof, type=string/file, required+attribute: name=proof, type=string/identifier, required+attribute: name=Comment, type=string+attribute: name=SimplePatterns, type=bool, label="Simple Patterns"
+ tools/evman/servers/Alfa/unknown.gif view
binary file changed (absent → 1335 bytes)
+ tools/evman/servers/Alfa/valid.gif view
binary file changed (absent → 1317 bytes)
+ tools/evman/servers/Alfa/validate view
@@ -0,0 +1,153 @@+#!/bin/bash++# Script to validate Alfa certificates.+# This script should be invoked from cert.+# It expects "$PROGRAMATICA", "$certsDir" and "$SERVERDIR" to be set.+# It also expects the name of a certificate on the command line.++type=Alfa++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/validation.sh" # defines $module, $conc, $attr, $certpath, etc+hyp=`getattr hyp "$attr"`++proof_dir=alfa++### Auxiliary functions ########################################################++## Use for testing, works without Alfa:+fakealfacheck() {+  grep -wq "$proof" "$proof_file" && ! fgrep -q '?' "$proof_file"+}++# Create the proposition to be proved (an implication from $hyp to $conc)+createprop() {+  prop=""+  sep=""+  oldIFS="$IFS"+  IFS=", "+  for h in $* ; do+    [ "$h" = "" -o "$h" = ".." ] || { prop="$prop$sep Module_$h"; sep=" ->"; }+  done+  prop="$prop$sep Module_$assertion"+  IFS="$oldIFS"+}++## Proper check, requires Alfa >= 2003-07-15+alfacheck() {+  # Assumes that $proof_file and $proof are set+  wrapper_file="$proof_dir/wrapper.alfa"++  # Compute a path to $proof_file, relative to $wrapper_file:+  case "$proof_file" in+    $proof_dir/*) proof_path="${proof_file#$proof_dir/}";;+    /*) proof_path="$proof_file";;+    *) proof_path="../$proof_file"+  esac++  rm -f "$wrapper_file"+  echo '--#include "'"$module.alfa"'"' >$wrapper_file+  echo '--#include "'"$proof_path"'"' >>$wrapper_file+  echo "proof :: $prop = $proof" >>$wrapper_file++  echo >&2 "Running Alfa"+  FUD_solvecnt="${FUD_solvecnt-300}"; export FUD_solvecnt+  (unset DISPLAY ; alfa "$wrapper_file" -check > "$output"  2>&1)+  #rm "$wrapper_file"+}++validate() {+  mkdir -p "$proof_dir"+  ( cd "$proof_dir"; ln -sf $SERVERDIR/*.alfa . )+  case "$simple" in+    True) pfecmd="alfa -simplepats" ;;+    *) pfecmd=alfa+  esac+  #echo "createprop $hyp"+  createprop $hyp+  echo "pfe $pfecmd $module"+  if pfe $pfecmd $module >"$output" 2>&1 ; then+    if [ -r "$proof_file" ] ; then+      echo "Proof missing" >"$output"+      if alfacheck; then +	markvalid+      else +	#echo "Proof missing or incomplete."+	tail -1 "$output" # Hmm. Error message can be longer than 1 line!!+	echo "Put your proof in $proof_file and call it $proof."+	markinvalid+      fi+    else+      echo '--#include "'"$proof_dir/$module.alfa"'"' >$proof_file+      echo "$proof :: $prop = ?" >>$proof_file+      abort "Open $proof_file in Alfa and create a proof called $proof, then validate again."+    fi+  else+    cat "$output"+    markinvalid+  fi+}++validatenew() {+  validate+}++auxfilechange() {+  while read file ; do+    if [ "$file" -nt "$certpath/valid" ] ; then+      return 0+    fi+  done < <(certauxfiles "$certpath")+  return 1+}++revalidate() {+  tmpdiff="$certsDir/diff$$"+  if [ "$attr" -nt "$certpath/valid" ] ; then+    echo "Certificate attributes have changed."+    validate+  elif auxfilechange ; then+    # This assumes that all relevant Alfa files are mentioned in $attrs!!!+    echo "Some auxiliary certificate file has changed."+    validate+  elif ! pfe tadiff "$deps" "$assertion" >"$tmpdiff" || [ -s "$tmpdiff" ] ; then+    #echo "The following changes might affect the validity of"+    echo "There has been changes that might affect the validity of"+    echo "the $type certificate $cert."+    #echo ""+    #cat "$tmpdiff"+    echo ""+    validate+  else+    echo "There has been no changes affecting the validity of"+    echo "the $type certificate $cert. Marking it as still valid."+    datestamp valid $certpath $module+  fi+  status=$?+  rm -f "$tmpdiff"+  return $status+}++### Here we go... ##############################################################++proof_file="`getattr file/proof "$attr"`"+proof="`getattr proof "$attr"`"+simple="`getattr SimplePatterns "$attr"`"++if [ -z "$proof_file" ] ; then+  # Default Alfa file for proofs. The user can change this.+  proof_file="${module}Proofs.alfa"+  setattr file/proof "$proof_file" "$attr"+fi++if [ -z "$proof" ] ; then+  proof="proof$conc"+  setattr proof "$proof" "$attr"+fi+++if [ -r "$certpath/valid" ] && [ -r "$deps" ] ; then+  revalidate+else+  validatenew+fi
+ tools/evman/servers/Cut/functions.sh view
@@ -0,0 +1,14 @@++## Compute the sequent that results from cut elimination+cut() {+  leftpath="$1"+  rightpath="$2"+  leftmod="${leftpath%%/*}"+  #rightmod="${rightpath%%/*}"++  pivot="$leftmod.`getcertattr conc "$leftpath"`"++  conc="`getcertattr conc "$rightpath"`"+  hyp=`(listcertattr hyp "$leftpath";listcertattr hyp "$rightpath")| sort -u | fgrep -wv "$pivot"`+  # Returns $conc, $hyp and $pivot+}
+ tools/evman/servers/Cut/invalid.gif view
binary file changed (absent → 114 bytes)
+ tools/evman/servers/Cut/new view
@@ -0,0 +1,75 @@+#!/bin/sh++# This script should be invoked from cert+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set.++type=Cut++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/functions.sh"+[ -n "$certsDir" ] || abort 'Bug: $certsDir is not set'+[ -n "$SERVERDIR" ] || abort 'Bug: $SERVERDIR is not set'+. $SERVERDIR/functions.sh # cut()++u="Usage: cert new $type <module/cert> <module/leftcert> <module/rightcert>+   or: cert new $type <module/cert> conc"++usage() { abort "$u"; }++createcert() {+  mkdir -p "$1"+  cat >"$1/cert.attr" <<EOF+type: $type+version: `getserverattr version`+conc: $conc+hyp: $hyp+pivot: $pivot+left: $leftpath+right: $rightpath+who: $USER+date: `LANG=C date`+EOF+}++[ -n "$1" ] || usage+cert="$1"++[ -n "$2" ] || usage+case "$2" in+  [A-Z]*/*)+    left="$2"+    [ -n "$3" ] || usage+    right="$3"+    conc=""+    shift;shift;shift ;;+  *)+    # Create incomplete certificate (this is the usage pfebrowser assumes)+    conc="$2"+    left=""; right=""+    shift;shift+esac++[ -n "$*" ] && usage++checkproject++module="${cert%/*}"+certname="${cert##*/}"+#checkcertannot "$module" "$certname"+certpath="$module/$certname"+[ -d "$certsDir$certpath" ] && abort "$cert already exists"+leftpath="$left";rightpath="$right" # Hmm.+if [ -n "$conc" ] ; then+  hyp=""+else+  (checkcert "$leftpath")+  (checkcert "$rightpath")+  cut "$leftpath" "$rightpath"+fi++# Some debugging output:+echo "Hyp: $hyp"+echo "Pivot: $pivot"+echo "Conclusion: $conc"++createcert "$certsDir$certpath"
+ tools/evman/servers/Cut/server.attr view
@@ -0,0 +1,14 @@+name: Cut+version: 0.02+release: January 5, 2005+src: http://www.cse.ogi.edu/~hallgren/Programatica/+description: Proof by cut elimination++# Some ideas on how to specify what attributes certificates have,+# to allow generic tools (pfebrowser in particular) to create and+# manipulate certificates.+attribute: name=conc, type=string/assertion, label=Conclusion, required+attribute: name=hyp, type=string, label="Assumptions", optional+attribute: name=left, type=string/cert, label=Left, required+attribute: name=right, type=string/cert, label=Right, required+attribute: name=Comment, type=string
+ tools/evman/servers/Cut/unknown.gif view
binary file changed (absent → 99 bytes)
+ tools/evman/servers/Cut/valid.gif view
binary file changed (absent → 914 bytes)
+ tools/evman/servers/Cut/validate view
@@ -0,0 +1,58 @@+#!/bin/sh++# Script to validate Cut certificates.+# This script should be invoked from cert.+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set.++type=Cut++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/validation.sh" # Sets assertion, attr, conc, deps, module+[ -n "$SERVERDIR" ] || abort 'Bug: $SERVERDIR is not set'+. $SERVERDIR/functions.sh  # cut()+++### Auxiliary functions ########################################################++checkcut() {+  cut "$1" "$2"+  conc2=`getattr conc $attr`+  hyp2=`getattr hyp $attr`+  err=0+  [ "$conc" = "$conc2" ] || { echo "Conclusion doesn't match"; err=1; }+  if [ -n "$hyp2" ] ; then+    [ "$hyp" = "$hyp2" ] || { echo "Hypothesis doesn't match"; err=1; }+  else+    setattr hyp "$hyp" "$attr"+  fi+  return $err+}++validate() {+  left=`getattr left $attr`+  right=`getattr right $attr`+  case "$left,$right" in+    ?*/?*,?*/?*)+      if checkcut "$left" "$right" >"$output"; then+	vl="`cd $certsDir && quickvalidate $left`"+	vh="`cd $certsDir && quickvalidate $right`"+	echo "$left $vl, $right $vh" | tee "$output"+	case "$vl,$vh" in+	  Valid,Valid) trivialmarkvalid ;;+	  *) markinvalid+	esac+      else+	markinvalid+      fi ;;+    *)+      { echo "Bad/missing names for certificate to cut (should be <Module/certname>):"+        echo "left certificate: $left"+        echo "right certificate: $right"+      } | tee "$output"+      markinvalid+  esac+}++### Here we go... ##############################################################++validate
+ tools/evman/servers/I_say_so/new view
@@ -0,0 +1,45 @@+#!/bin/sh++# This script should be invoked from cert+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/functions.sh"+[ -n "$certsDir" ] || abort 'Bug: $certsDir is not set'++type=I_say_so++usage() { abort "Usage: cert new $type <module/cert> <conc>"; } # [<hyp>]++createcert() {+  mkdir -p "$1"+  cat >"$1/cert.attr" <<EOF+type: $type+version: `getserverattr version`+conc: $2+hyp: $3+who: $USER+date: `LANG=C date`+EOF+}++[ -n "$1" ] || usage+cert="$1"++[ -n "$2" ] || usage+conc="$2"+shift;shift;+[ -n "$*" ] && usage # Hypotheses are not supported (yet).+hyp=".."++checkproject++module="${cert%/*}"+certname="${cert##*/}"+#checkcertannot "$module" "$certname"+certpath="$module/$certname"+[ -d "$certsDir$certpath" ] && abort "$cert already exists"+pfe assertions "$module" | grep -qw "$conc" ||+  abort "Error: $conc is not a named assertion in module $module"++createcert "$certsDir$certpath" "$conc" "$hyp"
+ tools/evman/servers/I_say_so/server.attr view
@@ -0,0 +1,10 @@+name: I say so+version: 0.02+release: June 18, 2003+src: http://www.cse.ogi.edu/~hallgren/Programatica/+description: A person certifies the validity of an assertion+abbrev: ISay++attribute: name=conc, type=string/assertion, label=Conclusion, required+attribute: name=Comment, type=string+#attribute: name=hyp, type=string, label="Assumptions", optional
+ tools/evman/servers/I_say_so/validate view
@@ -0,0 +1,62 @@+#!/bin/sh++# Script to validate I_say_so certificates.+# This script should be invoked from cert.+# It expects "$PROGRAMATICA" and "$certsDir" to be set.+# It also expects the name of a certificate on the command line.++type=I_say_so++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/validation.sh" # Sets assertion, attr, conc, deps, module+++### Auxiliary functions ########################################################++validate() {+  echo "Sequent: $hyp |- $conc"+  echo "Do you want to mark the $type certificate $cert valid [no]?"+  if user_confirmation ; then+    markvalid+  else+    #echo "Since you didn't answer yes, the certificate remains invalid."+    markinvalid+  fi+}++validatenew() {+  echo "The certificate $cert for assertion $conc has not previously"+  echo "been validated. Here the are names of the entities it might depend on:"+  echo ""+  pfe needed "$assertion"+  echo ""+  validate+}++revalidate() {+  if [ -s "$tmpdiff" ] ; then+    echo "The following changes might affect the validity of"+    echo "the $type certificate $cert:"+    echo ""+    cat "$tmpdiff"+    echo ""+    validate+  else+    echo "There has been no changes affecting the validity of"+    echo "the $type certificate $cert. Marking it as still valid."+    datestamp valid $certpath $module+  fi+}++### Here we go... ##############################################################++tmpdiff="$certsDir/diff$$"++if [ -r "$deps" ] && pfe tadiff "$deps" "$assertion" >"$tmpdiff" ; then+  revalidate+else+  validatenew+fi+status=$?+rm -f "$tmpdiff"+exit $status
+ tools/evman/servers/Isabelle/invalid.gif view
binary file changed (absent → 1461 bytes)
+ tools/evman/servers/Isabelle/lib/PLogic.thy view
@@ -0,0 +1,48 @@+theory PLogic+imports HOLCF+begin++constdefs+  set_bind :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<times> 'b) set" (binder "SET " 10)+  "set_bind f \<equiv> {(x,y). y \<in> f x}"++  strong :: "'a::pcpo set \<Rightarrow> 'a set"+  "strong A \<equiv> A - {\<bottom>}"++  arrow :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<rightarrow> 'b) set"+  "arrow A B \<equiv> {f. \<forall>x\<in>A. f\<cdot>x \<in> B}"++  arrow2 :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<rightarrow> 'b) u set"+  "arrow2 A B \<equiv> insert \<bottom> {up\<cdot>f |f. \<forall>x\<in>A. f\<cdot>x \<in> B}"++  lifted :: "('a \<rightarrow> tr) \<Rightarrow> 'a set"+  "lifted p \<equiv> {x. p\<cdot>x \<sqsubseteq> TT}"++  cong1 :: "('a \<rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set"+  "cong1 x A \<equiv> \<Union>a\<in>A. {x\<cdot>a}"++  cong2 :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'c set"+  "cong2 x A B \<equiv> \<Union>a\<in>A. \<Union>b\<in>B. {x\<cdot>a\<cdot>b}"++  cong3 :: "('a \<rightarrow> 'b \<rightarrow> 'c \<rightarrow> 'd) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'c set \<Rightarrow> 'd set"+  "cong3 x A B C \<equiv> \<Union>a\<in>A. \<Union>b\<in>B. \<Union>c\<in>C. {x\<cdot>a\<cdot>b\<cdot>c}"++lemma set_bind: "((x,y) \<in> set_bind f) = (y \<in> f x)"+by (simp add: set_bind_def)++lemma strong: "(x \<in> strong A) = (x \<in> A \<and> x \<noteq> \<bottom>)"+by (simp add: strong_def)++lemma arrow: "(f \<in> arrow A B) = (\<forall>x\<in>A. f\<cdot>x \<in> B)"+by (simp add: arrow_def)++lemma arrowI: "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> f\<cdot>x \<in> B\<rbrakk> \<Longrightarrow> f \<in> arrow A B"+by (simp add: arrow_def)++lemma arrowD: "\<lbrakk>f \<in> arrow A B; x \<in> A\<rbrakk> \<Longrightarrow> f\<cdot>x \<in> B"+by (simp add: arrow_def)++lemma lifted: "(x \<in> lifted p) = (p\<cdot>x \<sqsubseteq> TT)"+by (simp add: lifted_def)++end
+ tools/evman/servers/Isabelle/lib/Prelude.thy view
@@ -0,0 +1,97 @@+theory Prelude+imports PLogic+begin++subsection {* Ints *}++types HInt = "int lift"++instance lift :: (zero) zero ..+instance lift :: (one) one ..+instance lift :: (number) number ..++defs (overloaded)+  zero_lift_def: "0 \<equiv> Def 0"+  one_lift_def: "1 \<equiv> Def 1"+  number_of_lift_def: "number_of w \<equiv> Def (number_of w)"++consts+  even :: "HInt \<rightarrow> tr"+  odd :: "HInt \<rightarrow> tr"+  less' :: "'a::ord lift \<rightarrow> 'a lift \<rightarrow> tr" (infixl "`<" 50)+  plus' :: "'a::plus lift \<rightarrow> 'a lift \<rightarrow> 'a lift" (infixl "`+" 65)++defs+  even_def: "even \<equiv> flift2 Parity.even"+  odd_def: "odd \<equiv> flift2 (\<lambda>x. \<not> Parity.even x)"+  less'_def: "less' \<equiv> FLIFT x y. Def (x < y)"+  plus'_def: "plus' \<equiv> FLIFT x y. Def (x + y)"+++subsection {* Tuples *}+nonterminals typs++syntax+  "_typs" :: "[type,typs] \<Rightarrow> typs" ("_,/ _")+  "" :: "type \<Rightarrow> typs" ("_")+  "_tupletype" :: "[type, typs] \<Rightarrow> type" ("<_,/ _>")++translations+  (type) "<a, b, c>" == (type) "<a, <b, c>>"+  (type) "<a, b>" == (type) "a * b"++constdefs+  fst :: "<'a,'b> \<rightarrow> 'a"+  "fst \<equiv> cfst"+  snd :: "<'a,'b> \<rightarrow> 'b"+  "snd \<equiv> csnd"++lemma fst_tuple [simp]: "fst\<cdot><x, y> = x"+by (simp add: fst_def)++lemma snd_tuple [simp]: "snd\<cdot><x, y> = y"+by (simp add: snd_def)++translations+"case s of <x,y> => t" == "csplit$(LAM x y. t)$s"++(*+domain ('a,'b) T2 = T2 (lazy fst :: "'a") (lazy snd :: "'b") ("\<guillemotleft>_,/ _\<guillemotright>")+syntax T2 :: "type \<Rightarrow> type \<Rightarrow> type" ("\<guillemotleft>_,/ _\<guillemotright>")++domain ('a,'b,'c) T3 = T3 (lazy "'a") (lazy "'b") (lazy "'c")+syntax T3 :: "type \<Rightarrow> type \<Rightarrow> type \<Rightarrow> type" ("\<guillemotleft>_,/ _,/ _\<guillemotright>")+*)++subsection {* Lists *}++domain 'a L0+  = Nil0 ("[:]")+  | Cons0 (lazy head :: "'a") (lazy tail :: "'a L0") (infixr "`:" 65)++syntax+  "L0" :: "type \<Rightarrow> type" ("[_]")+  "_L0" :: "args \<Rightarrow> 'a L0" ("[:(_):]")++translations+  "[:x, xs:]" == "x `: [:xs:]"+  "[:x:]" == "x `: [:]"++consts length_c :: "['a] \<rightarrow> HInt"+fixrec+  "length_c\<cdot>[:] = 0"+  "length_c\<cdot>(x `: xs) = 1 `+ length_c\<cdot>xs"++consts zip :: "['a] \<rightarrow> ['b] \<rightarrow> ['a * 'b]"+fixrec+  "zip\<cdot>[:]\<cdot>ys = [:]"+  "zip\<cdot>(x `: xs)\<cdot>[:] = [:]"+  "zip\<cdot>(x `: xs)\<cdot>(y `: ys) = <x, y> `: zip\<cdot>xs\<cdot>ys"++fixpat zip_stricts [simp]: "zip\<cdot>\<bottom>\<cdot>ys" "zip\<cdot>(x `: xs)\<cdot>\<bottom>"++subsection {* Either type *}++domain ('a,'b) Either = Left (lazy "'a") | Right (lazy "'b")++end
+ tools/evman/servers/Isabelle/new view
@@ -0,0 +1,58 @@+#!/bin/sh++# This script should be invoked from cert+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/functions.sh"+[ -n "$certsDir" ] || abort 'Bug: $certsDir is not set'++type=Isabelle++usage() { abort "Usage: cert new $type <module/cert> <conc> [<hyp>]"; }++createcert() {+  mkdir -p "$1"+  cat >"$1/cert.attr" <<EOF+type: $type+version: `getserverattr version`+conc: $2+hyp: $3+who: $USER+date: `LANG=C date`+EOF+}++checkhyps() {+  oldIFS="$IFS"+  IFS=", "+  err=0+  for h in $* ; do+    [ "$h" = ".." ] || checkassertion "$h" || { err=1; echo "$h ??"; }+  done+  IFS="$oldIFS"+  return $err+}++[ -n "$1" ] || usage+cert="$1"++[ -n "$2" ] || usage+conc="$2"+shift;shift;+[ -n "$*" ] && usage # Hypotheses are not supported (yet).+#hyp="$*"+[ -n "$hyp" ] || hyp=".."++checkproject++module="${cert%/*}"+certname="${cert##*/}"+#checkcertannot "$module" "$certname"+certpath="$module/$certname"+[ -d "$certsDir$certpath" ] && abort "$cert already exists"+checkassertion "$module.$conc" ||+  abort "Error: $conc is not a named assertion in module $module"+checkhyps "$hyp" || abort "Error: malformed hypothesis"++createcert "$certsDir$certpath" "$conc" "$hyp"
+ tools/evman/servers/Isabelle/server.attr view
@@ -0,0 +1,12 @@+name: Isabelle+version: 0.01+release: September 21, 2005+src: http://www.cse.ogi.edu/~hallgren/Programatica/+description: Formal proof by embedding of Haskell in Isabelle HOL-CF++attribute: name=conc, type=string/assertion, label=Conclusion, required+attribute: name=hyp, type=string, label="Depends on", optional+attribute: name=file/proof, type=string/file, required+attribute: name=proof, type=string/identifier, required+attribute: name=Comment, type=string+attribute: name=SimplePatterns, type=bool, label="Simple Patterns"
+ tools/evman/servers/Isabelle/unknown.gif view
binary file changed (absent → 1511 bytes)
+ tools/evman/servers/Isabelle/valid.gif view
binary file changed (absent → 1485 bytes)
+ tools/evman/servers/Isabelle/validate view
@@ -0,0 +1,110 @@+#!/bin/bash++# Script to validate Isabelle certificates.+# This script should be invoked from cert.+# It expects "$PROGRAMATICA", "$certsDir" and "$SERVERDIR" to be set.+# It also expects the name of a certificate on the command line.++type=Isabelle++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/validation.sh" # defines $module, $conc, $attr, $certpath, etc+hyp=`getattr hyp "$attr"`++proof_dir=isabelle++### Auxiliary functions ########################################################+++isabellecheck() {+  isabelle -e "with_path \"$SERVERDIR/lib\" use_thy \"${proof_file%.thy}\";" -q HOLCF Output >"$output"+  grep -q 'val it = () : unit' "$output"+}++validate() {+  pfecmd=isabelle+  echo "pfe $pfecmd $module"+  echo "Translating $module..." >"$output"+  if pfe $pfecmd $module >"$module.thy" 2>>"$output" ; then+    if [ -r "$proof_file" ] ; then+      echo "Proof missing" >"$output"+      if isabellecheck; then +	markvalid+      else +	#echo "Proof missing or incomplete."+	tail -1 "$output" # Hmm. Error message can be longer than 1 line!!+	#echo "Put your proof in $proof_file and call it $proof."+	markinvalid+      fi+    else+      abort "Put your proof in $proof_file, then validate again."+    fi+  else+    cat "$output"+    markinvalid+  fi+}++validatenew() {+  validate+}++auxfilechange() {+  while read file ; do+    if [ "$file" -nt "$certpath/valid" ] ; then+      return 0+    fi+  done < <(certauxfiles "$certpath")+  return 1+}++revalidate() {+  tmpdiff="$certsDir/diff$$"+  if [ "$attr" -nt "$certpath/valid" ] ; then+    echo "Certificate attributes have changed."+    validate+  elif auxfilechange ; then+    # This assumes that all relevant files are mentioned in $attrs!!!+    echo "Some auxiliary certificate file has changed."+    validate+  elif ! pfe tadiff "$deps" "$assertion" >"$tmpdiff" || [ -s "$tmpdiff" ] ; then+    #echo "The following changes might affect the validity of"+    echo "There has been changes that might affect the validity of"+    echo "the $type certificate $cert."+    #echo ""+    #cat "$tmpdiff"+    echo ""+    validate+  else+    echo "There has been no changes affecting the validity of"+    echo "the $type certificate $cert. Marking it as still valid."+    datestamp valid $certpath $module+  fi+  status=$?+  rm -f "$tmpdiff"+  return $status+}++### Here we go... ##############################################################++proof_file="`getattr file/proof "$attr"`"+proof="`getattr proof "$attr"`"+simple="`getattr SimplePatterns "$attr"`"++if [ -z "$proof_file" ] ; then+  # Default file for proofs. The user can change this.+  proof_file="${module}_Proofs.thy"+  setattr file/proof "$proof_file" "$attr"+fi++if [ -z "$proof" ] ; then+  proof="proof$conc"+  setattr proof "$proof" "$attr"+fi+++if [ -r "$certpath/valid" ] && [ -r "$deps" ] ; then+  revalidate+else+  validatenew+fi
+ tools/evman/servers/Mono/invalid.gif view
binary file changed (absent → 107 bytes)
+ tools/evman/servers/Mono/new view
@@ -0,0 +1,45 @@+#!/bin/sh++# This script should be invoked from cert+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/functions.sh"+[ -n "$certsDir" ] || abort 'Bug: $certsDir is not set'++type=Mono++usage() { abort "Usage: cert new $type <module/cert> <conc> [<hyp>]"; }++createcert() {+  mkdir -p "$1"+  cat >"$1/cert.attr" <<EOF+type: $type+version: `getserverattr version`+conc: $2+hyp: $3+who: $USER+date: `LANG=C date`+EOF+}++[ -n "$1" ] || usage+cert="$1"++[ -n "$2" ] || usage+conc="$2"+shift;shift;+hyp="$*"++checkproject++module="${cert%/*}"+certname="${cert##*/}"+#checkcertannot "$module" "$certname"+certpath="$module/$certname"+[ -d "$certsDir$certpath" ] && abort "$cert already exists"+pfe assertions "$module" | grep -qw "$conc" ||+  abort "Error: $conc is not a named assertion in module $module"++hyp="${hyp:-$module.$conc}"+createcert "$certsDir$certpath" "$conc" "$hyp"
+ tools/evman/servers/Mono/server.attr view
@@ -0,0 +1,12 @@+name: Mono+version: 0.01+release: June 17, 2003+src: http://www.cse.ogi.edu/~hallgren/Programatica/+description: Proof by monotonicity++# Some ideas on how to specify what attributes certificates have,+# to allow generic tools (pfebrowser in particular) to create and+# manipulate certificates.+attribute: name=conc, type=string/assertion, label=Conclusion, required+attribute: name=hyp, type=string, label="Assumptions", optional+attribute: name=Comment, type=string
+ tools/evman/servers/Mono/unknown.gif view
binary file changed (absent → 99 bytes)
+ tools/evman/servers/Mono/valid.gif view
binary file changed (absent → 178 bytes)
+ tools/evman/servers/Mono/validate view
@@ -0,0 +1,38 @@+#!/bin/sh++# Script to validate Mono certificates.+# This script should be invoked from cert.+# It expects "$PROGRAMATICA" and "$certsDir" to be set.+# It also expects the name of a certificate on the command line.++type=Mono++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/validation.sh" # Sets assertion, attr, conc, deps, module+++### Auxiliary functions ########################################################++# * A Mono certificate is wellformed if all hypotheses are names of existing+#   assertions.+# * A Mono certificate is valid if it is wellformed and the conclusion is+#   one of the hypotheses.++validate() {+  wellformed=yes+  valid=no+  hyp=`getattr hyp "$attr"`+  for h in $hyp ; do+    checkassertion "$h" || { wellformed=no; errmsg "$h ??"; }+    [ "$module.$conc" = "$h" ] && valid=yes+  done+  if [ "$valid,$wellformed" = "yes,yes" ] ; then+    trivialmarkvalid+  else+    markinvalid+  fi+}++### Here we go... ##############################################################++validate
+ tools/evman/servers/Plover/invalid.gif view
binary file changed (absent → 1301 bytes)
+ tools/evman/servers/Plover/new view
@@ -0,0 +1,46 @@+#!/bin/sh++# This script should be invoked from cert+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/functions.sh"+[ -n "$certsDir" ] || abort 'Bug: $certsDir is not set'++type=Plover++usage() { abort "Usage: cert new $type <module/cert> <conc>"; } # [<hyp>]++createcert() {+  mkdir -p "$1"+  cat >"$1/cert.attr" <<EOF+type: $type+version: `getserverattr version`+conc: $2+hyp: $3+who: $USER+date: `LANG=C date`+EOF+}++[ -n "$1" ] || usage+cert="$1"++[ -n "$2" ] || usage+conc="$2"+shift;shift;+[ -n "$*" ] && usage # Hypotheses are not supported (yet).+#hyp="$*"+hyp=".."++checkproject++module="${cert%/*}"+certname="${cert##*/}"+#checkcertannot "$module" "$certname"+certpath="$module/$certname"+[ -d "$certsDir$certpath" ] && abort "$cert already exists"+pfe assertions "$module" | grep -qw "$conc" ||+  abort "Error: $conc is not a named assertion in module $module"++createcert "$certsDir$certpath" "$conc" "$hyp"
+ tools/evman/servers/Plover/server.attr view
@@ -0,0 +1,14 @@+name: Plover+version: 0.03+release: October 3, 2005+src: http://www.cse.ogi.edu/~hallgren/Programatica/+description: Formal proof by a dedicated Plogic prover based on Stratego+abbrev: Pl++# Some ideas on how to specify what attributes certificates have,+# to allow generic tools (pfebrowser in particular) to create and+# manipulate certificates.+attribute: name=conc, type=string/assertion, label=Conclusion, required+#attribute: name=hyp, type=string, label="Depends on", optional+attribute: name=Untyped, type=bool, label=Untyped+attribute: name=Comment, type=string
+ tools/evman/servers/Plover/unknown.gif view
binary file changed (absent → 1277 bytes)
+ tools/evman/servers/Plover/valid.gif view
binary file changed (absent → 1380 bytes)
+ tools/evman/servers/Plover/validate view
@@ -0,0 +1,46 @@+#!/bin/sh++# Script to validate Alfa certificates.+# This script should be invoked from cert.+# It expects "$PROGRAMATICA", "$certsDir" and "$SERVERDIR" to be set.+# It also expects the name of a certificate on the command line.++type=Plover++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/validation.sh" # defines $module, $conc, etc++### Auxiliary functions ########################################################++plovercheck() {+  [ -d tmp ] || { mkdir -p tmp && rmtmpdir=yes; }+  echo '"'"$assertion"'"' | Plover 2>&1 | tee "$output"+  grep -q "^True$" "$output"+}++validate() {+  #if pfe stratego $module > $module.ast ; then # old+  case "$untyped" in+    True) pfeflags="-untyped" ;;+    *) pfeflags=""+  esac+  if pfe strategoslice $pfeflags $assertion > $module.ast 2>"$output"; then+    if plovercheck; then +      markvalid+    else +      markinvalid+    fi+    status=$?+    # Remove tmp/ automatically, if it was created automatically.+    [ "${rmtmpdir-no}" = "yes" ] && rm -r tmp+    return $status+  else+    cat "$output"+    markinvalid+  fi+}++### Here we go... ##############################################################++untyped="`getattr Untyped "$attr"`"+validate
+ tools/evman/servers/QuickCheck/icons/quick_check_Fail.gif view
binary file changed (absent → 720 bytes)
+ tools/evman/servers/QuickCheck/icons/quick_check_OK.gif view
binary file changed (absent → 740 bytes)
+ tools/evman/servers/QuickCheck/icons/quick_check_Unknown.gif view
binary file changed (absent → 763 bytes)
+ tools/evman/servers/QuickCheck/lib/Generators.hs view
@@ -0,0 +1,7 @@+module Generators where++-- tmp++generators = []++
+ tools/evman/servers/QuickCheck/lib/QC_combinators.hs view
@@ -0,0 +1,128 @@+module QC_combinators where++import qualified Prelude as P (not)+import Prelude hiding (not)+import qualified QuickCheck as QC+import ShowFunctions+--import System(getEnv)+import Maybe(fromMaybe)++import Generators(generators)+++-- the type of formulas+data F              = Prop QC.Property | Bool Bool++instance QC.Testable F where+  property (Bool p) = QC.property p+  property (Prop p) = p++-- predicates+type Pred a         = a -> F+++(/\), (\/), (==>)   :: F -> F -> F+not                 :: F -> F+forAll, exists      :: (Show a, QC.Arbitrary a) => String -> (a -> F) -> F+true,false          :: F++(!)                 :: (a -> Bool) -> Pred a+lfp,gfp             :: (Pred a -> Pred a) -> Pred a+(===)               :: Eq a => a -> a -> F++(-=>)               :: (Show a, QC.Arbitrary a) => Pred a -> Pred b -> Pred (a -> b)++(%:)                :: Pred a -> Pred [a] -> Pred [a]+++++Bool p /\ Bool q    = Bool (p && q)+_ /\ _              = noNest++Bool p \/ Bool q    = Bool (p || q) +_ \/ _              = noNest++not (Bool p)        = Bool (P.not p)+not _               = noNest++---+pNot p  = lift1 not p+(^/\) p q = liftPropOp (/\) p q+(^\/) p q = liftPropOp (\/) p q+(^==>) p q = liftPropOp (==>) p q+-- (^<==>) = liftPropOp (<==>)++class LiftProp p where+  lift1 :: (F->F)->p->p+  liftPropOp :: (F->F->F)->p->p->p++instance LiftProp F where+  lift1 = id+  liftPropOp = id++instance LiftProp p => LiftProp (a->p) where+  lift1 f p x = lift1 f (p x)+  liftPropOp op p q x = liftPropOp op (p x) (q x)++--liftPropOp op p q x = p x `op` q x -- The S combinator, missing from Prelude!++---++forAll x f          = Prop (QC.forAll (genFor x) f)++exists              = noExists        -- does not exist :-)++true                = Bool True++false               = Bool False++Bool p ==> q        = Prop (p QC.==> q)+p ==> q             = not p \/ q++x === y             = Bool (x == y)++(p -=> q) f         = forAll "x" $ \x -> p x ==> q (f x)        -- how to control this x++(!) p               = Bool . p+++(p %: q) (x:xs)     = p x /\ q xs+(p %: q) _          = false+++noNest              = error "nested quantifers are not supported"+noExists            = error "existential quantifiers are not supported"+++-- TODO: parametrize on 50+-- lfp f x             = foldr (\/) false $ take 50 $ map ($ x) $ iterate f (const false)+-- gfp f x             = foldr (/\) true  $ take 50 $ map ($ x) $ iterate f (const true)+++lfp f               = iterate f (const false) !! 50+--lfp f               = f (lfp f)+gfp f x             = foldr1 (/\) $ take 50 $ map ($ x) $ iterate f (const true)+++genFor x            = fromMaybe QC.arbitrary (lookup x generators)+++--testToFile fileName f = ...++testToStdout maxTest maxFail verbose =+    QC.check config{QC.configMaxTest=maxTest,QC.configMaxFail=maxFail}+  where +    config = if verbose then qcVerbose else qcConfig++-- Copied from QuickCheck since they aren't exported:+qcConfig = QC.Config+  { QC.configMaxTest = 100+  , QC.configMaxFail = 1000+  , QC.configSize    = (+ 3) . (`div` 2)+  , QC.configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+  }+         +qcVerbose = qcConfig+  { QC.configEvery = \n args -> show n ++ ":\n" ++ unlines args+  }
+ tools/evman/servers/QuickCheck/lib/QC_prelude.hs view
@@ -0,0 +1,36 @@+module QC_prelude where++import qualified QC_combinators as QC ++pred_True True  = QC.true+pred_True _     = QC.false++pred_False False = QC.true+pred_False _     = QC.false++pred_Tuple0 _    = QC.true+pred_Tuple2 p q (x,y) = p x QC./\ q y+pred_Tuple3 p q r (x,y,z) = p x QC./\ q y QC./\ r z+pred_Tuple4 p q r s (x,y,z,w) = p x QC./\ q y QC./\ r z QC./\ s w++(p %: q) (x:xs) = p x QC./\ q xs+(p %: q) _      = QC.false++nil []          = QC.true+nil _           = QC.false++pred_Just p (Just x)  = p x+pred_Just p _         = QC.false++pred_Nothing Nothing = QC.true+pred_Nothing _       = QC.false++pred_Left p (Left x) = p x+pred_Left _ _        = QC.false++pred_Right p (Right x) = p x+pred_Right _ _         = QC.false++assert_Triv   = QC.true+assert_Absurd = QC.false+
+ tools/evman/servers/QuickCheck/new view
@@ -0,0 +1,46 @@+#!/bin/sh++# This script should be invoked from cert+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/functions.sh"+[ -n "$certsDir" ] || abort 'Bug: $certsDir is not set'++type=QuickCheck++usage() { abort "Usage: cert new $type <module/cert> <conc>"; } # [<hyp>]++createcert() {+  mkdir -p "$1"+  cat >"$1/cert.attr" <<EOF+type: $type+version: `getserverattr version`+conc: $2+hyp: $3+who: $USER+date: `LANG=C date`+EOF+}++[ -n "$1" ] || usage+cert="$1"++[ -n "$2" ] || usage+conc="$2"+shift;shift;+[ -n "$*" ] && usage # Hypotheses are not supported (yet).+#hyp="$*"+hyp=".."++checkproject++module="${cert%/*}"+certname="${cert##*/}"+#checkcertannot "$module" "$certname"+certpath="$module/$certname"+[ -d "$certsDir$certpath" ] && abort "$cert already exists"+pfe assertions "$module" | grep -qw "$conc" ||+  abort "Error: $conc is not a named assertion in module $module"++createcert "$certsDir$certpath" "$conc" "$hyp"
+ tools/evman/servers/QuickCheck/server.attr view
@@ -0,0 +1,14 @@+name: QuickCheck (under construction)+version: 0.02+release: 09 April 2003+src: http://www.cse.ogi.edu/~hallgren/Programatica/+description: Tests run with the QuickCheck tool+abbrev: Qc++# Some ideas...+attribute: name=conc, type=string/assertion, label=Conclusion, required+attribute: name=maxTest, type=nat, default=100+attribute: name=maxFail, type=nat, default=1000+attribute: name=verbose, type=bool, default=False+attribute: name=generators, type=string/file+attribute: name=Comment, type=string
+ tools/evman/servers/QuickCheck/validate view
@@ -0,0 +1,86 @@+#!/bin/sh++# Script to validate QuickCheck certificates.+# This script should be invoked from cert.+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set.+# It also expects the name of a certificate on the command line.++type=QuickCheck++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/validation.sh"++tmpdir=slice++### Auxiliary functions ########################################################++sourcedirs() {+  subgraphfiles $module | grep -v ^hi/libs/ | while read path ; do+    dirname $path+  done | sort -u+}++getAttrWithDefault() {+  v="`getattr $1 $attr`"+  echo "${v:-$2}"+}++validate() {+  tmpmod="$tmpdir/$module.hs"+  pfe qcslice "$module.$conc"+  hugspath=:$SERVERDIR/lib # :$PROGRAMATICA/libs/Monads+  #srcdirs=`sourcedirs`+  #hugspath=$hugspath:`echo $srcdirs | sed 's/ /:/g'` # needed for 1st & 2nd ver+  #echo "hugspath=$hugspath"+  maxTest="`getAttrWithDefault maxTest 100`"+  maxFail="`getAttrWithDefault maxFail 1000`"+  qcverbose="`getAttrWithDefault verbose False`"+  # generators...?+  echo 'Test did not run' >"$output"+  echo "QC.testToStdout $maxTest $maxFail $qcverbose assert_$conc"+  echo "QC.testToStdout $maxTest $maxFail $qcverbose assert_$conc" | +    ${HUGS-hugs} -w +q -98 -P$hugspath $tmpmod > "$output" # no interactive feedback+    #ghci -fglasgow-exts -package util -i$hugspath $tmpmod  > "$output"+  #rm -f $tmpmod+  if tail "$output" | grep -q "OK, passed " ; then  # not very reliable!!+    markvalid+  else +    markinvalid+  fi+}++validatenew() {+  validate+}++revalidate() {+  if [ -s "$tmpdiff" ] ; then+    #echo "The following changes might affect the validity of"+    echo "There has been changes that might affect the validity of"+    echo "the $type certificate $cert."+    #echo ""+    #cat "$tmpdiff"+    echo ""+    validate+  elif [ "$attr" -nt "$certpath/valid" ] ; then+    echo "Certificate attributes have changed."+    validate+  else+    echo "There has been no changes affecting the validity of"+    echo "the $type certificate $cert. Marking it as still valid."+    datestamp valid $certpath $module+  fi+}++### Here we go... ##############################################################++tmpdiff="$certsDir/diff$$"++if [ -r "$deps" ] && pfe tadiff "$deps" "$assertion" >"$tmpdiff" ; then+  revalidate+else+  validatenew+fi+status=$?+rm -f "$tmpdiff"+exit $status
+ tools/evman/servers/TestCase/new view
@@ -0,0 +1,43 @@+#!/bin/sh++# This script should be invoked from cert+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/functions.sh"+[ -n "$certsDir" ] || abort 'Bug: $certsDir is not set'++type=TestCase++usage() { abort "Usage: cert new $type <module/cert> <test>"; }++createcert() {+  mkdir -p "$1"+  cat >"$1/cert.attr" <<EOF+type: $type+version: `getserverattr version`+test: $2+who: $USER+date: `LANG=C date`+EOF+}++[ -n "$1" ] || usage+cert="$1"++[ -n "$2" ] || usage+test="$2"+shift;shift;+[ -n "$*" ] && usage++checkproject++module="${cert%/*}"+certname="${cert##*/}"+checkcertannot "$module" "$certname"+certpath="$module/$certname"+[ -d "$certsDir$certpath" ] && abort "$cert already exists"+pfe types "$module" | grep -qw "^$test :: IO ()\$" ||+  abort "Error: $test is not present in module $module, or does not have type IO ()"++createcert "$certsDir$certpath" "$test"
+ tools/evman/servers/TestCase/server.attr view
@@ -0,0 +1,9 @@+name: TestCase+version: 0.01+release: 08 April 2004+src: http://www.cse.ogi.edu/~hallgren/Programatica/+description: Test cases for regression testing+has_sequent: no++attribute: name=test, type=string, label="Test (identifier of type IO ())", required+attribute: name=Comment, type=string
+ tools/evman/servers/TestCase/validate view
@@ -0,0 +1,93 @@+#!/bin/sh++# Script to validate QuickCheck certificates.+# This script should be invoked from cert.+# It expects "$PROGRAMATICA", "$SERVERDIR" and "$certsDir" to be set.+# It also expects the name of a certificate on the command line.++type=TestCase+has_sequent=no++[ -n "$PROGRAMATICA" ] || { echo >&2 'Bug: $PROGRAMATICA is not set'; exit 1;}+. "$PROGRAMATICA/validation.sh"++#tmpdir=slice++### Auxiliary functions ########################################################++sourcedirs() {+  subgraphfiles $module | grep -v ^hi/libs/ | while read path ; do+    dirname $path+  done | sort -u+}++runtest() {+  srcdirs=`sourcedirs`+  hugspath=`echo $srcdirs | sed 's/ /:/g'`+  echo "$test" | hugs -w +q -98 -P:$hugspath "$hsfile" >"$lastoutput" 2>&1+}++validate() {+  runtest+  echo "The following differences were detected:" >"$output"+  if diff "$expected" "$lastoutput" >>"$output" ; then+    echo "Output agrees with reference output."+    markvalid+    echo "The output from the last run of the test agrees with the reference output:" >"$output"+    echo "" >>"$output"+    cat "$lastoutput" >>"$output"+  else +    markinvalid+    echo "See diagnostic output for more info."+  fi+}++validatenew() {+  runtest+  mv "$lastoutput" "$expected"+  echo "This is the first time this test has been run." >"$output"+  echo "Using the following output as reference to test against in future runs." >>"$output"+  echo "" >>$output+  cat "$expected" >>"$output"+  cat "$output"+  markvalid+}++revalidate() {+  if [ -s "$tmpdiff" ] ; then+    #echo "The following changes might affect the validity of"+    echo "There has been changes that might affect the validity of"+    echo "the $type certificate $cert. Re-running test."+    #echo ""+    #cat "$tmpdiff"+    echo ""+    validate+  elif [ "$attr" -nt "$certpath/valid" ] ; then+    echo "Certificate attributes have changed."+    validate+  else+    echo "There has been no changes affecting the validity of"+    echo "the $type certificate $cert. Marking it as still valid."+    datestamp valid $certpath $module+  fi+}++### Here we go... ##############################################################++test=`getattr test "$attr"`+assertion="$module.$test"+hsfile="`pfe file "$module" | sed "s/$module: //"`"+#echo "hsfile=$hsfile"+expected="$certpath/expected.txt"+lastoutput="$certpath/last.txt"++tmpdiff="$certsDir/diff$$"++if [ -r "$deps" ] && pfe tadiff "$deps" "$assertion" >"$tmpdiff" ; then+  revalidate+else+  validatenew+fi+status=$?+rm -f "$tmpdiff"+exit $status
+ tools/evman/validation.sh view
@@ -0,0 +1,48 @@++# Auxiliary functions for validation of certificates.++. "$PROGRAMATICA/functions.sh"+++### Functions ##################################################################++trivialmarkvalid() {+ echo '[]' >"$deps" && datestamp valid $certpath $module+}++markvalid() {+  if pfe tasig "$assertion" >"$deps" 2>>"$output" ; then+    datestamp valid $certpath $module+  else+     echo "Validation succeeeded, but computing the dependency info failed."+     return 1+  fi+}++markinvalid() { datestamp invalid $certpath $module; }+++### Initialization #############################################################+### Perform some sanity checks and define some useful variables:++[ -n "$certsDir" ] || abort 'Bug: $certsDir is not set'+[ -n "$1" ] || abort 'Bug: validate called without a certificate argument'++cert="$1"+module="${cert%/*}"+certpath="$certsDir$cert"++checkproject+checkcert "$cert" # Sets $attr+deps="$certpath/deps" # Name of file containting PFE dependency information+output="$certpath/output.txt" # Standard place for diagnostic output++case "${has_sequent-yes}" in+  yes)+    conc=`getattr conc "$attr"`+    assertion="$module.$conc"++    checkassertion "$module.$conc" || {+      abort "Did't find the assertion $conc in module $module"+    }+esac
+ tools/features.html view
@@ -0,0 +1,164 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<html>+<head>+<title>Programatica Haskell Tools - Features</title>+<link rel=parent href="./" title="Programatica Tools">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="/~hallgren/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="/~hallgren/src.css" title="Normal">+<link rel=icon type="image/gif" href="web/icon1.png">+</head>+<body>+<h1><img align=right src="web/icon1.png" alt="">+Features of the Programatica Haskell Tools</h1>++<p>+This page summarizes the features of the+<cite>Programatica Haskell Toolkit</cite>, which is++<ul>+<li>A Haskell front-end, with functionality similar to what you find in a+    compiler front-end for Haskell, implemented in Haskell.+<li>some command line tools and a graphical Haskell browser, built on top of+    the Haskell front-end.+</ul>++<p>+See the <a href="usage.html">Usage</a> page for how to use the tools.+<p>+It should also be possible for Haskell programmers to reuse our Haskell+front-end in their own Haskell programs, but at the moment+there is very little documentation to support this, unfortunately.+(But it has been used in+<a href="http://www.cs.kent.ac.uk/projects/refactor-fp/hare.html">HaRe+ -- the Haskell refactorer</a> tool from the+University of Kent.)++<h2>Summary of functionality</h2>++<ul>+<li>Lexical analysis, parsing (including operator fixity),+    scoping, pretty printing.+<li>Module-level dependency analysis, to support built-in make(1)-like+    module processing.+<li>Type checking, removing overloading by the dictionary translation,+    generating code for derived instances.+<li>Program transformations: pattern binding removal,+    pattern match simplification, function binding simplification,+    list comprehension removal.+<li>Definition-level dependency analysis, dead-code detection, slicing.+<li>Translation to Alfa/Agda (roughly Cayenne).+<li>Rendering of Haskell source code as HTML with+    accurate syntax highlighting and hyperlinks from uses to definitions.+    (See <a href="/~hallgren/h2h.html">notes on the HTML conversion</a>.)+<li>Find definitions of a particular identifier.+<li>Find all uses of a particular entity.+<li>...+</ul>++<h2>Supported language</h2>+<div>+<p>+The tools support <strong>Haskell 98</strong> as described in the+<a href="http://www.haskell.org/definition/"><cite>Haskell 98+Language and Libraries: the Revised Report</cite></a>. It also supports+a number of <strong>extensions</strong> to varying degree.+<!--<em>n+k</em> patterns are not supported.-->++<h3>Unusually well-supported standard language features</h3>++<ul>+<li>Mutually recursive modules (without the need for hi-boot files).+(See our <a href="/~diatchki/hsmod/">formal module system specification</a>+from the Haskell Workshop in 2002.)+<li>A lexer that complies with the Haskell report.+    (See the <a href="/~hallgren/Talks/LHiH/">Lexer for Haskell in Haskell</a>+     page.)+</ul>++<h3>Common Haskell Language extensions</h3>+++<table>+<caption>+Available functionality: P=lexing/parsing/scoping, T=type checking+<br>Y=supported, y=partially supported, n=not supported (yet), blank=n/a.+</caption>+<tr><th>P<th>T<th>Feature+<tr><td>Y<td>+    <td>Hierarchical module names (i.e. "<code>.</code>" in module names)+<tr><td>Y<td>y+    <td>Haskell Hierachical Libraries+<tr><td>y<td>+     <td>Foreign Function Interface+<tr><td>Y<td>Y+    <td>Multi-parameter classes+<tr><td>Y<td>Y+    <td>Overlapping instances (as in Hugs)+<tr><td>Y<td>y+    <td>Functional dependencies (see+	<a href="http://www.cse.ogi.edu/~mpj/pubs/fundeps.html"><cite>Type+	Classes	with Functional Dependencies</cite></a>)+<tr><td>Y<td>n+    <td>Rank-n polymorphism+    (use of the <code>forall</code> keywords in type expression)+<tr><td>Y<td>n+    <td>Existentially quantified types+    (use of the <code>forall</code> keyword in data constructor specifications)+<tr><td>Y<td>Y+    <td>The horrible n+k patterns+<tr><td>n<td>n+    <td>Pattern guards+<tr><td>n<td>n+    <td>Infix type constructors  +<tr><td>n<td>n+    <td>Type signatures in patterns, scoped type variables+<tr><td>y<td>n+    <td>Generalised derived instances for newtypes+<tr><td>n<td>n+    <td>Generalised Algebraic Data Types+<tr><td>n<td>n+    <td><code>mdo</code>+</table>+<br>++<h3>Programatica specific language extensions</h3>++<ul>+<li>Predicate definitions, using the <code>property</code> keyword.+<li>Property assertions, using the <code>assert</code> keyword.+<li>P-logic formulas (appear in predicate definitions and property assertions).+</ul>+</div>++<h2>Supported Libraries</h2>++<p>+The Programatica Haskell Tools are packaged with two sets of libraries:++<ul>+<li>the plain Haskell 98 libraries, as specified in the+    <a href="http://www.haskell.org/onlinereport/">Haskell 98 Report</a>.+<li>a version of the <a href="http://www.haskell.org/ghc/docs/latest/html/libraries/index.html">Haskell+    Hierarchical Libraries</a>+   (adapted from the libraries supplied with Hugs).+</ul>++<p>+The command <a href="usage.html#pfesetup"><code>pfesetup</code></a>+sets up a project using the Haskell 98 libraries by default.+By supplying the flag <code>+h</code> or <code>hierarchical</code> a project+using the hierarchical libraries is created instead.++<h2>Limitations</h2>++<p>+The tools currently don't implement exhaustive checking for static errors+and might let things like duplicate definitions or repeated variables in+patterns slip through silently.+(Implementing this has been given low priority,+ since it has been assumed that the tools will be used as a complement to+other Haskell compilers/interpreters, rather than a replacement.)++</body>+</html>
+ tools/find-uses view
@@ -0,0 +1,9 @@+#!/bin/bash++for FILE in `find . \( -name '*.hs'  -or \+                       -name '*.lhs' -or \+                       -name '*.y'   -or \+                       -name '*.ly'      \+                    \) -print` ; do +    grep -n "$1" "$FILE" /dev/null | grep -v CVS+done
+ tools/find-word view
@@ -0,0 +1,9 @@+#!/bin/bash++for FILE in `find . \( -name '*.hs'  -or \+                       -name '*.lhs' -or \+                       -name '*.y'   -or \+                       -name '*.ly'      \+                    \) -print` ; do+	grep -n -w "$1" "$FILE" /dev/null | grep -v CVS+done
+ tools/hs2alfa/BaseStruct2Alfa.hs view
@@ -0,0 +1,975 @@+module BaseStruct2Alfa{-(transModule,modPath)-} where+import TiDecorate(DeclsUseType,TiPat(..),drop_use)+import TiPrelude(prelFlip,prelOtherwise,prelTrue)+import PNT(PNT(..))+import TypedIds(IdTy(ConstrOf,Class),ConInfo(..),TypeInfo(..))+import UniqueNames as UN(PN(..),Orig(..),orig)+import HasBaseName+import NameMaps+import NameMapsDecorate+import QualNames(unqual,getQualified)+import BaseSyntax hiding (extend)+import Syntax(kstar,kpred,kprop)+import HsConstants(mod_Prelude)+import PrettyPrint+import qualified UAbstract as U+import qualified AbstractOps as U+import qualified UMatch as U+import qualified USubstitute as U+import qualified UFree as U+--import qualified DrawOptions as U(defaultArgOptions,HasName(..),ArgOptions(..))+--import qualified DrawOptionsPrinter as U(printIdOptions)+import EnvM hiding (inEnv)+import MUtils+import TI hiding (TI,getEnv,inst,tapp,sch,inEnv,extend,restrict,tupleT,conName)+--import TiT(kcCheck)+--import RemovePatBinds(remPatBinds')+--import RemoveIrrefPatsBase(removeIrrefPats)+import Lift(lift)+import TiHsName+import USCC(decls)+import PFE0(moduleInfoPath) -- grr++--import Char(isUpper)+import Maybe(fromMaybe,listToMaybe,fromJust)+import List(nub,partition,(\\),sort)+import Monad(join,mplus{-,unless-})+--import Fudgets(ctrace)++default(Int)++type DEnv = DeclsType NName+type DEnv' = DeclsUseType NName+type Env = ([ModuleName],DEnv) -- to keep track of which module is being translated+type Ctx = [Typing NName (Pred NName)]+--type NName = PN HsName+type NName = PNT++---++modPath m = moduleInfoPath m++".alfa"++class Trans src dst | src->dst where+  trans :: src->EnvM Env dst+  transTyped :: Maybe (HsTypeI NName) -> src -> EnvM Env dst++  -- Defined at least one of trans and transTyped!+  trans = transTyped Nothing+  transTyped _ = trans++instance Trans src dst => Trans (Maybe src) (Maybe dst) where+  transTyped t (Just e) = Just # transTyped t e+  transTyped t Nothing = return Nothing++ltrans xs = mapM trans xs++--instance Trans [HsImportDeclI i] [U.Decl] where+--  trans is = return [] -- not implemented yet++instance (Trans ds1 [U.Def],+	  --MapNames (Bool,NName) ds1 NName ds2,+          AccNames NName ds1,+	  MapNames NName ds0 NName ds1)+      => Trans (HsModuleI m i1 ds0) U.Module where+  trans m = transModule m # getEnv++packageSynonym (PlainModule newm) (PlainModule oldm) = -- !!!+  [U.decl' [U.defA $+            U.Package (U.Var (transMName newm),(U.ctx [],+                       U.PackageInst (un (transMName oldm))))]]++joinModuleNames [m] = m+joinModuleNames ms = PlainModule . concat $ sort [s|PlainModule s<-ms] -- !!!++uPackage n ds = U.defA $ U.Package (n,(U.ctx [],U.PackageDef ds))+uPack n ds = uPackage n (decls ds)++transModule hsmodule (mo0,denv) =+      U.Module (map include origMods+++                [U.decl' [uPackage (U.Var m)+                              (map openUnqual (unqualNames ns)+++                               decls (withEnv env (trans ds2)))]]+		)+    where+      PlainModule m = transM (joinModuleNames mo0) -- !!!+      mo = map transM mo0+      HsModule src _ e is ds0 =+          {-remPatBinds' bind_names . removeIrrefPats arg_names $-} hsmodule+{-+	where+	  --arg_names, bind_names :: [PNT]+	  arg_names   = [ localVal ("arg" ++ show n) | n <- [1..]] +	  bind_names  = [ localVal ("bind" ++ show n) | n <- [1..]] +-}+      env = (mo,denv)+      ds2 = {-mapNames snd-} ds1+      ds1 = transNames mo ds0++      ns = --map snd $+	   filter notcon $ {- nubBy eqSrc $ -} accNames (:) ds1 []++      --notcon = fst+      notcon (PNT _ (ConstrOf {}) _) = False+      notcon _ = True++      origMods = nub [m|PNT (PN _ (G m _ _)) _ _<-ns,m `notElem` mo0]++      include m = U.ImportDecl (U.Import (modPath m))++      unqualNames ns =+         collectByFst [(m,n)|PNT (PN (UnQual n) (G m _ _)) _ _<-ns,m `notElem` mo0]++      openUnqual (PlainModule m,ns) = -- !!!+	  U.decl' [U.defA (U.Open (un (transMName m),map oa (nub ns)))]++oa = oav . U.Var . transName+oav' v = U.OpenArg [] v Nothing+oav v = oav' v Nothing++mapPNT f (PNT i idty p) = PNT (f i) idty p++transNames self = mapNames2 TopLevel (varf,conf)+    where+      varf (role,ClassOrTypeNames) = mapPNT (u . tvar)+      varf (role,ValueNames)       = mapPNT (u . var)+      conf (role,ClassOrTypeNames) = mapPNT (u . tcon)+      conf (role,ValueNames)       = mapPNT (u . vcon)++      -- Packages can't refer to themselves...+      u (PN (Qual m n) o) | m `elem` self = PN (UnQual n) o+      u x = x++--    var (PN (UnQual x) o@(I m _)) = PN (Qual (transM m) x) o -- instances+      var (PN (UnQual x) o@(D n _)) = PN (UnQual (x++show n)) o -- type vars+      var (PN (UnQual x) o@(Sn _ s)) = PN (UnQual (x{-++sh s-})) o+--       where sh (SrcLoc f 0 0) = ""+--	       sh (SrcLoc f r c) = "_"++show r++"_"++show c+      var (PN (Qual _ _) o@(G m n _)) = PN (Qual (transM m) (transName n)) o+      var v@(PN q o) =+              if v==prelVal "super"+	      then localVal "super" -- hack+	      else PN (transQ q) o++      tvar (PN (UnQual x) o@(D n _)) = PN (UnQual (x++show n)) o -- generated type var+      tvar (PN (UnQual x) o@(UN.S s)) = PN (UnQual (x++"_")) o -- source type var++      vcon (PN _ o@(G m n _)) = PN (UnQual (transConName n)) o+      vcon c = c++      tcon (PN (Qual _ _) o@(G m n _)) = PN (Qual (transM m) (transTCon n)) o+      tcon (PN (UnQual _) o@(G m n _)) = PN (UnQual (transTCon n)) o++      transTCon n =+        case n of+          "[]" -> "List"+	  _ -> transName n++      transQ (UnQual x) = UnQual (transName x)+      transQ (Qual m n) = Qual (transM m) (transName n)+++transConName n = case n of+                   "[]" -> "Nil"+                   ":" -> "Cons" -- Hmm. Alfa Library convension+		   _ -> transName n++inPrelude this = transM mod_Prelude `elem` this+transM (PlainModule m) = PlainModule (transMName m)+transM (MainModule m) = PlainModule (transMName "Main") -- !!!+transMName m = "Module_"++dots2uscore m++transName n = +  case n of+    "Type" -> "Type_" -- reserved identifier+    "sig" -> "sig_"+    "use" -> "use_"+    "." -> ".." -- reserved operator+    "()" -> "Unit"+    '(':s -> "Tuple"++show (length s) -- tuples!+    _ -> n++transD ds = decls # trans ds++{-+instance Trans Ctx [U.Def] where trans = ltrans++instance Trans (Typing NName (Pred NName)) U.Def where+   trans (d:>:t) = do t' <- trans t+		      d' <- transVar d+		      return $ valdef d' ([],t') U.ePreMetaVar+-}++inModDEnv f = inModEnv (apSnd f)+extend env = inModDEnv (env+++)+extendFrom ds = extend (drop_use (envFrom ds))++extendTyvars = extendTyvars' . mapFst HsVar+extendTyvars' vs = inModDEnv (\(ks,ts)->(map tyvar vs++ks,ts))+  where tyvar (v,k) = v:>:(k,Tyvar)++restrict vs = inModDEnv (\(ks,ts)->(ks,[a|a@(x:>:_)<-ts,x `notElem` vs]))+restrictFrom ps = restrict (patternVars ps)+scope ps ds = restrictFrom ps . extendFrom ds++instance (Printable e,Printable p,Printable ds,Printable t,Printable ctx,+	 FreeNames NName ctx,+	 Printable tp,DefinedNames NName tp,DefinedNames NName t,+	 FreeNames NName t,KindCheck NName t Kind,Types NName t,+	 FreeNames NName tp,Trans p U.Pat,+	 HasId NName p, DefinedNames NName p, AccNames NName p,+	 KindCheck NName tp Kind,Types NName tp,+	 HasId NName e,Trans e U.Exp,Trans ds [U.Def], EnvFrom ds DEnv',+         Trans t U.Exp,Trans ctx [U.Exp],Trans tp U.Exp) =>+	 Trans (DI NName e p ds t ctx tp) [U.Def] where+  trans d = trans' d =<< getMEnv+    where+      trans' d this =+	  case d of+	    HsTypeDecl s tp t             -> tPs tp $ typeD # tlhs tp <# trans t+	    HsNewTypeDecl s ctx tp cd drv -> tPs tp $ dataD # tlhs tp <# ltrans [cd]+	    HsDataDecl s ctx tp cds drv   -> tPs tp $ dataD # tlhs tp <# ltrans cds+	    HsClassDecl s ctx tp _ ds     -> pPs tp $ classD ds =<< tlhs tp+	    HsInstDecl s optn c tp ds     -> iPs c tp $ instDecl s optn c tp ds+      --    HsDefaultDecl s t             -> return (hsDefaultDecl s t)+            HsTypeSig s nms c tp          -> return [] -- just looks ugly...+	    HsFunBind s matches           -> transMatches matches+	    HsPatBind s p rhs ds          -> transPatBind p rhs ds+      --    HsInfixDecl   s fixity names  -> return (hsInfixDecl s fixity names)+	    HsPrimitiveTypeDecl s ctx tp  -> tPs tp $ primTypeD # tlhs tp+	    HsPrimitiveBind s i t         -> primValueD i t+	    _ -> return [commentdef d]+	where+          pPs = kPs kpred+	  tPs = kPs kstar++	  kPs k lhs m =+             do vks <- runKc k (freeTyvars lhs) lhs+                extendTyvars' vks m++	  iPs ctx lhs m =+             do vks <- runKc kpred (freeTyvars (ctx,lhs)) lhs+                extendTyvars' vks (m [(v,k)|(HsVar v,k)<-vks])++	  tlhs tp  = do (qn, ts) <- U.flatApp' # trans tp+			let HsCon n = definedType tp+			    n' = U.Var (getQualified (getBaseName n))+			k <- kinfo tp+			return (n,n',k,[x|U.EVar x<-ts])++	  kinfo tp = do (k,i) <- knd (definedType tp)+			k' <- trans k+			return (k',i)++     -- A hack to be able to use special syntax when defining types in the Prelude:+	  --unqual (U.EVar n) = n+	  --unqual (U.EProj (U.EVar (U.Var m)) (U.Label s)) = U.Var s++	  typeD (_,n,(k,_),xs) t = [valdef n (args xs k) t]++	  dataD lhs@(_,n,(k,_),xs) cs =+	      if inPrelude this && reusePreludeFromAlfa n+	      then primTypeD lhs+	      else [valdef n (args xs k) (U.ESum cs)]+            where+	      reusePreludeFromAlfa n =+                 n `elem` map U.Var ["Unit","Bool","List"]++          --methodnames ms = ltrans [n|HsVar n<-ns]+          --  where ns:>:_ =unzipTyped ms+          methodnames ms = [U.Var ("method_"++show i)|i<-[1..length ms]]++	  classD ds (n,n'@(U.Var nstr),(k,TI.Class ctx vs fdeps ms0),_) =+	      do let ss=zipWith superMethod [1..] ctx+                     ms=ss++ms0+                 vs' <- ltrans (tdom vs)+		 ms' <- ltrans ms+		 let ns' = methodnames ms+		 ds' <- trans{-D-} ds -- default methods+		 let tsig = args vs' k+		     cn = {-projSelf-} (U.EVar n')+		     c = U.app cn (map U.EVar vs')+		 mds <- concatMapM (methodDecl c ns' vs') (zip ns' ms)+		 return $ valdef n' (args vs' k) (sig ns' ms'):+			  defaultMethods ds'+++			  mds+	    where+	      d = U.Var "d"+	      (cvs,_) = U.flatFun k++{-+	      defaultMethods ds' =+                  U.defA $ U.Package (pkg,(U.ctx [],U.PackageDef ds'))+	        where pkg = U.Var ("default__"++nstr)+-}+	      defaultMethods = map (U.mapDefB defaultMethod)+	      defaultMethod (U.Value (U.Var name,rhs)) =+	        U.Value (U.Var (defaultName name),rhs)+	      defaultMethod (U.Binding (U.Var name,rhs)) =+	        U.Binding (U.Var (defaultName name),rhs)+	      defaultMethod d = d -- comments...++	      methodDecl c ns' vs' (n',HsVar m:>:s) =+		do (gs,qt) <- kcScheme m s+                   gs' <- ltrans gs+		   qt' <- extendTyvars gs (trans qt)+		   let ps = zip vs' cvs++gs'++[(d,c)]+		   m' <- transUnqualVar m+		   return $ hide m' ps +++			    [valdef m' (ps,([],qt'))+				    (sigproj ns' n' (map (U.EVar . fst) gs'))+				    ]++              superMethod i supercl =+	         HsVar (superName n i):>:mono supercl++              sigproj ns' m' gs' =+                U.app (U.EProj (U.EVar d) (var2lbl m')) gs'+              dataproj ns' m' gs' =+                U.ECase (U.EVar d) [U.Branch (inst,(ns',U.app (U.EVar m') gs'))]++              sig ns ms = U.ESig (zipWith method ns ms)+                where+		  method n (U.SigField x t) = U.SigField (var2lbl n) t++              sig2data _ ms =+                U.ESum [U.Constr (inst,(U.ctx [(lbl2var x,t)|U.SigField x t<-ms],[]))]+	  inst = U.Con "instance"++	  primTypeD (_,n,(k,_),xs) = +	      [if inPrelude this+	       then preludePrimImportD n+	       else postulate n (args xs k)]++	  preludePrimImportD n =preludePrimImportD' n Nothing+	  preludePrimImportAsD n = preludePrimImportD' n . Just+	  preludePrimImportD' n as =+	      U.changeProps (const [U.Public]) $+	      U.defA (U.Open (pb,[oav' n as]))+	    where+	      pb = un "PreludeFromAlfa"++	  --instDecl s Nothing ctx tp ds vks = undefined+	  instDecl s (Just n) ctx tp ds vks =+	      do ctx' <- trans ctx+		 vks' <- ltrans vks+		 t <- trans tp+		 --ds' <- transD ds+                 ds' <- trans ds+		 ns <- do (k,TI.Class super _ _ ms) <- kinfo tp+			  let ns=[n|HsVar n:>:_<-ms]+                              HsCon c=definedType tp+			      ss=map (superName c) [1..length super]+			  ltrans (ss++ns)+		 let mns = methodnames ns+		 n' <- trans n+		 let dicts = xargs ctx'+                     actx = vks'++dicts+		     targs = map (U.EVar . fst) vks'+		 return $+	           --hide n' vks' +++                   [valdef n' (actx,([],t)) (str targs dicts (zip ns mns) ds')]+            where+	      str targs dicts ns2mns ds =+                  U.EStr (decls (map (U.mapDefB (rename.adjust)) (bindings ds)))+	        where+                  adjust (U.Binding (n,e)) = U.Binding (n,adjustmethod e targs dicts)+		  adjust d = d++	          rename (U.Value (name,rhs)) = U.Value (mname name,rhs)+	          rename (U.Binding (name,rhs)) = U.Binding (mname name,rhs)+	          rename d = d -- comments...++                  mname n = fromJust (lookup n ns2mns)+{-+	      str2con targs dicts ns ds = U.app (U.ECon inst) (map conarg ns)+	        where+	          conarg n = fromMaybe undef (lookup n ds')+	          ds' = [(n,adjustmethod e targs dicts)|+                          U.DefA _ (U.Binding (n,e))<-bindings ds]+-}+              adjustmethod e = substds . uapply e++	      --useDefault (U.Var n) = un (defaultName n)+              --undef = U.ePreMetaVar+	      --undef = eUndefined `uApp` U.ePreMetaVar++          bindings = U.rmTypeSign . map (U.mapDefB preserve)+	    where+	      preserve d =+	        case d of+                  U.Value (name,(ctx@(U.Ctx _ (_:_)),e,t)) | needType e ->+                    U.Value (name,(ctx,eTyped e t,t))+                  _ -> d++              needType (U.ECase {}) = True+	      needType _ = False -- sig and data can't occur in instance decls++          ifHasType v d m = ifM (inEnv (HsVar v)) m (return [commentdef d])+	  transMatches ms@(HsMatch _ n _ _ _:_) =+	      ifHasType n ms $+	      do sch@(gs,cs:=>t) <- schk (HsVar n)+		 extendTyvars gs $ do+		   cs' <- ltrans cs+		   (xs,rhs) <- umatch this (matchcons ms) # ltrans ms+		   (targs,tres) <- U.flatFun # trans t+		   --this <- getMEnv+		   tctx <- ltrans gs+		   let (ctx,(xs',tres')) = args' xs (cs'++targs) tres+		       cnt = length gs+length cs'+		   n' <- transUnqualVar n+		   return $+	             --commentdef sch:+                     hide' n' cnt++[valdef n' (tctx++ctx,(xs',tres')) rhs]++	  transPatBind = transVarBind . fromJust' . isVar ++          fromJust' = fromMaybe (error "Hs2Alfa.hs: pattern bindings not supported")+	  transVarBind qv rhs ds =+            ifHasType qv d $+	    do v <- transUnqualVar qv+	       (gs,[]:=>t) <- schk (HsVar qv)+	       tvs <- ltrans gs+	       extendTyvars gs $ do+		 t' <- trans t+		 extendFrom ds $ do+		   rhs' <- transR ds rhs+		   return $ hide v gs ++ [valdef v (tvs, ([],t')) rhs']+++	  primValueD qv t =+	    do v <- transUnqualVar qv+	       if inPrelude this +	         then return [preludePrimImportD v]+		 else do (gs,[]:=>t) <- schk (HsVar qv)+			 tvs <- ltrans gs+			 extendTyvars gs $ do+			   t' <- trans t+			   return $ hide v gs ++ [postulate v (tvs, ([], t'))]++commentdef d = U.defA $ U.CommentDef (comment (pp d))++args xs t = uncurry (args' xs) (U.flatFun t)+args' [] ts tres = ([],([],U.eFuns ts tres))+args' (x:xs) (t:ts) tres = apFst ((x,t):) (args' xs ts tres)+args' xs [] tres = ([],(xs,tres))++{- This was used in an attempt to put type and class declarations inside+ packages, where auxiliary functions could be put as well without creating+name clashes. But packages can't be recursive so it didn't work.+-}+--packdef v lhs rhs = uPackage v (decls [valdef self lhs rhs])+--self = U.Var "T"+--projSelf e = U.EProj e (U.Label "T")++valdef v (ctx,(xs, t)) rhs =+  U.defA $ U.Value (v,(U.ctx ctx,U.uAbsExp xs (rmtannot rhs),t))++rmtannot (U.ETyped e t) = e+rmtannot e = e++typeOf (U.ETyped e t) = Just t+typeOf _ = Nothing++postulate v (ctx,(xs, t)) = U.defA $ U.Axiom (v,(U.ctx ctx,U.uAbsExp xs t))+--typedef v ctx rhs = U.defA $ U.Type (v,(U.ctx ctx,rhs))++eTyped e@(U.ETyped _ _) t = e+eTyped e t = U.ETyped e t++instance (HasId NName e,Trans e U.Exp,Trans p U.Pat,DefinedNames NName p,+	  Trans ds [U.Def],EnvFrom ds DEnv')+          => Trans (HsMatchI NName e p ds) U.Rule where+  trans (HsMatch s _ ps rhs ds) =+    (,) # ltrans ps <# (scope ps ds $ transR ds rhs)++transR ds e = eLet # transD ds <# trans e++instance Trans t U.Exp => Trans (HsConDeclI NName t c) U.Constructor where+  -- Existential quantification is ignored!!! (Impredicativity problem)+  trans (HsConDecl s _ _ n as) = constr # transCon n <# mapM (trans.unbang) as+    where+      constr n as = U.Constr (nilHack n,(args as,[]))+      unbang bt = accBangType const bt ()+      args = U.ctx . xargs++      nilHack (U.Con "List") = U.Con "Nil"+      nilHack c = c+  trans (HsRecDecl s _ _ n fs) = constr # transCon n <# concatMapM transFields fs+    where+      transFields (fs,bt) = fields # mapM trans fs <# trans (unbang bt)+        where fields fs t = [(f,t)|f<-fs]+      constr n as = U.Constr (n,(U.ctx as,[]))++xargs = zipWith arg [1..]+  where arg i t = (U.Var ("x"++show i),t)++instance (HasId NName e,Trans e U.Exp) => Trans (HsRhs e) U.Exp where+  transTyped t (HsBody e) = transTyped t e+  transTyped t (HsGuard gs) = transGuards gs =<< trans t+    where+       -- this is a quick hack!!!+      transGuards [] t =+          do this <- getMEnv+             return (eUndefined this `uApp` opt "result type in guarded rhs" t) -- a failed guard+      transGuards ((_,g,e):gs) t =+          if isTrue g+	  then trans e+          else eIf t # trans g <# trans e <# transGuards gs t++      isTrue = maybe False isTrueId . isId+      isTrueId x = x `elem` [prelTrue,prelOtherwise]++instance Trans (Assump NName) U.SigPart where+  trans (HsVar x:>:t) = U.SigField # transLbl x <# trans t++instance Trans (Scheme NName) U.Exp where+  trans s =+    do (vs,qt) <- kcScheme "?" s+       U.piExp # ltrans vs <# extendTyvars vs (trans qt)++instance Trans t U.Exp => Trans (Qual NName t) U.Exp where+  trans (ctx:=>t) = U.eFuns # ltrans ctx <# trans t++instance Trans (HsTypeI NName) U.Exp where trans (Typ t) = trans t+instance Trans NName U.Var where trans x = U.Var # (flip transId x # getMEnv)++transEVar x = inst x+{-+  do b <- inEnv x+     if b+      then do Forall vs (ctx:=>_) <- sch x  --  monomorphic recursive call+	      unless (null vs && null ctx) $+	         error $"missing type annotation for "++show x+	      x' <- inst x+	      vs' <- map U.EVar # ltrans vs+	      return $ U.app x' (vs'++replicate (length ctx) U.ePreMetaVar)+      else inst x -- lambda bound variable+-}++-- Constructors don't need type arguments, but they need to be applied+-- to the right number of values.+transECon c sc ts =+    con # inst c <# trans (specialize sc ts)+  where+    con c t =+       eTyped (U.absExp (zipWith (U.:-) ps ts) (U.app c (map U.EVar ps))) t+      where+	(ts,tr) = U.flatFun t+        ps = [U.Var ("conarg"++show n)|n<-[1..length ts]]++    specialize (Forall _ gs qt) ts = apply (TI.S (zip (tdom gs) ts)) qt++instance (Printable t,KindCheck NName t Kind,Trans t U.Exp,Types NName t)+       => Trans (TI NName t) U.Exp where+  trans t =+    case t of+      HsTyFun x y  -> U.eFun # trans x <# trans y+--    HsTyTuple ts -> U.app . tupleT (length ts) # getMEnv <# ltrans ts+      HsTyApp f x  -> trans f `tapp` trans x+      HsTyVar nm   -> do b <- inTEnv (HsVar nm)+		         if b+			    then do (k,_) <- knd (HsVar nm)+			            if k==kprop+				       then U.EApp (un "predT") # inst (HsVar nm)+				       else inst (HsVar nm)+			    else return (missing "type variable not in scope")+      HsTyCon nm   -> instTcon nm+      HsTyForall vs ps t1 ->+          do vks <- runKc kstar (map HsVar vs) t1+	     let vks' = [(v,k)|(HsVar v,k)<-vks] -- grr+             U.piExp # ltrans vks' <# extendTyvars' vks (trans t1) -- ps !!!++--ePis vs t = foldr ePi t vs+--ePi (v,k) = U.EPi (v U.:- k)+{-+tupleT n this = uqn (tupleName n)+  where+    prel = transM mod_Prelude+    uqn = if this==prel then un else qn prel+-}+tupleName n = "Tuple"++show (n::Int)++instance Trans Kind U.Exp where+  trans (K k) =+    case k of+      Kstar -> return eStar+      Kfun k1 k2 -> U.eFun # trans k1 <# trans k2+      Kpred -> return eClass+      Kprop -> return ePropKind++consE = U.ECon cons+nilE  = U.ECon nil+cons  = U.Con "Cons"+nil   = U.Con "Nil"++{-+type Pat0 = (U.Con,[U.Var])++instance Trans HsPat Pat0 where+  trans (Pat p) =+    case p of+      HsPId (HsCon c) -> return (transCon c,[])+      HsPApp c ps -> return (transCon c,transPVars ps)+      HsPList []  -> return (nil,[])+-}++instance Trans (TiPat NName) U.Pat where+  trans (Pat p) = trans p+  trans (TiPSpec (HsVar v) _ []) = U.PVar # transUnqualVar v+  trans (TiPSpec (HsCon c) _ _) = con0P c+  trans (TiPTyped p t) = transTyped (Just t) p+  trans (TiPApp p1 p2) = papp # trans p1 <# trans p2+    where+      papp (U.PCon c ps) p = U.PCon c (ps++[p])+      papp _ _ = U.PVar noname -- !!!++  trans p = --error $ "Not implemented yet: "++pp p+	  return $ U.PVar noname -- !!!++  transTyped t (Pat e) = transTyped t e+  transTyped _ e = trans e++-- ...++instance (Printable p,Trans p U.Pat) => Trans (PI NName p) U.Pat where+  trans p =+    case p of+      HsPId (HsCon c) -> con0P c+      HsPId (HsVar v) -> U.PVar # transUnqualVar v+      HsPApp c ps -> U.PCon # transCon c <# ltrans ps+      HsPList  s ps -> foldr consP nilP # ltrans ps+      HsPTuple s ps -> U.PCon (tupleCon (length ps)) # ltrans ps+      HsPInfixApp p1 c p2 -> U.PCon # transCon c <# ltrans [p1,p2]+      HsPParen p -> trans p+      HsPAsPat v p -> U.PAs # trans v <# trans p+      HsPWildCard -> return $ U.PVar noname+      HsPIrrPat p -> trans p -- !!+      _ -> --error $ "Not implemented yet: "++pp p+           return $ U.PVar noname -- !!!++noname = U.Var "__" -- "_" is reserved in Agda nowadays++nilP = U.PCon nil []+consP p1 p2 = U.PCon cons [p1,p2]+con0P c = flip U.PCon [] # transCon c++tupleCon = U.Con . tupleName++--rmtrans e = rmtannot # trans e+rmltrans es = map rmtannot # ltrans es++ptrans (TiPTyped p t) = (,) # trans p <# trans t+lptrans = mapM ptrans++optTransTyped t e = maybe e (eTyped e) # trans t++{-+checkChar x c = +  if c<toEnum 0 || c>toEnum 255+  then error$ "Unsupported char"++show (fromEnum c)++" in "++show x+  else c+-}+checkChar _ c = toEnum (fromEnum c `mod` 256) -- hmm++instance (HasId NName e,Trans e U.Exp,+	  --AccNames NName p,DefinedNames NName p,HasId NName p,Trans p U.Pat,+	  Trans ds [U.Def],EnvFrom ds DEnv')+	 => Trans (EI NName e (TiPat NName) ds c t) U.Exp where+  transTyped t e =+    optTransTyped t =<<+    case e of+      HsId x                 -> transEVar x+      HsLit _ (HsChar c)     -> return (U.EChar (checkChar c c))+      HsLit _ (HsString s)   -> return (U.EString (map (checkChar s) s))+      --HsLit _ (HsString s)   -> return (U.EString "") -- for a performance test+      HsLit _ (HsInt i)      -> return (U.EInt i)+      HsLit _ (HsFrac x)     -> return (U.ERat x)+      HsLit _ _              -> return (missing "unimplemented type of literal")+      HsInfixApp x op z      -> inst op `tapp` trans x `tapp` trans z+      HsApp x y              -> trans x `tapp` trans y+--    HsNegApp x             -> inst prelNegate `tapp` tc x+      HsLambda ps e          -> do this <- getMEnv+                                   eLambda this (patscons ps) # lptrans ps <# restrictFrom ps (trans e)+      HsLet ds e             -> eLet # transD ds <# extendFrom ds (trans e)+      HsIf x y z             -> eIf # trans t <# trans x <# trans y <# trans z+      HsCase e alts          -> do this <- getMEnv+                                   eCase this (altcons alts) # trans t <# trans e <# ltrans alts+--    HsDo stmts             -> tcStmts stmts+      HsTuple es             -> U.app (U.ECon (tupleCon (length es))) #rmltrans es+      HsList es              -> foldr (U.app2 consE) nilE # rmltrans es+      HsParen e              -> trans e+      HsLeftSection x op     -> inst op `tapp` trans x+      HsRightSection op y    -> inst pqFlip `tapp` inst op `tapp` trans y+--    HsRecConstr s n fields   -> recConstr n fields+  --  HsRecUpdate e upds     ->+--     HsEnumFrom x           -> inst prelEnumFrom `tapp` tc x+--    HsEnumFromTo x y       -> inst prelEnumFromTo `tapp` tc x `tapp` tc y+--    HsEnumFromThen x y     -> inst prelEnumFromThen `tapp` tc x `tapp` tc y+--    HsEnumFromThenTo x y z ->+--	inst prelEnumFromThenTo `tapp` tc x `tapp` tc y `tapp` tc z+--    HsListComp stmts       -> emap hsListComp # tcLComp stmts+--    HsExpTypeSig s e c t    -> tcExpTypeSig s e c t+      -- Unimplemented things are turned into metavariables:+      _                      -> return $ missing "unimplemented form of expression"+   where+{-   recConstr c fs =+       case fieldsOf c of+         Nothing -> return $ missing bad+         Just fns -> do c' <- inst (HsCon c)+			let args = map (pick [(orig fn,e)|HsField fn e<-fs]) fns+			args' <- mapM (mtrans bad) args+			return (U.app c' args')++     bad = "bad record construction?"++     fieldsOf (PNT c (ConstrOf _ tinfo) _) =+       fmap (map orig) . join . listToMaybe $+	 [conFields ci|ci<-constructors tinfo,orig (conName ci)==orig c]+     fieldsOf (PNT c (TypedIds.Class ms) _) = Just (map orig ms)+     fieldsOf _ = Nothing -- Not a constructor ?!++     pick = flip lookup+-} +     pqFlip = mapHsIdent oqual prelFlip+++oqual (PNT (PN _ o@(G m n _)) t s) = PNT (PN (Qual m n) o) t s+oqual n = n++mtrans s Nothing = return $ missing s+mtrans s (Just e) = trans e++instance (Trans i1 i2,Trans e1 e2) => Trans (HsFieldI i1 e1) (i2,e2) where+  trans (HsField i e) = (,) # trans i <# trans e++instance Trans [HsTypeI NName] [U.Exp] where trans = ltrans++instance (Trans a1 a2,Trans b1 b2) => Trans (a1,b1) (a2,b2) where+  trans = trans >#< trans++instance (HasId NName e,Trans e U.Exp,Trans p U.Pat,DefinedNames NName p,+	  Trans ds [U.Def],EnvFrom ds DEnv')+         => Trans (HsAlt e p ds) U.Rule+  where+    trans (HsAlt s p rhs ds) =+        do p' <- trans p+	   scope p ds $ do+	     rhs' <- transR ds rhs+	     return ([p'], rhs')++sets xs = [(x,eStar)|x<-xs]+--sets xs = [(x,U.ePreMetaVar)|x<-xs]++instTcon c = {-projSelf # -} inst (HsVar c)++inst x = flip inst' x # getMEnv++inst' this (HsCon x) = U.ECon (transCon' this x)+inst' this (HsVar n) = case getBaseName (n::NName) of+		         UnQual  x -> un x+			 Qual mo x -> qn mo x++qn (PlainModule m) x = U.EProj (un m) (U.Label x)+un = U.EVar . U.Var+--evar = U.EVar . U.Var++{-+transPVar p = transVar (fromJust' . isVar $ p)+  where fromJust' = fromMaybe (error "BaseStruct2Alfa.hs: patterns in lambdas are not supported")+transPVars ps = mapM transPVar ps+-}++-- This is used to translate identifiers appearing where only unqualified names+-- are legal, but the abstract syntax allows qualified names+transUnqualVar = transVar . unqual++transCon x = flip transCon' x # getMEnv+transVar x = flip transVar' x # getMEnv++var2lbl (U.Var x) = U.Label x+lbl2var (U.Label x) = U.Var x+transLbl x = var2lbl # transUnqualVar x++transVar' this = U.Var . transId this+transCon' this = U.Con . transId this++--lbl = U.Label # transId++transId this n = transId' this (getBaseName (n::NName))++transId' this (UnQual x) = x+transId' this (Qual mo@(PlainModule m) x) = -- !!!+    if mo `elem` this+    then x+    else m{-++"_"-}++x+               --Hmm. Qualified names in definitions won't work...+	       --Just output something rather than failing immediately.+++eClass = un "Class" -- for readability+eStar = un "Star" -- for readability+--eStar = U.eSet -- avoids dependency on nonstd predefined things in Alfa+ePropKind = un "PropKind" -- for readability+eUndefined this =+  if inPrelude this+  then un "undefined"+  else qn (transM mod_Prelude) "undefined"++eLet [] e = e+eLet (U.Decl _ []:ds) e = eLet ds e+eLet ds e = U.ELet ds e -- problem if e is case or sig or ...++eCase this css t e rules = optTyped t (U.subst e v ecase)+  where ([v],ecase) = umatch this css rules++optTyped = maybe id (flip eTyped)++eLambda this css tps e0 =+    if all uIsVar ps+    then U.absExp [x U.:-t|(U.PVar x,t)<-tps] e0+    else U.absExp [v U.:-t|(v,t)<-zip vs ts] (f ecase)+  where+    (ps,ts) = unzip tps+    (vs,ecase) = umatch this css [(ps,e)]+    (e,f) = case e0 of+	      U.ETyped e t -> (e,flip eTyped t)+	      _ -> (e0,id)++altcons alts = patscons [ p | HsAlt s p rhs ds<-alts]+matchcons ms =  patscons [ p | HsMatch s _ ps rhs ds<-ms,p<-ps]++-- This can fail if a pattern contains constructors from different types+-- but with the same unqualified name...+patscons = transCons . accCons+  where+    transCons = (listcons:).map (mapFst con)+    con (PN c o) = U.Con (transConName c)++    listcons = [(U.Con "Nil",0),(U.Con "Cons",2)]++    --tr x = ctrace "cons" x x++accCons ps = accNames con ps []+  where+    con (PNT c (ConstrOf _ tinfo) _) css =+	if cs `elem` css+	then css+	else cs:css+      where cs = tinfo2cs tinfo+    con _ css = css++    tinfo2cs tinfo = [(c,n)|ConInfo{conName=c,conArity=n}<-constructors tinfo]+++eIf t cnd thn els = eIfTyped (opt "result type for if" t') cnd thn els+  where t' = t `mplus` typeOf thn `mplus` typeOf els++eIfTyped t cnd thn els = U.app (un "if_then_else") [t,cnd,thn,els]+--eIf cnd thn els = U.ECase cnd [b "True" thn,b "False" els]+--  where b c e = U.Branch (U.Con c,([],e))++umatch this css rules =+  case rules of+    [(ps,e)] | all uIsVar ps -> ([x|U.PVar x<-ps],e) -- to preserve var names+    _ -> U.exhaustiveMatch'' css [] rules undef+  where+    undef = eUndefined this `uApp` missing "potential pattern match failure"++uIsVar (U.PVar _) = True+uIsVar _ = False++m1 `tapp` m2 = uApp # m1 <# m2++e1 `uApp` e2 =+  case e1 of+    -- Agda doesn't like applied meta variables:+    U.EMeta _ -> e1+    U.EAnnot a (U.EMeta _) -> e1+    -- Agda doesn't like beta redexes:+    U.ETyped (U.EAbs (x U.:-_) e1') (U.EPi _ t) -> U.subst e2 x e1' `eTyped` t+    U.EAbs x e1' -> uLet x e2 e1'+    --U.ETyped e1' (U.EPi _ t) -> (e1' `uApp` e2) `eTyped` t+    _ ->  U.EApp e1 e2+  where+    -- Avoid code duplication, if possible without name capture+    -- (there are no non-recursive declarations in Agda)+    uLet (x U.:-t) e2 e1 = +      if x `elem` U.free e2+      then U.subst e2 x e1+      else U.ELet [U.decl' [valdef x (([],([],t))) e2]] e1++getDEnv = snd # getEnv+getMEnv = fst # getEnv++{-++Since the type checker doesn't provide kind information for type variables in+type schemes, we do a _local_ kind inference on the type scheme.+I am not quite sure this is enough to always get the right kinds...+-}+schk x = kcScheme x =<< sch x+schak x = akcScheme x =<< sch x++kcScheme  _ (Forall _  vs qt) = return ([(v,k)|v:>:k<-vs],qt)+akcScheme _ (Forall as vs qt) = return ([(v,k)|v:>:k<-as++vs],qt)+{-+kcScheme x (Forall [] qt) = return ([],qt) -- shortcut+kcScheme x (Forall vs qt) =+  do vks <- runKc' x kstar (map HsVar (tdom vs)) qt+     return ([(v,k)|(HsVar v,k)<-vks],qt)+--}+--runKcStar = runKc kstar++runKc = runKc' ""+runKc' s  k vs qt =+  do kenv <- fst # getDEnv+     vkts <- lift (errorContext (pp (s,vs,qt,k)) $+                   extendkts kenv $ kgeneraliseSloppy $+                   do bs <- kintro vs+		      bs' <- kintro (map HsVar (tv qt)\\vs) -- hmm+                      k' <- extendkts (bs++bs') $ kc qt+		      let _ = k' `asTypeOf` k+	              return bs)+     return [(v,k)|v:>:(k,_)<-vkts]++sch x = lookupts x . snd # getDEnv+knd x = lookupts x . fst # getDEnv++inEnv x = (elem x . map tfst . snd) # getDEnv+inTEnv v = (elem v . map tfst . fst) # getDEnv++tfst (x:>:_) = x++lookupts x [] = error ("Not in scope:"++show x)+lookupts x ((y:>:t):ts) = if x==y then t else lookupts x ts++eCmnt = U.eComment . comment+comment s = "{- "++s++" -}"+annot s = "{-# Alfa "++s++" #-}"++missing s = eCmnt s U.ePreMetaVar+opt = fromMaybe . missing++hide v = hide' v . length++hide' (U.Var v) cnt =+    if cnt>0+    then [U.defA $ U.CommentDef $ annot s]+    else []+  where+    s = --U.printIdOptions (U.name v,(U.defaultArgOptions v){U.hideCnt=cnt})+        "var "++show v++" hide "++show cnt+---}++uapply e [] = e+uapply (U.EAbs (x U.:-_) e) (a:as) = uapply (U.subst a x e) as+uapply e as = U.app e as -- hmm++substds e [] = e+substds e@(U.EAbs p@(x U.:-t) b) ds =+    case partition (sameT t) ds of+      ((d,_):ds1,ds2) -> substds (U.subst (U.EVar d) x b) (ds1++ds2)+      ([],ds2) -> U.EAbs p (substds b ds2) -- assume p is a type parameter+      -- _ -> U.eComment (comment $ "Something went wrong here: dictionary argument type mismatch: "++show t) e -- Hmm+  where+    sameT t (_,t') = t==t'+substds e _ = U.eComment (comment "Something went wrong here: too many dictionary arguments?") e -- Hmm
+ tools/hs2alfa/Flags.ghc view
@@ -0,0 +1,4 @@+Hs2Alfa.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+BaseStruct2Alfa.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+Prop2Alfa.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+PfeAlfaCmds.hs: -fno-monomorphism-restriction
+ tools/hs2alfa/HEADER.html view
@@ -0,0 +1,19 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<!-- This file is included by the web server in the automatically generated+     directory index.+-->+<head>+<title>Programatica Tools, tools/hs2alfa</title>+<link rel=parent href="../" title="Programatica Tools">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../web/icon1.png">+</head>++<base>+<h1><img align=right src="../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/hs2alfa</h2>++The README file is displayed below the directory index.
+ tools/hs2alfa/Hs2Alfa.hs view
@@ -0,0 +1,28 @@+module Hs2Alfa(transModule,modPath) where+import BaseStruct2Alfa+import TiDecorate(TiDecls(..),TiDecl(..),TiExp(..))+import HsIdent+import HsModule+import qualified UAbstract as U++import MUtils++--default(Int)++transModule = trans :: HsModuleI i (TiDecls NName) -> Env -> U.Module++instance Trans (TiDecls NName) [U.Def] where+  trans (Decs ds env) = concat # extend env (ltrans ds)++instance Trans (TiDecl NName) [U.Def] where+  trans (Dec d) = trans d++instance Trans (TiExp NName) U.Exp where+  trans (Exp e) = trans e+  trans (TiSpec c@(HsCon _) sc ts) = transECon c sc ts+  --trans (TiSpec x _ []) = transEVar x+  trans s@(TiSpec x _ ts) = U.app # inst x <# ltrans ts+  trans (TiTyped e t) = transTyped (Just t) e++  transTyped t (Exp e) = transTyped t e+  transTyped _ e = trans e
+ tools/hs2alfa/HuMakefile view
@@ -0,0 +1,29 @@++BASE=${BASE-../base}+PFE_DIR=${PFE_DIR-../pfe}+PROP=${PROP-../property}+HS2HTML_DIR=${HS2HTML_DIR-../hs2html}+HS2ALFA_DIR=${HS2ALFA_DIR-.}+A=$HS2ALFA_DIR++#Alfa source directories:+#AS=AlfaSource:AlfaSource/../IAgda:AlfaSource/../Graphic+#AS=AlfaSource:AlfaSource/../Graphic+AS=$A/AlfaSource++case ${TARGET-x} in # TARGET is defined by Makefile+  apfe|tstProp2Alfa)+    . $PROP/HuMakefile+    APFE_DIRS=$A:$AS:$SRC_DIRS+    SRC_DIRS=$APFE_DIRS+    ;;+  tstHs2Alfa)+    . $BASE/HuMakefile+    SRC_DIRS=$A:$AS:$B:$MODSRC_DIRS	# For tstHs2alfa+    ;;+  *)+     echo "Unknown target $TARGET (see HuMakefile)"+     exit 1+esac++GHCFLAGS="$GHCFLAGS -cpp"
+ tools/hs2alfa/Makefile view
@@ -0,0 +1,52 @@+TARGETS=apfe tstHs2Alfa tstProp2Alfa++### Optimization and other compiler options:+#OPT=+OPT=-O+HFLAGS=++#Tools:+RM=rm -f+#HMAKE=sh ../scripts/hsfudmake.sh+HMAKE=sh ../scripts/hsmake.sh++################################################################################+### Rules for compiling the programs++apfe::+	@$(MAKE) -s AlfaSource+	@sh ../scripts/updateNow.sh ../pfe/Now.hs+	@$(MAKE) -C ../property propparser+	TARGET=$@ $(HMAKE) $(OPT) $(HFLAGS) $@ -o $@++all:: $(TARGETS)++tstHs2Alfa::+	@$(MAKE) -C ../pfe baseparser+	TARGET=$@ $(HMAKE) $(OPT) $(HFLAGS) $@ -o $@++tstProp2Alfa::+	@$(MAKE) -C ../property propparser+	TARGET=$@ $(HMAKE) $(OPT) $(HFLAGS) $@ -o $@+++AlfaSource:+	@echo "You need to unpack alfaforpfe.tar.gz first."+	@echo "Get it from http://www.cse.ogi.edu/~hallgren/Programatica/download/"+	@exit 1++################################################################################+### Rules for generating HTML++hi/srclist.txt:+	PFE_LIBS=../base/tests pfesetup hs2alfa.hs++html:: hi/srclist.txt+	pfe htmlfiles++################################################################################+### Rules for cleaning up++clean:+	$(RM) -r $(TARGETS) hi+	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'
+ tools/hs2alfa/PfeAlfaCmds.hs view
@@ -0,0 +1,111 @@+module PfeAlfaCmds(pfeAlfaCmds) where+import Prelude hiding (putStrLn,writeFile,catch)+import Monad(filterM)+import Maybe(mapMaybe)+import List(intersect)++import HsModule++import RemovePatBinds(remPats)+import RemoveListCompProp(rmAllListComp)+import SimpFunBind(simpAllFunBind)+import SimpPatMatch(simpAllPatMatch,getSimpPatIds,prelError)+--import SimpFieldLabels(simpFieldLabels)+import DefinedNames(addName)+import PFE4(rewriteAndTypeCheck)+import PFE_Rewrites(Rewrite(..),compRw,pmRewrite,pbRewrite,lcRewrite)+import PFE0(moduleList,subGraph,newerThan,getSortedSubGraph)+import PfeParse(moduleArgs',kwOption,just)+import TI((+++))+import TiModule(joinModules,representative)++import Prop2Alfa(transModule,modPath)+import BaseStruct2Alfa(packageSynonym,joinModuleNames)+--import FileConv(printModule)+import qualified UAbstract as U++import AbstractIO+import DirUtils(getModificationTimeMaybe)+import MUtils+import EnvM(withEnv)++pfeAlfaCmds =+  [--("alfa",(moduleArgs prop2alfa1,"translate modules to Alfa")),+   ("alfa",(moduleArgs' opt prop2alfa,"translate modules to Alfa"))]+  where+    opt = kwOption "-simplepats"++prop2alfa simplepats = if simplepats then prop2alfa2 else prop2alfa1++prop2alfa1 = prop2alfa' rewrite1+prop2alfa2 = prop2alfa' rewrite2++rewrite1 = pmRewrite `compRw` rewrite2+rewrite2 = pbRewrite `compRw` lcRewrite `compRw` addNameRw+addNameRw = Rewrite "an" (return addName)++prop2alfa' rewrite@(Rewrite rwname _) ms =+    do dir <- getEnv "APFE_DIR" `catch` const (return "alfa")+       changedsccs <- changedSccs dir =<< getSortedSubGraph (just ms)+       let ms = concat changedsccs+       if null ms then done+         else do tms <- rewriteAndTypeCheck rewrite  (Just ms)+                 mapM_ (transSCC dir tms) changedsccs+  where+    transSCC dir alltms ms = mapM (writeModule dir . trans1) ms+      where+        joinedmn = joinModuleNames ms+	rm = representative ms+	tms = [(m,tm)|(m,(_,(tms,_)))<-alltms,m `elem` ms,(rwn,tm)<-tms,rwn==rwname++"fl"]+	joinedtm = joinModules (map snd tms)++        trans1 m = (m,U.Module transm)+          where+            transm = if m==rm+	             then transds ++ syn+	             else imp:syn++            U.Module transds = withEnv (ms,env) (transModule joinedtm)+            syn = if m==joinedmn then [] else packageSynonym m joinedmn+	    imp = U.ImportDecl (U.Import (modPath rm))++        env = foldr ((+++).snd.snd.snd.snd) ([],[]) alltms++{-+prop2alfa1 =+    mapM_ writeModule.transModules @@ rewriteAndTypeCheck rewrite.Just+  where+    transModules ms = mapMaybe transModule' ms+      where+        transModule' (n,(_,(optm,_))) =+	    do m <- optm+	       return (n,withEnv ([n],env) (transModule m))+        env = foldr ((+++).snd.snd.snd.snd) ([],[]) ms+-}++writeModule dir (n,U.Module decls) =+    do let path=dir++"/"++modPath n+       ePutStrLn ("Updating: "++path)+       writeFile path ({-printModule-}show m)+  where+    m = U.Module (prefix++decls)+    prefix =+      [ U.Comment magic,+	U.ImportDecl (U.Import "Haskell.alfa"),+        U.Comment "{-# Alfa hidetypeannots on #-}"]++    magic = "-- Automatically converted from Haskell by hs2alfa..."++changedSccs dir g =+    -- A quick hack to avoid retranslating unchanged modules...+    do changed <- map (fst.snd) # filterM moduleChanged (concat g)+       let allsccs = [[m|(f,(m,is))<-scc]|scc<-g]+	   sccs= [scc|scc<-allsccs,+		      not.null $+		      moduleList (subGraph g scc) `intersect` changed]+       return sccs+  where+    moduleChanged (path,(m,_)) =+      newerThan  # getModificationTime path+                <# getModificationTimeMaybe (dir++"/"++modPath m)+
+ tools/hs2alfa/Prelude.alfa view
@@ -0,0 +1,31 @@+package Prelude where+  Unit :: Set+    = data Unit+  Bool :: Set+    = data False | True+  Char :: Set+    = data A | B | C+  List (A::Set) :: Set+    = data Nil | (:) (x::A) (xs::List A)+  postulate undefined (A::Set) ::A++Class :: #2+  = Type++Star :: Type+  = Set++if (A::Star)(cnd::Prelude.Bool)(thn::A)(els::A) :: A+  = case cnd of {+      (False) -> els;+      (True) -> thn;}+{-# Alfa hiding on+var "Unit" as "()"+con "Unit" as "()"+con "Nil" as "[]"+con "Cons" infix rightassoc 5 as ":"+con ":" infix rightassoc 5+var "List" mixfix as "[_]"+var "Star" as "*" with symbolfont+var "if" hide 1 mixfix as "if _ then _ else _"+ #-}
+ tools/hs2alfa/Prop.alfa view
@@ -0,0 +1,21 @@+--#include "Prelude.alfa"++--#include "Alfa/Propositions.alfa"++open Prelude  use  Unit,  Char,  List,  undefined++open Propositions+ use  Prop,  Absurdity,  AbsurdityElim,  Triviality,  TrivialityIntro,  Pred++listInd (A::Set)+        (P::Pred (List A))+        (xs::List A)+        (n::P Nil@_)+        (c::(x::A) -> (xs::List A) -> (pxs::P xs) -> P ((:)@_ x xs))+  :: P xs+  = case xs of {+      (Nil) -> n;+      (x : xs') -> c x xs' (listInd A P xs' n c);}+{-# Alfa hiding on+var "listInd" hide 3+ #-}
+ tools/hs2alfa/Prop2Alfa.hs view
@@ -0,0 +1,284 @@+module Prop2Alfa(Prop2Alfa.transModule,modPath) where+import TiPropDecorate+import PropSyntax(HsModuleI,HsPatI,prop,Prop,Rec(..))+import qualified PropSyntax as PS+import HsConstants(mod_Prelude)+import PNT+import TypedIds+import HsPropStruct+import HsPropMaps+import HsIdent+import QualNames(mkUnqual,getQualified)+import UniqueNames(noSrcLoc,origModule)+import DefinedNames(definedType)+import PrettyPrint(Printable,pp)+import TI hiding (getEnv,inst,tapp,sch,inEnv,extend,restrict,conName,definedType)+import NameMapsPropDecorate+import BaseStruct2Alfa+import qualified UAbstract as U+import qualified AbstractOps as U+import qualified UMatch as U+import MUtils+import EnvM+import Maybe(fromMaybe)+import Char(isAlpha)++transModule = trans :: HsModuleI m i (TiDecls NName) -> EnvM Env U.Module++instance (Trans b u,Trans p u) => Trans (Prop b p) u where+  transTyped t p = prop tt tt p+    where tt x = transTyped t x++instance Trans (TiAssertion NName) U.Exp where transTyped = transTypedRec+instance Trans (TiPredicate NName) U.Exp where transTyped = transTypedRec++instance Trans (OTiAssertion NName) U.Exp where+  trans (OA is ds pa) = +      --U.uAbsExp+      U.piExp . map (flip (,) (missing "assertion dictionary type"))+        # ltrans is <# (eLet # mapM transT ds <# trans pa)+    where+      transT (i:>:t,e) =+	do i' <- transUnqualVar i+	   t' <- trans t+	   e' <- trans e+	   return $ U.decl' [valdef i' ([],([],t')) e']+			  +instance (Printable pa,Printable pp,+	  Trans pa U.Exp,Trans pp U.Exp)+       => Trans (PD NName pa pp) [U.Def] where+  trans pd =+      case pd of+        HsAssertion s optnm pa -> maybe cmnt (transAssert pa) optnm+        HsPropDecl s nm is pp -> transPropDecl nm  is pp+    where+      cmnt = return [commentdef pd]++      transAssert pa nm =+	do (gs,cs:=>t) <- schak (HsCon nm)+	   extendTyvars gs $ do+	     -- assume t=Prop+	     -- t' <- trans t -- should be Prop+	     gs' <- ltrans gs+	     cs' <- ltrans cs+	     nm' <- trans nm+	     pa' <- trans pa+	     let cnt=length gs+	     return $+               --hide' nm' cnt+++	       [valdef nm' ([],([],{-U.eFuns cs'-}eAssertion))+		           (U.piExp gs' (dictTypes cs' pa'))]++      dictTypes ts = uncurry U.piExp . apFst dictTypes' . U.flatPi+        where dictTypes' xts = zip (map fst xts) ts++drop (length ts) xts++      transPropDecl n is pp =+        do n' <- transUnqualVar n+           sch@(gs,cs:=>t) <- schk (HsCon n) -- or schak...+	   extendTyvars gs $ do+	     tctx <- ltrans gs+	     cs' <- ltrans cs+	     (targs,tres) <- U.flatFun # trans t+	     is' <- ltrans (map getHSName is)+	     let (ctx,tres') = args' is' (cs'++targs) tres+	         cnt=length gs+	     pp' <- trans pp+	     return $ hide' n' cnt++[valdef n' (tctx++ctx,tres') pp']++eProp = un "Prop"+eAssertion = un "Assertion"+--eProp = U.eType+ePred = uApp (un "Pred")++instance (Trans e U.Exp,Trans t U.Exp,Trans pa U.Exp,Trans pp U.Exp)+      => Trans (PA NName e t pa pp) U.Exp where+    trans pa =+      case pa of+	Quant All i optt pa -> do i' <- trans i+                                  optt' <- trans optt+				  U.EPi (i' U.:- opt "type in universal quantifier" optt') # trans pa+	Quant q i optt pa -> do i' <- trans i+				optt' <- trans optt+                                uApp # transQ q optt' <#+				     (eAbs i' optt' # trans pa)+			     +--	PropId i -> U.EVar # i+	PropApp i ts es -> appqvar # transConId i <# ltrans ts <# mapM (either trans trans) es+	PropNeg a -> uApp eNot # trans a+	PropOp op a1 a2 -> U.app # trans op <# ltrans [a1,a2]+	PropEqual e1 e2 -> equal # trans e1 <# trans e2+	PropHas e p -> uApp # trans p <# trans e+	PropParen a -> trans a++eAbs n optt e = U.EAbs (n U.:-opt "type in abstraction" optt) e+eNot = un "Not"+ePredNot = un "NegPred"+--eEq =  m1 (un "Identical")++m1 s e =uApp e (missing s)+m2 s = m1 s . m1 s++-- The type checker is assumed to add a type annotation to the left operand+equal (U.ETyped e1 t1) e2 = U.app (un "===") [t1,e1,e2]+equal e1 e2 = U.app (un "===") [missing "type in equality prop",e1,e2]++transQ q optt = flip uApp (opt "type in quantifier" optt) # trans q++instance Trans Quantifier U.Exp where+  trans q =+    return $+    case q of+      All   -> un "ForAll"+      Exist -> un "Exists"++instance Trans PropOp U.Exp where+  trans op =+    return $+    case op of+     Conj  -> un "And"+     Disj  -> un "Or"+     Imp   -> un "Implies"+     Equiv -> un "Equivalence"++appvar i ts es = U.app (U.EVar i) (ts++es)+appqvar e ts es = U.app e (ts++es)++instance (Trans c U.Exp,Trans t U.Exp) => Trans (PS.Q [c] t) U.Exp where+  trans (c PS.:=> t) = U.eFuns # ltrans c <# trans t++instance (Trans e U.Exp,Trans p U.Pat,Trans t U.Exp,+	  Trans pa U.Exp,Trans pp U.Exp,+	  Printable e,Printable p,Printable t,Printable pa,Printable pp)+      => Trans (PP NName e p t pa pp) U.Exp where+  trans p =+    case p of+--    PredId i -> U.EVar # trans i+      PredApp i ts ps -> appqvar # transConId i+                               <# ltrans ts <# mapM (either trans trans) ps+      PredArrow p1 p2 -> U.app (m2 "type for arrow predicate" (un "Arrow")) # ltrans [p1,p2]+      PredInfixApp p1 i p2 -> U.app . U.EVar # trans i <# ltrans [p1,p2]+      PredNeg optt p -> liftNeg # trans optt <# trans p+      PredOp op optt p1 p2 -> liftOp # trans op <# trans optt <# trans p1 <# trans p2+      PredLfp i optt p -> fix "Lfp" # trans i <# trans optt <# trans p+      PredGfp i optt p -> fix "Gfp" # trans i <# trans optt <# trans p+      PredNil -> return (m1 "type for IsNil" (un "IsNil"))+      PredLifted e -> uApp (m1 "type for !" (un "Lift")) # trans e+      PredStrong p -> trans p -- !!+      PredParen p -> trans p+      PredComp pts a -> foldr abstr # trans a <# ltrans pts+      _ -> return $ missing (comment (pp p)) -- for unimplemented things+    where+      abstr (U.PVar x,optt) e = eAbs x optt e+      abstr _ _ = missing "pattern in predicate comprehension" -- !!!++      liftNeg optt p =+          U.app ePredNot [opt "type of lifted negation" (deep # optt),p]++      liftOp op optt p1 p2 =+          U.app (un "predOp")+                [opt "type of lifted connective" (deep # optt),op,p1,p2]++      fix op i optt p = U.app (un op) [opt "type in Gfp/Lfp" optt,eAbs i (ePred # optt) p]++      deep t =+        case t of+	  U.EApp f t2 | f==un "predT" -> deep t2 -- compensation for shallow translation of t+	  U.EPi (x U.:-t1) t2 -> U.app predCon [t1,deep t2]+	  _ -> if t==propType+	       then propCon+	       else t -- must be a type variable of kind Prop+		+      predCon = U.ECon (U.Con "Pred")+      propCon = U.ECon (U.Con "Prop")+      propType = qn (transM mod_Prelude) "Prop"+----++instance Trans (TiDecls NName) [U.Def] where+  trans (Decs ds env) = concat # extend env (ltrans ds)++instance Trans (TiDecl NName) [U.Def] where+  trans (Dec d) = prop transBase trans d+    where transBase d = (++) # trans d <# liftedCons d++instance Trans (HsPatI NName) U.Pat where trans = trans . struct++instance Trans (TiExp NName) U.Exp where+  trans (Exp e) = trans e+  trans (TiSpec c@(HsCon _) sc ts) = transECon c sc ts+  --trans (TiSpec x _ []) = transEVar x+  trans s@(TiSpec x _ ts) = U.app # inst x <# ltrans ts+  trans (TiTyped e t) = transTyped (Just t) e++  transTyped t (Exp e) = transTyped t e+  transTyped t e = optTransTyped t =<< trans e++------++transRec = trans . struct+transTypedRec t = transTyped t . struct++------++liftedCons d =+  concat #+  case d of+    PS.HsNewTypeDecl s ctx lhs con  der -> liftedCons' lhs+    PS.HsDataDecl    s ctx lhs cons der -> liftedCons' lhs+    _ -> return []+  where+    liftedCons' = liftedCons'' . definedType++    liftedCons'' t@(PNT tn _ _) =+        mapM liftedCon [splitAt i cs'|i<-[0..length cs'-1]]+      where+        cs' = [(pnt (conName c) cty,conArity c)|c<-cs]+        Type tinfo@(TypeInfo {constructors=cs}) = idTy t+	cty = ConstrOf (getQualified tn) tinfo++    liftedCon (cs1,(c,n):cs2) =+	do (gs,qt) <- schk (HsCon c)+	   gs' <- ltrans gs+	   qt' <- extendTyvars gs (trans qt)+	   let ps = gs'++zip pns (map ePred args)++[(x0,res)]+	       (args,res)=U.flatFun qt'+	   c' <- transUnqualVar c+	   other <- mapFstM (\c -> trConName # trans c) (cs1++cs2)+	   let cpred = trPredName c'+	       ccon = trConName c'+	       body = predBody ccon n other+	   return $ hide cpred gs ++[valdef cpred (ps,([],eProp)) body]++       where+         pns = [U.Var ("P"++show i)|i<-[1..n]]+	 x0:xs =[U.Var ("x"++show i)|i<-[0..]]++         predBody c n other = U.ECase (U.EVar x0)+				      (rightBranch:map otherBranch other)+           where+	     rightBranch       = br c n (conj (zipWith varapp pns xs))+	     otherBranch (c,n) = br c n (un "Absurdity")++	     br (U.Var c) n e = U.Branch (U.Con c,(take n xs,e))+	     varapp p x = U.EVar p `uApp` U.EVar x++	     conj [] = un "Triviality"+	     conj ps = foldr1 (uApp . uApp (un "And")) ps++    pnt c idty = PNT (mkUnqual c) idty noSrcLoc++    trPredName (U.Var s) = U.Var . predName . transConName $ s+    trConName (U.Var s) = U.Var . transConName $ s++transConId i =+  if isCon i+  then qn' (transM (origModule i)) # getMEnv <# (liftedConName # trans i)+  else U.EVar # trans i++qn' m ms v@(U.Var x) = if m `elem` ms then U.EVar v else qn m x++liftedConName (U.Var s) = U.Var (predName s)++predName s =+  case s of+    c:_ | isAlpha c -> "Pred"++s+    _ -> "%"++s
+ tools/hs2alfa/README.html view
@@ -0,0 +1,97 @@+<h2>What is in this directory (hs2alfa)</h2>++This directory contains the translator from Haskell to Alfa, which is built+on top of the <a href="../pfe">PFE</a> framework and parts of+<a href="http://www.cs.chalmers.se/~hallgren/Alfa/">Alfa</a>.++<p>+By running <code>make</code> you can create <code>apfe</code>, a command line+tool that has all the functionality of the PFE framework, plus the+ability to translate Haskell files to Alfa files.++<p>+There are also two (obsolete) test programs that don't depend on the PFE+framework: <code>tstHs2Alfa</code> (for the base language, Haskell 98)+and <code>tstProp2Alfa</code> (for Hasell 98 + property declarations).+They can be compiled with <code>make</code> <var>progamname</var>.++<p>+The code compiles with GHC, provided that the directory+<code>AlfaSource</code>, containing certain modules from Alfa, is present+(get <a href="http://www.cse.ogi.edu/~hallgren/Programatica/download/alfaforpfe.tar.gz">alfaforpfe.tar.gz</a>+and unpack it in this directory).++<h3>Limitations</h3>++The translator is work in progress (as everything else here).+It does handle++<ul>+<li>the most common forms of declarations and expressions,+<li>polymorphism,+<li>classes and overloading (by the dictionary translation, which is+    performed mostly by the Haskell type checker in+     <a href="../base/TI/">../base/TI/</a>),+<li>data types and (some forms of) pattern matching,+<li>the list comprehension syntax,+<li>mutually recursive modules (by combining them into one module, name+    clashes can cause problems).+</ul>++The translator does not yet (fully) support++<ul>+<li>pattern matching with guards,+<li>literals in patterns,+<li>data constructors with labelled fields,+<!--+<li>references to default methods in instance declarations+<li>pattern bindings+<li>partially applied constructors+<li>right sections, e.g. (+1)+<li>classes with superclasses+<li>instance declarations that refer to methods of the same class+<li>instances with contexts+<li>polymorphic functions where the quantified variables have kinds other than *+-->+<li>names that are reserved in Alfa but not in Haskell+    (but <code>sig</code>, <code>.</code> and <code>Type</code> are translated).+<li>certain constructions that the Agda type checker rejects, e.g.+    <code>case let ... in ... of ...</code>+</ul>++Other problems:+<ul>+<li>Type signatures containing synonyms for function types (like ReadS) +    can cause problems. (Workaround: comment out the type signature or+    manually expand the type synonym.)+<li>Name capture can occur, for example, in the translation of+    <pre><code>+    class Functor f where fmap :: (a->b)->f a->f b+    instance Ix a => Ix (Array a) where fmap = ...+    </code></pre>+    there will be a problem with capture of the type variable <code>a</code>.+</ul>++The translator can translate P-logic predicate definitions and property+assertions, but++<ul>+<li>the fixed point operators <code>Lfp</code> and <code>Gfp</code> are+    translated, but their meaning in Alfa is probably not what it should be.+<li>the use of constructors lifted to predicates is not yet supported,+<li>the P-logic equality operator (<code>===</code>) is translated to+    intentional equality, which differs for functions.+<!--+-->+<li>the comprehension syntax is restricted.+</ul>++<p>+The subdirectory <a href="tests/">tests</a> contains sample Haskell modules+that the translator can translate. (There are also some test files in+this directory.)++<hr>+<address>Author: Thomas Hallgren</address>+<address>Contact: <a href="http://www.cse.ogi.edu/~hallgren/">TH</address>
+ tools/hs2alfa/USCC.hs view
@@ -0,0 +1,15 @@+module USCC(decls) where+import UFree+import UAbstract(Decls,Def,defaNames,Var(..),decl')+import TiSCC+import FreeNames+import DefinedNames+import HsIdent(HsIdentI(..))++decls = map decl' . sccD :: [Def] -> Decls++instance FreeNames Var Def where+  freeNames = map (flip (,) ValueNames . HsVar) . free++instance DefinedNames Var Def where+  definedNames = map (flip (,) Value . HsVar) . defaNames
+ tools/hs2alfa/apfe.hs view
@@ -0,0 +1,10 @@++import PPfeMain(mainPFE)+import PPfeInstances+import PfeInteractive(pfeiAllCmds)+import PPfeCmds(ppfeCmds)+import PfeAlfaCmds(pfeAlfaCmds)++main = mainPFE (pfeiAllCmds apfeCmds)++apfeCmds = ppfeCmds++pfeAlfaCmds
+ tools/hs2alfa/tests/Fields.hs view
@@ -0,0 +1,24 @@+module Fields where++data Point = P {x,y::Int} | Q {z::Int}++origin = P { x=0, y=0 }+h = P {x=1,y=1}+v = origin {y=1}++u = P {}++sq x = x*x++dist1 p = sq (x p) + sq (y p)++dist2 P{x=x,y=y} = sq x+sq y++--data Z = Z {z::Int}++data Thread s = T { name::String, status::s}+data Running = Running+data Runanble = Runnable (IO())+++makeRunning t = t{status=Running}
+ tools/hs2alfa/tests/Haskell.alfa view
@@ -0,0 +1,243 @@+--#include "Alfa/Types.alfa"++--#include "Alfa/Bool.alfa"++--#include "Logic.alfa"++--#include "Alfa/Natural.alfa"++--#include "Integer.alfa"++-- Some definitions used by hs2alfa to make the translated code look more Haskell-like++Class = Type++Star = Set++Assertion = Type++-- super is a trick used in the type checker when referring to superclasses++super (C::Class)(inst::C) :: C+  = inst++TypeSig (A::Set)(a::A) :: A+  = a++public open Booleans  use  if_then_else++open Logic+ use  Prop,  Pred,  Rel,  Absurdity,  AbsurdityElim,  Triviality,+      TrivialityIntro,  NDGoal,  And,  AndIntro,  AndElim1,  AndElim2,+      AndElimCont,  Or,  OrIntro1,  OrIntro2,  OrElim,  Implies,+      ImpliesIntro,  ImpliesElim,  Not,  NotElim,  Equivalence,+      ForAll,  ForAllI,  ForAllElim,  Exists,  ExistsIntro,+      ExistsElim++package PreludeFromAlfa where+  public open Types  use  Char,  List+  open Types  use  Digit,  Pair,  Sign,  String+  public open Booleans  use  Bool+  open Booleans  use  (&&)+  public open Logic  use  Prop+  public open Integers+          use  Integer,  primIntegerEq,  eqSign,  primIntegerAdd,+               primIntegerNegate,  primIntegerSub,  primIntegerAbs,+               primIntegerSignum,  primIntegerMul,  primIntegerRem,+               primIntegerQuot,  primIntegerLte+  primUnicodeMaxChar ::Char+    = C@_ NF@_ NF@_+  Ratio (a::Star) :: Star+    = data (:%) (n::a) (d::a)+  Rational = Ratio Integer+  primIntegerNeg (i::Integer) :: Bool+    = case i of {+        (Pair fst snd) ->+          case fst of {+            (Neg) -> True@_;+            (Pos) -> False@_;};}+  primIntegerDigits (i::Integer) :: List (List Bool)+    = case i of {+        (Pair fst snd) ->+          let convDigit (d::Digit) :: List Bool+                = case d of {+                    (D0) -> Nil@_;+                    (D1) -> Cons@_ True@_ Nil@_;+                    (D2) -> Cons@_ True@_ (Cons@_ False@_ Nil@_);+                    (D3) -> Cons@_ True@_ (Cons@_ True@_ Nil@_);+                    (D4) ->+                      Cons@_ True@_ (Cons@_ False@_ (Cons@_ False@_ Nil@_));+                    (D5) -> Cons@_ True@_ (Cons@_ False@_ (Cons@_ True@_ Nil@_));+                    (D6) -> Cons@_ True@_ (Cons@_ True@_ (Cons@_ False@_ Nil@_));+                    (D7) -> Cons@_ True@_ (Cons@_ True@_ (Cons@_ True@_ Nil@_));+                    (D8) ->+                      Cons@_ True@_ (Cons@_ False@_ (Cons@_ False@_ (Cons@_ False@_ Nil@_)));+                    (D9) ->+                      Cons@_ True@_ (Cons@_ False@_ (Cons@_ False@_ (Cons@_ True@_ Nil@_)));}+              convDigits (ds::List Digit) :: List (List Bool)+                = case ds of {+                    (Nil) -> Nil@_;+                    (Cons x xs) -> Cons@_ (convDigit x) (convDigits xs);}+          in  convDigits snd;}+  Int = Integer+  primInteger2Int ::Integer -> Int+    =  \(h::Integer) -> h+  primInt2Integer ::Int -> Integer+    =  \(h::Int) -> h+  primIntEq = primIntegerEq+  primIntLte = primIntegerLte+  postulate primIntToChar :: Int -> Char+  postulate primCharToInt :: Char -> Int+  primIntAdd = primIntegerAdd+  primIntNegate = primIntegerNegate+  primIntSub = primIntegerSub+  primIntMul = primIntegerMul+  primIntRem = primIntegerRem+  primIntQuot = primIntegerQuot+  primIntAbs = primIntegerAbs+  primIntSignum = primIntegerSignum+  (->) (a::Star)(b::Star) :: Star+    = a -> b+  Unit ::Star+    = data Unit+  Tuple2 (a::Star)(b::Star) :: Star+    = data Tuple2 (x1::a) (x2::b)+  Tuple3 (a::Star)(b::Star)(c::Star) :: Star+    = data Tuple3 (a::a) (b::b) (c::c)+  Tuple4 (a::Star)(b::Star)(c::Star)(d::Star) :: Star+    = data Tuple4 (a::a) (b::b) (c::c) (d::d)+  Tuple5 (a::Star)(b::Star)(c::Star)(d::Star)(e::Star) :: Star+    = data Tuple5 (a::a) (b::b) (c::c) (d::d) (e::e)+  Tuple6 (a::Star)(b::Star)(c::Star)(d::Star)(e::Star)(f::Star) :: Star+    = data Tuple6 (a::a) (b::b) (c::c) (d::d) (e::e) (f::f)+  Tuple7 (a::Star)(b::Star)(c::Star)(d::Star)(e::Star)(f::Star)(g::Star) ::+    Star+    = data Tuple7 (a::a) (b::b) (c::c) (d::d) (e::e) (f::f) (g::g)+  abstract postulate Float :: Star+  abstract postulate Double :: Star+  public postulate primError (a::Star)(s::String) :: a+  abstract postulate IO (a::Star) :: Star+  postulate getContents :: IO String+  postulate readFile (path::String) :: IO String+  postulate writeFile (path::String)(contents::String) :: IO Unit+  postulate appendFile (path::String)(contents::String) :: IO Unit+  postulate putStr (str::String) :: IO Unit+  postulate Handle :: Star+  -- Hugs.Prelude stuff:+  postulate Addr :: Star+  postulate ForeignObj :: Star+  postulate FunPtr (a::Star) :: Star+  postulate Object (a::Star) :: Star+  postulate Ptr (a::Star) :: Star+  postulate StablePtr (a::Star) :: Star+  postulate ForeignPtr (a::Star) :: Star+  postulate Word :: Star+  postulate Word8 :: Star+  postulate Word16 :: Star+  postulate Word32 :: Star+  postulate Word64 :: Star+  postulate Int8 :: Star+  postulate Int16 :: Star+  postulate Int32 :: Star+  postulate Int64 :: Star+  primSeq (a::Star)(b::Star)(x::a)(y::b) :: b+    = y+  -- The P-Logic predicate []:+  IsNil (A::Star)(xs::List A) :: Prop+    = case xs of {+        (Nil) -> Triviality;+        (Cons x xs') -> Absurdity;}+  Cons (A::Star)(Px::Pred A)(Pxs::Pred (List A))(xs::List A) :: Prop+    = case xs of {+        (Nil) -> Absurdity;+        (Cons x xs') -> And (Px x) (Pxs xs');}+  -- The P-Logic lifting operator:+  Lift (A::Star)(f::A -> Bool)(x::A) :: Prop+    = Logic.IsTrue (f x)+  Arrow (A::Star)(B::Star)(P::Pred A)(Q::Pred B)(f::A -> B) :: Prop+    = ForAll A ( \(x::A) -> Implies (P x) (Q (f x)))+  -- A deep embedding of predicate types:+  PredT ::Type+    = data Prop | Pred (t::Star) (p::PredT)+  predT (pt::PredT) :: Type+    = case pt of {+        (Prop) -> Prop;+        (Pred t p) -> t -> predT p;}+  PropKind = PredT+  NegPred (A::PredT)(p::predT A) :: predT A+    = case A of {+        (Prop) -> Not p;+        (Pred t p') ->  \(a::t) -> NegPred p' (p a);}+  -- (Old) Lifting a binary operator to unary predicates:+  liftPropOp (A::Star)(op::Prop -> Prop -> Prop)(p1::Pred A)(p2::Pred A) ::+    Pred A+    =  \(a::A) -> op (p1 a) (p2 a)+  -- Lifting a binary operator to arbitrary arity predicates:+  predOp (pt::PredT)+         (op::Prop -> Prop -> Prop)+         (p1::predT pt)+         (p2::predT pt) ::+    predT pt+    = case pt of {+        (Prop) -> op p1 p2;+        (Pred t p) ->  \(a::t) -> predOp p op (p1 a) (p2 a);}+  -- The types of Lfp and Gfp are too general (to allow arbitrary arity predicates)...+  open Natural+   use  Nat,  (+),  (*),  isZero,  natRec,  natEq,  max,  (-),  natLte,+        natLt,  natGt+  iter (A::Star)(P::Pred A -> Pred A)(n::Nat) :: Pred A -> Pred A+    = case n of {+        (Zero) ->  \(h::Pred A) -> h;+        (Succ n') ->  \(h::Pred A) -> P (iter A P n' h);}+  Lfp (A::Set)(P::Pred A -> Pred A) :: Pred A+    =  \(a::A) ->+      Exists Nat ( \(n::Nat) -> iter A P n ( \(h'::A) -> Absurdity) a)+  Gfp (A::Set)(P::Pred A -> Pred A) :: Pred A+    =  \(a::A) ->+      ForAll Nat ( \(n::Nat) -> iter A P n ( \(h'::A) -> Triviality) a)++open Logic  use  (===)++open PreludeFromAlfa+ use  IsNil,  Lift,  Arrow,  NegPred,  liftPropOp,  PropKind,  predT,+      predOp,  Lfp,  Gfp,  Cons+{-# Alfa unfoldgoals off+brief on+hidetypeannots off+wide++nd+hiding on+var "Unit" tuple as "()"+con "Unit" as "()"+con "Nil" as "[]"+con ":" infix rightassoc 5+var "List" mixfix as "[_]"+var "Star" as "*" with symbolfont+var "Tuple2" tuple+con "Tuple2" tuple+var "super" hide 1+var "Tuple3" tuple+var "Tuple4" tuple+var "Tuple5" tuple+var "Tuple6" tuple+var "Tuple7" tuple+con "Tuple3" tuple+con "Tuple4" tuple+con "Tuple5" tuple+con "Tuple6" tuple+con "Tuple7" tuple+var "IsNil" hide 1 as "[]"+var "Lift" hide 1 as "!" with symbolfont+var "Arrow" hide 2 infix as "®" with symbolfont+var "primError" hide 1+var "primSeq" hide 2+var "liftPropOp" hide 1 mixfix as "2 1 3"+var "NegPred" hide 1 as "Ø" with symbolfont+var "Gfp" hide 1 quantifier domain on+var "Lfp" hide 1 quantifier domain on+var "Cons" hide 1 infix rightassoc 5 as ":"+var "TypeSig" mixfix as "2 :: 1"+var "iter" hide 1+con "Pred" infix rightassoc as "®" with symbolfont+ #-}
+ tools/hs2alfa/tests/Integer.alfa view
@@ -0,0 +1,304 @@+--#include "Alfa/Types.alfa"++--#include "Alfa/Bool.alfa"++--#include "Alfa/Natural.alfa"++--#include "Alfa/List.alfa"++--#include "Alfa/Tuples.alfa"++package Integers where+  open Types  use  Digit,  Sign,  IntLit+  open Booleans+   use  Bool,  ifTrue,  ifFalse,  ifD,  if_then_else,  not,  (&&),+        (||),  boolEq+  open Natural+   use  Nat,  succ,  (+),  (*),  isZero,  natRec,  natEq,  max,  (-),+        natLte,  natLt,  natGt+  open Lists  use  List,  reverse,  null+  open Tuples  use  Pair,  fst,  snd+  Integer = IntLit+  one = succ Zero@_+  two = succ one+  three = succ two+  four = succ three+  five = succ four+  six = succ five+  seven = succ six+  eight = succ seven+  nine = succ eight+  digitToNat (d::Digit) :: Nat+    = case d of {+        (D0) -> Zero@_;+        (D1) -> one;+        (D2) -> two;+        (D3) -> three;+        (D4) -> four;+        (D5) -> five;+        (D6) -> six;+        (D7) -> seven;+        (D8) -> eight;+        (D9) -> nine;}+  isZeroDigit (d::Digit) :: Bool+    = isZero (digitToNat d)+  eqSign (s1::Sign)(s2::Sign) :: Bool+    = case s1 of {+        (Neg) ->+          case s2 of {+            (Neg) -> True@_;+            (Pos) -> False@_;};+        (Pos) ->+          case s2 of {+            (Neg) -> False@_;+            (Pos) -> True@_;};}+  eqDigit (d1::Digit)(d2::Digit) :: Bool+    = natEq (digitToNat d1) (digitToNat d2)+  eqDigits (ds1::List Digit)(ds2::List Digit) :: Bool+    = case ds1 of {+        (Nil) ->+          case ds2 of {+            (Nil) -> True@_;+            (Cons x xs) -> False@_;};+        (Cons x xs) ->+          case ds2 of {+            (Nil) -> False@_;+            (Cons x' xs') -> (eqDigit x x' && eqDigits xs xs');};}+  normDigits (ds::List Digit) :: List Digit+    = case ds of {+        (Nil) -> Nil@_;+        (Cons x xs) ->+          case isZeroDigit x of {+            (True) -> normDigits xs;+            (False) -> ds;};}+  zeroInteger ::Integer+    = Pair@_ Pos@_ (Cons@_ D0@_ Nil@_)+  -- addSign: create +0 rather than -0+  addSign (s::Sign)(ds::List Digit) :: Integer+    = if_then_else Integer (null Digit ds) zeroInteger (Pair@_ s ds)+  normInteger (i::Integer) :: Integer+    = case i of { (Pair s ds) -> addSign s (normDigits ds);}+  primNormIntegerEq (i1::Integer)(i2::Integer) :: Bool+    = case i1 of {+        (Pair s1 ds1) ->+          case i2 of {+            (Pair s2 ds2) ->+              (eqSign s1 s2 && eqDigits (normDigits ds1) (normDigits ds2));};}+  primIntegerEq (x::Integer)(y::Integer) :: Bool+    = primNormIntegerEq (normInteger x) (normInteger y)+  succDigit (d::Digit) :: Digit+    = case d of {+        (D0) -> D1@_;+        (D1) -> D2@_;+        (D2) -> D3@_;+        (D3) -> D4@_;+        (D4) -> D5@_;+        (D5) -> D6@_;+        (D6) -> D7@_;+        (D7) -> D8@_;+        (D8) -> D9@_;+        (D9) -> D0@_;}+  predDigit (d::Digit) :: Digit+    = case d of {+        (D0) -> D9@_;+        (D1) -> D0@_;+        (D2) -> D1@_;+        (D3) -> D2@_;+        (D4) -> D3@_;+        (D5) -> D4@_;+        (D6) -> D5@_;+        (D7) -> D6@_;+        (D8) -> D7@_;+        (D9) -> D8@_;}+  carryDigit (d::Digit) :: Bool+    = case d of {+        (D0) -> False@_;+        (D1) -> False@_;+        (D2) -> False@_;+        (D3) -> False@_;+        (D4) -> False@_;+        (D5) -> False@_;+        (D6) -> False@_;+        (D7) -> False@_;+        (D8) -> False@_;+        (D9) -> True@_;}+  borrowDigit (d::Digit) :: Bool+    = case d of {+        (D0) -> True@_;+        (D1) -> False@_;+        (D2) -> False@_;+        (D3) -> False@_;+        (D4) -> False@_;+        (D5) -> False@_;+        (D6) -> False@_;+        (D7) -> False@_;+        (D8) -> False@_;+        (D9) -> False@_;}+  succDigits (ds::List Digit) :: List Digit+    = case ds of {+        (Nil) -> Cons@_ D1@_ Nil@_;+        (Cons x xs) ->+          Cons@_ (succDigit x) (let it ::List Digit+                                      = case carryDigit x of {+                                          (True) -> succDigits xs;+                                          (False) -> xs;}+                                in  it);}+  predDigits (ds::List Digit) :: List Digit+    = case ds of {+        (Nil) -> Nil@_;+        (Cons x xs) ->+          Cons@_ (predDigit x) (let it ::List Digit+                                      = case borrowDigit x of {+                                          (True) -> predDigits xs;+                                          (False) -> xs;}+                                in  it);}+  incDigits (n::Nat)(ds::List Digit) :: List Digit+    = case n of {+        (Zero) -> ds;+        (Succ n') -> succDigits (incDigits n' ds);}+  decDigits (n::Nat)(ds::List Digit) :: List Digit+    = case n of {+        (Zero) -> ds;+        (Succ n') -> predDigits (decDigits n' ds);}+  mutual addDigits (ds1::List Digit)(ds2::List Digit) :: List Digit+           = case ds1 of {+               (Nil) -> ds2;+               (Cons x xs) -> addDigits' xs (incDigits (digitToNat x) ds2);}+         addDigits' (ds1::List Digit)(ds2::List Digit) :: List Digit+           = case ds2 of {+               (Nil) -> Cons@_ D0@_ ds1;+               (Cons x xs) -> Cons@_ x (addDigits ds1 xs);}+  addUnsigned (ds1::List Digit)(ds2::List Digit) :: List Digit+    = reverse Digit (addDigits (reverse Digit ds1) (reverse Digit ds2))+  O ::Set+    = data LT | EQ | GT+  lexOrd (o1::O)(o2::O) :: O+    = case o1 of {+        (LT) -> LT@_;+        (EQ) -> o2;+        (GT) -> GT@_;}+  lte (o::O) :: Bool+    = case o of {+        (LT) -> True@_;+        (EQ) -> True@_;+        (GT) -> False@_;}+  lt (o::O) :: Bool+    = case o of {+        (LT) -> True@_;+        (EQ) -> False@_;+        (GT) -> False@_;}+  compareNat (n1::Nat)(n2::Nat) :: O+    = if_then_else O (natLte n1 n2) (if_then_else O (natEq n1 n2) EQ@_ LT@_) GT@_+  compareDigit (d1::Digit)(d2::Digit) :: O+    = compareNat (digitToNat d1) (digitToNat d2)+  compareDigits (ds1::List Digit)(ds2::List Digit) :: O+    = case ds1 of {+        (Nil) ->+          case ds2 of {+            (Nil) -> EQ@_;+            (Cons x xs) -> LT@_;};+        (Cons x xs) ->+          case ds2 of {+            (Nil) -> GT@_;+            (Cons x' xs') -> lexOrd (compareDigits xs xs') (compareDigit x x');};}+  compareUnsigned (ds1::List Digit)(ds2::List Digit) :: O+    = compareDigits (reverse Digit ds1) (reverse Digit ds2)+  compareNormInteger (i1::Integer)(i2::Integer) :: O+    = case i1 of {+        (Pair s1 ds1) ->+          case i2 of {+            (Pair s2 ds2) ->+              case s1 of {+                (Neg) ->+                  case s2 of {+                    (Neg) -> compareUnsigned ds2 ds1;+                    (Pos) -> LT@_;};+                (Pos) ->+                  case s2 of {+                    (Neg) -> GT@_;+                    (Pos) -> compareUnsigned ds1 ds2;};};};}+  compareInteger (i1::Integer)(i2::Integer) :: O+    = compareNormInteger (normInteger i1) (normInteger i2)+  primIntegerLte (i1::Integer)(i2::Integer) :: Bool+    = lte (compareInteger i1 i2)+  mutual subDigits (ds1::List Digit)(ds2::List Digit) :: List Digit+           = case ds2 of {+               (Nil) -> ds1;+               (Cons x xs) -> subDigits' (decDigits (digitToNat x) ds1) xs;}+         subDigits' (ds1::List Digit)(ds2::List Digit) :: List Digit+           = case ds1 of {+               (Nil) -> Nil@_;+               (Cons x xs) -> Cons@_ x (subDigits xs ds2);}+  posSubDigits (ds1::List Digit)(ds2::List Digit) :: List Digit+    = reverse Digit (subDigits (reverse Digit ds1) (reverse Digit ds2))+  subNormUnsigned (ds1::List Digit)(ds2::List Digit) :: Integer+    = case lt (compareUnsigned ds1 ds2) of {+        (True) -> Pair@_ Neg@_ (posSubDigits ds2 ds1);+        (False) -> Pair@_ Pos@_ (posSubDigits ds1 ds2);}+  subUnsigned (ds1::List Digit)(ds2::List Digit) :: Integer+    = subNormUnsigned (normDigits ds1) (normDigits ds2)+  primIntegerAdd (i1::Integer)(i2::Integer) :: Integer+    = case i1 of {+        (Pair s1 ds1) ->+          case i2 of {+            (Pair s2 ds2) ->+              case s1 of {+                (Neg) ->+                  case s2 of {+                    (Neg) -> Pair@_ Neg@_ (addUnsigned ds1 ds2);+                    (Pos) -> subUnsigned ds2 ds1;};+                (Pos) ->+                  case s2 of {+                    (Neg) -> subUnsigned ds1 ds2;+                    (Pos) -> Pair@_ Pos@_ (addUnsigned ds1 ds2);};};};}+  negateSign (s::Sign) :: Sign+    = case s of {+        (Neg) -> Pos@_;+        (Pos) -> Neg@_;}+  primIntegerNegate (i::Integer) :: Integer+    = case i of { (Pair s ds) -> Pair@_ (negateSign s) ds;}+  primIntegerSub (i1::Integer)(i2::Integer) :: Integer+    = primIntegerAdd i1 (primIntegerNegate i2)+  primIntegerAbs (i::Integer) :: Integer+    = Pair@_ Pos@_ (snd Sign (List Digit) i)+  primNormIntegerSignum (s::Sign)(ds::List Digit) :: Integer+    = case ds of {+        (Nil) -> Pair@_ Pos@_ (Cons@_ D0@_ Nil@_);+        (Cons x xs) ->+          case s of {+            (Neg) -> Pair@_ Neg@_ (Cons@_ D1@_ Nil@_);+            (Pos) -> Pair@_ Pos@_ (Cons@_ D1@_ Nil@_);};}+  primIntegerSignum (i::Integer) :: Integer+    = case i of { (Pair s ds) -> primNormIntegerSignum s (normDigits ds);}+  mulDigit (n::Nat)(ds::List Digit) :: List Digit+    = case n of {+        (Zero) -> Nil@_;+        (Succ n') -> addDigits ds (mulDigit n' ds);}+  mulUnsigned (ds1::List Digit)(ds2::List Digit) :: List Digit+    = case ds1 of {+        (Nil) -> Nil@_;+        (Cons x xs) ->+          addDigits (mulDigit (digitToNat x) ds2) (mulUnsigned xs (Cons@_ D0@_ ds2));}+  mulSign (s1::Sign)(s2::Sign) :: Sign+    = case s1 of {+        (Neg) -> negateSign s2;+        (Pos) -> s2;}+  primIntegerMul (i1::Integer)(i2::Integer) :: Integer+    = case i1 of {+        (Pair s1 ds1) ->+          case i2 of {+            (Pair s2 ds2) ->+              Pair@_ (mulSign s1 s2) (reverse Digit (mulUnsigned (reverse Digit ds1) (reverse Digit ds2)));};}+  postulate primIntegerRem :: Integer -> Integer -> Integer+  postulate primIntegerQuot :: Integer -> Integer -> Integer+{-# Alfa unfoldgoals off+brief on+hidetypeannots off+wide++nd+hiding on+var "eqSign" infix 4 as "=="+var "eqDigit" infix 4 as "=="+var "eqDigits" infix 4 as "=="+ #-}
+ tools/hs2alfa/tests/List.hs view
@@ -0,0 +1,265 @@+module List {-(+    elemIndex, elemIndices,+    find, findIndex, findIndices,+    nub, nubBy, delete, deleteBy, (\\),+    union, unionBy, intersect, intersectBy,+    intersperse, transpose, partition, group, groupBy,+    inits, tails, isPrefixOf, isSuffixOf,+    mapAccumL, mapAccumR,+    sort, sortBy, insert, insertBy, maximumBy, minimumBy,+    genericLength, genericTake, genericDrop,+    genericSplitAt, genericIndex, genericReplicate,+    zip4, zip5, zip6, zip7,+    zipWith4, zipWith5, zipWith6, zipWith7,+    unzip4, unzip5, unzip6, unzip7, unfoldr,++    -- ...and what the Prelude exports+    --[]((:), []),+    map, (++), concat, filter,+    head, last, tail, init, null, length, (!!),+    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,+    iterate, repeat, replicate, cycle,+    take, drop, splitAt, takeWhile, dropWhile, span, break,+    lines, words, unlines, unwords, reverse, and, or,+    any, all, elem, notElem, lookup,+    sum, product, maximum, minimum, concatMap,+    zip, zip3, zipWith, zipWith3, unzip, unzip3+    )-} where++import Prelude+import Maybe( listToMaybe )++infix 5 \\++elemIndex               :: Eq a => a -> [a] -> Maybe Int+elemIndex x             =  findIndex (x ==)++elemIndices             :: Eq a => a -> [a] -> [Int]+elemIndices x           =  findIndices (x ==)++find                    :: (a -> Bool) -> [a] -> Maybe a+find p                  =  listToMaybe . filter p++findIndex               :: (a -> Bool) -> [a] -> Maybe Int+findIndex p             =  listToMaybe . findIndices p++findIndices             :: (a -> Bool) -> [a] -> [Int]+findIndices p xs        =  [ i | (x,i) <- zip xs [0..], p x ]++nub                     :: Eq a => [a] -> [a]+nub                     =  nubBy (==)++nubBy                   :: (a -> a -> Bool) -> [a] -> [a]+nubBy eq []             =  []+nubBy eq (x:xs)         =  x : nubBy eq (filter (\y -> not (eq x y)) xs)++delete                  :: Eq a => a -> [a] -> [a]+delete                  =  deleteBy (==)++deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]+deleteBy eq x []        = []+deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys++(\\)                    :: Eq a => [a] -> [a] -> [a]+(\\)                    =  foldl (flip delete)++deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]+deleteFirstsBy eq       =  foldl (flip (deleteBy eq))++union                   :: Eq a => [a] -> [a] -> [a]+union                   =  unionBy (==)++unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]+unionBy eq xs ys        =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs++intersect               :: Eq a => [a] -> [a] -> [a]+intersect               =  intersectBy (==)++intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]+intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]++intersperse             :: a -> [a] -> [a]+intersperse sep []      =  []+intersperse sep [x]     =  [x]+intersperse sep (x:xs)  =  x : sep : intersperse sep xs++-- transpose is lazy in both rows and columns,+--   and works for non-rectangular 'matrices'+-- For example, transpose [[1,2],[3,4,5],[]]  =  [[1,3],[2,4],[5]]+-- Note that [h | (h:t) <- xss] is not the same as (map head xss)+-- because the former discards empty sublists inside xss+transpose                :: [[a]] -> [[a]]+transpose []  = []+transpose ([]     : xss) = transpose xss+transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) :+   transpose (xs : [t | (h:t) <- xss])++partition               :: (a -> Bool) -> [a] -> ([a],[a])+partition p xs          =  foldr select ([],[]) xs+                           where select x (ts,fs) | p x       = (x:ts,fs)+                                                  | otherwise = (ts, x:fs)++-- group splits its list argument into a list of lists of equal, adjacent+-- elements.  e.g.,+-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]+group                   :: Eq a => [a] -> [[a]]+group                   =  groupBy (==)++groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]+groupBy eq []           =  []+groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs+                           where (ys,zs) = span (eq x) xs++-- inits xs returns the list of initial segments of xs, shortest first.+-- e.g., inits "abc" == ["","a","ab","abc"]+inits                   :: [a] -> [[a]]+inits []                =  [[]]+inits (x:xs)            =  [[]] ++ map (x:) (inits xs)++-- tails xs returns the list of all final segments of xs, longest first.+-- e.g., tails "abc" == ["abc", "bc", "c",""]+tails                   :: [a] -> [[a]]+tails []                =  [[]]+tails xxs@(_:xs)        =  xxs : tails xs++isPrefixOf               :: Eq a => [a] -> [a] -> Bool+isPrefixOf []     _      =  True+isPrefixOf _      []     =  False+isPrefixOf (x:xs) (y:ys) =  x == y && isPrefixOf xs ys++isSuffixOf              :: Eq a => [a] -> [a] -> Bool+isSuffixOf x y          =  reverse x `isPrefixOf` reverse y++mapAccumL               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccumL f s []        =  (s, [])+mapAccumL f s (x:xs)    =  (s'',y:ys)+                           where (s', y ) = f s x+                                 (s'',ys) = mapAccumL f s' xs++mapAccumR               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])+mapAccumR f s []        =  (s, [])+mapAccumR f s (x:xs)    =  (s'', y:ys)+                           where (s'',y ) = f s' x+                                 (s', ys) = mapAccumR f s xs++unfoldr :: (b -> Maybe (a,b)) -> b -> [a]+unfoldr f b = case f b of+	        Nothing    -> []+		Just (a,b) -> a : unfoldr f b++sort                    :: (Ord a) => [a] -> [a]+sort                    =  sortBy compare++sortBy                  :: (a -> a -> Ordering) -> [a] -> [a]+sortBy cmp              =  foldr (insertBy cmp) []++insert :: (Ord a) => a -> [a] -> [a]+insert = insertBy compare++insertBy                :: (a -> a -> Ordering) -> a -> [a] -> [a]+insertBy cmp x []       =  [x]+insertBy cmp x ys@(y:ys')+                        =  case cmp x y of+                                GT -> y : insertBy cmp x ys'+                                _  -> x : ys++maximumBy               :: (a -> a -> a) -> [a] -> a+maximumBy max []        =  error "List.maximumBy: empty list"+maximumBy max xs        =  foldl1 max xs++minimumBy               :: (a -> a -> a) -> [a] -> a+minimumBy min []        =  error "List.minimumBy: empty list"+minimumBy min xs        =  foldl1 min xs++--genericLength           :: (Integral a) => [b] -> a+genericLength []        =  0+genericLength (x:xs)    =  1 + genericLength xs++--genericTake             :: (Integral a) => a -> [b] -> [b]+genericTake _ []        =  []+genericTake 0 _         =  []+genericTake n (x:xs)+   | n > 0              =  x : genericTake (n-1) xs+   | otherwise          =  error "List.genericTake: negative argument"++--genericDrop             :: (Integral a) => a -> [b] -> [b]+genericDrop 0 xs        =  xs+genericDrop _ []        =  []+genericDrop n (_:xs)+   | n > 0              =  genericDrop (n-1) xs+   | otherwise          =  error "List.genericDrop: negative argument"++--genericSplitAt          :: (Integral a) => a -> [b] -> ([b],[b])+genericSplitAt 0 xs     =  ([],xs)+genericSplitAt _ []     =  ([],[])+genericSplitAt n (x:xs)+   | n > 0              =  (x:xs',xs'')+   | otherwise          =  error "List.genericSplitAt: negative argument"+       where (xs',xs'') =  genericSplitAt (n-1) xs++--genericIndex            :: (Integral a) => [b] -> a -> b+genericIndex (x:_)  0   =  x+genericIndex (x:xs) n+        | n > 0         =  genericIndex xs (n-1)+        | otherwise     =  error "List.genericIndex: negative argument"+genericIndex _ _        =  error "List.genericIndex: index too large"++--genericReplicate        :: (Integral a) => a -> b -> [b]+genericReplicate n x    =  genericTake n (repeat x)++zip4                    :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]+zip4                    =  zipWith4 (,,,)++zip5                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]+zip5                    =  zipWith5 (,,,,)++zip6                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [(a,b,c,d,e,f)]+zip6                    =  zipWith6 (,,,,,)++zip7                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->+                              [g] -> [(a,b,c,d,e,f,g)]+zip7                    =  zipWith7 (,,,,,,)++zipWith4                :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]+zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)+                        =  z a b c d : zipWith4 z as bs cs ds+zipWith4 _ _ _ _ _      =  []++zipWith5                :: (a->b->c->d->e->f) ->+                           [a]->[b]->[c]->[d]->[e]->[f]+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)+                        =  z a b c d e : zipWith5 z as bs cs ds es+zipWith5 _ _ _ _ _ _    =  []++zipWith6                :: (a->b->c->d->e->f->g) ->+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]+zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)+                        =  z a b c d e f : zipWith6 z as bs cs ds es fs+zipWith6 _ _ _ _ _ _ _  =  []++zipWith7                :: (a->b->c->d->e->f->g->h) ->+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]+zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)+                   =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs+zipWith7 _ _ _ _ _ _ _ _ = []++unzip4                  :: [(a,b,c,d)] -> ([a],[b],[c],[d])+unzip4                  =  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->+                                        (a:as,b:bs,c:cs,d:ds))+                                 ([],[],[],[])++unzip5                  :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])+unzip5                  =  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->+                                        (a:as,b:bs,c:cs,d:ds,e:es))+                                 ([],[],[],[],[])++unzip6                  :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])+unzip6                  =  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->+                                        (a:as,b:bs,c:cs,d:ds,e:es,f:fs))+                                 ([],[],[],[],[],[])++unzip7          :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])+unzip7          =  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->+                                (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))+                         ([],[],[],[],[],[],[])
+ tools/hs2alfa/tests/ListProp.hs view
@@ -0,0 +1,18 @@+module ListProp where+import List++assert ElemProp = {-#cert:Alfa_ElemProp#-}+  All y . All xs . All ys . True {y `elem` ys} ==> True {y `elem` (xs++ys)}++property Reflexive = {| op | All x . True {op x x} |}++assert NubByProp = {-#cert:Alfa_NubByProp#-}+  All eq . Reflexive {eq} ==> All x . {nubBy eq [x,x]} === {[x]}++sameEq x y = (==) (y `asTypeOf` x)+assert NubProp = {-#cert:Alfa_NubProp#-}+  All x . Reflexive {sameEq x} ==> {nub [x,x]} === {[x]}+++assert NubPropDoesn'tWork =+  All x . Reflexive {(==)} ==> {nub [x,x]} === {[x]}
+ tools/hs2alfa/tests/ListPropProofs.alfa view
@@ -0,0 +1,171 @@+--#include "alfa/ListProp.alfa"++open Logic  use  refl,  cong,  subst,  substSym++open Module_Prelude+ use  Eq,  elem,  List,  (++),  PredTrue,  Bool,  (||),  (==),  tail,+      filter,  not,  PredNil,  PredFalse,  asTypeOf++open Module_List  use  nub,  nubBy++open Module_ListProp  use  ElemProp,  NubByProp,  NubProp,  Reflexive++orRightLemma (a::Bool)(b::Bool)(bp::PredTrue b) :: PredTrue (a || b)+  = case a of {+      (False) -> bp;+      (True) -> TrivialityIntro;}++mutual --#S+       proofElemProp :: ElemProp+         = let proof (t2::Star)(d6::Eq t2)(y::t2)(xs::List t2)(ys::List t2)+                 :: Implies+                      (PredTrue (elem t2 d6 y ys))+                      (PredTrue (elem t2 d6 y ((++) t2 xs ys)))+                 = let lemma (xs::List t2)(hyp::PredTrue (elem t2 d6 y ys))+                         :: PredTrue (elem t2 d6 y ((++) t2 xs ys))+                         = case xs of {+                             (Nil) -> hyp;+                             (Cons x xs') ->+                               orRightLemma+                                 ((==) t2 d6 y x)+                                 (elem t2 d6 y ((++) t2 xs' ys))+                                 (lemma xs' hyp);}+                   in  ImpliesIntro+                         (PredTrue (elem t2 d6 y ys))+                         (PredTrue (elem t2 d6 y ((++) t2 xs ys)))+                         (lemma xs)+           in  proof++lemmaNubByNil (a::Star)+              (eq::a -> a -> Bool)+              (xs::List a)+              (p::(===) (List a) xs Nil@_)+  :: (===) (List a) (nubBy a eq xs) Nil@_+  = substSym+      (List a)+      xs+      Nil@_+      (\(h::List a) -> (===) (List a) (nubBy a eq h) Nil@_)+      p+      Ref@_++lemmaIfFalse (a::Star)+             (b::Bool)+             (th::a)+             (el::a)+             (P::a -> Prop)+             (pb::PredFalse b)+             (pel::P el)+  :: P (if a b th el)+  = case b of {+      (False) -> pel;+      (True) -> case pb of { };}++lemmaNotFalse (b::Bool)(p::PredTrue b) :: PredFalse (not b)+  = case b of {+      (False) -> case p of { };+      (True) -> p;}++cons (a::Star)(x::a)(xs::List a) :: List a+  = Cons@_ x xs++lemmaNubBy (t22::Star)+           (eq::t22 -> t22 -> Bool)+           (hyp::Reflexive t22 eq)+           (x::t22)+  :: (===)+       (Module_Prelude.List t22)+       (nubBy t22 eq (Cons@_ x (Cons@_ x Nil@_)))+       (Cons@_ x Nil@_)+  = NDGoal+      ((===)+         (Module_Prelude.List t22)+         (nubBy t22 eq (Cons@_ x (Cons@_ x Nil@_)))+         (Cons@_ x Nil@_))+      (cong+         (PreludeFromAlfa.List t22)+         (Module_Prelude.List t22)+         (nubBy+            t22+            eq+            (filter t22 (\(y::t22) -> not (eq x y)) (Cons@_ x Nil@_)))+         Nil@_+         (cons t22 x)+         (NDGoal+            ((===)+               (PreludeFromAlfa.List t22)+               (nubBy+                  t22+                  eq+                  (filter t22 (\(y::t22) -> not (eq x y)) (Cons@_ x Nil@_)))+               Nil@_)+            (lemmaNubByNil+               t22+               eq+               (filter t22 (\(y::t22) -> not (eq x y)) (Cons@_ x Nil@_))+               (NDGoal+                  ((===)+                     (List t22)+                     (filter t22 (\(y::t22) -> not (eq x y)) (Cons@_ x Nil@_))+                     Nil@_)+                  (lemmaIfFalse+                     (List t22)+                     (not (eq x x))+                     (Cons@_ x Nil@_)+                     Nil@_+                     (\(h::List t22) -> (===) (List t22) h Nil@_)+                     (NDGoal+                        (PredFalse (not (eq x x)))+                        (lemmaNotFalse+                           (eq x x)+                           (NDGoal (PredTrue (eq x x)) (hyp x))))+                     (NDGoal+                        ((===) (List t22) Nil@_ Nil@_)+                        (refl (List t22) Nil@_)))))))++proofNubByProp :: NubByProp+  = \(t22::Star) ->+    \(eq::(h::t22) -> (h'::t22) -> Module_Prelude.Bool) ->+    ImpliesIntro+      ((x::t22) -> Module_Prelude.PredTrue (eq x x))+      ((x::t22) ->+       (===)+         (Module_Prelude.List t22)+         (Module_List.nubBy t22 eq (Cons@_ x (Cons@_ x Nil@_)))+         (Cons@_ x Nil@_))+      (lemmaNubBy t22 eq)++proofNubProp :: NubProp+  = \(t31::Star) ->+    \(d34::Module_Prelude.Eq t31) ->+    \(x::t31) ->+    ImpliesIntro+      ((x'::t31) ->+       Module_Prelude.PredTrue+         (Module_Prelude.(==) t31 d34 (Module_Prelude.asTypeOf t31 x' x) x'))+      ((===)+         (Module_Prelude.List t31)+         (Module_List.nub t31 d34 (Cons@_ x (Cons@_ x Nil@_)))+         (Cons@_ x Nil@_))+      (\(hyp::(x'::t31) ->+              Module_Prelude.PredTrue+                (Module_Prelude.(==)+                   t31+                   d34+                   (Module_Prelude.asTypeOf t31 x' x)+                   x')) ->+       lemmaNubBy t31 (t31 == d34) hyp x)+{-# Alfa unfoldgoals on+brief on+hidetypeannots on+wide++nd+hiding on+var "lemma" hide 1+var "cons" hide 1+var "NubByNil" hide 3+var "proofNubByNil" hide 3+var "lemmaIfFalse" hide 5+var "lemmaNotFalse" hide 1+ #-}
+ tools/hs2alfa/tests/Logic.alfa view
@@ -0,0 +1,70 @@+--#include "Alfa/Types.alfa"++--#include "Alfa/PropositionalCalculus.alfa"++--#include "Alfa/PredicateCalculus.alfa"++--#include "Alfa/Identity.alfa"++package Logic where+  public open Propositions+          use  Prop,  Absurdity,  AbsurdityElim,  Triviality,  TrivialityIntro,+               Pred,  Rel,  NDGoal,  IsTrue+  public open Propositional+          use  And,  AndIntro,  AndElim1,  AndElim2,  AndElimCont,  Or,+               OrIntro1,  OrIntro2,  OrElim,  Implies,  ImpliesIntro,+               ImpliesElim,  Not,  NotElim,  Equivalence+  public open PredicateCalculus+          use  ForAll,  ForAllI,  ForAllElim,  Exists,  ExistsIntro,+               ExistsElim+  public open Identity+          use  refl,  subst,  substSym,  sym,  trans,  cong,  cong2,  cong1+  (===) :: (A::Set) -> (a::A) -> (b::A) -> Set+    = Identity.(==)+{-# Alfa unfoldgoals off+brief on+hidetypeannots off+wide++nd+hiding on+var "NDGoal" proofgoal+var "Absurdity" as "^" with symbolfont+var "AbsurditElim" hide 1+var "AbsurdityElim" hide 1 as "^E" with symbolfont+var "Triviality" as "T" with symbolfont+var "TrivialityIntro" as "TI" with symbolfont+var "And" infix 3 as "Ù" with symbolfont+var "AndIntro" hide 2 as "ÙI" with symbolfont+var "AndElim1" hide 2 as "ÙE1" with symbolfont+var "AndElim2" hide 2 as "ÙE2" with symbolfont+var "Or" infix 2 as "Ú" with symbolfont+var "OrIntro1" hide 2 as "ÚI1" with symbolfont+var "OrIntro2" hide 2 as "ÚI2" with symbolfont+var "OrElim" hide 3 as "ÚE" with symbolfont+var "Implies" infix rightassoc 1 as "®" with symbolfont+var "ImpliesIntro" hide 2 as "®I" with symbolfont+var "ImpliesElim" hide 2 as "®E" with symbolfont+var "Equivalence" infix 1 as "«" with symbolfont+var "Not" as "Ø" with symbolfont+con "AndI" infix 3 as "ÙI" with symbolfont+var "AndElimCont" hide 3 as "ÙE+" with symbolfont+var "NotElim" hide 1 as "ØE" with symbolfont+var "ForAll" hide 1 quantifier domain on as "\"" with symbolfont+var "ForAllI" hide 2 as "\"I" with symbolfont+var "ForAllElim" hide 3 as "\"E" with symbolfont+var "Exists" hide 1 quantifier domain on as "$" with symbolfont+var "ExistsIntro" hide 2 as "$I" with symbolfont+var "ExistsElim" hide 3 as "$E" with symbolfont+con "existsI" as "$I" with symbolfont+con "forallI" as "\"I" with symbolfont+var "===" distfix3 4+var "refl" hide 2+var "subst" hide 3+var "substSym" hide 3+var "sym" hide 3+var "trans" hide 4+var "cong" hide 4+var "cong2" hide 7+var "cong1" hide 6+ #-}
+ tools/hs2alfa/tests/Maybe.hs view
@@ -0,0 +1,40 @@+module Maybe(+    isJust, isNothing,+    fromJust, fromMaybe, listToMaybe, maybeToList,+    catMaybes, mapMaybe,++    -- ...and what the Prelude exports+    Maybe(Nothing, Just),+    maybe+  ) where+import Prelude --(Maybe(..))++isJust                 :: Maybe a -> Bool+isJust (Just a)        =  True+isJust Nothing         =  False++isNothing        :: Maybe a -> Bool+isNothing        =  not . isJust++fromJust               :: Maybe a -> a+fromJust (Just a)      =  a+fromJust Nothing       =  error "Maybe.fromJust: Nothing"++fromMaybe              :: a -> Maybe a -> a+fromMaybe d Nothing    =  d+fromMaybe d (Just a)   =  a++maybeToList            :: Maybe a -> [a]+maybeToList Nothing    =  []+maybeToList (Just a)   =  [a]++listToMaybe            :: [a] -> Maybe a+listToMaybe []         =  Nothing+listToMaybe (a:_)      =  Just a+ +catMaybes              :: [Maybe a] -> [a]+catMaybes ms           =  [ m | Just m <- ms ]++mapMaybe               :: (a -> Maybe b) -> [a] -> [b]+mapMaybe f             =  catMaybes . map f+
+ tools/hs2alfa/tests/Prelude.hs view
@@ -0,0 +1,336 @@+module Prelude(module Prelude,module PreludeText,module PreludeList) where+import PreludeText+import PreludeList++infixr 5 :+infixr 0 $+infixr 9 .++-- For the P-Logic extension:+data Prop+--type Pred a = a->Prop++(f . g) x = f (g x)+id x = x+const x y = x+flip f x y = f y x+f $ x = f x++asTypeOf :: a->a->a+asTypeOf x = const x++data Char+data Integer+data Int+data Float+data Double++data IO a+instance Functor IO+instance Monad IO++foreign import putStr :: String -> IO ()+putStrLn s = putStr s >> putStr "\n"+print x = putStrLn (show x)++foreign import primSeq :: a -> b -> b+seq = primSeq++foreign import primError :: String -> a+error = primError+undefined = error "undefined"++type String = [Char]+data [] a = [] | a : [a] deriving (Eq,Ord)+data () = () deriving (Eq,Ord,Show)+data (,) a b = (,) a b deriving (Eq,Ord,Show)+data  (,,) a b c =  (,,) a b c +data  (,,,) a b c d =  (,,,) a b c d+data  (,,,,) a b c d e =  (,,,,) a b c d e+data  (,,,,,) a b c d e f =  (,,,,,) a b c d e f+data  (,,,,,,) a b c d e f g =  (,,,,,,) a b c d e f g+data  (,,,,,,,) a b c d e f g h =  (,,,,,,,) a b c d e f g h+++data Bool = False | True deriving (Eq,Ord,Bounded,Show)+data Maybe a = Nothing | Just a deriving (Eq,Ord)+data Either a b = Left a | Right b deriving (Eq)++not b = if b then False else True++class Functor f where+  fmap :: (a->b)->f a->f b++infixl 1 >>, >>=++class Monad m where+  return :: a -> m a+  (>>=) :: m a -> (a -> m b) -> m b+  (>>) :: m a -> m b -> m b+  fail :: String -> m a++  fail = error+  m1>>m2 = m1>>=const m2++sequence :: Monad m => [m a] -> m [a]+sequence+    = foldr mcons (return [])+  where+      mcons p q+	  = p >>= (\ x -> q >>= (\ y -> return (x : y)))+ +mapM :: Monad m => (a -> m b) -> [a] -> m [b]+mapM f as = sequence (map f as)++instance Functor Maybe where+  fmap g m = case m of+	       Nothing -> Nothing+	       Just x -> Just (g x)++instance Monad Maybe where+  Just x >>= f = f x+  Nothing >>= _ = Nothing+  return x = Just x+  fail _ = Nothing+  --m1>>m2 =m1>>=const m2++instance Functor [] where fmap = map++maybe n j Nothing = n+maybe n j (Just x) = j x++class (Eq a,Show a) => Num a where+  (+),(-),(*) :: a -> a -> a+  negate           :: a -> a+  abs, signum      :: a -> a+  fromInteger :: Integer -> a++  x-y=x+negate y+  negate x = 0-x++class  (Num a) => Fractional a  where+    (/)              :: a -> a -> a+    recip            :: a -> a+    fromRational     :: Rational -> a++        -- Minimal complete definition:+        --      fromRational and (recip or (/))+    recip x          =  1 / x+    x / y            =  x * recip y++--even, odd        :: (Integral a) => a -> Bool+even n           =  n `rem` 2 == 0+odd n            =  not (even n)++infixl 6 +++fst (x,y) = x+snd (x,y) = y+++infix 4 ==,/=,<,<=,>=,>++class Eq a where+  (==),(/=) :: a -> a -> Bool++  x/=y = not (x==y)+  x==y = not (x/=y)++class Eq a => Ord a where+    compare :: a -> a -> Ordering+    (<=) :: a -> a -> Bool+    min,max :: a -> a -> a++    min x y  = if x <= y then x else y+    max x y  = if x <= y then y else x++    x<=y = case compare x y of+		 LT -> True+		 EQ -> True+		 GT -> False++data Ordering = LT | EQ | GT deriving (Eq,Ord)+++x>y = not (x<=y)+x>=y = y<=x+x<y = not (x>=y)++lexOrder EQ o = o+lexOrder o _ = o++class Bounded a where minBound,maxBound :: a++class Enum a where+  succ,pred      :: a+  toEnum         :: Int -> a+  fromEnum       :: a -> Int+  enumFrom       :: a -> [a]+  enumFromThen   :: a -> a -> [a]+  enumFromTo     :: a -> a -> [a]+  enumFromThenTo :: a -> a -> a -> [a]++otherwise = True++curry f x y = f (x,y)+uncurry f (x,y) = f x y+++{-+eqList :: Eq a => [a]->[a]->Bool+[] `eqList` [] = True+(x:xs) `eqList` (y:ys) = (x==y) && (xs `eqList` ys)+_ `eqList` _ = False+--}+{-+instance Eq a => Eq [a] where+  --(==) = eqLista+  [] == [] = True+  (x:xs) == (y:ys) = (x==y) && (xs == ys)+  _ == _ = False+-}+--------------------------------------------------------------------------------+foreign import primIntegerEq :: Integer -> Integer -> Bool+foreign import primIntegerLte :: Integer -> Integer -> Bool+foreign import primIntegerAdd :: Integer -> Integer -> Integer+foreign import primIntegerNegate :: Integer -> Integer+foreign import primIntegerSignum :: Integer -> Integer+foreign import primIntegerAbs :: Integer -> Integer++instance Eq Integer where (==) = primIntegerEq++instance Ord Integer where (<=) = primIntegerLte+instance Num Integer where+  (+) = primIntegerAdd+  fromInteger = id+  negate = primIntegerNegate+  abs = primIntegerAbs+  signum = primIntegerSignum++instance Show Integer where show=undefined+instance Enum Integer++--------------------------------------------------------------------------------+foreign import primIntEq :: Int -> Int -> Bool+foreign import primInteger2Int :: Integer -> Int+foreign import primIntAdd :: Int -> Int -> Int+foreign import primIntNegate :: Int -> Int+foreign import primIntSignum :: Int -> Int+foreign import primIntAbs :: Int -> Int++instance Eq Int where (==) = primIntEq++instance Ord Int+instance Show Int++instance Num Int where+  (+) = primIntAdd+  negate = primIntNegate+  abs = primIntAbs+  signum = primIntSignum+  fromInteger = primInteger2Int++--------------------------------------------------------------------------------++instance Eq Char+instance Num Float+instance Show Float+instance Eq Float+instance Show Double+instance Num Double+instance Ord Double+instance Eq Double+instance Enum Int++instance Fractional Float+instance Fractional Double++--instance (Eq a,Eq b) => Eq (a,b) where+--  (a1,b1) == (a2,b2) = a1==a2 && b1==b2++infixr 3 &&+True && b = b+_ && _ = False++infixr 2 ||+False || b = b+_ || _ = True+++------++data  (Integral a)      => Ratio a = !a :% !a  deriving (Eq)+type  Rational          =  Ratio Integer++class  (Real a, Enum a) => Integral a  where+    quot, rem        :: a -> a -> a+    div, mod         :: a -> a -> a+    quotRem, divMod  :: a -> a -> (a,a)+    toInteger        :: a -> Integer++        -- Minimal complete definition:+        --      quotRem, toInteger+    n `quot` d       =  q  where (q,r) = quotRem n d+    n `rem` d        =  r  where (q,r) = quotRem n d+    n `div` d        =  q  where (q,r) = divMod n d+    n `mod` d        =  r  where (q,r) = divMod n d+    divMod n d       =  if signum r == - signum d then (q-1, r+d) else qr+                        where qr@(q,r) = quotRem n d++class  (Num a, Ord a) => Real a  where+    toRational       ::  a -> Rational++class  (Real a, Fractional a) => RealFrac a  where+    properFraction   :: (Integral b) => a -> (b,a)+    truncate, round  :: (Integral b) => a -> b+    ceiling, floor   :: (Integral b) => a -> b++        -- Minimal complete definition:+        --      properFraction+    truncate x       =  m  where (m,_) = properFraction x++    round x          =  let (n,r) = properFraction x+                            m     = if r < 0 then n - 1 else n + 1+                          in case signum (abs r - 0.5) of+                                -1 -> n+                                0  -> if even n then n else m+                                1  -> m++    ceiling x        =  if r > 0 then n + 1 else n+                        where (n,r) = properFraction x++    floor x          =  if r < 0 then n - 1 else n+                        where (n,r) = properFraction x++class  (Fractional a) => Floating a  where+    pi                  :: a+    exp, log, sqrt      :: a -> a+    (**), logBase       :: a -> a -> a+    sin, cos, tan       :: a -> a+    asin, acos, atan    :: a -> a+    sinh, cosh, tanh    :: a -> a+    asinh, acosh, atanh :: a -> a++        -- Minimal complete definition:+        --      pi, exp, log, sin, cos, sinh, cosh+        --      asin, acos, atan+        --      asinh, acosh, atanh+    x ** y           =  exp (log x * y)+    logBase x y      =  log y / log x+    sqrt x           =  x ** 0.5+    tan  x           =  sin  x / cos  x+    tanh x           =  sinh x / cosh x++fromIntegral     :: (Integral a, Num b) => a -> b+fromIntegral     =  fromInteger . toInteger++instance Integral Integer where+  toInteger = id+  quotRem n d = error "quotRem not implemented yet"++instance Integral Int+instance Real Integer+instance Real Int+--instance Real Double+--instance Floating Double+--instance RealFrac Double
+ tools/hs2alfa/tests/PreludeList.hs view
@@ -0,0 +1,93 @@+module PreludeList where++infixr 5 +++infixl 9  !!+infix 4 `elem`,`notElem`++map f [] = []+map f (x:xs) = f x:map f xs++[]++ys = ys+(x:xs)++ys = x:(xs++ys)++concatMap f = concat . map f++filter p [] = []+filter p (x:xs) = if p x then x:filter p xs else filter p xs++concat = foldr (++) []++null [] = True+null (_:_) = False++head (x:_) = x++tail (_:xs) = xs++foldr f z [] = z+foldr f z (x:xs) = f x (foldr f z xs)++foldl f z [] = z+foldl f z (x:xs) = foldl f (f z x) xs++zip (x:xs) (y:ys) = (x,y):zip xs ys+zip _ _ = []++unzip [] = ([],[])+unzip ((x,y):xys) = case unzip xys of (xs,ys) -> (x:xs,y:ys)+++length :: [a] -> Int+length [] = 0+length (_:xs) = 1+length xs++replicate n x = take n (repeat x)++repeat x = xs where xs = x:xs++take n xs =+  if n<=0+  then []+  else case xs of+         [] -> []+	 x:xs -> x:take (n-1) xs++drop n xs =+  if n<=0+  then xs+  else case xs of+         [] -> []+	 x:xs -> drop (n-1) xs++all p xs = foldr ((&&).p) True xs+any p xs = foldr ((||).p) False xs++x `elem` xs = any (x==) xs+x `notElem` xs = all (x/=) xs++span p xs = (takeWhile p xs,dropWhile p xs)++takeWhile p [] = []+takeWhile p (x:xs) = if p x then x:takeWhile p xs else []++dropWhile p [] = []+dropWhile p (x:xs) = if p x then dropWhile p xs else x:xs++reverse xs = foldl (\ys y->y:ys) [] xs++foldl1 f (x:xs) = foldl f x xs++minimum xs = foldl1 min xs++lookup :: Eq a => a -> [(a,b)] -> Maybe b+lookup x [] = Nothing+lookup x ((x',y):xys) = if x'==x then Just y else lookup x xys++(!!)                :: [a] -> Int -> a+xs !! n = if n<0+          then error "Prelude.!!: negative index"+	  else case xs of+	         [] -> error "Prelude.!!: index too large"+		 x:xs -> if n==0+			 then x+			 else xs!!(n-1)
+ tools/hs2alfa/tests/PreludeProperties.alfa view
@@ -0,0 +1,80 @@+--#include "Prelude.alfa"++--#include "Alfa/PropositionalCalculus.alfa"++package PreludeProperties where+  open Module_Prelude  use  List,  Bool,  Ord,  (<=)+  open Propositional+   use  Prop,  Absurdity,  Triviality,  TrivialityIntro,  Pred,  And,+        ImpliesIntro,  Not+  IsTrue (b::Bool) :: Prop+    = case b of {+        (False) -> Absurdity;+        (True) -> Triviality;}+  IsLte (A::Star)(ordA::Ord A)(x::A)(y::A) :: Prop+    = IsTrue ((<=) A ordA x y)+  AllElems (A::Star)(P::Pred A)(xs::List A) :: Prop+    = case xs of {+        (Nil) -> Triviality;+        (Cons x1 x2) -> And (P x1) (AllElems A P x2);}+  TotalOrder (A::Star)(ordA::Ord A) :: Prop+    = sig {refl :: (a::A) -> IsLte A ordA a a;+           asym ::+             (a1::A) ->+             (a2::A) ->+             Not (IsLte A ordA a1 a2) -> IsLte A ordA a2 a1;+           trans ::+             (a1::A) ->+             (a2::A) ->+             (a3::A) ->+             IsLte A ordA a1 a2 -> IsLte A ordA a2 a3 -> IsLte A ordA a1 a3;}+  trans (A::Star)(ordA::Ord A)(totord::TotalOrder A ordA)+    :: (x::A) ->+       (y::A) ->+       (z::A) ->+       (xy::IsLte A ordA x y) ->+       (yz::IsLte A ordA y z) ->+       IsLte A ordA x z+    = totord.trans+  antisym (A::Star)(ordA::Ord A)(totord::TotalOrder A ordA)+    :: (x::A) ->+       (y::A) ->+       (xy::Not (IsLte A ordA x y)) ->+       IsLte A ordA y x+    = totord.asym+  ifProp (A::Star)+         (cnd::Bool)+         (thn::A)+         (els::A)+         (P::Pred A)+         (pt::IsTrue cnd -> P thn)+         (pf::Not (IsTrue cnd) -> P els)+    :: P (if A cnd thn els)+    = case cnd of {+        (False) ->+          let ndgoal :: P (if A False@_ thn els)+                = pf+                    (let ndgoal :: Not (IsTrue False@_)+                           = ImpliesIntro (IsTrue False@_)+                               Propositions.Absurdity+                               (\(hyp::IsTrue False@_) ->+                                let ndgoal :: Absurdity+                                      = hyp+                                in  ndgoal)+                     in  ndgoal)+          in  ndgoal;+        (True) ->+          let ndgoal :: P (if A True@_ thn els)+                = pt+                    (let ndgoal :: IsTrue True@_+                           = TrivialityIntro+                     in  ndgoal)+          in  ndgoal;}+{-# Alfa hiding on+var "AllElems" hide 1+var "TotalOrder" hide 1+var "ifProp" hide 5+var "IsLte" hide 2 infix 4 as "£" with symbolfont+var "trans" hide 6+var "antisym" hide 5+ #-}
+ tools/hs2alfa/tests/PreludeText.hs view
@@ -0,0 +1,32 @@+module PreludeText where++type ShowS = String->String++class Show a where+  show :: a -> String+  showsPrec :: Int -> a -> ShowS+  showList :: [a] -> ShowS++  showsPrec _ x = showString (show x)++  show x        = showsPrec 0 x ""++  showList []       = showString "[]"+  showList (x:xs)   = showChar '[' . shows x . showl xs+		      where showl []     = showChar ']'+			    showl (x:xs) = showChar ',' . shows x .+					   showl xs++shows            :: (Show a) => a -> ShowS+shows            =  showsPrec 0++showString = (++)+showChar c s = c:s++showParenArg :: Int -> ShowS -> ShowS+showParenArg d = showParen (10<=d)++showParen        :: Bool -> ShowS -> ShowS+showParen b p    =  if b then showChar '(' . p . showChar ')' else p++showArgument x = showChar ' ' . showsPrec 10 x
+ tools/hs2alfa/tests/SPS.hs view
@@ -0,0 +1,57 @@+-- Synchronous stream processors+module SPS where++newtype S i o = S (i->(o,S i o))+feed (S sps) i = sps i+++runS _       []     = []+runS sps (i:is) = continue (feed sps i) is+continue c is = fst c:runS (snd c) is++mapS f = S sps+  where sps i = (f i,S sps)++mapAccumS f s0 = S (sps s0)+  where+    sps s1 i = case f s1 i of+                (s2,o) -> (o,S (sps s2))++--(>*<) :: S i1 o1 -> S i2 o2 -> S (i1,i2) (o1,o2)+sps1 >*< sps2 = S sps+  where+    sps (i1,i2) = ((fst o1,fst o2),snd o1>*<snd o2)+       where o1 = feed sps1 i1+	     o2 = feed sps2 i2++(>+<) :: S i1 o1 -> S i2 o2 -> S (Either i1 i2) (Either o1 o2)+sps1 >+< sps2 = S sps+  where+    sps (Left  i1) = (Left  o1,sps1'>+<sps2) where (o1,sps1') = feed sps1 i1+    sps (Right i2) = (Right o2,sps1>+<sps2') where (o2,sps2') = feed sps2 i2++sps1 -<- sps2 = S sps+  where+    sps i2 = (o1,sps1'-<-sps2')+     where+       (o2,sps2') = feed sps2 i2+       (o1,sps1') = feed sps1 o2++assert Separation1 = {-#cert:Separation1#-}+  All sps1 . All sps2 . All is1 . All is2 .+  {runS (sps1>*<sps2) (zip is1 is2)} === {zip (runS sps1 is1) (runS sps2 is2)}+--{-+assert Separation2 =+  All sps1a . All sps1b . All sps2a . All sps2b .+  {(sps1a>*<sps1b)-<-(sps2a>*<sps2b)}===+  {(sps1a-<-sps2a)>*<(sps1b-<-sps2b)}+--}++assert Separation3 =+  All sps1 . All sps2 . All is .+  {split (runS (sps1>+<sps2) is)} ===+    {(runS sps1 (lefts is),runS sps2 (rights is))}++split zs = (lefts zs,rights zs)+lefts zs = [x|Left x<-zs]+rights zs = [y|Right y<-zs]
+ tools/hs2alfa/tests/SPSproof.alfa view
@@ -0,0 +1,183 @@+--#include "alfa/SPS.alfa"++open Module_Prelude+ use  List,  Tuple2,  unzip,  zip,  fst,  snd,  undefined++open Logic+ use  Prop,  Pred,  Rel,  Absurdity,  AbsurdityElim,  Triviality,+      TrivialityIntro,  NDGoal,  And,  AndIntro,  AndElim1,  AndElim2,+      AndElimCont,  Or,  OrIntro1,  OrIntro2,  OrElim,  Implies,+      ImpliesIntro,  ImpliesElim,  Not,  NotElim,  Equivalence,+      ForAll,  ForAllI,  ForAllElim,  Exists,  ExistsIntro,+      ExistsElim,  IsTrue,  (===),  refl,  subst,  substSym,  sym,+      trans,  cong,  cong2,  cong1++open Module_SPS+ use  S,  runS,  mapS,  mapAccumS,  (>*<),  Separation1,  feed,+      continue++separationLemma (i1::Star)+                (o1::Star)+                (i2::Star)+                (o2::Star)+                (sps1::S i1 o1)+                (sps2::S i2 o2)+                (is1::List i1)+                (is2::List i2)+  :: (===)+       (List (Tuple2 o1 o2))+       (runS+          (Tuple2 i1 i2)+          (Tuple2 o1 o2)+          ((>*<) i1 o1 i2 o2 sps1 sps2)+          (zip i1 i2 is1 is2))+       (zip o1 o2 (runS i1 o1 sps1 is1) (runS i2 o2 sps2 is2))+  = case is1 of {+      (Nil) ->+        let ndgoal+              :: (===)+                   (List (Tuple2 o1 o2))+                   (runS+                      (Tuple2 i1 i2)+                      (Tuple2 o1 o2)+                      ((>*<) i1 o1 i2 o2 sps1 sps2)+                      (zip i1 i2 Nil@_ is2))+                   (zip o1 o2 (runS i1 o1 sps1 Nil@_) (runS i2 o2 sps2 is2))+              = refl+                  (List (Tuple2 o1 o2))+                  (runS+                     (Tuple2 i1 i2)+                     (Tuple2 o1 o2)+                     ((>*<) i1 o1 i2 o2 sps1 sps2)+                     (zip i1 i2 Nil@_ is2))+        in  ndgoal;+      (Cons x xs) ->+        case is2 of {+          (Nil) ->+            let ndgoal+                  :: (===)+                       (List (Tuple2 o1 o2))+                       (runS+                          (Tuple2 i1 i2)+                          (Tuple2 o1 o2)+                          ((>*<) i1 o1 i2 o2 sps1 sps2)+                          (zip i1 i2 (Cons@_ x xs) Nil@_))+                       (zip+                          o1+                          o2+                          (runS i1 o1 sps1 (Cons@_ x xs))+                          (runS i2 o2 sps2 Nil@_))+                  = refl+                      (List (Tuple2 o1 o2))+                      (runS+                         (Tuple2 i1 i2)+                         (Tuple2 o1 o2)+                         ((>*<) i1 o1 i2 o2 sps1 sps2)+                         (zip i1 i2 (Cons@_ x xs) Nil@_))+            in  ndgoal;+          (Cons x' xs') ->+            case sps1 of {+              (S sps1') ->+                case sps2 of {+                  (S sps2') ->+                    let it+                          :: (===)+                               (List (Tuple2 o1 o2))+                               (runS+                                  (Tuple2 i1 i2)+                                  (Tuple2 o1 o2)+                                  ((>*<) i1 o1 i2 o2 (S@_ sps1') (S@_ sps2'))+                                  (zip i1 i2 (Cons@_ x xs) (Cons@_ x' xs')))+                               (zip+                                  o1+                                  o2+                                  (runS i1 o1 (S@_ sps1') (Cons@_ x xs))+                                  (runS i2 o2 (S@_ sps2') (Cons@_ x' xs')))+                          = let c1 = sps1' x+                                c2 = sps2' x'+                                indhyp+                                  :: (===)+                                       (Module_Prelude.List (Tuple2 o1 o2))+                                       (runS+                                          (Tuple2 i1 i2)+                                          (Tuple2 o1 o2)+                                          ((>*<)+                                             i1+                                             o1+                                             i2+                                             o2+                                             (snd o1 (S i1 o1) c1)+                                             (snd o2 (S i2 o2) c2))+                                          (zip i1 i2 xs xs'))+                                       (zip+                                          o1+                                          o2+                                          (runS i1 o1 (snd o1 (S i1 o1) c1) xs)+                                          (runS i2 o2 (snd o2 (S i2 o2) c2) xs'))+                                  = separationLemma+                                      i1+                                      o1+                                      i2+                                      o2+                                      (snd o1 (S i1 o1) c1)+                                      (snd o2 (S i2 o2) c2)+                                      xs+                                      xs'+                            in  cong2+                                  (Tuple2 o1 o2)+                                  (Module_Prelude.List (Tuple2 o1 o2))+                                  (List (Tuple2 o1 o2))+                                  (Tuple2@_+                                     (Module_Prelude.fst o1 (S i1 o1) (sps1' x))+                                     (Module_Prelude.fst o2 (S i2 o2) (sps2' x')))+                                  (runS+                                     (Tuple2 i1 i2)+                                     (Tuple2 o1 o2)+                                     ((>*<)+                                        i1+                                        o1+                                        i2+                                        o2+                                        (snd o1 (S i1 o1) c1)+                                        (snd o2 (S i2 o2) c2))+                                     (zip i1 i2 xs xs'))+                                  (Tuple2@_+                                     (Module_Prelude.fst o1 (S i1 o1) (sps1' x))+                                     (Module_Prelude.fst o2 (S i2 o2) (sps2' x')))+                                  (zip+                                     o1+                                     o2+                                     (runS i1 o1 (snd o1 (S i1 o1) c1) xs)+                                     (runS i2 o2 (snd o2 (S i2 o2) c2) xs'))+                                  (\(h::Tuple2 o1 o2) ->+                                   \(h'::Module_Prelude.List (Tuple2 o1 o2)) ->+                                   Cons@_ h h')+                                  (refl+                                     (Tuple2 o1 o2)+                                     (Tuple2@_+                                        (Module_Prelude.fst+                                           o1+                                           (S i1 o1)+                                           (sps1' x))+                                        (Module_Prelude.fst+                                           o2+                                           (S i2 o2)+                                           (sps2' x'))))+                                  indhyp+                    in  it;};};};}++separationProof :: Separation1+  = separationLemma+{-# Alfa unfoldgoals on+brief on+hidetypeannots off+wide++topdown+hiding on+var "separationLemma" hide 4+var "parFeedLemma" hide 4+var "fstEq" hide 4+var "sndEq" hide 4+var "ForAllI2" hide 3 as "\"I2" with symbolfont+ #-}
+ tools/hs2alfa/tests/Sort.hs view
@@ -0,0 +1,13 @@+module Sort where++--insert :: Ord a => a -> [a] -> [a]+insert x [] = [x]+insert x (y:ys) = if x<=y+		  then x:y:ys+		  else y:insert x ys++--sort :: Ord a => [a] -> [a]+sort [] = []+sort (x:xs) = insert x (sort xs)++isort xs = foldr insert [] xs
+ tools/hs2alfa/tests/SortProofs.alfa view
@@ -0,0 +1,53 @@+--#include "SortProps.alfa"++--#include "Haskell.alfa"++open Module_Prelude  use  Int++open Module_SortProps  use  S0,  S1,  S2++open Module_Sort  use  insert,  sort++open Identity+ use  (==),  refl,  subst,  sym,  trans,  cong,  cong2,  cong1++proof0 :: S0+  = \(t8::Star) ->+    \(d7::Module_Prelude.Ord t8) ->+    let ndgoal :: IsNil t8 (sort t8 d7 Nil@_)+          = TrivialityIntro+    in  ndgoal++proof1 :: S1+  = \(t11::Star) ->+    \(d13::Module_Prelude.Ord t11) ->+    \(x::t11) ->+    let ndgoal+          :: Identical (Module_Prelude.List t11) (sort t11 d13 (Cons@_ x Nil@_))+               (Cons@_ x Nil@_)+          = refl (Module_Prelude.List t11) (sort t11 d13 (Cons@_ x Nil@_))+    in  ndgoal++proof2 :: S2+  = \(t16::Star) ->+    \(d18::Module_Prelude.Ord t16) ->+    \(x1::t16) ->+    \(x2::t16) ->+    let ndgoal+          :: Or+               (Identical (Module_Prelude.List t16)+                  (sort t16 d18 (Cons@_ x1 (Cons@_ x2 Nil@_)))+                  (Cons@_ x1 (Cons@_ x2 Nil@_)))+               (Identical (Module_Prelude.List t16)+                  (sort t16 d18 (Cons@_ x1 (Cons@_ x2 Nil@_)))+                  (Cons@_ x2 (Cons@_ x1 Nil@_)))+          = ?+    in  ndgoal+{-# Alfa unfoldgoals off+brief on+hidetypeannots off+wide++nd+hiding on+ #-}
+ tools/hs2alfa/tests/SortProperties.alfa view
@@ -0,0 +1,320 @@+--#include "Sort.alfa"++--#include "Alfa/PropositionalCalculus.alfa"++--#include "PreludeProperties.alfa"++{- Error: Error in the definition of LteAllTrans because:+Type does not contain constructor: List A in :-}++package SortProperties where+  open Propositional+   use  Prop,  Absurdity,  AbsurdityElim,  Triviality,  TrivialityIntro,+        Pred,  And,  AndIntro,  AndElimCont,  Implies,  ImpliesIntro,+        ImpliesElim,  Not+  open Module_Sort  use  insert,  sort+  open Module_Prelude  use  List,  Bool,  Ord,  (<=)+  open PreludeProperties+   use  IsTrue,  AllElems,  TotalOrder,  ifProp,  IsLte,  trans,+        antisym+  -- The property that x is less than or equal to all elements of the list xs:+  LteAll (A::Star)(ordA::Ord A)(x::A)(xs::List A) :: Prop+    = AllElems A (IsLte A ordA x) xs+  -- The property that a lists is ordered:+  IsOrdered (A::Star)(ordA::Ord A)(xs::List A) :: Prop+    = case xs of {+        (Nil) -> Triviality;+        (Cons x1 xs') -> And (LteAll A ordA x1 xs') (IsOrdered A ordA xs');}+  -- If x1<=x2 and x2 is lte all elements of xs then x1 is lte all elements of xs:+  LteAllTrans (A::Star)+              (ordA::Ord A)+              (x1::A)+              (x2::A)+              (xs::List A)+              (totord::TotalOrder A ordA)+              (lt1::IsLte A ordA x1 x2)+              (lta::LteAll A ordA x2 xs)+    :: LteAll A ordA x1 xs+    = case xs of {+        (Nil) ->+          let ndgoal :: LteAll A ordA x1 Nil@_+                = TrivialityIntro+          in  ndgoal;+        (Cons x1' x2') ->+          let ndgoal :: LteAll A ordA x1 (Cons@_ x1' x2')+                = AndElimCont (IsLte A ordA x2 x1')+                    (AllElems A (IsLte A ordA x2) x2')+                    (LteAll A ordA x1 (Cons@_ x1' x2'))+                    (let ndgoal+                           :: And (IsLte A ordA x2 x1')+                                (AllElems A (IsLte A ordA x2) x2')+                           = lta+                     in  ndgoal)+                    (\(a::IsLte A ordA x2 x1') ->+                     \(b::AllElems A (IsLte A ordA x2) x2') ->+                     let ndgoal :: LteAll A ordA x1 (Cons@_ x1' x2')+                           = AndIntro (IsLte A ordA x1 x1')+                               (AllElems A (IsLte A ordA x1) x2')+                               (let ndgoal :: IsLte A ordA x1 x1'+                                      = trans A ordA totord x1 x2 x1'+                                          (let ndgoal :: IsLte A ordA x1 x2+                                                 = lt1+                                           in  ndgoal)+                                          (let ndgoal :: IsLte A ordA x2 x1'+                                                 = a+                                           in  ndgoal)+                                in  ndgoal)+                               (let ndgoal :: AllElems A (IsLte A ordA x1) x2'+                                      = LteAllTrans A ordA x1 x2 x2' totord+                                          (let ndgoal :: IsLte A ordA x1 x2+                                                 = lt1+                                           in  ndgoal)+                                          (let ndgoal :: LteAll A ordA x2 x2'+                                                 = b+                                           in  ndgoal)+                                in  ndgoal)+                     in  ndgoal)+          in  ndgoal;}+  -- If x1 is lte x2 and x2 is lte all elements of xs, then x1 is lte all elements of x2:xs+  LteFirst (A::Star)+           (ordA::Ord A)+           (x1::A)+           (x2::A)+           (xs::List A)+           (totord::TotalOrder A ordA)+           (x1p::IsLte A ordA x1 x2)+           (x2p::LteAll A ordA x2 xs)+    :: LteAll A ordA x1 (Cons@_ x2 xs)+    = let ndgoal :: LteAll A ordA x1 (Cons@_ x2 xs)+            = AndIntro (IsLte A ordA x1 x2) (AllElems A (IsLte A ordA x1) xs)+                (let ndgoal :: IsLte A ordA x1 x2+                       = x1p+                 in  ndgoal)+                (let ndgoal :: LteAll A ordA x1 xs+                       = LteAllTrans A ordA x1 x2 xs totord+                           (let ndgoal :: IsLte A ordA x1 x2+                                  = x1p+                            in  ndgoal)+                           (let ndgoal :: LteAll A ordA x2 xs+                                  = x2p+                            in  ndgoal)+                 in  ndgoal)+      in  ndgoal+  insertLemma (A::Star)+              (ordA::Ord A)+              (x1::A)+              (x2::A)+              (xs::List A)+              (x1x2::IsLte A ordA x1 x2)+              (x1xs::LteAll A ordA x1 xs)+    :: LteAll A ordA x1 (insert A ordA x2 xs)+    = case xs of {+        (Nil) ->+          let ndgoal :: LteAll A ordA x1 (insert A ordA x2 Nil@_)+                = AndIntro (IsLte A ordA x1 x2)+                    (AllElems A (IsLte A ordA x1) Nil@_)+                    (let ndgoal :: IsLte A ordA x1 x2+                           = x1x2+                     in  ndgoal)+                    (let ndgoal :: AllElems A (IsLte A ordA x1) Nil@_+                           = TrivialityIntro+                     in  ndgoal)+          in  ndgoal;+        (Cons x1' x2') ->+          let ndgoal :: LteAll A ordA x1 (insert A ordA x2 (Cons@_ x1' x2'))+                = ifProp (List A) ((<=) A ordA x2 x1')+                    (Cons@_ x2 (Cons@_ x1' x2'))+                    (Cons@_ x1' (insert A ordA x2 x2'))+                    (\(h::List A) -> LteAll A ordA x1 h)+                    (\(h::IsLte A ordA x2 x1') ->+                     let ndgoal :: LteAll A ordA x1 (Cons@_ x2 (Cons@_ x1' x2'))+                           = AndIntro (IsLte A ordA x1 x2)+                               (AllElems A (IsLte A ordA x1) (Cons@_ x1' x2'))+                               (let ndgoal :: IsLte A ordA x1 x2+                                      = x1x2+                                in  ndgoal)+                               (let ndgoal+                                      :: AllElems A (IsLte A ordA x1)+                                           (Cons@_ x1' x2')+                                      = x1xs+                                in  ndgoal)+                     in  ndgoal)+                    (\(h::Not (IsLte A ordA x2 x1')) ->+                     let ndgoal+                           :: LteAll A ordA x1+                                (Cons@_ x1' (insert A ordA x2 x2'))+                           = AndElimCont (IsLte A ordA x1 x1')+                               (AllElems A (IsLte A ordA x1) x2')+                               (LteAll A ordA x1+                                  (Cons@_ x1' (insert A ordA x2 x2')))+                               (let ndgoal+                                      :: And (IsLte A ordA x1 x1')+                                           (AllElems A (IsLte A ordA x1) x2')+                                      = x1xs+                                in  ndgoal)+                               (\(a::IsLte A ordA x1 x1') ->+                                \(b::AllElems A (IsLte A ordA x1) x2') ->+                                let ndgoal+                                      :: LteAll A ordA x1+                                           (Cons@_ x1' (insert A ordA x2 x2'))+                                      = AndIntro (IsLte A ordA x1 x1')+                                          (AllElems A (IsLte A ordA x1)+                                             (insert A ordA x2 x2'))+                                          (let ndgoal :: IsLte A ordA x1 x1'+                                                 = a+                                           in  ndgoal)+                                          (let ndgoal+                                                 :: AllElems A (IsLte A ordA x1)+                                                      (insert A ordA x2 x2')+                                                 = insertLemma A ordA x1 x2 x2'+                                                     (let ndgoal+                                                            :: IsLte A ordA x1+                                                                 x2+                                                            = x1x2+                                                      in  ndgoal)+                                                     (let ndgoal+                                                            :: LteAll A ordA x1+                                                                 x2'+                                                            = b+                                                      in  ndgoal)+                                           in  ndgoal)+                                in  ndgoal)+                     in  ndgoal)+          in  ndgoal;}+  -- Inserting an element in an ordered lists yields and ordered list:+  insertProp (A::Star)+             (ordA::Ord A)+             (totord::TotalOrder A ordA)+             (x::A)+             (xs::List A)+             (pxs::IsOrdered A ordA xs)+    :: IsOrdered A ordA (insert A ordA x xs)+    = case xs of {+        (Nil) ->+          let ndgoal :: IsOrdered A ordA (insert A ordA x Nil@_)+                = AndIntro (LteAll A ordA x Nil@_) (IsOrdered A ordA Nil@_)+                    (let ndgoal :: LteAll A ordA x Nil@_+                           = TrivialityIntro+                     in  ndgoal)+                    (let ndgoal :: IsOrdered A ordA Nil@_+                           = TrivialityIntro+                     in  ndgoal)+          in  ndgoal;+        (Cons x1 x2) ->+          let ndgoal :: IsOrdered A ordA (insert A ordA x (Cons@_ x1 x2))+                = AndElimCont (LteAll A ordA x1 x2) (IsOrdered A ordA x2)+                    (IsOrdered A ordA (insert A ordA x (Cons@_ x1 x2)))+                    (let ndgoal+                           :: And (LteAll A ordA x1 x2) (IsOrdered A ordA x2)+                           = pxs+                     in  ndgoal)+                    (\(a::LteAll A ordA x1 x2) ->+                     \(b::IsOrdered A ordA x2) ->+                     let ndgoal+                           :: IsOrdered A ordA (insert A ordA x (Cons@_ x1 x2))+                           = ifProp (List A) ((<=) A ordA x x1)+                               (Cons@_ x (Cons@_ x1 x2))+                               (Cons@_ x1 (insert A ordA x x2))+                               (\(h::List A) -> IsOrdered A ordA h)+                               (\(h::IsLte A ordA x x1) ->+                                let ndgoal+                                      :: IsOrdered A ordA+                                           (Cons@_ x (Cons@_ x1 x2))+                                      = AndIntro (LteAll A ordA x (Cons@_ x1 x2))+                                          (IsOrdered A ordA (Cons@_ x1 x2))+                                          (let ndgoal+                                                 :: LteAll A ordA x+                                                      (Cons@_ x1 x2)+                                                 = LteFirst A ordA x x1 x2+                                                     totord+                                                     (let ndgoal+                                                            :: IsLte A ordA x x1+                                                            = h+                                                      in  ndgoal)+                                                     (let ndgoal+                                                            :: LteAll A ordA x1+                                                                 x2+                                                            = a+                                                      in  ndgoal)+                                           in  ndgoal)+                                          (let ndgoal+                                                 :: IsOrdered A ordA+                                                      (Cons@_ x1 x2)+                                                 = pxs+                                           in  ndgoal)+                                in  ndgoal)+                               (\(h::Not (IsLte A ordA x x1)) ->+                                let ndgoal+                                      :: IsOrdered A ordA+                                           (Cons@_ x1 (insert A ordA x x2))+                                      = AndIntro+                                          (LteAll A ordA x1 (insert A ordA x x2))+                                          (IsOrdered A ordA (insert A ordA x x2))+                                          (let ndgoal+                                                 :: LteAll A ordA x1+                                                      (insert A ordA x x2)+                                                 = insertLemma A ordA x1 x x2+                                                     (let ndgoal+                                                            :: IsLte A ordA x1 x+                                                            = antisym A ordA+                                                                totord+                                                                x+                                                                x1+                                                                (let ndgoal+                                                                       :: Not+                                                                            (IsLte+                                                                               A+                                                                               ordA+                                                                               x+                                                                               x1)+                                                                       = h+                                                                 in  ndgoal)+                                                      in  ndgoal)+                                                     (let ndgoal+                                                            :: LteAll A ordA x1+                                                                 x2+                                                            = a+                                                      in  ndgoal)+                                           in  ndgoal)+                                          (let ndgoal+                                                 :: IsOrdered A ordA+                                                      (insert A ordA x x2)+                                                 = insertProp A ordA totord x x2+                                                     (let ndgoal+                                                            :: IsOrdered A ordA+                                                                 x2+                                                            = b+                                                      in  ndgoal)+                                           in  ndgoal)+                                in  ndgoal)+                     in  ndgoal)+          in  ndgoal;}+  -- The output of the sort function is an ordered list:+  sortProp (A::Star)(ordA::Ord A)(totord::TotalOrder A ordA)(xs::List A)+    :: IsOrdered A ordA (sort A ordA xs)+    = case xs of {+        (Nil) ->+          let ndgoal :: IsOrdered A ordA (sort A ordA Nil@_)+                = TrivialityIntro+          in  ndgoal;+        (Cons x1 x2) ->+          let ndgoal :: IsOrdered A ordA (sort A ordA (Cons@_ x1 x2))+                = insertProp A ordA totord x1 (sort A ordA x2)+                    (sortProp A ordA totord x2)+          in  ndgoal;}++{-# GF  Eng IsOrdered A ordA xs = mkSent (xs.s!pnv++["is ordered by"]++ordA.s!pnv)  #-}++{-# Alfa hiding on+var "IsOrderedCons" hide 2+var "IsOrdered" hide 2+var "ifProp" hide 5+var "AllElems" hide 1+var "LteAll" hide 2+var "LteFirst" hide 6+var "insertProp" hide 5+var "insertLemma" hide 5+var "AntiSymmetry" hide 1+var "LteAllTrans" hide 6+var "sortProp" hide 3+ #-}
+ tools/hs2alfa/tests/SortProps.hs view
@@ -0,0 +1,39 @@+module SortProps where+import Sort++assert S0 = {sort []} ::: []++assert S1 = All x . {sort [x]} === {[x]}++assert S2 = All x1 . All x2 . {sort [x1,x2]} === {[x1,x2]}+                           \/ {sort [x1,x2]} === {[x2,x1]}++--assert S = S0 /\ S1 /\ S2++ordered [] = True+ordered [x] = True+ordered (x1:x2:xs) = x1<=x2 && ordered (x2:xs)++lteAll x = all (x<=)++orderedInt :: [Int] -> Bool+orderedInt = ordered ++--property IsTrue = {| x | x===True |}+--property IsOrdered = {|xs | IsTrue {orderedInt xs} |}++property IsOrdered = !ordered++assert InsertProp = All x . All xs . IsOrdered xs ==> IsOrdered {insert x xs}++assert SortProp1 = All xs . IsOrdered {sort xs}++property AllElems P = Gfp X . [] \/ P:X++property Minimal x = AllElems (!((x::Int)<=))++property Or1 P Q = {| x | (x:::P) \/ (x:::Q) |}+property Or2 P Q = P \/ Q++property IsOrdered2 =+   Lfp X . {| xs | (xs:::[]) \/ (Minimal {head xs} xs /\ ({tail xs}:::X)) |}
+ tools/hs2alfa/tests/Test0.hs view
@@ -0,0 +1,64 @@+module Test0 where+import Prelude hiding (length,even,odd)++-- Testing literals:+t = 'T'+hello = "Hello, world!"++--answer :: Num a => a+--answer = 42++n = Nothing++tr = True+fa = False++data Nat = Zero | Succ Nat deriving (Eq)++add Zero b = b+add (Succ n) b = Succ (add n b)+++length xs = case xs of+              [] -> Zero+	      (x:xs) -> Succ (length xs)++z = length []+sz = Succ z++assert A1 = {length []} === {Zero}+assert A2 = z === {Zero}++even Zero = True+even (Succ n) = odd n++odd Zero = Prelude.False+odd (Succ n) = even n++data Tree a = Leaf a | Node (Tree a) (Tree a)++data App f a = App (f a)++xs = [Nothing,Just ()]++four = let z = Zero+           s x = Succ x+       in s ( s ( s (s z)))++x = id four++--n' = fmap id n+--ys = fmap isJust xs++instance Show Nat+instance Num Nat where+  (+) = add+  --(-) = undefined+  --(*) = undefined+  --fromInteger = undefined++double x = x+x++swap (x,y) = (y,x)++--super x y = (x==y,x<=y)
+ tools/hs2alfa/tests/Test1.hs view
@@ -0,0 +1,38 @@+module Test1 where+++b = Nothing == Just True++--t = (\x->[x]) True+t2 = (:[]) True+t3 = (True:) []++succ = (+1)++short xs = null (drop 1 xs)++(x,y) = bla++bla = (False,if True then  True else False)++--swap = \ (x,y) -> (y,x)++zip2 (x:xs) (y:ys) = (x,y):zip2 xs ys+zip2 _ _ = []++unzip4                  =  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->+                                        (a:as,b:bs,c:cs,d:ds))+                                 ([],[],[],[])++partition               :: (a -> Bool) -> [a] -> ([a],[a])+partition p xs =  foldr select ([],[]) xs+   where select x (ts,fs) | p x = (x:ts,fs)+                          | otherwise = (ts, x:fs)++intersperse             :: a -> [a] -> [a]+intersperse sep []      =  []+intersperse sep [x]     =  [x]+intersperse sep (x:xs)  =  x : sep : intersperse sep xs++mem x [] = True+mem x (y:ys) = x==y && mem x ys
+ tools/hs2alfa/tst0.hs view
@@ -0,0 +1,83 @@+module Prelude where++id x = x+const x y = x++--type Char = Prelude.Char+--type String = [Char]+--type List a = [a]+data [] a = [] | a : [a]+data () = ()++--type Bool = Prelude.Bool+data Bool = True | False+data Maybe a = Nothing | Just a+data Nat = Zero | Succ Nat+data Either a b = Left a | Right b+n = Nothing++tr = True+fa = False+not b = if b then fa else tr++add Zero b = b+add (Succ n) b = Succ (add n b)++length xs = case xs of+              [] -> Zero+	      (x:xs) -> Succ (length xs)++z = length []++foldr f z [] = z+foldr f z (x:xs) = f x (foldr f z xs)++even Zero = True+even (Succ n) = odd n++odd Zero = False+odd (Succ n) = even n++data Tree a = Leaf a | Node (Tree a) (Tree a)++data App f a = App (f a)++xs = [Nothing,Just ()]++four = let z = Zero+           s x = Succ x+       in s ( s ( s (s z)))++map f [] = []+map f (x:xs) = f x:map f xs++x = id four++class Functor f where+  fmap :: (a->b)->f a->f b++class Monad m where+   return :: a -> m a+   (>>=) :: m a -> (a -> m b) -> m b++instance Functor Maybe where+  fmap g m = case m of+	       Nothing -> Nothing+	       Just x -> Just (g x)++instance Functor [] where fmap = map++isJust m = case m of Just x -> True ; Nothing -> False++--n' = fmap id n+ys = fmap isJust xs++class Num a where+  (+) :: a -> a -> a++infixl 6 +++instance Num Nat where+  (+) = add++double x = x+x
+ tools/hs2alfa/tst0f.hs view
@@ -0,0 +1,11 @@+module Prelude where++data [] a = [] | a : [a]++map f [] = []+map f (x:xs) = f x:map f xs++class Functor f where fmap :: (a->b)->f a->f b++instance Functor [] where fmap = map+
+ tools/hs2alfa/tst1.hs view
@@ -0,0 +1,22 @@+module Tst1 where++data Bool = False | True++data Nat = Zero | Succ Nat++-- length :: [a] -> Nat+length []     = Zero+length (x:xs) = Succ (length xs)++-- map :: (a->b) -> [a] -> [b]+map f []     = []+map f (x:xs) = f x:map f xs++mapLengthProp f xs = length (map f xs) == length xs++---++Zero   == Zero   = True+Succ _ == Zero   = False+Zero   == Succ _ = False+Succ n == Succ m = n==m
+ tools/hs2alfa/tst1prop.alfa view
@@ -0,0 +1,14 @@+--#include "Prop.alfa"++--#include "tst1b.alfa"++IsTrue (b::Bool) :: Prop+  = case b of {+      (False) -> Absurdity;+      (True) -> Triviality;}++Thm1 (A::Set)(B::Set)(f::A -> B)(xs::List A) :: IsTrue (mapLengthProp A B f xs)+  = ?+{-# Alfa hiding on+var "Thm1" hide 2+ #-}
+ tools/hs2alfa/tst1propb.alfa view
@@ -0,0 +1,26 @@+--#include "Prop.alfa"++--#include "tst1b.alfa"++IsTrue (b::Bool) :: Prop+  = case b of {+      (False) -> Absurdity;+      (True) -> Triviality;}++Thm1 (A::Set)(B::Set)(f::A -> B)(xs::List A) :: IsTrue (mapLengthProp A B f xs)+  = let ndgoal :: IsTrue (mapLengthProp A B f xs)+          = listInd A (\(h::List A) -> IsTrue (mapLengthProp A B f h)) xs+              (let ndgoal :: IsTrue (mapLengthProp A B f Nil@_)+                     = TrivialityIntro+               in  ndgoal)+              (\(x::A) ->+               \(xs'::List A) ->+               \(pxs::IsTrue (mapLengthProp A B f xs')) ->+               let ndgoal :: IsTrue (mapLengthProp A B f ((:)@_ x xs'))+                     = pxs+               in  ndgoal)+    in  ndgoal+{-# Alfa hiding on+var "Thm1" hide 2+var "Thm1b" hide 2+ #-}
+ tools/hs2alfa/tstHs2Alfa.hs view
@@ -0,0 +1,38 @@+import HsParser(parse)+import Syntax(hsModName)+import TiDecorate()+import ReAssocBase()+import ScopeNamesBase()+import NameMapsBase()+import TiProgram(tcProgramFiles)+import Hs2Alfa(transModule,modPath)+import FileConv(printModule)+import System(getArgs)+--import MUtils+--import TextFileConv(toFile)+--import UTF8+import DirUtils(expand)++main =+    writeProgram . transProgram =<< tcProgram =<< expand =<< getArgs+  where+    writeProgram = mapM writeModule+    writeModule (n,m) =+        do putStrLn path+           writeFile path ( {-toFile $-}prefix++printModule m)+      where path=modPath n++    tcProgram files = tcProgramFiles parse files++    transProgram (mss,env) = map transModule' (concat mss)+      where+        transModule' m = (hsModName m,transModule (m,[]) (undefined,env))++    prefix =+      unlines [+	magic,+	"",+	"--#include \"Haskell.alfa\"",+        "{-# Alfa hiding on #-}"]++    magic = "-- Automatically converted from Haskell by hs2alfa..."
+ tools/hs2alfa/tstProp2Alfa.hs view
@@ -0,0 +1,40 @@+import TiProgram(tcProgramFiles)+import PropParser(parse)+import PropSyntax(hsModName)+import ReAssocProp()+--import ReAssoc+--import PrettyPrint+import TiPropDecorate()+import ReAssocProp()+import ScopeNamesProp()+import NameMapsProp()+import Prop2Alfa+import Hs2Alfa(modPath)+import FileConv(printModule)+import System(getArgs)+import DirUtils(expand)+--import UTF8++main =+    writeProgram . transProgram =<< tcProgram =<< expand =<< getArgs+  where+    writeProgram = mapM writeModule+    writeModule (n,m) =+        do putStrLn path+           writeFile path ( {-toFile $-}prefix++printModule m)+      where path=modPath n++    tcProgram files = tcProgramFiles parse files++    transProgram (mss,env) = map transModule' (concat mss)+      where+        transModule' m = (hsModName m,transModule (m,[]) (undefined,env))++    prefix =+      unlines [+	magic,+	"",+	"--#include \"Haskell.alfa\"",+        "{-# Alfa hiding on #-}"]++    magic = "-- Automatically converted from Haskell by hs2alfa..."
+ tools/hs2html/ConvRefsTypes.hs view
@@ -0,0 +1,57 @@+module ConvRefsTypes where+import RefsTypes+import SrcLoc1+import NameMaps+import TypedIds+import UniqueNames+import HsName+import HsIdent(getHSName)+import PrettyPrint+import MUtils(apFst)+--import NoEq++simplifyRefsTypes mrs = [(pp m,simplifyRefsTypes' rs)|(m,rs)<-mrs]++simplifyRefsTypes' refs = simprefs refs+  where+    simprefs rs = [(simpp p,(pp n,simpr dctx,simpsp sp,map (simpos.apFst getHSName) os))|+                    ((dctx,sp),i,os)<-rs,+		    let PN n p=getHSName i]::Refs++    simpr (Def TopLevel) = DT+    simpr (Def Local) = DL+    simpr (Def (ClassDef ())) = DC+    simpr (Def (Instance ())) = DI+    simpr (Def Pattern) = DP+    simpr (Sig _) = U -- hmm+    simpr Use = U+    simpr Logic = U+    simpr FieldLabel = U+    simpr (ExpEnt _) = Ex+    simpr (ImpEnt _ _) = Im++    simpsp ValueNames = V+    simpsp ClassOrTypeNames = T++    simpp (S s) = simpSrcLoc s+    simpes s = (simpf (srcPath s),simpSrcLoc s)++    simpf ('.':'/':s) = s+    simpf s = s++    simpos (PN n o,t) = (simpt t,simpo o)++    --simpo (G (Module m) n (N (Just s))) | s/=loc0 = Right (simpes s) -- Use m and n?+    simpo (G m n ({-N-} _)) = Left (m,n)+    simpo (S s) = Right (simpes s)++    simpt Value = V+    simpt Assertion = V -- !!+    simpt Property = V -- !!+    simpt (Type {}) = T+    simpt (Class {}) = Cl+    simpt (ConstrOf (PN n p) _)  = Co n -- (simpo p)+    simpt (FieldOf (PN n p) _) = Fi n --(simpo p)+    simpt (MethodOf (PN n p) _ _) = Me n --(simpo p)++simpSrcLoc (SrcLoc f n r c) = Pos n r c
+ tools/hs2html/HLex2html.hs view
@@ -0,0 +1,244 @@+{-++This module defines the function #hlex2html#, which translates the output from+an early pass of the lexical analyzer to HTML. It can also make use of cross+reference information to link identifiers to their definitions.++The generated HTML is intended to be part of the body of a web page,+thus it does not include the #head# or #body# tags.+-}+module HLex2html({-hlex2html,-}hlex2html',simpleHlex2html) where+import RefsTypes --hiding (isDef)+import MUtils(apSnd)+import Char(isSpace{-,isAlpha-},isAlphaNum)+import HsTokens+import SrcLoc1+import LitTxt(toHTMLblock)+import PathUtils(normf)+import HLexTagModuleNames+import PrettyPrint(pp)++--------------------------------------------------------------------------------+type ModuleContext = (FilePath,[(FilePath,Module)]) -- (this,other) modules+type LexTokens = [(Token,(Pos,String))]+type URL = String+type HTML = String++simpleHlex2html :: LexTokens -> HTML+--hlex2html  :: ModuleContext -> (Refs,LexTokens) -> HTML+hlex2html' :: (Module->URL) -> ModuleContext -> (Refs,LexTokens) -> HTML+--------------------------------------------------------------------------------++simpleHlex2html = hlex2html' undefined dummy . (,) []+  where dummy = ("",[("",noModule)])++hlex2html' srcURL (thisf,fm) =+     normal . tokens2html srcURL (thisf,thism,fm) . uncurry merge .+     apSnd convModuleNames+  where Just thism = lookup thisf fm++{-++The functions #normal#, #pre#, and #code# implement a state machine that+handles the insertion of properly nested #pre# and #div# tags.+-}++-- Normal text mode, in which literate comments can be output:+normal [] = []+normal ((LiterateComment,(_,s)):ts) = toHTMLblock s++normal ts+normal ((Whitespace,(p,s)):ts) | noCodeOnLine (line p) ts = s++normal ts -- indented code??+normal ((Commentstart,(Pos{column=1},s1)):(Comment,(_,s2)):ts) =+        preStart++cmntesc (s1++s2)++pre ts+normal ((Comment,ps1):(Whitespace,ps2):ts) | isBlockComment ps1 ps2 =+        preStart++cmntesc (snd ps1++snd ps2)++pre ts+normal ts = codeStart++code ts++-- Inside a <pre> block, where blank lines and block comments can be output:+pre [] = preEnd+pre ((LiterateComment,(_,s)):ts) = preEnd++toHTMLblock s++normal ts+pre ((Whitespace,(_,s)):ts) = s++pre ts+pre ((Commentstart,(Pos{column=1},s1)):(Comment,(_,s2)):ts) =+        cmntesc (s1++s2)++pre ts+pre ((Comment,ps1):(Whitespace,ps2):ts) | isBlockComment ps1 ps2 =+        cmntesc (snd ps1++snd ps2)++pre ts+pre ts = preEnd++codeStart++code ts++-- Inside a code, where code and ordinary comments can be output:+code [] = codeEnd+code ((LiterateComment,(_,s)):ts) = codeEnd++toHTMLblock s++normal ts+code ((Commentstart,(_,s1)):(Comment,(_,s2)):ts) = cmntesc (s1++s2)++code ts+code ((Comment,ps1):(Whitespace,ps2):ts) | isBlockComment ps1 ps2 =+        codeEnd++preStart++cmntesc (snd ps1++snd ps2)++pre ts+code ((Comment,(_,s))   :ts) = cmntesc s++code ts+code ((Whitespace,(_,s))   :ts) = s++code ts+code ((_,(_,s)):ts) = s++code ts++preStart = "<pre>"+preEnd = "</pre>"+codeStart = "<div class=code><pre>"+codeEnd = "</pre></div>"++isBlockComment (Pos{column=1},'{':'-':_) (_,s) | '\n' `elem` s = True+isBlockComment _ _ = False++noCodeOnLine l ts =+    all ((`elem` notCode).fst) (takeWhile ((==l).line.fst.snd) ts)+  where notCode = [LiterateComment,Whitespace{-,Commentstart,Comment-}]++cmntesc = cmnt . esc++--------------------------------------------------------------------------------++tokens2html srcURL rs = map (token2html srcURL rs)++token2html :: (Module->URL)->(FilePath,Module,[(FilePath,Module)])->+	      ((Token,(Pos,String)),Maybe Orig)->+	      (Token,(Pos,String))+token2html _      _    ((LiterateComment,ps@(_,"> ")),_) = (Whitespace,ps)+token2html _      _                ((NestedComment,s),_) = nestedcomment s+token2html srcURL (thisf,thism,fm) ((t,(p,s)),r) = (t,(p,f (esc s)))+  where+    moduleLink s = +      case [m|(f,m)<-fm,sameModuleName s m] of+        [m] -> link (srcURL m)+	_ -> modname+    f = case t of+	  ModuleName -> if sameModuleName s thism || thism==noModule+		        then modname+		        else moduleLink s+	  ModuleAlias -> modname+	  Reservedid -> b+	  Reservedop -> b+	  Conid -> conp+	  Consym -> consymp+	  Qconid -> conp+	  Qconsym -> consymp+	  Varid -> varp+	  Specialid -> b+	  Varsym -> varsymp+	  Qvarid -> varp+	  Qvarsym -> varsymp+--	  Literal -> lit -- obsolete+          IntLit -> lit+          FloatLit -> lit+	  CharLit -> lit+	  StringLit -> lit+	  {-+	  Whitespace -> +	  Special+	  -}+	  _ -> id+    varp = var (info "var" "" p)+    conp = con (info "con" "" p)+    varsymp = var (info "var" "op" p)+    consymp = con (info "con" "op" p)+    modname = con (Nothing,[("class","mod")])++    info cl op p =+      case r of+	Just (n,role,sp,rs) | n==s ->+	    (link,+	     (if isDef role+	     then (("id",rstarget sp rs):)+	     else id) $+	       [("class",ty++cl++op),("title",n++": "++title)])+          where+            ty = if isType sp then "t" else ""+            ttag t = if isType t then "t" else "v"++	    link = case links of+		     [Just link] -> Just link+		     _ -> Nothing+	    title = case titles of+		      [] -> "not in scope"+		      _  -> unwords titles+	    (links,titles) = unzip (map shr rs)+++	    sht T = "type"+	    sht V = "value"+	    sht Cl = "class"+	    sht (Co n) = "constructor of "++n+	    sht (Me n) = "method of class "++n+	    sht (Fi n) = "field of type "++n++            shr (t,p) =+		apSnd (("a "++sht t)++) $+		if role==DP+		then (Nothing," bound here")+		else if isDef role+	             then (Nothing," defined here")+		     else shrp t p+	    shrp t (Left (m,n)) =+	      if m==thism+	      then (Just ("#"++tmangle t n)," defined in this module")+	      else (Just (srcURL m++"#"++tmangle t n)," defined in module "++pp m)+	    shrp _ (Right p'@(f,rc)) =+		if p'==(thisf,p)+		then (Nothing," defined here")+		else if f==thisf+		     then (Just ("#"++shPos' rc),+		           " defined in this module at "++shPos rc)+		     else (Just (srcURL m++"#"++shPos' rc),+		           " defined in module "++pp m++" at "++show p')+	      where Just m = lookup (normf f) fm++	    --shpos (f,(y,x)) = show (SrcLoc f 0 y x) -- hmm+	    --shrc (y,x) = show y++":"++show x+	    --shrc' (y,x) = show y++"."++show x++            rstarget t = rtarget t . head+	    rtarget t = either (gtarget t) ptarget . snd+	    gtarget t = tmangle t . snd+	    ptarget = shPos' . snd+	    tmangle t p = ttag t++mangle p+ +	_ -> (Nothing,attrs)+         where+           attrs = if thism==noModule+		   then [("class",cl++op)]+		   else [("title","Hmm. Info missing")]++--isDef r =  r `elem` [DT,DL,DP,DC]++b = ctx "b"+var (optl,as) = optlink optl . ctx' "var" as+con (optl,as) = optlink optl . ctx' "b"  as+lit = ctx' "span" [("class","lit")]++optlink = maybe id link+link url = ctx' "a" [("href",url)]++cmnt = ctx' "span" [("class","cmnt")]++-- Some nested comments, {-+ ... -}, are treated like literate comments...+nestedcomment ps@(p,s) =+  case s of+    '{':'-':'+':c:s' | isSpace c ->+         case reverse s' of+           '}':'-':s -> (LiterateComment,(p,reverse s))+           _ -> (NestedComment,ps) -- Can't happen+    _ -> (NestedComment,ps)++ctx t s = tag t++s++endtag t+ctx' t as s = tag (t++shas as)++s++endtag t+  where+    shas = concatMap sha+    sha (n,v) = ' ':n++"="++quote v++tag t = "<"++t++">"+endtag t = tag ('/':t)++esc = concatMap esc1+  where esc1 '<' = "&lt;"+	esc1 '&' = "&amp;"+	esc1 c = [c]++quote s =+  if all isAlphaNum s+  then s+  else '"':s++"\""++mangle = concatMap mangle1+  where+    mangle1 c = if isAlphaNum c+		then [c]+		else '.':show (fromEnum c) -- hmm
+ tools/hs2html/HLexTagModuleNames.hs view
@@ -0,0 +1,62 @@+{-++This module exports the lexer postprocessor #convModulesNames#,+which changes the tags of module names and special identifers in imports.+(They are just tagged as #Conid# and #Varid# by the lexer.)++Real module names are retagged as #ModuleName#, while module aliases in+export lists, and after the #as# keyword, are retagged as #ModuleAlias#.++The special identifiers #qualified#, #as# and #hiding# are retagged as+ #Specialid#.++This is a simple hack that assumes that the input is syntactically correct.+-}+module HLexTagModuleNames(convModuleNames) where+import HsTokens++convModuleNames = convh++-- At the beginning of a module+convh = skipspace convh'+convh' (t@(Reservedid,(_,"module")):ts) = t:convm ts +convh' ts = conv ts -- no module header++-- When "module" has been seen at the beginning of a module:+convm = skipspace convm'+convm' ((Qconid,ps):ts) = (ModuleName,ps):conv ts+convm' ((Conid,ps):ts) = (ModuleName,ps):conv ts+convm' ts = conv ts -- syntactically incorrect module header?!++-- At various positions+conv = skipspace conv'+conv' [] = []+conv' (t@(Reservedid,(_,"import")):ts) = t:convi ts+conv' (t@(Reservedid,(_,"module")):ts) = t:conve ts +conv' (t:ts) = t:conv ts -- a "normal" token, output unchanged++-- When "module" has been seen in an export list:+conve = skipspace conve'+conve' ((Qconid,ps):ts) = (ModuleAlias,ps):conv ts+conve' ((Conid,ps):ts) = (ModuleAlias,ps):conv ts+conve' ts = conv ts  -- syntactically incorrect module export?!++-- When "import" has been seen:+convi = skipspace convi'+convi' ((Varid,ps@(_,"qualified")):ts) = (Specialid,ps):convi ts+convi' ((Qconid,ps):ts) = (ModuleName,ps):conva ts+convi' ((Conid,ps):ts) = (ModuleName,ps):conva ts+convi' ts = conv ts -- syntactically incorrect import declaration?!++-- When the module name after "import" has been seen:+conva = skipspace conva'+conva' (t2@(Varid,ps@(_,"as")):ts) = (Specialid,ps):conva ts+conva' (t2@(Varid,ps@(_,"hiding")):ts) = (Specialid,ps):conv ts+conva' ((Qconid,ps):ts) = (ModuleAlias,ps):conva ts+conva' ((Conid,ps):ts) = (ModuleAlias,ps):conva ts+conva' ts = conv ts+++skipspace f (t@(Whitespace,_):ts) = t:skipspace f ts+skipspace f (t@(NestedComment,_):ts) = t:skipspace f ts+skipspace f (t1@(Commentstart,_):t2@(Comment,_):ts) = t1:t2:skipspace f ts+skipspace f ts = f ts
+ tools/hs2html/HuMakefile view
@@ -0,0 +1,7 @@++B=../base+PARSE_DIRS=$B/parse2/Lexer+SRC_DIRS=.:$PARSE_DIRS:$B/AST:$B/lib:$B/lib/Monads:$B/pretty++GHCFLAGS="-fno-allow-overlapping-instances -fglasgow-exts -package lang -package data -package text"+ #-Wall -fwarn-incomplete-patterns
+ tools/hs2html/LitTxt.hs view
@@ -0,0 +1,11 @@+module LitTxt (toHTML,toHTMLblock) where++import MyDoc+import ParseMyDoc+import MyDoc2HTML+import Text.PrettyPrint(render)+import EnvM (withEnv)+++toHTML = render . withEnv html . ppMyDoc . parse+toHTMLblock = render . withEnv htmlblock . ppMyDoc . parse
+ tools/hs2html/Makefile view
@@ -0,0 +1,31 @@+TARGETS=hs2html hslex2html+++#Optimization and other compiler options:+#OPT=+OPT=-O+HFLAGS=++#Tools:+RM=rm -f+HMAKE=sh ../scripts/hsmake.sh++################################################################################+### Rules for compiling the programs++nothing:++all: $(TARGETS)++hs2html::+	$(HMAKE) $(OPT) $(HFLAGS) hs2html++hslex2html::+	$(HMAKE) $(OPT) $(HFLAGS) hslex2html++################################################################################+### Rules for cleaning up++clean:+	$(RM) -r $(TARGETS) hi+	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'
+ tools/hs2html/MyDoc.hs view
@@ -0,0 +1,74 @@+module MyDoc where++import Text.PrettyPrint+import EnvM+import MUtils +import Monad+import Char(isSpace)+++type Heading    = (Int,String)+data TxtDec     = Plain | Emph | Code | Math    deriving (Eq,Show)+type DecString  = (TxtDec,String)++type Code       = [String]+type TxtBlock   = [Paragraph]+data Paragraph  = Txt [[DecString]] | Lst [TxtBlock] | H Heading  deriving Show++type MyDoc      = [Either TxtBlock Code]+++data Style = Style +    { ppHeading   :: Heading -> Doc+    , ppDecStr    :: DecString -> Doc+    , ppCode      :: Code -> Doc++    , ppList      :: [Doc] -> Doc+    , ppItem      :: Doc -> Doc++    , ppParagraph :: Doc -> Doc++    , ppText      :: Doc -> Doc+    , ppFinalize  :: Doc -> Doc+    }+++env f x = do e <- getEnv+             return (f e x)++ppH x = env ppHeading x+ppS x = env ppDecStr x+ppC x = env ppCode x++ppL x = env ppList x+ppI x = env ppItem x++ppP x = env ppParagraph x+ppT x = env ppText x+ppF x = env ppFinalize x+++ppMyDoc d = ppF =<< (vcat # mapM (either topLevel ppC) d)++topLevel d = ppT =<< (vcat # mapM prt d)+    where+    prt ((H h):xs)  = liftM2 ($$) (ppH h) (prt xs)+    prt ((Txt as):xs) +        | emp as    = (text "" $$) # prt xs++    prt x           = vcat # mapM (ppP @@ ppPar) x+    ++ppTxtBlock d    = vcat # mapM ppPar d++ppPar (Txt tss) = vcat # mapM (\ts -> hcat # mapM ppS ts) tss+ppPar (Lst is)  = ppL =<< mapM (ppI @@ ppTxtBlock) is+ppPar (H _)     = error "inner heading? (MyDoc.hs)"++emp []          = True+emp ([]:xss)    = emp xss+emp (xs:xss)    = all (all isSpace.snd) xs && emp xss++++
+ tools/hs2html/MyDoc2HTML.hs view
@@ -0,0 +1,42 @@+module MyDoc2HTML(html,htmlblock) where++import MyDoc+import Text.PrettyPrint hiding (Style)++htmlblock = html { ppFinalize = id }++html = Style+    { ppHeading     = heading+    , ppDecStr      = txt+    , ppCode        = code++    , ppList        = list+    , ppItem        = item++    , ppParagraph   = par+    , ppText        = id+    , ppFinalize    = fin+    } ++tag t       = char '<' <> text t <> char '>'+endtag t    = text "</" <> text t <> char '>'++tagB t d    = tag t $$ d $$ endtag t +tagL t d    = tag t <> d <> endtag t ++heading (n,t) = tagL ('H' : show (n + 1)) (text t)+txt (x,t) = f (text t)+    where +    f = case x of+        Plain   -> id+        Emph    -> tagL "I"+        Code    -> tagL "TT"+        Math    -> tagL "I"++list        = tagB "UL" . vcat+code        = tagB "PRE" . vcat . map text+item        = tagL "LI"+par         = tagB "P"++fin         = tagB "HTML" . tagB "BODY"+
+ tools/hs2html/MyDoc2Latex.hs view
@@ -0,0 +1,50 @@+module MyDoc2Latex(latex) where++import MyDoc+import Pretty+++beg t = text "\\begin{" <> text t <> char '}'+end t = text "\\end{" <> text t <> char '}'++cmd x t = beg x $$ t $$ end x+++latex = Style+    { ppHeading     = heading+    , ppDecStr      = txt+    , ppCode        = code++    , ppList    = list+    , ppItem    = item++    , ppParagraph   = par+    , ppText        = id+    , ppFinalize    = fin+    }+++fin x = text "\\documentclass{article}"+      $$ cmd "document" x++heading (n,t) = text lvl <> curlies (text t)+    where+    lvl = case n of    +        0 -> "\\section" +        1 -> "\\subsection"+        2 -> "\\subsubsection"+        _ -> error "*** section level > 3"++txt (dec,t) = let t' = text t in case dec of+    Plain   -> t'+    Emph    -> text "\\emph" <> curlies t'+    Code    -> text "\\verb#" <> t' <> char '#' +    Math    -> char '$' <> t' <> char '$'++list    = cmd "itemize" . vcat +item i  = text "\\item" <+> i+par t   = text "\n" $$ t++code = cmd "verbatim" . vcat . map text ++
+ tools/hs2html/MyDoc2litHTML.hs view
@@ -0,0 +1,38 @@+module MyDoc2litHTML(litHTML) where++import MyDoc+import Pretty++litHTML = Style+    { ppHeading     = heading+    , ppDecStr      = txt+    , ppCode        = code++    , ppList        = list+    , ppItem        = item++    , ppParagraph   = par+    , ppText        = markHTML+    , ppFinalize    = id+    } ++tag t       = char '<' <> text t <> char '>'+endtag t    = text "</" <> text t <> char '>'++tagL t d    = tag t <> d <> endtag t ++heading (n,t) = tagL ('H' : show (n + 1)) (text t)+txt (x,t) = f (text t)+    where +    f = case x of+        Plain   -> id+        Emph    -> tagL "I"+        Code    -> tagL "TT"+        Math    -> tagL "I"++list        = tagL "UL" . vcat+code        = vcat . map text+item        = tagL "LI"+par         = tagL "P"++markHTML x  = text "{-+" <+> x <+> text "-}"
+ tools/hs2html/ParseMyDoc.hs view
@@ -0,0 +1,212 @@+module ParseMyDoc where++import MyDoc++import Monad+import List+import Maybe+import Char++import StateM +--import MUtils++-- Constants+tabWidth    = 8++data CharClass = CodeChar | ItemChar | UnderChar+                deriving Eq+++chars = +    [ (CodeChar, ['>', '|'])+    , (ItemChar, ['*', '-'])+    , (UnderChar, ['=', '-', '~'])+    ]++get x = fromJust (lookup x chars)+++-- Character classes+is t c = c `elem` get t +++-- Line types+codeL (n,x:xs)  = n == 0 && is CodeChar x+codeL _         = False+blankL (n,x)    = null x+underL (n,x:xs) = is UnderChar x && all (== x) xs +underL _        = False+itemL (n,x:y:_) = is ItemChar x && isSpace y+itemL _         = False++-- underline types+lvl (_,x:_) +    | is UnderChar x    = fromJust $ elemIndex x (get UnderChar)+    | otherwise         = error "not underline character"++stripList = drop 2++-- Utilities+indent x = (foldr add 0 (takeWhile isSpace x), dropWhile isSpace x)+    where+    add '\t'    = (+ tabWidth)+    add _       = (+ 1)++eIf p a b = either (const a) (const b) p+eMap f g  = either (Left . f) (Right . g)++grpEither :: [Either a b] -> [Either [a] [b]]+grpEither = map grp . groupBy eq+    where+    eq x y          = eIf x (eIf y True False) (eIf y False True)+    grp xs@(x: _)   = eIf x (Left $ unL `map` xs) (Right $ unR `map` xs)+    unL = either id undefined +    unR = either undefined id +++parse =  map (eMap f id) . sepCodeAndText . map indent . lines+    where+    f = proc initSt+    initSt  = [ St+        { offset = 0+        , curTxt = []+        , curItem = []+        , curList = []+        } ]++++sepCodeAndText = grpEither . map identify +    where+    identify l@(n,txt)+        | codeL l   = Right (tail txt)+        | otherwise = Left l++data St = St +    { offset    :: Integer+    , curTxt    :: [String]+    , curItem   :: [Paragraph]+    , curList   :: [TxtBlock]+    }+    deriving Show+++newList m txt = St+    { offset    = m +    , curTxt    = [stripList txt]+    , curItem   = []+    , curList   = [] +    } ++newItem txt st  = (endItem st) { curTxt = [stripList txt] }++-- add the blank text to compensate for the removed underlining+-- it is at the front becuase it will later be reversed+newHeading h st = endItem $ newLine $ (endItem st) { curItem = [h] }+newTxt txt st   = st { curTxt = txt : curTxt st }+newLine st      = st { curTxt = [] : curTxt st }++endTxt st+    | null (curTxt st)  = st +    | otherwise = st+        { curTxt = []+        , curItem = toPar (curTxt st) : curItem st+        }+    where+    toPar = Txt . dec . reverse+{-+    unl []          = []+    unl [x]         = x+    unl (x:y:zs)    = x ++ "\n" ++ y ++ unl zs+-}++endItem st = let s = endTxt st in +    if null (curItem s) then s+    else s+    { curItem = []+    , curList = toItm (curItem s) : curList s +    }+    where+    toItm = reverse++endList []          = error "endList: []"+endList [x]         = [x]+endList (st:x:xs)   = x { curItem = l : curItem x } : xs+    where+    l = Lst $ reverse $ curList (endItem st)++endAllLists []  = error "endAllLists: []"+endAllLists [x] = [endItem x]+endAllLists xss = endAllLists (endList xss) +++proc [] _   = error "proc: [] _"++proc sts [] = reverse $ curList $ top (endAllLists sts)++proc sts (l1:l2:ls)+    | underL l2 +        = let [st]  = endAllLists sts+              st'   = newHeading (H (lvl l2, getTxt l1)) st+          in proc [st'] ls+++proc [st] (l:ls) +    | blankL l  = let st' = endItem st+                  in proc [newLine st'] ls+++proc stack (l:ls)+    | blankL l  = proc (apTop newLine stack) ls+    | m == n && itemL l = proc (apTop (newItem txt) stack) ls+    | n >= m = if itemL l +                then proc (push (newList n txt) (apTop endTxt stack)) ls+                else proc (apTop (newTxt txt) stack) ls+    | otherwise = let x:xs = endList stack +                  in proc (apTop (newTxt txt) (endList stack)) ls+    where+    m   = offset (top stack)+    n   = getPos l+    txt = getTxt l +++getPos = fst+getTxt = snd++push = (:)+top = head++apTop f (x:xs)  = f x : xs+apTop _ _       = error "apTop: []"++++dec = decorate Plain ++decorate _ [] = []+decorate t (xs:xss)+    = let (_,(ws,a,s))= withStS ([],"",t) (mapM_ toAct xs)+      in reverse ((s,reverse a):ws) : decorate s xss++toAct '_' = act '_' Emph+toAct '#' = act '#' Code+toAct '$' = act '$' Math+toAct x   = addChar x ++chgTo s = do+    (ws,a,t) <- getSt+    setSt_ ((t,reverse a):ws,"",s)++addChar c = do+    (ws,a,t) <- getSt+    setSt_ (ws,c:a,t)++act c state = do+    (ws,a,s) <- getSt+    case s of +        Plain   -> chgTo state+        x+            | x == state    -> chgTo Plain+            | otherwise     -> addChar c++
+ tools/hs2html/RefsTypes.hs view
@@ -0,0 +1,63 @@+module RefsTypes(module RefsTypes,Pos(..),sameModuleName,noModule) where+import HsName(ModuleName,sameModuleName,noModule)+import HsLexerPos(Pos(..))+import SrcLoc1(SrcLoc)+{-++The cross reference information was once written to files by #tstModules#+and then read by #hs2html#. That is why there were #Show# and #Read# instances,+and why the constructor names are short.+<p>+Since hs2html has been integrated into pfe now, these types are rather+obsolete...+-}++--data SP = T | V deriving (Read)+data T = V | Co Name {-Ref-} | Me Name {-Ref-} | Fi Name {-Ref-} | T | Cl deriving (Eq,Show,Read)+data R = DT | DL | DC | DI | DP | U | Ex | Im deriving ({-Show,Read,-}Eq)+type Module = ModuleName+type Name = String+--type Pos = (Int,Int) -- (line,column)+type SrcPos = (FilePath,Pos) -- better to keep SrcLoc?+type Global = (Module,Name)+type Local = SrcPos+type Ref = Either Global Local+type Orig = (Name,R,T,[(T,Ref)])+type Refs = [(Pos,Orig)]++isDef U = False+isDef DI = False+isDef Ex = False+isDef Im = False+isDef _ = True++isType Cl = True+isType T = True+isType _ = False++shPos p = show (line p)++":"++show (column p)+shPos' p = show (line p)++"."++show (column p)++-- Merge a sorted list of reference info with a list of lexical tokens+-- (Designed to be lazy in the reference list)+merge rs [] = []+merge rs tts@(t@(_,(tp,_)):ts) = (t,optref):merge rs' ts+  where+    (optref,rs') = findref rs++    findref [] = (Nothing,[])+    findref rrs@((rp,ref):rs) =+	  case compare rp tp of+	    LT -> findref rs+	    EQ -> (Just ref,rs)+	    GT -> (Nothing,rrs)++{-+-- Strict merge (only marginally faster, it seems):+merge' rs [] = []+merge' [] ts = map (flip (,) Nothing) ts+merge' rrs@(r@(rp,ref):rs) tts@(t@(_,(tp,_)):ts) =+  case compare rp tp of+    LT -> merge' rs tts+    EQ -> (t,Just ref):merge' rs ts+    GT -> (t,Nothing):merge' rrs ts+-}
+ tools/hs2html/hs2html.hs view
@@ -0,0 +1,53 @@+{-+This program converts Haskell source to HTML. Apart from the Haskell source+files, it requires the cross reference information produced by running++       tstModules xrefs <files>++on the complete program.+-}++import HsLexerPass1+import System(getArgs)+import Unlit(readHaskellFile)+import MUtils+import RefsTypes+import HLex2html+import PathUtils(normf)++-- fix the hard coded path?+main =+  do args <- getArgs+     fms <- mapFst normf # (readIO =<< readFile "hi/ModuleSourceFiles.hv")+     case args of+       ["file",m]   -> putStrLn . maybe "?" id . lookup m . map swap $ fms+       ["html",m]   -> module2html m fms+       ["f2html",f] -> file2html (normf f) fms+       ["all2html"] -> all2html fms+       ["modules"]  -> putStr . unlines . map (\(f,m)->m++" "++f) $ fms+       ["files"]  -> putStr . unlines . map fst $ fms+       _ -> fail "Usage: hs2html (file <module> | html <module> | f2html <file> | files | modules | all2html)"++readl s = map read . lines $ s++readModule = readRefs >#< lexHaskellFile+readRefs :: Module -> IO Refs+readRefs m = readl # readFile ("hi/"++m++".refs")+lexHaskellFile f = lexerPass0 # readHaskellFile Nothing f++all2html fms = mapM_ one2html fms+  where+    one2html (f,m) = writeFile h.hlex2html (f,fms)=<<readModule (m,f)+      where h = "hi/"++m++".html"++module2html m fms =+  case [f|(f,m')<-fms,m'==m] of+    f:_ -> haskell2html (f, fms) (m, f)+    _ -> fail "Unknown module"++file2html f fms =+  case [m|(f',m)<-fms,f'==f] of+    m:_ -> haskell2html (f, fms) (m,f)+    _ -> fail "Unknown source file"++haskell2html ffm mf = putStrLn.hlex2html ffm=<<readModule mf
+ tools/hs2html/hslex2html.hs view
@@ -0,0 +1,14 @@+import System(getArgs)+import HsLexerPass1(lexerPass0)+import HLex2html(simpleHlex2html)+import Unlit(readHaskellFile)++main =+  do args <- getArgs+     if null args+       then interact hslex2html+       else mapM_ hsfile2html args++hsfile2html path = putStr . hslex2html =<< readHaskellFile Nothing path++hslex2html = simpleHlex2html.lexerPass0
+ tools/hs2isabelle/AST/IsabelleAST.hs view
@@ -0,0 +1,5 @@+module IsabelleAST (module AST) where+import IsabelleType as AST+import IsabelleTerm as AST+import IsabelleProp as AST+import IsabelleDecl as AST
+ tools/hs2isabelle/AST/IsabelleDecl.hs view
@@ -0,0 +1,39 @@+module IsabelleDecl where+import IsabelleType(ConstsDecl,TypesDecl,DomainType,DomainDecl(..))+import IsabelleTerm(HMatches,FixrecDecl(..))+import IsabelleProp(PredDecl,PropDecl)+import Mixfix++-- For top level declarations:++data IsaDecl+  = IsaTypes TypesDecl+  | IsaDomain DomainDecl+  | IsaConsts ConstsDecl+  | IsaFixrec FixrecDecl+  | IsaPredDecl PredDecl+  | IsaPropDecl PropDecl+  | IsaComment String++data Module = Module (String, [String]) [IsaDecl]++------------------------------------------------------------++instance Show IsaDecl where+  showsPrec p x = case x of+    IsaTypes d -> shows d+    IsaDomain d -> shows d+    IsaConsts d -> shows d+    IsaFixrec d -> shows d+    IsaPropDecl d -> shows d+    IsaPredDecl d -> shows d+    IsaComment s -> showLR "(*\n" "*)\n" (showString s)++instance Show Module where+  showsPrec p (Module (name,imports) decls) =+    showString "theory " . showString name .+    showString "\nimports " . showSpaceSep (map showString imports) .+    showString "\nbegin\n\n" .+    showSep (showString "\n") (map shows decls) .+    showString "\nend\n"+  
+ tools/hs2isabelle/AST/IsabelleProp.hs view
@@ -0,0 +1,148 @@+module IsabelleProp where+import IsabelleTerm+import IsabelleType+import Mixfix++type TypedId = (String, Maybe Type)++data Prop+  = PropTrue                                     {- truth value -}+  | PropFalse                                    {- truth value -}+  | PropVar     String                           {- Propositional variable -}+  | PropHas     [PredArg] Pred                   {- Predicate membership -}+  | PropEqual   Term Term                        {- equality assertion -}+  | PropConj    Prop Prop                        {- propositional conjunct -}+  | PropDisj    Prop Prop                        {- propositional disjunct -}+  | PropImpl    Prop Prop                        {- implication chain -}+  | PropEquiv   Prop Prop                        {- equivalence -}+  | PropNeg     Prop                             {- negation -}+  | PropForall  [TypedId] Prop                   {- universal quantification -}+  | PropExists  [TypedId] Prop                   {- existential quantification -}+    -- maybe should add type field to quantifiers++propForall x (PropForall xs u) = PropForall (x:xs) u+propForall x u = PropForall [x] u++propExists x (PropExists xs u) = PropExists (x:xs) u+propExists x u = PropExists [x] u++data PropDecl+  = PropDecl String Prop                {- prop. declaration -}+++--signature sorts Pred PredPat PredFormula PredDecl++data Pred+{-  PredConst : String -> Pred -}           {- predicate constant -}+  = PredUniv+  | PredUndef+  | PredArrow   Pred Pred                     {- arrow predicate -}+  | PredLfp     String Pred                   {- least fixed-point predicate -}+  | PredGfp     String Pred                   {- greatest fixed-point predicate-}+  | PredVar     String                        {- predicate variable -}+  | PredLifted  Term                          {- lifted section predicate -}+  | PredNeg     Pred                          {- negated predicate -}+  | PredStrong  Pred                          {- strengthened predicate -}+  | PredTuple   [Pred]                        {- tuple predicate -}+  | PredLit     Integer                       {- literal predicate -}+  | PredCong    String [PredArg]              {- constructor congruence pred. -}+  | PredComp    [Pattern] Prop                {- set comprehension -}+  | PredDisj    Pred Pred                     {- pred. disjunction -}+  | PredConj    Pred Pred                     {- pred. conjunction -}+  | PredImpl    Pred Pred                     {- pred. implication chain -}+  | PredEquiv   Pred Pred                     {- pred. equivalence -}+     -- shouldn't PredEquiv return Prop? or is this pointwise equivalence?++data PredArg+  = TermArg Term+  | PredArg Pred++data PredPat+  = PredAbs String [String]  {- pred. abstraction -}+{-+data Param+  = TermParam String+  | PredParam String+-}+data PredDecl+  = PredDecl PredPat Pred  {- pred. declaration -}++------------------------------------------------------------++instance Show Prop where+  showsPrec p x = case x of+    PropTrue -> showString "PropTrue"+    PropFalse -> showString "PropFalse"+    PropVar x -> showString x+    PropHas [x] a -> mixfix "_ : _" [showsPrec 50 x, showsPrec 51 a] 50 p+    PropHas xs a -> mixfix "_ : _" [showTuple (map shows xs), showsPrec 51 a] 50 p+    PropEqual u v -> mixfix "_ = _" [showsPrec 50 u, showsPrec 51 v] 50 p+    PropConj u v -> mixfix "_ & _" [showsPrec 36 u, showsPrec 35 v] 35 p+    PropDisj u v -> mixfix "_ & _" [showsPrec 31 u, showsPrec 30 v] 30 p+    PropImpl u v -> mixfix "_ --> _" [showsPrec 26 u, showsPrec 25 v] 25 p+    PropEquiv u v -> mixfix "_ = _" [showsPrec 50 u, showsPrec 51 v] 50 p+    PropNeg u -> mixfix "~ _" [showsPrec 40 u] 40 p+    PropForall xs u ->+        mixfix "ALL _. _" [showTypedIds xs, showsPrec 10 u] 10 p+    PropExists xs u ->+        mixfix "EX _. _" [showTypedIds xs, showsPrec 10 u] 10 p+    where+      showTypedId p (x, Nothing) = showString x+      showTypedId p (x, Just t) = mixfix "_::_" [showString x, shows t] 0 p+      showTypedIds (x:[]) = showTypedId 0 x+      showTypedIds (x:xs) = mixfix "_ _" [showTypedId 1 x, showTypedIds xs] 0 0++instance Show Pred where+  showsPrec p x = case x of+    PredUniv -> showString "UNIV"+    PredUndef -> showString "{UU}"+    PredArrow a b -> mixfix "arrow _ _" [showsPrec 1000 a, showsPrec 1000 b] 999 p+    PredLfp x a -> mixfix "lfp (%_. _)" [showString x, shows a] 999 p+    PredGfp x a -> mixfix "gfp (%_. _)" [showString x, shows a] 999 p+    PredVar x -> showString x+    PredLifted x -> mixfix "lifted _" [showsPrec 1000 x] 999 p+    PredNeg a -> mixfix "- _" [showsPrec 81 a] 80 p+    PredStrong a -> mixfix "strong _" [showsPrec 1000 a] 999 p+    PredTuple as -> showTuple (map shows as)+    PredLit n -> showBraces (shows (HInt n))+    PredCong c [] -> showBraces (showString c)+    PredCong c xs -> mixfix "cong_ _ _"+      [shows (length xs), showString c, showSpaceSep (map showCongArg xs)] 999 p+    PredComp [x] a -> mixfix "{_. _}" [shows x, shows a] 1000 p+    PredComp xs a -> mixfix "{_. _}" [showTuple (map shows xs), shows a] 1000 p+    PredDisj a b -> mixfix "_ Un _" [showsPrec 65 a, showsPrec 66 b] 65 p+    PredConj a b -> mixfix "_ Int _" [showsPrec 70 a, showsPrec 71 b] 70 p+    PredImpl a b -> showsPrec p (PredDisj (PredNeg a) b)+    PredEquiv a b -> mixfix "_ <=> _" [showsPrec 50 a, showsPrec 51 b] 50 p++instance Show PredArg where+  showsPrec p x = case x of+    TermArg t -> showsPrec p t+    PredArg a -> showsPrec p a++showCongArg x = case x of+    TermArg t -> showBraces (shows t)+    PredArg a -> showsPrec 1000 a++instance Show PredPat where+  showsPrec p (PredAbs f xs) = case xs of+    [] -> showString f+    _  -> mixfix "_ _" [showString f, showSpaceSep (map showString xs)] 999 p+{-+instance Show Param where+  showsPrec p x = case x of+    TermParam s -> showString s+    PredParam s -> showString s+-}+instance Show PredDecl where+  showsPrec p (PredDecl (lhs@(PredAbs x _)) rhs) =+    mixfix "constdefs\n  _ :: \"\\_\"\n  \"_ == _\"\n"+      [showString x, showsPrec 3 lhs, showsPrec 2 rhs] 2 p++instance Show PropDecl where+  showsPrec p (PropDecl lhs rhs) =+    mixfix "(*\nlemma _: \"_\"\n*)\n" [showString lhs, shows rhs] 0 0+{-+    mixfix "constdefs\n  _ :: bool\n  \"_ == _\"\n"+      [showString lhs, showString lhs, showsPrec 2 rhs] 2 p+-}
+ tools/hs2isabelle/AST/IsabelleTerm.hs view
@@ -0,0 +1,93 @@+module IsabelleTerm where+import IsabelleType+import Mixfix++type Pattern = Term++-- LCF terms in HOLCF+data Term+  = HVar String+  | HAbs [String] Term -- should probably be [Pattern]+  | HAbsTuple [String] Term+  | HApp Term Term+  | HInfix Term String Term+  | HTuple [Term]+  | HList [Term]+  | HLet [HMatch] Term+  | HIte Term Term Term -- if-then-else+  | HInt Integer+  | HCase Term [HAlt]+  | HConstrain Term Type+  | HMixfix String [Int] Int [Term]++data HAlt = HAlt Pattern Term++head_of_Term :: Term -> String+head_of_Term (HApp t _) = head_of_Term t+head_of_Term (HInfix _ s _) = s+head_of_Term (HVar s) = s++-- hIte = HMixfix "If _ then _ else _ fi" [0,0,0] 60+hApps t ts = foldl HApp t ts+hCon c ts = hApps (HVar c) ts++isHVar (HVar _) = True+isHVar _ = False++hAbs (HVar x) (HAbs xs t) = HAbs (x:xs) t+hAbs (HVar x) t = HAbs [x] t+hAbs (HTuple ts) t | all isHVar ts = HAbsTuple (map (\(HVar x) -> x) ts) t+hAbs p t = error ("hAbs: illegal pattern " ++ show p)++hAbss ps t = foldr hAbs t ps++nomatch = HVar "UU"++data HMatch+  = HMatch Pattern Term++head_of_HMatch :: HMatch -> String+head_of_HMatch (HMatch lhs rhs) = head_of_Term lhs++data HMatches+  = HMatches [HMatch]++head_of_HMatches :: HMatches -> String+head_of_HMatches (HMatches (m:ms)) = head_of_HMatch m++data FixrecDecl+  = FixrecDecl [HMatches]++------------------------------------------------------------++instance Show Term where+  showsPrec p x = case x of+    HVar s -> showString s+    HAbs xs t -> mixfix "LAM _. _"+                    [showSpaceSep (map showString xs), showsPrec 10 t] 10 p+    HAbsTuple xs t -> mixfix "LAM <_>. _"+                    [showCommaSep (map showString xs), showsPrec 10 t] 10 p+    HApp t t' -> mixfix "_$_" [showsPrec 999 t, showsPrec 1000 t'] 999 p+    HInfix t o t' -> mixfix "_ `_ _" [showsPrec 900 t, showString o, showsPrec 900 t'] 0 p+    HTuple ts -> showSpace . showAngles (showCommaSep (map shows ts))+    HList [] -> showString "[:]"+    HList ts -> showLR "[:" ":]" (showCommaSep (map shows ts))+    HIte b x y -> mixfix "If _ then _ else _ fi" [shows b, shows x, shows y] 60 p+    HInt n -> shows n -- mixfix "Def _" [shows n] 999 p+    HMixfix s ps p0 ts -> mixfix s (zipWith ($) (map showsPrec ps) ts) p0 p+    HCase t alts ->+            mixfix "case _ of _" [shows t, showBarSep (map shows alts)] 10 p+    HConstrain x t -> mixfix "_::_" [showsPrec 4 x, shows t] 3 p++instance Show HAlt where+  showsPrec p (HAlt lhs rhs) = mixfix "_ => _" [shows lhs, shows rhs] 10 p++instance Show HMatch where+  showsPrec p (HMatch lhs rhs) = mixfix "_ = _" [showsPrec 50 lhs, showsPrec 51 rhs] 50 p++instance Show HMatches where+  showsPrec p (HMatches ms) = showAll (map (showLR "  \"" "\"\n" . shows) ms)++instance Show FixrecDecl where+  showsPrec _ (FixrecDecl blocks) =+    showString "fixrec\n" . (showSep (showString "and\n") (map shows blocks))
+ tools/hs2isabelle/AST/IsabelleType.hs view
@@ -0,0 +1,134 @@+module IsabelleType where+import Mixfix+import Char(isAlpha)++data Sort = Sort [String] | DefaultSort++tVar a = TVar a DefaultSort++data Type+  = TVar String Sort+  | TType String [Type]+  | TCfun Type Type+  | TFfun Type Type+  | TCprod Type Type+  | TSprod Type Type+  | TSsum Type Type++tApp (TType s ts) t = TType s (ts ++ [t])++foldr1' :: (a -> a -> a) -> a -> [a] -> a+foldr1' f z [] = z+foldr1' f z xs = foldr1 f xs++tCprods = foldr1' TCprod (TType "unit" [])+tSprods = foldr1' TSprod (TType "one" [])+tSsums  = foldr1' TSsum  (TType "unit" [])+tFfuns ts t = foldr TFfun t ts+tCfuns ts t = foldr TCfun t ts++tList t = TType "list" [t]++type TypePattern = Type++-- Datatype declarations++data TypesDecl = TypesDecl TypePattern Type++data TypeSig = TypeSig String Type+data ConstsDecl = ConstsDecl [TypeSig]++data Strictness = Lazy | Strict+data DomainArg = DomainArg Strictness String Type+data DomainCons = DomainCons String [DomainArg]+data DomainType = DomainType TypePattern [DomainCons]+data DomainDecl = DomainDecl [DomainType]++------------------------------------------------------------++instance Show Sort where+  showsPrec p DefaultSort = id+  showsPrec p (Sort xs) = showString "::" . case xs of+    [x] -> showString x+    xs -> showBraces (showCommaSep (map showString xs))++instance Show Type where+  showsPrec p x = case x of+    TVar a s -> showChar '\'' . showString a . shows s+    -- special case for list constructor+    TType "[]" [t] -> showSquares (shows t)+    -- special case for tuple constructors+    TType ('(':_) ts -> showSpace . showAngles (showCommaSep (map shows ts))+    TType c [] -> showTypeName c+    TType c [t] -> shows t . showSpace . showTypeName c+    TType c ts -> showParens (showCommaSep (map shows ts)) .+                  showSpace . showTypeName c+    TCfun  t t' -> mixfix "_ -> _" [showsPrec 1 t, showsPrec 0 t'] 0 p+    TFfun  t t' -> mixfix "_ => _" [showsPrec 1 t, showsPrec 0 t'] 0 p+    TCprod t t' -> mixfix "_ * _"  [showsPrec 21 t, showsPrec 20 t'] 20 p+    TSprod t t' -> mixfix "_ ** _" [showsPrec 21 t, showsPrec 20 t'] 20 p+    TSsum  t t' -> mixfix "_ ++ _" [showsPrec 11 t, showsPrec 10 t'] 10 p+    where showTypeName c = showString c -- ('H':c)++instance Show TypesDecl where+  showsPrec p (TypesDecl lhs rhs) =+    mixfix "types _ = _\n" [shows lhs, showQuotes (shows rhs)] 1000 p++instance Show TypeSig where+  showsPrec _ (TypeSig name typ) = if isAlpha (head name)+    then showString name . showString " :: " . showQuotes (shows typ)+    else showQuotes (showString ('`':name)) . showString " :: " .+      showQuotes (shows typ) . showString ("  (infixl \"`" ++ name ++ "\" 90)")++instance Show ConstsDecl where+  showsPrec _ (ConstsDecl sigs) =+    showString "consts\n" . showAll (map (showLR "  " "\n" . shows) sigs)+    +instance Show DomainArg where+  showsPrec _ (DomainArg str name t) = case (str,name) of+    (Strict, "") -> show_t+    (Strict, s)  -> showParens (showString s . showString "::" . show_t)+    (Lazy,   "") -> showParens (showString "lazy " . show_t)+    (Lazy,   s)  -> showParens+      (showString "lazy " . showString s . showString "::" . show_t)+    where show_t = showQuotes (shows t)++instance Show DomainCons where+  showsPrec _ (DomainCons s []) = showString s+  showsPrec _ (DomainCons s args) =+    showString s . showSpace . showSpaceSep (map shows args)++instance Show DomainType where+  showsPrec _ (DomainType t cons) =+    shows t . showString " = " . showBarSep (map shows cons)++instance Show DomainDecl where+  showsPrec _ (DomainDecl ds) =+    showString "domain\n" .+    showSep (showString "and\n") (map (showLR "  " "\n" . shows) ds)++------------------------------------------------------------+-- for testing+a' = tVar "a"+b' = tVar "b"+c' = tVar "c"+d' = tVar "d"+--a' = TVar "a" (Sort ["cpo"])++{-+domain 'a tree = Leaf (value :: "'a") | Node (children :: "'a forest")+and 'a forest = Empty | Trees (head :: "'a tree") (tail :: "'a forest")+-}++tree_forest :: DomainDecl+tree_forest = DomainDecl [tree, forest]+  where+    a_tree = TType "tree" [a']+    a_forest = TType "forest" [a']+    tree = DomainType a_tree [leaf, node]+    leaf = DomainCons "Leaf" [DomainArg Lazy "value" a']+    node = DomainCons "Node" [DomainArg Lazy "children" a_forest]+    forest = DomainType a_forest [empty, trees]+    empty = DomainCons "Empty" []+    trees = DomainCons "Trees"+      [DomainArg Lazy "" a_tree, DomainArg Strict "" a_forest]
+ tools/hs2isabelle/AST/Mixfix.hs view
@@ -0,0 +1,27 @@+module Mixfix where+import List (intersperse)++mixfix' :: String -> [ShowS] -> ShowS+mixfix' ('_':cs) (p:ps) = p . mixfix' cs ps+mixfix' ('\\':c:cs) ps = showChar c . mixfix' cs ps+mixfix' (c:cs) ps = showChar c . mixfix' cs ps+mixfix' _ _ = id++mixfix :: String -> [ShowS] -> Int -> Int -> ShowS+mixfix cs ps p0 p = showParen (p > p0) (mixfix' cs ps)++showSpace = showChar ' '+showLR l r x = showString l . x . showString r+showQuotes = showLR "\"" "\""+showBraces = showLR "{" "}"+showParens = showLR "(" ")"+showAngles = showLR "<" ">"+showSquares = showLR "[" "]"++showAll xs = foldr (.) id xs+showSep sep xs = showAll (intersperse sep xs)+showCommaSep = showSep (showChar ',')+showSpaceSep = showSep showSpace+showBarSep = showSep (showString " | ")++showTuple xs = showParens (showCommaSep xs)
+ tools/hs2isabelle/BaseStruct2Isabelle.hs view
@@ -0,0 +1,165 @@+{-++Reusable functions for translation from the (non-recursive) base structure+to Isabelle.+-}++module BaseStruct2Isabelle where+import IsabelleAST+import BaseSyntax -- non-recursive base syntax structure+import PrettyPrint(pp)+import PropSyntaxStruct(Q((:=>)))+import Char(isAlpha)++-- translate identifiers+transId x = pp x+{-+transId x = +  case orig x of+    G m n _ -> pp m++"."++pp n+    _ -> pp x+-}++-- translate literals+transL lit =+  case lit of+    HsInt   i  -> HInt i+    HsChar  c  -> not_supported "character literal" lit+    HsString s -> not_supported "string literal" lit+    HsFrac   x -> not_supported "fraction literal" lit++-- translate patterns+transP trId trP p =+  case mapPI trId trP p of+    HsPId (HsVar x) -> HVar x+    HsPId (HsCon c) -> HVar c+    HsPLit _ lit -> transL lit -- new+--  HsPSucc _ n l -> ...+    HsPInfixApp x op y -> HInfix x op y+    HsPApp c ps -> hApps (HVar c) ps+    HsPTuple s ps -> HTuple ps+    HsPList s ps -> HList ps+    HsPParen p -> p+--  HsPRec+    HsPAsPat _ _ -> not_supported "as-pattern" p+    HsPWildCard -> HVar "dummy" -- not_supported "wildcard pattern" p+    HsPIrrPat _ -> not_supported "irrefutable pattern" p+    _ -> not_supported "Pattern" p++-- translate declarations+transD trId trE trP trDs trT trC trTp d =+  case mapDI trId trE trP trDs trT trC trTp d of+    HsPatBind _ p rhs ds ->+      IsaFixrec (FixrecDecl [HMatches [HMatch p (transRhs rhs)]])+    HsFunBind _ ms ->+      IsaFixrec (FixrecDecl [HMatches (map transMatch ms)])+    HsTypeDecl _ tp t ->+      IsaTypes (TypesDecl tp t)+    HsDataDecl _ c tp cons ds ->+      IsaDomain (DomainDecl [DomainType tp (map transCon cons)])+    HsNewTypeDecl _ c tp con ds ->+      IsaDomain (DomainDecl [DomainType tp [transCon con]])+    {-+    HsClassDecl SrcLoc c tp (HsFunDeps i) ds |+    HsInstDecl SrcLoc (Maybe i) c t ds |+    HsDefaultDecl SrcLoc [t] |+    HsTypeSig SrcLoc [i] c t |+    HsInfixDecl SrcLoc HsFixity [HsIdentI i] |+    HsPrimitiveTypeDecl SrcLoc c tp |+    HsPrimitiveBind SrcLoc i t+    -}+    _ -> IsaComment (pp d)+  where+    transMatch (HsMatch _ i ps rhs ds) = if isAlpha (head i)+      then HMatch (hApps (HVar i) ps) (transRhs rhs)+      else case ps of [x,y] -> HMatch (HInfix x i y) (transRhs rhs)++    transRhs (HsBody e) = e+    transRhs _ = error "guarded rhs"+    +    transCon con =+      case con of+        HsConDecl loc _ _ c args -> DomainCons c (map transConArg args)+        HsRecDecl loc _ _ c args -> DomainCons c (concatMap transRecArg args)++    transConArg arg =+      case arg of+        HsBangedType t -> DomainArg Strict "" t+        HsUnBangedType t -> DomainArg Lazy "" t+    +    transRecArg (names, arg) =+      case arg of+        HsBangedType t -> [DomainArg Strict n t | n <- names]+        HsUnBangedType t -> [DomainArg Lazy n t | n <- names]+++-- translate expressions+transE trId trE trP trDs trT trC e =+  case mapEI trId trE trP trDs trT trC e of +    HsId (HsVar x)              -> HVar x+    HsId (HsCon c)              -> HVar c+    HsApp x y                   -> HApp x y+    HsLit _ lit                 -> transL lit -- new+    HsInfixApp x (HsVar op) z   -> HInfix x op z+    HsInfixApp x (HsCon c) z    -> HInfix x c z+    -- HsNegApp _ x                -> HVar "Prelude.negate" `HApp` x+    HsLambda ps e               -> hAbss ps e+    -- HsLet ds e                  -> HLet ds e+    HsIf x y z                  -> HIte x y z+    HsCase e alts               -> HCase e (map transAlt alts)+    HsTuple xs                  -> HTuple xs+    HsList xs                   -> HList xs+    HsParen x                   -> x+{-+    HsLeftSection x (HsVar op)  -> hleftsection x op +    HsRightSection (HsVar op) y -> hrightsection op y+    HsLeftSection x (HsCon c)   -> hConleftsection x c+    HsRightSection (HsCon c) y  -> hConrightsection c y+-}+    -- The following removed by the type checker too...+{-+    HsEnumFrom e1	       -> HVar "Prelude.enumFrom" `HApp` e1+    HsEnumFromTo e1 e2	       -> HVar "Prelude.enumFromTo" `HApp` e1 `HApp` e2+    HsEnumFromThen e1 e2	       ->+       HVar "Prelude.enumFromThen" `HApp` e1 `HApp` e2+    HsEnumFromThenTo e1 e2 e3   ->+       HVar "Prelude.enumFromThenTo" `HApp` e1 `HApp` e2 `HApp` e3+-}+    HsExpTypeSig _ e c t        -> HConstrain e t -- !! what about context?+    _ -> HVar (not_supported_msg "Expression" e) -- !!+  where+    -- translate case alternatives+    transAlt alt =+      case alt of+	HsAlt _ pat (HsBody rhs) _ -> HAlt pat rhs -- !!!+	 --_ -> not_supported "Case branch" "'where' clauses"+      --where+	--transRhs (HsBody e)       = e -- [NonGuarded e]+	--transRhs (HsGuard gdrhss) = undefined -- [Guarded g e|(_,g,e)<-gdrhss]++-- translate types+transT trId trT t =+  case mapTI trId trT t of+    HsTyFun t1 t2 -> TCfun t1 t2+    HsTyApp t1 t2 -> tApp t1 t2+    HsTyVar a -> tVar a+    HsTyCon c -> TType c []+    _ -> not_supported "Type" t++-- translate type declaration LHS+transTp trId trTp trTa t =+  case t of+    HsTyApp t1 t2 -> tApp (trTp t1) (trTa t2)+    HsTyCon c -> TType (trId c) []+    _ -> not_supported "LHS in type decl" t++-- translate type declaration argument LHS+transTa trId t =+  case t of+    HsTyVar a -> tVar (trId a)+    _ -> not_supported "Type parameter in LHS of type decl" t++-- translate qualified types+transQ trC trT (c:=>t) = trT t  -- ignore context for now++not_supported s x = error $ not_supported_msg s x+not_supported_msg s x = s++" not supported (yet): "++pp x
+ tools/hs2isabelle/Flags.ghc view
@@ -0,0 +1,1 @@+IsabelleCmds.hs: -fno-monomorphism-restriction
+ tools/hs2isabelle/IsabelleCmds.hs view
@@ -0,0 +1,91 @@+module IsabelleCmds where+import Prelude hiding (print)+import PFE0(pput,epput,getSubGraph)+import PFE3(parseModule)+import PFE4(rewriteAndTypeCheckModule,topTypes)+import PFE_Rewrites(fbRewrite,lcRewrite,flRewrite,pmRewrite,compRw,rwFun)+import HsModule(HsModuleI(..),hsModImportsFrom)+import PfeDepCmds(tdepgraph)+import PfeParse(moduleArg,qualId)+import PfePropCmds(baseNames)+import TiClasses(filterDefs,fromDefs)+import TiSCC(sccD')+import PFEdeps(tdefinedNames,splitDecls,isDefaultDecl)+import HsIdent(getHSName)+import MapDeclMProp() -- ?+import DefinedNames(addName,definedNames)+import FreeNames(freeNames)+--import TiPropInstances()+import TiProp() -- for PFE, instance CheckRecursion ...+import TiTypes(Scheme(Forall),Typing((:>:)),Qual((:=>)))+import RemoveListCompProp()+--import TiPropDecorate(TiDecl)+--import PNT(PNT)++import qualified Prop2Isabelle as P2I+import qualified IsabelleAST as AST+--import qualified PropDecorate2Isabelle2 as Ti2S+import SimpFunBind+import RemoveListComp+import SimpFieldLabels(simpFieldLabels)++import AbstractIO(print)+import MUtils(( # ),(@@),apSnd)+import Sets(mkSet,elementOf)+import PrettyPrint((<+>),pp)++isabelleCmds =+  [("isabelle", (moduleArg isabelle,"simple translation of one module to Isabelle")),+   ("isabelleslice", (qualId isabelleSlice,"translate a slice to Isabelle"))]++isabelleSlice qn = undefined -- slice' qn =<< transModule++isabelle m =+  do simplify <- rwFun $ foldr1 compRw [lcRewrite]+     let transM = simplify . addName+     parsed <- fmap snd (parseModule m)+     Just types <- fmap (lookup m) (topTypes (Just [m]))+     let decls1 = hsModDecls parsed+         decls2 = transM decls1+         decls3 = sccD2 decls2+         decls4 = map P2I.transDecs decls3+         decls5 = map P2I.combineDecls decls4+         decls6 = P2I.addConstsDecls (typetable types) decls5+         isamod = AST.Module (header parsed) decls6+     print isamod++sccD2 ds = sccD' names ds+  where names d = (map fst (definedNames d), map fst (freeNames d))++header m = (pp (hsModName m), map pp (hsModImportsFrom m))++typetable (_,(_,(_,(_,xs)))) = map f xs+  where f (i :>: (Forall _ _ (_ :=> t))) = (pp i, P2I.transType t)++{-+use function besides hsModDecls to get module name, imports, exports+topTypes [m] returns PFE4Info+-}+{-+transModule =+  do simplify <- rwFun $ foldr1 compRw [lcRewrite]+     let transM = P2I.transDecs . simplify . addName+     return transM++slice' q@(m,n) trans =+  do ms <- map (fst.snd) # getSubGraph (Just [m])+     (_,(_,_,used)) <- tdepgraph [q]+     let needed = mkSet used+     slices <- mapM (moduleSlice needed) ms+     let defs = concatMap trans slices+         isamod = P2I.defs2module "" [] defs+     print isamod++moduleSlice needed m =+    --filter isNeeded . t . splitDecls . fromDefs . hsModDecls # rewriteAndTypeCheckModule simplify m+    filter isNeeded . splitDecls . hsModDecls . snd # parseModule m+  where+    isNeeded d = isDefaultDecl d || isNeeded' d+    isNeeded' = any (`elementOf` needed) . map getHSName . tdefinedNames False m+    --t = id :: [TiDecl PNT] -> [TiDecl PNT]+-}
+ tools/hs2isabelle/Prop2Isabelle.hs view
@@ -0,0 +1,68 @@+{-++Knot-tying definitions for the base+property syntax to Isabelle translation.+-}++module Prop2Isabelle where+import BaseStruct2Isabelle(transP,transD,transE,transT,transTp,transTa,transId,transQ)+import PropStruct2Isabelle(transPD,transPA,transPP)+import PropSyntax+import IsabelleAST++combine :: IsaDecl -> IsaDecl -> IsaDecl+combine (IsaDomain (DomainDecl xs))+        (IsaDomain (DomainDecl ys)) = IsaDomain (DomainDecl (xs ++ ys))+combine (IsaFixrec (FixrecDecl xs))+        (IsaFixrec (FixrecDecl ys)) = IsaFixrec (FixrecDecl (xs ++ ys))+combine _ _ = error "Illegal mutual recursion"++combineDecls :: [IsaDecl] -> IsaDecl+combineDecls = foldr1 combine++fixrec2consts :: [(String,Type)] -> FixrecDecl -> ConstsDecl+fixrec2consts table (FixrecDecl xs) = ConstsDecl (zipWith TypeSig ns ts)+  where+    typeof n = case lookup n table of Just t -> t+    ns = map head_of_HMatches xs+    ts = map typeof ns++addConstsDecls :: [(String,Type)] -> [IsaDecl] -> [IsaDecl]+addConstsDecls table [] = []+addConstsDecls table (x:xs) = case x of+  IsaFixrec d -> IsaConsts (fixrec2consts table d) : x : addConstsDecls table xs+  _           -> x : addConstsDecls table xs++------------------------------------------------------------++--transPat :: PrintableOp i => HsPatI i -> P+transPat (Pat p) = transP transId transPat p++transDecs ds = map transDec ds++--transDec :: (IsSpecialName i,PrintableOp i) => HsDeclI i -> D+transDec (Dec d) =+    prop (transD transId transExp transPat transLocalDecs transType transContext transTlhs)+         (transPD transId transAssertion transPredicate)+         d++--transExp :: HsExp -> E+transExp (Exp e) =+    transE transId transExp transPat transLocalDecs transType transContext e++transAssertion (PA a) =+    transPA transId transExp transQType transAssertion transPredicate+            a++transPredicate (PP p) =+    transPP transId transExp transPat transQType transAssertion transPredicate+            p++transType (Typ t) = transT transId transType t+transContext ts = undefined -- map transType ts++transQType qt = transQ transContext transType qt++transLocalDecs ds = error "transLocalDecs"++transTlhs (Typ t) = transTp transId transTlhs transTarg t+  where+    transTarg (Typ t) = transTa transId t
+ tools/hs2isabelle/PropDecorate2Isabelle.hs view
@@ -0,0 +1,65 @@+{-++Knot-tying definitions for the base+property+typeinfo syntax to Isabelle+translation.+-}++module PropDecorate2Isabelle where+import BaseStruct2Isabelle(transP,transD,transE,transId)+import PropStruct2Isabelle(transPD,transPA,transPP)+import Prop2Isabelle(transQType,transType,transContext)+import qualified Prop2Isabelle as P2S(transPat)+import TiPropDecorate+import PropSyntaxStruct(prop)+import HasBaseStruct(hsId,hsPId)+import TiDecorate(TiPat(..))+import TiClasses(fromDefs,toDefs)+import IsabelleDecl++--transPat :: PrintableOp i => HsPatI i -> P+transPat (Pat p) = transP transId transPat p+transPat (TiPApp p1 p2) = transPat p2 -- !!!+transPat (TiPSpec i _ _) = transPat (hsPId i)+transPat (TiPTyped e t) = transPat e++rmIgnored = filter notIgnored+  where+    notIgnored (Ignored _) = False+    notIgnored _ = True++transDecs ds = map transDec ds++--transDec :: (IsSpecialName i,PrintableOp i) => HsDeclI i -> D+transDec (Dec d) =+    prop (transD transId transExp transPat transLocalDecs transType transContext transType)+         (transPD transId transOAssertion transPredicate)+         d++--transExp :: HsExp -> E+transExp (Exp e) =+    transE transId transExp transPat transLocalDecs transType transContext e+transExp (TiSpec i _ _) = transExp (hsId i)+transExp (TiTyped e t) = transExp e++transOAssertion (OA xs ds a) = {- ... -} transAssertion a -- !!!++transAssertion (PA a) =+  transPA transId transExp transQType transAssertion transPredicate+          a++transPredicate (PP p) =+  transPP transId transExp P2S.transPat transQType transAssertion transPredicate+          p++--transType (Typ t) = transT transId transType t+--transContext ts = map transType ts++--transQType qt = transQ transContext transType qt++--bad x = error "Base2Isabelle: not yet"+++transLocalDecs ds = concatMap transLocalDec (fromDefs ds)+transLocalDec d =+  case transDec d of+    Def (P def) -> [def]+    _ -> [] -- silently ignores unimplemented things!!!
+ tools/hs2isabelle/PropStruct2Isabelle.hs view
@@ -0,0 +1,80 @@+{-++Reusable functions for translation from the (non-recursive) P-Logic structure+to Isabelle.+-}++module PropStruct2Isabelle where+import IsabelleAST as S+import PropSyntaxStruct as P+import HsPropMaps+import PrettyPrint(pp)+import Maybe(fromMaybe)++-- translate property declarations: PD i pa pp -> IsaDecl+transPD trId trPA trPP pd =+  case mapPD trId trPA trPP pd of+    HsPropDecl _ n ns p ->+      IsaPredDecl (PredDecl (PredAbs n (map getHSName ns)) p)+    HsAssertion _ (Just n) a ->+      IsaPropDecl (PropDecl n a)+    _ -> IsaComment (pp pd)+    {-+  where+    transPredParam (HsCon c) = PredParam c+    transPredParam (HsVar x) = TermParam x+    -}+    --predParam (HsVar x) = "Not supported: Predicate definition: values as parameters" -- !!!++-- translate property assertions: PA i e t pa pp -> Prop+transPA trId trE trT trPA trPP pa =+  case mapPA trId trE trT trPA trPP pa of+    P.Quant P.All i optt pa -> propForall (i,optt) pa+    P.Quant P.Exist i optt pa -> propExists (i,optt) pa+    P.PropApp i ts [] -> PropVar i+    P.PropApp i ts es -> S.PropHas (map arg es) (PredVar i) -- !!+    P.PropNeg a -> S.PropNeg a+    P.PropOp op a1 a2 -> propOp op a1 a2+    P.PropEqual e1 e2 -> S.PropEqual e1 e2+    P.PropHas e p -> S.PropHas [TermArg e] p+    P.PropParen a -> a+    -- _ -> not_supported "Assertion" pa+  where+    propOp op =+      case op of+        P.Conj -> S.PropConj+        P.Disj -> S.PropDisj+        P.Imp  -> S.PropImpl+        P.Equiv-> S.PropEquiv++    arg = either TermArg PredArg+    -- bad _ = not_supported "Predicate application" "predicates as arguments"++-- translate predicate formulas: PP i e p t pa pp -> Pred+transPP trId trE trP trT trPA trPP pred =+  case mapPP trId trE trP trT trPA trPP pred of+    P.PredApp i ts [] -> S.PredVar i+    P.PredApp i ts ps -> S.PredCong i (map transPredArg ps) -- !!!+    P.PredArrow p1 p2 -> S.PredArrow p1 p2+    P.PredInfixApp p1 i p2 -> PredCong i (map PredArg [p1,p2])+    P.PredNeg optt p -> S.PredNeg p+    P.PredOp op optt p1 p2 -> predOp op p1 p2+    P.PredLfp i _ p -> S.PredLfp i p+    P.PredGfp i _ p -> S.PredGfp i p+    P.PredNil -> S.PredCong "Nil" []+    P.PredLifted e -> S.PredLifted e+    P.PredStrong p -> S.PredStrong p+    P.PredParen p -> p+    P.PredComp pts a -> S.PredComp (map fst pts) a+    -- _ -> not_supported "Predicate" pred+  where+    transPredArg = either TermArg PredArg+    --bad _ = not_supported "Predicate application" "values as arguments"++    predOp op =+      case op of+        P.Conj -> S.PredConj+        P.Disj -> S.PredDisj+        P.Imp  -> S.PredImpl+        P.Equiv-> S.PredEquiv++not_supported s x = error $ s++" not supported (yet): "++pp x
+ tools/hs2isabelle/tests/SPS.hs view
@@ -0,0 +1,61 @@+-- Synchronous stream processors+module SPS where++newtype S i o = S (i->(o,S i o))+feed (S sps) i = sps i+++runS _       []     = []+runS sps (i:is) = continue (feed sps i) is+continue c is = fst c:runS (snd c) is++mapS_sps f i = (f i,S (mapS_sps f))++mapS f = S (mapS_sps f)++mapAccumS_sps f s1 i =+  case f s1 i of (s2,o2) -> (o2,S (mapAccumS_sps f s2))++mapAccumS f s0 = S (mapAccumS_sps f s0)++--(>*<) :: S i1 o1 -> S i2 o2 -> S (i1,i2) (o1,o2)+sps1 >*< sps2 = S (sps_times sps1 sps2)+sps_times sps1 sps2 (i1,i2) =+  case feed sps1 i1 of+    (o1,s1) -> case feed sps2 i2 of+      (o2,s2) -> ((o1,o2), s1 >*< s2)++(>+<) :: S i1 o1 -> S i2 o2 -> S (Either i1 i2) (Either o1 o2)+sps1 >+< sps2 = S (sps_plus sps1 sps2)++sps_plus sps1 sps2 (Left  i1) = case feed sps1 i1 of (o1,sps1') -> (Left  o1,sps1'>+<sps2)+sps_plus sps1 sps2 (Right i2) = case feed sps2 i2 of (o2,sps2') -> (Right o2,sps1>+<sps2')++sps1 -<- sps2 = S (sps_compose sps1 sps2)+sps_compose sps1 sps2 i2 = +  case feed sps2 i2 of+    (o2,sps2') -> case feed sps1 o2 of+      (o1,sps1') -> (o1,sps1'-<-sps2')++assert Separation1 = {-#cert:Separation1#-}+  All sps1 . All sps2 . All is1 . All is2 .+  {runS (sps1>*<sps2) (zip is1 is2)} === {zip (runS sps1 is1) (runS sps2 is2)}+--{-+assert Separation2 =+  All sps1a . All sps1b . All sps2a . All sps2b .+  {(sps1a>*<sps1b)-<-(sps2a>*<sps2b)}===+  {(sps1a-<-sps2a)>*<(sps1b-<-sps2b)}+--}++assert Separation3 =+  All sps1 . All sps2 . All is .+  {split (runS (sps1>+<sps2) is)} ===+    {(runS sps1 (lefts is),runS sps2 (rights is))}++split zs = (lefts zs,rights zs)+lefts [] = []+lefts (Left x:zs) = x : lefts zs+lefts (Right _:zs) = lefts zs+rights [] = []+rights (Left _:zs) = rights zs+rights (Right x:zs) = x : rights zs
+ tools/hs2isabelle/tests/SPS_Proofs.thy view
@@ -0,0 +1,24 @@+theory SPS_Proofs+imports SPS+begin++fixpat runS_strict [simp]: "runS\<cdot>x\<cdot>\<bottom>"++lemma Separation1:+  "ALL is1 is2 sps1 sps2.+    runS$(sps1 `>*< sps2)$(zip$is1$is2) =+    zip$(runS$sps1$is1)$(runS$sps2$is2)"+ apply (rule allI)+ apply (rule_tac x=is1 in L0.ind)+    apply (simp_all)+ apply (rule allI)+ apply (rule_tac x=is2 in L0.casedist)+   apply (simp_all)+ apply (rule allI)+ apply (rule_tac p="feed\<cdot>sps1\<cdot>a" in cprodE)+ apply (rule allI)+ apply (rule_tac p="feed\<cdot>sps2\<cdot>aa" in cprodE)+ apply simp+done++end
+ tools/hs2stratego/AST/Parentheses.hs view
@@ -0,0 +1,23 @@+{-++The Stratego syntax for terms is what one gets with derived Show+instances in Haskell, except for constructors with exactly one argument,+which have to be wrapped in parentheses. We use the type P below to+get explicit parentheses from the derived Show instances.++(We use tuples for constructors with more than one argument, so they+will be printed as expected by Stratego, but there are no tuples of+arity 1 in Haskell...)+-}+module Parentheses where++newtype P a = P a deriving (Eq,Ord)++instance Show a => Show (P a) where+  showsPrec n (P x) = showString "(" . shows x . showString ")"++{- -- not needed at the moment...+instance Read a => Read (P a) where+  readsPrec n s = [(P x,r)| ("(",r0)<-lex s,+			    (x,r1)<-reads r0,+			    (")",r)<-lex r1]+-}
+ tools/hs2stratego/AST/StrategoAST2.hs view
@@ -0,0 +1,6 @@+module StrategoAST2(module AST) where+import StrategoPattern as AST+import StrategoTerm as AST+import StrategoType as AST+import StrategoProp as AST+import StrategoDecl as AST
+ tools/hs2stratego/AST/StrategoDecl.hs view
@@ -0,0 +1,18 @@+module StrategoDecl where+import StrategoTerm(Def)+import StrategoProp(PredDecl,PropDecl)+import Parentheses++-- For top level declarations:++data Decl+  = Def (P Def)+  | Property (P PredDecl)+  | Assert (P PropDecl)+  | Ignored (P String)+  deriving (Show{-,Read-})++def = Def . P+property = Property . P+assert = Assert . P+ignored = Ignored . P
+ tools/hs2stratego/AST/StrategoPattern.hs view
@@ -0,0 +1,44 @@+module StrategoPattern where+import Parentheses++data Literal+  = HInt (P Integer)+  | HChar (P String) -- character literals in Stratego?+  | HString (P String) -- desugar into list of characters?+  | HFrac (P Rational)+  deriving (Show{-,Read-})++hInt = HInt. P+hChar = HChar . P+hString = HString . P+hFrac = HFrac . P++data Pattern+  = NoPattern+  | NewPattern (P String)+  | WildCard+  | VarPat (P String)+  | ConstrPat (String, [Pattern])+  | AsPattern (String, Pattern)+  | TuplePat (P [Pattern])+  | LitPat (P Literal) -- new+{- old+  | LitPat (P Integer)+  | CharLitPat (P Char)+  | StringLitPat (P String)+-}+  | TwiddlePat (P Pattern)++  | FunPat (String, [Pattern])+  deriving (Show{-,Read-})++varPat = VarPat . P+tuplePat = TuplePat . P+litPat = LitPat . P+--charLitPat = CharLitPat . P+--stringLitPat = StringLitPat . P+twiddlePat = TwiddlePat . P++pcons x xs = ConstrPat (":", [x,xs])+pnil = ConstrPat ("[]", [])+plist = foldr pcons pnil
+ tools/hs2stratego/AST/StrategoProp.hs view
@@ -0,0 +1,113 @@+module StrategoProp where+import StrategoTerm+import StrategoPattern+import StrategoType+import Parentheses++--signature  sorts Sequent Rule++data Sequent+  = Valid+  | Consequence ([Prop], [Prop])+  deriving (Show{-,Read-})++data Rule+   = Conclude ([Sequent], Sequent)+  deriving (Show{-,Read-})+++--signature   sorts Prop PropDecl Qvar++data Prop+  = True                                         {- truth value -}+  | False                                        {- truth value -}+  | PropVar     (P String)                       {- Propositional variable -}+  | Has         (Term, Pred)                     {- Unary predicate applic. -}+  | HasMult     ([Term], Pred)                   {- k-ary predicate applic. -}+  | Equal       (Term, Term)                     {- equality assertion -}+  | Conj        (P [Prop])                       {- propositional conjunct -}+  | Disj        (P [Prop])                       {- propositional disjunct -}+  | Implies     ([Prop], Prop)                   {- implication chain -}+  | Equiv       (Prop, Prop)                     {- equivalence -}+  | Neg         (P Prop)                         {- negation -}+  | Quant       ([Qvar], Prop)                   {- quantified proposition -}+  deriving (Show{-,Read-})++propVar = PropVar . P+propConj = Conj . P+propDisj = Disj . P+propNeg = Neg . P++data Qvar+  = All         (String, Type)                   {- universal quantification -}+  | Exists      (String, Type)                   {- existential  quantification -}+  deriving (Show{-,Read-})++type Identifier = String -- ??++data PropDecl+  = PropDecl   (Identifier, Prop)                {- prop. declaration -}+  deriving (Show{-,Read-})+++--signature sorts Pred PredPat PredFormula PredDecl++data Pred+{-  PredConst : String -> Pred -}           {- predicate constant -}+  = Univ+  | UnDef+--  Just        Pred                          {- case match predicate -}+--  Nothing                                   {- match failure predicate -}+  | Arrow       (Pred, Pred)                  {- arrow predicate -}+  | LfpPred     (String, Pred)                {- least fixed-point predicate -}+  | GfpPred     (String, Pred)               {- greatest fixed-point predicate-}+--  PredRef     Identifier                    {- predicate reference ? -}+  | PredVar     (P Identifier)                {- predicate variable -}+  | LiftedSec   (P Term)                      {- lifted section predicate -}+--  PredSect    Pred * Int                    {- predicate section  (1 or 2) -}+  | PredNeg     (P Pred)                      {- negated predicate -}+  | Strong      (P Pred)                      {- strengthened predicate -}+--  TypedPred   Pred * Type                   {- explicitly typed predicate -}+  | TuplePred   (P [Pred])                    {- tuple predicate -}+  | LitPred     (P Int)                       {- literal predicate -}+  | DataCong    (String, [PredArg])           {- constructor congruence pred. -}+--  PredInst    String * [Term]               {- predicate instance -}+  | Comprehension ([Pattern], Prop)           {- set comprehension -}+  | PredDisj    (P [Pred])                    {- pred. disjunction -}+  | PredConj    (P [Pred])                    {- pred. conjunction -}+  | PredImpl    ([Pred], Pred)                {- pred. implication chain -}+  | PredEquiv   (Pred, Pred)                  {- pred. equivalence -}+  deriving (Show{-,Read-})++predVar = PredVar . P+liftedSec = LiftedSec . P+predNeg = PredNeg . P+strong = Strong . P+tuplePred = TuplePred . P+litPred = LitPred . P+predDisj = PredDisj . P+predConj = PredConj . P++data PredArg+  = TermArg (P Term)+  | PredArg (P Pred)+  deriving (Show)++termArg = TermArg . P+predArg = PredArg . P++data PredPat+  = PredAbs    (String, [Param])  {- pred. abstraction -}+  deriving (Show{-,Read-})++data Param+  = TermParam (P String)+  | PredParam (P String)+  deriving (Show)++termParam = TermParam . P+predParam = PredParam . P++data PredDecl+  = PredDecl   (PredPat, Pred)            {- pred. declaration -}+  deriving (Show{-,Read-})
+ tools/hs2stratego/AST/StrategoTerm.hs view
@@ -0,0 +1,96 @@+module StrategoTerm where+import StrategoPattern+import StrategoType+import Parentheses++data Term+  = HVar (P String)+  | HLit (P Literal)+{- old+  | HLit (P Integer)+  | HCharLit (P Char)+  | HStringLit (P String)+-}+  | HNeg (P Integer) -- just for negated literals+  | HApp (Term, Term)+  | HTuple (P [Term])+  | HCon (String, [Term])+  | HAbs (Pattern, Term) -- should probably be [Pattern]+  | HLet ([Def], Term)+  | HCase (Term, [HBranch])+  | HIte (Term, Term, Term) -- if-then-else+  | HCompose (Term, Term) -- not used+  | TypedVar (String, Type)+  | HConst (P String)             -- Skolem constant+    {- Let is introduced for primarily for alpha conversion.+       It represents an explicit substitution                -}+  | Let  ([Binding], Term)+  deriving (Show{-,Read-})++hVar = HVar . P+hLit = HLit . P+--hCharLit = HCharLit . P+--hStringLit = HStringLit . P+hNeg = HNeg . P+hTuple = HTuple . P+hConst = HConst . P++hlet [] e = e+hlet ds e = HLet (ds,e)++happ = curry HApp+habs1 = curry HAbs+habs ps e = foldr habs1 e ps+-- Wrong strictness, \ p1 p2 -> e is not the same as \ p1 -> \ p2 -> e !!!+++-- List constructors:+hlist = foldr hcons hnil+  where hcons x xs = HCon ("Prelude.:", [x,xs])+        hnil = HCon ("[]", [])++-- Sections+hleftsection x op = hVar op `happ` x+hrightsection op y = HAbs (zp, hVar op `happ` ze `happ` y)+hconleftsection x op = HAbs (zp,HCon (op,[x,ze])) -- constructor arity?+hconrightsection op y = HAbs (zp, HCon (op, [ze,y])) -- constructor arity?++z = "zzz"+zp = varPat z+ze = hVar z++nomatch = hVar "Prelude.undefined"++data HBranch+  = HBranch (Pattern, [GuardedTerm]) -- ??+  deriving (Show{-,Read-})++data Def+  = HDef (Pattern, Term)          -- Not quite right; should be an App-Pattern+				  -- but we assume defns are put into a normal+				  -- form by explicit abstraction on the rhs.+  | TSyn (String,[String],Type)+  | TData (String,[String],[DataDecl])+  | TNew (String,[String],DataDecl)+  deriving (Show{-,Read-})++tSyn (c,vs) t = TSyn (c,vs,t)+tData (c,vs) cons = TData (c,vs,cons)+tNew (c,vs) con = TNew (c,vs,con)++data Binding+  = Elt (String, Term)+  deriving (Show{-,Read-})++data GuardedTerm+  = Guarded (Term, Term)+  | NonGuarded (P Term)+  deriving (Show{-,Read-})++nonGuarded = NonGuarded . P++{-+data AbsPat+  = AbstArrow (Pattern, [GuardedTerm])+  deriving (Show{-,Read-})+-}
+ tools/hs2stratego/AST/StrategoType.hs view
@@ -0,0 +1,30 @@+module StrategoType where+import Parentheses++data Type+  = TVar (P String)+  | TConst (P String)+  | TTuple (P [Type])+  | TInst (String,[Type])+  | TArrow (Type, Type)+  | TApp (Type, Type)+  deriving (Show{-,Read-})++data DataDecl+  = DCons (String,[(Strictness,Type)])+  deriving (Show{-,Read-})++data Strictness = Lazy | Strict+  deriving (Show{-,Read-})++tVar = TVar . P+tConst = TConst . P+tTuple = TTuple . P++tApp = curry TApp+tInst = curry TInst++tarrow = curry TArrow+tarrows ts t = foldr tarrow t ts++dCons = curry DCons
+ tools/hs2stratego/Base2Stratego2.hs view
@@ -0,0 +1,5 @@+module Base2Stratego2 where+import BaseStruct2Stratego2+import Syntax(HsPatI(..))++transPat (Pat p) = transP transId transPat p
+ tools/hs2stratego/BaseStruct2Stratego2.hs view
@@ -0,0 +1,196 @@+{-++Reusable functions for translation from the (non-recursive) base structure+to Stratego.+-}++module BaseStruct2Stratego2 where+import StrategoAST2+import BaseSyntax -- non-recursive base syntax structure+import PrettyPrint(pp)+import UniqueNames(orig,Orig(G))+import TypedIds(IdTy(..),idTy)+import TiDefinedNames(definedTypeName)+import DefinedNames(contextSize)+import TiNames(superName)+import Parentheses++transId x = +  case orig x of+    G m n _ -> pp m++"."++pp n+    _ -> pp x++transL lit =+  case lit of+    HsInt   i  -> hInt i+    HsChar  c  -> hChar [c]+    HsString s -> hString s -- desugar into list of characters?+    HsFrac   x -> hFrac x++transPId i =+  case i of+    HsVar x -> varPat x+    HsCon c -> ConstrPat (c,[])++transP trId trP p =+ case mapPI trId trP p of+   HsPId i -> transPId i+   HsPLit _ lit -> litPat (transL lit) -- new+{- old+   HsPLit _ (HsInt _ i) -> litPat i+   HsPLit _ (HsChar c) -> charLitPat c+   HsPLit _ (HsString s) -> stringLitPat s+-- other literals...+-}+-- HsPSucc _ n l -> ...+   HsPInfixApp x op y -> ConstrPat (op,[x,y])+   HsPApp c ps -> ConstrPat (c,ps)+   HsPTuple s ps -> tuplePat ps+   HsPList s ps -> plist ps+   HsPParen p -> p+-- HsPRec+   HsPAsPat x p -> AsPattern (x,p)+   HsPWildCard -> WildCard+   HsPIrrPat p -> twiddlePat p+   _ -> not_supported "Pattern" p+++transD trId trE trP trDs trT trC trTp d =+ case d of+   HsClassDecl loc c tp fd ds -> defs (transClassDecl tp)+   HsInstDecl loc (Just n) c t ds -> onedef (transInstDecl n c t ds) +   _ ->+     case mapDI trId trE trP trDs trT trC trTp d of+       HsPatBind loc p rhs ds -> onedef (HDef (p, hlet ds (transRhs rhs)))+       HsFunBind _ [HsMatch _ f ps rhs ds] ->+		onedef (HDef (varPat f,habs ps (hlet ds (transRhs rhs))))+       HsTypeDecl loc tp t -> onedef (tSyn tp t)+       HsDataDecl loc c tp cons ds -> onedef (tData tp (map transCon cons))+       HsNewTypeDecl loc c tp con ds -> onedef (tNew tp (transCon con))+       _ -> [ignored (pp d)]+  where+    onedef d = [def d]+    defs = map def++    transRhs (HsBody e) = e+    transRhs (HsGuard triples) = foldr guard nomatch triples+      where+        guard (loc,guard,body) therest = HIte(guard,body,therest)++    transCon con =+      case con of+        HsConDecl loc _ _ c args -> dCons c (map transConArg args)+        HsRecDecl loc _ _ c args ->+            dCons c [a'|(fs,a)<-args,let a'=transConArg a,f<-fs]++    transConArg arg =+      case arg of+        HsBangedType t -> (Strict,t)+	HsUnBangedType t -> (Lazy,t)++    {-+ Classes are translated to tuple types. The methods are translated+        to tuple field selector functions. -}+    transClassDecl tp =+      case idTy cn of+        Class cnt ms ->+	    [selector i (superName cn (i+1)) | i<-[0..cnt-1]] +++            zipWith selector [cnt..] ms+	  where+	    arity = cnt+length ms+	    selector i m = HDef (varPat m',habs1 (tpat i) ze)+	      where+		m' = transId m+		tpat i = tuplePat [pick j|j<-[0..arity-1]]+		  where pick j = if j==i then zp else WildCard+       where+         cn = definedTypeName tp++    {-+ Instances are translated into tuple definitons... -}	+    transInstDecl n ctx inst ds =+      case idTy cn of+        Class cnt ms ->+            HDef (varPat n',+		  habs (map varPat dicts) (hTuple (map findDef ms')))+	  where+	    ms' = map (transId . superName cn) [1..cnt]++map transId ms+	    ds' = trDs ds+	    arity = cnt+length ms+	    n' = transId n+	    dicts = ["d"++show i|i<-[1..contextSize ctx]]++            findDef m =+	      case [ e | (HDef (VarPat (P m'),e))<-ds',m'==m] of+	        [e] -> foldl happ e (map hVar dicts)+       where+         cn = definedTypeName inst++transEId i =+  case i of+    HsVar x -> hVar x+    HsCon c -> HCon (c,[])++transE trId trE trP trDs trT trC e =+ case mapEI trId trE trP trDs trT trC e of +   HsId i                      -> transEId i+   HsApp x y                   -> x `happ` y+   HsLit _ lit                 -> hLit (transL lit) -- new+{- old+   HsLit _ (HsInt _ i)         -> hLit i+   HsLit _ (HsChar c)          -> hCharLit c+   HsLit _ (HsString s)        -> hStringLit s+-}+-- other literals...+   HsInfixApp x (HsVar op) z   -> hVar op `happ` x `happ` z+   HsInfixApp x (HsCon c) z    -> HCon (c,[x,z]) -- !! constructor arity?+   HsNegApp _ x                -> hVar "Prelude.negate" `happ` x+   HsLambda ps e               -> habs ps e+   HsLet ds e                  -> hlet ds e+   HsIf x y z                  -> HIte (x, y, z)+   HsCase e alts               -> HCase (e,map transAlt alts)+   HsTuple xs                  -> hTuple xs+   HsList xs                   -> hlist xs+   HsParen x                   -> x+   HsLeftSection x (HsVar op)  -> hleftsection x op +   HsRightSection (HsVar op) y -> hrightsection op y+   HsLeftSection x (HsCon c)   -> hconleftsection x c+   HsRightSection (HsCon c) y  -> hconrightsection c y+   -- The following removed by the type checker too...+   HsEnumFrom e1	       -> hVar "Prelude.enumFrom" `happ` e1+   HsEnumFromTo e1 e2	       -> hVar "Prelude.enumFromTo" `happ` e1 `happ` e2+   HsEnumFromThen e1 e2	       ->+       hVar "Prelude.enumFromThen" `happ` e1 `happ` e2+   HsEnumFromThenTo e1 e2 e3   ->+       hVar "Prelude.enumFromThenTo" `happ` e1 `happ` e2 `happ` e3+   HsExpTypeSig _ e c t        -> e -- !!+   _ -> hVar (not_supported_msg "Expression" e) -- !!+  where+    transAlt alt =+      case alt of+	 HsAlt loc pat rhs _ -> HBranch (pat,transRhs rhs) -- !!!+	 --_ -> not_supported "Case branch" "'where' clauses"+      where+	transRhs (HsBody e)       = [nonGuarded e]+	transRhs (HsGuard gdrhss) = [Guarded (g,e)|(_,g,e)<-gdrhss]+++transT trId trT t =+  case mapTI trId trT t of+    HsTyFun t1 t2 -> TArrow (t1,t2)+    HsTyApp t1 t2 -> tApp t1 t2+    HsTyVar a -> tVar a+    HsTyCon c -> tConst c+    _ -> not_supported "Type" t++transTp trId trTp trTa t =+  case t of+    HsTyApp t1 t2 -> (c,vs++[trTa t2])+      where (c,vs) = trTp t1+    HsTyCon c -> (trId c,[])+    _ -> not_supported "LHS in type decl" t++transTa trId t =+  case t of+    HsTyVar a -> trId a+    _ -> not_supported "Type parameter in LHS of type decl" t++not_supported s x = error $ not_supported_msg s x+not_supported_msg s x = s++" not supported (yet): "++pp x
+ tools/hs2stratego/Flags.ghc view
@@ -0,0 +1,1 @@+StrategoCmds.hs: -fno-monomorphism-restriction
+ tools/hs2stratego/HEADER.html view
@@ -0,0 +1,15 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<head>+<title>Programatica Tools, tools/hs2stratego</title>+<link rel=parent href="../" title="Programatica Tools">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../web/icon1.png">+</head>+<body>+<h1><img align=right src="../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/hs2stratego</h2>++The README file is displayed below the directory index.
+ tools/hs2stratego/Prop2Stratego2.hs view
@@ -0,0 +1,54 @@+{-++Knot-tying definitions for the base+property syntax to Stratego translation.+-}++module Prop2Stratego2 where+import BaseStruct2Stratego2(transP,transD,transE,transT,transTp,transTa,transId,not_supported)+import PropStruct2Stratego2(transPD,transPA,transPP,transQ)+import PropSyntax+import StrategoDecl+import Parentheses -- needed for pattern matching. Grr!!++--transPat :: PrintableOp i => HsPatI i -> P+transPat (Pat p) = transP transId transPat p++rmIgnored = filter notIgnored+  where+    notIgnored (Ignored _) = False+    notIgnored _ = True++transDecs ds = concatMap transDec ds++--transDec :: (IsSpecialName i,PrintableOp i) => HsDeclI i -> D+transDec (Dec d) =+    prop (transD transId transExp transPat transLocalDecs transType transContext transTlhs)+         ((:[]) . transPD transId transAssertion transPredicate)+         d++--transExp :: HsExp -> E+transExp (Exp e) =+    transE transId transExp transPat transLocalDecs transType transContext e++transAssertion (PA a) =+    transPA transId transExp transQType transAssertion transPredicate+            a++transPredicate (PP p) =+    transPP transId transExp transPat transQType transAssertion transPredicate+            p++transType (Typ t) = transT transId transType t+transContext ts = map transType ts++transQType qt = transQ transContext transType qt++--bad x = error "Base2Stratego: not yet"+++transLocalDecs ds = concatMap transLocalDec ds+transLocalDec d = [def|Def (P def)<-transDec d]+                  -- silently ignores unimplemented things!!!++transTlhs (Typ t) = transTp transId transTlhs transTarg t+  where+    transTarg (Typ t) = transTa transId t
+ tools/hs2stratego/PropDecorate2Stratego2.hs view
@@ -0,0 +1,67 @@+{-++Knot-tying definitions for the base+property+typeinfo syntax to Stratego+translation.+-}++module PropDecorate2Stratego2 where+import BaseStruct2Stratego2(transP,transD,transE,transId,not_supported)+import PropStruct2Stratego2(transPD,transPA,transPP)+import Prop2Stratego2(transQType,transType,transTlhs,transContext)+import qualified Prop2Stratego2 as P2S(transPat)+import TiPropDecorate+import PropSyntaxStruct(prop)+import HasBaseStruct(hsId,hsPId)+import TiDecorate(TiPat(..))+import TiClasses(fromDefs)+import StrategoDecl+import Parentheses -- needed for pattern matching. Grr!!++--transPat :: PrintableOp i => HsPatI i -> P+transPat (Pat p) = transP transId transPat p+transPat (TiPApp p1 p2) = transPat p2 -- !!!+transPat (TiPSpec i _ _) = transPat (hsPId i)+transPat (TiPTyped e t) = transPat e+{-+rmIgnored = filter notIgnored+  where+    notIgnored (Ignored _) = False+    notIgnored _ = True+-}+transDecs ds = transDecs' (fromDefs ds)+transDecs' ds = map transDec ds++--transDec :: (IsSpecialName i,PrintableOp i) => HsDeclI i -> D+transDec (Dec d) =+    prop (transD transId transExp transPat transLocalDecs transType transContext transTlhs)+         (transPD transId transOAssertion transPredicate)+         d++--transExp :: HsExp -> E+transExp (Exp e) =+    transE transId transExp transPat transLocalDecs transType transContext e+transExp (TiSpec i _ _) = transExp (hsId i)+transExp (TiTyped e t) = transExp e++transOAssertion (OA xs ds a) = {- ... -} transAssertion a -- !!!++transAssertion (PA a) =+  transPA transId transExp transQType transAssertion transPredicate+          a++transPredicate (PP p) =+  transPP transId transExp P2S.transPat transQType transAssertion transPredicate+          p++--transType (Typ t) = transT transId transType t+--transContext ts = map transType ts++--transQType qt = transQ transContext transType qt++--bad x = error "Base2Stratego: not yet"+++transLocalDecs ds = concatMap transLocalDec (fromDefs ds)+transLocalDec d =+  case transDec d of+    Def (P def) -> [def]+    _ -> [] -- silently ignores unimplemented things!!!
+ tools/hs2stratego/PropStruct2Stratego2.hs view
@@ -0,0 +1,81 @@+{-++Reusable functions for translation from the (non-recursive) P-Logic structure+to Stratego.+-}++module PropStruct2Stratego2 where+import StrategoAST2 as S+import PropSyntaxStruct as P+import HsPropMaps+import HsPropPretty()+import PrettyPrint(pp)+import Maybe(fromMaybe)++transPD trId trPA trPP pd =+  case mapPD trId trPA trPP pd of+    HsPropDecl s n ns p -> property (PredDecl (PredAbs (n,map transPredParam ns),p))+    HsAssertion s (Just n) a -> assert (PropDecl (n,a))+    _ -> ignored (pp pd)+  where+    transPredParam (HsCon c) = predParam c+    transPredParam (HsVar x) = termParam x+    --predParam (HsVar x) = "Not supported: Predicate definition: values as parameters" -- !!!++transPA trId trE trT trPA trPP pa =+  case mapPA trId trE trT trPA trPP pa of+    P.Quant q i optt pa -> S.Quant ([quant q (i,t)],pa)+      where t = fromMaybe (tVar "dummy") optt+    PropApp i ts [] -> propVar i+    PropApp i ts es -> HasMult (map predArg es,predVar i) -- !!+    PropNeg a -> propNeg a+    PropOp op a1 a2 -> propOp op a1 a2+    PropEqual e1 e2 -> Equal (e1, e2)+    PropHas e p -> Has (e,p)+    PropParen a -> a+    _ -> not_supported "Assertion" pa+  where+    quant q =+      case q of+        P.All -> S.All+	Exist -> Exists++    propOp op a1 a2 =+      case op of+        P.Conj -> propConj [a1,a2]+        P.Disj -> propDisj [a1,a2]+        P.Imp  -> Implies ([a1],a2)+        P.Equiv-> S.Equiv (a1,a2)++    predArg = either id bad+    bad _ = not_supported "Predicate arguments" pa++transPP trId trE trP trT trPA trPP pred =+  case mapPP trId trE trP trT trPA trPP pred of+    PredApp i ts [] -> predVar i+    PredApp i ts ps -> DataCong (i,map transPredArg ps) -- !!!+    PredArrow p1 p2 -> Arrow (p1,p2)+    PredInfixApp p1 i p2 -> DataCong (i,map predArg [p1,p2])+    P.PredNeg optt p -> predNeg p+    PredOp op optt p1 p2 -> predOp op p1 p2+    PredLfp i _ p -> LfpPred (i,p)+    PredGfp i _ p -> GfpPred (i,p)+    PredNil -> DataCong ("[]",[])+    PredLifted e -> liftedSec e+    PredStrong p -> strong p+    PredParen p -> p+    PredComp pts a -> Comprehension (map fst pts,a)+    _ -> not_supported "Predicate" pred+  where+    transPredArg = either termArg predArg+    --bad _ = not_supported "Predicate application" "values as arguments"++    predOp op a1 a2 =+      case op of+        P.Conj -> predConj [a1,a2]+        P.Disj -> predDisj [a1,a2]+        P.Imp  -> PredImpl ([a1],a2)+        P.Equiv-> PredEquiv (a1,a2)++transQ trC trT (c:=>t) = tarrows ({-map tPred-} (trC c)) (trT t) -- ???++not_supported s x = error $ s++" not supported (yet): "++pp x
+ tools/hs2stratego/README.html view
@@ -0,0 +1,112 @@+<h2>What is in this directory (hs2stratego)</h2>+<div>+The code in this directory implements a simple translation of Haskell code+to the Stratego representation defined in ../../Plogic. There is one new+pfe command:++<pre>+    pfe stratego M+</pre>++For the time being, it translates a Haskell module M to a list of Decl (defined+below). Unsupported forms of declarations are ignored. The translation is+made before type checking.+<p>+The command <code>pfe prove</code>, which provided an earlier version of+the translation to Stratego, has been removed. The code is still available+in <a href="../Phugs/"><code>../Phugs</code</a>.+</div>++<h3>Files</h3>++<div>+<p>The subdirectory <code>AST</code> contains the Haskell implementation of the+abstract syntax in <code>../../Plogic</code>:</p>++<table>+<tr><th>File<th>Corresponds to+<tr><td>AST/StrategoPattern.hs		<td>Pattern.r+<tr><td>AST/StrategoProp.hs		<td>Prop.r, Pred.r+<tr><td>AST/StrategoTerm.hs		<td>Term.r+<tr><td>AST/StrategoType.hs		<td>Type.r+<tr><td>AST/StrategoDecl.hs		<td>a type for top-level declarations+<tr><td>AST/StrategoAST2.hs		<td>collects and re-exports all+</table>++<p>+This directory contains the translation functions and the code to hook+into the PFE framework.</p>++<table>+<tr><th>File<th>Purpose+<tr><td>StrategoCmds.hs			<td> hook it into the PFE framework+<tr><td>BaseStruct2Stratego2.hs		<td> base syntax translation+<tr><td>PropStruct2Stratego2.hs		<td> P-logic translation+<tr><td>Prop2Stratego2.hs		<td> knot-tying definitions+<tr><td>Flags.ghc                       <td> compiler flags for GHC+</table>+</div>+<h3>About the translation</h3>+++<ul>+<li>A new data type for top-level declarations have been introduced,+see <a href="AST/StrategoDecl.hs">AST/StrategoDecl.hs</a>.+<li>+All top-level names are replaced with their original name (qualified name).+<li>+Function bindings and list comprehensions are simplified as in the+Haskell&nbsp;98 report.+<li>+The output is produced by using derived <code>Show</code> instances,+so these has to be an <strong>exact</strong> correspondence between+the Haskell data types in the AST directory and the data structures+expected in Stratego.+</ul>++<h3>Changes that should be made in the Stratego files</h3>++<ul>+<li>Some constructors names with hyphen have to be renamed:+    <ul>+    <li>     Prop-decl ==> PropDecl+    <li>     Lfp-Pred ==> LfpPred+    <li>     Gfp-Pred ==> GfpPred+    <li>     Pred-abs ==> PredAbs+    <li>     Pred-decl ==> PredDecl+    </ul>+<li>+The sort HBranch used in the constructor HCase isn't declared.+The result of the constructor HBranch is declared to be Term, but should+presumably be HBranch.+</ul>++<h3>Other things TODO</h3>++<ul>+<li>+HAbs takes a single pattern, but should probably take a list of patterns, since+      "\ p1 p2 -> e" is not the same as "\ p1 -> \ p2 -> e".++<li>+Make room for literals other than integers (strings, characters, fractional)+<li>+Make room for the record syntax (or translate it away).+<li>+Make sure the translation of types makes sense.+<li>+Make room for qualified types.+<li>+Make room for negation in patterns?+<li>+Make room for the equivalence connective <==>.+<li>+Are constructor applications assumed to be saturated?+<li>+Make room for type signatures in expressions, e.g. (+)::(Int->Int->Int)+<li>+...+</ul>+<hr>+<address>Authors: TH</address>+<address>Contact: <a href="http://www.cse.ogi.edu/~hallgren/">TH</address>
+ tools/hs2stratego/StrategoCmds.hs view
@@ -0,0 +1,100 @@+module StrategoCmds where+import Prelude hiding (print)+import PFE0(pput,epput,getSubGraph)+import PFE3(parseModule)+import PFE4(rewriteAndTypeCheckModule)+import PFE_Rewrites(fbRewrite,lcRewrite,flRewrite,pmRewrite,compRw,rwFun)+import HsModule(hsModDecls)+import PfeDepCmds(tdepgraph)+import PfeParse+import PfePropCmds(baseNames)+import TiClasses(filterDefs,fromDefs)+import PFEdeps(tdefinedNames,splitDecls,isDefaultDecl)+import HsIdent(getHSName)+import MapDeclMProp() -- ?+import DefinedNames(addName)+import TiPropInstances()+import TiProp() -- for PFE, instance CheckRecursion ...+import RemoveListCompProp()+import SimpPatMatchProp()+--import TiPropDecorate(TiDecls)+--import PNT(PNT)++import qualified Prop2Stratego2 as P2S+--import qualified PropDecorate2Stratego2 as Ti2S+import qualified TiProp2Stratego2 as Ti2S++import AbstractIO(print)+import MUtils(( # ),(@@),apSnd)+import Sets(mkSet,elementOf)+import PrettyPrint((<+>))++strategoCmds =+  [("stratego", (tModuleArg stratego,"translation of one module to Stratego")),+   ("strategoslice", (tQualId strategoSlice,"translate a slice to Stratego")){-,+   ("tstratego", (moduleArg tstratego,"resolve overloading and translate one module to Stratego")),+   ("tstrategoslice", (qualId tstrategoSlice,"resolve overloading and translate a slice to Stratego"))-}]+++tModuleArg = moduleArg' untyped++tQualId cmd = f #@ untyped <@ arg "<M.x>"+  where f u = cmd u @@ parseQualId++untyped = kwOption "-untyped"++stratego untyped = if untyped then ustratego else tstratego+strategoSlice untyped = if untyped then ustrategoSlice else tstrategoSlice++--------------------------------------------------------------------------------++ustrategoSlice qn = slice' qn =<< transModule++ustratego m =+  do transM <- transModule+     (print.transM.hsModDecls . snd) =<< parseModule m++transModule =+  do simplify <- rwFun $ foldr1 compRw [fbRewrite,lcRewrite,flRewrite]+     let transM = P2S.rmIgnored . P2S.transDecs . simplify . addName+     return transM+++slice' q@(m,n) trans =+  do ms <- map (fst.snd) # getSubGraph (Just [m])+     (_,(_,_,used)) <- tdepgraph [q]+     let needed = mkSet used+     print.concatMap trans =<< mapM (moduleSlice needed) ms++moduleSlice needed m =+  filter (isNeeded needed m) . splitDecls . hsModDecls . snd # parseModule m++--------------------------------------------------------------------------------++tstrategoSlice qn = tslice' qn ttransM++ttransM = P2S.rmIgnored . Ti2S.transDecs' -- . addName++tstratego m =+    print.ttransM.fromDefs.hsModDecls =<< rewriteAndTypeCheckModule rewrite m++tslice' q@(m,n) trans =+  do ms <- map (fst.snd) # getSubGraph (Just [m])+     (_,(_,_,used)) <- tdepgraph [q]+     let needed = mkSet used+     print.concatMap trans =<< mapM (tmoduleSlice needed) ms++tmoduleSlice needed m =+    filter (isNeeded needed m) . splitDecls . fromDefs . hsModDecls+      # rewriteAndTypeCheckModule rewrite m+--  where+--    t = id :: TiDecls PNT -> TiDecls PNT++--------------------------------------------------------------------------------++rewrite = pmRewrite `compRw` lcRewrite++isNeeded needed m d = isDefaultDecl d || isNeeded' d+  where+    isNeeded' =+        any (`elementOf` needed) . map getHSName . tdefinedNames False m
+ tools/hs2stratego/TiBase2Stratego2.hs view
@@ -0,0 +1,16 @@+module TiBase2Stratego2 where+import HsIdent(mapHsIdent)+import TiDecorate(TiPat(..))+import BaseStruct2Stratego2(transP,transPId,transId,not_supported)+import StrategoPattern(Pattern(ConstrPat))++transPat p =+  case p of+    Pat p -> transP transId transPat p+    TiPSpec i _ _ -> transPId (mapHsIdent transId i)+    TiPApp p1 p2 -> transPat p1 `pApp` transPat p2+    TiPTyped p _ -> transPat p+    _ -> not_supported "Pattern" p+  where+    pApp (ConstrPat (c,ps)) p =  ConstrPat (c,ps++[p])+    pApp _ _ = not_supported "Pattern" p
+ tools/hs2stratego/TiProp2Stratego2.hs view
@@ -0,0 +1,44 @@+{-++Knot-tying definitions for the type decorated base+property syntax to+Stratego translation.+-}+module TiProp2Stratego2 where+import TiPropDecorate(TiDecl(..),TiExp(..),+		      TiAssertion(..),OTiAssertion(..),TiPredicate(..))+import PropSyntax(prop,mapHsIdent)+import BaseStruct2Stratego2+import PropStruct2Stratego2+import Prop2Stratego2(transType,transContext,transTlhs,transQType)+import TiBase2Stratego2+import qualified Base2Stratego2 as B+import StrategoDecl+import TiClasses(fromDefs)+import Parentheses -- needed for pattern matching. Grr!!++transDecs ds = transDecs' (fromDefs ds)+transDecs' ds = concatMap transDec ds++transDec (Dec d) =+    prop (transD transId transExp transPat transLocalDecs transType transContext transTlhs)+         ((:[]) . transPD transId transOAssertion transPredicate)+         d++transExp e =+  case e of+    Exp e -> transE transId transExp transPat transLocalDecs transType transContext e+    TiSpec i _ _ -> transEId (mapHsIdent transId i)+    TiTyped e _ -> transExp e++transOAssertion (OA is ds a) = transAssertion a -- !!!++transAssertion (PA a) =+    transPA transId transExp transQType transAssertion transPredicate+            a++transPredicate (PP p) =+    transPP transId transExp B.transPat transQType transAssertion transPredicate+            p++transLocalDecs ds = concatMap transLocalDec (fromDefs ds)+transLocalDec d = [def|Def (P def)<-transDec d]+                  -- silently ignores unimplemented things!!!
+ tools/hsutils/L.hs view
@@ -0,0 +1,58 @@+{-++Except for one equation, this module provides an implementation of the+function L from section 9.3 of the revised Haskell 98 Report.+The missing equation is the one that requires interaction with the parser.+This means that things like++     let x=1+     in x+x++will be correctly translated to++     let {x=1}+     in x+x++but things like++     let x=1 in x+x++that should be parsed as++     let { x=1 } in x+x++will *not* be treated correctly in this implementation.+-}++module L(l) where+import HsTokens(Token(..))+default(Int)++-- The equations for cases when <n> is the first token:+l ts0@((Indent n,(p,_)):ts) ms0@(m:ms) | m==n = semi p:l ts ms0+                                       | n<m  = vrbrace p:l ts0 ms+l ((Indent _,_):ts) ms = l ts ms+-- The equations for cases when {n} is the first token:+l ((Open n,(p,_)):ts) (m:ms) | n>m = vlbrace p:l ts (n:m:ms)+l ((Open n,(p,_)):ts) []     | n>0 = vlbrace p:l ts [n]+l ((Open n,(p,_)):ts) ms       = vlbrace p:vrbrace p:l ((Indent n,(p,"")):ts) ms+-- Equations for explicit braces:+l (t1@(Special,(_,"}")):ts) (0:ms) = t1:l ts ms+l (t1@(Special,(p,"}")):ts) ms     = layout_error p "unexpected }"++ts -- hmm+l (t1@(Special,(p,"{")):ts) ms     = t1:l ts (0:ms)+-- The equation for ordinary tokens:+l (t:ts) ms = t:l ts ms+-- Equations for end of file:+l [] [] = [{-eoftoken-}]+l [] (m:ms) = if m/=0+	      then vrbrace eof:l [] ms+	      else layout_error eof "missing } at eof"++-- There are the tokens inserted by the layout processor:+vlbrace p = (Layout,(p,"{"))+vrbrace p = (Layout,(p,"}"))+semi p = (Special,(p,";"))++--eoftoken = (GotEOF,(eof,""))+eof = (-1,-1) -- hmm++layout_error p msg = [(ErrorToken,(p,"{-"++msg++"-}"))] -- hmm
+ tools/hsutils/LICENSE view
@@ -0,0 +1,31 @@+hsutils is Copyright (c) Thomas Hallgren, and the OGI School of+Science & Engineering, Oregon Health & Science University, 2002-2003,+All rights reserved, and is distributed as free software under the+following license.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++- Neither name of the copyright holders nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS+OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR+TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ tools/hsutils/Makefile view
@@ -0,0 +1,38 @@+TARGETS=stripcomments layout+RM=rm -f++all:: $(TARGETS)++stripcomments::+	ghc -optl -s --make -iLexer stripcomments.hs -o stripcomments++layout::+	ghc -optl -s --make -iLexer layout.hs -o layout++clean:+	$(RM) -r $(TARGETS) hi+	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'++hsutils-1.2.tar.gz::+	ln -s . hsutils-1.2+	tar zchf hsutils-1.2.tar.gz hsutils-1.2/{LICENSE,README,Makefile,*.hs,Lexer/{HsLex,HsTokens,HsLexUtils,HsLayoutPre,HsLexerPass1}.hs}+	rm hsutils-1.2++html:: hi/srclist.txt+	pfe htmlfiles++hi/srclist.txt:+	pfesetup -I Lexer stripcomments.hs++WEBROOT=~/public_html+WWW=$(WEBROOT)/hsutils++upload:: hsutils-1.2.tar.gz $(WWW)+	mv hsutils-1.2.tar.gz $(WWW) && \+	cd $(WWW) && \+	ln -s . hsutils-1.2 && \+	tar zxf hsutils-1.2.tar.gz && \+	rm hsutils-1.2++$(WWW):+	[ -d $(WWW) ] || mkdir $(WWW)
+ tools/hsutils/README view
@@ -0,0 +1,80 @@+NAME++stripcomments - strip blank lines and comments from Haskell files.++layout - simple conversion of layout to explicit braces and semicolons++USAGE++	stripcomments file_1 ... file_n+	layout file_1 ... file_n++DESCRIPTION++stripcomments reads Haskell files named on the command line and strips+away comments and blank lines. Layout and syntactic correctness is+preserved. The result is sent to the standard output.++layout reads Haskell files named on the command line and outputs them+on stdout with the braces and semicolons implied by layout made+explicit. Comments and white space is preserved. (See also limitations+below.)++Files whose names end with '.lhs' are assumed to contain literate style+Haskell, other files are assumed to contain plain Haskell.++HOW TO COMPILE AND INSTALL++	make+	cp stripcomments /usr/local/bin     # or some other suitable directory+	cp layout /usr/local/bin	    # or some other suitable directory++REQUIREMENTS++The Makefile assumes that a version of GHC that supports --make is+installed. GHC 5.02 or later is recommended. Be prepared that+Lexer/HsLex.hs takes a long time to compile.++The programs are implemented in pure Haskell 98, and can also be loaded+in Hugs 98.++LIMITATIONS++The program layout does not support full Haskell 98 layout: it does+not implement the part that requires interaction with the parser. For+example, the program will not correctly translate++	let x=1 in x+x++but will correctly translate++	let x=1+	in x+x++Also, the program layout handles literate style Haskell files by converting+literate comments to ordinary nested comments. This can result in incorrect+code when literate comments contain "{-" or "-}".++LINKS++http://www.cse.ogi.edu/~hallgren/hsutils/+http://www.cse.ogi.edu/~hallgren/Talks/LHiH/+http://www.haskell.org/ghc/+http://www.haskell.org/hugs/++VERSIONS++1.2 Package renamed to hsutils and includes the program layout in addition+    to stripcomments.++1.1 Bug fix: avoid outputting a leading blank line for modules that start+             with one or more lines of whitespace++1.0 Initial release++AUTHOR++Thomas Hallgren  http://www.cse.ogi.edu/~hallgren/++OGI School of Science & Engineering+Oregon Health & Science University
+ tools/hsutils/Unlit.hs view
@@ -0,0 +1,89 @@+-- From nhc13/src/comiler13/Unlit.hs+module Unlit(unlit,readHaskellFile,optUnlit,isLiterateFile) where++-- Part of the following code is from "Report on the Programming Language Haskell",+-- version 1.2, appendix C.++import Char++readHaskellFile path = fmap (optUnlit path) (readFile path)++optUnlit path =+  if isLiterateFile path+  then unlit path+  else id++isLiterateFile path = last4 path == ".lhs"+  where last4 = reverse . take 4 . reverse++--------------------------------------------------------------------------------++data Classified = Program String | Blank | Comment String | Include Int String | Pre String++classify :: [String] -> [Classified]+classify []                = []+classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs+   where allProg [] = []  -- Should give an error message, but I have no good position information.+         allProg (('\\':x):xs) |  x == "end{code}" = Blank : classify xs+	 allProg (x:xs) = Program x:allProg xs+classify (('>':x):xs)      = Program (' ':x) : classify xs+classify (('#':x):xs)      = (case words x of+                                (line:file:_) | all isDigit line -> Include (read line) file+                                _                                -> Pre x+                             ) : classify xs+classify (x:xs) | all isSpace x = Blank:classify xs+classify (x:xs)                 = Comment x:classify xs++-- Old version: put literate comment lines in one-line comments+old_unclassify = unlines . map unclassify1++unclassify1 :: Classified -> String+unclassify1 (Program s) = s+unclassify1 (Pre s)     = '#':s+unclassify1 (Include i f) = '#':' ':show i ++ ' ':f+unclassify1 Blank       = ""+unclassify1 (Comment s) = "-- "++s++-- New version: put literate comment blocks in nested comments+-- (Drawback: these can potentially interfere with other comments)+new_unclassify = unclassify0+  where+    unclassify0 (Comment s:xs) = "{-+\t"++s++"\n"++unc xs -- -}+    unclassify0 xs = un xs++    -- Normal state, inside code block+    un [] = []+    un (Blank:Comment s:xs) = "{-+\n"++s++"\n"++unc xs -- -}+    un (x:xs) = unclassify1 x++"\n"++un xs++    -- Comment state, inside a literate comment+    unc [] = "-}\n"+    unc (Comment s:xs) = s++"\n"++unc xs+    unc (Blank:xs) = unb xs++    -- Blank line state, inside a literate comment, after a blank line+    unb [] = "-}\n"+    unb (Blank:xs) = "\n"++unb xs+    unb xs@(Comment _:_) = "\n"++unc xs+    unb xs = "-}\n"++un xs++unlit :: String -> String -> String+unlit file =+  new_unclassify . adjecent file (0::Int) Blank . classify . lines++adjecent :: String -> Int -> Classified -> [Classified] -> [Classified]+adjecent file 0 _             (x              :xs) = x : adjecent file 1 x xs -- force evaluation of line number+adjecent file n y@(Program _) (x@(Comment _)  :xs) = error (message file n "program" "comment")+adjecent file n y@(Program _) (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@(Program _) (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n y@(Comment _) (x@(Program _)  :xs) = error (message file n "comment" "program")+adjecent file n y@(Comment _) (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@(Comment _) (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n y@Blank       (x@(Include i f):xs) = x: adjecent f    i     y xs+adjecent file n y@Blank       (x@(Pre _)      :xs) = x: adjecent file (n+1) y xs+adjecent file n _             (x@next         :xs) = x: adjecent file (n+1) x xs+adjecent file n _             []                    = []++message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"+message []     n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"+message file   n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"
+ tools/hsutils/index_inc.html view
@@ -0,0 +1,16 @@+This is the Haskell 98 source of a small program called+<code>stripcomments</code>, which strips comments from Haskell source files.+Both plain Haskell and literate style Haskell is supported.++<ul>+  <li>For more details, see the <a href="README">README</a> file.+  <li>Starting point for browsing the source code:+      <a href="pfe.cgi?Main">Main</a>+  <li><a href="LICENSE">LICENSE</a>+  <li>Download the source code:+      <a href="stripcomments-1.1.tar.gz">stripcomments-1.1.tar.gz</a> (12KB)+  <li>stripcomments is based on my+      <a href="../Talks/LHiH/">Lexer for Haskell in Haskell</a>.+</ul>++<h2>Modules</h2>
+ tools/hsutils/layout.hs view
@@ -0,0 +1,34 @@+import System(getArgs)+import Unlit(readHaskellFile)+import L(l)+import HsLexerPass1+import HsLayoutPre(layoutPre)+import List(partition)++-- This version reads the Haskell input from files named on the command line.+main = mapM_ doLayout =<< getArgs++doLayout path = putStrLn . layout =<< readHaskellFile path++layout =+    concatMap tokenString . +    uncurry (mergeBy (cmpBy tokenPos)) .+    apFst (flip l [] . layoutPre) .+    partition (notWhite.fst) .+    lexerPass0+  where+    tokenPos = fst . snd+    tokenString = snd . snd+++--- Utilities++apFst f (x,y) = (f x,y)+cmpBy f x y      = f x `compare` f y++mergeBy cmp [] ys  = ys+mergeBy cmp xs []  = xs+mergeBy cmp a@(x:xs) b@(y:ys) =+    case x `cmp` y of+      GT -> y : mergeBy cmp a ys +      _ -> x : mergeBy cmp xs b
+ tools/hsutils/stripcomments.hs view
@@ -0,0 +1,17 @@+{-++This is a small utility to strip blank lines and comments from Haskell files.++Haskell modules are read from files named on the command line.++The result is output on stdout.++Haskell files whose names end with ".lhs" are assumed to be in literate style.+-}++import System(getArgs)+import Unlit(readHaskellFile)+import StripComments(stripcomments)++main = mapM_ stripFile =<< getArgs++stripFile path = putStrLn . stripcomments =<< readHaskellFile path
+ tools/hsutils/stripcomments0.hs view
@@ -0,0 +1,9 @@+{-++This is a small utility to strip blank lines and comments from a Haskell file.+This version takes a Haskell program on stdin and writes the result to+stdout. Literate files are not supported.+-}++import StripComments(stripcomments)++main = interact stripcomments
+ tools/interp/AST.hs view
@@ -0,0 +1,117 @@+module AST where++type Name = String++data Op = Plus | Mult | IntEq | IntLess++data LS = Lazy | Strict deriving Eq++data E+  = Var Name+  | App E E+  | Abs [P] E+  | Let [D] E+  | Case E [(P,B,[D])]+  | TupleExp [E]+  | Const Integer+  | ConApp Name [(E,LS)]+  | NewApp Name E+  | Boom+  | Undefined+--- Above is the "core", below various extras+  | Bin Op E E+  | Cond E E E+  | Tconst +  | Fconst++-- Declarations+data D = Fun Name [([P],B,[D])] | Val P B [D]++-- Bodies+data B = Guarded [(E,E)] | Normal E++--- Nested Patterns+data P = Pconst Integer+       | Pvar Name+       | Ptuple [P]+       | Pcondata Name [P]  +       | Pnewdata Name P+       | Ptilde P++++showB :: B -> String+showB (Normal e) = showE e+showB (Guarded ps) = foldr f "\n" ps+   where f (e1,e2) ans = "| "++(showE e1) ++ " = " ++(showE e2)++ ans++showD :: D -> String+showD (Val p body ds) =  " " ++ showP p ++ "=" ++ (showB body) ++ "\n" +++                         "   where " ++ (showDs ds)+showD (Fun nm xs) = foldr (++) "" (map f xs)+   where f (ps,body,ds) = +           nm ++ " " ++(showPs ps) ++ " = " ++(showB body) ++ "\n" +++           "   where " ++ (showDs ds)+   ++showDs dcls = foldr (++) "" (map showD dcls)+++showOp :: Op -> String+showOp Plus = "+"+showOp Mult = "*"+showOp IntEq = "=="+showOp IntLess = "<"++showP (Pconst i) = show i+showP (Pvar n) = n+showP (Pcondata n ns) = +                "(" ++ n ++ " " ++ +                (foldr (\ s t -> if t/="" then (showP s) ++ "," ++ t+                                     else (showP s)) +                        "" ns)+                ++ ")"+showP (Pnewdata n x) = "(" ++ n ++ " " ++ (showP x) ++ ")"              +showP (Ptilde p) = "~" ++ (showP p)++showPs [] = ""+showPs (p:ps) = (showP p)++" "++(showPs ps)++showE :: E -> String+showE (Const i) = show i+showE Tconst = "True"+showE Fconst = "False"+showE (Var nm) = nm+showE (Abs p d) = "(\\" ++ (foldr (++) " " (map showP p)) ++ " -> " ++ showE d ++ ")"+showE (App d d') = "(" ++ showE d ++ " " ++ showE d' ++ ")"+showE (Let dcls d) = "let " ++ +                          foldr (++) "" (map showD dcls)+                            ++ +                        " in " ++ showE d+showE (ConApp n l) =  "(" ++ n ++ " " ++  +                (foldr (\ (s,ls) t -> +                            let sa = if (ls == Strict) then "!" else "" +                            in+                                 if t/="" then sa ++ (showE s) ++ "," ++ t+                                     else sa ++ (showE s)) +                        "" l)+                      ++ ")"+showE (NewApp n x) = "(" ++ n ++ " " ++  (showE x) ++ ")"                     +showE (Bin op d d') = "(" ++ showE d ++ " " ++ showOp op ++ " " ++ +                               showE d' ++ ")"+showE Tconst = "true"+showE Fconst = "false"+showE (Case e ms) =+      "(case " ++ showE e ++ " of " ++ +           (foldr (++) "" (map (\ alt -> "[" ++ (showAlt alt) ++ "]") ms)) ++ ")"+   where showAlt (p,b,ds) = show p ++ " -> " ++ show b ++ "\n" ++ showDs ds+++instance Show E where+  show = showE++instance Show P where+  show = showP++instance Show B where+  show = showB
+ tools/interp/Front2AST.hs view
@@ -0,0 +1,176 @@+module Front2AST where++import Syntax+++type Name = String+data Op = Plus | Mult | IntEq | IntLess+data LS = Lazy | Strict deriving Eq++data Pat +  = Pconst Integer         -- { 5 }+  | Pvar Name              -- { x }+  | Ptuple [Pat]           -- { (p1,p2) }+  | Pcondata Name [Pat]    -- data T1 = C1 t1 t2 \nl {C1 p1 p1} = e +  | Pnewdata Name Pat      -- newtype T2 = C2 t1 t2 \nl {C2 p1 p2} = e+  | Ptilde Pat             -- { ~p }+data Exp +  = Var Name               -- { x }+  | Const Integer          -- { 5 }+  | App Exp Exp            -- { f x }+  | Abs [Pat] Exp          -- { \ p1 p2 -> e }+  | TupleExp [Exp]         -- { (e1,e2) }+  | ConApp Name [(Exp,LS)] -- data T1 = C1 t1 t2 \nl p = {C1 e1 e2}+  | NewApp Name Exp        -- newtype T2 = C2 t1 t2 \nl p = {C2 e1 e2}+  | Seq Exp Exp            -- { seq e1 e2 }               +  | Bin Op Exp Exp         -- { e1 + e2 }+  | Cond Exp Exp Exp       -- { if e1 then e2 else e3 }+  | Let [Dec] Exp          -- { let x=e1 \nl   y=e2 in e3 }+  | Case Exp [Match]       -- { case e of m1 \nl m2 }+type Match = +      (Pat, Body, [Dec])   -- case e of { pat -> body where decs } +data Dec +  = Fun Name [Clause]      -- { f p1 p2 = b where decs }+  | Val Pat Body [Dec]     -- { p = b where decs }+type Clause = +      ([Pat],Body,[Dec])   -- f { p1 p2 = body where decs }+data Body+  = Guarded [(Exp,Exp)]    -- f p { | e1 = e2 | e3 = e4 } where ds+  | Normal Exp             -- f p = { e } where ds+++showB :: Body -> String+showB (Normal e) = showE e+showB (Guarded ps) = foldr f "\n" ps+   where f (e1,e2) ans = "| "++(showE e1) ++ " = " ++(showE e2)++ ans++showWhere ds = if null ds then "" else "   where "++showD :: Dec -> String+showD (Val p body ds) =  " " ++ showP p ++ "=" ++ (showB body) ++ "\n" +++                         (showWhere ds) ++ (showDs ds)+showD (Fun nm xs) = foldr (++) "" (map f xs)+   where f (ps,body,ds) = +           nm ++ " " ++(showPs ps) ++ " = " ++(showB body) ++ "\n" +++           (showWhere ds) ++ (showDs ds)+   ++showDs dcls = foldr (++) "" (map showD dcls)+++showOp :: Op -> String+showOp Plus = "+"+showOp Mult = "*"+showOp IntEq = "=="+showOp IntLess = "<"++showP (Pconst i) = show i+showP (Pvar n) = n+showP (Pcondata n ns) = +                "(" ++ n ++ " " ++ +                (foldr (\ s t -> if t/="" then (showP s) ++ "," ++ t+                                     else (showP s)) +                        "" ns)+                ++ ")"+showP (Pnewdata n x) = "(" ++ n ++ " " ++ (showP x) ++ ")"              +showP (Ptilde p) = "~" ++ (showP p)++showPs [] = ""+showPs (p:ps) = (showP p)++" "++(showPs ps)++showE :: Exp -> String+showE (Const i) = show i+showE (Var nm) = nm+showE (Abs p d) = "(\\" ++ (foldr (++) " " (map showP p)) ++ " -> " ++ showE d ++ ")"+showE (App d d') = "(" ++ showE d ++ " " ++ showE d' ++ ")"+showE (Let dcls d) = "let " ++ +                          foldr (++) "" (map showD dcls)+                            ++ +                        " in " ++ showE d+showE (ConApp n l) =  "(" ++ n ++ " " ++  +                (foldr (\ (s,ls) t -> +                            let sa = if (ls == Strict) then "!" else "" +                            in+                                 if t/="" then sa ++ (showE s) ++ "," ++ t+                                     else sa ++ (showE s)) +                        "" l)+                      ++ ")"+showE (NewApp n x) = "(" ++ n ++ " " ++  (showE x) ++ ")"                     +showE (Bin op d d') = "(" ++ showE d ++ " " ++ showOp op ++ " " ++ +                               showE d' ++ ")"+showE (Seq x y) = "(seq "++(showE x) ++ " " ++ (showE y) ++ ")"+                  ++showE (Case e ms) =+      "(case " ++ showE e ++ " of " ++ +           (foldr (++) "" (map (\ alt -> "[" ++ (showAlt alt) ++ "]") ms)) ++ ")"+   where showAlt (p,b,ds) = show p ++ " -> " ++ show b ++ "\n" ++ showDs ds+++instance Show Exp where+  show = showE++instance Show Pat where+  show = showP++instance Show Body where+  show = showB++-----------------------------------------------------------------------++bad x = error "not yet"++trP :: HsPat -> Pat+trP (Pat p) =+ case mapP trP p of+   HsPId n -> Pvar (showId n)+   HsPLit (HsInt n) -> Pconst n+   HsPInfixApp x op y -> Pcondata (show op) [x,y]+   HsPApp n ps -> Pcondata (show n) ps+   HsPTuple ps -> Ptuple ps+   HsPIrrPat p -> Ptilde p+   HsPParen p -> p+   other -> error ("no "++(show other)++" patterns yet")+++trD :: HsDecl -> Dec+trD (d @ (Dec x)) =+ case mapD trE trP (map trD) bad bad bad x of+   HsPatBind loc p b ds -> Val p (trRhs b) ds+   HsFunBind loc matches -> Fun (name matches) (map g matches)+      where name ((HsMatch loc nm ps rhs ds): ms) = (show nm)+            g (HsMatch loc nm ps rhs ds) = (ps,trRhs rhs,ds)+   other -> error ("illegal dec "++(show d))          +      +trRhs :: HsRhs Exp -> Body+trRhs (HsBody e) = Normal e+trRhs (HsGuard triples) = Guarded(map f triples)+        where f (loc,guard,body) = (guard,body)++trAlt :: HsAlt Exp Pat [Dec] -> (Pat,Body,[Dec])+trAlt (HsAlt loc pat rhs ds) = (pat,trRhs rhs,ds)++trE :: HsExp -> Exp+trE (e @ (Exp x)) = + case mapE trE trP (map trD) bad bad x of +   HsId n                 -> Var (showId n)+   HsApp x y              -> App x y+   HsLit (HsInt n)        -> Const n+   HsInfixApp x op z      -> App (App (Var (showId op)) x) z+   HsNegApp x             -> App (Var "negate") x  +   HsLambda ps e          -> Abs ps e+   HsLet ds e             -> Let ds e+   HsIf x y z             -> Cond x y z+   HsCase e alts          -> Case e (map trAlt alts)+   HsTuple xs             -> TupleExp xs+   HsList xs              -> f xs+      where f [] = ConApp "[]" []+            f (x:xs) = ConApp ":" [(x,Lazy),(f xs,Lazy)]+   HsParen x              -> x+   HsLeftSection x op     -> Abs[Pvar "zzz"] (App (App (Var (show op)) x) (Var "zzz"))+   HsRightSection op y    -> Abs[Pvar "zzz"] (App (App (Var (show op)) (Var "zzz")) y)+   other -> error ("no translation yet for: "++(show e))+++showId (HsVar x) = show x+showId (HsCon x) = show x
+ tools/interp/HaskellCoreLite1.1.hs view
@@ -0,0 +1,568 @@+module HaskellCoreLite1_1 where ++{-+Differences from 1.0:++1. has irrefutable patterns (done)+2. added explicit fixpoints (done)+3. guards in cases (done)+4. fixing match failure. (done) Added two types of errors - trappable & fatal.+   Now, fatbar distinguishes them.+5. tuples. I'm assuming for the moment that these will+   be implemented as special cases of ADTs. They'll be constructor+   apps of "3tuple", "4tuple", etc. (done)+6. Should also have constructor patterns with arity greater than 1. (done)+-}++type Name = String++data Op = Plus | Mult | IntEq | IntLess++data E+  = Var Name+  | App E E+  | Abs P E+  | Let [D] E+  | Case E [(P,E)]+  | PairExp E E+  | TupleExp [E]+  | Const Integer+  | ConApp Name [E]+  | Boom+  | Undefined+--- Above is the "core", below various extras+  | Bin Op E E+  | Cond E E E+  | Tconst +  | Fconst+  | Guarded [(E,E)]+  | Match [(E,E)] [D] --- this is the body of a general case statement+                      --- each (E,E) is an guarded expression g-->e +		      --- where b:BoolExp, and [D] are declarations+		      --- introduced by "where".+++--- N.b., these are nested patterns.+data P = Pconst Integer+       | Pvar Name+       | Ppair P P+       | Ptuple [P]+       | Pstrdata Name [P]  +       | Pirref P++type D = (P,E)++showD :: D -> String+showD (p,le) =  " " ++ showP p ++ "=" ++ (showE le) ++ " " ++showOp :: Op -> String+showOp Plus = "+"+showOp Mult = "*"+showOp IntEq = "=="+showOp IntLess = "<"++showP (Pconst i) = show i+showP (Pvar n) = n+showP (Pstrdata n ns) = +		"(" ++ n ++ " " ++ +		(foldr (\ s t -> if t/="" then (showP s) ++ "," ++ t+		                     else (showP s)) +			"" ns)+		++ ")"+showP (Pirref p) = "~" ++ (showP p)++showE :: E -> String+showE (Const i) = show i+showE Tconst = "True"+showE Fconst = "False"+showE (Var nm) = nm+showE (Abs p d) = "(\\" ++ (showP p) ++ " -> " ++ showE d ++ ")"+showE (App d d') = "(" ++ showE d ++ " " ++ showE d' ++ ")"+showE (Let dcls d) = "let " ++ +			  foldr (++) "" (map (\(p,e)-> showD (p,e)) dcls)+			    ++ +                        " in " ++ showE d+showE (ConApp n l) =  "(" ++ n ++ " " ++  +		(foldr (\ s t -> if t/="" then (showE s) ++ "," ++ t+		                     else (showE s)) +			"" l)+		      ++ ")"++showE (PairExp n l) = "<"++showE n++","++ showE l ++ ">"+showE (Bin op d d') = "(" ++ showE d ++ " " ++ showOp op ++ " " ++ +                               showE d' ++ ")"+showE Tconst = "true"+showE Fconst = "false"+showE (Case e pelist) =+      "(case " ++ showE e ++ " of " ++ +           (foldr (++) "" (map (\(p,e)-> +			 "[" ++ (showP p) ++ "--->" ++ (showE e) ++ "]")+			 pelist)) ++ ")"+showE (Match glist dcls) = "{" ++ +			foldr (++) "" (map (\(g,e)-> showE g ++ "-->" ++ showE+			e) glist)+			    ++ +                        " where " ++ +			foldr (++) "" (map (\(p,e)-> showD (p,e)) dcls)+			++ "}"++instance Show E where+  show = showE++----------------------------------------------------------------------+-- Values+----------------------------------------------------------------------++type EnvFrag = [(Name,M Value)]++data Value+  = +--- scalars+    Z Integer+  | BV Bool+--- CBN functions+  | Fun (M Value -> M Value)+--- Generic structured data+  | Tagged Name [M Value]+--- Variable Bindings +  | VarBind EnvFrag+---+---  | PairVal (M Value) (M Value)+--- values for all tuples:+  | TupleVal [M Value]++---Do I need to use something like this?+data Fix a = Fix (Fix a -> a)+fix = \ f -> (\ (Fix x) -> +		   (f (\ a -> x (Fix x) a)))+		      (Fix (\ (Fix x) -> (f (\ a -> x (Fix x) a))))++showValue :: Value -> String+showValue (Z i) = show i+showValue (BV i) = show i+showValue (Fun _) = "(function)"++instance Show Value where+  show = showValue+++----------------------------------------------------------------------+-- Errors+----------------------------------------------------------------------++data ErrorTypes = Trappable String | Fatal String++instance Show(ErrorTypes) where+   show = \ e -> case e of+		      Trappable x -> "Trappable: " ++ x+		      Fatal x -> "Fatal: " ++ x++data Error a = Ok a | ErrorC ErrorTypes++----------------------------------------------------------------------+-- Error monad+----------------------------------------------------------------------+++errUnit :: a -> Error a+errUnit = Ok+++errBind :: Error a -> (a -> Error b) -> Error b+errBind x f = case x of+		     (Ok v) -> f v+		     (ErrorC msg) -> (ErrorC msg)++instance Monad Error where+  return = errUnit+  (>>=) = errBind++showEC x =+       case x of+	    (Ok v) -> show v+	    (ErrorC msg) -> show msg++showError :: Show a => Error a -> String+showError x =+       case x of+	    (Ok v) -> show v+	    (ErrorC msg) -> show msg++instance Show a => Show (Error a) where+    show = showError++raise0 :: ErrorTypes -> Error a+raise0 = ErrorC++----------------------------------------------------------------------+-- Environments+----------------------------------------------------------------------++type Env = Name -> M Value++----------------------------------------------------------------------+-- M = Environment+Error +----------------------------------------------------------------------++newtype M a = M (Env -> (Error a))++mUnit :: a -> M a+mUnit a = M (\rho -> return a)+++mBind :: M a -> (a -> M b) -> M b+mBind x f =+        M (\rho -> +		 do { v <- (deM x) rho ; deM (f v) rho })++instance Monad M where+  return = mUnit+  (>>=) = mBind++deM (M x) = x++lift :: Error a -> M a+lift ec = M (\ _ ->  ec)++----------------------------------------------------------------------+-- Non-standard Morphisms+----------------------------------------------------------------------++raise :: ErrorTypes -> M a+raise = \msg -> lift (raise0 msg)++rdEnv :: M Env+rdEnv = M (\rho -> return rho)++tweek f x y = \ z -> if x == z then y else f z++xEnv :: Env -> Name -> M Value -> Env+xEnv rho n phi = tweek rho n phi++inEnv :: Env -> M a -> M a+inEnv rho (M x) = M (\ _ -> x rho)++--- this isn't the suavest way of defining this+infixr 7 `fatbar`+fatbar a b = M (\rho ->+ --- N.b., no additional evaluation done here+                  case (deM a) rho of+		       (Ok x) -> return x+		       (ErrorC x) -> +			       case x of +				    Fatal msg -> ErrorC x+				    Trappable msg -> (deM b) rho+			    )+++----------------------------------------------------------------------+-- +----------------------------------------------------------------------++--- these functions/PairVal should be replaced with select/Tagged:++proj :: Int -> M Value -> M Value+proj n phi = do { (TupleVal mvals) <- phi ; mvals !! (n-1)  }++--- N.b., checkTag now strips off the tag "t"+checkTag :: Name -> M Value -> M Value+checkTag tag arg =+	 do { (Tagged t mvals) <- arg+	    ; if t==tag then return (TupleVal mvals)+	      else raise $ (Trappable $ "Tag " ++ t ++ "!="++tag)+	      }+++--- This is necessary to get the bindings for lambda +--- abstraction and case. Oddly, lambda abstractions are *not*+--- generally lazy. They're not strict, either, but a+--- hybrid between the two.+--- +match :: P -> M Value -> M EnvFrag+match (Pvar x) arg = return [(x,arg)]+match (Pconst i) arg = do { (Z v) <- arg+			  ; if v==i then +				    return []+			    else raise (Trappable "Constant pattern failed")+			    }+match (Ppair p1 p2) arg = do { (TupleVal mvals) <- arg+			     ; vbl1 <- match p1 (head mvals)+			     ; vbl2 <- match p2 (head $ tail mvals)+			     ;    return (vbl1 ++ vbl2) +				    }+match (Ptuple ps) arg = +   do { (TupleVal mvals) <- arg+      ; sequence (map (\(p,phi) -> match p phi) (zip ps mvals)) +		 >>= (return . concat)+	     }+match (Pstrdata tag ps) arg = +   do { (Tagged t mvals) <- arg+      ; if tag==t +	then+	   sequence (map (\(p,phi) -> match p phi) (zip ps mvals)) +		>>= (return . concat)+        else raise (Trappable "Constructor pattern failed")+	     }+match (Pirref p) arg = return (lazymatch p arg)++--- N.b., the range is *not* a computational type because+--- no matching occurs, and so no failure is possible at this+--- point.+---+lazymatch :: P -> M Value -> EnvFrag+lazymatch (Pconst k) mv = []+lazymatch (Pvar x) mv = [(x,mv)]+lazymatch (Ppair p1 p2) mv = +    (lazymatch p1 (proj 1 mv)) ++ (lazymatch p2 (proj 2 mv))+lazymatch (Pirref p) mv = lazymatch p mv+lazymatch (Pstrdata n ps) mvals = +         concat+	       (map (\(i,p) -> lazymatch p (proj i (checkTag n mvals))) +			            (zip [1..(length ps)] ps))+lazymatch (Ptuple ps) mvals = +         concat+	       (map (\(i,p) -> lazymatch p (proj i mvals))+			            (zip [1..(length ps)] ps))++app :: M Value -> M Value -> M Value+app x y = do { rho <- rdEnv ; (Fun f1) <- x ; f1 (inEnv rho y) }++addBindings :: Env -> EnvFrag -> Env+addBindings rho [] = rho+addBindings rho ((n,mv):bindings) = addBindings (xEnv rho n mv) bindings++eval :: E -> M Value+eval (Const i) = return (Z i)+eval Tconst = return $ BV True+eval Fconst = return $ BV False+eval Boom = eval Boom+eval Undefined = raise (Fatal "Undefined")+eval (Var n) = do { rho <- rdEnv ; rho n }+eval (Abs p l) = +     do { rho <- rdEnv +	; return (Fun $ \ arg ->+			   do { vbl <- match p arg +			      ; inEnv (addBindings rho vbl) (eval l) } ) }+eval (App l1 l2) =+     do { rho <- rdEnv+        ; (Fun f1) <- eval l1+	; f1 (inEnv rho $ eval l2) }+eval (PairExp l1 l2) = +     do { rho <- rdEnv+	; return (TupleVal [inEnv rho (eval l1), inEnv rho (eval l2)])+          }+eval (TupleExp es) = +  do { rho <- rdEnv ; return (TupleVal $ map (\e -> inEnv rho $ eval e) es) }+eval (ConApp n es) = +  do { rho <- rdEnv ; return (Tagged n $ map (\e -> inEnv rho $ eval e) es) }+---+--- N.b., eval (Case expr (p,e)) = eval (App (Abs (p,e)) expr)+---+eval (Case e pelist) = +     foldr fatbar+	   (raise (Fatal "Match Error"))+	   (map (\ (p',e') -> app (eval (Abs p' e')) (eval e)) pelist) +{-+The above is equivalent to:+     app (eval \p1.e1) (eval e) FATBAR+	       ...+     app (eval \pn.en) (eval e) FATBAR+     raise "Match Failure"+-}	   +---+--- Here, the meaning of a pattern is given by "lazymatch", rather+--- than by "match". This yields real lazy pattern-matching.+---+eval (Let pelist le) = +     do { rho <- rdEnv+	; let rho' = +	       fix (\ r -> +		 addBindings rho $+		   foldr (++) []  +		         (map (\(p,e)->lazymatch p (inEnv r (eval e))) pelist))+	  in+	       inEnv rho' (eval le)+	       }+eval (Bin op l1 l2) =+     case op of +      Plus -> +	do { (Z i1) <- eval l1 +	   ; (Z i2) <- eval l2 +	   ; return (Z (i1+i2)) }+      Mult -> +	do { (Z i1) <- eval l1 +	   ; (Z i2) <- eval l2 +	   ; return (Z (i1*i2)) }+      IntEq ->+	do { (Z i1) <- eval l1 +	   ; (Z i2) <- eval l2 +	   ; return (BV (i1==i2)) }+      IntLess ->+	do { (Z i1) <- eval l1 +	   ; (Z i2) <- eval l2 +	   ; return (BV (i1<i2)) }++eval (Cond l1 l2 l3) =+     do { (BV b) <- eval l1+	; if b then (eval l2) else (eval l3) }+eval (Guarded glist) = +     foldr fatbar+	   (raise (Fatal "Match Error"))+	   (map (\ (g,e) ->  do { BV b <- eval g+				; if b then +				       eval e +				  else raise (Trappable "Guard Failure")+				  })+	        glist)+--- I'm making a point here that "<glist> where <decls>" is equivalent+--- to "let <decls> in <glist>."+eval (Match glist decls) = eval (Let decls (Guarded glist))++--------------------------------------------------------------------+--- Haskell Weirdness.+--------------------------------------------------------------------++data RedBlack a = Red a | Black a+data OneTwo a b = One a | Two a b+instance Show a => Show (RedBlack a) where+    show = \ x -> case x of +		       Red v -> show v+		       Black v -> show v++omega :: Int -> (Int,Int)+omega = \x -> if True then (omega x) else (omega x)++h0 = (\ (Red x) -> 1) (Black 99)+h1 = (\ (Red (Black x)) -> 1) (Red undefined)+h2 = (\ (Red (Two x (Black y))) -> 1) (Red (Two 1 (Black 9)))+h3 = (\ (Red (Two x (Black y))) -> 1) (Red (Two undefined (Black undefined)))+h4 :: Int+h4 = (\ (Red (Two x (Black y))) -> x) (Red (Two undefined (Black undefined)))++ex1 = case undefined of 1 -> 99        ---> undefined+ex2 = case undefined of x -> 99        ---> 99+ex3 = case undefined of (x,y) -> 99    ---> undefined+ex4 = case undefined of (Red x) -> 99  ---> undefined++++-----------------------------------------------------------+--			some examples+-----------------------------------------------------------++redpat = \ x -> Pstrdata "red" [(Pvar x)]+greenpat = \ x -> Pstrdata "green" [(Pvar x)]+blackpat = \ x -> Pstrdata "black" [(Pvar x)]+blackexp = \t -> ConApp "black" [t]+redexp = \t -> ConApp "red" [t]+greenexp = \t -> ConApp "green" [t]+pairpat = Ppair (Pvar "x") (Pvar "y")+black = \ x -> ConApp "black" [x]+red = \ x -> ConApp "red" [x]+green = \ x -> ConApp "green" [x]++run le = showEC (deM (eval le) error)++--- Important to note that abstraction is neither lazy nor strict+--- +e1 = App (Abs (redpat "x") (Const 1)) (blackexp (Const 19)) ---> error+e2 = App (Abs (redpat "x") (Var "x")) (blackexp (Const 19)) ---> error+e3 = App (Abs (redpat "x") (Var "x")) (redexp (Const 19))   ---> 19+e4 = App (Abs pairpat (Const 4)) (PairExp Boom Boom)        ---> 4+e5 = App (Abs (redpat "x") (Var "x")) Boom                  ---> non-term+e6 = App (Abs (redpat "x") (Var "x")) (ConApp "red" [Boom]) ---> non-term+e7 = App (Abs (redpat "x") (Const 1)) (ConApp "red" [Boom]) ---> 1+e8 = App (Abs pairpat (Var "x")) (PairExp (Const 1) Boom)   ---> 1++c1 = Case Undefined [(Pvar "x", Const 1)]               ---> 1+c2 = Case Undefined [(Pconst 99, Const 1)]              ---> Undefined+c3 = Case Undefined [(redpat "x", Const 1)]             ---> Undefined+c4 = Case (black Undefined) [(redpat "x", Const 1)]     ---> match failure+c5 = Case (red Undefined) [(redpat "x", Const 1)]       ---> 1++c6body = (Case (Var "val") +			[(redpat "x",    +			  (Case (Var "x") [(blackpat "z",(Const 99))])+				 ),+			 (Pstrdata "red" [greenpat "y"], Const 87)])++c6 = Let [(Pvar "val", redexp (greenexp (Const 1)))] c6body+++l1 = Let [(Pconst 1, Const 0)] (Const 99)                 ---> 99+l2 = Let [(redpat "x", Undefined)] (Const 99)             ---> 99+l3 = Let [(redpat "x", black Undefined)] (Const 99)       ---> 99+l4 = Let [(redpat "x", black Undefined)] (Var "x")        ---> red != black+l5 = Let [(redpat "x", red (Const 99))] (Var "x")         ---> 99+l6 = Let [(redpat "x", black Undefined),+	  (redpat "y", green (Const 99))] (Var "x")       ---> red != black+++{-+HaskellCoreLite> let (Red x) = Black 19 in 87+87+HaskellCoreLite> let (Red x) = Black 19 in x++Program error: {v1405 (RedBlack_Black (Num_fromInt instNum_v35 19))}+-}++{- +   BTW, this works with the old def'n of let +   (i.e., dynamic binding with no explicit fixpoints). +-}+evenDef = Abs (Pvar "x") (Cond (Bin IntEq (Var "x") (Const 0)) +	  	        Tconst+		        (App (Var "odd") (Bin Plus (Var "x") (Const $ -1))))++oddDef =  Abs (Pvar "x") (Cond (Bin IntEq (Var "x") (Const 0)) +	  	        Fconst+		        (App (Var "even") (Bin Plus (Var "x") (Const $ -1))))+++oddeven = Let [(Pvar "even",evenDef),(Pvar "odd",oddDef)] (App (Var "even") (Const 3))++---this one demonstrates irrefutable patterns+---compare with:+---   e1 = App (Abs (redpat "x") (Const 1)) (blackexp (Const 19)) ---> error++irref0 = App (Abs (Pirref (redpat "x")) (Const 1)) (blackexp (Const 19))+irref1 = App (Abs (Pirref (redpat "x")) (Var "x")) (blackexp (Const 19))++v = (z + z) where z = 1 ++--- Simple example of a guarded case statement:+++c7 = +   let+	c7body = Match [(Bin IntEq (Var "x") (Var "z"), (Const 99))]+	               [(Pvar "z",(Const 1))]+   in+      Case (Const 1) [(Pvar "x", c7body)]		 +++c8 = +   let+	body = Match [(Bin IntEq (Var "x") (Var "z"), (Const 99))]+	               [(Pvar "z",(Const 2))]+   in+      Case (Const 1) [(Pvar "x", body)]		 ++c9 = +   let+	body = Match [(Bin IntEq (Var "x") (Var "z"), (Const 99))]+	               [(Pvar "z",(Const 1))]+   in+      Case (Const 1) [(Pvar "x", body),(Pvar "y", (Const 101))]		 ++c10 = +   let+	body = Match [(Bin IntEq (Var "x") (Var "z"), (Const 99))]+	               [(Pvar "z",(Const 2))]+   in+      Case (Const 1) [(Pvar "x", body),(Pvar "y", (Const 101))]		 +++projy = App (Abs (Ptuple [Pvar "x", Pvar "y", Pvar "z"]) +		         $ Var "y")+		 (TupleExp [Boom, Const 2, Boom])
+ tools/interp/HaskellCoreLite1.2.hs view
@@ -0,0 +1,483 @@+module HaskellCoreLite1_2 where ++{-+Differences from HCL1.1:++This version has explicit pattern-matching failure in the type of "match."+I.e., match :: P -> M Value -> M (Maybe EnvFrag)++So, now M now longer has two error types "Fatal" and "Trappable" - they're+all fatal now. Also, fatbar has gone away.++BTW, most/all of the changes are marked with comments starting with "N.b."++-}++type Name = String++data Op = Plus | Mult | IntEq | IntLess++data LS = Lazy | Strict deriving Eq++data E+  = Var Name+  | App E E+  | Abs P E+  | Let [D] E+  | Case E [Match]+  | PairExp E E+  | TupleExp [E]+  | Const Integer+---  | ConApp Name [E] +  | ConApp Name [(E,LS)]+  | NewApp Name E+  | Boom+  | Undefined+--- Above is the "core", below various extras+  | Bin Op E E+  | Cond E E E+  | Tconst +  | Fconst++data Match = Guarded P [(E,E)] [D]+           | Normal P E [D]++--- N.b., these are nested patterns.+data P = Pconst Integer+       | Pvar Name+       | Ppair P P+       | Ptuple [P]+       | Pcondata Name [P]  +       | Pnewdata Name P+       | Ptilde P++type D = (P,E)++showD :: D -> String+showD (p,le) =  " " ++ showP p ++ "=" ++ (showE le) ++ " " ++showDecls dcls = foldr (++) "" (map (\(p,e)-> showD (p,e)) dcls)+++showOp :: Op -> String+showOp Plus = "+"+showOp Mult = "*"+showOp IntEq = "=="+showOp IntLess = "<"++showP (Pconst i) = show i+showP (Pvar n) = n+showP (Pcondata n ns) = +                "(" ++ n ++ " " ++ +                (foldr (\ s t -> if t/="" then (showP s) ++ "," ++ t+                                     else (showP s)) +                        "" ns)+                ++ ")"+showP (Pnewdata n x) = "(" ++ n ++ " " ++ (showP x) ++ ")"              +showP (Ptilde p) = "~" ++ (showP p)++showM :: Match -> String+showM (Normal p e ds) = showP p ++ "->" +                                ++ showE e +                                ++ " where " ++ showDecls ds+showM (Guarded p glist ds) = +    (foldr (++) "" +       (map (\(g,b) -> showP p ++ " | " ++ showE g ++ "->" ++ showE b) glist))+                    ++ " where " ++ showDecls ds++showE :: E -> String+showE (Const i) = show i+showE Tconst = "True"+showE Fconst = "False"+showE (Var nm) = nm+showE (Abs p d) = "(\\" ++ (showP p) ++ " -> " ++ showE d ++ ")"+showE (App d d') = "(" ++ showE d ++ " " ++ showE d' ++ ")"+showE (Let dcls d) = "let " ++ +                          foldr (++) "" (map (\(p,e)-> showD (p,e)) dcls)+                            ++ +                        " in " ++ showE d+showE (ConApp n l) =  "(" ++ n ++ " " ++  +                (foldr (\ (s,ls) t -> +			    let sa = if (ls == Strict) then "!" else "" +			    in+				 if t/="" then sa ++ (showE s) ++ "," ++ t+                                     else sa ++ (showE s)) +                        "" l)+                      ++ ")"+showE (NewApp n x) = "(" ++ n ++ " " ++  (showE x) ++ ")"                     ++showE (PairExp n l) = "<"++showE n++","++ showE l ++ ">"+showE (Bin op d d') = "(" ++ showE d ++ " " ++ showOp op ++ " " ++ +                               showE d' ++ ")"+showE Tconst = "true"+showE Fconst = "false"+showE (Case e ms) =+      "(case " ++ showE e ++ " of " ++ +           (foldr (++) "" (map (\m -> "[" ++ (showM m) ++ "]") ms)) ++ ")"+++instance Show E where+  show = showE++----------------------------------------------------------------------+-- Values+----------------------------------------------------------------------++type EnvFrag = [(Name,M Value)]++data Value+  = +--- scalars+    Z Integer+  | BV Bool+--- CBN functions+  | Fun (M Value -> M Value)+--- Generic structured data+  | Tagged Name [M Value]+--- values for all tuples:+  | TupleVal [M Value]++data Fix a = Fix (Fix a -> a)+fix = \ f -> (\ (Fix x) -> +                   (f (\ a -> x (Fix x) a)))+                      (Fix (\ (Fix x) -> (f (\ a -> x (Fix x) a))))++showValue :: Value -> String+showValue (Z i) = show i+showValue (BV i) = show i+showValue (Fun _) = "(function)"+showValue (Tagged n arglist) = "(" ++ n ++ " " ++ (present (map splat arglist)) ++ ")"++present (x:(y:rest)) = (show x)++" "++(present (y:rest))+present (x:[]) = show x+present [] = ""++instance Show Value where+  show = showValue++splat phi = (deM phi (\msg -> error "hey - you're applying the empty env!"))+run le = (deM (eval le) (\msg -> error "hey - you're applying the empty env!"))++----------------------------------------------------------------------+-- Errors+----------------------------------------------------------------------++data Error a = Ok a | Err String++----------------------------------------------------------------------+-- Error monad+----------------------------------------------------------------------+++errUnit :: a -> Error a+errUnit = Ok+++errBind :: Error a -> (a -> Error b) -> Error b+errBind x f = case x of+                     (Ok v) -> f v+                     (Err msg) -> (Err msg)++instance Monad Error where+  return = errUnit+  (>>=) = errBind++showEC x =+       case x of+            (Ok v) -> show v+            (Err msg) -> show msg++showError :: Show a => Error a -> String+showError x =+       case x of+            (Ok v) -> show v+            (Err msg) -> show msg++instance Show a => Show (Error a) where+    show = showError++raise0 = Err++----------------------------------------------------------------------+-- Environments+----------------------------------------------------------------------++type Env = Name -> M Value++----------------------------------------------------------------------+-- M = Environment+Error +----------------------------------------------------------------------++newtype M a = M (Env -> (Error a))++mUnit :: a -> M a+mUnit a = M (\rho -> return a)+++mBind :: M a -> (a -> M b) -> M b+mBind x f =+        M (\rho -> +                 do { v <- (deM x) rho ; deM (f v) rho })++instance Monad M where+  return = mUnit+  (>>=) = mBind++deM (M x) = x++lift :: Error a -> M a+lift ec = M (\ _ ->  ec)++----------------------------------------------------------------------+-- Non-standard Morphisms+----------------------------------------------------------------------++raise :: String -> M a+raise = \msg -> lift (raise0 msg)++rdEnv :: M Env+rdEnv = M (\rho -> return rho)++tweek f x y = \ z -> if x == z then y else f z++xEnv :: Env -> Name -> M Value -> Env+xEnv rho n phi = tweek rho n phi++inEnv :: Env -> M a -> M a+inEnv rho (M x) = M (\ _ -> x rho)++----------------------------------------------------------------------+-- +----------------------------------------------------------------------++--- these functions/PairVal should be replaced with select/Tagged:++proj :: Int -> M Value -> M Value+proj n phi = do { (TupleVal mvals) <- phi ; mvals !! (n-1)  }++--- N.b., checkTag now strips off the tag "t"+checkTag :: Name -> M Value -> M Value+checkTag tag arg =+         do { (Tagged t mvals) <- arg+            ; if t==tag then return (TupleVal mvals)+              else raise $ "Tag " ++ t ++ "!="++tag+              }+++concatM ::Monad m => [m [a]] -> m [a]+concatM x = sequence x >>= (return . concat)++---+--- N.b., the meaning of match has changed so that+--- pattern failure is explicit in the range here:+---+match :: P -> M Value -> M (Maybe EnvFrag)+match (Pvar x) arg = return $ Just [(x,arg)]+match (Ptilde p) arg = return $ Just (lazymatch p arg)+match (Pconst i) arg = do { (Z v) <- arg+                          ; if v==i then +                                    return $ Just []+                            else return Nothing+                            }+match (Ppair p1 p2) arg = +      do { (TupleVal mvals) <- arg+         ; vbl1 <- match p1 (head mvals)+         ; vbl2 <- match p2 (head $ tail mvals)+         ; case (vbl1,vbl2) of+             (Just vl1, Just vl2) ->return $ Just (vl1 ++ vl2) +             _ -> return Nothing+         }+match (Ptuple ps) arg = +   do { (TupleVal mvals) <- arg+      ; sequence (map (\(p,phi) -> match p phi) (zip ps mvals)) +                 >>= (return . concatM)+             }+match (Pcondata tag ps) arg = +   do { (Tagged t mvals) <- arg+      ; if tag==t +        then+           sequence (map (\(p,phi) -> match p phi) (zip ps mvals)) +                >>= (return . concatM)+        else return Nothing+             }+match (Pnewdata n p) arg = match p arg+  +++lazymatch :: P -> M Value -> EnvFrag+lazymatch (Pconst k) mv = []+lazymatch (Pvar x) mv = [(x,mv)]+lazymatch (Ptilde p) mv = lazymatch p mv+lazymatch (Ppair p1 p2) mv = +          lazymatch p1 (proj 1 mv) ++ lazymatch p2 (proj 2 mv)+lazymatch (Pcondata n ps) mv = +   concat (map (\(i,p) -> lazymatch p (proj i (checkTag n mv)))+                    (zip [1..(length ps)] ps))+lazymatch (Pnewdata n p) mv = lazymatch p mv                    +lazymatch (Ptuple ps) mvals = +   concat (map (\(i,p) -> lazymatch p (proj i mvals))+                    (zip [1..(length ps)] ps))+++app :: M Value -> M Value -> M Value+app x y = do { rho <- rdEnv ; (Fun f1) <- x ; f1 (inEnv rho y) }++addBindings :: Env -> EnvFrag -> Env+addBindings rho [] = rho+addBindings rho ((n,mv):bindings) = addBindings (xEnv rho n mv) bindings++---+--- N.b. ,I use this in the definition of (eval (Let ...)) and in the +--- meaning of matches as well +---+letbind :: [(P,E)] -> M a -> M a+letbind pelist phi =+     do { rho <- rdEnv+        ; let rho' = +               fix (\ r -> +                 addBindings rho $+                   foldr (++) []  +                         (map (\(p,e)->lazymatch p (inEnv r (eval e))) pelist))+          in+               inEnv rho' phi+               }+++eval :: E -> M Value+eval (Const i) = return (Z i)+eval Tconst = return $ BV True+eval Fconst = return $ BV False+eval Boom = eval Boom+eval Undefined = raise "Undefined"+eval (Var n) = do { rho <- rdEnv ; rho n }+---+--- N.b., the abstraction must check if it gets an EnvFrag back.+---+eval (Abs p l) = +     do { rho <- rdEnv +        ; return (Fun $ \ arg ->+                   do { vbl <- match p arg +                      ; case vbl of+                           (Just vl) -> +                              inEnv (addBindings rho vl) (eval l) +                           Nothing -> raise "Match Error in Abs"+                           } ) }+eval (App l1 l2) =+     do { rho <- rdEnv+        ; (Fun f1) <- eval l1+        ; f1 (inEnv rho $ eval l2) }+eval (PairExp l1 l2) = +     do { rho <- rdEnv+        ; return (TupleVal [inEnv rho (eval l1), inEnv rho (eval l2)])+          }+eval (TupleExp es) = +  do { rho <- rdEnv ; return (TupleVal $ map (\e -> inEnv rho $ eval e) es) }+{-+ This is a little difficult to understand as is, although what is going on is+ quite simple. Here's how I would write it in standard mathematical notation:++[[ c e1 !e2 ]] =+     rdEnv >>= \rho ->+     [[ e2 ]] >>= \ v2 ->+        return (c* (inEnv rho [[e1]]) (return v2))++That is, e2 (annotated as strict) is evaluated early and a trivial computation+"(return v2)" is kept for it. +-}+eval (ConApp n es) = +  do { rho <- rdEnv+     ; let evald_es = map (\(e,ls) -> +			   case ls of+			     Lazy -> return(inEnv rho $ eval e)+			     Strict -> eval e >>= \v -> return(return v)) es+       in+          f evald_es >>= \result -> return (Tagged n $ result)+       }+   where +	 f [] = return []+	 f (phi:phis) = phi >>= \v-> (f phis) >>= \vs -> return (v:vs)+eval (NewApp n x) = eval x++{-+         (foldr (\ phi phis -> phi >>= \v-> (f phis) >>= \vs -> return (v:vs)) +                (return [])+foldr (\ phi phis -> phi >>= \v-> (f phis) >>= \vs -> return (v:vs)) +      (return [])+      es+-}++---+--- N.b., this is the new definition of case.+---+eval (Case e ms) = evalMatchList (map evalM ms) (eval e)+eval (Let pelist le) = letbind pelist $ eval le+eval (Bin op l1 l2) =+     case op of +      Plus -> +        do { (Z i1) <- eval l1 +           ; (Z i2) <- eval l2 +           ; return (Z (i1+i2)) }+      Mult -> +        do { (Z i1) <- eval l1 +           ; (Z i2) <- eval l2 +           ; return (Z (i1*i2)) }+      IntEq ->+        do { (Z i1) <- eval l1 +           ; (Z i2) <- eval l2 +           ; return (BV (i1==i2)) }+      IntLess ->+        do { (Z i1) <- eval l1 +           ; (Z i2) <- eval l2 +           ; return (BV (i1<i2)) }++eval (Cond l1 l2 l3) =+     do { (BV b) <- eval l1+        ; if b then (eval l2) else (eval l3) }++-------------------------------------------------------------+-------------- Matches and their meaning  -------------------+-------------------------------------------------------------++justify :: M Value -> M (Maybe Value)+justify x = x >>= (return . Just)++evalM :: Match -> M Value -> M(Maybe Value)+evalM (Normal p e ds) arg = +   do { mfrag <- match p arg+      ; case mfrag of+         Nothing -> return Nothing+         Just frag -> do { env <- rdEnv+                         ; inEnv (addBindings env frag) +                                    $ letbind ds (justify (eval e))+                         }+      }+evalM (Guarded p guards ds) arg =+   do { env <- rdEnv+      ; mfrag <- match p arg+      ; case mfrag of+         Nothing   -> return Nothing+         Just frag -> inEnv (addBindings env frag) +                               $ letbind ds (evalGuardedList guards)+      }+    where+        evalGuardedList :: [(E,E)] -> M (Maybe Value)+        evalGuardedList [] = return Nothing+        evalGuardedList ((g,b):gs) =+                           do { v <- eval g+                              ; case v of+                                   (BV True)  -> (eval b) >>= (return . Just)+                                   (BV False) -> evalGuardedList gs+                              }++evalMatchList :: [M Value -> M(Maybe Value)] -> (M Value -> M Value)+evalMatchList [] arg = raise "Match Failure"+evalMatchList (f:fs) arg = +  do { mv <- f arg+     ; case mv of+         Nothing -> evalMatchList fs arg+         Just v -> return v+     }++--------------------------------------------------------------+--------------------------------------------------------------+--------------------------------------------------------------
+ tools/interp/HaskellCoreLite1.3.hs view
@@ -0,0 +1,194 @@+module HaskellCoreLite1_3 where ++import AST+import Monad++------------------------------------+-- Monadic control structures+------------------------------------++caseM test fail successf =+  do { vbl <- test+     ; case vbl of+         Nothing -> fail+         Just x -> successf x+     }++ifV test thenM elseM =+  do { BV b <- test+     ; if b then thenM else elseM+     }+     +----------------------------------------------------------------------+--- these functions do matching or selection+----------------------------------------------------------------------++proj :: Int -> M Value -> M Value+proj n phi = do { (TupleVal mvals) <- phi ; mvals !! (n-1)  }++checkTag :: Name -> M Value -> M Value+checkTag tag arg =+    do { (Tagged t mvals) <- arg+       ; if t==tag +            then return (TupleVal mvals)+            else raise("Tag " ++ t ++ "!="++tag)+       }+++concatM ::Monad m => [m [a]] -> m [a]+concatM x = sequence x >>= (return . concat)++match :: P -> M Value -> M (Maybe EnvFrag)+match (Pvar x) arg = return (Just [(x,arg)])+match (Ptilde p) arg = return (Just (lazymatch p arg))+match (Pconst i) arg = +    do { (Z v) <- arg+       ; if v==i +            then return(Just [])+            else return Nothing+       }+match (Ptuple ps) arg = +    do { (TupleVal mvals) <- arg+       ; frags <- sequence(zipWith match ps mvals)+       ; return(concatM frags)+       }+match (Pcondata tag ps) arg = +    do { (Tagged t mvals) <- arg+       ; if tag==t +         then sequence (zipWith match ps mvals) >>= (return . concatM)+         else return Nothing+       }+match (Pnewdata n p) arg = match p arg+  +++lazymatch :: P -> M Value -> EnvFrag+lazymatch (Pconst k) mv = []+lazymatch (Pvar x) mv = [(x,mv)]+lazymatch (Ptilde p) mv = lazymatch p mv+lazymatch (Pcondata n ps) mv = concat(zipWith tagN [1..] ps)+    where tagN i p = lazymatch p (proj i (checkTag n mv))+lazymatch (Pnewdata n p) mv = lazymatch p mv                    +lazymatch (Ptuple ps) mvals = concat(zipWith select [1..] ps)+    where select i p = lazymatch p (proj i mvals)++app :: M Value -> M Value -> M Value+app x y = do { rho <- rdEnv ; (FV f1) <- x ; f1 (inEnv rho y) }++addBindings :: Env -> EnvFrag -> Env+addBindings rho [] = rho+addBindings rho ((n,mv):bindings) = addBindings (xEnv rho n mv) bindings++----------------------------------------------------------+letbind :: [D] -> M a -> M a+letbind ds phi =+     do { rho <- rdEnv+        ; let rho' = fix (\ r -> addBindings rho (addDs ds r))+          in inEnv rho' phi+        }+               +addDs :: [D] -> Env -> EnvFrag+addDs [] r = []+addDs (d:ds) r =+  case d of+   (Val p body ds) -> lazymatch p (inEnv r (letbind ds (evalB body))) ++ (addDs ds r)+   (Fun nm cls) -> (nm,evalCls cls) : (addDs ds r)+    where evalCls :: [([P],B,[D])] -> M Value+          evalCls [] = raise "no guard matches"+          evalCls ((ps,body,ds):cls) = +              arrow ps (inEnv r (letbind ds (evalB body)))   ++arrow :: [P] -> M Value -> M Value+arrow [] b = b+arrow (p:ps) b =+   do { rho <- rdEnv+      ; let f v = caseM (match p v) +                       (raise "match Error in Fun")+                       (\ vl -> inEnv (addBindings rho vl) (arrow ps b))+      ; return(FV f)+      }++evalB :: B -> M(Value)+evalB (Normal e) = (eval e)+evalB (Guarded []) = error "no guard matches"+evalB (Guarded ((g,e):gs)) = ifV (eval g) (eval e) (evalB (Guarded gs))+      ++eval :: E -> M Value+eval (Const i) = return (Z i)+eval Tconst = return (BV True)+eval Fconst = return (BV False)+eval Boom = eval Boom+eval Undefined = raise "Undefined"+eval (Var n) = do { rho <- rdEnv ; rho n }+eval (Abs ps l) = arrow ps (eval l)+eval (App l1 l2) =+   do { rho <- rdEnv+      ; (FV f1) <- eval l1+      ; f1 (inEnv rho $ eval l2) }+eval (TupleExp es) = +   do { rho <- rdEnv ; return (TupleVal $ map (\e -> inEnv rho $ eval e) es) }+eval (ConApp n es) = +   do { rho <- rdEnv+      ; let f (e,Lazy) es   = do { cs <- es+                                 ; return ((inEnv rho (eval e)):cs) }+            f (e,Strict) es = do { c <- eval e; cs <- es+                                 ; return((return c):cs)}+      ; cs <- foldr f (return []) es+      ; return(Tagged n cs)+      }  +eval (NewApp n x) = eval x+eval (Case e ms) = evalMatchList (map evalM ms) (eval e)+eval (Let pelist le) = letbind pelist (eval le)+eval (Bin op l1 l2) =+   do { (Z i1) <- eval l1+      ; (Z i2) <- eval l2+      ; return(f op i1 i2)+      }+ where f Plus x y = Z(x + y)+       f Mult x y = Z(x * y)+       f IntEq x y = BV(x==y)+       f IntLess x y = BV(x < y)+eval (Cond l1 l2 l3) = ifV (eval l1) (eval l2) (eval l3)+     ++-------------------------------------------------------------+-------------- Matches and their meaning  -------------------+-------------------------------------------------------------++justify :: M Value -> M (Maybe Value)+justify x = x >>= (return . Just)++--- Probably need a new name for this:+evalM :: (P,B,[D]) -> M Value -> M(Maybe Value)+evalM (p,(Normal e),ds) arg = +   caseM (match p arg) (return Nothing)+         (\frag ->  do { rho <- rdEnv+                       ; inEnv (addBindings rho frag) +                               $ letbind ds (justify (eval e))+                       })+evalM (p,(Guarded guards),ds) arg =+   caseM (match p arg) (return Nothing) +      (\frag ->  do { rho <- rdEnv+                    ; inEnv (addBindings rho frag) +                           $ letbind ds (evalGuardedList guards) } )+    where+        evalGuardedList :: [(E,E)] -> M (Maybe Value)+        evalGuardedList [] = return Nothing+        evalGuardedList ((g,b):gs) =+                           do { v <- eval g+                              ; case v of+                                   (BV True)  -> (eval b) >>= (return . Just)+                                   (BV False) -> evalGuardedList gs+                              }++evalMatchList :: [M Value -> M(Maybe Value)] -> (M Value -> M Value)+evalMatchList [] arg = raise "Match Failure"+evalMatchList (f:fs) arg = caseM (f arg) (evalMatchList fs arg) return++--------------------------------------------------------------+--------------------------------------------------------------+--------------------------------------------------------------++splat phi = (deM phi (\msg -> error "hey - you're applying the empty env!"))+run le = (deM (eval le) (\msg -> error "hey - you're applying the empty env!"))
+ tools/interp/HaskellWorkshop/Ideas.txt view
@@ -0,0 +1,48 @@+Haskell is complex,++No one has ever given a precise semantics for all the little+corners such as, nested patterns, lazy pattern matching, guards etc.++Why in Haskell?+  common vocabulary+      easier for Haskell programmers to understand+      +  executable+      Part of the programatica project (worlds slowest haskell implementation)+      +  unlike the haskell report gives a finer grain definition+  +  Standard against which to compare other implementations+  +  Introduce examples which illustrate the subtleties+  +Format ++0) Whats wrong with other descriptions+        patterns are always simple+        distinction between case, let, lambda, lazy patterns+        Sematics as translation introduces Variable introduction problem+        Guards are subtle, they may force unnecesary evaluation+        ++1) Why a Monadic description?+   what monad?++2) Call by name vs lazy description++3) The meaning of patterns+        Different uses of patterns+        case, let, lambda+        Lazy patterns+        nested patterns+        +4) Guards++5) Other things+        Strict Data constructors+        newtypes and lifting+        +6) Type classes, +        suggestion library introduction transform+        +7)        
+ tools/interp/HaskellWorkshop/body.bib view
@@ -0,0 +1,459 @@+++@InProceedings{Haskell::Jones1999,+  title =        "Typing Haskell in Haskell",+  author =       "Mark P. Jones",+  pages =        "68--78",+  booktitle =    "Proceedings of the 1999 Haskell Workshop",+  month =        "21--24 " # oct,+  year =         "1999",+  address =      "Paris, France",+  note = "Published in Technical Report UU-CS-1999-28, Department of+Computer Science, University of Utrecht"+}++@TechReport{Steele-Sussman78b,+  key =          "Steele \& Sussman",+  author =       "Guy Lewis {Steele Jr.} and Gerald Jay Sussman",+  title =        "The Art of the Interpreter or, The Modularity Complex+                 (Parts Zero, One, and Two)",+  institution =  "Massachusetts Institute of Technology, Artificial+                 Intelligence Laboratory",+  year =         "1978",+  month =        may,+  type =         "AI Memo",+  number =       "453",+  annote =       "Several metacircular interpreters for different+                 variants of LISP. Discussion of how the language design+                 decisions affect the programming styles available to+                 the user of the language. 24 references.",+}++@Book{Abelson-Sussman-Sussman96,+  key =          "Abelson \& Sussman \& Sussman",+  author =       "Harold Abelson and Gerald Jay Sussman and Julie+                 Sussman",+  title =        "Structure and Interpretation of Computer Programs",+  publisher =    "McGraw Hill",+  address =      "Cambridge, Mass.",+  year =         "1996",+  edition =      "second",+  ISBN =         "0-07-000484-6",+  annote =       "Introductory programming text using the Scheme dialect+                 of Lisp. Many references.",+}++@InProceedings{LiangHudak,+  author =       "Sheng Liang and Paul Hudak and Mark Jones",+  title =        "Monad transformers and modular interpreters",+  editor =       "{ACM}",+  booktitle =    "Conference record of {POPL} '95, 22nd {ACM}+                 {SIGPLAN-SIGACT} Symposium on Principles of Programming+                 Languages: papers presented at the Symposium: San+                 Francisco, California, January 22--25, 1995",+  publisher =    "ACM Press",+  address =      "New York, NY, USA",+  year =         "1995",+  ISBN =         "0-89791-692-1",+  pages =        "333--343",+  bibdate =      "Mon May 3 12:52:30 MDT 1999",+  OPTurl =          "http://www.acm.org:80/pubs/citations/proceedings/plan/199448/p333-liang/",+  abstract =     "We show how a set of {\em building blocks\/} can be+                 used to construct programming language interpreters,+                 and present implementations of such building blocks+                 capable of supporting many commonly known features,+                 including simple expressions, three different function+                 call mechanisms (call-by-name, call-by-value and lazy+                 evaluation), references and assignment, nondeterminism,+                 first-class continuations, and program tracing. The+                 underlying mechanism of our system is {\em monad+                 transformers\/}, a simple form of abstraction for+                 introducing a wide range of computational behaviors,+                 such as state, I/O, continuations, and exceptions. Our+                 work is significant in the following respects. First,+                 we have succeeded in designing a fully modular+                 interpreter based on monad transformers that incudes+                 features missing from Steele's, Espinosa's, and+                 Wadler's earlier efforts. Second, we have found new+                 ways to lift monad operations through monad+                 transformers, in particular difficult cases not+                 achieved in Moggi's original work. Third, we have+                 demonstrated that interactions between features are+                 reflected in liftings and that semantics can be changed+                 by reordering monad transformers. Finally, we have+                 implemented our interpreter in Gofer, whose constructor+                 classes provide just the added power over Haskell's+                 type classes to allow precise and convenient expression+                 of our ideas. This implementation includes a method for+                 constructing extensible unions and a form of subtyping+                 that is interesting in its own right.",+  acknowledgement = ack-nhfb,+  keywords =     "algorithms; design; languages",+  subject =      "{\bf D.3.4} Software, PROGRAMMING LANGUAGES,+                 Processors, Interpreters. {\bf F.3.2} Theory of+                 Computation, LOGICS AND MEANINGS OF PROGRAMS, Semantics+                 of Programming Languages, Denotational semantics. {\bf+                 D.3.3} Software, PROGRAMMING LANGUAGES, Language+                 Constructs and Features, Data types and structures.",+}+++@Book{Stoy,+  author =       "J. E. Stoy",+  title =        "{Denotational Semantics: The Scott-Strachey Approach+                 to Programming Language Semantics}",+  publisher =    "MIT Press",+  address =      "Cambridge, Massachusetts",+  year =         "1977",+}+ ++@Book{Gunter,+  author =       "Carl A. Gunter",+  title =        "Semantics of Programming Languages: Programming+                 Techniques",+  publisher =    "The {MIT} Press",+  year =         "1992",+  address =      "Cambridge, Massachusetts",+  topic =        "semantics-of-programming-languages;",+}++@InCollection{Mog:meta,+  author =       "Eugenio Moggi",+  title =        "Metalanguages and Applications",+  editor =       "A. M. Pitts and P. Dybjer",+  booktitle =    "Semantics and Logics of Computation",+  series =       "Publications of the Newton Institute",+  volume =       "14",+  pages =        "185--239",+  publisher =    "Cambridge University Press",+  address =      "Cambridge",+  year =         "1997",+}++@Article{Moggi,+  author =       "E. Moggi",+  title =        "Functor Categories and Two-Level Languages",+  journal =      "Lecture Notes in Computer Science",+  volume =       "1378",+  pages =        "211--??",+  year =         "1998",+  coden =        "LNCSD9",+  ISSN =         "0302-9743",+  bibdate =      "Tue Apr 28 08:51:33 MDT 1998",+  acknowledgement = ack-nhfb,+}++++@InProceedings{Pitts00,+  author =       "A. M. Pitts and M. J. Gabbay",+  title =        "A Metalanguage for Programming with Bound Names Modulo Renaming",+  booktitle =    "Mathematics of Programme Construction",+  pages =        "230-255",+  year =         2000,+  volume =       1837,+  series =       "LNCS",+  publisher =    "Springer-Verlag",+}++@Article{JFP::Sabry1998,+  title =        "What is a purely functional language?",+  author =       "Amr Sabry",+  pages =        "1--22",+  journal =      "Journal of Functional Programming",+  month =        jan,+  year =         "1998",+  volume =       "8",+  number =       "1",+  references =   "\cite{JFP::AriolaF1997} \cite{POPL::AriolaFMOW1995}+                 \cite{POPL::CartwrightF1992} \cite{TCS::FelleisenH1992}+                 \cite{POPL::Filinski1994} \cite{POPL::OderskyRH1993}+                 \cite{JFP::OHearn1996} \cite{POPL::PeytonJonesW1993}+                 \cite{TCS::Plotkin1975} \cite{TCS::Plotkin1977}+                 \cite{POPL::WeeksF1993}",+}++@Article{Reynolds,+  author =       "John Reynolds",+  year =         "1972",+  publisher =    "ACM",+  journal =      "ACM Conference Proceedings",+  pages =        "717--740",+  title =        "Definitional Interpreters for Higher Order Programming+                 Languages",+}+++@PhdThesis{Espinosa95PHD,+  author =       "David Espinosa",+  title =        "Semantic {Lego}",+  year =         "1995",+  school =       "Columbia University",+  url =          "http://www-swiss.ai.mit.edu/ftpdir/users/dae/home.html",+  keywords =     "action semantics, monads",+}++@Article{Wad92:monads,+  author =       "P. Wadler",+  title =        "Comprehending monads",+  journal =      "Mathematical Structures in Computer Science",+  pages =        "461--493",+  year =         "1992",+  volume =       "2",+  OPTnote =         "Category theorists invented {\em monads\/} in the+                 1960's to concisely express certain aspects of+                 universal algebra. Functional programmers invented {\em+                 list comprehensions\/} in the 1970's to concisely+                 express certain programs involving lists. This paper+                 shows how list comprehensions may be generalised to an+                 arbitrary monad, and how the resulting programming+                 feature can concisely express in a pure functional+                 language some programs that manipulate state, handle+                 exceptions, parse text, or invoke continuations. A new+                 solution to the old problem of destructive array update+                 is also presented. No knowledge of category theory is+                 assumed.",+}++@Article{Wadler:1995:MFP,+  author =       "P. Wadler",+  title =        "Monads for functional programming",+  journal =      "Lecture Notes in Computer Science",+  volume =       "925",+  pages =        "24--52",+  year =         "1995",+  coden =        "LNCSD9",+  ISSN =         "0302-9743",+  bibdate =      "Sat May 11 13:45:32 MDT 1996",+  acknowledgement = ack-nhfb,+}++@InProceedings{DSL99*81,+  author =       "Tim Sheard and Zine-el-abidine Benaissa and Emir+                 Pasalic",+  title =        "{DSL} Implementation Using Staging and Monads",+  pages =        "81--94",+  booktitle =    "Proceedings of the 2nd Conference on Domain-Specific+                 Languages",+  month =        oct # "~3--5",+  publisher =    "USENIX Association",+  address =      "Berkeley, CA",+  year =         "1999",+}++@Book{PeytonJones86,+  author =       "Simon L. Peyton Jones",+  title =        "The Implementation of Functional Programming+                 Languages",+  publisher =    "Prentice-Hall",+  year =         "1987",+  ISBN =         "0-13-453325-9",+  series =       "Computer Science",+}+++@Book{Kamin,+  author =       "Samuel N. Kamin",+  title =        "Programming Languages, An Interpreter-Based Approach",+  publisher =    "Addison Wesley",+  year =         "1990",+  ISBN =         "0-201-06824-9",+}++@Book{Friedman,+  author =       "Daniel P. Friedman and Mitchell Wand and Christopher+                 T. Haynes",+  title =        "Essentials of Programming Languages",+  publisher =    "McGraw-Hill Book Co.",+  edition =      "second",+  year =         "2001",+  address =      "New York, N.Y.",+  annote =       "Graduate text on programming languages, concentrating+                 on semantics of imperative languages using+                 interpreters. Also some disucssion of compilation. 59+                 references.",+  source =       "Leavens bib",+}+++@InProceedings{Gabbay99lics,+  author =       "Murdoch Gabbay and Andrew Pitts",+  title =        "A New Approach to Abstract Syntax Involving Binders",+  editor =       "G. Longo",+  pages =        "214--224",+  booktitle =    "Proceedings of the 14th Annual Symposium on Logic in+                 Computer Science (LICS'99)",+  year =         "1999",+  publisher =    "IEEE Computer Society Press",+  address =      "Trento, Italy",+  month =        jul,+  keywords =     "misc",+}++@TechReport{Haskell98,+  author =       "Simon Peyton Jones and John Hughes, editors",+  title =        "Report on the Programming Language {Haskell 98}",+  institution =  "Yale University, CS Dept.",+  type =         "Technical Report",+  number =       "YALEU/DCS/RR-1106",+  month =        feb,+  year =         "1999",+}+++@PhdThesis{LiangThesis,+  author =       {Sheng Liang},+  title =        {Modular Monadic Semantics and Compilation},+  school =       {Yale University},+  year =         {1997},+  OPTkey =       {},+  OPTtype =      {},+  OPTaddress =   {},+  OPTmonth =     {},+  OPTnote =      {},+  OPTannote =    {}+}++@Article{PeytonJone92a,+  author =       "Simon L. Peyton Jones",+  journal =      "Journal of Functional Programming",+  title =        "Implementing lazy functional languages on stock+                 hardware: the Spineless Tagless {G}-machine",+  year =         "92",+  document-size = "211.2 kbytes",+  OPTurl =          "ftp://ftp.dcs.gla.ac.uk/pub/glasgow-fp/papers/spineless-tagless-gmachine.ps.Z",+  month =        jul,+  number =       "2",+  pages =        "127--202",+  volume =       "2",+  scope =        "implemen",+}++@Article{PeytonJones:1998:TBO,+  author =       "Simon L. {Peyton Jones} and Andr{\'e} L. M. Santos",+  title =        "A transformation-based optimiser for {Haskell}",+  journal =      "Science of Computer Programming",+  volume =       "32",+  number =       "1--3",+  pages =        "3--47",+  day =          "1",+  month =        sep,+  year =         "1998",+  coden =        "SCPGD4",+  ISSN =         "0167-6423",+  bibdate =      "Mon Oct 11 18:07:09 MDT 1999",+  OPTurl =          "http://www.elsevier.com/cas/tree/store/scico/sub/1998/32/1-3/538.pdf",+  acknowledgement = ack-nhfb,+  affiliation =  "Univ of Glasgow",+  affiliationaddress = "Glasgow, UK",+  classification = "723.1; 723.1.1; 921.3; 921.5",+  journalabr =   "Sci Comput Program",+  keywords =     "Computer programming languages; Glasgow Haskell+                 compiler (ghc); Mathematical transformations;+                 Optimization; Program compilers; Second-order lambda+                 calculus",+  xxtitle =      "Transformation-based optimizer for {Haskell}",+}+++@Article{SCP::JonesS1998,+  title =        "A transformation-based optimiser for~{Haskell}",+  author =       "Simon L. Peyton Jones and Andr{\'e} L. M. Santos",+  pages =        "3--47",+  journal =      "Science of Computer Programming",+  month =        sep,+  year =         "1998",+  volume =       "32",+  number =       "1--3",+  preliminary =  "ESOP::Jones1996:18",+}++@Article{Wadler92,+  author =       "P. Wadler",+  title =        "The essence of functional programming.",+  journal =      "19th POPL",+  pages =        "1--14",+  publisher =    "ACM",+  month =        jan,+  year =         "1992",+  keywords =     "FP, functional programming, monad, monads, exception,+                 state, continuations, type, types, POPL, POPL19,+                 POPL92",+}+ ++@Misc{programatica,+  OPTcrossref = "http://www.cse.ogi.edu/PacSoft/projects/programatica/default.htm",+  key = "Programatica, a Pacific Software Research Center Project",+  author = "{James Hook, Prinicpal Investigator}",+  title = "Programatica Home Page",+  howpublished = "http://www.cse.ogi.edu/PacSoft/projects/programatica/default.htm",+  year = "2001"+  }+  +++@InProceedings{JonesMark93,+  author =       "Mark P. Jones",+  booktitle =    "FPCA '93: Conference on Functional Programming and+                 Computer Architecture, Copenhagen, Denmark",+  title =        "{A} system of constructor classes: overloading and+                 implicit higher-order polymorphism",+  year =         "1993",+  publisher =    "ACM Press",+  address =      "New York, N.Y.",+  OPTurl =          "ftp://nebula.cs.yale.edu/pub/yale-fp/papers/fpca93.dvi.Z",+  month =        jun,+  pages =        "52--61",+}++@Article{Hall:1994:TCH,+  author =       "C. Hall and K. Hammond and S. Peyton Jones and P.+                 Wadler",+  title =        "Type classes in Haskell",+  journal =      "Lecture Notes in Computer Science",+  volume =       "788",+  pages =        "241--??",+  year =         "1994",+  coden =        "LNCSD9",+  ISSN =         "0302-9743",+  bibdate =      "Mon May 13 11:52:14 MDT 1996",+  acknowledgement = ack-nhfb,+}++@Article{newcore,+  author = "Simon L. Peyton-Jones and Simon Marlowe",+  title = "Secrets of the Glasgow Haskell Compiler Inliner",+  journal = "IDL'99",+  note = "http://research.microsoft.com/Users/simonpj/papers/inline.ps.gz"+  }+  +@TechReport{Danvy,+  author =       "O Danvy and J Koslowski and K Malmkjaer",+  institution =  "Kansas State University",+  title =        "Compiling Monads",+  year =         "91",+  address =      "Manhattan, Kansas",+  document-size = "34.1 kbytes",+  url =          "ftp://ftp.diku.dk/pub/diku/semantics/papers/D-154.dvi.Z",+  keywords =     "computational monads, lambda-interpreters, partial+                 evaluation",+  month =        dec,+  number =       "CIS-92-3",+  scope =        "monads",+}++@TechReport{MoggiE90a,+  author =       "E Moggi",+  institution =  "Dept. of Computer Science, Edinburgh Univ.",+  title =        "An Abstract View of Programming Languages",+  year =         "90",+  document-size = "63.3 kbytes",+  url =          "http://theory.doc.ic.ac.uk/papers/MoggiE/abs-view.dvi.gz",+  number =       "ECS-LFCS-90-113",+  scope =        "monads",+}+++  
+ tools/interp/HaskellWorkshop/body.tex view
@@ -0,0 +1,1316 @@+\documentclass{entcs} \usepackage{entcsmacro}+\usepackage{graphicx}++\include{psinput}+\include{psfig}+\include{global-defs}+% New definitions+\newcommand{\hletexp}[2]{\ensuremath{let\;#1\;in\;#2}}+\newcommand{\hlambda}[2]{\ensuremath{\backslash #1 \mbox{{\tt ->}}\, #2}}+\newcommand{\hsem}[1]{\ensuremath{\standard{\mathtt{#1}}}}++\def\lastname{Sheard, Harrison, and Hook}+\begin{document}+\begin{frontmatter}+  \title{Modeling Fine Control of Demand in Haskell} +      \author{Tim Sheard\thanksref{ALL}\thanksref{myemail}}+      \author{William Harrison\thanksref{coemail}}+      \author{James Hook\thanksref{triemail}}+      \address{Pacific Software Research Center\\+               Oregon Graduate Institute\\+               Beaverton, Oregon}                +      \thanks[ALL]{The work described here was supported by NSF Grant CDA-9703218, +                   the M.J. Murdock Charitable Trust and the Department of Defense.} +      \thanks[myemail]{Email: {\texttt{\normalshape sheard@cse.ogi.edu}}} +      \thanks[coemail]{Email: {\texttt{\normalshape wlh@cse.ogi.edu}}}+      \thanks[triemail]{Email: {\texttt{\normalshape hook@cse.ogi.edu}}}+    +    +\begin{abstract} +The lazy functional language Haskell can be viewed at many levels.  At the +highest level it can be manipulated as if it were the call-by-name lambda +calculus.  Slightly below this level is the model of the call-by-need +lambda calculus, where control over duplication of computation becomes +explicit. Underneath this level is a more detailed model that provides +precise control over the evaluation of data constructors and +destructors.  Expert Haskell programmers move between these three levels +with ease, often making detailed operational arguments about program +representations when discussing the third level.  One of the attributes +that makes Haskell so successful is the extraordinary semantic coherence +between these three levels.  This paper introduces a compositional +meta-circular interpreter for Haskell that articulates the ``third level" of +semantics, in which the fine control of evaluation in data construction and +analysis is made precise.++\end{abstract}+\end{frontmatter}++\section{Introduction}\label{intro}++Haskell is a large, lazy, industrial-strength language, that is usable and+efficient across a wide variety of domains. We commonly refer to Haskell as+a {\em lazy} language, but technically it is really {\em non-strict}+because it contains constructs that make small changes to standard lazy+evaluation. These features make Haskell both more efficient+and harder to understand.++In this paper we present a meta-circular\cite{Steele-Sussman78b,Abelson-Sussman-Sussman96,Kamin,Friedman}+interpreter (of Haskell, written in Haskell) which provides a unified model of+these constructs and their interactions with Haskell's other features. Our+interpreter is a compositional monadic interpreter written in the style of+Liang, Hudak, and Jones \cite{LiangHudak}.++In particular, we model nested patterns, several different forms of lazy+pattern matching, guards and {\tt where} clauses on equations, strict+constructor functions, the {\tt newtype} datatype definition facility, and+the {\tt seq} operator. All these features make subtle changes to the+default lazy evaluation strategy of Haskell, and all for compelling reasons.+But, these slight changes are not always easy for programmers to+understand. A simple concise model of these features, understandable by+ordinary Haskell users is of significant benefit to the Haskell community.++\subsection{Rationale}++As part of the {\em Programatica}\cite{programatica} project at the Oregon Graduate+Institute, we are attempting to develop both a theory of Haskell programs, and some+automated tools for manipulating this theory. An important part of our work is to develop a+logic with which to manipulate Haskell terms. In order to develop sound rules of inference+for the logic, we need to know the meaning of the terms. This led us to the literature,+which to our surprise, was lacking in formal descriptions of the {\em big picture} of+Haskell. There are plenty of papers about particular features of Haskell, (its+laziness\cite{PeytonJone92a}, its class system\cite{JonesMark93,Hall:1994:TCH}, etc.) but+very little work which unifies the {\em essence of Haskell} with all the fine-control+mechanisms that have been added and refined over the years. Just how does Haskell differ+from the lazy lambda calculus\cite{Stoy,Gunter}?++This work started as an exercise to satisfy our own curiosity. Could we write a+Haskell interpreter that successfully modeled {\em all} of the control structures of+Haskell, yet remain simple and concise? Soon, the exercise became more than just a+simple toy. It became a model by which we judged much of our other work. We did not+anticipate that the model could be as simple and elegant as it turned out to+be. We quickly gained a deep appreciation for the continuity and semantic coherence of+all of the control features of Haskell. In addition to being simple, concise, and+elegant the model is useful! We wish to share it with the Haskell community at large.++Two important questions one might ask are {\em Why use Haskell to describe+Haskell?} and {\em What features should be described?}  We use Haskell because+many of those most interested in a semantics for Haskell features already have a+good, although not precise, appreciation for the meaning of Haskell programs.+Thus, those interested in Haskell, can use our interpreter as a concise+description or standard to which other descriptions (or implementations) can be+compared. It also provides a common language in which extensions and additions+to Haskell can be described precisely and concisely.++What criteria should be used to select the features of Haskell to be represented in our+interpreter? Our goal was (and still is) to describe all of Haskell, yet the features of+Haskell that deal with modules, type classes, comprehensions, and the {\tt do} notation,+depend upon programs being annotated with type information. The work reported in this paper+deals with a core fragment that does not require type annotations for unambiguous+interpretation. This fragment includes all the control structures in Haskell. We see this+work as a key step towards a denotational semantics for all of Haskell.++What strategy we should use in writing our interpreter? The Haskell'98+report\cite{Haskell98} uses a strategy of translating many complex constructs into a+simpler core language\cite{newcore}, that is really just a slightly extended+lambda-calculus. We feel that the translation based approach, while useful, is semantically+problematic. Many of the translation schemas in the Haskell Report rely on two devices.+First, the introduction of new variables; and second, the restructuring of code to avoid+duplication (usually to maintain sharing and to avoid code blowup). The semantics of+languages with binding mechanisms are very complex. When one defines a language feature by+a translation that introduces new variables, one leaves the well understood world of+domains and continuous functions, and moves into a much more complicated world. Recent work+on languages with binding mechanisms suggests that these kinds of transformations are by no+means trivial to model correctly\cite{Moggi,Pitts00}. For this reason we eschew such+techniques when there are relatively simple alternatives. A significantly larger core, but+with many fewer and simpler translations is more apt for describing the control features of+Haskell. These features were introduced to give the programmer explicit control over+evaluation in a {\em high-level} manner. It is incongruous to give these features meaning+in terms of a translation into the very same convoluted programs the features were meant to+replace.++One of the reasons for our research is to provide a concise model of Haskell. We+wish to point at a particular line of code in our model, and proclaim, if you+change {\em that line}, then {\em this change} will become evident in the model.+We particularly wanted to be able to do this with the control features of+Haskell. Our interpreter is meant to provide a mechanism to make such fine+distinctions.++Our goals for this research are three-fold. First to collect together in one place a formal+description of a larger subset of Haskell than has been previously described. Second, to+provide a concise description that can be used to communicate about Haskell+implementations. Last, we view this work as the first step in a program to define a formal+logic of Haskell programs, ultimately to be embedded into a large automated+toolset\cite{programatica}.+++\section{A Model for Haskell}++This section presents a call-by-name model of Haskell as a+compositional meta-circular monadic interpreter; a call-by-need+strategy is discussed in Section~\ref{callbyneed}.  Call-by-name+is appropriate for a theory of program correctness, but may be+inappropriate for a theory of program optimization. A call-by-need+approach tries to model sharing, and thus resources consumed.  Based+on the work of Sabry and Liang we expect that the primary difference+between the call-by-name and call-by-need interpreters will be in the+underlying monad of computation selected\cite{JFP::Sabry1998}.++When Moggi\cite{MoggiE90a} introduced monads as a technique to structure semantics, he+introduced the distinction between a value of a type and a computation of a given type.+Using this basic distinction, Danvy\cite{Danvy} identified two basic forms of monadic+interpreters for functional languages:  the Kleisli interpreter that models functions as+mappings from values to computations, and the Reynolds\cite{Reynolds} interpreter that+models functions as transformations on computations.  The difference between the two is+that the Reynolds interpreter makes the evaluation strategy (call-by-value vs.+call-by-name) of the language being modeled explicit without depending upon the evaluation+strategy of the meta-language. A Reynolds interpreter can be used to express either+call-by-name or call-by-value (or something in between like Haskell), irregardless of the+evaluation strategy of the meta-language. Only a lazy meta-language can implement a+call-by-name strategy using a Kleisli interpreter.++The meta-circular interpreter developed here reflects the structure of+the Reynolds interpreter in several ways.  First, the notion of value+of the interpreter corresponds to terms in weak-head-normal form, with+computations ({\tt M Value}), rather than base values (simply {\tt+Value}), embedded recursively.++{\small+\begin{verbatim}+data Value                   -- Models values in Haskell+   = Z Integer                -- Scalars+   | FV (M Value -> M Value)  -- CBN functions+   | Tagged Name [M Value]    -- Algebraic structured data+   | TupleVal [M Value]       -- Tuples+\end{verbatim}+}++Secondly, the environment maps names to computations, not to values.+That is, it is possible to put a computation in the environment that+may not even have a weak-head-normal form value.  This is expressed:++{\small+\begin{verbatim}+type Env = Name -> M Value        -- Maps Names to computations+type EnvFrag = [(Name,M Value)]   -- Intensional environment fragment+data Error a = Ok a | Err String  -- A run-time error++newtype M a = M (Env -> (Error a)) -- M is an environment monad+                                    -- with errors. See Figure 1.+\end{verbatim}+}++Finally, the types of the meaning functions defining the interpreter yield+computations (as opposed to values) as their ranges. These functions have the+following structure. For each syntactic category of the language, {\tt T},+there is a function, {\tt mT :: T -> t1}. We say that {\tt mT} computes the+{\em meaning of} {\tt T}, and associates the type {\tt t1} with this meaning.+The type {\tt t1} often has the form ({\tt M t2}) or ({\tt M t3 -> M t4}),+where {\tt M} is the computation monad.++To be concrete, consider meaning functions for the datatypes defined in+Figure \ref{AST}. We have divided our Haskell subset into many syntactic+categories, three of which are called {\tt Exp}, {\tt Dec}, {\tt Pat} (for+expressions, declarations, and patterns).  Each has a corresponding meaning+function:++{\small+\begin{verbatim}+mExp :: Exp -> M Value+mDecs :: [Dec] -> M a -> M a+mPat :: Pat -> M Value -> M (Maybe EnvFrag)+\end{verbatim}+}++We have found the following analogy to be a useful intuition for thinking about such+meaning functions. Functions such as {\tt mExp :: Exp -> M Value}, can be thought of as+computation producers. The function {\tt mExp} produces a computation from an {\tt Exp}.+This computation computes a result of type {\tt Value}.++Functions such as {\tt mDecs :: [Dec] -> M a -> M a} can be thought of as producing+computation transformers. The term {\tt (mDecs ds):: M a -> M a} is a computation+transformer. Taking one computation as input, and producing a different but related+computation that adds the bindings indicated by {\tt ds} to the original computation.+It adds the necessary computational steps to extend the environment with the meaning of+the values bound in {\em ds}. The function {\tt mDecs} is used to give meaning to the+Haskell expression {\tt (let {\em ds} in {\em e})} by transforming the translation of+{\em e} as follows: {\tt (mDecs {\em ds} (mExp {\em e}))}.+++A compositional interpreter must have the following additional property: the+meaning of any term in a syntactic category {\tt T} must depend, in a purely+functional manner, only on the meaning of its subterms. Monadic interpreters+have the ability to cleanly separate different concerns\cite{Wadler92}, and+are remarkably concise and reusable.  Haskell has introduced explicit support+for monadic abstractions in the  {\tt do} notation. The {\tt do} notation+combines monadic expressions (computations) into larger monadic expressions+(bigger computations). The {\tt do} notation both composes computations, and+makes clear the order in which the computations are to be run.++\begin{figure}+{\small+\begin{center}+{\bf Definition of monad {\tt M}.}+\end{center}+\begin{verbatim}+instance Monad Error where+   return = Ok+   (>>=) x f = case x of+                (Ok v) -> f v+                (Err msg) -> (Err msg)++instance Monad M where+   return a = M (\rho -> return a)+   (>>=) x f = M g+     where g rho = do { v <- (deM x) rho ; deM (f v) rho }+           deM (M x) = x++-- Non-standard Morphisms+lift :: Error a -> M a+lift ec = M (\ _ ->  ec)++raise :: String -> M a+raise = \msg -> lift (Err msg)++rdEnv :: M Env+rdEnv = M (\rho -> return rho)++inEnv :: Env -> M a -> M a+inEnv rho (M x) = M (\ _ -> x rho)++instance Functor M where+    fmap f x = do { x' <- x; return(f x') }+\end{verbatim}+\caption{A computation has type{\tt (M Value)}.+{\tt M} is an environment monad with errors.}\label{Monad}+}+\hrule+\end{figure}++++\subsection{Which Monad?}++The definition of our monad in Haskell can be found in Figure \ref{Monad}. We call+our computational monad {\tt M}. It is an environment monad with errors. We define+it in the monad transformer style\cite{LiangHudak,LiangThesis,Espinosa95PHD}.+First defining a pure {\tt Error} monad, and then laying the environment features+on top.++The monad abstracts away the additional structure necessary to build compositional+interpreters. In Haskell, this additional structure must deal correctly with two+features: suspended computation, and the possibility of failure.++In Haskell, there are several distinct kinds of failures. Only one of which is+modeled in the monad {\tt M}. ++\begin{enumerate}++\item The first kind of failure, which is modeled within the monad, arises from+      run-time errors, such as division by zero, and non-exhaustive pattern match+      coverage. Taking the {\tt head} of the empty list is an example of this kind+      of failure.++\item The second kind of failure, stems from non-terminating computations. This+      kind of failure is captured by the model itself not terminating when+      given a non-terminating Haskell program as input.++\item The third kind of failure, stems from pattern-matching failure in a context+      where the failure can be caught, and control then proceeds to the next+      {\tt Match} of a case, or the next {\tt Clause} of a multi-line function+      definition. We model this outside the monad, as a computation of type+      {\tt M(Maybe a)}. We call such computations {\em partial} computations.+      A partial computation can become a failure of the first kind, if it occurs+      in a context with no {\em next} {\tt Match} or {\tt Clause}.+\end{enumerate}++In our semantics, a failure of the first kind is reported by using the non-standard+morphism {\tt raise}. The monad propagates failures once they are raised.++Suspensions are built using an environment. The environment component of {\tt M} is a+function ({\tt Name -> M Value}), which binds the free variables found in terms to+computations. This environment is used to build suspended computations. Intuitively, a+suspended computation is like a thunk or closure. It contains two components: a set of+instructions to execute, and a set of bindings for the free variables that appear in the+instructions. Suspensions are built at the monadic level using a classic pattern. The+nonstandard morphism {\tt rdEnv} is used to capture the current static mapping, and the+morphism {\tt inEnv} takes a captured mapping and a computation, and is used to create a+new computation that will run under the captured mapping.++The structure of {\tt Values} and the monad {\tt M} are conventional. We assume the+reader has some familiarity with monads\cite{Wadler92,Wad92:monads,Wadler:1995:MFP}+and interpreters\cite{LiangHudak,Espinosa95PHD,DSL99*81}+++\subsection{Monadic Control Structures}++A nice property of monadic computation in Haskell is that it is easy to capture+patterns of control and abstract them into functions at the monadic level. A+familiar pattern that occurs many times in our semantics is a monadic conditional.+While interpreting a syntactic category, some computation, called the {\em+discriminant}, is evaluated lazily, just enough to make a choice between one of two+alternate paths. This pattern occurs about a dozen times in our semantics. These+fall into one of three categories, depending upon the {\em type} of the+discriminant.++When the discriminant has type ({\tt M Value}), and that value is representing+a {\tt Bool} type, as it would in an if-then-else or guarded-body expression,+we have a simple lifting of the {\tt if-then-else} expression of Haskell. We+capture this pattern with the function {\tt ifV}.+{\small+\begin{verbatim}+ifV :: M Value -> M b -> M b -> M b+ifV test thenM elseM =+  do { v <- test+     ; case v of+         Tagged "True" [] -> thenM +         Tagged "False" [] -> elseM +         other -> raise "Not a Bool in ifV" }+\end{verbatim}+}+++A second kind of choice is captured by the function {\tt caseM}. It is used when+describing pattern matching. Pattern matching is inherently partial. For example in+a {\tt case} expression, when a pattern does not match, control passes to the next+arm of the case. When matching succeeds, additional information is captured: the+bindings for the variables bound by the pattern. This type of behavior is captured+by a discriminant with type {\tt M(Maybe a)}. The two arms of the conditional+correspond to the computation producing {\tt Nothing} or {\tt (Just x)}. The arm+for the {\tt (Just x)} case should be a function that produces a computation when+applied to {\tt x}. {\small++\begin{verbatim} +caseM :: M (Maybe b) -> M c -> (b -> M c) -> M c +caseM test noMatch matchF = +  do { vbl <- test ; +       case vbl of +         Nothing -> noMatch+         Just x -> matchF x }+\end{verbatim} }++The last form of conditional is called {\tt hasTag} and is used to do dynamic+matching of tags in algebraic structured data. This kind of conditional compares a+statically known tag against the tag of a dynamically produced {\tt Tagged} value.+If the tag matches, take one path, if it does not match, take the other path. In+either case, additional information becomes available that is useful on the chosen+path. If the match is successful, the list of pairs binding variables+(representing the variables bound by the pattern) to suspended computations+(representing the data stored in the algebraic type), becomes known. If the tags+are not the same, then the non-matching tag name (useful for reporting failure)+becomes known. Thus the arms of {\tt hasTag} are both represented by functions.++{\small+\begin{verbatim}     +hasTag :: String -> M Value -> +          ([M Value] -> M b) -> (String -> M b) -> M b     +hasTag tag arg mPatf nomPatf =+  do { v <- arg+     ; case v of+         (Tagged t mvals) -> if t==tag then mPatf mvals else nomPatf t+         other -> raise "Not a Tagged Value in hasTag" }+\end{verbatim}+}+++ +\begin{figure}[t]+\begin{center} {\small {\bf Haskell Subset Abstract Syntax}}+\end{center}+{\small +\begin{verbatim}+type Name = String+data Op = Plus | Mult | IntEq | IntLess+data LS = Lazy | Strict deriving Eq++data Pat +  = Pconst Integer            -- { 5 }+  | Pvar Name                 -- { x }+  | Ptuple [Pat]              -- { (p1,p2) }+  | Pcondata Name [Pat]       -- data T1 = C1 t1 t2; {C1 p1 p1} = e +  | Pnewdata Name Pat         -- newtype T2 = C2 t1;  {C2 p1} = e+  | Ptilde Pat                -- { ~p }+  +data Exp +  = Var Name                  -- { x }+  | Const Integer             -- { 5 }+  | App Exp Exp               -- { f x }+  | Abs [Pat] Exp             -- { \ p1 p2 -> e }+  | TupleExp [Exp]            -- { (e1,e2) }+  | ConApp Name [(Exp,LS)]    -- data T1 = C1 t1 t2; p = {C1 e1 e2}+  | NewApp Name Exp           -- newtype T2 = C2 t1; p = {C2 e1}+  | Seq Exp Exp               -- { seq e1 e2 }               +  | Bin Op Exp Exp            -- { e1 + e2 }+  | Cond Exp Exp Exp          -- { if e1 then e2 else e3 }+  | Let [Dec] Exp             -- { let x=e1;   y=e2 in e3 }+  | Case Exp [Match]          -- { case e of m1; m2 }+  +type Match = (Pat,Body,[Dec]) -- case e of { pat -> body where decs } +data Dec +  = Fun Name [Clause]         -- { f p1 p2 = b where decs }+  | Val Pat Body [Dec]        -- { p = b where decs }++type Clause = ([Pat],Body,[Dec]) -- f { p1 p2 = body where decs }+data Body+  = Guarded [(Exp,Exp)]       -- f p { | e1 = e2 | e3 = e4 } where ds+  | Normal Exp                -- f p = { e } where ds+\end{verbatim}+}+\caption{{\footnotesize The comments following each constructor function are meant to+illustrate the concrete syntax represented by that constructor. Each comment+has the form {\em context\{ example \}} where {\em context} is possibly empty.+The {\em context} is supposed to place the {\em example} (which could be+a possibly ambiguous program text fragment) into perspective. In the examples, we use semicolon+(;) where the offsides rule would normally be used.}}\label{AST}+\hrule+\end{figure}++\section{The Abstract Syntax}++Haskell is a rich language with many features. Our subset identifies 9 different+syntactic categories. These categories include names, operators, strictness+annotations, matches, clauses,  bodies, expressions, declarations, and patterns.++In Figure \ref{AST} we display the {\tt data} definitions in Haskell that represent+our abstract syntax. Our definitions are conventional and we have used+comments to relate the abstract syntax to the concrete syntax of Haskell. The+missing syntax, necessary to complete a Haskell definition, has mostly to do with+the module system, classes, list comprehensions, and the do notation.+++\section{The Meaning of Expressions}++The heart of a functional language like Haskell is the expression language. The meaning+of a Haskell program is given in terms of the meaning of the expressions it contains.+In our semantics, the meaning of a Haskell program is a computation producing a {\tt+Value}.++The rest of this section is a detailed explanation of the function {\tt mExp}. It is+divided into subsections. Each subsection describes a few related clauses making up+the definition of {\tt mExp} along with the auxiliary functions necessary for those+clauses. These auxiliary functions supply meaning for the other syntactic categories+of Haskell.++For pedagogical reasons, the text of the paper breaks the definition into a few clauses+at a time. An actual implementation would need to collect them all together in a+single place.++\subsection{Simple Expressions}+++{\small+\begin{verbatim}+mExp :: Exp -> M Value+mExp (Var n) = do { rho <- rdEnv ; rho n }+mExp (Const i) = return (Z i)+mExp (TupleExp es) = +   do { rho <- rdEnv +      ; return (TupleVal (map (inEnv rho . mExp) es)) }+mExp (Cond l1 l2 l3) = ifV (mExp l1) (mExp l2) (mExp l3)+\end{verbatim}+}++The meaning of a variable is obtained by extracting the current environment ({\tt rho})+and then applying it to the variables name. It is useful to think of the {\tt do}+notation as building a computation. Lookup the computation stored in the+environment {\tt rho}, and return it.++Constants are simply turned into values and returned. No complicated translation+necessary.++In the case for tuples, the laziness of Haskell first becomes apparent. Each of the+subexpressions (the {\tt es}), must be suspended, and the resulting list of+computations is then wrapped by the {\tt TupleVal} constructor. To suspend a+computation one must first grab the current environment ({\tt rho}), translate the+expression, then apply the computation transformer {\tt (inEnv rho)} to enable the+computation to find the correct environment when it is later run. This is repeated+for each sub-expression in the tuple. We will see this pattern many times. One+cannot tell when, or where, a computation must be run, so it is suspended before+being embedded inside a {\tt Value}.+ +Conditional expressions, are easily translated using the control operator {\tt ifV}.++\subsection{Application and Abstraction}++Function application and abstraction are the key to any functional+language. Care must +be taken to implement Haskell's laziness correctly.++{\small\label{CBNapplication}+\begin{verbatim}+mExp :: Exp -> M Value+mExp (App f x) =+   do { rho <- rdEnv+      ; (FV f1) <- mExp f+      ; f1 (inEnv rho (mExp x)) }+mExp (Abs ps l) = arrow ps (mExp l)+\end{verbatim}+}++To compute the meaning of an application, grab the current environment, evaluate+the function part ({\tt f}), to obtain a function value ({\tt FV f1}). Then apply+{\tt f1} to the suspended argument. The argument is suspended by first translating+{\tt x}, then transforming this computation to run in the current environment using+{\tt inEnv}. This is the {\em spot} where we specify a {\em Reynolds Style}+interpreter\cite{Reynolds}.++As we saw in the {\tt App} case the meaning of a function is a {\tt Value} of the form+{\tt FV f}, where {\tt f} is a function with type {\tt (M Value -> M Value)}. The meaning+of an abstraction must compute such a value. This is accomplished by translating the+body of the abstraction ({\tt l}), then applying the computation transformer {\tt+arrow}.++{\small+\begin{verbatim}+arrow :: [Pat] -> M Value -> M Value+arrow [] b = b+arrow (p:ps) b =+   do { rho <- rdEnv+      ; let f v = +             caseM (mPat p v) +                   (raise "mPat Error in Fun")+                   (\ vl -> inEnv (addBindings rho vl) (arrow ps b))+      ; return(FV f)+      }+\end{verbatim}+}++The key to understanding {\tt (arrow [p1, ... pn] body)} is that it builds a+nested sequence of {\tt FV} objects {\tt FV(\ v1 -> ... (FV \ vn -> body))}+where {\tt n} is the length of the list of patterns. The body of each of the+{\tt FV}s is a suspended computation, which incrementally adds the bindings to+the variables found in each {\tt pi}. The hard work is performed by the+transformer {\tt mPat}. The meaning of binding constructs, like patterns, in our+semantics is always associated with the production of an {\tt EnvFrag}. An {\tt+EnvFrag} is a list pairing {\tt Name}s to computations. An {\tt EnvFrag} can be+used to extend an {\tt Env} using the function {\tt addBindings :: Env ->+EnvFrag -> Env}.++\subsection{Patterns}\label{pattern}++Pattern matching nested patterns is a challenging problem when describing the+semantics of Haskell. We consider our treatment of nested patterns one of the+major contributions of this paper. Patterns can occur in several different+syntactic contexts. In lambda expressions ({\tt \ p1 p2 -> e}), in let+expressions ({\tt let p = e1 in e2}), in matches ({\tt case e1 of p -> e2}), and+in clauses in multi-line function definitions ({\tt f p1 p2 = e}). Patterns also+appear as sub-patterns inside other patterns.++Patterns are used in two distinctly separate semantic ways in Haskell. The way a+pattern is used is decided by the syntactic context in which it appears. We call+the two semantic meanings of patterns, {\em optimistic lazy} patterns, and {\em+discriminant strict} patterns. Optimistic lazy patterns occur in {\tt let}+expressions and where patterns are annotated as lazy (\verb+~p+). Discriminant+strict patterns occur in all other contexts. ++The two different meanings of patterns produce different kinds of transformers.+Both meanings of a pattern can be thought of as computation transformers. They+are used to transform the computation of the expression appearing in the+scope where the variables of the pattern are bound.++The function {\tt mPat} defines the meaning of discriminant strict patterns. The+function {\tt mPatLazy} defines the meaning of optimistic lazy patterns. Both+meanings for patterns are {\em lazy} in some sense. Discriminant strict patterns+are lazy in that they force only enough evaluation to determine if the+pattern matches. Optimistic lazy patterns are lazy in that they never force+any evaluation at all. They are optimistic in the sense that it is assumed that+the pattern will match, and computation proceeds on the assumption that it will.+If later events invalidate this assumption, then a failure of the first type+will be raised.++The types of the functions {\tt mPat :: Pat -> M Value -> M(Maybe EnvFrag)} and+{\tt mPatLazy :: Pat -> M Value -> EnvFrag} encode this information. ++The function {\tt mPat} gives meaning to discriminant strict patterns. The+partiality of discriminant strict patterns shows up as the {\tt Maybe} type.+Because discriminant strict patterns may force computation in the discriminant+the resulting {\tt M(Maybe EnvFrag)} is a monadic computation. The partiality of+{\tt mPat} is used as a signal to advance to the next {\em match} of a {\tt+case}, or the next {\em clause} of a multi-line function definition.++The function {\tt mPatLazy} gives meaning to optimistic lazy patterns. It+optimistically returns an {\tt EnvFrag} without forcing any evaluation. It only+forces evaluation of the discriminant when one of the variables bound in the+pattern is demanded. If the value can't be matched to the optimistic pattern a+failure of the first type is raised. Failure is delayed. Advancing to the next arm+in a multi-arm {\tt case} guarded by a lazy pattern is not possible, since an+arm guarded by an optimistic lazy pattern is irrevocably chosen. This is illustrated in the table+below. The first 3 lines of the table correspond to {\tt mPat} matching, and the+last two lines correspond to {\tt mPatLazy} matching.++\[+{\small+\begin{tabular}{|l|c|l|} \hline+{\em example} & {\em value} & {\em comment} \\ \hline+\verb+(\ x -> 3) bottom+  & 3 & succeeds  \\ \hline+\verb+(\ (x:xs) -> 3) bottom+  & bottom & diverges  \\ \hline+\verb+(\ (x:xs) -> 3) []+ & Failure & match failure \\ \hline+\verb+let x:xs = [] in 3+  & 3 &  succeeds \\ \hline+\verb+case [] of { ~(x:xs) -> x; [] -> 3 }+ &  Failure & delayed error \\ \hline+\end{tabular}+}+\]++The transformer, {\tt (mPat p)}, has type {\tt (M Value -> M (Maybe EnvFrag))}, and+transforms its translated argument into another computation which (at run-time of the+computation) computes a {\tt Maybe} type. The {\tt Maybe} type can be observed dynamically+and different courses of action can be taken. The result of a successful match is {\tt+(Just (x::EnvFrag))}. Recall that\\ \verb+type EnvFrag = [(Name,M Value)]+.\\ One can+think of an {\tt EnvFrag} as a dispatch table, pairing each variable with a computation+which needs to be executed to get that variable's value. These computations may be+non-trivial, as only a small amount of the computation necessary to produce the value that+the pattern was matched against may have been forced.++We now give the definition of {\tt mPat}. As for {\tt mExp} we will discuss+it a few clauses at a time.++{\small+\begin{verbatim}+mPat :: Pat -> M Value -> M (Maybe EnvFrag)+mPat (Pvar x) arg = return (Just [(x,arg)])+mPat (Pconst i) arg = +    do { (Z v) <- arg+       ; if v==i +            then return(Just [])+            else return Nothing+       }+\end{verbatim}+}++Matching a variable never forces any computation, and always succeeds, so a simple list+with a single pair is immediately returned. To match a pattern constant, the argument+must be forced so that its value can be compared against the constant in the pattern.++Tuples and structured data have much in common so we discuss both these cases+together. The key is to force only enough evaluation to match against+the pattern, and no more.+++{\small+\begin{verbatim}  +mPat :: Pat -> M Value -> M (Maybe EnvFrag)+mPat (Ptuple ps) arg = +    do { (TupleVal mvals) <- arg+       ; mfrags <- sequence(zipWith mPat ps mvals)+       ; return(allJust mfrags)+       }+mPat (Pcondata tag ps) arg = +    hasTag tag arg+        (\ mvals -> do { mfrags <- sequence (zipWith mPat ps mvals)+                       ; return(allJust mfrags)+                       })+        (\ t -> return Nothing)++\end{verbatim}+}++For {\tt Ptuple}, {\tt arg} must be forced to get at the underlying tuple. Then each+sub-pattern is recursively matched against the sub-components of the tuple. Note that+if all the sub-patterns of the tuple are variables, no more computation will be+forced. If some are not variables, just those components of the argument tuple will be+forced. By zipping {\tt mPat} over the sub-patterns, and the suspended computations+that make up the body of the tuple, we compute a list of recursive results.+Each of the recursive results could either be {\tt (Just frag)} or {\tt Nothing}. If+they are {\em all} of the form {\tt (Just frag)} the subfragments are combined+into one large fragment.++{\small+\begin{verbatim}  +allJust :: [Maybe [a]] -> Maybe [a]  +allJust [] = Just[]+allJust (Just x : xs) = fmap (x ++) (allJust xs)+allJust (Nothing : xs) = Nothing  +\end{verbatim}+}++Structured data is similar. The {\tt hasTag} conditional operator forces+evaluation of the argument. If the tag matches, the first arm proceeds as for+tuples; If the tag does not match, the other arm immediately returns a partial+result.+++{\small+\begin{verbatim}+mPat :: Pat -> M Value -> M (Maybe EnvFrag)+mPat (Pnewdata n p) arg = mPat p arg+mPat (Ptilde p) arg = return (Just (mPatLazy p arg))+\end{verbatim}+}++The constructor function introduced by a {\tt newtype} declaration acts like the+identity function. Thus to match a {\tt Pnewdata} pattern against an argument,+just match its sub-pattern against the argument. A similar rule is found in the+evaluation of {\tt newtype} constructor functions in the function {\tt mExp}.++A pattern annotated as lazy ({\verb+~p+), is treated as an optimistic lazy+pattern, regardless of its context. The function {\tt mPatLazy} always immediately+succeeds without forcing any computation at all. Since {\tt mPat} returns a {\tt+Maybe} result, and the call to {\tt mPatLazy} always returns just an {\tt+EnvFrag}, we must wrap the {\tt Just} constructor around the result of {\tt+mPatLazy}.++The meaning of an optimistic lazy pattern is a computation transformer. Since+matching an optimistic lazy pattern is never partial, the transformer transforms+the argument directly into an {\tt EnvFrag} (rather than a {\tt Maybe EnvFrag}),+binding variables to computations. Each such computation demands the argument when+one of the variables in the pattern is demanded. If the pattern does not match the+argument, these computations must incorporate a delayed match error. The key to+understanding {\tt mPatLazy} is to understand how the argument computation is+lazily incorporated into each computation in the {\tt EnvFrag}.+++{\small+\begin{verbatim}+mPatLazy :: Pat -> M Value -> EnvFrag+mPatLazy (Pconst k) mv = []         +mPatLazy (Pvar x) mv = [(x,mv)]+mPatLazy (Ptilde p) mv = mPatLazy p mv+mPatLazy (Pcondata n ps) mv = concat(zipWith argN [1..] ps)+    where argN i p = mPatLazy p (subValue i)+          subValue i = do { vs <- hasTag n mv return error; vs !! (i-1)}+          error tag  = raise ("Tag " ++ n ++ " != " ++ tag)+mPatLazy (Pnewdata n p) mv = mPatLazy p mv                    +mPatLazy (Ptuple ps) mvals = concat(zipWith select [1..] ps)+    where select i p = mPatLazy p (proj i mvals)+          proj :: Int -> M Value -> M Value+          proj n phi = do { (TupleVal mvals) <- phi ; mvals !! (n-1)  } +\end{verbatim}+}++For structured data, each sub-pattern may bind some variables, each of these patterns+pulls on the original argument when one of their variables is demanded. This happens+when calling {\tt subValue i} which in turn pulls on {\tt mv} through the call +\verb+(hasTag n mv return error)+. A similar action takes place through the use of+the function {\tt proj} in the tuple case.++Optimistic lazy patterns with constant sub-patterns are worth thinking about+for a moment. An optimistic pattern always matches immediately, delayed+failure is raised only if pulling on the variables in the pattern discovers+that the value being matched does not have the structure of the pattern. An+optimistic lazy constant pattern always matches, and since it has no+variables, it never causes delayed failure. A constant pattern in an+optimistic lazy context acts as a wildcard pattern!++We now return to further discussion of the meaning of expressions.++\subsection{Constructor Application}++Constructor applications are evaluated in a manner much like tuples. The key+difference is the possibility that constructors can have some of their arguments+annotated as strict arguments. For example in Haskell, we might write\\ {\tt data+T = C String !Int}, to denote that the second argument to {\tt C} should be forced+into head normal form before the {\tt C} object is allocated in the heap. We+denote this in our abstract syntax by pairing each sub-argument with a strictness+annotation ({\tt LS}).++{\small+\begin{verbatim}+mExp :: Exp -> M Value+mExp (ConApp n es) = +   do { rho <- rdEnv+      ; let f (e,Lazy) es   = +              do { cs <- es; return ((inEnv rho (mExp e)):cs) }+            f (e,Strict) es = +              do { c <- mExp e; cs <- es; return((return c):cs)}+      ; cs <- foldr f (return []) es+      ; return(Tagged n cs)+      }  +\end{verbatim}+}++Lazy arguments are suspended (using {\tt rdEnv} and {\tt inEnv}) in the current+environment, strict ones are evaluated immediately.  Inspecting the interpreter+shows that strict constructors store computations which are already in head-normal+form.++\subsection{Case Expressions}++In {\tt case} expressions we use the pattern matching transformers defined in+Section \ref{pattern}. A {\tt case} contains a {\em discriminant} ({\tt e}), and a+list of {\em matches} ({\tt ms}). A {\tt Match} consists of a pattern, a body, and+an optional list of local declarations\footnote{We discuss {\tt where} clause+declarations in Section \ref{decs}.}. The pattern of each {\tt Match} is matched+against {\tt e} in turn, returning the meaning of the body of the first successful+match. Since a match may be partial, our semantics must handle this properly. The meaning+of a match of the form ({\tt pat -> body}), is a transformer taking the meaning of+the discriminant to a computation returning a {\tt (Maybe Value)}. This has the+form {\tt (Just (mExp body))} if the pattern matches, and {\tt Nothing} if it does+not. For example, the case expression, {\tt (case x of m1; m2)} is given meaning+by the expression:++{\small+\[ \verb+(mMatch m1) (mExp x)+ \;[\!]\; \verb+(mMatch m3) (mExp x)+ \;[\!]\; \verb+raise "Match Failure"+ \] +}++Here the right associative infix {\em fatbar} operator ($\;[\!]\;$), returns the first+(left most) operand that returns a {\tt Just} value. We make this precise by:++{\small+\begin{verbatim}+mExp :: Exp -> M Value+mExp (Case e ms) =  +   foldr (fatbar (mExp e)) (raise "Match Failure") (map mMatch ms)+  where fatbar arg mm next = caseM (mm arg) next return+\end{verbatim}+}++The meaning of a {\tt Match} is computed by {\tt mMatch ::  Match -> M Value ->+M(Maybe Value)}.  Like {\tt mPat}, {\tt mMatch} may force computation, and it may+also be partial.  Unlike a {\tt Pat},  {\tt mMatch} transforms a computation into+a {\tt (Maybe Value)} rather than a {\tt (Maybe EnvFrag)}.+The partiality of a {\tt Match} can stem from two causes.+Consider: +\begin{verbatim} +f (x:xs) | even x = 1 +\end{verbatim} +The term {\tt (f [])} is partial because of pattern match failure; the term {\tt+(f [1])} is partial because of guard failure. +{\small+\begin{verbatim}+mMatch :: Match -> M Value -> M(Maybe Value)+mMatch (p,body,ds) arg = +   caseM (mPat p arg) +     (return Nothing)+     (\frag ->  do { rho <- rdEnv+                   ; inEnv (addBindings rho frag) +                             (mDecs ds (mBody body))+                   })                    +\end{verbatim}+}++The function {\tt mMatch} is basically an extension of {\tt mPat}, executing the+corresponding {\em body} in an environment extended with two additional sets of+bindings. The first set is the bindings found in the {\tt EnvFrag} computed by a+successful match, and the second is the bindings found in the {\tt where} clause {\tt+ds}. We discuss {\tt mDecs} in Section \ref{decs}.++A {\tt Body} is either a single expression or a list of guarded expressions.++{\small+\begin{verbatim}      +  where mBody :: Body -> M(Maybe Value)+        mBody (Normal e) = do { x <- mExp e; return(Just x)}+        mBody (Guarded guards) = mExpGuardList guards+        mExpGuardList :: [(Exp,Exp)] -> M (Maybe Value)+        mExpGuardList [] = return Nothing+        mExpGuardList ((g,b):gs) =+            ifV (mExp g)+                (do { x <- mExp b; return(Just x) })+                (mExpGuardList gs)+\end{verbatim}+}++The partiality of {\tt mBody} is made necessary by guarded expressions; it is+possible for all the guards to be partial. If this happens, the whole {\tt Match}+is partial as well, and control should pass to the next {\tt Match} in the+enclosing {\tt case} expression.+++\subsection{Declarations and Let Expressions}\label{decs}++Sets of mutually recursive definitions appear in {\tt let} expressions, {\tt+where} clauses, and at the top-level of Haskell programs. The difference+between these is a subtle distinction of scope. The semantics of a set of+mutually recursive definitions is always a transformer. The distinction in+scope is made by the way the transformer is applied.++The meaning of a set of mutually recursive definitions is given by {\tt mDecs :: [Dec]+-> M Value -> M Value}. It is a transformer that transforms the computation in the scope+of the definitions into another that knows how to access those definitions. The difficulty+in defining a meaning function for a set of {\em mutually recursive} definitions, is the+{\em recursion}. The {\em use} of such a transformer is quite straightforward. For example,+the meaning of a {\tt let} expression can be given simply by:++{\small+\begin{verbatim}+mExp :: Exp -> M Value+Exp (Let ds body) = mDecs ds (mExp body)+\end{verbatim}+}++The {\em definition} of {\tt mDecs} is more problematic. The meaning of+binding constructs in our semantics is always associated with the production+of an {\tt EnvFrag}. An {\tt EnvFrag} is a list of pairs. Each pair consists+of a {\tt Name}, and computation. For a set of {\em mutually recursive}+declarations, the computations inside the {\tt EnvFrag} must include the+bindings for the names declared in the set. But this {\tt Environment} can+only be constructed once the {\tt EnvFrag} is complete. Thus we have a+chicken and egg problem. What comes first, the {\tt Env} or the {\tt+EnvFrag}?++Fortunately this problem is easy to solve using the recursion of the meta-language+Haskell. We expect the following recursive equation to hold of our semantics:++{\small+\begin{verbatim}+newEnv = addBindings oldEnv (makeDsFrag newEnv ds)+\end{verbatim}+}++Here {\tt makeDsFrag} produces an {\tt EnvFrag} given the {\tt Env} which+already contains bindings for the names declared in {\tt ds}. However this+equation is non-compositional. We give a compositional definition of {\tt newEnv}+below that satisfies this equation.++The function {\tt mDecs} builds a transformer that extends the environment with the+variables bound by the set of declarations. We make the recursion that solves the+chicken and egg problem explicit, by using an explicit {\tt fix} operator. The function+{\tt mDecs} works by grabbing the current environment, adding the bindings produced by+{\tt makeDsFrag} to make a new {\tt Env}, and using the {\tt inEnv} transformer to build+a suspension that will evaluate the original computation in this environment.++{\small+\begin{verbatim}+mDecs :: [Dec] -> M a -> M a+mDecs ds mExp =+     do { rho <- rdEnv+        ; let newEnv = fix (\ r -> addBindings rho (makeDsFrag r ds))+          in inEnv newEnv mExp+        }+\end{verbatim}+}               ++The function {\tt makeDsFrag} is straight forward. There are two kinds of declarations,+{\tt Val} and {\tt Fun}. For each kind of declaration build a pair, pairing the names+bound with their associated computations. Recall that {\tt r} is an environment that+will contain the bindings we are now constructing.+++{\small+\begin{verbatim}+makeDsFrag :: Env -> [Dec] -> EnvFrag+makeDsFrag r ds = foldr mDec [] ds+ where mDec (Val p body ds) frag = +            mPatLazy p (inEnv r (mDecs ds (mBody body))) ++ frag+       mDec (Fun nm cls) frag = (nm,mExpCls cls) : frag+       mExpCls :: [([Pat],Body,[Dec])] -> M Value+       mExpCls [] = raise "no guard matches"+       mExpCls ((ps,body,ds):cls) = +            arrow ps (inEnv r (mDecs ds (mBody body)))  +\end{verbatim}+}++Recall that the meaning of a declaration must never perform any computation,+only build new environments. Thus the use of {\tt mPatLazy} in the {\tt Val}+clause of the function {\tt mDec}. Note also the recursive use of {\tt mDecs}+to handle {\tt where} clauses inside each declaration.+++\subsection{Newtype Constructor Application}++A {\tt newtype} constructor acts like the identity function, thus it is easy to define+the clause of {\tt mExp} for {\tt newtype} constructors:++{\small+\begin{verbatim}+mExp :: Exp -> M Value+mExp (NewApp n x) = mExp x+\end{verbatim}+}++\subsection{Miscellaneous expressions}++Finally, we come to the last few miscellaneous expression forms, the {\tt seq} operator,+and primitive binary operators. We assume that the primitive operators are strict in their+operands.++{\small+\begin{verbatim}+mExp :: Exp -> M Value+mExp (Seq x y) = do { mExp x; mExp y }+mExp (Bin op l1 l2) =+   do { (Z i1) <- mExp l1+      ; (Z i2) <- mExp l2+      ; return(mOp op i1 i2)+      }+ where mOp :: Op -> Integer -> Integer -> Value+       mOp Plus x y = Z(x + y)+       mOp Mult x y = Z(x * y)+       mOp IntEq x y = fromBool(x==y)+       mOp IntLess x y = fromBool(x < y)+       fromBool True = Tagged "True" []+       fromBool False = Tagged "False" []+\end{verbatim}+}++The {\tt Seq} operation needs some explanation. {\tt Seq} evaluates+its first operand, then evaluates and returns the value of its second+operand. The benefit of {\tt Seq} is only evident in a monad that models+the sharing of a call by need semantics. In such a model, one uses {\tt Seq}+to force computation of the first operand, so that subsequent shared demands+will perform only a small constant amount of computation. The most common+use of {\tt Seq} is to define a strict application operator.++{\small+\begin{verbatim}+strictApply f x = seq x (f x)+\end{verbatim}+}++For this to usefully, we would have to change our monad to encode sharing.++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++\section{Using the interpreter: adding call-by-need evaluation}\label{callbyneed}++With a few simple changes, the interpreter developed here can be made call-by-need+rather than call-by-name. This is a happy consequence of parameterizing our+interpreter by a monad structured with monad+transformers\cite{LiangHudak,LiangThesis}. The only changes necessary are adding a+heap structure to the monad {\tt M} and replacing the closures that are formed+through function application with self-updating thunks. In this section, we outline+these changes. Our treatment follows Liang's dissertation\cite{LiangThesis}+closely.++Previously, we defined {\tt M} as:+\begin{verbatim}+       M a = Env -> (Error a)+\end{verbatim}+The first change is to include a heap in the definition of {\tt M}:+\begin{verbatim}+       M a = Env -> (Error (Heap a))+\end{verbatim}+\noindent where:+\begin{verbatim}+       Heap a = Sto -> (Sto,a)+       Sto = (Loc,[(Loc,M Value)])+       Loc = Int+\end{verbatim}++\noindent {\tt Heap} is a state monad with heap structure {\tt Sto}. The first+component of {\tt Sto}, {\tt Loc}, represents the next free address in the heap. The+second component of {\tt Sto}, {\tt [(Loc,M Value)]}, represents the heap itself.+That is, each pair \verb+(l,thk)+ in the list, represents a thunk {\tt thk} stored at+location {\tt l}. With the new definition of {\tt M}, it is a simple matter to+specify operations {\tt (alloc : M Loc)}, {\tt (read : Loc -> M Value)}, and {\tt+(write : Loc -> M Value)} which allocate a new location in the heap, and read (and+write) from (and to) heap locations, respectively.++Now, the only necessary change to our interpreter is to replace closures with+thunks in the definition of function application:+{\small+\begin{verbatim}+mExp :: Exp -> M Value+mExp (App f x) =+   do { rho <- rdEnv+      ; (FV f1) <- mExp f+      ; loc <- alloc+      ; write loc (mkthunk rho loc (mExp x))+      ; f1 (read loc) }+where+     mkthunk r l phi = +           do { v <- inEnv r phi ; write l (return v) ; return v }+\end{verbatim}+}++The first two lines of this code are identical to those in the+original call-by-name definition in Section \ref{CBNapplication}.+Then, a new location {\tt loc} is allocated in the heap, and a thunk for+the argument {\tt x} (i.e., {\tt mkthunk rho loc (mExp x)}), is written to {\tt+loc}. Now, rather than passing the closure {\tt (inEnv rho (mExp x))} as one+would in call-by-name, a reference to {\tt loc} is +passed: {\tt (f1 (read loc))}. ++Defining application in this manner implements call-by-need evaluation. The first+time {\tt x} is evaluated within {\tt f}, the thunk {\tt (mkthunk rho loc (mExp x))}+will evaluate the closure {\tt (inEnv rho (mExp x))} to value {\tt v}, and will then+update itself by writing the unit computation {\tt (return v)} to {\tt loc}.+Successive evaluations of {\tt x} will share {\tt (return v)} rather than the+original closure, as call-by-name would.++To fully exploit the sharing of call-by-need in our interpreter we would have to rephrase+the pattern binding within matches in a case expression {\tt (case e of m1 ... mn)} so that+incremental evaluation of {\tt e} is performed.++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++\section{Using the interpreter: evaluation subtleties}++\newcommand{\undef}{\ensuremath{\perp}}++Consider the following example taken from the Haskell'98+Report\cite{Haskell98} (page 43) which demonstrates the subtle+differences in evaluation between constructors introduced with {\tt+data},+{\tt data} with strictness annotations, and {\tt newtype}:+\begin{verbatim}+     data D1 = D1 Int                      d1 (D1 i) = 42+     data D2 = D2 !Int                     d2 (D2 i) = 42+     newtype N = N Int                     n (N i) = 42+\end{verbatim}++The differences in evaluation between {\tt D1}, {\tt D2}, and {\tt N} are then+illustrated by the following equivalences:++{\small+\begin{center}+\begin{tabular}{|c|c|}\hline+Haskell Terms & Equivalent to: \\+\hline+{\tt (d1 \undef)},\quad {\tt (d2 \undef)}, \quad {\tt (d2 (D2 \undef))} & \undef\\+\hline+{\tt (n \undef)},\quad {\tt (n (N \undef))},\quad  {\tt (d1 (D1 \undef))} & {\tt+42}\\+\hline+{\tt (N \undef)},\quad {\tt (D2 \undef)}, \quad ({\em but not} {\tt (D1 \undef)}) &+\undef\\+\hline+\end{tabular}+\end{center}+}++It is possible to point to lines in the code presented here which explain this+behavior! For example, exactly why is {\tt (D1 \undef)} not \undef, while {\tt (D2+\undef)} and {\tt (N \undef)} are? Just look at the clauses defining the various+flavors of constructor application:++%\vspace*{.5in}+\begin{minipage}[h]{6in}+{\footnotesize+\begin{verbatim}+         mExp (ConApp n es) =+           do { rho <- rdEnv+              ; let f (e,Lazy) es   =+{-1-}                 do { cs <- es; return ((inEnv rho (mExp e)):cs) }+                    f (e,Strict) es =+{-2-}                 do { c <- mExp e; cs <- es; return((return c):cs)}+              ; cs <- foldr f (return []) es+              ; return(Tagged n cs)+              }+{-3-}    mExp (NewApp n x) = mExp x++\end{verbatim}+}+\end{minipage}++%\vspace{.2in}++\noindent  {\tt (D1 \undef)} is evaluated as a lazy constructor application, and its+meaning (from the line marked ``{\small \verb+{-1-}+}'') is the non-\undef\/ suspension {\tt+(return (inEnv r \undef))}. Having a strictness annotation, {\tt D2} evaluates its+argument on the line marked ``{\small \verb+{-2-}+}'' with {\tt do \{ c <- \undef ; ...\}},+and so {\tt (D2 \undef)} produces \undef. A constructor introduced by {\tt newtype}+is not treated as a {\em bona fide} semantic function, as {\tt data} constructors+are, and as shown on line ``{\small \verb+{-3-}+}'', {\tt (N i)} and {\tt i} are semantically the same thing. Thus, {\tt (N+\undef)} and \undef\/ are equivalent.++Why does {\tt d1} behave strictly (i.e., {\tt (d1 \undef)} is equivalent to \undef),+while {\tt n} is lazy (i.e., {\tt (n \undef)} is equivalent to 42)? Just consider+the three lines defining pattern-matching on {\tt data} and {\tt newtype}+constructors:++{\footnotesize+\begin{verbatim}+     mPat (Pcondata tag ps) arg = hasTag tag arg  (...) (...)+     mPat (Pnewdata n p) arg = mPat p arg+     mPat (Pvar x) arg = return (Just [(x,arg)])+\end{verbatim}+}+\noindent It is enough to know that the discriminant {\tt hasTag} evaluates+its argument {\tt arg} to see that {\tt (d1 \undef)} is equivalent to \undef. ++++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++\section{Pattern-matching compilation is not just desugaring}++If a pattern {\tt p} is \(\mathtt{(C}\; \mathtt{t_1}\ldots \mathtt{t_n)}\) where+$\mathtt{t_i}$ are variables, and $\mathtt{C}$ is a constructor function, then+{\tt p} is a {\em simple} pattern. However, if one or more of the $\mathtt{t_i}$+are not variable patterns, then {\tt p} is a {\em nested} pattern.+Pattern-matching compilation\cite{PeytonJones86,SCP::JonesS1998} is typically performed as part of+the front-end (as it is in GHC and Hugs), because it yields more efficient+programs (see Chapter 5 by Wadler in \cite{PeytonJones86} for further details).+Figure~\ref{SyntacticSaccharin} shows an example of pattern-match compilation in+which the definition of a Haskell function {\tt nodups} with nested patterns is+transformed into a similar definition without nested patterns. One feature of this+transformation was the necessity of generating new variables {\tt x}, {\tt x'},+{\tt xs}, and {\tt xs'} along the way.+++\begin{figure}+\hrule+\vspace{1.5ex}++{\small+\begin{verbatim}+nodups1 l =      -- Original with nested patterns:+  case l of+    [] -> []      +    [x] -> [x]+    (y:(x:xs)) -> if x==y then (nodups1 (x:xs)) +                          else (y:(nodups1 (x:xs)))+                          +nodups2 xs'' =   -- After pattern-match compilation: +  case xs'' of +    [] -> []      +     x':xs' -> case xs' of+                [] -> [x']+                x:xs -> if x'==x then (nodups2 (x:xs)) +                                 else (x':(nodups2 (x:xs)))+\end{verbatim}+}+%\vspace{-0.5cm}+\caption{Syntactic Saccharin}+%I checked the Merriam-Webster dictionary-this is the correct spelling of +% ``Saccharin''+\vspace{1.5ex}+\hrule+\label{SyntacticSaccharin}+\end{figure}+++Previous attempts\cite{PeytonJone92a,PeytonJones:1998:TBO} to define a denotational semantics for the core of+Haskell concentrate on the fragment of the language without nested patterns (the+kind of programs produced by pattern-match compilation). This semantics for+``unnested'' Haskell core could be extended simply to the full language by+defining the meaning of a term with nested patterns to be the meaning of its+compilation. For example, the meaning of {\tt nodups1} is identified with that of+{\tt nodups2}. Observe that, within this extended semantics, there is an implicit+reliance on the ability to generate fresh names just as {\tt x}, {\tt x'}, {\tt+xs}, and {\tt xs'} were generated. The implicit assumption in this approach+that pattern-match compilation is essentially a semantically irrelevant+elimination of syntactic sugar.++One drawback of this extended semantics is that it is no longer compositional. A+much more serious flaw, however, derives from the reliance on fresh name+generation within the pattern-matching compilation. Recent+developments\cite{Moggi,Gabbay99lics} in the semantics of staged languages reveal that the+structural consequences of including name generation within a denotational+semantics are considerable. This would have serious consequences for+developing a simple logic for Haskell programs.+++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+++\section{Conclusions}++Haskell is commonly referred to as a lazy functional language, but it is more properly+understood as a non-strict language because it contains features (patterns, the {\tt+seq} operator, etc.) which introduce strict perturbations of the default lazy+evaluation mechanism. These perturbations are important for practical reasons: expert Haskell+programmers may use strictness sparingly in their programs to avoid some of the+computational overhead associated with laziness without giving it up entirely.++However, this mixed evaluation order complicates Haskell from a+semantic point of view. We have modeled Haskell's control of demand by+using a Reynolds style interpreter, which can model the full range, from+fully strict to fully lazy languages. We used a monadic style to get fine control+over demand, and to encapsulate the various effects of Haskell.++The present work is the first formal treatment of the fine control of demand in Haskell. We+present a language definition that clearly separates lazy and normal patterns. The patterns+considered were nested patterns, and we did not resort to pattern-match compilation to simplify+the task. The work clearly defines the interaction between {\tt data} (with and without+strictness annotations) and {\tt newtype} data constructors with Haskell's other features. This+definition lays the foundation for an equational reasoning system about real Haskell programs.+The code presented in this paper is available online at {\tt www.cse.ogi.edu/\verb+~+sheard/}.++\bibliographystyle{entcs}+\bibliography{body}  +++\end{document}
+ tools/interp/HaskellWorkshop/entcs.cls view
@@ -0,0 +1,1162 @@+%%
+%% This is file `entcs.cls'.
+%% IMPORTANT NOTICE:
+%% You are not allowed to distribute this file.
+%% For distribution of the original source see
+%% the copyright notice in the file esl.dtx .
+%%
+\def\esp@fileversion{2e-1.15}
+\def\esp@filedate{1994/01/12}
+%% esl.dtx Copyright (C) 1994 Elsevier Science
+\def\@shortjnl{\relax}
+ \def\@journal{Elsevier Preprint} \def\@company{}
+  \def\@shortjid{entcs}
+ \NeedsTeXFormat{LaTeX2e}
+ \ProvidesClass{\@shortjid}
+ [\esp@filedate, \esp@fileversion: \@journal]
+\RequirePackage{newlfont}
+\RequirePackage{amssymb}
+\RequirePackage{latexsym}
+\RequirePackage{hyperref}
+\input{leqno.clo}
+\DeclareOption{12pt}{}
+\DeclareOption{11pt}{}
+\DeclareOption{10pt}{}
+\DeclareOption{oneside}{\@twosidefalse \@mparswitchfalse}
+\DeclareOption{twoside}{\@twosidetrue  \@mparswitchtrue}
+\@twocolumnfalse
+\newif\if@TwoColumn
+\DeclareOption{onecolumn}{\@twocolumnfalse\@TwoColumnfalse}
+\DeclareOption{twocolumn}{\@twocolumntrue\@TwoColumntrue}
+\def\@docty{XX}
+\DeclareOption{letter}{%
+ \def\@docty{SN}%
+}
+\DeclareOption{proc}{%
+ \def\@docty{PP}%
+}
+\DeclareOption{erratum}{%
+ \def\@docty{EN}\gdef\@articletype{Erratum}%
+}
+\newif\if@draft
+\DeclareOption{draft}{%
+  \@drafttrue
+  \def\query{\marginpar{???}}%       % mark author queries in proof
+  \overfullrule 5\p@                 % to indicate overfull boxes
+}
+\DeclareOption{final}{%
+  \@draftfalse
+  \def\query{}%
+  \overfullrule \z@
+}
+\let\snm\relax \let\cty\relax \let\cny\relax
+\DeclareOption{capcas}{\typeout {* `capcas' option ignored *}}
+\newif\if@ussrhead \@ussrheadfalse
+\DeclareOption{ussrhead}{\@ussrheadtrue}
+\newif\if@debug \@debugfalse
+\DeclareOption{debug}{\typeout{* Debugging is on *}\@debugtrue
+              \errorcontextlines=1000}
+\newif\if@seceqn
+\@seceqnfalse                          % Default: equation numbering is not
+\DeclareOption{seceqn}{\@seceqntrue}   % reset at beginning of each section
+\newif\if@secthm
+\@secthmfalse
+\DeclareOption{secthm}{\@secthmtrue}
+\newif\if@nameyear
+\@nameyearfalse
+\DeclareOption{nameyear}{\@nameyeartrue}
+ \ExecuteOptions{oneside}
+ \ExecuteOptions{onecolumn,final}
+\ProcessOptions
+\def\@pagenumprefix{}
+\def\author@font{}
+\DeclareOldFontCommand{\rm}{\normalfont\rmfamily}{\mathrm}
+\DeclareOldFontCommand{\cal}{\normalfont\rmfamily}{\mathcal}
+\DeclareOldFontCommand{\sf}{\normalfont\sffamily}{\mathsf}
+\DeclareOldFontCommand{\tt}{\normalfont\ttfamily}{\mathtt}
+\DeclareOldFontCommand{\bf}{\normalfont\bfseries}{\mathbf}
+\DeclareOldFontCommand{\it}{\normalfont\itshape}{\mathit}
+\DeclareOldFontCommand{\sl}{\normalfont\slshape}{\@nomath\sl}
+\DeclareOldFontCommand{\sc}{\normalfont\scshape}{\@nomath\sc}
+\def\partname{Part}
+\def\contentsname{Contents}
+\def\listfigurename{List of Figures}
+\def\listtablename{List of Tables}
+\def\refname{References}
+\def\indexname{Index}
+\def\figurename{Fig.}
+\def\tablename{Table}
+\def\abstractname{Abstract}
+\lineskip 1\p@
+\normallineskip 1\p@
+\def\baselinestretch{1}
+\nonfrenchspacing
+\def\@overtitleskip{69pt}
+\def\@bibliosize{\frenchspacing\small}
+\def\@historysize{\small}
+\def\@keywordsize{\small}
+\def\@titlesize{\Large}
+\def\@authorsize{\large}
+\def\@keywordheading{{\it Key words: \ }}
+\def\@addressstyle{\small\itshape}
+\def\@captionsize{\small}
+\def\@abstractsize{\fontsize{\@ixpt}{11pt}\selectfont}
+\def\@articletypesize{\fontsize{\@xiiipt}{13pt}\selectfont}
+\def\normalsize{\@setfontsize\normalsize\@xiipt{14.5}%
+\abovedisplayskip 12\p@ \@plus 2\p@ \@minus 2\p@%
+\belowdisplayskip \abovedisplayskip
+\abovedisplayshortskip \z@ \@plus 2\p@%
+\belowdisplayshortskip 3.5\p@ \@plus 2\p@ \@minus 2\p@
+\let\@listi\@listI}
+\def\small{\@setfontsize\small\@xipt{13.6}%
+\abovedisplayskip 11\p@ plus3\p@ minus6\p@
+\belowdisplayskip \abovedisplayskip
+\abovedisplayshortskip  \z@ plus3\p@
+\belowdisplayshortskip  6.5\p@ plus3.5\p@ minus3\p@
+\def\@listi{\leftmargin\leftmargini
+ \parsep 4.5\p@ plus2\p@ minus\p@ \itemsep 5\p@%\parsep
+            \topsep 9\p@ plus3\p@ minus5\p@}}
+%\let\footnotesize=\small
+\def\footnotesize{\@setsize\footnotesize{12\p@}\xpt\@xpt}
+\def\scriptsize{\@setfontsize\scriptsize\@viiipt{9.5}}
+\def\tiny{\@setfontsize\tiny\@vipt{7}}
+\def\large{\@setfontsize\large\@xivpt{18}}
+\def\Large{\@setfontsize\Large\@xviipt{22}}
+\def\LARGE{\@setfontsize\LARGE\@xxpt{22}}
+\def\huge{\@setfontsize\huge\@xxvpt{27}}
+\let\Huge=\huge
+\def\baselinestretch{1}
+\normalsize                                % Choose the normalsize font.
+\newdimen\@bls                             % Several dimensions are
+\@bls=\baselineskip                        % expressed in terms of this.
+\if@twoside                  % Values for two-sided printing:
+   \oddsidemargin   50\p@    %   Left margin on odd-numbered pages.
+   \evensidemargin  10\p@    %   Left margin on even-numbered pages.
+   \marginparwidth  10\p@    %   \@Width of marginal notes.
+\else                        % Values for one-sided printing:
+   \oddsidemargin   35\p@    %   Left margin on odd-numbered pages.
+   \evensidemargin  35\p@    %   Left margin on even-numbered pages.
+   \marginparwidth   2pc
+\fi
+\marginparsep 20\p@          % Horizontal space between outer margin and
+                             % marginal note
+\topmargin \z@           %    Nominal distance from top of page to top of
+                         %    box containing running head.
+\headheight  \z@         %    \@Height of box containing running head.
+\headsep     \z@         %    Space between running head and text.
+ \footskip 40\p@
+\bigskipamount=\@bls \@plus 0.3\@bls \@minus 0.3\@bls % 1/1 line
+\medskipamount=0.5\bigskipamount                  % 1/2 line
+\smallskipamount=0.25\bigskipamount               % 1/4 line
+\textheight 42\baselineskip  %44? \@Height of text (including footnotes and 
+\advance\textheight\topskip  % figures, excluding running head and foot).
+\textwidth 33pc              % \@Width of text line.
+                             % For two-column mode:
+\columnsep 2pc               %   Space between columns
+\columnseprule \z@           %   \@Width of rule between columns.
+ \footnotesep 8.4\p@
+\skip\footins 12\p@ \@plus  8\p@      % Space between last line of text and
+                                      % top of first footnote.
+\floatsep 8\p@ \@plus 4\p@ \@minus 2\p@ % Space between adjacent floats moved
+                                        % to top or bottom of text page.
+\textfloatsep 8\p@ \@plus 4\p@\@minus 2\p@ % Space between main text and 
+                                           % floats at top or bottom of page.
+\intextsep 8\p@ \@plus 4\p@ \@minus 2\p@ % Space between in-text figures and
+                                         % text.
+\dblfloatsep      8\p@ \@plus 4\p@ \@minus 4\p@ % Same as \floatsep for double-column
+                                         % figures in two-column mode.
+\dbltextfloatsep 12\p@ \@plus 4\p@ \@minus 4\p@ % \textfloatsep for double-column
+                                         % floats.
+\@fptop \z@ \@plus 1fil  % Stretch at top of float page/column. (Must be
+                         % \z@ \@plus ...)
+\@fpsep 8\p@ \@plus 2fil % Space between floats on float page/column.
+\@fpbot \z@ \@plus 1fil  % Stretch at bottom of float page/column. (Must be
+                         % \z@ \@plus ... )
+\@dblfptop \z@ \@plus 1fil % Stretch at top of float page. (Must be \z@ \@plus ...)
+\@dblfpsep 8\p@ \@plus 2fil % Space between floats on float page.
+\@dblfpbot \z@ \@plus 1fil % Stretch at bottom of float page. (Must be
+                           % \z@ \@plus ... )
+\marginparpush 5\p@        % Minimum vertical separation between two marginal
+                           % notes.
+\parskip 1pt % 1pc \@plus 1\p@   % Extra vertical space between paragraphs.
+\parindent 1.5em                 % Indentation of each paragraph.
+\newskip\eqntopsep                   % Extra vertical space, in addition to
+ \eqntopsep 4pt plus 1\p@ minus 1\p@ % \parskip, added above and below
+\newdimen\eqnarraycolsep             % Half the space between columns
+\eqnarraycolsep 1\p@                 % in an \eqnarray.
+\@lowpenalty   51      % Produced by \nopagebreak[1] or \nolinebreak[1]
+\@medpenalty  151      % Produced by \nopagebreak[2] or \nolinebreak[2]
+\@highpenalty 301      % Produced by \nopagebreak[3] or \nolinebreak[3]
+\@beginparpenalty -\@lowpenalty    % Before a list or paragraph environment.
+\@endparpenalty   -\@lowpenalty    % After a list or paragraph environment.
+\@itempenalty     -\@lowpenalty    % Between list items.
+% \def\section{\@startsection{section}{1}{\z@}{1.5\@bls
+%   \@plus .4\@bls \@minus .1\@bls}{\@bls}{\normalsize\bfseries}}
+\def\section{\@startsection{section}{1}{\z@}%
+        {-3ex plus -1ex minus -.2ex}%
+        {2ex plus .2ex}{\large\bfseries}}
+% \def\subsection{\@startsection{subsection}{2}{\z@}{\@bls
+%   \@plus .3\@bls \@minus .1\@bls}{\@bls}{\normalsize\itshape}}
+\def\subsection{\@startsection{subsection}{2}{\z@}%
+        {-3ex plus -1ex minus -.2ex}%
+        {1.3ex plus .2ex}{\normalsize\itshape}}
+% \def\subsubsection{\@startsection{subsubsection}{3}{\z@}{\@bls
+%   \@plus .2\@bls}{0.0001pt}{\normalsize\itshape}}
+\def\subsubsection{\@startsection{subsubsection}{3}{-\lastskip}{-\@bls plus
+-.2\@bls}{0.0001pt}{\normalsize\itshape}}
+\def\paragraph{\@startsection{paragraph}{4}{\z@}{3.25ex plus
+  2ex \@minus 0.2ex}{0.0001pt}{\normalsize\bfseries}} %was -1em
+\setcounter{secnumdepth}{3}
+\def\half@em{\hskip 0.5em} \def\lb@part{PART \thepart.\half@em}
+\def\lb@empty@part{PART \thepart}
+\def\lb@section{\thesection.\half@em}
+\def\lb@empty@section{\thesection}
+\def\lb@subsection{\thesubsection.\half@em}
+\def\lb@empty@subsection{\thesubsection}
+\def\lb@subsubsection{\thesubsubsection.\half@em}
+\def\lb@empty@subsubsection{\thesubsubsection}
+\def\lb@paragraph{\theparagraph.\half@em}
+\def\lb@empty@paragraph{\theparagraph}
+\def\lb@subparagraph{\thesubparagraph.\half@em}
+\def\lb@empty@subparagraph{\thesubparagraph}
+\def\head@style{\interlinepenalty\@M \hyphenpenalty\@M
+  \exhyphenpenalty\@M \rightskip 0pt plus 0.5\hsize \relax}
+\def\app@number#1{\setcounter{#1}{0}%
+  \@addtoreset{#1}{section}%
+  \@namedef{the#1}{\thesection.\arabic{#1}}}
+\def\appendix{\@ifstar{\appendix@star}{\appendix@nostar}}
+\def\appendix@nostar{%
+  \def\lb@section{Appendix \thesection.\half@em}
+  \def\lb@empty@section{Appendix \thesection}
+  \setcounter{section}{0}\def\thesection{\Alph{section}}%
+  \setcounter{subsection}{0}%
+  \setcounter{subsubsection}{0}%
+  \setcounter{paragraph}{0}%
+  \app@number{equation}\app@number{figure}\app@number{table}}
+\def\appendix@star{%
+  \def\lb@section{Appendix}\let\lb@empty@section\lb@section
+  \setcounter{section}{0}\def\thesection{\Alph{section}}%
+  \setcounter{subsection}{0}%
+  \setcounter{subsubsection}{0}%
+  \setcounter{paragraph}{0}%
+  \app@number{equation}\app@number{figure}\app@number{table}}
+\def\ack{\section*{%
+Acknowledgement
+  }
+  \addtocontents{toc}{\protect\vspace{6pt}}%
+  \addcontentsline{toc}{section}{%
+Acknowledgement
+}}
+\@namedef{ack*}{\par\vskip 3.0ex \@plus 1.0ex \@minus 1.0ex}
+\let\endack\par
+\@namedef{endack*}{\par}
+\newdimen\labelwidthi
+\newdimen\labelwidthii
+\newdimen\labelwidthiii
+\newdimen\labelwidthiv
+\def\normal@labelsep{0.5em}
+\labelsep\normal@labelsep
+\settowidth{\labelwidthi}{(iii)}
+\settowidth{\labelwidthii}{(d)}
+\settowidth{\labelwidthiii}{(iii)}
+\settowidth{\labelwidthiv}{(M)}
+\leftmargini\labelwidthi    \advance\leftmargini\labelsep
+\leftmarginii\labelwidthii  \advance\leftmarginii\labelsep
+\leftmarginii\labelwidthiii \advance\leftmarginiii\labelsep
+\leftmarginii\labelwidthiv  \advance\leftmarginiv\labelsep
+\def\setleftmargin#1#2{\settowidth{\@tempdima}{#2}\labelsep\normal@labelsep
+  \csname labelwidth#1\endcsname\@tempdima
+  \@tempdimb\@tempdima \advance\@tempdimb\labelsep
+  \csname leftmargin#1\endcsname\@tempdimb}
+\def\@listI{\leftmargin\leftmargini
+  \labelwidth\labelwidthi \labelsep\normal@labelsep
+  \topsep .35pc%\z@
+\partopsep\z@ \parsep\z@ \itemsep .3pc%5\p@%2\parsep%\z@
+  \listparindent 1em}
+\def\@listii{\leftmargin\leftmarginii
+  \labelwidth\labelwidthii \labelsep\normal@labelsep
+  \topsep\z@ \partopsep\z@ \parsep\z@ \itemsep \z@
+  \listparindent 1em}
+\def\@listiii{\leftmargin\leftmarginiii
+  \labelwidth\labelwidthiii \labelsep\normal@labelsep
+  \topsep\z@ \partopsep\z@ \parsep\z@ \itemsep \z@
+  \listparindent 1em}
+\def\@listiv{\leftmargin\leftmarginiv
+  \labelwidth\labelwidthiv \labelsep\normal@labelsep
+  \topsep\z@ \partopsep\z@ \parsep\z@ \itemsep \z@
+  \listparindent 1em}
+\let\@listi\@listI
+\@listi
+\def\left@label#1{{#1}\hss}
+\def\rechts@label#1{\hss\llap{#1}}
+\def\thick@label#1{\hspace\labelsep #1}
+\newcount\@maxlistdepth
+\@maxlistdepth=2
+\def\labelitemi{\lower.5ex\hbox{$^\bullet$}} %originally -- changed  8-6-95
+\def\labelitemii{$\cdot$}           %originally \cdot changed 8-6-95
+\def\labelenumi{(\theenumi)}        \def\theenumi{\roman{enumi}}
+\def\labelenumii{(\theenumii)}      \def\theenumii{\alph{enumii}}
+\def\enumerate{%
+  \ifnum \@enumdepth >\@maxlistdepth
+    \@toodeep
+  \else
+    \advance\@enumdepth \@ne
+    \edef\@enumctr{enum\romannumeral\the\@enumdepth}%
+    \list{\csname label\@enumctr\endcsname}%
+       {\usecounter{\@enumctr}
+       \let\makelabel=\rechts@label}
+  \fi}
+\def\itemize{%
+  \ifnum \@itemdepth >\@maxlistdepth
+    \@toodeep
+  \else
+    \advance\@itemdepth \@ne
+    \edef\@itemitem{labelitem\romannumeral\the\@itemdepth}%
+     \setleftmargin{i}{--}%
+     \setleftmargin{ii}{$\cdot$}%
+    \list{\csname\@itemitem\endcsname}%
+       {\let\makelabel\rechts@label}
+  \fi}
+\def\verse{\let\\=\@centercr
+  \list{}{\itemsep\z@
+  \itemindent \z@
+  \listparindent\z@
+  \rightmargin 1em
+  \leftmargin \rightmargin}\item[]}
+\let\endverse\endlist
+\def\quotation{\list{}{\itemindent\z@
+ \leftmargin 1em \rightmargin \z@
+  \parsep \z@ \@plus 1pt}\item[]}
+\let\endquotation=\endlist
+\def\quote{\list{}{\itemindent\z@
+   \leftmargin 1em \rightmargin \z@}%
+\item[]}
+\let\endquote=\endlist
+\def\descriptionlabel#1{\hspace\labelsep \bfseries #1}
+\def\description{\list{}{\labelwidth\z@
+  \leftmargin 1em \itemindent-\leftmargin
+  \let\makelabel\descriptionlabel}}
+\let\enddescription\endlist
+\def\@atfmtname{atlplain}
+\ifx\fmtname\@atfmtname
+ \def\neq{\not\nobreak\mkern -2mu =}%
+ \let\ne\neq
+\fi
+\def\operatorname#1{\mathop{\mathrm{#1}}\nolimits}
+\def\lefteqn#1{\hbox to\z@{$\displaystyle {#1}$\hss}}
+\newskip\eqnbaselineskip % Standard interline spacing in an {eqnarray}
+\jot=2\p@
+\newskip\eqnlineskip     % Minimal space between the bottom of
+                         % a line and the top of the next line.
+\eqnbaselineskip=14\p@  \eqnlineskip=2\p@
+\newdimen\mathindent
+\if@TwoColumn
+  \mathindent 0em
+\else
+  \mathindent 2em
+\fi
+\def\[{\relax\ifmmode\@badmath
+  \else  %\bgroup removed on request from BW (1993-05-17)
+  \@beginparpenalty\predisplaypenalty
+  \@endparpenalty\postdisplaypenalty
+  \begin{trivlist}\@topsep \eqntopsep       % used by first \item
+   \@topsepadd \eqntopsep                   % used by \@endparenv
+  \item[]\leavevmode
+   \hbox to\linewidth\bgroup\hfil $ \displaystyle
+  \hskip\mathindent\bgroup\fi}
+\def\]{\relax\ifmmode \egroup $\hfil \egroup
+  \end{trivlist}    % \egroup removed on request from BW (1993-05-17)
+  \else \@badmath \fi}
+\def\equation{\@beginparpenalty\predisplaypenalty
+  \@endparpenalty\postdisplaypenalty
+\refstepcounter{equation}\trivlist
+   \@topsep \eqntopsep                      % used by first \item
+   \@topsepadd \eqntopsep                   % used by \@endparenv
+   \item[]\leavevmode
+   \hbox to\linewidth\bgroup \hfil $ \displaystyle \hskip\mathindent\bgroup}
+\def\endequation{\egroup$\hfil \displaywidth\linewidth
+  \@eqnnum\egroup \endtrivlist}
+\def\eqnarray{%
+  \par                                               %BW
+  \noindent                                          %BW
+  \baselineskip\eqnbaselineskip\lineskip\eqnlineskip %BW
+  \lineskiplimit\eqnlineskip                         %BW
+  \stepcounter{equation}%
+  \let\@currentlabel=\theequation
+  \global\@eqnswtrue
+  \global\@eqcnt\z@ \tabskip\mathindent \let\\=\@eqncr
+  \abovedisplayskip\eqntopsep\ifvmode\advance\abovedisplayskip\partopsep\fi
+  \belowdisplayskip\abovedisplayskip
+  \belowdisplayshortskip\abovedisplayskip
+  \abovedisplayshortskip\abovedisplayskip
+  $$\halign to \displaywidth\bgroup\@eqnsel
+    \pre@coli$\displaystyle\tabskip\z@{##}$\post@coli
+    &\global\@eqcnt\@ne
+    \pre@colii$\displaystyle{##}$\post@colii
+    &\global\@eqcnt\tw@
+    \pre@coliii $\displaystyle\tabskip\z@{##}$\post@coliii
+    \tabskip\@centering&\llap{##}\tabskip\z@\cr}
+\def\endeqnarray{\@@eqncr\egroup
+ \global\advance\c@equation\m@ne$$\global\@ignoretrue }
+\def\pre@coli{\hskip\@centering}              \def\post@coli{}
+\def\pre@colii{\hskip 2\eqnarraycolsep \hfil} \def\post@colii{\hfil}
+\def\pre@coliii{\hskip 2\eqnarraycolsep}      \def\post@coliii{\hfil}
+\arraycolsep 2\p@      % Half the space between columns in array environment.
+\tabcolsep 6\p@        % idem in tabular environment.
+\def\arraystretch{1.5} % More vertical space in tables
+\arrayrulewidth 0.4\p@ % \@Width of rules and space between adjacent
+\doublerulesep 2\p@    % rules in any of these two environments.
+\tabbingsep \labelsep  % Space used by the \' command.  (See LaTeX{} manual.)
+\skip\@mpfootins = 6\p@ \@plus 2\p@  % Space between last line of text and
+                                     % top of first footnote.
+\fboxsep = 7\p@    % Space left between box and text by \fbox and \framebox.
+\fboxrule = 0.4\p@ % \@Width of rules in box made by \fbox and \framebox.
+\newcounter{section}
+\newcounter{subsection}[section]
+\newcounter{subsubsection}[subsection]
+\newcounter{paragraph}[subsubsection]
+\newcounter{subparagraph}[paragraph]
+\if@seceqn
+ \@addtoreset{equation}{section}
+ \def\theequation{\arabic{section}.\arabic{equation}}
+\else
+  \def\theequation{\arabic{equation}}
+\fi
+\def\thesection      {\arabic{section}}
+\def\thesubsection   {\thesection.\arabic{subsection}}
+\def\thesubsubsection{\thesubsection.\arabic{subsubsection}}
+\def\theparagraph    {\thesubsubsection.\arabic{paragraph}}
+\def\thesubparagraph {\theparagraph.\arabic{subparagraph}}
+\@addtoreset{section}{part} % reset section numbers at beginning of part
+%\def\qed{\relax\ifmmode\hskip2em \Box\else\unskip\nobreak\hskip1em $\Box$\fi}
+\def\qed{\relax\ifmmode\hfill \Box\else\unskip\nobreak\hfill $\Box$\fi}
+
+\def\proof@headerfont{\upshape\bfseries}
+\gdef\theorem@headerfont{\itshape}
+\gdef\th@plain{\upshape
+  \def\@begintheorem##1##2{\item[\hskip\labelsep
+    {\theorem@headerfont ##1\ ##2.}]}%
+  \def\@opargbegintheorem##1##2##3{\item[\hskip\labelsep
+    {\theorem@headerfont ##1\ ##2.}\ {\upshape (##3).}]}}
+\gdef\th@definition{\upshape
+  \def\@begintheorem##1##2{\item[\hskip\labelsep
+    {\theorem@headerfont ##1\ ##2.}]}%
+  \def\@opargbegintheorem##1##2##3{\item[\hskip\labelsep
+    {\theorem@headerfont ##1\ ##2.}\ {\upshape (##3).}]}}
+
+\newenvironment{pf}%
+  {\par\addvspace{.6pc plus .2pc minus .1pc}
+   \noindent
+   {\textbf\proofname}\enspace\ignorespaces}%
+  {\par\addvspace{.6pc plus .2pc minus .1pc}}
+\def\proofname{Proof.}
+\@namedef{pf*}#1{\par\begingroup\def\proofname{#1}\pf\endgroup\ignorespaces}
+\expandafter\let\csname endpf*\endcsname=\endpf
+\newtheorem{thm}{Theorem}[section]
+\newtheorem{cor}[thm]{Corollary}
+\newtheorem{lem}[thm]{Lemma}
+\newtheorem{claim}[thm]{Claim}
+\newtheorem{axiom}[thm]{Axiom}
+\newtheorem{conj}[thm]{Conjecture}
+\newtheorem{fact}[thm]{Fact}
+\newtheorem{hypo}[thm]{Hypothesis}
+\newtheorem{assum}[thm]{Assumption}
+\newtheorem{prop}[thm]{Proposition}
+\newtheorem{crit}[thm]{Criterion}
+\newtheorem{defn}[thm]{Definition}
+\newtheorem{exmp}[thm]{Example}
+\newtheorem{rem}[thm]{Remark}
+\newtheorem{prob}[thm]{Problem}
+\newtheorem{prin}[thm]{Principle}
+\newtheorem{alg}{Algorithm}
+\long\def\@makealgocaption#1#2{\vskip 2ex \small
+  \hbox to \hsize{\parbox[t]{\hsize}{{\bfseries #1.} #2}}}
+\newcounter{algorithm}
+\def\thealgorithm{\@arabic\c@algorithm}
+\def\fps@algorithm{tbp}
+\def\ftype@algorithm{4}
+\def\ext@algorithm{lof}
+\def\fnum@algorithm{Algorithm \thealgorithm}
+\def\algorithm{\let\@makecaption\@makealgocaption\@float{algorithm}}
+\let\endalgorithm\end@float
+\newtheorem{note}{Note}
+\newtheorem{summ}{Summary}
+\newtheorem{case}{Case}
+\def\@pnumwidth{2.55em}
+\def\@tocrmarg{2.55em \@plus 5em}
+\def\@dotsep{-2.5}
+\setcounter{tocdepth}{2}
+\def\tableofcontents{%
+  \section*{\contentsname}%
+  \@starttoc{toc}}
+\def\l@section{\@dottedtocline{1}{0.0em}{1.40em}}
+\def\l@subsection{\@dottedtocline{2}{1.40em}{2.24em}}
+\def\l@subsubsection{\@dottedtocline{3}{2.24em}{3.09em}}
+\def\thebibliography{%
+  \@startsection{section}{1}{\z@}{20\p@ \@plus 8\p@ \@minus 4pt}
+  {\@bls}{\large\bfseries}*{\refname}%
+  \addcontentsline{toc}{section}{\refname}%
+  \@thebibliography}
+\let\endthebibliography=\endlist
+\def\@thebibliography#1{\@bibliosize
+  \list{\@biblabel{\arabic{enumiv}}}{\settowidth\labelwidth{\@biblabel{#1}}
+  \if@nameyear
+    \labelwidth\z@ \labelsep\z@ \leftmargin\parindent
+    \itemindent-\parindent
+  \else
+    \labelsep 3\p@ \itemindent\z@
+    \leftmargin\labelwidth \advance\leftmargin\labelsep
+\fi
+     \itemsep 0.3\@bls \@plus 0.1\@bls \@minus 0.1\@bls
+    \usecounter{enumiv}\let\p@enumiv\@empty
+    \def\theenumiv{\arabic{enumiv}}}%
+    \def\newblock{\hskip 0.11em \@plus 0.33em \@minus -0.07em}
+    \tolerance\@M \hyphenpenalty\@M \hbadness5000 \sfcode`\.=1000\relax}
+\if@nameyear
+  \def\@biblabel#1{}
+\else
+  \def\@biblabel#1{\hskip \z@ \@plus 1filll[#1]}
+\fi
+\newcount\@tempcntc
+\def\@citex[#1]#2{\if@filesw\immediate\write\@auxout{\string\citation{#2}}\fi
+ \@tempcnta\z@\@tempcntb\m@ne\def\@citea{}\@cite{\@for\@citeb:=#2\do
+  {\@ifundefined
+   {b@\@citeb}{\@citeo\@tempcntb\m@ne\@citea\def\@citea{,}{\bfseries ?}\@warning
+   {Citation `\@citeb' on page \thepage \space undefined}}%
+  {\setbox\z@\hbox{\global\@tempcntc0\csname b@\@citeb\endcsname\relax}%
+   \ifnum\@tempcntc=\z@ \@citeo\@tempcntb\m@ne
+    \@citea\def\@citea{,}\hbox{\csname b@\@citeb\endcsname}%
+   \else
+    \advance\@tempcntb\@ne
+    \ifnum\@tempcntb=\@tempcntc
+    \else\advance\@tempcntb\m@ne\@citeo
+    \@tempcnta\@tempcntc\@tempcntb\@tempcntc\fi\fi}}\@citeo}{#1}}
+\def\@citeo{\ifnum\@tempcnta>\@tempcntb\else\@citea\def\@citea{,}%
+ \ifnum\@tempcnta=\@tempcntb\the\@tempcnta\else
+  {\advance\@tempcnta\@ne\ifnum\@tempcnta=\@tempcntb \else \def\@citea{--}\fi
+   \advance\@tempcnta\m@ne\the\@tempcnta\@citea\the\@tempcntb}\fi\fi}
+\@namedef{cv*}{\section*{Curriculum Vitae}\cv}
+ \def\cv{\hangindent=7pc \hangafter=-12 \parskip\bigskipamount \small}
+\def\footnote{\@ifnextchar[{\@xfootnote}{\refstepcounter
+   {\@mpfn}\xdef\@thefnmark{\thempfn}\@footnotemark\@footnotetext}}
+\def\footnotemark{\@ifnextchar[{\@xfootnotemark
+    }{\refstepcounter{footnote}\xdef\@thefnmark{\thefootnote}\@footnotemark}}
+\def\footnoterule{\kern-3\p@
+  \hrule \@width 3pc           % The \hrule has default \@height of 0.4pt.
+  \kern 2.6\p@}
+\def\thempfootnote{\alph{mpfootnote}}
+\def\mpfootnotemark{%
+  \@ifnextchar[{\@xmpfootnotemark}{\stepcounter{mpfootnote}%
+  \begingroup
+    \let\protect\noexpand
+    \xdef\@thefnmark{\thempfootnote}%
+  \endgroup
+  \@footnotemark}}
+\def\@xmpfootnotemark[#1]{%
+  \begingroup
+    \c@mpfootnote #1\relax
+    \let\protect\noexpand
+    \xdef\@thefnmark{\thempfootnote}%
+  \endgroup
+  \@footnotemark}
+\def\@mpmakefnmark{$\,^{\mathrm{\@thefnmark}}$}
+\long\def\@mpmakefntext#1{\noindent
+                     {$^{\mathrm{\@thefnmark}}$ #1}}
+\def\@iiiminipage#1#2[#3]#4{%
+  \leavevmode
+  \@pboxswfalse
+  \setlength\@tempdima{#4}%
+  \def\@mpargs{{#1}{#2}[#3]{#4}}%
+  \setbox\@tempboxa\vbox\bgroup
+    \color@begingroup
+      \hsize\@tempdima
+      \textwidth\hsize \columnwidth\hsize
+      \@parboxrestore
+      \def\@mpfn{mpfootnote}\def\thempfn{\thempfootnote}\c@mpfootnote\z@
+      \let\@footnotetext\@mpfootnotetext
+      \let\@makefntext\@mpmakefntext
+      \let\@makefnmark\@mpmakefnmark
+      \let\@listdepth\@mplistdepth \@mplistdepth\z@
+      \@minipagerestore\global\@minipagetrue  %% \global added 24 May 89
+      \everypar{\global\@minipagefalse\everypar{}}}
+\def\fn@presym{}
+\long\def\@makefntext#1{\noindent\hbox to 1em
+  {$^{\fn@presym\mathrm{\@thefnmark}}$\hss}#1}
+\def\@makefnmark{\,\hbox{$^{\fn@presym\mathrm{\@thefnmark}}$}\,}
+\setcounter{topnumber}{5}
+\def\topfraction{0.99}
+\def\textfraction{0.05}
+\def\floatpagefraction{0.9}
+\setcounter{bottomnumber}{5}
+\def\bottomfraction{0.99}
+\setcounter{totalnumber}{10}
+\def\dbltopfraction{0.99}
+\def\dblfloatpagefraction{0.8}
+\setcounter{dbltopnumber}{5}
+\long\def\@maketablecaption#1#2{\@captionsize
+  \hbox to \hsize{\parbox[t]{\hsize}{\begin{center}#1 \\ #2\end{center}}}}
+\long\def\@makefigurecaption#1#2{\@captionsize
+  \vskip 8\p@
+  \setbox\@tempboxa\hbox{#1. #2}
+  \ifdim \wd\@tempboxa >\hsize              % IF longer than one line THEN
+    \unhbox\@tempboxa\par                   % set as justified paragraph
+  \else                                     % ELSE
+    \hbox to\hsize{\hfil\box\@tempboxa\hfil}%   center single line.
+  \fi}
+\def\conttablecaption{\par \begingroup \@parboxrestore \normalsize
+  \@makecaption{\fnum@table\,---\,continued}{}\par
+  \vskip-1pc \endgroup}
+\def\contfigurecaption{\vskip-1pc \par \begingroup \@parboxrestore \normalsize
+  \@makecaption{\fnum@figure\,---\,continued}{}\par
+  \endgroup}
+\newcounter{figure}
+\def\thefigure{\@arabic\c@figure}
+\def\fps@figure{tbp}
+\def\ftype@figure{1}
+\def\ext@figure{lof}
+\def\fnum@figure{\figurename~\thefigure}
+\def\figure{%
+\let\@makecaption\@makefigurecaption
+  \let\contcaption\contfigurecaption \@float{figure}}
+% \let\endfigure\end@float
+\def\endfigure{\addvspace{.2pc plus .2pc minus .1pc}\end@float}
+\@namedef{figure*}{%
+\let\@makecaption\@makefigurecaption
+  \let\contcaption\contfigurecaption \@dblfloat{figure}}
+\@namedef{endfigure*}{\end@dblfloat}
+\newcounter{table}
+\def\thetable{\@arabic\c@table}
+\def\fps@table{tbp}
+\def\ftype@table{2}
+\def\ext@table{lot}
+\def\fnum@table{\tablename~\thetable}
+\def\table{%
+\let\@makecaption\@maketablecaption
+\small
+  \let\footnoterule\relax
+  \let\contcaption\conttablecaption \@float{table}}
+%\let\endtable\end@float
+\def\endtable{\addvspace{.2pc plus .2pc minus .1pc}\end@float}
+\@namedef{table*}{%
+\let\@makecaption\@maketablecaption
+\small
+  \let\footnoterule\relax
+  \let\contcaption\conttablecaption \@dblfloat{table}}
+\@namedef{endtable*}{\end@dblfloat}
+\newtoks\t@glob@notes             % List of all notes
+\newtoks\t@loc@notes              % List of notes for one element
+\newcount\note@cnt                % Number of notes per element
+\newcounter{author}               % Author counter
+\newcount\n@author                % Total number of authors
+\def\n@author@{}                  % idem, read from .aux file
+\newcounter{collab}               % Collaboration counter
+\newcount\n@collab                % Total number of collaborations
+\def\n@collab@{}                  % idem, read from .aux file
+\newcounter{address}              % Address counter
+\newdimen\sv@mathsurround         % Dimen register to save \mathsurround
+\newcount\sv@hyphenpenalty        % Count register to save \hyphenpenalty
+\newcount\prev@elem \prev@elem=0  % Variables to keep track of
+\newcount\cur@elem  \cur@elem=0   % types of elements that are processed
+\chardef\e@title=1
+\chardef\e@subtitle=1
+\chardef\e@author=2
+\chardef\e@collab=3
+\chardef\e@address=4
+\newif\if@newelem                 % Switch to new type of element?
+\newif\if@firstauthor             % First author or collaboration?
+\newif\if@preface                 % If preface: omit history and abstract
+\newif\if@hasabstract             % If abstract / keywords: do not omit rules
+\newbox\fm@box                    % Box for collected front matter
+\newdimen\fm@size                 % Total height of \fm@box
+\newbox\t@abstract                % Box for abstract
+\newbox\t@keyword                 % Box for keyword abstract
+ \let\report@elt\@gobble
+\def\add@tok#1#2{\global#1\expandafter{\the#1#2}}
+\def\add@xtok#1#2{\begingroup
+  \no@harm
+  \xdef\@act{\global\noexpand#1{\the#1#2}}\@act
+\endgroup}
+\def\beg@elem{\global\t@loc@notes={}\global\note@cnt\z@}
+\def\@xnamedef#1{\expandafter\xdef\csname #1\endcsname}
+\def\no@harm{%
+  \let\\=\relax  \let\rm\relax
+  \let\ss=\relax \let\ae=\relax \let\oe=\relax
+  \let\AE=\relax \let\OE=\relax
+  \let\o=\relax  \let\O=\relax
+  \let\i=\relax  \let\j=\relax
+  \let\aa=\relax \let\AA=\relax
+  \let\l=\relax  \let\L=\relax
+  \let\d=\relax  \let\b=\relax \let\c=\relax
+  \let\bar=\relax
+  \def\protect{\noexpand\protect\noexpand}}
+\def\proc@elem#1#2{\begingroup
+    \no@harm                             % make a few instructions harmless
+    \let\thanksref\@gobble               % remove \thanksref from element
+    \@xnamedef{@#1}{#2}%                 % and store as \@#1
+  \endgroup
+  \prev@elem=\cur@elem                   % keep track of type of previous
+  \cur@elem=\csname e@#1\endcsname       % and current element
+  \expandafter\elem@nothanksref#2\thanksref\relax}
+\def\elem@nothanksref#1\thanksref{\futurelet\@peektok\elem@thanksref}
+\def\elem@thanksref{\ifx\@peektok\relax  % No more \thanksref, so now exit
+  \else \expandafter\elem@morethanksref \fi}
+\def\elem@morethanksref#1{\add@thanksref{#1}\elem@nothanksref}
+\def\add@thanksref#1{\global\advance\note@cnt\@ne
+  \ifnum\note@cnt>\@ne \add@xtok\t@loc@notes{\note@sep}\fi
+  \add@tok\t@loc@notes{\ref{#1}}}
+\def\note@sep{,}
+\def\thanks{\@ifnextchar[{\@tempswatrue
+  \thanks@optarg}{\@tempswafalse\thanks@optarg[]}}
+\def\thanks@optarg[#1]#2{\refstepcounter{footnote}\if@tempswa
+  \label{#1}\else\relax\fi
+  \add@tok\t@glob@notes{\footnotetext}%
+  \add@xtok\t@glob@notes{[\the\c@footnote]}%
+  \add@tok\t@glob@notes{{#2}}}
+\def\footnote{\@ifnextchar[{\@xfootnote}{\refstepcounter%
+   {\@mpfn}\xdef\@thefnmark{\thempfn}\@footnotemark\@footnotetext}}
+\def\footnotemark{\@ifnextchar[{\@xfootnotemark%
+    }{\refstepcounter{footnote}\xdef\@thefnmark{\thefootnote}\@footnotemark}}
+\def\footnoterule{\kern-3\p@\hrule \@width 3pc%  % The \hrule has default \@height of 0.4pt.
+  \kern 2.6\p@}
+ \let\report@elt\@gobble
+\def\frontmatter{\label{FirstPage}%
+  \let\@corresp@note\relax
+  \global\t@glob@notes={}\global\c@author\z@
+  \global\c@collab\z@ \global\c@address\z@
+  \sv@mathsurround\mathsurround \m@th
+  \global\n@author=0\n@author@\relax
+  \global\n@collab=0\n@collab@\relax
+  \global\advance\n@author\m@ne   % In comparisons later on we need
+  \global\advance\n@collab\m@ne   % n@author-1 and n@collab-1
+  \global\@firstauthortrue        % set to false by first \author or \collab
+  \global\@hasabstractfalse       % Default:  no abstract or keywords
+  \global\@prefacefalse           %           not preface
+  \@ifundefined{RIfM@}{}{\undo@AMS}%
+ \parskip 4\p@
+  \open@fm \ignorespaces}
+\def\preface{\@prefacetrue}
+\def\endfrontmatter{\global\n@author=\c@author
+  \global\n@collab=\c@collab \@writecount
+  \global\@topnum\z@
+  \thispagestyle{copyright}%            % Format rest of front matter:
+  \if@preface \else                     % IF not preface THEN
+  \history@fmt                          % print history (received, ...)
+  \newcount\c@sv@footnote
+  \global\c@sv@footnote=\c@footnote     % save current footnote number
+  \if@hasabstract                       % IF abstract/ keywords THEN
+   \vskip 24\p@ \@plus 6\p@ \@minus 3\p@ % Space above rule
+    \hrule height 0.4pt
+    \vskip 8\p@
+    \unvbox\t@abstract                  % print abstract, if any
+    \unvbox\t@keyword                   % Keyword abstract, if any
+    \vskip 10\p@
+    \hrule height 0.4pt
+  \fi                                   % FI
+  \dedicated@fmt                        % print dedication
+  \vskip 18\p@                          % Vertical space below frontmatter
+  \fi                                   % FI
+  \close@fm                             % Close front matter material.
+   \output@glob@notes                   % Put notes at bottom of 1st page
+  \global\c@footnote=\c@sv@footnote     % restore footnote number
+  \global\@prefacefalse
+  \global\leftskip\z@                   % Restore the normal values of
+  \global\@rightskip\z@                 % \leftskip,
+  \global\rightskip\@rightskip          % \rightskip and
+  \global\mathsurround\sv@mathsurround  % \mathsurround.
+  \let\title\relax       \let\author\relax
+  \let\collab\relax      \let\address\relax
+  \let\frontmatter\relax \let\endfrontmatter\relax
+  \let\@maketitle\relax  \let\@@maketitle\relax
+  \normal@text}
+\let\maketitle\relax
+\newdimen\t@xtheight
+\t@xtheight\textheight \advance\t@xtheight-\splittopskip
+\def\open@fm{\global\setbox\fm@box=\vbox\bgroup
+  \hsize=\textwidth                         % Front matter is page-wide
+  \centering                                % and centered
+  \sv@hyphenpenalty\hyphenpenalty           % (save \hyphenpenalty)
+  \hyphenpenalty\@M}                        % and not hyphenated
+\def\close@fm{\egroup                       % close \vbox (\fm@box)
+  \fm@size=\dp\fm@box \advance\fm@size by \ht\fm@box
+  \@whiledim\fm@size>\t@xtheight \do{%
+    \global\setbox\@tempboxa=\vsplit\fm@box to \t@xtheight
+    \unvbox\@tempboxa \newpage
+    \fm@size=\dp\fm@box \advance\fm@size by \ht\fm@box}
+  \if@TwoColumn
+    \emergencystretch=1pc \twocolumn[\unvbox\fm@box]
+  \else
+    \unvbox\fm@box
+  \fi}
+\def\output@glob@notes{\bgroup
+  \the\t@glob@notes
+  \egroup}
+\def\justify@off{\let\\=\@normalcr
+  \leftskip\z@ \@rightskip\@flushglue \rightskip\@rightskip}
+\def\justify@on{\let\\=\@normalcr
+  \leftskip\z@ \@rightskip\z@ \rightskip\@rightskip}
+\def\normal@text{\global\let\\=\@normalcr
+  \global\leftskip\z@ \global\@rightskip\z@ \global\rightskip\@rightskip
+  \global\parfillskip\@flushglue}
+\def\@writecount{\write\@mainaux{\string\global
+  \string\@namedef{n@author@}{\the\n@author}}%
+  \write\@mainaux{\string\global\string
+  \@namedef{n@collab@}{\the\n@collab}}}
+\def\title#1{%
+  \beg@elem
+  \title@note@fmt                      % formatting instruction
+  \add@tok\t@glob@notes                % for \thanks commands
+    {\title@note@fmt}%
+  \proc@elem{title}{#1}%
+  \def\title@notes{\the\t@loc@notes}%  % store the notes of the title,
+  \title@fmt{\@title}{\title@notes}%   % print the title
+  \ignorespaces}
+\def\subtitle#1{%
+  \beg@elem
+  \proc@elem{subtitle}{#1}%
+  \def\title@notes{\the\t@loc@notes}%     % store the notes of the title,
+  \subtitle@fmt{\@subtitle}{\title@notes} % print the title
+  \ignorespaces}
+\newdimen \@logoheight \@logoheight 5pc
+\def\@Lhook{\vrule \@height \@logoheight \@width \z@ \vrule \@height 10\p@
+\@width 0.2\p@ \vrule \@height 0.2\p@ \@width 10pt}
+\def\@Rhook{\vrule \@height 0.2\p@ \@width 10\p@ \vrule \@height 10\p@
+\@width 0.2\p@ \vrule \@height \@logoheight \@width \z@}
+\def\title@fmt#1#2{%
+\@ifundefined{@runtitle}{\gdef\@runtitle{#1}}{}%
+ \vspace*{16pt}                         % Vertical space above title
+  {\LARGE #1\,\hbox{$^{#2}$}\par}%
+ \vskip 24\p@                           % Vertical space below title
+  }
+\def\subtitle@fmt#1#2{%                 % No vertical space above sub-title
+  {\@titlesize #1\,\hbox{$^{#2}$}}\par}
+\def\title@note@fmt{\def\thefootnote{\fnstar{footnote}}}
+\def\author{\@ifnextchar[{\author@optarg}{\author@optarg[]}}
+\def\author@optarg[#1]#2{\stepcounter{author}%
+  \beg@elem
+  \@for\@tempa:=#1\do{\expandafter\add@thanksref\expandafter{\@tempa}}%
+  \report@elt{author}\proc@elem{author}{#2}%
+  \author@fmt{\the\c@author}{\the\t@loc@notes}{\@author}} % removed by SP
+\ignorespaces
+\def\author@fmt#1#2#3{\@newelemtrue
+  \if@firstauthor
+  \first@author \global\@firstauthorfalse \fi
+  \ifnum\prev@elem=\e@author \global\@newelemfalse \fi
+  \if@newelem \author@fmt@init \fi
+  \edef\@tempb{#2}\ifx\@tempb\@empty
+    \hbox{{\author@font #3}}\else
+    \hbox{{\author@font #3}\,$^{\mathrm{#2}}$}%
+  \fi}
+\def\first@author{\author@note@fmt  % re-define \thefootnote as
+                                    % appropriate for author/address
+  \add@tok\t@glob@notes
+    {\author@note@fmt\@corresp@note}}%
+\def\author@fmt@init{%
+  \par
+  \vskip 8\p@ \@plus 4\p@ \@minus 2\p@
+  \@authorsize
+  \leavevmode}                        % Vertical space above author list
+ \def\and{\unskip~and~}
+\def\collab{\@ifstar{\collab@arg}{\collab@arg}}
+\let\collaboration=\collab
+\def\collab@arg#1{\stepcounter{collab}%
+  \if@firstauthor \first@collab \global\@firstauthorfalse \fi
+  \beg@elem
+  \proc@elem{collab}{#1}%
+  \collab@fmt{\the\c@collab}{\the\t@loc@notes}{\@collab}%
+  \ignorespaces}
+\def\collab@fmt#1#2#3{\@newelemtrue
+  \ifnum\prev@elem=\e@collab \global\@newelemfalse \fi
+  \if@newelem \collab@fmt@init \fi
+  \par                                 % Start new paragraph
+  {\large #3\,$^{\mathrm{#2}}$}}
+\def\first@collab{
+  \collab@note@fmt                     % re-define \thefootnote as
+  \add@tok\t@glob@notes                % appropriate for collab/address
+    {\collab@note@fmt}}%
+\def\collab@fmt@init{\vskip 1em}       % Vertical space above list
+\def\author@note@fmt{\setcounter{footnote}{0}%
+  \def\thefootnote{\xarabic{footnote}}}
+\let\collab@note@fmt=\author@note@fmt
+\def\xarabic#1{%
+\expandafter\expandafter\expandafter\ifnum\expandafter\the\@nameuse{c@#1}<0
+  *\else\arabic{#1} \fi}
+\def\address{\@ifstar{\address@star}%
+  {\@ifnextchar[{\address@optarg}{\address@noptarg}}}
+\def\address@optarg[#1]#2{\refstepcounter{address}%
+  \beg@elem
+  \report@elt{address}\proc@elem{address}{#2}%
+  \address@fmt{\the\c@address}{\the\t@loc@notes}{\@address}\label{#1}%
+  \ignorespaces}
+\def\address@noptarg#1{\refstepcounter{address}%
+  \beg@elem
+  \proc@elem{address}{#1}%
+  \address@fmt{\z@}{\the\t@loc@notes}{\@address}%
+  \ignorespaces}
+\def\address@star#1{%
+  \beg@elem
+  \proc@elem{address}{#1}%
+  \address@fmt{\m@ne}{\the\t@loc@notes}{\@address}%
+  \ignorespaces}
+\def\theaddress{\alph{address}}
+\def\address@fmt#1#2#3{\@newelemtrue
+  \ifnum\prev@elem=\e@address \@newelemfalse \fi
+  \if@newelem \address@fmt@init \fi
+  \noindent \bgroup \@addressstyle
+  \ifnum#1=\z@
+    #3\,$^{\mathrm{#2}}$\space%
+  \else
+    \ifnum#1=\m@ne
+      $^{\phantom{\mathrm{\theaddress}}}$\space #3\,$^{\mathrm{#2}}$%
+    \else
+      $^{\mathrm{\theaddress}}$\space #3\,$^{\mathrm{#2}}$%
+    \fi
+  \fi
+  \par \egroup}
+\def\address@fmt@init{%
+  \par                                % Start new paragraph
+   \vskip 6\p@ \@plus 3\p@ \@minus 1.5pt}
+\def\abstract{\@ifnextchar[{\@abstract}{\@abstract[]}}
+% \def\@abstract[#1]{%
+%   \global\@hasabstracttrue
+%   \hyphenpenalty\sv@hyphenpenalty     % restore \hyphenpenalty
+%   \global\setbox\t@abstract=\vbox\bgroup
+%    \small
+%    \hbox to \textwidth\bgroup\hfill\begin{minipage}{.8\textwidth}
+%  \abstractname
+%   \ignorespaces}
+%  \def\endabstract{\end{minipage}\hfill\egroup\egroup}
+\def\@abstract[#1]{%
+  \global\@hasabstracttrue
+  \hyphenpenalty\sv@hyphenpenalty
+  \global\setbox\t@abstract=\vbox\bgroup
+  \leftskip\z@%
+  \@rightskip\z@ \rightskip\@rightskip \parfillskip\@flushglue
+  \small
+  \parindent 1em
+  \noindent {\bf\abstractname}
+  \par\noindent %\vskip 0.5\@bls Changed 23-2-95 by MWM
+  \ignorespaces}
+\def\endabstract{\par \egroup}
+\def\keyword{%
+  \global\@hasabstracttrue             % Implies rules are to be printed
+  \hyphenpenalty\sv@hyphenpenalty      % restore \hyphenpenalty
+  \def\sep{\unskip, }                  % separator for multiple keywords
+  \def\MSC{\par\leavevmode\hbox {\it 1991 MSC:\ }}%
+  \def\PACS{\par\leavevmode\hbox {\it PACS:\ }}%
+  \global\setbox\t@keyword=\vbox\bgroup
+   \hbox to \textwidth\bgroup\hfill\begin{minipage}{.8\textwidth}
+  \@keywordsize
+  \parskip\z@
+  \vskip 10\p@ \@plus 2\p@ \@minus 2\p@       % One line of space above keywords.
+  \noindent \@keywordheading
+  \justify@off                         % Keywords are not justified.
+  \ignorespaces}
+ \def\endkeyword{\end{minipage}\hfill\egroup\egroup}
+\def\runtitle#1{\gdef\@runtitle{#1}}
+\def\runauthor#1{\gdef\@runauthor{#1}} \def\@runauthor{}
+\def\journal#1{\gdef\@journal{#1}}
+\def\volume#1{\gdef\@volume{#1}}       \def\@volume{0}
+\def\issue#1{\gdef\@issue{#1}}         \def\@issue{0}
+\newcount\@pubyear
+\newcount\@copyear
+\@pubyear=\number\year
+\@copyear\@pubyear \advance\@copyear-1900
+\def\pubyear#1{\global\@pubyear#1
+  \global\@copyear\@pubyear \global\advance\@copyear-1900
+  \ignorespaces}
+\def\firstpage#1{\def\@tempa{#1}\ifx\@tempa\@empty\else
+  \gdef\@firstpage{#1}%
+  \global\c@page=#1 \ignorespaces\fi}
+\def\@firstpage{1}
+\def\@lastpage{\@ifundefined{r@LastPage}{0}{\pageref{LastPage}}}
+\def\lastpage#1{\def\@tempa{#1}\ifx\@tempa\@empty\else
+  \gdef\@lastpage{#1}\ignorespaces\fi
+  }
+\AtEndDocument{%
+   \clearpage
+   \addtocounter{page}{-1}%
+   \immediate\write\@auxout{\string
+   \newlabel{LastPage}{{}{\thepage}{\relax }{}{}}}%
+   \addtocounter{page}{1}%
+}
+\def\date#1{\gdef\@date{#1}}                  
+\def\@date{\today}
+\def\aid#1{}
+\def\ssdi#1#2{}
+\def\received#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@received{#1}\fi}
+  \def\@received{\relax}
+\def\revised#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@revised{#1}\fi}
+  \def\@revised{\relax}
+\def\accepted#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@accepted{#1}\fi}
+  \def\@accepted{\relax}
+\def\communicated#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@communicated{#1}\fi}
+  \def\@communicated{\relax}
+\def\dedicated#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@dedicated{#1}\fi}
+  \def\@dedicated{\relax}
+\def\presented#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@presented{#1}\fi}
+  \def\@presented{\relax}
+\def\articletype#1{\gdef\@articletype{#1}}
+  \@ifundefined{@articletype}{\def\@articletype{}}{}
+\def\received@prefix{Received~}
+\def\revised@prefix{; revised~}
+\def\accepted@prefix{; accepted~}
+\def\communicated@prefix{; communicated~by~}
+\def\history@prefix{}
+\def\received@postfix{}
+\def\revised@postfix{}
+\def\accepted@postfix{}
+\def\communicated@postfix{}
+\def\history@postfix{}
+\def\empty@data{\relax}
+\def\history@fmt{%
+  \bgroup
+  \@historysize
+  \vskip 6\p@ \@plus 2\p@ \@minus 1\p@      % Vertical space above history
+  \ifx\@received\empty@data \else           % If there is no \received, do not print anything
+    \leavevmode
+    \history@prefix
+    \received@prefix\@received \received@postfix%
+    \ifx\@revised\empty@data \else
+      \revised@prefix\@revised \revised@postfix%
+    \fi
+    \ifx\@accepted\empty@data \else
+      \accepted@prefix\@accepted \accepted@postfix%
+    \fi
+    \ifx\@communicated\empty@data \else
+      \communicated@prefix\@communicated \communicated@postfix%
+    \fi
+    \history@postfix
+  \fi
+  \par \egroup}
+\def\dedicated@fmt{%
+  \ifx\@dedicated\empty@data \else
+    \vskip 4\p@ \@plus 3\p@
+    \normalsize\it\centering \@dedicated
+    \fi}
+\def\@ialph#1{\ifcase#1\or \or \or \or \or e\or f\or g\or h\or i\or j\or
+  k\or \ell\or m\or n\or o\or p\or q\or r\or s\or t\or u\or v\or w\or x\or
+  y\or z\or aa\or ab\or ac\or ad\or ae\or af\or ag\or ah\or ai\or aj\or
+  ak\or a\ell\or am\or an\or ao\or ap\or aq\or ar\or as\or at\or au\or av\or
+  aw\or ay\or az\or ba\or bb\or bc\or bd\or be\or bf\or bg\or bh\or bi\or
+  bj\or bk\or b\ell\or bm\or bn\or bo\or bp\or bq\or br\or bs\or bt\or
+  bu\or bw\or bx\or by\or bz\or ca\or cb\or cc\or cd\or ce\or cf\or cg\or
+  ch\or ci\or cj\or ck\or c\ell\or cm\or cn\or co\or cp\or cq\or cr\or
+  cs\or ct\or cu\or cw\or cx\or cy\or cz\else\@ctrerr\fi}
+\def\fnstar#1{\@fnstar{\@nameuse{c@#1}}}
+\def\@fnstar#1{\ifcase#1\or
+    \hbox{$\star$}\or
+    \hbox{$\star\star$}\or
+    \hbox{$\star\star\star$}\or
+    \hbox{$\star\star\star\star$}\or
+    \hbox{$\star\star\star\star\star$}\or
+    \hbox{$\star\star\star\star\star\star$}
+  \else
+    \@ctrerr
+  \fi
+  \relax}
+\mark{{}{}}   % Initializes TeX's marks
+\def\rightheadline{}
+\def\leftheadline{}
+\def\annum{\the\@pubyear}
+\def\firstheadline{}
+\def\firstfootline{}
+\def\ps@plain{\let\@mkboth\@gobbletwo
+ \def\@oddhead{\rightheadline}%
+ \def\@evenhead{\leftheadline}%
+ \def\@oddfoot{\hfil {\rmfamily\thepage} \hfil}%
+ \let\@evenfoot\@oddfoot}
+\def\@copyright{\the\@copyear/ $\copyright$\ \the\@pubyear\
+  Elsevier Science \@company{} All  rights reserved}
+\def\@jou@vol@pag{\@journal\ \@volume\ (\the\@pubyear)\ }
+\def\sectionmark#1{}
+\def\subsectionmark#1{}
+\let\@j@v@p\@jou@vol@pag    % long journal title appears in reprint line
+\let\@@j@v@p\@jou@vol@pag   % long journal title appears in running headline
+\def\sectionmark#1{}
+\def\subsectionmark#1{}
+\def\ps@copyright{\let\@mkboth\@gobbletwo
+  \def\@oddhead{\ifnum\value{page}=1\firstheadline
+              \else\rightheadline\fi}
+        \def\@evenhead{\ifnum\value{page}=1\firstheadline
+              \else\leftheadline\fi}
+  \def\@oddfoot{\small\slshape
+    \def\@tempa{0}
+    \ifx\@volume\@tempa
+      Preprint submitted to \@journal\hfil\@date\/%
+    \else
+      \firstfootline\fi}%
+  \let\@evenfoot\@oddfoot
+}
+\let\ps@headings\ps@plain
+\def\today{\number\day\space\ifcase\month\or
+  January\or February\or March\or April\or May\or June\or
+  July\or August\or September\or October\or November\or December\fi
+  \space\number\year}
+\def\nuc#1#2{\relax\ifmmode{}^{#1}{\protect\text{#2}}\else${}^{#1}$#2\fi}
+\def\itnuc#1#2{\setbox\@tempboxa=\hbox{\scriptsize\it #1}
+  \def\@tempa{{}^{\box\@tempboxa}\!\protect\text{\it #2}}\relax
+  \ifmmode \@tempa \else $\@tempa$\fi}
+\let\old@vec\vec % save old definition of \vec
+\def\pol#1{\old@vec{#1}}
+\def\@bfvec#1{\boldsymbol{#1}}
+\def\@pmbfvec#1{\pmb{#1}}
+\def\undo@AMS{\global\let\vec\@bfvec}
+\def\half{{\textstyle {1\over2}}}
+\def\threehalf{{\textstyle {3\over2}}}
+\def\quart{{\textstyle {1\over4}}}
+\def\d{\,\mathrm{d}}
+\def\e{\mathop{\mathrm{e}}\nolimits}
+\def\int{\intop}
+\def\oint{\ointop}
+\newbox\slashbox \setbox\slashbox=\hbox{$/$}
+\newbox\Slashbox \setbox\Slashbox=\hbox{\large$/$}
+\def\pFMslash#1{\setbox\@tempboxa=\hbox{$#1$}
+  \@tempdima=0.5\wd\slashbox \advance\@tempdima 0.5\wd\@tempboxa
+  \copy\slashbox \kern-\@tempdima \box\@tempboxa}
+\def\pFMSlash#1{\setbox\@tempboxa=\hbox{$#1$}
+  \@tempdima=0.5\wd\Slashbox \advance\@tempdima 0.5\wd\@tempboxa
+  \copy\Slashbox \kern-\@tempdima \box\@tempboxa}
+\def\FMslash{\protect\pFMslash}
+\def\FMSlash{\protect\pFMSlash}
+\mathchardef\Gamma="0000
+\mathchardef\Delta="0001
+\mathchardef\Theta="0002
+\mathchardef\Lambda="0003
+\mathchardef\Xi="0004
+\mathchardef\Pi="0005
+\mathchardef\Sigma="0006
+\mathchardef\Upsilon="0007
+\mathchardef\Phi="0008
+\mathchardef\Psi="0009
+\mathchardef\Omega="000A
+\mathchardef\varGamma="0100
+\mathchardef\varDelta="0101
+\mathchardef\varTheta="0102
+\mathchardef\varLambda="0103
+\mathchardef\varXi="0104
+\mathchardef\varPi="0105
+\mathchardef\varSigma="0106
+\mathchardef\varUpsilon="0107
+\mathchardef\varPhi="0108
+\mathchardef\varPsi="0109
+\mathchardef\varOmega="010A
+  \def\Cset{\Bbb{C}}
+  \def\Hset{\Bbb{H}}
+  \def\Nset{\Bbb{N}}
+  \def\Qset{\Bbb{Q}}
+  \def\Rset{\Bbb{R}}
+  \def\Zset{\Bbb{Z}}
+\if@TwoColumn
+  \adjdemerits=100
+  \linepenalty=100
+  \doublehyphendemerits=5000        % experimental (1993-12-14)
+  \emergencystretch=1.6pc
+  \spaceskip=0.3em \@plus 0.17em \@minus 0.12em
+\fi
+\ps@headings                                % 'headings' page style
+\pagenumbering{arabic}                      % Arabic page numbers
+\def\thepage{\@pagenumprefix\arabic{page}}  % preceded by \@pagenumprefix
+\InputIfFileExists{\@shortjid.cfg}{}{}
+\endinput
+%%
+%% End of file `entcs.cls'.

+ tools/interp/HaskellWorkshop/entcs.sty view
@@ -0,0 +1,924 @@+% Document-style for Electronic Notes in Theoretical Computer Science
+% Adopted from document-style for journals published by Elsevier Science. 
+% To be used with LaTeX version 2.09 of 14 January 1992 (or later) 
+%
+% Version: 1.10
+% Date:    13 February 1998
+%
+% Copyright (C) 1998. All rights reserved.
+%
+% IMPORTANT NOTICE:
+%
+% You are not allowed to change this file. You may however copy this file 
+% to a file with a different name and then change the copy. 
+% 
+% You are NOT ALLOWED to distribute this file alone. You are NOT ALLOWED 
+% to take money for the distribution or use of this file (or a changed 
+% version) except for a nominal charge for copying etc. 
+% 
+% You are allowed to distribute this file under the condition that it is 
+% distributed together with all files mentioned in readme.els. 
+% 
+% If you receive only some of these files from someone, complain! 
+% 
+%
+\def\esp@fileversion{2.12}
+\def\esp@filedate{2 June 1994}
+\def\@shortjnl{\@nil}
+\def\@@shortjnl{\@nil}
+\def\@journal{Elsevier Science}
+\def\@issn{0}
+\def\@jid{ENTCS} \def\@shortjid{encs}
+\typeout{Electronic Notes in Theoretcial Computer Science document style
+\esp@fileversion \space\space <\esp@filedate>}
+\def\partname{Part}
+\def\contentsname{Contents}
+\def\listfigurename{List of Figures}
+\def\listtablename{List of Tables}
+\def\refname{References}
+\def\indexname{Index}
+\def\figurename{Fig.}
+\def\tablename{Table}
+\def\abstractname{Abstract}
+\def\@ptsize{2}
+\def\ds@twoside{\@twosidetrue
+                \@mparswitchtrue}
+\def\ds@oneside{\@twosidefalse
+                \@mparswitchfalse}
+\@twocolumnfalse
+\newif\if@TwoColumn
+\def\ds@onecolumn{\@twocolumnfalse
+                  \@TwoColumnfalse}
+\def\ds@twocolumn{\@twocolumnfalse
+                  \@TwoColumntrue}
+\@TwoColumnfalse
+\@twosidefalse
+\@namedef{ds@10pt}{}
+\@namedef{ds@11pt}{}
+\def\ds@fleqn{}
+\def\@pagenumprefix{}
+\newif\if@draft \@draftfalse
+\def\query{}
+\def\ds@draft{%
+\@drafttrue
+\def\query{\marginpar{???}}%
+\overfullrule 5pt}
+\let\snm\relax \let\cty\relax \let\cny\relax
+\newif\if@seceqn
+\@seceqnfalse
+\def\ds@seceqn{\@seceqntrue}
+\newif\if@secthm
+\@secthmfalse
+\def\ds@secthm{\@secthmtrue}
+\newif\if@nameyear
+\@nameyearfalse
+\def\ds@nameyear{\@nameyeartrue}
+\newif\if@nfss
+\@ifundefined{selectfont}{\@nfssfalse}{\@nfsstrue}
+\@options
+\input entcs12.sty\relax
+\def\links@label#1{{#1}\hss}
+\def\rechts@label#1{\hss\llap{#1}}
+\def\thick@label#1{\hspace\labelsep #1}
+\newcount\@maxlistdepth \@maxlistdepth=2
+\def\labelitemi{\lower.5ex\hbox{$^\bullet$}}%originally -- changed 15-2-95
+\def\labelitemii{$\cdot$}%originally \cdot changed 15-2-95
+\def\labelenumi{(\theenumi)}        \def\theenumi{\roman{enumi}}
+\def\labelenumii{(\theenumii)}      \def\theenumii{\alph{enumii}}
+\def\enumerate{%
+  \ifnum \@enumdepth >\@maxlistdepth
+    \@toodeep
+  \else
+    \advance\@enumdepth \@ne
+    \edef\@enumctr{enum\romannumeral\the\@enumdepth}%
+    \list{\csname label\@enumctr\endcsname}%
+       {\usecounter{\@enumctr}
+       \let\makelabel=\rechts@label}
+  \fi}
+\def\itemize{%
+  \ifnum \@itemdepth >\@maxlistdepth
+    \@toodeep
+  \else
+    \advance\@itemdepth \@ne
+    \edef\@itemitem{labelitem\romannumeral\the\@itemdepth}%
+    \setleftmargin{i}{--}%
+    \setleftmargin{ii}{$\cdot$}%
+    \list{\csname\@itemitem\endcsname}%
+       {\let\makelabel\rechts@label}
+  \fi}
+\def\verse{\let\\=\@centercr
+  \list{}{\itemsep\z@
+  \itemindent \z@
+  \listparindent\z@
+  \rightmargin 1em
+  \leftmargin \rightmargin}\item[]}
+\let\endverse\endlist
+\def\quotation{\list{}{\itemindent\z@
+  \leftmargin 1em \rightmargin \z@
+  \parsep 0pt plus 1pt}\item[]}
+\let\endquotation=\endlist
+\def\quote{\list{}{\itemindent\z@
+  \leftmargin 1em \rightmargin\z@}\item[]}
+\let\endquote=\endlist
+\def\descriptionlabel#1{\hspace\labelsep \bf #1}
+\def\description{\list{}{\labelwidth\z@
+  \leftmargin 1em \itemindent-\leftmargin
+  \let\makelabel\descriptionlabel}}
+\let\enddescription\endlist
+\def\operatorname#1{\mathop{\mathrm{#1}}\nolimits}
+\def\lefteqn#1{\hbox to\z@{$\displaystyle {#1}$\hss}}
+\newskip\eqnbaselineskip
+\jot=2pt
+\newskip\eqnlineskip
+\eqnbaselineskip=14pt  \eqnlineskip=2pt
+\newdimen\mathindent
+\if@TwoColumn
+  \mathindent 0em
+\else
+  \mathindent 2em
+\fi
+\def\[{\relax\ifmmode\@badmath
+  \else%
+  \@beginparpenalty\predisplaypenalty
+  \@endparpenalty\postdisplaypenalty
+  \begin{trivlist}\@topsep \eqntopsep
+   \@topsepadd \eqntopsep
+  \item[]\leavevmode
+  \hbox to\linewidth\bgroup$ \displaystyle
+  \hskip\mathindent\bgroup\fi}
+\def\]{\relax\ifmmode \egroup $\hfil \egroup
+  \end{trivlist}%
+  \else \@badmath \fi}
+\def\equation{\@beginparpenalty\predisplaypenalty
+  \@endparpenalty\postdisplaypenalty
+\refstepcounter{equation}\trivlist
+   \@topsep \eqntopsep
+   \@topsepadd \eqntopsep
+   \item[]\leavevmode
+  \hbox to\linewidth\bgroup $ \displaystyle \hskip\mathindent\bgroup}
+\def\endequation{\egroup$\hfil \displaywidth\linewidth
+  \@eqnnum\egroup \endtrivlist}
+\def\eqnarray{%
+  \par
+  \noindent
+  \baselineskip\eqnbaselineskip\lineskip\eqnlineskip
+  \lineskiplimit\eqnlineskip
+  \stepcounter{equation}%
+  \let\@currentlabel=\theequation
+  \global\@eqnswtrue
+  \global\@eqcnt\z@ \tabskip\mathindent \let\\=\@eqncr
+  \abovedisplayskip\eqntopsep\ifvmode\advance\abovedisplayskip\partopsep\fi
+  \belowdisplayskip\abovedisplayskip
+  \belowdisplayshortskip\abovedisplayskip
+  \abovedisplayshortskip\abovedisplayskip
+  $$\halign to \displaywidth\bgroup\@eqnsel
+    \pre@coli$\displaystyle\tabskip\z@{##}$\post@coli
+    &\global\@eqcnt\@ne
+    \pre@colii$\displaystyle{##}$\post@colii
+    &\global\@eqcnt\tw@
+    \pre@coliii $\displaystyle\tabskip\z@{##}$\post@coliii
+    \tabskip\@centering&\llap{##}\tabskip\z@\cr}
+\def\endeqnarray{\@@eqncr\egroup
+ \global\advance\c@equation\m@ne$$\global\@ignoretrue }
+\def\pre@coli{\hskip\@centering}              \def\post@coli{}
+\def\pre@colii{\hskip 2\eqnarraycolsep \hfil} \def\post@colii{\hfil}
+\def\pre@coliii{\hskip 2\eqnarraycolsep}      \def\post@coliii{\hfil}
+\arraycolsep 2pt
+\tabcolsep 6pt
+\def\arraystretch{1.5}
+\arrayrulewidth 0.4pt
+\doublerulesep 2pt
+\tabbingsep \labelsep
+\skip\@mpfootins = 6pt plus 2pt
+\fboxsep = 7pt
+\fboxrule = 0.4pt
+\newcounter{part}
+\newcounter{section}
+\newcounter{subsection}[section]
+\newcounter{subsubsection}[subsection]
+\newcounter{paragraph}[subsubsection]
+\newcounter{subparagraph}[paragraph]
+\def\thepart {\Roman{part}}
+\if@seceqn
+ \@addtoreset{equation}{section}
+ \@addtoreset{table}{section}
+ \@addtoreset{figure}{section}
+ \def\theequation{\arabic{section}.\arabic{equation}}
+ \def\thetable{\thesection.\arabic{table}}
+ \def\thefigure{\thesection.\arabic{figure}}
+\else
+ \def\theequation{\arabic{equation}}
+ \def\thefigure{\arabic{figure}}
+ \def\thetable{\arabic{table}}
+\fi
+\def\thesection      {\arabic{section}}
+\def\thesubsection   {\thesection.\arabic{subsection}}
+\def\thesubsubsection{\thesubsection.\arabic{subsubsection}}
+\def\theparagraph    {\thesubsubsection.\arabic{paragraph}}
+\def\thesubparagraph {\theparagraph.\arabic{subparagraph}}
+\def\qed{\relax\ifmmode\hfill \Box\else\unskip\nobreak\hfill $\Box$\fi}
+\let\proof@headerfont\bf
+\ifx\normalshape\undefined
+  \gdef\normalshape{\rm}
+\fi
+\newenvironment{pf}%
+  {\par\addvspace{.6pc plus .2pc minus .1pc}
+%\addvspace{\@bls plus 0.5\@bls minus 0.1\@bls} Changed 20-2-95 MWM
+   \noindent
+   {\bf\proofname}\enspace\ignorespaces}%
+  {\par\addvspace{.6pc plus .2pc minus .1pc}}
+%\par\addvspace{\@bls plus 0.5\@bls minus 0.1\@bls}} Changed 20-2-95 MWM
+\def\proofname{Proof.}
+\@namedef{pf*}#1{\par\begingroup\def\proofname{#1}\pf\endgroup\ignorespaces}
+\expandafter\let\csname endpf*\endcsname=\endpf
+\newtheorem{thm}{Theorem}[section]
+\newtheorem{cor}[thm]{Corollary}
+\newtheorem{lem}[thm]{Lemma}
+\newtheorem{claim}[thm]{Claim}
+\newtheorem{axiom}[thm]{Axiom}
+\newtheorem{conj}[thm]{Conjecture}
+\newtheorem{fact}[thm]{Fact}
+\newtheorem{hypo}[thm]{Hypothesis}
+\newtheorem{assum}[thm]{Assumption}
+\newtheorem{prop}[thm]{Proposition}
+\newtheorem{crit}[thm]{Criterion}
+\newtheorem{defn}[thm]{Definition}
+\newtheorem{exmp}[thm]{Example}
+\newtheorem{rem}[thm]{Remark}
+\newtheorem{prob}[thm]{Problem}
+\newtheorem{prin}[thm]{Principle}
+\newtheorem{alg}{Algorithm}
+\long\def\@makealgocaption#1#2{\vskip 2ex \small
+  \hbox to \hsize{\parbox[t]{\hsize}{{\bf #1.} #2}}}
+\newcounter{algorithm}
+\def\thealgorithm{\@arabic\c@algorithm}
+\def\fps@algorithm{tbp}
+\def\ftype@algorithm{4}
+\def\ext@algorithm{lof}
+\def\fnum@algorithm{Algorithm \thealgorithm}
+\def\algorithm{\let\@makecaption\@makealgocaption\@float{algorithm}}
+\let\endalgorithm\end@float
+\newtheorem{note}{Note}
+\newtheorem{summ}{Summary}
+\newtheorem{case}{Case}
+\def\@pnumwidth{2.55em}
+\def\@tocrmarg{2.55em plus 5em}
+\def\@dotsep{-2.5}
+\setcounter{tocdepth}{2}
+\def\tableofcontents{%
+  \section*{\contentsname}%
+  \@starttoc{toc}}
+\def\l@section{\@dottedtocline{1}{0.0em}{1.40em}}
+\def\l@subsection{\@dottedtocline{2}{1.40em}{2.24em}}
+\def\l@subsubsection{\@dottedtocline{3}{2.24em}{3.09em}}
+\def\thebibliography{%
+  \@startsection{section}{1}{\z@}{20pt plus 8pt minus 4pt}
+  {\@bls}{\large\bf}*{\refname}%
+  \addcontentsline{toc}{section}{\refname}%
+  \@thebibliography}
+\let\endthebibliography=\endlist
+\def\@thebibliography#1{\frenchspacing\small
+  \list{\@biblabel{\arabic{enumiv}}}{\settowidth\labelwidth{\@biblabel{#1}}
+  \if@nameyear
+    \labelwidth\z@ \labelsep\z@ \leftmargin\parindent
+    \itemindent-\parindent
+  \else
+    \labelsep 3pt \itemindent\z@
+    \leftmargin\labelwidth \advance\leftmargin\labelsep
+\fi
+    \itemsep 0.3\@bls plus 0.1\@bls minus 0.1\@bls
+    \usecounter{enumiv}\let\p@enumiv\@empty
+    \def\theenumiv{\arabic{enumiv}}}%
+    \def\newblock{\hskip 0.11em plus 0.33em minus -0.07em}
+    \tolerance\@M \hyphenpenalty\@M \hbadness5000 \sfcode`\.=1000\relax}
+\if@nameyear
+  \def\@biblabel#1{}
+\else
+  \def\@biblabel#1{\hskip \z@ plus 1filll[#1]}
+\fi
+\newcount\@tempcntc
+\def\@citex[#1]#2{\if@filesw\immediate\write\@auxout{\string\citation{#2}}\fi
+ \@tempcnta\z@\@tempcntb\m@ne\def\@citea{}\@cite{\@for\@citeb:=#2\do
+  {\@ifundefined
+   {b@\@citeb}{\@citeo\@tempcntb\m@ne\@citea\def\@citea{,}{\bf ?}\@warning
+   {Citation `\@citeb' on page \thepage \space undefined}}%
+  {\setbox\z@\hbox{\global\@tempcntc0\csname b@\@citeb\endcsname\relax}%
+   \ifnum\@tempcntc=\z@ \@citeo\@tempcntb\m@ne
+    \@citea\def\@citea{,}\hbox{\csname b@\@citeb\endcsname}%
+   \else
+    \advance\@tempcntb\@ne
+    \ifnum\@tempcntb=\@tempcntc
+    \else\advance\@tempcntb\m@ne\@citeo
+    \@tempcnta\@tempcntc\@tempcntb\@tempcntc\fi\fi}}\@citeo}{#1}}
+\def\@citeo{\ifnum\@tempcnta>\@tempcntb\else\@citea\def\@citea{,}%
+ \ifnum\@tempcnta=\@tempcntb\the\@tempcnta\else
+  {\advance\@tempcnta\@ne\ifnum\@tempcnta=\@tempcntb \else \def\@citea{--}\fi
+   \advance\@tempcnta\m@ne\the\@tempcnta\@citea\the\@tempcntb}\fi\fi}
+\@namedef{cv*}{\section*{Curriculum Vitae}\cv}
+\def\cv{\hangindent=7pc \hangafter=-12 \parskip\bigskipamount \small}
+\def\footnote{\@ifnextchar[{\@xfootnote}{\refstepcounter
+   {\@mpfn}\xdef\@thefnmark{\thempfn}\@footnotemark\@footnotetext}}
+\def\footnotemark{\@ifnextchar[{\@xfootnotemark
+    }{\refstepcounter{footnote}\xdef\@thefnmark{\thefootnote}\@footnotemark}}
+\def\footnoterule{\kern-3\p@
+  \hrule width 3pc
+  \kern 2.6\p@}
+\def\thempfootnote{\alph{mpfootnote}}
+\def\mpfootnotemark{%
+  \@ifnextchar[{\@xmpfootnotemark}{\stepcounter{mpfootnote}%
+  \begingroup
+    \let\protect\noexpand
+    \xdef\@thefnmark{\thempfootnote}%
+  \endgroup
+  \@footnotemark}}
+\def\@xmpfootnotemark[#1]{%
+  \begingroup
+    \c@mpfootnote #1\relax
+    \let\protect\noexpand
+    \xdef\@thefnmark{\thempfootnote}%
+  \endgroup
+  \@footnotemark}
+\def\@mpmakefnmark{\,\hbox{$^{\mathrm{\@thefnmark}}$}}
+\long\def\@mpmakefntext#1{\noindent
+                     \hbox{$^{\mathrm{\@thefnmark}}$} #1}
+\def\@iminipage[#1]#2{\leavevmode
+  \@pboxswfalse
+  \if #1b\vbox
+  \else \if #1t\vtop
+  \else \ifmmode \vcenter
+  \else \@pboxswtrue $\vcenter
+  \fi \fi \fi
+  \bgroup \hsize #2\textwidth\hsize \columnwidth\hsize
+  \@parboxrestore
+  \def\@mpfn{mpfootnote}\def\thempfn{\thempfootnote}\c@mpfootnote\z@
+  \let\@footnotetext\@mpfootnotetext
+  \let\@makefntext\@mpmakefntext
+  \let\@makefnmark\@mpmakefnmark
+  \let\@listdepth\@mplistdepth \@mplistdepth\z@
+  \@minipagerestore\global\@minipagetrue
+  \everypar{\global\@minipagefalse\everypar{}}}
+\def\fn@presym{}
+\long\def\@makefntext#1{\noindent\hbox to 1em
+  {\hfil$^{\fn@presym\mathrm{\@thefnmark}}$}\,#1}
+\def\@makefnmark{\,\hbox{$^{\fn@presym\mathrm{\@thefnmark}}$}\,}
+\setcounter{topnumber}{5}
+\def\topfraction{0.99}
+\def\textfraction{0.05}
+\def\floatpagefraction{0.9}
+\setcounter{bottomnumber}{5}
+\def\bottomfraction{0.99}
+\setcounter{totalnumber}{10}
+\def\dbltopfraction{0.99}
+\def\dblfloatpagefraction{0.8}
+\setcounter{dbltopnumber}{5}
+\newbox\@tempboxb
+\def\@maketablecaption#1#2{\medbreak
+  \hbox to \hsize{\parbox[t]{\hsize}{ \centerline{\small#1 \ #2}}}}
+\long\def\@makefigurecaption#1#2{\small
+  \vskip 8pt
+  \setbox\@tempboxa\hbox{#1. #2}
+  \ifdim \wd\@tempboxa >\hsize
+    \unhbox\@tempboxa\par
+  \else
+    \hbox to\hsize{\hfil\box\@tempboxa\hfil}%
+  \fi}
+\def\conttablecaption{\par \begingroup \@parboxrestore \normalsize
+  \@makecaption{\fnum@table\,---\,continued}{}\par
+  \vskip-1pc \endgroup}
+\def\contfigurecaption{\vskip-1pc \par \begingroup \@parboxrestore \normalsize
+  \@makecaption{\fnum@figure\,---\,continued}{}\par
+  \endgroup}
+\newcounter{figure}
+\def\thefigure{\@arabic\c@figure}
+\def\fps@figure{tbp}
+\def\ftype@figure{1}
+\def\ext@figure{lof}
+\def\fnum@figure{\figurename~\thefigure}
+\def\figure{\par\vspace{-\lastskip}
+        \addvspace{1pc plus .2pc minus .1pc}
+       \let\@makecaption\@makefigurecaption
+  \let\contcaption\contfigurecaption \@float{figure}}
+%\let\endfigure\end@float
+\def\endfigure{\addvspace{.2pc plus .2pc minus .1pc}\end@float}
+\@namedef{figure*}{\let\@makecaption\@makefigurecaption
+  \let\contcaption\contfigurecaption \@dblfloat{figure}}
+\@namedef{endfigure*}{\end@dblfloat}
+\newcounter{table}
+\def\thetable{\@arabic\c@table}
+\def\fps@table{tbp}
+\def\ftype@table{2}
+\def\ext@table{lot}
+\def\fnum@table{\tablename~\thetable}
+\def\table{\par\vspace{-\lastskip}
+        \addvspace{1pc plus .2pc minus .1pc}
+        \let\@makecaption\@maketablecaption \small
+  \let\footnoterule\relax
+  \let\contcaption\conttablecaption \@float{table}}
+%\let\endtable\end@float
+\def\endtable{\addvspace{.2pc plus .2pc minus .1pc}\end@float}
+\@namedef{table*}{\vspace{-\lastskip}\par
+        \addvspace{.6pc plus .2pc minus .1pc}
+       \let\@makecaption\@maketablecaption \small
+  \let\footnoterule\relax
+  \let\contcaption\conttablecaption \@dblfloat{table}}
+\@namedef{endtable*}{\end@dblfloat}
+\newtoks\t@glob@notes
+\newtoks\t@loc@notes
+\newcount\note@cnt
+\newcounter{author}
+\newcount\n@author
+\def\n@author@{}
+\newcounter{collab}
+\newcount\n@collab
+\def\n@collab@{}
+\newcounter{address}
+\newdimen\sv@mathsurround
+\newcount\sv@hyphenpenalty
+\newcount\prev@elem \prev@elem=0
+\newcount\cur@elem  \cur@elem=0
+\chardef\e@title=1
+\chardef\e@subtitle=1
+\chardef\e@author=2
+\chardef\e@collab=3
+\chardef\e@address=4
+\newif\if@newelem
+\newif\if@firstauthor
+\newif\if@preface
+\newif\if@hasabstract
+\newbox\fm@box
+\newdimen\fm@size
+\newbox\t@abstract
+\newbox\t@keyword
+\let\report@elt\@gobble
+\def\add@tok#1#2{\global#1\expandafter{\the#1#2}}
+\def\add@xtok#1#2{\begingroup
+  \no@harm
+  \xdef\@act{\global\noexpand#1{\the#1#2}}\@act
+\endgroup}
+\def\beg@elem{\global\t@loc@notes={}\global\note@cnt\z@}
+\def\@xnamedef#1{\expandafter\xdef\csname #1\endcsname}
+\def\no@harm{%
+  \let\\=\relax  \let\rm\relax
+  \let\ss=\relax \let\ae=\relax \let\oe=\relax
+  \let\AE=\relax \let\OE=\relax
+  \let\o=\relax  \let\O=\relax
+  \let\i=\relax  \let\j=\relax
+  \let\aa=\relax \let\AA=\relax
+  \let\l=\relax  \let\L=\relax
+  \let\d=\relax  \let\b=\relax \let\c=\relax
+  \let\bar=\relax
+  \def\protect{\noexpand\protect\noexpand}}
+\def\proc@elem#1#2{\begingroup
+    \no@harm
+    \let\thanksref\@gobble
+    \@xnamedef{@#1}{#2}%
+  \endgroup
+  \prev@elem=\cur@elem
+  \cur@elem=\csname e@#1\endcsname
+  \expandafter\elem@nothanksref#2\thanksref\relax}
+\def\elem@nothanksref#1\thanksref{\futurelet\@peektok\elem@thanksref}
+\def\elem@thanksref{\ifx\@peektok\relax
+  \else \expandafter\elem@morethanksref \fi}
+\def\elem@morethanksref#1{\add@thanksref{#1}\elem@nothanksref}
+\def\add@thanksref#1{\global\advance\note@cnt\@ne
+  \ifnum\note@cnt>\@ne \add@xtok\t@loc@notes{\note@sep}\fi
+  \add@tok\t@loc@notes{\ref{#1}}}
+\def\note@sep{,}
+\def\thanks{\@ifnextchar[{\@tempswatrue
+  \thanks@optarg}{\@tempswafalse\thanks@optarg[]}}
+\def\thanks@optarg[#1]#2{\refstepcounter{footnote}\if@tempswa
+  \label{#1}\else\relax\fi
+  \add@tok\t@glob@notes{\footnotetext}%
+  \add@xtok\t@glob@notes{[\the\c@footnote]}%
+  \add@tok\t@glob@notes{{#2}}}
+\def\frontmatter{\label{FirstPage}%
+  \let\@corresp@note\relax
+  \global\t@glob@notes={}\global\c@author\z@
+  \global\c@collab\z@ \global\c@address\z@
+  \sv@mathsurround\mathsurround \m@th
+  \global\n@author=0\n@author@\relax
+  \global\n@collab=0\n@collab@\relax
+  \global\advance\n@author\m@ne
+  \global\advance\n@collab\m@ne
+  \global\@firstauthortrue
+  \global\@hasabstractfalse
+  \global\@prefacefalse
+  \@ifundefined{RIfM@}{}{\undo@AMS}%
+  \parskip 4\p@
+  \open@fm \ignorespaces}
+\def\preface{\@prefacetrue}
+\def\endfrontmatter{\global\n@author=\c@author
+  \global\n@collab=\c@collab \@writecount
+  \global\@topnum\z@
+  \ifx\@firstpage\@lastpage
+    \gdef\@pagerange{\@pagenumprefix\@firstpage}
+  \else
+    \gdef\@pagerange{\@pagenumprefix\@firstpage--\@pagenumprefix\@lastpage}
+  \fi
+  \thispagestyle{copyright}%
+  \if@preface \else
+  \history@fmt
+  \newcount\c@sv@footnote
+  \global\c@sv@footnote=\c@footnote
+  \if@hasabstract
+    \vskip 24pt plus 6pt minus 3pt
+    \hrule height 0.4pt
+    \vskip 8pt
+    \unvbox\t@abstract
+    \unvbox\t@keyword
+    \vskip 10pt
+    \hrule height 0.4pt
+  \fi
+  \dedicated@fmt
+  \vskip 18pt
+  \fi
+  \close@fm
+  \output@glob@notes
+  \global\c@footnote=\c@sv@footnote
+  \global\@prefacefalse
+  \global\leftskip\z@
+  \global\@rightskip\z@
+  \global\rightskip\@rightskip
+  \global\mathsurround\sv@mathsurround
+  \let\title\relax       \let\author\relax
+  \let\collab\relax      \let\address\relax
+  \let\frontmatter\relax \let\endfrontmatter\relax
+  \let\@maketitle\relax  \let\@@maketitle\relax
+  \normal@text}
+\let\maketitle\relax
+\newdimen\t@xtheight
+\t@xtheight\textheight \advance\t@xtheight-\splittopskip
+\def\open@fm{\global\setbox\fm@box=\vbox\bgroup
+  \hsize=\textwidth
+  \centering
+  \sv@hyphenpenalty\hyphenpenalty
+  \hyphenpenalty\@M}
+\def\close@fm{\egroup
+  \fm@size=\dp\fm@box \advance\fm@size by \ht\fm@box
+  \@whiledim\fm@size>\t@xtheight \do{%
+    \global\setbox\@tempboxa=\vsplit\fm@box to \t@xtheight
+    \unvbox\@tempboxa \newpage
+    \fm@size=\dp\fm@box \advance\fm@size by \ht\fm@box}
+  \if@TwoColumn
+    \emergencystretch=1pc \twocolumn[\unvbox\fm@box]
+  \else
+    \unvbox\fm@box
+  \fi}
+\def\output@glob@notes{\bgroup
+  \the\t@glob@notes
+  \egroup}
+\def\justify@off{\let\\=\@normalcr
+  \leftskip\z@ \@rightskip\@flushglue \rightskip\@rightskip}
+\def\justify@on{\let\\=\@normalcr
+  \leftskip\z@ \@rightskip\z@ \rightskip\@rightskip}
+\def\normal@text{\global\let\\=\@normalcr
+  \global\leftskip\z@ \global\@rightskip\z@ \global\rightskip\@rightskip
+  \global\parfillskip\@flushglue}
+\def\@writecount{\write\@mainaux{\string\global
+  \string\@namedef{n@author@}{\the\n@author}}%
+  \write\@mainaux{\string\global\string
+  \@namedef{n@collab@}{\the\n@collab}}}
+\def\title{\@ifnextchar[{\@@title}{\@@title[]}}
+\def\@@title[#1]#2{%
+  \beg@elem
+  \title@note@fmt
+  \add@tok\t@glob@notes
+    {\title@note@fmt}%
+  \proc@elem{title}{#2}%
+  \def\title@notes{\the\t@loc@notes}%
+  \title@fmt{\@title}{\title@notes}%
+  \ignorespaces}
+\def\subtitle#1{%
+  \beg@elem
+  \proc@elem{subtitle}{#1}%
+  \def\title@notes{\the\t@loc@notes}%
+  \subtitle@fmt{\@subtitle}{\title@notes}%
+  \ignorespaces}
+\newdimen \@logoheight \@logoheight 5pc
+\def\@Lhook{\vrule height \@logoheight width 0pt \vrule height 10pt width 0.2pt \vrule height 0.2pt width 10pt}
+\def\@Rhook{\vrule height 0.2pt width 10pt \vrule height 10pt width 0.2pt \vrule height \@logoheight width 0pt}
+\def\title@fmt#1#2{%
+  \vspace*{16pt}
+  {\LARGE #1\,\hbox{$^{#2}$}\par}%
+  \vskip 24pt
+  }
+\def\subtitle@fmt#1#2{%
+  {\Large #1\,\hbox{$^{#2}$}}\par}
+\def\title@note@fmt{\def\thefootnote{\fnstar{footnote}}}
+\def\author{\@ifnextchar[{\author@optarg}{\author@optarg[]}}
+\def\author@optarg[#1]#2{\stepcounter{author}%
+  \beg@elem
+  \@for\@tempa:=#1\do{\expandafter\add@thanksref\expandafter{\@tempa}}%
+  \report@elt{author}\proc@elem{author}{#2}%
+  \author@fmt{\the\c@author}{\the\t@loc@notes}{\@author}}%
+\def\author@fmt#1#2#3{\@newelemtrue
+  \if@firstauthor
+  \first@author \global\@firstauthorfalse \fi
+  \ifnum\prev@elem=\e@author \global\@newelemfalse \fi
+  \if@newelem \author@fmt@init \fi
+  \edef\@tempb{#2}\ifx\@tempb\@empty
+    \hbox{#3}\else
+    \hbox{#3\,$^{\mathrm{#2}}$}%
+  \fi}
+\def\first@author{\author@note@fmt
+  \add@tok\t@glob@notes
+    {\author@note@fmt\@corresp@note}}%
+\def\author@fmt@init{%
+  \par
+  \vskip 8pt plus 4pt minus 2pt
+  \large
+  \leavevmode}
+\def\and{\unskip~and~}
+\def\collab{\@ifstar{\collab@arg}{\collab@arg}}
+\let\collaboration=\collab
+\def\collab@arg#1{\stepcounter{collab}%
+  \if@firstauthor \first@collab \global\@firstauthorfalse \fi
+  \beg@elem
+  \proc@elem{collab}{#1}%
+  \collab@fmt{\the\c@collab}{\the\t@loc@notes}{\@collab}%
+  \ignorespaces}
+\def\collab@fmt#1#2#3{\@newelemtrue
+  \ifnum\prev@elem=\e@collab \global\@newelemfalse \fi
+  \if@newelem \collab@fmt@init \fi
+  \par
+  {\large #3\,$^{\mathrm{#2}}$}}
+\def\first@collab{
+  \collab@note@fmt
+  \add@tok\t@glob@notes
+    {\collab@note@fmt}}%
+\def\collab@fmt@init{\vskip 1em}
+\def\author@note@fmt{\setcounter{footnote}{0}%
+  \def\thefootnote{\xarabic{footnote}}}
+\let\collab@note@fmt=\author@note@fmt
+\def\xarabic#1{%
+  \expandafter\expandafter\expandafter\ifnum\expandafter\the\@nameuse{c@#1}<0
+  *\else\arabic{#1} \fi}
+\def\address{\@ifstar{\address@star}%
+  {\@ifnextchar[{\address@optarg}{\address@noptarg}}}
+\def\address@optarg[#1]#2{\refstepcounter{address}%
+  \beg@elem
+  \report@elt{address}\proc@elem{address}{#2}%
+  \address@fmt{\the\c@address}{\the\t@loc@notes}{\@address}\label{#1}%
+  \ignorespaces}
+\def\address@noptarg#1{\refstepcounter{address}%
+  \beg@elem
+  \proc@elem{address}{#1}%
+  \address@fmt{\z@}{\the\t@loc@notes}{\@address}%
+  \ignorespaces}
+\def\address@star#1{%
+  \beg@elem
+  \proc@elem{address}{#1}%
+  \address@fmt{\m@ne}{\the\t@loc@notes}{\@address}%
+  \ignorespaces}
+\def\theaddress{\alph{address}}
+\def\address@fmt#1#2#3{\@newelemtrue
+  \ifnum\prev@elem=\e@address \@newelemfalse \fi
+  \if@newelem \address@fmt@init \fi
+  \noindent \bgroup \small\it
+  \ifnum#1=\z@
+    #3\,$^{\mathrm{#2}}$\space%
+  \else
+    \ifnum#1=\m@ne
+      $^{\phantom{\mathrm{\theaddress}}}$\space #3\,$^{\mathrm{#2}}$%
+    \else
+      $^{\mathrm{\theaddress}}$\space #3\,$^{\mathrm{#2}}$%
+    \fi
+  \fi
+  \par \egroup}
+\def\address@fmt@init{%
+  \par
+  \vskip 6pt plus 3pt minus 1.5pt}
+\def\abstract{\@ifnextchar[{\@abstract}{\@abstract[]}}
+\def\@abstract[#1]{%
+  \global\@hasabstracttrue
+  \hyphenpenalty\sv@hyphenpenalty
+  \global\setbox\t@abstract=\vbox\bgroup
+  \leftskip\z@
+  \@rightskip\z@ \rightskip\@rightskip \parfillskip\@flushglue
+  \small
+  \parindent 1em
+  \noindent {\bf\abstractname}
+  \par\noindent%\vskip 0.5\@bls Changed 23-2-95 by MWM
+  \ignorespaces}
+\def\endabstract{\par \egroup}
+\def\keyword{%
+  \global\@hasabstracttrue
+  \hyphenpenalty\sv@hyphenpenalty
+  \def\sep{\unskip; }
+  \def\MSC{\par\leavevmode\hbox {\it 1991 MSC:\ }}%
+  \def\PACS{\par\leavevmode\hbox {\it PACS:\ }}%
+  \def\JEL{\par\leavevmode\hbox {\it JEL classification:\ }}%
+  \let\UK\relax \let\CK\relax
+  \global\setbox\t@keyword=\vbox\bgroup
+  \small
+  \parskip\z@
+  \vskip 10pt plus 2pt minus 2pt
+  \noindent {\it Keywords:\ }%
+  \justify@off
+  \ignorespaces}
+\def\endkeyword{\par \egroup}
+\def\journal#1{\gdef\@journal{#1}}
+\def\volume#1{\gdef\@volume{#1}}       \def\@volume{0}
+\def\issue#1{\gdef\@issue{#1}}         \def\@issue{0}
+\newcount\@pubyear
+\newcount\@copyear
+\@pubyear=\number\year
+\@copyear\@pubyear \advance\@copyear-1900
+\def\pubyear#1{\global\@pubyear#1
+  \global\@copyear\@pubyear \global\advance\@copyear-1900
+  \ignorespaces}
+\def\firstpage#1{\def\@tempa{#1}\ifx\@tempa\@empty\else
+  \gdef\@firstpage{#1}\gdef\@lastpage{#1}%
+  \global\c@page=#1 \ignorespaces\fi
+  }
+\def\@firstpage{1}
+\def\lastpage#1{\def\@tempa{#1}\ifx\@tempa\@empty\else
+  \gdef\@lastpage{#1}\ignorespaces\fi}
+\def\@lastpage{0}
+\def\@pagerange{1--0}
+\def\date#1{\gdef\@date{#1}}                  \def\@date{\today}
+\def\aid#1{}
+\def\ssdi#1#2{}
+\def\received#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@received{#1}\fi}
+  \def\@received{\@nil}
+\def\revised#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@revised{#1}\fi}
+  \def\@revised{\@nil}
+\def\accepted#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@accepted{#1}\fi}
+  \def\@accepted{\@nil}
+\def\communicated#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@communicated{#1}\fi}
+  \def\@communicated{\@nil}
+\def\dedicated#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@dedicated{#1}\fi}
+  \def\@dedicated{\@nil}
+\def\presented#1{\def\@tempa{#1}\ifx\@tempa\@empty\else\gdef\@presented{#1}\fi}
+  \def\@presented{\@nil}
+\def\articletype#1{\gdef\@articletype{#1}}
+  \@ifundefined{@articletype}{\def\@articletype{}}{}
+\def\received@prefix{Received~}
+\def\revised@prefix{; revised~}
+\def\accepted@prefix{; accepted~}
+\def\communicated@prefix{\\Communicated~by~}
+\def\history@prefix{}
+\def\received@postfix{}
+\def\revised@postfix{}
+\def\accepted@postfix{}
+\def\communicated@postfix{}
+\def\history@postfix{}
+\def\empty@data{\@nil}
+\def\history@fmt{%
+  \bgroup
+  \small
+  \vskip 6pt plus 2pt minus 1pt
+  \ifx\@received\empty@data \else
+    \leavevmode
+    \history@prefix
+    \received@prefix\@received \received@postfix%
+    \ifx\@revised\empty@data \else
+      \revised@prefix\@revised \revised@postfix%
+    \fi
+    \ifx\@accepted\empty@data \else
+      \accepted@prefix\@accepted \accepted@postfix%
+    \fi
+    \ifx\@communicated\empty@data \else
+      \communicated@prefix\@communicated \communicated@postfix%
+    \fi
+    \history@postfix
+  \fi
+  \par \egroup}
+\def\dedicated@fmt{%
+  \ifx\@dedicated\empty@data \else
+    \vskip 4pt plus 3pt
+    \normalsize\it\centering \@dedicated
+    \fi}
+\def\@ialph#1{\ifcase#1\or \or \or \or \or e\or f\or g\or h\or i\or j\or
+  k\or \ell\or m\or n\or o\or p\or q\or r\or s\or t\or u\or v\or w\or x\or
+  y\or z\or aa\or ab\or ac\or ad\or ae\or af\or ag\or ah\or ai\or aj\or
+  ak\or a\ell\or am\or an\or ao\or ap\or aq\or ar\or as\or at\or au\or av\or
+  aw\or ay\or az\or ba\or bb\or bc\or bd\or be\or bf\or bg\or bh\or bi\or
+  bj\or bk\or b\ell\or bm\or bn\or bo\or bp\or bq\or br\or bs\or bt\or
+  bu\or bw\or bx\or by\or bz\or ca\or cb\or cc\or cd\or ce\or cf\or cg\or
+  ch\or ci\or cj\or ck\or c\ell\or cm\or cn\or co\or cp\or cq\or cr\or
+  cs\or ct\or cu\or cw\or cx\or cy\or cz\else\@ctrerr\fi}
+\def\fnstar#1{\@fnstar{\@nameuse{c@#1}}}
+\def\@fnstar#1{\ifcase#1\or
+    \hbox{$\star$}\or
+    \hbox{$\star\star$}\or
+    \hbox{$\star\star\star$}\or
+    \hbox{$\star\star\star\star$}\or
+    \hbox{$\star\star\star\star\star$}\or
+    \hbox{$\star\star\star\star\star\star$}
+  \else
+    \@ctrerr
+  \fi
+  \relax}
+\mark{{}{}}
+\def\rightheadline{}
+\def\leftheadline{}
+\def\annum{\the\@pubyear}
+\def\firstheadline{}
+\def\firstfootline{}
+\def\ps@plain{\let\@mkboth\@gobbletwo
+        \def\@oddhead{\rightheadline}
+        \def\@evenhead{\leftheadline}
+  \def\@oddfoot{\hfil {\rm\thepage} \hfil}%
+ \let\@evenfoot\@oddfoot}
+\def\@copyright{\@issn/\the\@copyear\ $\copyright$\ \the\@pubyear\
+  Elsevier Science B.V. All rights reserved}
+\def\@jou@vol@pag{\@journal\ \@volume\ (\the\@pubyear)}
+\let\@j@v@p\@jou@vol@pag
+\let\@@j@v@p\@jou@vol@pag
+\def\sectionmark#1{}
+\def\subsectionmark#1{}
+\def\ps@copyright{\let\@mkboth\@gobbletwo
+  \def\@oddhead{\ifnum\value{page}=1\firstheadline
+              \else\rightheadline\fi}
+        \def\@evenhead{\ifnum\value{page}=1\firstheadline
+              \else\leftheadline\fi}
+  \def\@oddfoot{\small\sl
+    \def\@tempa{0}
+    \ifx\@volume\@tempa
+      Preprint submitted to \@journal\hfil\@date\/%
+    \else
+      \firstfootline\fi}%
+  \let\@evenfoot\@oddfoot
+}
+\let\ps@noissn\ps@empty
+\let\ps@headings\ps@plain
+\def\today{\number\day\space\ifcase\month\or
+  January\or February\or March\or April\or May\or June\or
+  July\or August\or September\or October\or November\or December\fi
+  \space\number\year}
+\if@nfss \relax \else
+  \def\mathrm#1{{\rm #1}}
+  \let\@@mit=\mit
+  \def\mit#1{{\@@mit #1}}
+\fi
+\def\nuc#1#2{\relax\ifmmode{}^{#1}{\protect\text{#2}}\else${}^{#1}$#2\fi}
+\def\itnuc#1#2{\setbox\@tempboxa=\hbox{\scriptsize\it #1}
+  \def\@tempa{{}^{\box\@tempboxa}\!\protect\text{\it #2}}\relax
+  \ifmmode \@tempa \else $\@tempa$\fi}
+\let\old@vec\vec
+\def\pol#1{\old@vec{#1}}
+\def\@bfvec#1{\boldsymbol{#1}}
+\def\@pmbfvec#1{\pmb{#1}}
+\def\undo@AMS{\global\let\vec\@bfvec}
+\def\half{{\textstyle {1\over2}}}
+\def\threehalf{{\textstyle {3\over2}}}
+\def\quart{{\textstyle {1\over4}}}
+\def\d{\,\mathrm{d}}
+\def\e{\mathop{\mathrm{e}}\nolimits}
+\def\int{\intop}
+\def\oint{\ointop}
+\newbox\slashbox \setbox\slashbox=\hbox{$/$}
+\newbox\Slashbox \setbox\Slashbox=\hbox{\large$/$}
+\def\pFMslash#1{\setbox\@tempboxa=\hbox{$#1$}
+  \@tempdima=0.5\wd\slashbox \advance\@tempdima 0.5\wd\@tempboxa
+  \copy\slashbox \kern-\@tempdima \box\@tempboxa}
+\def\pFMSlash#1{\setbox\@tempboxa=\hbox{$#1$}
+  \@tempdima=0.5\wd\Slashbox \advance\@tempdima 0.5\wd\@tempboxa
+  \copy\Slashbox \kern-\@tempdima \box\@tempboxa}
+\def\FMslash{\protect\pFMslash}
+\def\FMSlash{\protect\pFMSlash}
+\mathchardef\Gamma="0000
+\mathchardef\Delta="0001
+\mathchardef\Theta="0002
+\mathchardef\Lambda="0003
+\mathchardef\Xi="0004
+\mathchardef\Pi="0005
+\mathchardef\Sigma="0006
+\mathchardef\Upsilon="0007
+\mathchardef\Phi="0008
+\mathchardef\Psi="0009
+\mathchardef\Omega="000A
+\mathchardef\varGamma="0100
+\mathchardef\varDelta="0101
+\mathchardef\varTheta="0102
+\mathchardef\varLambda="0103
+\mathchardef\varXi="0104
+\mathchardef\varPi="0105
+\mathchardef\varSigma="0106
+\mathchardef\varUpsilon="0107
+\mathchardef\varPhi="0108
+\mathchardef\varPsi="0109
+\mathchardef\varOmega="010A
+\if@nfss
+  \def\Cset{\Bbb{C}}
+  \def\Hset{\Bbb{H}}
+  \def\Nset{\Bbb{N}}
+  \def\Qset{\Bbb{Q}}
+  \def\Rset{\Bbb{R}}
+  \def\Zset{\Bbb{Z}}
+\fi
+\ps@headings
+\pagenumbering{arabic}
+\def\thepage{\@pagenumprefix\arabic{page}}
+
+\def\enddocument{\label{LastPage}\@checkend{document}\clearpage\begingroup  
+\if@filesw \immediate\closeout\@mainaux 
+\def\global\@namedef##1##2{}\def\newlabel{\@testdef r}%
+\def\bibcite{\@testdef b}\@tempswafalse \makeatletter\input \jobname.aux
+\if@tempswa \@warning{Label(s) may have changed.  Rerun to get
+cross-references right}\fi\fi\endgroup\deadcycles\z@\@@end}
+
+\endinput
+
+%%%end of entcs.sty%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ tools/interp/HaskellWorkshop/entcsmacro.sty view
@@ -0,0 +1,128 @@+% Macro file for Electronic Notes in Theoretical Computer Science.+% Adopted from document-style for journals published by Elsevier Science. +% To be used with LaTeX version 2.09 of 14 January 1992 (or later) +%+% Version: 1.10+% Date:    13 February 1998+%+% Copyright (C) 1998. All rights reserved.+%+% IMPORTANT NOTICE:+%+% You are not allowed to change this file. You may however copy this file +% to a file with a different name and then change the copy. +% +% You are NOT ALLOWED to distribute this file alone. You are NOT ALLOWED +% to take money for the distribution or use of this file (or a changed +% version) except for a nominal charge for copying etc. +% +% You are allowed to distribute this file under the condition that it is +% distributed together with all files mentioned in readme.els. +% +% If you receive only some of these files from someone, complain! +% +%++\headheight 10pt+\headsep 20pt+\footskip 20pt+\setlength{\topmargin}{-30pt}+\addtolength{\textheight}{25pt} ++\def\labelenumi{\rm\normalshape (\theenumi)}     +\def\labelenumii{\rm\normalshape (\theenumii)}++\font\eightrm=cmr8 scaled\magstep1+\font\eightbf=cmbx8 scaled\magstep1+\font\eighttt=cmtt8 scaled\magstep1+\font\eightit=cmsl10+\font\sixrm=cmr6 scaled\magstep1+\font\bfone=cmbx10 scaled\magstep2+\font\smc=cmcsc10 scaled\magstep1+\font\sc=cmcsc10 ++\def\date{\ifcase\month\or January\or February \or March\or April\or May+\or June\or July\or August\or September\or October\or November+\or December\fi\space\number\day, \number\year}++\volume{41}+\def\volu{41\ No.\ 1}+\journal{Electronic Notes in Theoretical Computer Science}+\def\jour{Electronic Notes in Theoretical Computer Science}+\def\vol{41}++\def\rightheadline{\hfill\sc\lastname\hfill}+\def\leftheadline{\hfill\sc\lastname\hfill}+\def\firstheadline{\vbox{\baselineskip=8pt+    \parindent 0pt \obeylines \eightrm \jour\space+    \volu$\,$(\annum)\hfill\break {\eighttt URL:+    \href{http://www.elsevier.nl/locate/entcs/volume\vol.html}+     {http://www.elsevier.nl/locate/entcs/volume\vol.html}}\ \ +    \pageref{LastPage} pages\hfill\break}} \def\firstfootline{\hfill+  \eightit \copyright \annum\ Published by Elsevier Science B.~V.\hfill}++\pagestyle{headings}++% THE NEXT LINES GIVE DEFINITIONS FOR THE THEOREM ENVIRONMENTS.+% EACH IS VIEWED AS A theorem environment IN THE SENSE OF LaTeX.+% THEIR NAMES ARE: Theorem, Proposition, Lemma, Corollary, Proposition,+% Criterion, Definition, Conjecture, Example, Problem, Remark, +% Summary, and Acknowledgement.  ALSO INCLUDED WITHIN encs.sty ARE THE+% ENVIRONMENTS Note, Claim and Case UNDER THEIR OWN NAMES, AND THE+% ENVIRONMENT Algorithm UNDER THE NAME alg; FOR THIS USE +% \begin{alg} text \end{alg}.+% TYPE \begin{name} text \end{name} AS USUAL FOR ENVIRONMENTS IN LaTeX.+% THE ENVIRONMENT name IS NUMBERED WITHIN section. E.G. THE FIRST 'Name' +% IN SECTION 1 IS NUMBERED 'Name 1.1'++\newenvironment{theorem}{\vspace{-\lastskip}\par\addvspace{.6pc plus+    .2pc minus .1pc}\begin{thm}}{\end{thm}\par\addvspace{.6pc plus+    .2pc minus .1pc}} \newenvironment{lemma}{\vspace{-\lastskip}\par+  \addvspace{.6pc plus .2pc minus .1pc}\begin{lem}}+  {\end{lem}\par\addvspace{.6pc plus .2pc minus .1pc}}+\newenvironment{corollary}{\vspace{-\lastskip}\par \addvspace{.6pc+    plus .2pc minus .1pc}\begin{cor}}{\end{cor}\par\addvspace{.6pc+    plus .2pc minus .1pc}}+\newenvironment{proposition}{\vspace{-\lastskip}\par \addvspace{.6pc+    plus .2pc minus .1pc}\begin{prop}}{\end{prop}\par\addvspace{.6pc+    plus .2pc minus .1pc}}+\newenvironment{criterion}{\vspace{-\lastskip}\par \addvspace{.6pc+    plus .2pc minus .1pc} \begin{crit}}{\end{crit}\par\addvspace{.6pc+    plus .2pc minus .1pc}}+\newenvironment{definition}{\vspace{-\lastskip}\par \addvspace{.6pc+    plus .2pc minus+    .1pc}\begin{defn}\rm}{\end{defn}\par\addvspace{.6pc plus .2pc+    minus .1pc}}+\newenvironment{conjecture}{\vspace{-\lastskip}\par \addvspace{.6pc+    plus .2pc minus .1pc}\begin{conj}}{\end{conj}\par\addvspace{.6pc+    plus .2pc minus .1pc}}+\newenvironment{example}{\vspace{-\lastskip}\par \addvspace{.6pc plus+    .2pc minus .1pc}\begin{exmp}\rm}{\end{exmp}\par\addvspace{.6pc+    plus .2pc minus .1pc}}+\newenvironment{problem}{\vspace{-\lastskip}\par \addvspace{.6pc plus+    .2pc minus .1pc}\begin{prob}}{\end{prob}\par\addvspace{.6pc plus+    .2pc minus .1pc}} \newenvironment{remark}{\vspace{-\lastskip}\par+  \addvspace{.6pc plus .2pc minus .1pc}\begin{rem}\rm}+{\end{rem}\par\addvspace{.6pc plus .2pc minus .1pc}}+\newenvironment{summary}{\vspace{-\lastskip}\par \addvspace{.6pc plus+    .2pc minus .1pc}\begin{summ}}{\end{summ}\par\addvspace{.6pc plus+    .2pc minus .1pc}}+\newenvironment{acknowledgement}{\vspace{-\lastskip}\par\addvspace{.6pc+    plus .2pc minus .1pc}\begin{ack}}{\end{ack}\par\addvspace{.6pc+    plus .2pc minus .1pc}}++\newenvironment{exercise}{\begin{trivlist}\item[\hskip%+    \labelsep{\bf Exercise.}]}% +    {\end{trivlist}}++%% THE ENVIRONMENT \begin{proof} ... \end{proof} PRODUCES AN+%% END-OF-PROOF SIGN.++\newenvironment{proof}{\begin{pf}}{\qed\end{pf}}++%% THE ENVIRONMENT \begin{proof*} ... \end{proof*} SUPPORTS ADDING+%% INFORMATION SUCH AS  'Proof (Sketch)' AS THE LABEL FOR THE PROOF.++\newenvironment{proof*}{\begin{pf*}}{\qed\end{pf*}}++%% END OF `entcsmacro.sty'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ tools/interp/HaskellWorkshop/global-defs.tex view
@@ -0,0 +1,333 @@+\newcommand{\ldbrack}{[\![}+\newcommand{\rdbrack}{]\!]}+\newcommand{\rdbrackPS}{]\!]_{ps}}+\newcommand{\minus}{{\tt neg}}+\newcommand{\update}{{\tt update}}+\newcommand{\updateSto}{{\tt updateSto}}+\newcommand{\updateA}{{\tt updateA}}+%\newcommand{\rdAddr}{{\tt rdAddr}}+\newcommand{\rdSto}{{\tt rdSto}}+\newcommand{\getSto}{{\tt getSto}}+\newcommand{\getSBRS}{{\tt getSBRS}}+\newcommand{\setSto}{{\tt setSto}}+\newcommand{\rdLabel}{{\tt rdLabel}}+\newcommand{\rdCode}{{\tt rdCode}}+\newcommand{\getCode}{{\tt getCode}}+\newcommand{\callcc}{{\tt callcc}\;}+\newcommand{\call}{{\tt call}}+\newcommand{\acall}{{\tt acall}}+\newcommand{\readIt}{{\tt read}}+\newcommand{\bool}{{\bf bool}}+++\newcommand{\getDisplay}{{\tt getDisplay}}+\newcommand{\updateDisplay}{{\tt updateDisplay}}+%\newcommand{\MachLang}{\textsf{\textbf{MachLang}}\/}+\newcommand{\MachLang}{\ensuremath{\mathbf{\mathsf{MachLang}\/}}}+\newcommand{\Rhs}{\ensuremath{\mathbf{\mathsf{Rhs}\/}}}+\newcommand{\TargetLang}{\ensuremath{\mathbf{\mathsf{TargetLang}\/}}}+\newcommand{\IntProducer}{\ensuremath{\mathbf{\mathsf{IntProducer}\/}}}++\newcommand{\letclosed}{{\bf letclosed}}+\newcommand{\letopen}{{\bf letopen}}+\newcommand{\letrec}{{\bf letrec}}+\newcommand{\funcall}{{\bf funcall}}+\newcommand{\apply}{\mathsf{apply}}+\newcommand{\Dynam}{\mathsf{Dynam}}+\newcommand{\Static}{\mathsf{Static}}+\newcommand{\Dmonad}{\mathsf{D}}+\newcommand{\Smonad}{\mathsf{S}}+\newcommand{\DynamOf}[1]{\mathsf{Dynam}(#1)}+\newcommand{\StaticOf}[1]{\mathsf{Static}(#1)}+\newcommand{\compile}{\ensuremath{\mathsf{compile}}}+%\newcommand{\compile}{\textsf{compile}}+\newcommand{\Monad}{\mathsf{M}}+\newcommand{\St}{\mathsf{St}}+\newcommand{\STtwo}{\mathsf{St2}}+\newcommand{\EnvSt}{\mathsf{EnvSt}}+\newcommand{\CPS}{\mathsf{CPS}}+\newcommand{\Id}{\mathsf{Id}}+\newcommand{\T}{\mathsf{T}}+\newcommand{\M}{\mathcal{M}}+\newcommand{\ALLOC}{{\tt ALLOC}}+\newcommand{\NOP}{{\tt NOP}}+\newcommand{\DEALLOC}{{\tt DEALLOC}}+\newcommand{\BRLEQ}{{\tt BRLEQ}}+%\newcommand{\then}{\,\mbox{{\bf{\tt \large{;}}}}\, }+\newcommand{\then}{\,\mbox{{\bf{\tt ;}}}\, }++++\newcommand{\Interp}{\mathsf{Dynam}}+\newcommand{\Comp}{\mathsf{Static}}++\newcommand{\updateL}{{\tt updateL}}+\newcommand{\updateLabel}{{\tt updateLabel}}+\newcommand{\getLabel}{{\tt getLabel}}+\newcommand{\getIt}{{\tt get}}+\newcommand{\setIt}{{\tt set}}+\newcommand{\contents}{{\tt read}}+\newcommand{\add}{{\tt add}}+\newcommand{\NN}{N}+\newcommand{\Mach}{[\![ - ]\!]_{Mach}}++%\newcommand{\IntProd}{{\tiny \mathbf{MachLang}\times \mathbf{Rhs}}}+\newcommand{\IntProd}{\mathit{IntProd}}++\newcommand{\getSP}{{\tt getSP}}+\newcommand{\setSBRS}{{\tt setSBRS}}+\newcommand{\rdLoc}{{\tt rdLoc}}++\newcommand{\jump}{{\tt jump}\,}+\newcommand{\JUMP}{{\tt JUMP}}+\newcommand{\SEGM}{{\tt SEGM}}+\newcommand{\SEGMENT}{{\tt SEGMENT}}+\newcommand{\LABEL}{{\tt LABEL}}+\newcommand{\ENDLABEL}{{\tt ENDLABEL}}+\newcommand{\Mono}{{\cal M}\!{\it ono}}++%\newcommand{\UnitType}{\,{\tt void}}+\newcommand{\Void}{{\tt void}}+%\newcommand{\bindI}{\;\;{\bf bindE}\;\;}+\newcommand{\bindD}{\;\star_{D}\;}+\newcommand{\unitD}{{\bf unit}_D}+++%\newcommand{\bind}{\;\;{\bf bind}\;\;}+\newcommand{\bind}{\;\star\;}+\newcommand{\bindid}{\;\star_{Id}\;}+\newcommand{\bindul}{\;\;\bigcirc\hspace{-1.25mm}\!\!\!\!\star\;\;\,\;}++\newcommand{\unit}{{\bf unit}}+\newcommand{\CreateTemp}{{\tt CreateTemp}}+\newcommand{\newloc}{{\tt newloc}}+\newcommand{\newLabel}{{\tt newlabel}}+\newcommand{\rdloc}{{\tt rdloc}}+\newcommand{\newAddr}{{\tt newAddr}}+\newcommand{\newSegment}{{\tt newSegment}}+\newcommand{\newSegments}{{\tt newSegments}}+\newcommand{\updateloc}{{\tt updateloc}}+\newcommand{\lift}{{\tt lift}}+\newcommand{\updateC}{{\tt updateC}}+\newcommand{\updateCode}{{\tt updateCode}}+\newcommand{\storeC}{{\tt storeC}}+\newcommand{\store}{{\tt store}}++\newcommand{\StateT}{{\mathcal T}_{\!\mathsf{St}}}+\newcommand{\EnvT}{{\mathcal T}_{\!\mathsf{Env}}}+\newcommand{\ContT}{{\mathcal T}_{\!\mathsf{CPS}}}++%\newcommand{\StateT}{{\mathcal T}_{\! St}}+%\newcommand{\EnvT}{{\mathcal T}_{\! Env}}++\newcommand{\CodeStore}{Code}++\newcommand{\rdAddr}{{\tt rdAddr}}+\newcommand{\inAddr}{{\tt inAddr}}+\newcommand{\Thread}{{\tt Thread}}+\newcommand{\C}{{\cal C}}+%\newcommand{\bindC}{\;{\bf bindC}\;}+\newcommand{\bindS}{\;\star_{S}\;}+\newcommand{\unitS}{{\bf unit}_S}+\newcommand{\BINDS}[2]{#1\bindS \lambda #2.}+\newcommand{\BIND}[2]{#1\bind \lambda #2.}+\newcommand{\BINDD}[2]{#1\bindD \lambda #2.}+\newcommand{\BINDM}[2]{#1\bindM \lambda #2.}+\newcommand{\MS}[1]{\ensuremath{\M\ldbrack #1 \rdbrack}}+\newcommand{\CS}[1]{\ensuremath{\C\ldbrack #1 \rdbrack}}+\newcommand{\standard}[1]{\ensuremath{\ldbrack #1 \rdbrack}}++\newcommand{\rdSeg}{{\tt rdSeg}}+\newcommand{\rdSD}{{\tt rdSD}}+\newcommand{\inSD}{{\tt inSD}}++\newcommand{\orLog}{\,{\bf or}\,}+\newcommand{\notLog}{{\bf not}\,}+\newcommand{\true}{{\tt true}}+\newcommand{\false}{{\tt false}}+\newcommand{\currentFrame}{{\tt currentFrame}}+\newcommand{\mkCall}{{\tt mkCall}}+\newcommand{\return}{{\tt return}}+\newcommand{\intexp}{{\bf intexp}}+\newcommand{\boolexp}{{\bf boolexp}}+\newcommand{\comm}{{\bf comm}}+%\newcommand{\prop}{{\bf prop}}+\newcommand{\mkcall}{{\tt mkcall}}+\newcommand{\mkargcall}{{\tt mkargcall}}+\newcommand{\mksubr}{{\tt mksubr}}+\newcommand{\initCS}{{\tt init}_{CS}}+\newcommand{\lookup}{{\tt lookup}}+\newcommand{\Assign}{\mathsf{Assign}}+\newcommand{\Negate}{\ensuremath{\mathsf{Negate}}}+\newcommand{\Add}{\mathsf{Add}}+\newcommand{\Arrow}{\mathsf{Lambda}}+\newcommand{\IfThen}{\ensuremath{\mathsf{IfThen}}}+\newcommand{\IfThenPS}{\ensuremath{\mathsf{IfThenPS}}}+\newcommand{\IfThenElsePS}{\ensuremath{\mathsf{IfThenElsePS}}}+\newcommand{\IfThenOf}[4]{\mathsf{IfThen}(#1,#2,#3,#4)}+\newcommand{\WhilePS}{\mathsf{WhilePS}}+\newcommand{\Or}{\mathsf{Or}}+\newcommand{\Not}{\mathsf{Not}}+\newcommand{\Lteq}{\mathsf{Lteq}}+%\newcommand{\Fresh}{\mathsf{Fresh}}+\newcommand{\New}{\mathsf{New}}+\newcommand{\Observe}{\mathsf{Obs}}+%\newcommand{\If}{\mathsf{If}}+\newcommand{\If}[2]{#1 \;\mbox{\raisebox{-0.4ex}{{\huge $\triangleright$}}}\; #2}+\newcommand{\guard}{\;\mbox{\raisebox{-0.4ex}{{\huge $\triangleright$}}}\;}+\newcommand{\NotEqual}{\mathsf{NotEqual}}+\newcommand{\And}{\mathsf{And}}+\newcommand{\NotInRHS}{\mathsf{NotInRHS}}+\newcommand{\DisplayUnchanged}{\mathsf{DisplayUnchanged}}+\newcommand{\savereg}{\mathsf{savereg}}+\newcommand{\rhs}{\mathit{rhs}}+\newcommand{\tmps}{\mathit{tmps}}+\newcommand{\pop}{\mathsf{pop}}++\newcommand{\Alloc}{{\tt Alloc}}+\newcommand{\deAlloc}{{\tt deAlloc}}++\newcommand{\rdEnv}{{\tt rdEnv}}+\newcommand{\rdgen}{{\tt rd}}+\newcommand{\ingen}{{\tt in}}+\newcommand{\inEnv}{{\tt inEnv}}+\newcommand{\allocLoc}{{\tt allocLoc}}++\newlength{\bracket}+\settowidth{\bracket}{[}+\newsavebox{\leftdoublebracket}+\newsavebox{\rightdoublebracket}+\sbox{\leftdoublebracket}{[\hspace{-.5\bracket}[}+\sbox{\rightdoublebracket}{]\hspace{-.5\bracket}]}+\newcommand{\ldbra}{\usebox{\leftdoublebracket}}+\newcommand{\rdbra}{\usebox{\rightdoublebracket}}+\newsavebox{\leftbraced}+\newsavebox{\rightbraced} +\sbox{\leftbraced}{\{\hspace{-.5\bracket}|}+\sbox{\rightbraced}{|\hspace{-.5\bracket}\}}+\newcommand{\lbrac}{\usebox{\leftbraced}}+\newcommand{\rbrac}{\usebox{\rightbraced}}+\makeatother+%\include{psinput}+%\include{psfig}++\newcommand{\segment}[3]{{\tt (SEGM}( #1,#2) \then #3{\tt )}}+\newcommand{\EndLabel}[2]{{\tt (ENDLABEL}\;#1\;\;#2{\tt )}}+\newcommand{\Lexit}{\ensuremath{L_{{\mathrm exit}}}}++\newcommand{\IfThenElse}[3]+	{\ensuremath+	{\begin{array}{lcl} +		\mbox{if   }\; #1\; \mbox{ then}\\+		\hspace{4ex} #2\\ +		\mbox{else }\; #3 \end{array}}}++\newcommand{\RCBB}{RCBB}+\newcommand{\Exp}{\ensuremath{Exp}}++\newcommand{\alloc}[1]{\ensuremath{\mathtt{ALLOC}(#1)}}+\newcommand{\dealloc}[1]{\ensuremath{\mathtt{DEALLOC}(#1)}}+\newcommand{\Obs}[3]{\ensuremath{\mathsf{Obs}(#1,#2,#3)}}+%\newcommand{\Obs}[3]{\mathbf{[}#1\; +% \;\mbox{\raisebox{-0.4ex}{{\huge $\triangleright$}}}\;+% #2\; \| \;#3\mathbf{]}}+\newcommand{\IP}[3]{\ensuremath{\langle #1,#2,#3\rangle}}++\newcommand{\pbang}{\mathsf{p!}}++%\newcommand{\staged}[1]{\ensuremath{\mathsf{staged}\ldbrack #1 \rdbrack}}+\newcommand{\staged}[1]{\ensuremath{\mathcal{S}\ldbrack #1 \rdbrack}}+\newcommand{\unquote}{{\tt unquote}}++\newcommand{\bindM}{\;\star_{M}\;}+\newcommand{\unitM}{{\bf unit}_M}+\newcommand{\highlight}[1]{\begin{center} \fbox{#1} \end{center}}+\newcommand{\reason}[1]{\vspace{3ex}\noindent\fbox{{#1}}}+\newcommand{\dynwhile}{\ensuremath{\mathsf{dynwhile}}}+\newcommand{\whilePS}{\ensuremath{\mathsf{whilePS}}}+\newcommand{\FreshLabels}{\mathsf{FreshLabels}}+\newcommand{\FreshLabel}{\mathsf{FreshLabel}}+\newcommand{\FreshLoc}{\mathsf{FreshLoc}}++%\newcommand{\qed}{\noindent\(\sqcap\!\!\!\!\sqcup\)}+\newcommand{\NewIn}[2]{\mathsf{NewIn}(#1,#2)}+\newcommand{\dom}[1]{\ensuremath{\mathsf{dom}(#1)}}+++%\newcommand{\assign}{\mbox{{\bf{\tt \large{:=}}}}}+%\newcommand{\assign}{\large{\mathbf{:=}}}+\newcommand{\assign}{\mathbf{:=}}++\newcommand{\restate}[5]{\label{#2-appendix}\noindent{\bf #1~\ref{#2} (#3)} {\em #4} #5}+\newcommand{\restateBlank}[5]{\label{#2-appendix}\noindent{\bf #1~\ref{#2} #3} {\em #4} #5}+\newcommand{\CF}[1]{\ensuremath{\mathsf{CF}\ldbrack #1 \rdbrack}}++\newcommand{\constexp}[1]{\ensuremath{\mathsf{constexp}(#1)}}+\newcommand{\AND}{\;\mathsf{AND}\;}++%\newcommand{\ObsArray}[3]+%{\ensuremath+%{\left[\begin{array}{lcl} +%		 #1\;\mbox{\raisebox{-0.4ex}{{\huge $\triangleright$}}} \\+%\hspace{6ex} #2 \mbox{\raisebox{-0.25ex}{{\Large $\;\|$}}} \\ +%		\hspace{12ex} #3 \end{array}\right] }}++\newcommand{\ObsArray}[3]+{\ensuremath+{(\mathsf{Obs}\left(\begin{array}{lcl} +		 #1,\\+\hspace{6ex} #2,  \\ +		\hspace{12ex} #3 \end{array}\right)) }}++\newcommand{\ObsArrayNP}[3]+{\ensuremath+{\mathsf{Obs}\left(\begin{array}{lcl} +		 #1,\\+\hspace{6ex} #2,  \\ +		\hspace{12ex} #3 \end{array}\right) }}++\newcommand{\ObsArrayNew}[3]+{\ensuremath+{\mathsf{Obs}\left(\begin{array}{lcl} +		#1,\\+                \hspace{2ex}#2,  \\ +		\hspace{2ex}#3 \end{array}\right) }}++\newcommand{\Pre}{\ensuremath{\mathsf{Pre}}}+\newcommand{\ifcmd}[2]{\ensuremath{\mbox{{\rm {\bf if }}} #1 \mbox{ {\rm {\bf then}} } #2}}+\newcommand{\whilecmd}[2]{\ensuremath{\mbox{{\rm {\bf while }}} #1 \mbox{ {\rm {\bf do}} } #2}}+\newcommand{\ifthenelsecmd}[3]{\ensuremath{\mbox{{\rm {\bf if }}} #1 \mbox{+{\rm {\bf then}} } #2 \mbox{ {\rm {\bf else}} } #3}} ++\newcommand{\LEQ}{\ensuremath{\;\mathsf{leq}\;}}+\newcommand{\srcleq}{\ensuremath{\mathsf{leq}}}+\newcommand{\boost}{\ensuremath{\mathsf{boost}}}+\newcommand{\W}[1]{\ensuremath{\mathcal{W}#1}}+\newcommand{\I}[1]{\ensuremath{\mathcal{I}#1}}+\newcommand{\ul}[1]{\underline{#1}}+\newcommand{\ajump}{{\tt ajump}}+%\newcommand{\equaldef}{=^{\hspace{-1.6ex}{\tiny\mbox{\raisebox{0.2ex}{$\triangle$}}}}}++\newcommand{\equaldef}{\stackrel{\triangle}{=}}++\newcommand{\nop}{\ensuremath{\mathtt{NOP}}}++\hyphenation{me-ta-com-put-ation me-ta-com-put-a-tion-based me-ta-com-put-ation---the}++\hyphenation{rep-res-ent-a-tion-al-ly-ind-ep-end-ent}++\newcommand{\Src}{\ensuremath{\mathsf{Src}\/}}++%\newarrow{Corresponds}{<}{-}{-}{-}{>}++\newcommand{\comment}[1]{}+%\newcommand{\comment}[1]{{\tiny {\rm {\bf (#1)}}}}++\newcommand{\invisible}[1]{}+%\newcommand{\invisible}[1]{#1}++\newcommand{\Value}{\ensuremath{\mathit Value}}++\newcommand{\implies}{\supset}+\newcommand{\F}{\ensuremath{\mathcal{F}}}+\newcommand{\typeMT}[2]{#1_{\mathsf{#2}}}
+ tools/interp/HaskellWorkshop/psfig.tex view
@@ -0,0 +1,499 @@+% Psfig/TeX Release 1.3
+% dvips version
+%
+% All software, documentation, and related files in this distribution of
+% psfig/tex are Copyright 1987, 1988 Trevor J. Darrell
+%
+% Permission is granted for use and non-profit distribution of psfig/tex 
+% providing that this notice be clearly maintained, but the right to
+% distribute any portion of psfig/tex for profit or as part of any commercial
+% product is specifically reserved for the author.
+%
+% $Header: /cvs/programatica/tools/interp/HaskellWorkshop/psfig.tex,v 1.1 2001/04/25 23:52:51 wlh Exp $
+% $Source: /cvs/programatica/tools/interp/HaskellWorkshop/psfig.tex,v $
+%
+% Thanks to Greg Hager (GDH) and Ned Batchelder for their contributions
+% to this project.
+%
+% Modified by J. Daniel Smith on 9 October 1990 to accept the
+% %%BoundingBox: comment with or without a space after the colon.  Stole
+% file reading code from Tom Rokicki's EPSF.TEX file (see below).
+
+%
+% from a suggestion by eijkhout@csrd.uiuc.edu to allow
+% loading as a style file:
+\edef\psfigRestoreAt{\catcode`@=\number\catcode`@\relax}
+\catcode`\@=11\relax
+\newwrite\@unused
+\def\typeout#1{{\let\protect\string\immediate\write\@unused{#1}}}
+\typeout{psfig/tex 1.4-dvips}
+
+
+%% Here's how you define your figure path.  Should be set up with null
+%% default and a user useable definition.
+
+\def\figurepath{./}
+\def\psfigurepath#1{\edef\figurepath{#1}}
+
+%
+% @psdo control structure -- similar to Latex @for.
+% I redefined these with different names so that psfig can
+% be used with TeX as well as LaTeX, and so that it will not 
+% be vunerable to future changes in LaTeX's internal
+% control structure,
+%
+\def\@nnil{\@nil}
+\def\@empty{}
+\def\@psdonoop#1\@@#2#3{}
+\def\@psdo#1:=#2\do#3{\edef\@psdotmp{#2}\ifx\@psdotmp\@empty \else
+    \expandafter\@psdoloop#2,\@nil,\@nil\@@#1{#3}\fi}
+\def\@psdoloop#1,#2,#3\@@#4#5{\def#4{#1}\ifx #4\@nnil \else
+       #5\def#4{#2}\ifx #4\@nnil \else#5\@ipsdoloop #3\@@#4{#5}\fi\fi}
+\def\@ipsdoloop#1,#2\@@#3#4{\def#3{#1}\ifx #3\@nnil 
+       \let\@nextwhile=\@psdonoop \else
+      #4\relax\let\@nextwhile=\@ipsdoloop\fi\@nextwhile#2\@@#3{#4}}
+\def\@tpsdo#1:=#2\do#3{\xdef\@psdotmp{#2}\ifx\@psdotmp\@empty \else
+    \@tpsdoloop#2\@nil\@nil\@@#1{#3}\fi}
+\def\@tpsdoloop#1#2\@@#3#4{\def#3{#1}\ifx #3\@nnil 
+       \let\@nextwhile=\@psdonoop \else
+      #4\relax\let\@nextwhile=\@tpsdoloop\fi\@nextwhile#2\@@#3{#4}}
+% 
+%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% file reading stuff from epsf.tex
+%   EPSF.TEX macro file:
+%   Written by Tomas Rokicki of Radical Eye Software, 29 Mar 1989.
+%   Revised by Don Knuth, 3 Jan 1990.
+%   Revised by Tomas Rokicki to accept bounding boxes with no
+%      space after the colon, 18 Jul 1990.
+%   Portions modified/removed for use in PSFIG package by
+%      J. Daniel Smith, 9 October 1990.
+%
+\newread\ps@stream
+\newif\ifnot@eof       % continue looking for the bounding box?
+\newif\if@noisy        % report what you're making?
+\newif\if@atend        % %%BoundingBox: has (at end) specification
+\newif\if@psfile       % does this look like a PostScript file?
+%
+% PostScript files should start with `%!'
+%
+{\catcode`\%=12\global\gdef\epsf@start{%!}}
+\def\epsf@PS{PS}
+%
+\def\epsf@getbb#1{%
+%
+%   The first thing we need to do is to open the
+%   PostScript file, if possible.
+%
+\openin\ps@stream=#1
+\ifeof\ps@stream\typeout{Error, File #1 not found}\else
+%
+%   Okay, we got it. Now we'll scan lines until we find one that doesn't
+%   start with %. We're looking for the bounding box comment.
+%
+   {\not@eoftrue \chardef\other=12
+    \def\do##1{\catcode`##1=\other}\dospecials \catcode`\ =10
+    \loop
+       \if@psfile
+	  \read\ps@stream to \epsf@fileline
+       \else{
+	  \obeyspaces
+          \read\ps@stream to \epsf@tmp\global\let\epsf@fileline\epsf@tmp}
+       \fi
+       \ifeof\ps@stream\not@eoffalse\else
+%
+%   Check the first line for `%!'.  Issue a warning message if its not
+%   there, since the file might not be a PostScript file.
+%
+       \if@psfile\else
+       \expandafter\epsf@test\epsf@fileline:. \\%
+       \fi
+%
+%   We check to see if the first character is a % sign;
+%   if so, we look further and stop only if the line begins with
+%   `%%BoundingBox:' and the `(atend)' specification was not found.
+%   That is, the only way to stop is when the end of file is reached,
+%   or a `%%BoundingBox: llx lly urx ury' line is found.
+%
+          \expandafter\epsf@aux\epsf@fileline:. \\%
+       \fi
+   \ifnot@eof\repeat
+   }\closein\ps@stream\fi}%
+%
+% This tests if the file we are reading looks like a PostScript file.
+%
+\long\def\epsf@test#1#2#3:#4\\{\def\epsf@testit{#1#2}
+			\ifx\epsf@testit\epsf@start\else
+\typeout{Warning! File does not start with `\epsf@start'.  It may not be a PostScript file.}
+			\fi
+			\@psfiletrue} % don't test after 1st line
+%
+%   We still need to define the tricky \epsf@aux macro. This requires
+%   a couple of magic constants for comparison purposes.
+%
+{\catcode`\%=12\global\let\epsf@percent=%\global\def\epsf@bblit{%BoundingBox}}
+%
+%
+%   So we're ready to check for `%BoundingBox:' and to grab the
+%   values if they are found.  We continue searching if `(at end)'
+%   was found after the `%BoundingBox:'.
+%
+\long\def\epsf@aux#1#2:#3\\{\ifx#1\epsf@percent
+   \def\epsf@testit{#2}\ifx\epsf@testit\epsf@bblit
+	\@atendfalse
+        \epsf@atend #3 . \\%
+	\if@atend	
+	   \if@verbose{
+		\typeout{psfig: found `(atend)'; continuing search}
+	   }\fi
+        \else
+        \epsf@grab #3 . . . \\%
+        \not@eoffalse
+        \global\no@bbfalse
+        \fi
+   \fi\fi}%
+%
+%   Here we grab the values and stuff them in the appropriate definitions.
+%
+\def\epsf@grab #1 #2 #3 #4 #5\\{%
+   \global\def\epsf@llx{#1}\ifx\epsf@llx\empty
+      \epsf@grab #2 #3 #4 #5 .\\\else
+   \global\def\epsf@lly{#2}%
+   \global\def\epsf@urx{#3}\global\def\epsf@ury{#4}\fi}%
+%
+% Determine if the stuff following the %%BoundingBox is `(atend)'
+% J. Daniel Smith.  Copied from \epsf@grab above.
+%
+\def\epsf@atendlit{(atend)} 
+\def\epsf@atend #1 #2 #3\\{%
+   \def\epsf@tmp{#1}\ifx\epsf@tmp\empty
+      \epsf@atend #2 #3 .\\\else
+   \ifx\epsf@tmp\epsf@atendlit\@atendtrue\fi\fi}
+
+
+% End of file reading stuff from epsf.tex
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+\def\psdraft{
+	\def\@psdraft{0}
+	%\typeout{draft level now is \@psdraft \space . }
+}
+\def\psfull{
+	\def\@psdraft{100}
+	%\typeout{draft level now is \@psdraft \space . }
+}
+\psfull
+\newif\if@prologfile
+\newif\if@postlogfile
+\def\pssilent{
+	\@noisyfalse
+}
+\def\psnoisy{
+	\@noisytrue
+}
+\psnoisy
+%%% These are for the option list.
+%%% A specification of the form a = b maps to calling \@p@@sa{b}
+\newif\if@bbllx
+\newif\if@bblly
+\newif\if@bburx
+\newif\if@bbury
+\newif\if@height
+\newif\if@width
+\newif\if@rheight
+\newif\if@rwidth
+\newif\if@clip
+\newif\if@verbose
+\def\@p@@sclip#1{\@cliptrue}
+
+%%% GDH 7/26/87 -- changed so that it first looks in the local directory,
+%%% then in a specified global directory for the ps file.
+
+\def\@p@@sfile#1{\def\@p@sfile{null}%
+	        \openin1=#1
+		\ifeof1\closein1%
+		       \openin1=\figurepath#1
+			\ifeof1\typeout{Error, File #1 not found}
+			\else\closein1
+			    \edef\@p@sfile{\figurepath#1}%
+                        \fi%
+		 \else\closein1%
+		       \def\@p@sfile{#1}%
+		 \fi}
+\def\@p@@sfigure#1{\def\@p@sfile{null}%
+	        \openin1=#1
+		\ifeof1\closein1%
+		       \openin1=\figurepath#1
+			\ifeof1\typeout{Error, File #1 not found}
+			\else\closein1
+			    \def\@p@sfile{\figurepath#1}%
+                        \fi%
+		 \else\closein1%
+		       \def\@p@sfile{#1}%
+		 \fi}
+
+\def\@p@@sbbllx#1{
+		%\typeout{bbllx is #1}
+		\@bbllxtrue
+		\dimen100=#1
+		\edef\@p@sbbllx{\number\dimen100}
+}
+\def\@p@@sbblly#1{
+		%\typeout{bblly is #1}
+		\@bbllytrue
+		\dimen100=#1
+		\edef\@p@sbblly{\number\dimen100}
+}
+\def\@p@@sbburx#1{
+		%\typeout{bburx is #1}
+		\@bburxtrue
+		\dimen100=#1
+		\edef\@p@sbburx{\number\dimen100}
+}
+\def\@p@@sbbury#1{
+		%\typeout{bbury is #1}
+		\@bburytrue
+		\dimen100=#1
+		\edef\@p@sbbury{\number\dimen100}
+}
+\def\@p@@sheight#1{
+		\@heighttrue
+		\dimen100=#1
+   		\edef\@p@sheight{\number\dimen100}
+		%\typeout{Height is \@p@sheight}
+}
+\def\@p@@swidth#1{
+		%\typeout{Width is #1}
+		\@widthtrue
+		\dimen100=#1
+		\edef\@p@swidth{\number\dimen100}
+}
+\def\@p@@srheight#1{
+		%\typeout{Reserved height is #1}
+		\@rheighttrue
+		\dimen100=#1
+		\edef\@p@srheight{\number\dimen100}
+}
+\def\@p@@srwidth#1{
+		%\typeout{Reserved width is #1}
+		\@rwidthtrue
+		\dimen100=#1
+		\edef\@p@srwidth{\number\dimen100}
+}
+\def\@p@@ssilent#1{ 
+		\@verbosefalse
+}
+\def\@p@@sprolog#1{\@prologfiletrue\def\@prologfileval{#1}}
+\def\@p@@spostlog#1{\@postlogfiletrue\def\@postlogfileval{#1}}
+\def\@cs@name#1{\csname #1\endcsname}
+\def\@setparms#1=#2,{\@cs@name{@p@@s#1}{#2}}
+%
+% initialize the defaults (size the size of the figure)
+%
+\def\ps@init@parms{
+		\@bbllxfalse \@bbllyfalse
+		\@bburxfalse \@bburyfalse
+		\@heightfalse \@widthfalse
+		\@rheightfalse \@rwidthfalse
+		\def\@p@sbbllx{}\def\@p@sbblly{}
+		\def\@p@sbburx{}\def\@p@sbbury{}
+		\def\@p@sheight{}\def\@p@swidth{}
+		\def\@p@srheight{}\def\@p@srwidth{}
+		\def\@p@sfile{}
+		\def\@p@scost{10}
+		\def\@sc{}
+		\@prologfilefalse
+		\@postlogfilefalse
+		\@clipfalse
+		\if@noisy
+			\@verbosetrue
+		\else
+			\@verbosefalse
+		\fi
+}
+%
+% Go through the options setting things up.
+%
+\def\parse@ps@parms#1{
+	 	\@psdo\@psfiga:=#1\do
+		   {\expandafter\@setparms\@psfiga,}}
+%
+% Compute bb height and width
+%
+\newif\ifno@bb
+\def\bb@missing{
+	\if@verbose{
+		\typeout{psfig: searching \@p@sfile \space  for bounding box}
+	}\fi
+	\no@bbtrue
+	\epsf@getbb{\@p@sfile}
+        \ifno@bb \else \bb@cull\epsf@llx\epsf@lly\epsf@urx\epsf@ury\fi
+}	
+\def\bb@cull#1#2#3#4{
+	\dimen100=#1 bp\edef\@p@sbbllx{\number\dimen100}
+	\dimen100=#2 bp\edef\@p@sbblly{\number\dimen100}
+	\dimen100=#3 bp\edef\@p@sbburx{\number\dimen100}
+	\dimen100=#4 bp\edef\@p@sbbury{\number\dimen100}
+	\no@bbfalse
+}
+\def\compute@bb{
+		\no@bbfalse
+		\if@bbllx \else \no@bbtrue \fi
+		\if@bblly \else \no@bbtrue \fi
+		\if@bburx \else \no@bbtrue \fi
+		\if@bbury \else \no@bbtrue \fi
+		\ifno@bb \bb@missing \fi
+		\ifno@bb \typeout{FATAL ERROR: no bb supplied or found}
+			\no-bb-error
+		\fi
+		%
+		\count203=\@p@sbburx
+		\count204=\@p@sbbury
+		\advance\count203 by -\@p@sbbllx
+		\advance\count204 by -\@p@sbblly
+		\edef\@bbw{\number\count203}
+		\edef\@bbh{\number\count204}
+		%\typeout{ bbh = \@bbh, bbw = \@bbw }
+}
+%
+% \in@hundreds performs #1 * (#2 / #3) correct to the hundreds,
+%	then leaves the result in @result
+%
+\def\in@hundreds#1#2#3{\count240=#2 \count241=#3
+		     \count100=\count240	% 100 is first digit #2/#3
+		     \divide\count100 by \count241
+		     \count101=\count100
+		     \multiply\count101 by \count241
+		     \advance\count240 by -\count101
+		     \multiply\count240 by 10
+		     \count101=\count240	%101 is second digit of #2/#3
+		     \divide\count101 by \count241
+		     \count102=\count101
+		     \multiply\count102 by \count241
+		     \advance\count240 by -\count102
+		     \multiply\count240 by 10
+		     \count102=\count240	% 102 is the third digit
+		     \divide\count102 by \count241
+		     \count200=#1\count205=0
+		     \count201=\count200
+			\multiply\count201 by \count100
+		 	\advance\count205 by \count201
+		     \count201=\count200
+			\divide\count201 by 10
+			\multiply\count201 by \count101
+			\advance\count205 by \count201
+			%
+		     \count201=\count200
+			\divide\count201 by 100
+			\multiply\count201 by \count102
+			\advance\count205 by \count201
+			%
+		     \edef\@result{\number\count205}
+}
+\def\compute@wfromh{
+		% computing : width = height * (bbw / bbh)
+		\in@hundreds{\@p@sheight}{\@bbw}{\@bbh}
+		%\typeout{ \@p@sheight * \@bbw / \@bbh, = \@result }
+		\edef\@p@swidth{\@result}
+		%\typeout{w from h: width is \@p@swidth}
+}
+\def\compute@hfromw{
+		% computing : height = width * (bbh / bbw)
+		\in@hundreds{\@p@swidth}{\@bbh}{\@bbw}
+		%\typeout{ \@p@swidth * \@bbh / \@bbw = \@result }
+		\edef\@p@sheight{\@result}
+		%\typeout{h from w : height is \@p@sheight}
+}
+\def\compute@handw{
+		\if@height 
+			\if@width
+			\else
+				\compute@wfromh
+			\fi
+		\else 
+			\if@width
+				\compute@hfromw
+			\else
+				\edef\@p@sheight{\@bbh}
+				\edef\@p@swidth{\@bbw}
+			\fi
+		\fi
+}
+\def\compute@resv{
+		\if@rheight \else \edef\@p@srheight{\@p@sheight} \fi
+		\if@rwidth \else \edef\@p@srwidth{\@p@swidth} \fi
+}
+%		
+% Compute any missing values
+\def\compute@sizes{
+	\compute@bb
+	\compute@handw
+	\compute@resv
+}
+%
+% \psfig
+% usage : \psfig{file=, height=, width=, bbllx=, bblly=, bburx=, bbury=,
+%			rheight=, rwidth=, clip=}
+%
+% "clip=" is a switch and takes no value, but the `=' must be present.
+\def\psfig#1{\vbox {
+	% do a zero width hard space so that a single
+	% \psfig in a centering enviornment will behave nicely
+	%{\setbox0=\hbox{\ }\ \hskip-\wd0}
+	%
+	\ps@init@parms
+	\parse@ps@parms{#1}
+	\compute@sizes
+	%
+	\ifnum\@p@scost<\@psdraft{
+		\if@verbose{
+			\typeout{psfig: including \@p@sfile \space }
+		}\fi
+		%
+		\special{ps::[begin] 	\@p@swidth \space \@p@sheight \space
+				\@p@sbbllx \space \@p@sbblly \space
+				\@p@sbburx \space \@p@sbbury \space
+				startTexFig \space }
+		\if@clip{
+			\if@verbose{
+				\typeout{(clip)}
+			}\fi
+			\special{ps:: doclip \space }
+		}\fi
+		\if@prologfile
+		    \special{ps: plotfile \@prologfileval \space } \fi
+		\special{ps: plotfile \@p@sfile \space }
+		\if@postlogfile
+		    \special{ps: plotfile \@postlogfileval \space } \fi
+		\special{ps::[end] endTexFig \space }
+		% Create the vbox to reserve the space for the figure
+		\vbox to \@p@srheight true sp{
+			\hbox to \@p@srwidth true sp{
+				\hss
+			}
+		\vss
+		}
+	}\else{
+		% draft figure, just reserve the space and print the
+		% path name.
+		\vbox to \@p@srheight true sp{
+		\vss
+			\hbox to \@p@srwidth true sp{
+				\hss
+				\if@verbose{
+					\@p@sfile
+				}\fi
+				\hss
+			}
+		\vss
+		}
+	}\fi
+}}
+\def\psglobal{\typeout{psfig: PSGLOBAL is OBSOLETE; use psprint -m instead}}
+\psfigRestoreAt
+
+
+
+
+
+

+ tools/interp/HaskellWorkshop/psinput.tex view
@@ -0,0 +1,12 @@+\input{psfig}				% <---- load psfig macros
+\newcommand{\psinput}[1]{
+  \mbox{\psfig{figure=#1}}}
+\newcommand{\hgap}{\hspace{12pt}}
+\newcommand{\vgap}{\\[12pt]}
+\newcommand{\pscap}[2]{
+  \parbox{2.01in}{
+   \begin{center}
+    \psinput{#1} \\ #2
+   \end{center}
+  }
+}

+ tools/interp/HaskellWorkshop/weirdness.hs view
@@ -0,0 +1,105 @@+module Weirdness where++{- These are examples of the dark corners of Haskell -}++newtype FooStrict = FooStrict Int +data FooLazy = FooLazy Int ++++omega :: Int->Int+omega x = if True then (omega x) else (omega x)++fooS x = (\ (FooStrict n) -> 1) x+fooL x = (\ (FooLazy n) -> 1) x++ex1 = fooS (FooStrict (omega 2))+ex2 = fooL (FooLazy (omega 2))++bot = bot++data D1 = D1 Int+d1 (D1 i) = 42+ex3 = d1 bot+ex5 = D1 bot++newtype N = N Int+n (N i) = 42+ex4 = n bot+ex6 = N bot+++{-++I'm not sure this is an interesting example.++Weirdness> fooS undefined+1+Weirdness> fooL undefined++Program error: {undefined}++Weirdness> fooL (FooLazy (omega 9))+1+Weirdness> fooS (FooStrict (omega 9))+1+-}++{- Here's an example of guards forcing a computational increment -}+data RB = Red Int | Black Int++guard = case (Red (omega 9)) of+          Red x -> "red"+          Black x -> "black"+    --->   "red"++guard' = case (Red (omega 9)) of+          Red x | x==10 -> "red"+          Black x -> "black"+    ---> non-termination++g (Red x) | x==10 = "red"+g (Black x) = "black"++xy | null xy = [1]+   | True = [1,2,3]+   +++{-+++-} +++{---------------------------------------------------------------------+                        Too much sugar will rot your teeth.+                        The following is an example of a +                        semantically un-innocent transformation+ ---------------------------------------------------------------------}+++{-+nodups [] = []+nodups [x] = [x]+nodups (y:(x:xs)) = if x==y then (nodups (x:xs)) else (y:(nodups (x:xs)))+-}++nodupsNP l = case l of+                [] -> []           +                [x] -> [x]+                (y:(x:xs)) -> if x==y then +                                (nodupsNP (x:xs)) +                             else (y:(nodupsNP (x:xs)))++nodups xs'' = case xs'' of+                [] -> []           +                x':xs' -> +                       case xs' of+                         [] -> [x']+                         x:xs -> if x'==x then +                                       (nodups (x:xs)) +                                 else (x':(nodups (x:xs)))+++
+ tools/interp/Monad.hs view
@@ -0,0 +1,123 @@+module Monad where++import AST++----------------------------------------------------------------------+-- Values+----------------------------------------------------------------------++type EnvFrag = [(Name,M Value)]++data Value+  = +--- scalars+    Z Integer+  | BV Bool+--- CBN functions+  | FV (M Value -> M Value)+--- Generic structured data+  | Tagged Name [M Value]+--- values for all tuples:+  | TupleVal [M Value]++data Fix a = Fix (Fix a -> a)+fix = \ f -> (\ (Fix x) -> +                   (f (\ a -> x (Fix x) a)))+                      (Fix (\ (Fix x) -> (f (\ a -> x (Fix x) a))))++showValue :: Value -> String+showValue (Z i) = show i+showValue (BV i) = show i+showValue (FV _) = "(function)"+showValue (Tagged n arglist) = "(Tagged Value)"++instance Show Value where+  show = showValue++----------------------------------------------------------------------+-- Errors+----------------------------------------------------------------------++data Error a = Ok a | Err String++----------------------------------------------------------------------+-- Error monad+----------------------------------------------------------------------+++errUnit :: a -> Error a+errUnit = Ok+++errBind :: Error a -> (a -> Error b) -> Error b+errBind x f = case x of+                     (Ok v) -> f v+                     (Err msg) -> (Err msg)++instance Monad Error where+  return = errUnit+  (>>=) = errBind++showEC x =+       case x of+            (Ok v) -> show v+            (Err msg) -> show msg++showError :: Show a => Error a -> String+showError x =+       case x of+            (Ok v) -> show v+            (Err msg) -> show msg++instance Show a => Show (Error a) where+    show = showError++raise0 = Err++----------------------------------------------------------------------+-- Environments+----------------------------------------------------------------------++type Env = Name -> M Value++----------------------------------------------------------------------+-- M = Environment+Error +----------------------------------------------------------------------++newtype M a = M (Env -> (Error a))++mUnit :: a -> M a+mUnit a = M (\rho -> return a)+++mBind :: M a -> (a -> M b) -> M b+mBind x f =+        M (\rho -> +                 do { v <- (deM x) rho ; deM (f v) rho })++instance Monad M where+  return = mUnit+  (>>=) = mBind++deM (M x) = x++lift :: Error a -> M a+lift ec = M (\ _ ->  ec)++----------------------------------------------------------------------+-- Non-standard Morphisms+----------------------------------------------------------------------++raise :: String -> M a+raise = \msg -> lift (raise0 msg)++rdEnv :: M Env+rdEnv = M (\rho -> return rho)++tweek f x y = \ z -> if x == z then y else f z++xEnv :: Env -> Name -> M Value -> Env+xEnv rho n phi = tweek rho n phi++inEnv :: Env -> M a -> M a+inEnv rho (M x) = M (\ _ -> x rho)
+ tools/interp/NewData.hs view
@@ -0,0 +1,43 @@+type Name = String++data Op = Plus | Mult | IntEq | IntLess++data LS = Lazy | Strict++-- M Value+data E+  = Var Name+  | App E E+  | Abs P E+  | Let [D] E+  | Case E [(P,Body,[D])]+  | PairExp E E+  | TupleExp [E]+  | Const Integer+  | ConApp Name [E] -- ConApp Name [(E,Bool)]+  | NewApp Name E+  | Boom+  | Undefined+--- Above is the "core", below various extras+  | Bin Op E E+  | Cond E E E+  | Tconst +  | Fconst++-- M(Maybe Value)+data Body = Guarded [(E,E)]+           | Normal E++-- M Value -> M(Maybe EnvFrag)+data P = Pconst Integer+       | Pvar Name+       | Ppair P P+       | Ptuple [P]+       | Pcondata Name [P]  +       | Pnewdata Name P+       | Ptilde P++-- M Value -> M Value  OR  EnvFrag+data D = +   Fun Name [([P],Body,[D])]  -- each item in the list   M Value -> M(Maybe Value)+ | Val P Body [D]  -- EnvFrag
+ tools/interp/examples.hs view
@@ -0,0 +1,189 @@++--------------------------------------------------------------------+--- Haskell Weirdness.+--------------------------------------------------------------------++data RedBlack a = Red a | Black a+data OneTwo a b = One a | Two a b+instance Show a => Show (RedBlack a) where+    show = \ x -> case x of +                       Red v -> show v+                       Black v -> show v++omega :: Int -> (Int,Int)+omega = \x -> if True then (omega x) else (omega x)++h0 = (\ (Red x) -> 1) (Black 99)+h1 = (\ (Red (Black x)) -> 1) (Red undefined)+h2 = (\ (Red (Two x (Black y))) -> 1) (Red (Two 1 (Black 9)))+h3 = (\ (Red (Two x (Black y))) -> 1) (Red (Two undefined (Black undefined)))+h4 :: Int+h4 = (\ (Red (Two x (Black y))) -> x) (Red (Two undefined (Black undefined)))++ex1 = case undefined of 1 -> 99        ---> undefined+ex2 = case undefined of x -> 99        ---> 99+ex3 = case undefined of (x,y) -> 99    ---> undefined+ex4 = case undefined of (Red x) -> 99  ---> undefined++++-----------------------------------------------------------+--                      some examples+-----------------------------------------------------------++redpat = \ x -> Pcondata "red" [(Pvar x)]+greenpat = \ x -> Pcondata "green" [(Pvar x)]+blackpat = \ x -> Pcondata "black" [(Pvar x)]+blackexp = \t -> ConApp "black" [t]+redexp = \t -> ConApp "red" [t]+greenexp = \t -> ConApp "green" [t]+pairpat = Ppair (Pvar "x") (Pvar "y")+black = \ x -> ConApp "black" [x]+red = \ x -> ConApp "red" [x]+green = \ x -> ConApp "green" [x]++--------------------------------------------------++dpat = \ x -> Pcondata "D" [(Pvar x)]+d1 = App (Abs (dpat "i") (Const 42)) Boom+   --- run d1 ==> non-termination+d2 = ConApp "D" [Boom]+   --- run d2 ==> "(D..." + non-termination++npat = \ x -> Pnewdata "N" (Pvar x)+n1 = App (Abs (npat "i") (Const 42)) Boom+   --- run n1 ==> 42 (i.e., 'Abs (npat "i") e' behaves like 'Abs "i" e'++n2 = NewApp "N" Boom+   --- run n2 ==> non-termination++--------------------------------------------------++splat phi = (deM phi (\msg -> error "hey - you're applying the empty env!"))+run le =  (deM (eval le) (\msg -> error "hey - you're applying the empty env!"))++--- Important to note that abstraction is neither lazy nor strict+--- +e1 = App (Abs (redpat "x") (Const 1)) (blackexp (Const 19)) ---> error+e2 = App (Abs (redpat "x") (Var "x")) (blackexp (Const 19)) ---> error+e3 = App (Abs (redpat "x") (Var "x")) (redexp (Const 19))   ---> 19+e4 = App (Abs pairpat (Const 4)) (PairExp Boom Boom)        ---> 4+e5 = App (Abs (redpat "x") (Var "x")) Boom                  ---> non-term+e6 = App (Abs (redpat "x") (Var "x")) (ConApp "red" [Boom]) ---> non-term+e7 = App (Abs (redpat "x") (Const 1)) (ConApp "red" [Boom]) ---> 1+e8 = App (Abs pairpat (Var "x")) (PairExp (Const 1) Boom)   ---> 1++l1 = Let [(Pconst 1, Const 0)] (Const 99)                 ---> 99+l2 = Let [(redpat "x", Undefined)] (Const 99)             ---> 99+l3 = Let [(redpat "x", black Undefined)] (Const 99)       ---> 99+l4 = Let [(redpat "x", black Undefined)] (Var "x")        ---> red != black+l5 = Let [(redpat "x", red (Const 99))] (Var "x")         ---> 99+l6 = Let [(redpat "x", black Undefined),+          (redpat "y", green (Const 99))] (Var "x")       ---> red != black+++{-+HaskellCoreLite> let (Red x) = Black 19 in 87+87+HaskellCoreLite> let (Red x) = Black 19 in x++Program error: {v1405 (RedBlack_Black (Num_fromInt instNum_v35 19))}+-}++{- +   BTW, this works with the old def'n of let +   (i.e., dynamic binding with no explicit fixpoints). +-}+evenDef = Abs (Pvar "x") (Cond (Bin IntEq (Var "x") (Const 0)) +                        Tconst+                        (App (Var "odd") (Bin Plus (Var "x") (Const $ -1))))++oddDef =  Abs (Pvar "x") (Cond (Bin IntEq (Var "x") (Const 0)) +                        Fconst+                        (App (Var "even") (Bin Plus (Var "x") (Const $ -1))))+++oddeven = Let [(Pvar "even",evenDef),(Pvar "odd",oddDef)] (App (Var "even") (Const 3))++---this one demonstrates irrefutable patterns+---compare with:+---   e1 = App (Abs (redpat "x") (Const 1)) (blackexp (Const 19)) ---> error++irref0 = App (Abs (Ptilde (redpat "x")) (Const 1)) (blackexp (Const 19))+irref1 = App (Abs (Ptilde (redpat "x")) (Var "x")) (blackexp (Const 19))++v = (z + z) where z = 1 +++c1 = Case Undefined $ [Normal (Pvar "x") (Const 1) []]     ---> 1+c2 = Case Undefined $ [Normal (Pconst 99) (Const 1) []]    ---> Undefined+c3 = Case Undefined $ [Normal (redpat "x") (Const 1) []]   ---> Undefined+c4 = Case (black Undefined) [Normal (redpat "x") (Const 1) []]+                                                           ---> match failure+c5 = Case (red Undefined) [Normal (redpat "x") (Const 1) []]+                                                           ---> 1+{- c6:+data RBG a = Red a | Black a | Green a+foo = let val = Red (Green 1)+      in+      case val of +         (Red x) -> (case x of (Black z) -> 99)+         (Red (Green y)) -> 87+-}+c6body = (Case (Var "val") +            [Normal (redpat "x") +                    (Case (Var "x") [Normal (blackpat "z") (Const 99) []])+                    [],+            Normal (Pcondata "red" [greenpat "y"]) (Const 87) []])++c6 = Let [(Pvar "val", redexp (greenexp (Const 1)))] c6body++--- Simple example of a guarded case statement:+++{-+data Match = Guarded P [(E,E)] [D]+           | Normal P E [D]++c7body = Guarded (Pconst 1)+                         [(Bin IntEq (Const 1) (Const 1), (Const 99))]+                         {- where -} [(Pvar "z",(Const 1))]++c7 = Case (Const 1) [c7body]++-}++c7 = let c7body = Guarded (Pvar "x") +                          [(Bin IntEq (Var "x") (Var "z"), (Const 99))]  +              {- where -} [(Pvar "z",(Const 1))]+     in Case (Const 1) [c7body]++c8 = let c8body = Guarded (Pvar "x")+                          [(Bin IntEq (Var "x") (Var "z"), (Const 99))]+              {- where -} [(Pvar "z",(Const 2))]+     in Case (Const 1) [c8body]++++c9 = +   let+        guardedbody = Guarded (Pvar "x") +                              [(Bin IntEq (Var "x") (Var "z"), (Const 99))]+                              [(Pvar "z",(Const 1))]+        normalbody = Normal (Pvar "y")  (Const 101) []+   in+      Case (Const 1) [guardedbody,normalbody]            ++c10 = +   let+        guardedbody = Guarded (Pvar "x") +                              [(Bin IntEq (Var "x") (Var "z"), (Const 99))]+                              [(Pvar "z",(Const 2))]+        normalbody = Normal (Pvar "y")  (Const 101) []+   in+      Case (Const 1) [guardedbody,normalbody]            ++projy = App (Abs (Ptuple [Pvar "x", Pvar "y", Pvar "z"]) +                         $ Var "y")+                 (TupleExp [Boom, Const 2, Boom])+
+ tools/pfe/._PFE3.hs view
binary file changed (absent → 167 bytes)
+ tools/pfe/Browser/AuxWindowsF.hs view
@@ -0,0 +1,39 @@+module AuxWindowsF where+import AllFudgets+import FudExtras(staticHyperGraphicsF')+import ContribFudgets(delayedAuxShellF)+--import ContribFudgets(menuBarF,subMenuItem,toggleItem,Transl(..))+++auxGfxWindowsF maintitle = auxWindowsF windows+  where+    windows = [(tag,gfxDispShellF (show tag))|tag<-[minBound..maxBound]]++    gfxDispShellF title = delayedAuxShellF longtitle gfxDispF+      where+        longtitle = maintitle++": "++title+	gfxDispF = scrollF (staticHyperGraphicsF' pm initD)+	pm = setSizing Dynamic+        initD = blankD (pP 440 220)++auxWindowsF auxwindows =+    {-loopThroughRightF-} windowsF {-auxWindowsMenuF-}+  where+    windowsF = post >^=< listF auxwindows -- >=^< pre+      where+        --pre (w,Left b) = (w,Left b)+	--pre (w,Right i) = (w,Right i)++	post (w,Left b) = Left (w,b)+	post (w,Right o) = Right (w,o)+{-+    auxWindowsMenuF =+        nameF "AuxWindowsMenu" $+        menuBarF [subMenuItem idT ws "Windows"]+      where+        ws = [wtoggle tag tag|(tag,window)<-auxwindows]+        wtoggle w = toggleItem (tr w) False+	tr w = Transl ((,) w) (\ (w',b) -> if w'==w then Just b else Nothing)++    idT = Transl id Just -- why not this?+-}
+ tools/pfe/Browser/CertAttrsEditorF.hs view
@@ -0,0 +1,42 @@+module CertAttrsEditorF where+import Maybe(fromMaybe)+import Fudgets+import Attrs+import CertAttrs+import CertServers(serverName,certAttrs)++dynCertAttrsEditorPopupsF =+    dynF nullF >=^< mapEither certAttrsEditorPopupsF id++certAttrsEditorPopupsF = listF . map edF+  where+    edF s = (n,attrsEditorPopupF n (certAttrs s))+      where n = serverName s++attrsEditorPopupF ctype attrs =+    post >^=< inputPopupF title (attrsEditorF attrs) Nothing >=^< pre+  where+    title = ctype++" certificate Attribute Editor"++    pre (cname,cattrs) = (Just cname,Just cattrs)+    post ((Just cname,_),attrs) = (cname,attrs)++attrsEditorF :: CertAttrs -> InF Attrs Attrs+attrsEditorF attrs =+    placerF (tableP 2) $+    inputListF [(name,attrEditorF attr)|(name,attr)<-attrs] >=^< pre+  where+    pre cattrs = map (pickattr cattrs) attrs++    pickattr cattrs (aname,attr) =+      (aname,fromMaybe (fromMaybe "" (adefault attr)) (lookup aname cattrs))+++attrEditorF Attr {atype=t,label=lbl} = labelF lbl >*< attrEditorF' t++attrEditorF' t =+  case t of    +    String -> stringF+    File -> stringF -- !!+    Nat -> stringF -- !!!+    Bool -> inputChange.show>^=<spacer1F leftS (toggleButtonF "")>=^<(=="True")
+ tools/pfe/Browser/CertCmd.hs view
@@ -0,0 +1,32 @@+module CertCmd where+import PFE_Certs(CertType,QCertName(..))+import PrettyPrint(Printable(..),pp)++data CertCmd+   = ValidateCert QCertName+   | RemoveCert QCertName+   | NewCert CertType QCertName String+   | NewCertAll CertType String{-ModuleName-}+   | TodoCert+   deriving (Eq,Show)++instance Printable CertCmd where ppi = ppi . shellCmd++--isValidate ValidateCert{} = True+--isValidate _ = False++cmdCert (ValidateCert cert) = Just cert+cmdCert (RemoveCert cert) = Just cert+cmdCert (NewCert ty cert concl) = Just cert+cmdCert _ = Nothing++shellCmd (ValidateCert cert) = "cert validate "++quote (ppqcert cert)+shellCmd (RemoveCert cert) = "cert rm "++quote (ppqcert cert)+shellCmd (NewCert ty cert concl) =+    unwords ["cert new",ty,quote (ppqcert cert),quote concl]+shellCmd (NewCertAll ty mod) = unwords ["cert new -all",ty,mod]+shellCmd TodoCert = "cert todo"++ppqcert (QCertName m c) = pp m++"/"++c++quote s = q++s++q where q="\""
+ tools/pfe/Browser/CertServerF.hs view
@@ -0,0 +1,60 @@+module CertServerF(certServerF,backspace) where+import Fudgets+--import AllFudgets(expandTabs)+import Char(isDigit)+import FudExtras(longTextChoicePopupF)++certServerF =+   loopThroughRightF (absF certServerSP)+	             (delayF shF>+<longTextChoicePopupF)++shF = --teeF show "shF" >==<+      (inputLinesSP -+- inputLinesSP) >^^=< subProcessF "sh" >=^< (++"\n")++certServerSP = loop+  where+    loop = get $ either ignore fromInput++    ignore _ = loop -- ignore output from shell while waiting for a cmd++    fromInput cmd =+      putSh ("LANG=C "++cmd ++ " ; echo +-+ $?") $+      getResult $ \ res ->+      output res $+      loop++getResult cont = loop []+  where+    loop acc = dispatch fromShell fromPopup ignore+      where+        ignore _ = loop acc -- ignore new cmds while a cmd is in progress++        fromShell l =+	  case l of+	    Left ('+':'-':'+':' ':s) | all isDigit s ->+	      cont (s=="0",reverse acc)+	    Right "+-+ Yes No" -> popup (msgTxt acc,("Yes","No")) (loop [])+	    --Right ('+':'-':'+':' ':s) -> cont (s=="0",reverse acc)+	    _ -> loop (mapEither backspace backspace l:acc)++        fromPopup msg = putSh msg (loop acc)++        msgTxt = map stripEither . reverse++output = put . Right+putSh = put . Left . Left+popup = put . Left . Right++dispatch fromShell fromPopup fromInput =+    get $ either (either fromShell fromPopup) fromInput++--confirmString Confirm = "Yes"+--confirmString Cancel = "No"+++-- Interpret the backspace control character:+backspace = bs []+  where+    bs ls ('\b':rs) = bs (drop 1 ls) rs+    bs ls (r:rs) = bs (r:ls) rs+    bs ls [] = reverse ls
+ tools/pfe/Browser/DrawDoc.hs view
@@ -0,0 +1,63 @@+module DrawDoc(drawDoc,toDrawing) where+import FudDraw+import PrettyDoc+import PrettyEnv+import MUtils+import PfeBrowserColors++drawDoc = toDrawing . runEnv defaultMode++toDrawing = conv . trim+  where+    conv d =+      case d of+	Empty -> blankD 0+	Char c -> g c+	Text s -> g s+	Attr t d -> fgD (defaultColor t) (conv d) -- a quick hack+	Nest n d -> indentD (n,conv d) -- hmm+	Group l ds -> group l (map conv' ds)+	  where+	    group l ds =+	      case l of+		Horiz Cat -> hboxcaD' 0 (map snd ds)+		Horiz Sep -> hboxcaD' sep (map snd ds)+		Vert -> vboxlD' 0 (map indentD ds)+		HorizOrVert Cat -> catD ds+		HorizOrVert Sep -> sepD ds+		Fill Cat -> fcatD ds+		Fill Sep -> fsepD ds++    conv' = apSnd conv . splitNest++    noNest = snd . splitNest++    splitNest = splitNest' 0+    splitNest' n (Nest n' d) = splitNest' (n+n') d+    splitNest' n d = (n,d)++    trim d =+      case d of+	Nest n d -> case trim d of+		      Empty -> Empty+		      d -> Nest n d+	Group l ds -> case [ d | d<-map trim ds,nonEmpty d] of+		        [] -> Empty+			[d] -> d+			ds -> Group l ds+	Attr a d -> Attr a (trim d)+        _ -> d++catD = wideOrTallD 0+sepD = wideOrTallD sep++fcatD = paraD 0+fsepD = paraD sep++--paraD = hboxcaD'+--paraD = wideOrTallD+paraD sep = placedD (paragraphP' (Point sep 0)) . boxD . map snd++--rframeD = frameD "red"+--bframeD = frameD "blue"+--frameD c d = stackD [fgD c (g frame),padD 2 d]
+ tools/pfe/Browser/DrawError.hs view
@@ -0,0 +1,35 @@+module DrawError(drawTypeError,drawScopeErrors) where+import FudDraw+import TiError+import DrawDoc+import PfePlumbing(InfoLbl(..),srcLocLbl)+import PrettyPrint(ppi)++drawScopeErrors = vboxlD' 0 . map drawScopeError+drawScopeError (loc,msg) = hboxcaD [drawSrcLoc loc,g ":",drawDoc msg]++drawTypeError m err =+  case err of+    InContext ctx err -> ctxD (drawContext m ctx) (drawTypeError m err)+    Other doc -> drawDoc doc++drawContext m ctx =+  case ctx of+    AtPos loc Nothing -> drawSrcLoc loc+    AtPos loc (Just d) -> hboxcaD [drawSrcLoc loc,drawDoc d]+    DeclCtx is -> hboxcaD (g "In the declaration of":map drawIdent is)+    ModuleCtx ms -> hboxcaD (msg:map (drawModule m) ms)+      where msg = if length ms==1 then g "In module" else g "In modules"+    OtherCtx d ls -> ctxD (drawDoc d) (vboxlD' 0 (map drawLoc ls))+      where+        drawLoc (d,loc) = ctxD (drawDoc d) (hboxcaD [g "from",drawSrcLoc loc])++drawIdent = drawLink DefLbl+drawSrcLoc = drawLink srcLocLbl++drawModule current m =+   if m==current then drawDoc (ppi m) else drawLink ModuleLbl m++drawLink lbl dst = labelD (lbl dst) (ulinkD (drawDoc (ppi dst)))++ctxD d1 d2 = vboxlD' 0 [d1,indentD (2,d2)]
+ tools/pfe/Browser/DrawLex.hs view
@@ -0,0 +1,150 @@+module DrawLex where+import Monad(join)+import List(groupBy)+import Maybe(mapMaybe,fromMaybe)+import Fudgets+import FudDraw(ulineD')+import GIFAltFile+import OpTypes(eqBy)++import PfePlumbing(Label(..),lblPos,Icons,CertsStatus,addRefPos,refPos,assertionDefLbl)+import TokenTags as C+import HsLexerPass1(nextPos1,Pos(..))+import HsTokens as T+import HLexTagModuleNames+import RefsTypes(merge{-,T(..)-})+import PFE_Certs(CertName,certAttrsPath)+import CertServers(parseAttrs)+import HsName(ModuleName(..))+import TypedIds(NameSpace(..))++-- only the position is significant when locating a Label in a drawing+rootLabel = posLabel rootPos+  where rootPos = Pos (-1) (-1) (-1) -- not a valid file position+posLabel p = Lbl ((TheRest,(p,"")),Nothing)+origLabel orig = Lbl ((TheRest,(refPos orig,"")),Just orig)++fakeLex = labelD rootLabel . vboxlD' 0 . map g . map (expand 1) . take 2500 . lines++drawLex dir icons m colorGctx rs cs na =+    if quickfix+    then+     labelD rootLabel . vboxlD' 0 . map g .+     lines . concatMap (snd.snd)+    else+     labelD rootLabel . vboxlD' 0 .+     map (hboxD' 0 . map tokenD . autoAnnot {-. groupSpace-}) .+     take 2500 . -- Show at most 2500 lines !!+    groupBy sameLine . concatMap split . merge (map addRefPos rs) .+    convModuleNames+  where+    -- split tokens that span several lines:+    split ((t,(Pos n y x,s)),r) =+	[Lbl ((t,(Pos n y' x,l)),r)|(y',l)<-zip [y..] (lines (expand x s))]++    sameLine = eqBy (line.lblPos)++    tokenD lbl@(Lbl((t,(p,s)),r)) = markD . labelD lbl . colorD t . g $ s+      where markD =+              case r of+		Just (_,_,defs) | length defs/=1 -> ulineD' "red"+		_ -> id++            colorD t =+	      case t of+		NestedComment ->+		  case isCertAnnot s of+		    Just cert -> const (drawCertIcon dir icons m cs cert)+		    _ -> fgD C.Comment+		Commentstart  -> fgD C.Comment+		T.Comment     -> fgD C.Comment+		LiterateComment -> fgD C.Comment+		Reservedid    -> fgD Reserved+		Reservedop    -> fgD Reserved+	        Special       -> fgD Reserved+	        Specialid     -> fgD Reserved+		Conid         -> con r+		Qconid        -> con r+		Varsym        -> fgD VarOp+		Qvarsym       -> fgD VarOp+		Consym        -> fgD ConOp+		Qconsym       -> fgD ConOp+		IntLit        -> fgD Lit+		FloatLit      -> fgD Lit+		StringLit     -> fgD Lit+		CharLit       -> fgD Lit+		_             -> id+    fgD = hardAttribD . colorGctx++    con = maybe id (fgD . rcolor)+    rcolor ((_,sp),_,_) = if sp==ValueNames then Con else TCon++    autoAnnot ts = ts++autoannots+      where+        autoannots = map (nestedComment dummyPos.certAnnot) certs+	certs = concatMap (fromMaybe [] . flip lookup na) as+        as = mapMaybe assertionDefLbl ts+        dummyPos = lblPos (last ts)++    certAnnot cert = "{-#cert:"++cert++"#-}"+    nestedComment p s = Lbl ((NestedComment,(p,s)),Nothing)++{-+    groupSpace [] = []+    groupSpace (lbl@(Lbl((t,(p,s)),r)):ts) =+	 if isWhite lbl+	 then case span isWhite ts of+		(ws,ts') -> Lbl((t,(p,s++concatMap str ws)),r):groupSpace ts'+	 else lbl:groupSpace ts+       where+         str (Lbl((_,(_,s)),_)) = s++         isWhite (Lbl((Whitespace,(p,s)),r)) = all isSpace s+         isWhite _ = False+-}++drawCertIcon :: FilePath -> Icons -> ModuleName -> CertsStatus -> CertName ->+	        Drawing lbl Gfx+drawCertIcon dir (sad,icons) m cstatus cert =+    g (fileGfxAlt certIcon (certAttrsPath m cert dir) sad)+  where+    certIcon s =+     case (`lookup` icons) =<< lookup "type" (parseAttrs s) of+       Just cicons -> Right (cstatusIcon cicons (join (lookup cert cstatus)))+       _ -> Left "bad cert/unknown cert type"++certIcon (sad,icons) (cert,(Just attrs,cstatus)) =+  case (`lookup` icons) =<< lookup "type" attrs of+    Just icons -> cstatusIcon icons cstatus+    _ -> sad+certIcon (sad,_) _ = sad++cstatusIcon (valid,invalid,unknown) cstatus =+  case cstatus of+    Just (isvalid,_) -> if isvalid then valid else invalid+    _ -> unknown++-- isCertAnnot :: Monad m => String -> m CertName+isCertAnnot s =+  do '{':'-':'#':'c':'e':'r':'t':':':r <- return s+     '}':'-':'#':f <- return (reverse r)+     return (reverse f)++{- Why use "case" when you can use "do"? :-)+isCertAnnot s =+  case s of+    '{':'-':'#':'c':'e':'r':'t':':':r ->+        case reverse r of+          '}':'-':'#':f -> Just (reverse f)+          _ -> Nothing+    _ -> Nothing+-}++expand x "" = ""+expand x (c:s) =+    case c of+      '\t' -> replicate (x'-x) ' '++expand x' s+      _ -> c:expand x' s+  where Pos _ _ x' = nextPos1 (Pos 0 1 x) c++quickfix = argFlag "quickfix" False
+ tools/pfe/Browser/Flags.ghc view
@@ -0,0 +1,8 @@+FudgetIOMonad.hs: -fno-monomorphism-restriction+PfeBrowserF.hs: -fno-monomorphism-restriction+PfeBrowserGUI.hs: -fno-monomorphism-restriction+PfeBrowserMonad.hs: -fno-monomorphism-restriction+IdInfo.hs: -fno-monomorphism-restriction+HistoryButtonsF.hs: -fno-monomorphism-restriction+AuxWindowsF.hs: -fno-monomorphism-restriction+PfeBrowserMenu.hs: -fno-monomorphism-restriction
+ tools/pfe/Browser/FudDraw.hs view
@@ -0,0 +1,39 @@+module FudDraw(module F,module FudDraw) where+import AllFudgets as F(+  Point(..),g,hFiller,+  fgD,blankD,vboxlD',hboxD,placedD,spacedD,boxD,labelD,stackD,+  paragraphP',ifSizeP,verticalP',spacersP,horizontalAlignP',+  idS,hMarginS,centerS,bottomS)++ulinkD s = fgD "blue" $+           spacedD centerS $+           stackD [spacedD bottomS (g (hFiller 1)),s]++ulineD' color s = spacedD centerS $+                  stackD [fgD color $ spacedD bottomS (g (hFiller 1)),s]++hboxcaD = hboxcaD' sep+hboxcaD' sep = placedD (horizontalAlignP' sep) . boxD++wideOrTallD sep nds = placedD (wideOrTallP sep ns) (boxD ds)+  where (ns,ds) = unzip nds++wideOrTallP sep ns = ifSizeP cmp wideP (tallP ns)+  where+    wideP = horizontalAlignP' sep+    tallP ns = verticalP' 0 `spacersP` map indentS ns++    cmp (Point w1 _) (Point w2 _) =+      w1<=maxwidth || w1-w2<150 && w2>9*w1 `div` 10+++--indentD n = fgD "grey85" (filledRectD (pP (sep*n) 5))+indentD (0,d) = d+indentD (n,d) = spacedD (indentS n) d++indentS 0 = idS+indentS n = hMarginS (sep*n) 0+++sep = 6 -- show be determined from the font+maxwidth = 500
+ tools/pfe/Browser/FudExtras.hs view
@@ -0,0 +1,58 @@+module FudExtras where+import AllFudgets+++--longTextPopupF = longTextPopupF' okButtonF+longTextPopupF = stripEither >^=< popupsF >=^< route+  where+    popupsF = messagePopupF >+< longTextPopupF' okButtonF++    route msg = (if length msg <= 1 then Left else Right) msg++longTextConfirmPopupF = longTextPopupF' buttonsF+  where+    buttonsF = post>^=<hBoxF (okButtonF>+<cancelButtonF)+    post = either (const Confirm) (const Cancel)++longTextChoicePopupF =+    post >^=< longTextPopupF'' buttonsF (concatMapSP pre)+  where+    post ((txt,(lbl1,lbl2)),choice) = either (const lbl1) (const lbl2) choice++    pre (txt,(lbl1,lbl2)) = [Right (Left lbl1),Right (Right lbl2),Left txt]++    buttonsF = hBoxF (dynButtonF "Yes" >+< dynButtonF "No")+    dynButtonF lbl = buttonF'' standard lbl >=^< Left . setLabel++---+longTextPopupF' buttonsF = longTextPopupF'' buttonsF (mapSP Left)++longTextPopupF'' buttonsF pre =+  popupShellF "Confirm" Nothing+    (filterRightSP>^^=< vBoxF (moreF>+<buttonsF)>=^^<pre)++okButtonF = spacer1F leftS $ kbuttonF "Return" "OK"+cancelButtonF = spacer1F rightS $ kbuttonF "Escape" "Cancel"++kbuttonF k = buttonF' (setKeys [([],k)])++---++-- Like popupMenuF, but allow you to specify which button should pop up the menu+popupMenuF' button alts f =+    mapEither fstEqSnd id>^=<+    oldPopupMenuF bgColor True menuFont (Button button) [] []+                  (pre alts) sndEqSnd f+    >=^< mapEither pre id+  where+    pre = map (`pair` []) . toEqSnd+++newtype NoEq a = NoEq a +instance Eq (NoEq a) where _==_ = True++staticHyperGraphicsF' pm initD =+    post >^=< hyperGraphicsF' pm initD>=^<Left . pre+  where+    pre = mapLabelDrawing NoEq+    post (NoEq lbl) = lbl
+ tools/pfe/Browser/FudgetIOMonad.hs view
@@ -0,0 +1,71 @@+module FudgetIOMonad where+import Prelude hiding (readFile,writeFile,+		       putStr,putStrLn,getLine,readLn,print,+		       catch,ioError)+import AllFudgets+import AbstractIO+import DialogueIO as D+import MUtils+import MT (MT(..))++newtype FIOM f i o a = M {unM::(a->f i o)->(D.IOError->f i o)->f i o}++runFIOM (M m) = m (const end) (error.show)++instance Functor (FIOM f i o) where+  fmap f (M m) = M $ \ c h -> m (c.f) h++instance Monad (FIOM f i o) where+  return x = M $ \ c h -> c x+  M m1>>=xm2 = M $ \ c h -> m1 (\x->unM (xm2 x) c h) h+  fail s = M $ \ c h -> h (OtherError s)+--------------------------------------------------------------------------------++getFM = M $ \ c h -> get c+putFM x = M $ \ c h -> put x (c ())++{- -- This causes weird type checking problems with GHC. Overlapping instances?+class Monad m => SPIO m i o | m -> i o where+  putM :: o -> m ()+  getM :: m i++instance StreamProcIO f => SPIO (FIOM f i o) i o where+  putM = putFM+  getM = getFM++instance (Monad (t m),MT t,SPIO m i o) => SPIO (t m) i o where+  putM = lift . putM+  getM = lift getM+-}+--------------------------------------------------------------------------------++instance FudgetIO f => FileIO (FIOM f i o) where+  readFile = strIO . ReadFile+  writeFile path s = succIO (WriteFile path s)++instance CatchIO D.IOError (FIOM f i o) where+  M m `catch` h = M $ \ c h' -> m c (\e->unM (h e) c h')+  ioError e = M $ \ _ h -> h e++instance FudgetIO f => DirectoryIO (FIOM f i o) where+  createDirectory path = succIO (CreateDirectory path "")+  removeFile = succIO . DeleteFile+  getDirectoryContents = strListIO . ReadDirectory+  doesDirectoryExist path = (((==)"d").take 1) # statusFile path++statusFile = strIO . StatusFile++instance FudgetIO f => SystemIO (FIOM f i o) where+  system cmd = succIO (System cmd) >> return ExitSuccess -- !!+++instance IOErr D.IOError where+  isDoesNotExistError (ReadError _) = True+  isDoesNotExistError _ = False++--------------------------------------------------------------------------------++strIO req = ansIO req (\(Str s)->s)+strListIO req =ansIO req (\(StrList s)->s)+succIO req = ansIO req (\Success->())+ansIO req proj = M $ \ c h -> hIOerr req h (c.proj)
+ tools/pfe/Browser/FudgetIOMonad1.hs view
@@ -0,0 +1,105 @@+module FudgetIOMonad1 where+import Prelude hiding (readFile,writeFile,+		       putStr,putStrLn,getLine,readLn,print,+		       catch,ioError)+import AllFudgets as F+import AbstractIO as A+import DialogueIO as D+import MUtils+--import MT++import PfePlumbing+++{-++To avoid a problem with overlapping instances in the MT class,+the types of the streams are hardwired...+-}+type PfeF = F In (Either String Out)++newtype FIOM a = M {unM::(a->PfeF)->(D.IOError->PfeF)->PfeF}++runFIOM (M m) = m (const end) (error.show)++instance Functor FIOM where+  fmap f (M m) = M $ \ c h -> m (c.f) h++instance Monad FIOM where+  return x = M $ \ c h -> c x+  M m1>>=xm2 = M $ \ c h -> m1 (\x->unM (xm2 x) c h) h+  fail s = M $ \ c h -> h (OtherError s)+--------------------------------------------------------------------------------++getFM = M $ \ c h -> get c+putFM x = M $ \ c h -> put x (c ())++quitFM = succIO (Exit 0)++{-+class Monad m => SPIO m where+  putM :: Out -> m ()+  getM :: m In++instance SPIO FIOM where+  putM = putFM+  getM = getFM++instance (Monad (t m),MT t,SPIO m) => SPIO (t m) where+  putM = lift . putM+  getM = lift getM+-}+--------------------------------------------------------------------------------++instance FileIO FIOM where+  readFile = strIO . ReadFile+  writeFile path s = succIO (WriteFile path s)++instance StdIO FIOM where+  putStr s = succIO (AppendChan "stdout" s)+  ePutStr s = succIO (AppendChan "stderr" s)++instance CatchIO D.IOError FIOM where+  M m `catch` h = M $ \ c h' -> m c (\e->unM (h e) c h')+  ioError e = M $ \ _ h -> h e++instance DirectoryIO FIOM where+  createDirectory path = succIO (CreateDirectory path "")+  removeFile = succIO . DeleteFile+  getDirectoryContents = strListIO . ReadDirectory+  doesDirectoryExist path = catchFalse $ (((==)"d").take 1) # statusFile path+  doesFileExist path = catchFalse $ (((==)"f").take 1) # statusFile path+  getModificationTime path = M $ flip (F.getModificationTime path)++statusFile = strIO . StatusFile+catchFalse io = io `catch` const (return False)++instance SystemIO FIOM where+  --system cmd = succIO (System cmd) >> return ExitSuccess -- !!+  system cmd = M $ \ c h -> hIOerr (System cmd) (c.exitcode)+					        (c.const ExitSuccess)+    where exitcode (OtherError s) = ExitFailure . read . last .  words $ s+          exitcode _ = ExitFailure 99 -- hmm+  getEnv = strIO . GetEnv+  getProgName = return progName+  getArgs = return args -- Does not include options!++instance TimeIO FIOM where+  getClockTime = xrequestFIOM getTime++instance IOErr D.IOError where+  isDoesNotExistError (ReadError _) = True+  isDoesNotExistError _ = False+  ioeGetErrorString err =+    case err of+      OtherError s -> s+      _ -> show err -- hmm!+  userError = OtherError -- hmm!+  isUserError _ = False++--------------------------------------------------------------------------------++strIO req = ansIO req (\(Str s)->s)+strListIO req =ansIO req (\(StrList s)->s)+succIO req = ansIO req (\Success->())+ansIO req proj = M $ \ c h -> hIOerr req h (c.proj)+xrequestFIOM req = M $ \ c h -> req c
+ tools/pfe/Browser/GIFAltFile.hs view
@@ -0,0 +1,31 @@+-- This file belongs in Fudgets/Internet/Lib/images...+module GIFAltFile where+import AllFudgets+import GIFparser+import GIFdecompress+import ImageGraphics+import DialogueIO++gifFileAlt = fileGfxAlt parseGifImage++parseGifImage s =+  case parseGIF s of+    Right gif -> Right (GIFImage Nothing (decompressGIF gif))+    Left msg -> Left msg++data FileGfxAlt altgfx gfx+  = FileGfxAlt (String->Either String gfx)+               FilePath+	       (DialogueIO.IOError->altgfx)++fileGfxAlt parse path alt = FileGfxAlt parse path (const alt)+fileGfx parse path = FileGfxAlt parse path (error.show)++instance (Graphic altgfx,Graphic gfx) => Graphic (FileGfxAlt altgfx gfx) where+  measureGraphicK (FileGfxAlt parse path alt) gctx k =+      hIOerr (ReadFile path) err $ \ (Str s) ->+      case parse s of+	Left msg -> err (OtherError msg)+	Right gfx -> measureGraphicK gfx gctx k+    where+      err e = measureGraphicK (alt e) gctx k
+ tools/pfe/Browser/HEADER.html view
@@ -0,0 +1,20 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<head>+<title>Programatica Tools, tools/pfe/Browser</title>+<link rel=parent href="../" title="Programatica Tools">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../../web/icon1.png">+</head>+<body>+<h1><img align=right src="../../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/pfe/Browser</h2>++<p>+The README file is displayed below the directory index.+<!--+<p>+See also the <a href="pfe.cgi">HTML version of the source code for pfe</a>.+-->
+ tools/pfe/Browser/HistoryButtonsF.hs view
@@ -0,0 +1,86 @@+module HistoryButtonsF where+import AllFudgets hiding (StreamProcIO(..))+import ReactiveF+import Monad(when)++-- Mostly taken from WWWBrowser...++historyButtonsF = loopThroughRightF ctrlF buttonsF+  where+    ctrlF = getFirst $ reactiveF ctrl . state0+    state0 first = ([],first,[])++    getFirst cont = getF $ either (\ _ -> getFirst cont) $+			   either cont (\ _ -> getFirst cont)++    ctrl = either fromButtons fromOutside+    fromButtons = either fromBack fromForward++    output = put . Right+    changeback = put . Left . Left+    changeforward = put . Left . Right++    set' (bs,cur,fs) =+       do set (bs,cur,fs)+	  changeback bs+	  changeforward fs++    goForward 0 h = return h+    goForward n (_,_,[]) = rfail+    goForward n (bs,cur,f:fs) = goForward (n-1) (cur:bs,f,fs)++    goBack n h = fliph `fmap` goForward n (fliph h)+    fliph (bs,cur,fs) = (fs,cur,bs)++    fromBack n = setput =<< goBack n =<< get+    fromForward n = setput =<< goForward n =<< get+    setput h@(_,cur,_) = set' h >> output cur++    fromOutside (Left new) =+        do (bs,cur,fs) <- get+	   when (cur==new) rfail+	   set' (cur:bs,new,[])++    fromOutside (Right new) =+        do (bs,cur,fs) <- get+	   set' (bs,new,fs)++    buttonsF = mbuttonF kl lArrowD >+< mbuttonF kr rArrowD+      where+         kl = k "Left"; kr = k "Right";+         k sym = setKeys [([Mod1],sym)]::Customiser (ButtonF a)++    mbuttonF keys lblf =+        post >^=< popupMenuF [] (dbuttonF keys lblf) >=^^< concatMapSP pre+      where+        pre alts = [Left (zip [1..limit] alts),Right (null alts)]+	limit = 30 -- maximum number of menu entries+	post = either id (const 1)++    dbuttonF keys lblf =+       buttonF'' keys (lblf True) >=^< Left . setLabel . lblf >=^^< idempotSP++    lArrowD = arrowD pts r+      where+	r = rR 12 3 4 4++    rArrowD = arrowD pts' r+      where+	pts' = [pP 16 10 - p | p<-pts]+	r = rR 0 3 4 4++    arrowD pts r disabled =+	spacedD (hvMarginS m m) $+	if disabled then outlineD else stackD [fillD,outlineD]+      where+        fillD =+	  fgD "white" $ fd [FillPolygon Convex CoordModeOrigin pts,+			     FillArc r 0 (64*360)]+        outlineD =+	  fgD ["blue4","#0000cc","black"] $+	      fd [DrawLines CoordModeOrigin pts,DrawArc r 0 (64*360)]++	m = Point 1 2+	fd = g . FixD (Point 17 11)++    pts = [pP 0 5,pP 5 0,pP 5 3,pP 10 3,pP 10 7,pP 5 7,pP 5 10,pP 0 5]
+ tools/pfe/Browser/HuMakefile view
@@ -0,0 +1,10 @@+PFE_DIR=..+BASE=../../base+PROP=../../property+. $PROP/HuMakefile+SRC_DIRS=.:$SRC_DIRS+#LIB_DIRS=InternetLib+GHCFLAGS="-cpp $GHCFLAGS -package lang"++#LDFLAGS="InternetLib/libInternetLib.a $LDFLAGS"+#LDFLAGS="-LInternetLib -lInternetLib $LDFLAGS"
+ tools/pfe/Browser/IdInfo.hs view
@@ -0,0 +1,64 @@+module IdInfo where+import PrettyPrint(pp)+--import HsIdent(getHSName)+--import HsModule(ModuleName(..))+import HsTokens+import PfePlumbing(refPos)+import UniqueNames(optOrigModule)+import QualNames(getQualified)+import HasBaseName(getBaseName)+--import RefsTypes+--import PFE0(ModuleFixities)+--import FudgetIOMonad1(SrcToken)+--import ParsedSyntax(Id)++import Maybe(fromMaybe)+import MUtils(( # ),mapFst)++--idInfo :: Refs -> ModuleFixities Id -> SrcToken -> [String]+idInfo refs infixes ((t,(p,s)),optref) =+    case optref of+      Just ((r,_),_,defs) {- | s'==s -} ->+	  (occurences,def,showDefs defs ++ infixinfo)+	where+          showDefs [] = [s++": "++"not in scope??"]+	  showDefs defs = map showDef defs++	  def = case defs of+		  [o] -> Just o+		  _ -> Nothing+	  occurences =+	    maybe [] (\o->[refPos r|r@(_,_,[o'])<-refs,o'==o]) def++          showDef (o,t') = {-show r++" "++-}s++": "++shO o++", "++pp t'+          {-+	  orig (Co t) = ", constructor of "++t+	  orig (Fi t) = ", field of "++t+	  orig (Me t) = ", method of "++t+	  orig V = ""+	  orig T = ", a type"+	  orig Cl = ", a class"+	  -}++	  infixinfo =+	    case defs of+	      [(qn,_)] ->+		fromMaybe [""] $+		do m <- optOrigModule qn+		   is <- mapFst getBaseName # lookup m infixes+		   fixity <- lookup (getBaseName.getQualified$ qn) is+		   return [pp fixity]+	      _ -> [""]++      --Just (s',r,_,defs) -> ([],Nothing,["?? "++s'++" /= "++s])+      _ -> ([],Nothing,+	       if t==TheRest+	       then []+	       else [show t++" at "++show p])+  where+    shO n = case optOrigModule n of+	      Just m -> pp m++"."++pp (getQualified n)+	      _ -> pp n++" (local)" -- improve!!+    --shO = either shQ shL+    --shQ (m,n)=m++"."++n+    --shL (path,p) = "local at "++show p
+ tools/pfe/Browser/Makefile view
@@ -0,0 +1,38 @@++TARGETS=pfebrowser++### Optimization and other compiler options:+#OPT=-O2+OPT=-O+#OPT=+ILIB=-package-conf InternetLib/package.conf -package internetlib -iInternetLib+#ILIB=-iInternetLib -ld InternetLib/libInternetLib.a+#ILIB=-package internetlib+HFLAGS=++### Tools:+RM=rm -f+HMAKE=sh ../../scripts/hsfudmake.sh -contrib++################################################################################+### Rules for compiling the programs++all: $(TARGETS)++pfebrowser::+	@$(MAKE) InternetLib+	@sh ../../scripts/updateNow.sh ../Now.hs+	@$(MAKE) -C ../../property/parse2+	$(HMAKE) $(OPT) $(HFLAGS) $(ILIB) $@ -o $@++InternetLib:+	@echo "You need to create a link to where InternetLib is installed:"+	@echo "   ln -s .../InternetLib InternetLib"+	@exit 1++################################################################################+### Rules for cleaning up++clean:+	rm -rf $(TARGETS)+	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'
+ tools/pfe/Browser/PfeBrowserCerts.hs view
@@ -0,0 +1,287 @@+module PfeBrowserCerts where+import Prelude hiding (putStr,putStrLn,print,readFile,ioError,catch,readIO)+import AllFudgets as Fud hiding (getModificationTime)+import FudDraw+import Maybe(isJust,listToMaybe,mapMaybe)+import MUtils+import AbstractIO+import FileUtils(readFileNow)+import DirUtils(latestModTime)+import List((\\))++import PfePlumbing+import PfeBrowserMonad+import PPU(pp{-,ppi,ppu,withPPEnv,($$),(<>),(<+>),PPHsMode-})+import PFE0+import PFE_Certs+import CertCmd+import CertServers(certFiles,lookupServer)+import PfePropCmds(tassertionSignature)+import CertAttrs(label)+import DrawLex(cstatusIcon,certIcon)+import QualNames(getQualified)+import TypedIds+import HsIdent(HsIdentI(..))+import TiNames(topName)++{-+ #evidenceGfx#: this function computes the table that is shown in the+Evidence window. Every existing certificate, certificate annotation and+assertion will be mentioned in one of the table entries.+-}+evidenceGfx m dir (bad,icons) certs asserts =+    htableD hdrs (concatMap certD certs++concatMap missingD missing)+  where+    hdrs = ["Icon","Name","Sequent (or other info)"]+    missing = [a|(a,_)<-asserts,pp a `notElem` concs]+    concs = mapMaybe (lookup "conc" @@ fst.snd) certs++    missingD a = [g bad,createCertD "" s,"?" |- HsCon a]+      where s = pp a++    certD (cert,(optattrs,status)) =+      case optattrs of+	Nothing -> [g bad,certNameD cert,+		    g "certificate does not exist (not created yet?)"]+	Just attrs ->+	  case (`lookup` icons) =<< lookup "type" attrs of+	    Just cicons ->+		[certIconD cert icon,certNameD cert, hyp |- a]+	      where+		icon = cstatusIcon cicons status+	    _ -> [g bad,certNameD cert,g "bad cert/unknown cert type"]+	  where+	    conc = fromMaybe "-" (lookup "conc" attrs)+	    hyp = fromMaybe "" (lookup "hyp" attrs)+	    --sequent = conc++" -| "++hyp+	    a = HsCon (topName Nothing m conc Assertion)++    certIconD cert icon = labelD (CertLbl cert) (g icon)++    hyp |- conc = hboxcD [g hyp,g "|-", assertionD conc]++    assertionD a = labelD (DefLbl a) (ulinkD (g (pp a)))++{-+ #getAssertionInfo#: compute the extra info that is shown when the user+clicks on an assertion name.+-}+getAssertionInfo (n,Assertion) =+  do allcs <- certs # getStBr+     cicons <- icons # getStBr+     let a = pp (getQualified n)+	 certs = [c|c@(_,(Just attrs,_))<-allcs,lookup "conc" attrs==Just a]+	 newc = head ((a:[a++show n|n<-[1..]])\\map fst allcs)+	 cis = [(cert,certIcon cicons cert)|cert<-certs]+     return [hboxcD' 10 (g "Certificates:":+			 (if null certs+			 then [g "none."]+			 else map certNameIconD cis)+			 ++[createCertD newc a])]+getAssertionInfo _ = return []+++{-+ #visibleStatusChange#: calling #showCertInfo# or #showQCertInfo# can+cause the status of a certificate to be updated. This function returns true+when the status of a certificate in the current module changed, in which+case certificate icons should be redrawn and the internal state should be+updated.+-}+statusChange cert =+  do m <- modname # getStBr+     newstatus <- fmap fst # certStatus m cert+     oldstatus <- ((fmap fst . snd) # ) . lookup cert . certs # getStBr+     return $ Just newstatus/=oldstatus++{-+ #showCertInfo#: computes the certificate information displayed when the+user clicks on a certificate icon. This includes checking whether the+certificate is valid, invalid or outofdate.+-}+showCertInfo cert =+  do m <- modname # getStBr+     showQCertInfo (QCertName m cert)++showQCertInfo qcert =+    maybe idle inProgress . listToMaybe . certInProgress =<< getStBr+  where+    idle = showQCertInfo' qcert+    inProgress cmd =+      case cmdCert cmd of+        Just qcert' -> inProgress' cmd qcert'+	_ -> idle+    inProgress' cmd qcert' =+      if qcert'==qcert+      then popupCertInfo qcert $+	     spacedD centerS $+	     vboxD [g $ "Certificate server command in progress:",+		    g (shellCmd cmd)]+      else idle++showQCertInfo' qcert =+    do certinfo <- getCertDescription qcert+       pfePut (toRefs (linesD (briefTxt certinfo)))+       popupCertInfo qcert (fullGfx certinfo)+  where+    briefTxt (Left (msg,actionD)) = [g msg,actionD]+    briefTxt (Right (fields,_)) = map (g.join) (take 3 fields)+      where join (x,y) = x++": "++y++    fullGfx (Left (msg,actionD)) = vboxD [Fud.g msg,actionD]+    fullGfx (Right (fields,actionD)) =+	vboxD [htableD ["Field","Value"] flatfields,actionD]+      where flatfields = concatMap (\(x,y)->[g x,g y]) fields++    getCertDescription (QCertName m cert) =+      withWaitCursor $ +      do let msg =g ("Checking status of certificate "++cert)+         putInfoWindow (CertInfo,msg)+	 pfePut (toRefs msg)+         dir <- checkProject+	 servers <- certServers # getStBr+	 (revalidate,status,info) <- certUpdStatus dir m =<< certInfo m cert+	 --let status = "Unknown"+	 optlogfile <- do let logfile = certDiagnosticsPath m cert dir+			  r <- try (readFileNow logfile)+			  return $ case r of+			             Right txt@(_:_) -> Just txt+			             _ -> Nothing++         return (certDescription (m,revalidate,optlogfile,status,servers) info)++    certDescription _ (cert,(Nothing,_)) =+        Left (cert++": certificate does not exist (not created yet?)", actionD)+      where+        actionD = createCertD cert ""++    certDescription (m,revalidate,optlogfile,status',servers)+                    (cert,(Just attrs,status)) =+      Right ([("Certificate",(cert++" :: "++ctype)),+              ("Current Status",status')]+--	     ++ cfield "Certifies" "conc"+--	     ++ cfield "Depends on" "hyp"+	     ++ showStatus status+	     ++ concat [cfield (label attrs) name|(name,attrs)<-cattrs]+	     ++ cfield "Created by" "who"+	     ++ sfield "About this certificate type" "description",+	     actionD)+      where+	showStatus Nothing = cfield "Date" "date"+	showStatus (Just (valid,when)) =+          [("Marked "++(if valid then "" else "in")++"valid on",show when)]++        ctype = fromMaybe "missing!!" (lookup "type" attrs)+	optserver = lookupServer servers ctype+	sattrs = maybe [] serverAttrs optserver+	cattrs = maybe [] certAttrs optserver+        cfield = field attrs+	sfield = field sattrs+        field attrs hdr name = maybe [] ((:[]).((,) hdr)) (lookup name attrs)++        actionD = hboxD' 20 (revalD++editD++logfileD++removeD)+          where+	    revalD  = if revalidate then [cmdD reval "Validate"] else []+	    removeD = [cmdD rm "Remove"]+	    logfileD = maybe [] logfile optlogfile+	      where+                logfile txt= [cmdD' (CertShowText txt) "View diagnostic output"]+	    editD =+	      if isJust optserver+	      then [cmdD' (CertEdit (ctype,(cert,attrs))) "Edit"]+	      else []++            cmdD  = cmdD' . CertCmd+            cmdD' cmd lbl = labelD cmd (ulinkD (g lbl))++            reval = ValidateCert mcert+	    rm    = RemoveCert mcert+	    mcert = QCertName m cert++    --showType = pfePut . toRefs @@ getType++revalidateAll =+    withWaitCursor $+    do dir <- checkProject+       m <- modname # getStBr+       mapM_ (certUpdStatus dir m @@ certInfo m . fst) . certs =<< getStBr++certUpdStatus dir m info@(cert,(a@(Just attrs),Just (valid,when))) =+    ifM auxchange (revalidate "auxiliary file changed/missing") $+    ifM srcchange+	(if valid+	 then certStatusFromSig+	 else revalidate "was invalid, some source file has been changed") $+    return (not valid,if valid then "Valid" else "Invalid",info)+  where+    auxchange = let auxfiles = certAuxFiles m cert attrs dir+		in anyChangeSince when auxfiles+    srcchange = do srcfiles <- map fst # getSubGraph (Just [m])+		   anyChangeSince when srcfiles -- not cached??++    revalidate why = return (True,"Needs revalidation ("++why++")",info)++    isUnconditionalCert =+      case (lookup "conc" attrs,lookup "hyp" attrs) of+	(Just conc,Just "..") -> Just conc+	_ -> lookup "test" attrs -- TestCase++    certStatusFromSig =+	maybe unknownStatus uncondCertStatusFromSig isUnconditionalCert++    unknownStatus = return (True,"unknown",info)++    uncondCertStatusFromSig conc =+      do optcertsig <-+	   maybeM (readIO =<< readFile (certDir m cert dir++"/deps"))+	 case optcertsig of+	   Nothing -> return (True,"New, not yet validated",info)+	   Just certsig ->+	     do srcsig <- tassertionSignature ((m,conc),Nothing)+		if certsig==srcsig+		  then do markValid m cert+			  st <- certStatus m cert+			  return (False,"Valid",(cert,(a,st)))+		  else revalidate "source changed"++    -- vaid/invalid status missing:+certUpdStatus _ _ info@(_,(Just _,_)) =+    return (True,"New, not yet validated",info)++    -- attributes missing:+certUpdStatus _ _ info = return (False,"unknown (attributes missing?!)",info)++quickCertsStatus m certs dir =+  do srcdate <- latestModTime . map fst =<< getSubGraph (Just [m])+     mapM (quickCertStatus m srcdate dir) certs++quickCertStatus m srcdate dir cert =+  do (optattrs,status) <- snd # certInfo m cert+     case (,) # optattrs <# status of+       Nothing -> return Nothing+       Just (attrs,status@(valid,when)) ->+	 if srcdate>when+	 then return Nothing+	 else ifM (anyChangeSince when (certAuxFiles m cert attrs dir))+		  (return Nothing)+		  (return (Just status))++--allCertFiles m cert dir = (++) # certAuxFiles m cert dir <# certSrcFiles m+certAuxFiles m cert attrs dir = certAttrsPath m cert dir:certFiles attrs+--certSrcFiles m = map fst # getSubGraph [m]++createCertD cert concl = labelD (CreateCert (cert,concl))+			        (ulinkD (g "Create a new certificate!"))++certNameD cert = labelD (CertLbl cert) (ulinkD (g cert))++certNameIconD ((c,_),icon) = labelD (CertLbl c) (hboxD [ulinkD (g c),g icon])++htableD hdrs cells = tableD' 0 (length hdrs) (map b hdrs++map f cells)+  where+    b x = stackD [fgD "grey" (g $ filler False False 5),padD 3 (g x)]+    f x = stackD [fgD "grey" (g frame),padD 3 x]+    --f x = padD 3 x++linesD = fontD defaultFont . vboxlD' 0 -- . map g++anyChangeSince when paths =+   ifM (allM doesFileExist paths)+       ((when<) # latestModTime paths)+       (return True) -- a file has been deleted
+ tools/pfe/Browser/PfeBrowserColors.hs view
@@ -0,0 +1,40 @@+module PfeBrowserColors(Color,TokenTag(..),loadColorsF,defaultColor) where+import Array+import Fudgets+import Char(toLower)+import TokenTags++type Color = TokenTag+{-+data Color+  = Comment | Reserved | Var | Con | TCon | VarOp | ConOp | Lit+  deriving (Eq,Ord,Ix,Bounded,Show)+-}++--loadColorsF :: (PfeColor -> F a b) -> F a b   +loadColorsF gctx fud =+    conts mkColor colorList $ \colors->+    let a = listArray colorBounds colors+    in fud (a!)+  where+    mkColor colorname =+      wCreateGCtx gctx (gcFgA [colorname,fgColor])++colorBounds = (minBound,maxBound) :: (Color,Color)++colorList =+  [argKey (flagname c) (defaultColor c)|c<-range colorBounds]++flagname c = map toLower (show c)++"color"++defaultColor c =+  case c of+    Comment -> "#00A0A0"+    Reserved -> "brown"+    Con -> "#F08000"+    TCon -> "blue3"+    VarOp -> "red"+    ConOp -> "#F08000"+    Lit -> "purple"+    ModName -> "brown"+    _ -> fgColor
+ tools/pfe/Browser/PfeBrowserF.hs view
@@ -0,0 +1,686 @@+module PfeBrowserF(mainF) where+import Prelude hiding (putStr,putStrLn,print,readFile,writeFile,ioError,catch,readIO)+import Monad(unless,mplus,when,filterM)+import Maybe(fromMaybe,mapMaybe,isJust)+import List(find,(\\),nub)+import AllFudgets as Fud hiding (getModificationTime)+import ContribFudgets hiding (lift)++import FudgetIOMonad1+import PfePlumbing+import PfeBrowserMonad+import IdInfo+import PfeBrowserGUI+import CertAttrsEditorF+import PfeBrowserMenu as M+import PfeBrowserCerts+import CertServerF+import CertCmd+import AuxWindowsF+import ImageGraphics(gifFile)+import FudExtras(longTextPopupF)++import HsModule(ModuleName(..),hsModName,{-,HsModuleI-})+import HsTokens as T+import PropPosSyntax(getHSName,SrcLoc(..))+import TiDecorate(no_use)+import TI(Typing(..),envFrom,topName,HsIdentI(..))+import PNT(PNT(..))+import TypedIds(namespace,isClassOrType)+import UniqueNames as UN(OptSrcLoc(N),optOrigModule)+import HasBaseName(getBaseName)++import PFE0(getModuleInfixes,setBatchMode,checkProject,ppFlags,+	    withProjectDir,epput,+	    updateModuleGraph,findNode,projectDir,getCurrentModuleGraph)+import PFE2(getModuleExports)+import PFE3(parseSourceFile'')+import ScopeModule(checkRefs)+import PFE4(exTypeCheck)+import Pfe2Cmds(ppExports)+import Pfe4Cmds(ppIface,moduleInterface)+import PFE_Certs+import CertServers(printAttrs)++import PPU(pp,ppi,ppu,withPPEnv,($$),(<>),(<+>),vcat)+import DrawDoc(drawDoc)+import DrawError+import DrawLex(origLabel,certIcon)+import FudDraw(ulinkD)+import MT(lift)+import MUtils+import AbstractIO hiding (getEnv)+import FileUtils(updateFile)+import SimpleGraphs(reverseGraph,neighbours)+import StatusIndicator(statusF,Status(..))++-- Debuging+--import IOExts(trace)++--- Plumbing -------------------------------------------------------------------++mainF opts pdir servers =+    loopOnlyF $ titleShellF' (setSizing Static) myversion pfeBrowserF+  where+    pfeBrowserF = pfeF opts >==< guiF++    -- @ guiF : the graphical user interface fudget of the PFE browser+    guiF :: F Out In+    TagF guiF dispatch tags =+	mapTF vBoxF $+	    (mapTF hBoxF (pfeMenuBarTF>&<statusTF) >&< infoWindowsTF)+	>&< compTagF (hSplitF' aLeft) graphDispTF moduleDispTF+	>&< (popupsTF >&< certServerTF)++    toTitle = Left+    (_toMenuBar:&:toStatus:&:_toInfoWindows):&:(toGraph:&:toModuleDisp)+     :&:(toPopups:&:toCertServer)=+	extend Right tags+    toMessagePopup:&:toNewCertPopup:&:(toCertAttrsEditors:&:toTextEditor) = toPopups++    pfeMenuBarTF = tagF fromMenuBar (pfeMenuBarF types)+      where+        types = [serverName s|s<-servers,+		              lookup "has_sequent" (serverAttrs s)/=Just "no"]++    statusTF = tagF (const done)+                    (spacer1F centerS $ {-"Status:" `labLeftOfF`-} statusF)++    popupsTF = messagePopupTF >&< newCertPopupTF >&<+	       (certAttrsEditorsTF >&< textEditorPopupTF)+      where+	messagePopupTF = tagF fromMessagePopup (snd>^=<longTextPopupF)+	newCertPopupTF = tagF fromNewCertPopup newCertPopupF+	certAttrsEditorsTF = tagF fromCertAttrsEditor dynCertAttrsEditorPopupsF+	textEditorPopupTF = tagF fromTextEditor textEditorPopupF++    graphDispTF = tagF fromGraph graphDispF+    certServerTF = tagF fromCertServer certServerF -- actually not a GUI part...++    toNodeInfo:&:(_toSource:&:_toRefs) = toModuleDisp+    moduleDispTF =+	mapTF vBoxF $     tagF fromNodeInfo nodeInfoF+		      >&< compTagF (vSplitF' aBottom)+				   (tagF fromSource sourceDispF)+				   (tagF fromRefs refDispF)++    infoWindowsTF = tagF fromInfoWindows $+		    spacer1F (noStretchS False True `compS` rightS) $+		    auxGfxWindowsF myname++    fromGraph = newNode+    fromNodeInfo = either newModuleLbl newFile+    fromRefs = infoPick Nothing+    fromMessagePopup _ = done++    fromInfoWindows = either popupInfoWindow infoPick'+      where infoPick' (w,infolbl) = infoPick (Just w) infolbl++    infoPick optw infolbl =+      case infolbl of+	CertLbl cert -> clearRefs >> changeHilite [] >> updCertInfo cert+        DefLbl (HsCon (PNT pn sp _)) -> goto (HsCon pn,sp)+        DefLbl (HsVar (PNT pn sp _)) -> goto (HsVar pn,sp)+	SrcLocLbl (path,pos) -> newFile path >> gotoLabel (posLabel pos)+          where gotoLabel lbl = do pfePut . toSource . mkvis $ lbl+			           changeHilite [lbl]+        ModuleLbl m -> newModuleLbl (m,Nothing)+	CertCmd cmd@(ValidateCert qcert) ->+	    do putCertServer cmd+	       vcert <- certDisplay # getStBr+	       when (vcert==Just qcert) $ showQCertInfo qcert+	CertCmd cmd ->+	    do maybe done close optw+	       putCertServer cmd+	  where+	    close w = popupInfoWindow (w,False)++	CreateCert ca -> newCertPopup ca+	CertEdit e -> pfePut (toCertAttrsEditors (Right e))+	CertShowText txt -> pfePut . toMessagePopup . map backspace . lines $ txt+	ShowErrorMsg gfx -> popupErrorMsg gfx++    newCertPopup ca =+      do cicons <- certIcons # getStBr+	 clearRefs+	 pfePut (toNewCertPopup (cicons,ca))++    putCertServer cmd =+	do cmds <- certInProgress # getStBr+	   setInProgress (cmds++[cmd])+	   if null cmds then doCertServer shellcmd else notnow+      where+	shellcmd = shellCmd cmd+	notnow = certCmdMsg "Command added to queue" shellcmd++    -- pre: no command in progress+    doCertServer shellcmd =+	do certCmdMsg "Sent certificate server command" shellcmd+	   pfePut (toCertServer shellcmd)++    certCmdMsg msg cmd =+      do cnt <- length . certInProgress # getStBr+         pfePut $ toRefs $ linesD $+		    [g $ msg++":", g cmd]+		    ++(if cnt>0+		       then [g $ "Number of commands in queue: "++show cnt]+		       else [])++    fromNewCertPopup (ty,(cert,concl)) =+      if null cert || null concl+      then popupMsg "Fill in both a certificate name and a conclusion when creating a new certificate!"+      else do m <- modname # getStBr+	      let qcert = QCertName m cert+		  cmd = CertCmd.NewCert ty qcert concl+	      putCertServer cmd+	      dcert <- certDisplay # getStBr+	      when (dcert==Just qcert) $ showQCertInfo qcert++    fromCertAttrsEditor (ctype,(cname,userattrs)) =+      do Just dir <- projectDir+	 m <- modname # getStBr+	 (_,(Just oldattrs,_)) <- certInfo m cname+	 let newattrs = updateAttrs oldattrs userattrs+	 updateFile (certAttrsPath m cname dir) (printAttrs newattrs)+	 infoPick Nothing (CertLbl cname) -- hmm+     where+	updateAttrs oldattrs newattrs =+	    map replace oldattrs++addedattrs -- preserve the order!+	  where+	    addedattrs = filter added newattrs+	    added (n,_) = n `notElem` map fst oldattrs+	    replace (name,old) = (name,fromMaybe old (lookup name newattrs))++    fromTextEditor ((_,Just src),src') =+	if src'/=src+	then do srcpath <- fst . modnode # getStBr+		-- This assumes that the editor window is modal, so that+		-- the current node still is the same!!+		writeFile srcpath src'+		reloadModule+	else done+    fromMenuBar msg = +      case msg of+	File fcmd -> fileCmd fcmd+	View vcmd -> viewCmd vcmd+	Windows wcmd -> windowCmd wcmd+	Cert ccmd -> certCmd ccmd+	_ -> done -- !!+      where+	fileCmd Quit = pfeQuit+	fileCmd ReloadModule = reloadProject+	fileCmd EditModule = editModule++	viewCmd vcmd = do updStBr $ \ st->st{viewMode=vcmd}+			  optGetTypes++	windowCmd (WindowCmd w up) =+	    pfePut (toInfoWindows (w,Left up)) --up is False or True++	certCmd certcmd =+	  case certcmd of+	    M.NewCert -> whenInModuleM $ newCertPopup ("","")+	    M.NewAll certtype -> whenInModuleM $ newAll certtype+	    M.TodoCert -> putCertServer CertCmd.TodoCert+	    RevalidateAllQuick -> revalidateAll >> reloadModule+	    ValidateAll -> validateAll+	    _ -> done -- !!++        newAll ty =+          do m <- modname # getStBr+             putCertServer $ CertCmd.NewCertAll ty (pp m)++        validateAll =+          do m <- modname # getStBr+	     let qcert = QCertName m+		 validateOne = putCertServer . ValidateCert . qcert . fst+	     mapM_ validateOne. certs =<< getStBr++	editModule =+	   do n <- modnode # getStBr+	      unless (isNoModule n) $+		do let srcpath = fst n+		       mname = fst (snd n)+		       prompt = "Edit "++pp mname++" in "++srcpath+		   src <- readFile srcpath+		   pfePut (toTextEditor (Just prompt,Just src))++    fromCertServer (ok,output) =+      do cmds <- certInProgress # getStBr+	 let cmds' = drop 1 cmds+	 setInProgress cmds'+	 if null cmds'+	    then do clearRefs+		    changeHilite []+		    {-when ok-}+		    reloadModule+            else doCertServer (shellCmd (head cmds'))+	 unless (null output) (route cmds . map stripEither $ output)+      where+	route (ValidateCert qcert:_) msg =+	    certCmdMsg (ppqcert qcert) (last msg)+	route _ msg =+	  if ok && length msg <= 3+	  then pfePut . toRefs . linesD . map g $ msg+	  else pfePut $ toMessagePopup msg++    --- Initialization and main loop -------------------------------------------++    --pfeF o = nullF+    pfeF :: Opts -> PfeF+    pfeF = runFIOM . runPfeFM pfeFM++    pfeFM :: PfeFM ()+    pfeFM =+	do g <- getCurrentModuleGraph+	   icons <- getCertIcons servers+	   sadicon <- getIcon (gifFile (badCertIconPath pdir))+	   setStBr St{modnode=noModuleNode,viewMode=view0,mrefs=[], hilbls=[],+		     types=Nothing,certs=[],revgraph=reverseGraph (map snd g),+		     certDisplay=Nothing,certInProgress=[],+		     certServers=servers,certIcons=icons,sadIcon=sadicon}+	   pfePut (toGraph g)+	   putInfoWindow (CertTypes,drawCertTypes (zip servers icons))+	   pfePut (toCertAttrsEditors (Left servers))+	   setBatchMode False+	   pfeloop+      where	  +	pfeloop :: PfeFM ()+	pfeloop =+	  do (dispatch =<< pfeGet) `catch` stdHandler+	     pfeloop++	getCertIcons :: CertServers -> PfeFM CertIcons+	getCertIcons servers = mapM getCertIcon servers+	getCertIcon certServer =+	  do let dir = serverDir certServer+		 certtype = serverName certServer+		 iconsrc status = gifFile (dir++"/"++status++".gif")+	     valid   <- getIcon (iconsrc "valid")+	     invalid <- getIcon (iconsrc "invalid")+	     unknown <- getIcon (iconsrc "unknown")+	     return (certtype,(valid,invalid,unknown))++	getIcon = lift . xrequestFIOM . convToPixmapK++	drawCertTypes = htableD hdrs . concatMap certD+	  where+	    hdrs = ["Icon","Type","Description"]+	    certD (server,(ty,(icon,_,_))) = [g icon,g ty,g descr]+	      where+		descr = fromMaybe "(Descrption missing)" $+			lookup "description" (serverAttrs server)++    typeErrorHandler err =+      do --setNoTypes+	 pfePut $ toRefs $ fgD "red" $ g "Type error!"+	 setStatus (Typing,InError)+         --o <- ppFlags+	 m <- modname # getStBr+         popupErrorMsg (fontD ppfont (drawTypeError m err))+	 epput err+	 +{-+    setNoTypes = do updStBr $ \ st->st{viewMode=Hyper}+		    putStrLn "Switching off type info"+		    pfePut (toMenuBar (View Hyper))+-}+    stdHandler err =+	do epput msg+	   -- popupMsg msg+	   unless (null msg) $ popupErrorMsg (msgGfx msg)++      where msg = ioeGetErrorString err++    popupErrorMsg gfx =+	do putInfoWindow (ErrorMsg,gfx)+	   popupInfoWindow (ErrorMsg,True)++    clearErrorMsg = putInfoWindow (ErrorMsg,blankD 10)++    setStatus = pfePut . toStatus++    resetStatus = sequence_ [setStatus (l,Unknown)|l<-[minBound..maxBound]]++    whenInModuleM = unlessM (isNoModule.modnode # getStBr)+++    --- Reactions and auxiliary functions --------------------------------------++    reloadProject =+	-- skip reload if there is no project, or no module is selected+	whenInModuleM $ reloadGraph >> reloadModule+      where+	reloadGraph =+	  do updateModuleGraph+	     -- should also check for added/removed files and update graphDispF+	     updModNode . modname =<< getStBr++    updModNode m =+      do g <- getCurrentModuleGraph+	 node <- findNode m+	 updStBr $ \st->st{revgraph=reverseGraph (map snd g),modnode=node}+	 return node++    reloadModule =+      whenInModuleM $+	do maybe done showQCertInfo . certDisplay =<< getStBr+	   newNode . modnode =<< getStBr++    {-+ #newNode#: load and display a new module, after the user has entered or+	 clicked on a module name or a file name. -}+    newNode node@(path,_) =+      withWaitCursor $+      do resetStatus+	 clearErrorMsg+	 setStatus (Syntax,InProgress)+         dir <- checkProject+	 --pfePut (toSource (Left ("","",[]))) -- empty window to scroll to top+	 r <- try (parseSourceFile'' path)+	 case r of+	   Left err -> badNode dir err+	   Right (ts,((wm,ast),refs)) ->+	    do node@(_,(m,_)) <- updModNode (getBaseName (hsModName ast)) --updates revgraph+	       let --refs =simplifyRefsTypes' rs+		   asserts = assertions ast -- :: [(PNT,AssertionI PNT)]+		   certs_annot = mapMaybe isCertToken ts -- :: [CertName]+		   isCert cert = doesFileExist (certAttrsPath m cert dir)+	       certs_existing <- filterM isCert . fromMaybe [] =<<+			    maybeM (getDirectoryContents (certModuleDir m dir))+	       let certs_noannot = certs_existing \\ certs_annot+		   certs = certs_annot++certs_noannot+	       certsStatus <- zip certs # quickCertsStatus m certs dir+	       certsInfo <-+		  let replace = zipWith replace1 certsStatus+		      replace1 (_,s) (c,(a,s0)) = (c,(a,s))+		  in replace # mapM (certInfo m) certs+	       let conccert (cert,(attrs,_)) =+                     flip (,) cert # (lookup "conc" =<< attrs)+                   na = collectByFst .+			mapMaybe conccert .+			filter ((`elem` certs_noannot).fst) $+			certsInfo+	       updStBr $ \st->st{mrefs=refs,hilbls=[],types=Nothing,certs=certsInfo}+	       e <- getModuleExports m+	       -- To keep the displays consistent with the internal state,+	       -- output operations should come after all operations that can fail!+	       setStatus (Syntax,Good)+	       setStatus (Scoping,InProgress)+	       scope_ok <- showScopeErrors refs+	       setStatus (Scoping,if scope_ok then Good else InError)+	       importedby <- flip neighbours m . revgraph # getStBr+	       pfePut (toNodeInfo (Left (node,importedby)))+	       cicons <- icons # getStBr+	       pfePut (toSource (Left (dir,cicons,node,ts,refs,certsStatus,na)))+	       o <- ppFlags+	       putInfoWindow (Exports,ppo o (ppExports m e))+	       putInfoWindow (Interface,ppMsgGfx o clickToActivate)+	       putInfoWindow (Pretty,ppo o ast)+	       putInfoWindow (Evidence,evidenceGfx m dir cicons certsInfo asserts)+	       pfePut (toTitle (myname++": "++pp m))+	       when scope_ok optGetTypes+      where+	{-++	Rather than aborting newNode (and potentially leaving the history buttons+	in an incosistent state) on errors, display an empty window and continue...+	-}+	badNode dir err =+	  do o <- ppFlags+	     s <- fromMaybe [] # maybeM (readFile path)+	     updStBr $ \st->st{modnode=node}+	     pfePut (toRefs (ppMsgGfx o (ioeGetErrorString err)))+	     pfePut (toNodeInfo (Left (node,[])))+	     pfePut (toSource (showsrctext s))+	     setStatus (Syntax,InError)+	     putInfoWindow (Exports,blankD 10)+	     putInfoWindow (Interface,blankD 10)+	     putInfoWindow (Pretty,blankD 10)+	     putInfoWindow (Evidence,blankD 10)+	     pfePut (toTitle (myname++": "++path))++	showScopeErrors refs =+	    do if ok+		 then clearRefs+		 else do o <- ppFlags+			 pfePut (toRefs (gfx o))+	       return ok+	    where+              ok = null errs+	      errs = checkRefs refs+	      errcnt = length errs++	      gfx o =+                labelD (ShowErrorMsg (fontD ppfont (drawScopeErrors errs)))+		       (ulinkD (g msg))++	      msg = if errcnt==1+		    then "One scoping error"+		    else show errcnt++" scoping errors"++    {-+ #newModule#: load and display a new module after the user has entered+	or clicked on a module name. -}+    newModule :: ModuleName ->PfeFM ()+    newModule m = newNode =<< findNode m++    newModuleLbl (m',optlbl) =+      do n@(_,(m,_)) <- modnode # getStBr+	 when (isNoModule n || m'/=m) $ newModule m'+	 maybe done gotoLabel optlbl+      where+	gotoLabel lbl = do pfePut . toSource . mkvis $ lbl+			   showInfo lbl++    {-+ #newFile#: load and display a new module after the user has entered or +	clicked on a file name. -}+    newFile :: FilePath ->PfeFM ()+    newFile path =+      do (oldpath,_) <- modnode # getStBr+	 when (path/=oldpath) $+	   do updateModuleGraph+	      g <- getCurrentModuleGraph+	      case [node|node@(path',_)<-g,path'==path] of+		[node] -> newNode node+		_ -> fail ("File not part of this project:"++path)++    {-+    goto o@(_,r) =+      case r of +	Left (s,n) ->+	  do let m' = Module s+	     m <- modname # getStBr+	     unless (m'==m) $ newModule m'+	     gotoLocal o+	_ -> gotoLocal o+    -}++    goto o@(r,_) =+	  do let optm' = optOrigModule r+	     m <- modname # getStBr+	     case optm' of+	       Just m'| m'/=m -> newModule m'+	       _ -> done+	     gotoLocal o++    gotoLocal (o,sp) =+      do st <- getStBr+	 case [r|r@((d,_),_,[(o',sp')])<-mrefs st,+		 isDef d,o'==o,namespace sp'==namespace sp]+	   of orig:_ -> do let lbl = origLabel orig+			   pfePut (toSource (mkvis lbl))+			   rememberLbl lbl+			   showInfo lbl+	      _ -> putStrLn $ "Didn't find def of "++show o++    rememberLbl lbl = +	do m <- modname # getStBr+	   pfePut (toNodeInfo (Right (m,lbl)))++    followLink lbl def = rememberLbl lbl >> goto def++    changeHilite new =+      do old <- hilbls # getStBr+	 pfePut (toSource (hilite (old\\new) (new\\old)))+	 updStBr $ \st->st{hilbls=new}++    getIdInfo lbl@(Lbl token) =+      do refs <- mrefs # getStBr+	 infixes <- getModuleInfixes+	 path <- fst . modnode # getStBr+	 let p = (path,lblPos lbl)+	     (occurences,optdef,refinfo) = idInfo refs infixes token+	 return ((occurences,optdef,concatMap msglines refinfo),p)++    fromSource (Just (Button 1),lbl@(Lbl ((ModuleName,(_,mn)),_))) =+	newModule (PlainModule mn) -- !!!+    fromSource (Just button,lbl@(Lbl token)) =+	case button of+	  Button 1 -> case isCertTokenRef token of+			Just cert -> changeHilite [lbl] >> updCertInfo cert+			_ -> do info@((_,optdef,_),_) <- getIdInfo lbl+				case optdef of+				  Nothing -> done+				  Just def ->+				    if isDefLbl lbl+				    then showInfo' lbl info+				    else followLink lbl def+	  Button 2 -> showInfo lbl+	  Button 3 -> do ((occurences,_,refinfo),_) <- getIdInfo lbl+			 let cnt=length occurences+			     msg=if cnt>0+				 then ["Highlighted all "++show cnt+++					" occurences in this module"]+				 else []+			 changeHilite (map posLabel occurences)+			 pfePut (toRefs (linesD (map g (refinfo++msg))))+	  _ -> done+    fromSource (Nothing,lbl) =+	ifM (isLink lbl)+	    (pfePut (toSource setlinkcursor))+	    (pfePut (toSource setnormalcursor))+      where+	isLink (Lbl ((ModuleName,(_,mn)),_)) = return True+	isLink lbl = +	  if isDefLbl lbl+	  then return False+	  else do info@((_,optdef,_),_) <- getIdInfo lbl+		  return (isJust optdef)++    updCertInfo cert = showCertInfo cert >> updCertIcons cert++    updCertIcons cert = whenM (statusChange cert) reloadModule+       -- TODO: efficient icon updates in the source display and evidence window++    showInfo lbl = showInfo' lbl =<< getIdInfo lbl++    showInfo' lbl ((_,def,refinfo),p) =+	do --optGetTypes+	   tinfo <- maybeD (optGetType p) def+	   ainfo <- maybeD getAssertionInfo def+	   pfePut (toRefs (linesD (map g refinfo++ainfo++tinfo)))+	   changeHilite (if isJust def then [lbl] else [])+      where+	maybeD = maybe (return [])++	optGetType p o = maybe (return []) (getType p o) . types =<< getStBr++	getType p (qn,k) types =+	  do --print (k,qn)+	     m <- modname # getStBr+	     let env = modtypes m types+	     o <- ppFlags+	     --print (let xs:>:_ = unzipTyped mt in xs)+	     return [typeInfo o env k p qn]++	typeInfo ppopts (mt,env) k p qn =+	    if isClassOrType k+	    then kinfo qn (fst env)+	    else tinfo (snd (no_use env)) mt p qn+	 where+	    kinfo qn = optpp . lookup qn . convTEnv (ppi.fst)++	    optpp = maybe (Fud.g "No type/kind info available") (ppo ppopts)++	    tinfo env mt (path,lexpos) qn =+		optpp (find' mt `mplus` lookup qn env')+	      where env' = convTEnv (ppi.fst) (env++mt)+		    qn' = getHSName qn+		    find' = fmap pp_use . find (pos.name)+		    name (i:>:_) = getHSName i+		    pos (PNT pn _ (N (Just (SrcLoc f _ lin col)))) =+		      pn==qn' && f==path && col==column lexpos && lin==line lexpos+		    pos i = False+		    pp_use (_:>:(gen,opti)) =+		      case opti of+			Just inst -> "Generally:"<+>gen<>","$$"Here:"<+>inst+			_ -> ppi gen++		    pntpos (PNT _ _ (N p)) = p++	convTEnv f env = [(bn i,f info)|i:>:info<-env]+	  where+	    bn = fmap orig -- . getHSName+	    orig (PNT n _ _) = n++	modtypes m pfe4info = (snd (envFrom tm),(concat kenvs,concat tenvs))+	  where+	    Just (_,((_,tm):_,_)) = lookup m (pfe4info::TInfo)+	    (kenvs,tenvs) = unzip [env|(_,(_,(_,(_,env))))<-pfe4info]++    optGetTypes =+      do st <- getStBr+	 when (viewMode st==Typed &&+               not (isNoModule (modnode st) || haveTypes st))+	      (retypeCheck (modname st))+      where+        retypeCheck m =+	     withWaitMsg (g "Type checking...") $+	     do setStatus (Typing,InProgress)+                opttypes <- exTypeCheck (Just [m])+		case opttypes of+		  Left err -> typeErrorHandler err+		  Right types ->+		    do mIface <- moduleInterface m -- calls typeCheck again ==> slow!!+		       setStatus (Typing,Good)+		       o <- ppFlags+		       putInfoWindow (Interface,ppo o (ppIface mIface))+		       updStBr $ \st->st{types=Just types}++    clearRefs = pfePut (toRefs (blankD 10))++    popupMsg = pfePut . toMessagePopup . msglines++    withWaitMsg msg cmd =+      do pfePut (toRefs msg)+	 tryThen (withWaitCursor cmd) $ clearRefs++setInProgress cmds =+    do updStBr $ \ st -> st{certInProgress=cmds}+       o <- ppFlags+       putInfoWindow (PendingCmds,ppo o (vcat cmds))++ppMsgGfx o = msgGfx . ppu o+msgGfx = linesD . map g . msglines+--msgGfx = vboxlD' 0 . map (atomicD . expandTabs 8)++ppo ppopts = ppo' ppopts+ppo' (_,ppopts) = fontD ppfont . drawDoc . withPPEnv ppopts . ppi++msglines = map (expandTabs 8) . lines++clickToActivate = +--  "(To activate type checker: click with the middle mouse button on an identifier)"+  "(To activate type checker: select Type Info from the View menu)"++---+{-+instance CatchIO e m => CatchIO e (WithState s m) where+  stm `catch` h =  do s <- getSt+		      r <- lift $ try (withStS s stm)+		      case r of+			Left err -> h err+			Right (ans,s') -> setSt_ s' >> return ans+  ioError = lift . ioError+-}++--+ppfont = argKey "ppfont" refFont
+ tools/pfe/Browser/PfeBrowserGUI.hs view
@@ -0,0 +1,189 @@+module PfeBrowserGUI(module PfeBrowserGUI,posLabel) where+import List(groupBy,sortBy)+import Maybe(isNothing)+--import Char(isSpace)++import AllFudgets+import FudExtras(popupMenuF',staticHyperGraphicsF')+import ContribFudgets(menuIcon,item,itemValue)--menuBarF,delayedSubMenuItem,idT,cmdItem+import HyperGraphicsF2+import TreeBrowser as B(treeBrowserF',Tree(..))+import HistoryButtonsF+import ListUtil(chopList,breakAt,mapFst)++import PfePlumbing+import PfeBrowserColors as C+import DrawLex(drawLex,fakeLex,posLabel,rootLabel,isCertAnnot)++import HsLexerPass1(lexerPass0)+import HsTokens as T+import HsName(ModuleName(..),parseModuleName)++import OpTypes(cmpBy)+import PrettyPrint(pp,(<+>))+import MUtils(apSnd)++textEditorPopupF = +    inputPopupF "Editor" (spF $ oldScrollF True (500,600) inputEditorF) Nothing+  where spF = spacer1F (noStretchS False False)++newCertPopupF :: F ToNewCertPopup FromNewCertPopup+newCertPopupF =+    snd>^=<inputPopupF title newCertF Nothing >=^< pre+  where+    title = "Create a new certificate"+    pre inp = (Just title,Just inp)++newCertF = tableF 2 (typeF `inputPairF` (nameF `inputPairF` conclF))+  where+    typeF = labelF "Type" >*<+              (inputChange>^=<dynF nullLF+               >=^< Left . radioButtonsF>=^^<idempotSP>=^<map certTypeItem)+    radioButtonsF [] = labelF "No certificate types available?!"+    radioButtonsF items@(item1:_) =+      radioGroupF [(itemValue item,item)|item<-items] (itemValue item1)++    nameF = labelF "Name" >*< stringF+    conclF = labelF "Conclusion" >*< stringF++    certTypeItem (cert,(icon,_,_)) = item cert (hboxD [g icon,g cert])++graphDispF :: F ToGraph FromGraph+graphDispF =+    mapFilterSP leaf>^^=<+    vScrollF (treeBrowserF' g0)>=^<graphTree.sortBy (cmpBy (fst.snd))+  where+    g0 = graphTree []+    leaf (B.Leaf l) = Just (itemValue l)+    leaf _ = Nothing++    graphTree g =+	Node "Module Graph" [Node "Files" (filepaths2trees g),+			     Node "Modules" (map mitem g)]+      where+	mitem n@((_,(m,_))) = B.Leaf (item n (pp m))++    filepaths2trees = list2trees . map withpath+      where+	list2trees = map tree . groupBy eqHead . sortBy (cmpBy fst)++	--tree ([]:_) = ??+	tree [([f],p)] = B.Leaf (item p f)+	tree ((x:xs,p):ys) = Node x (list2trees ((xs,p):mapFst tail ys))++	eqHead (x:xs,_) (y:ys,_) = x==y+	eqHead ([],_) ([],_) = True+	eqHead _ _ = False++	withpath n@(path,_) = (chopList (breakAt '/') path,n)++refDispF :: F ToRefs InfoLbl+refDispF = scrollF (staticHyperGraphicsF' pm initD)+  where pm = setSizing Dynamic . setFont refFont+        initD = padD 20 $ g $+		 "Welcome to the "++myversion++"!"++data ModPos = MP ModuleName (Maybe Label) deriving (Eq)++instance Graphic ModPos where+  measureGraphicK (MP m optpos) =+      measureGraphicK (pp $ m<+>fmap (line.lblPos) optpos)++nodeInfoF :: F ToNodeInfo FromNodeInfo+nodeInfoF =+    --simpleGroupF [] $+    vBoxF (fileF>*<hBoxF (historyF>*<nodeF))+  where+      -- Input is: ((f,(n,is)),es)+Pos++    fileF = Right >^=< ldispF  "File:" >=^< fst.fst >=^^< filterLeftSP++    historyF =+        post >^=<+        loopThroughRightF (absF ignore0)+		          (historyButtonsF{- >==< teeF show "history: "-})+        >=^< mpos+      where+	mpos = mapEither mpos1 mpos2+        mpos1 ((f,(n,is)),es) = MP n Nothing+	mpos2 (m,p) = MP m (Just p)+	post (MP m optpos) = Left (m,optpos)++	ignore0 = getSP $ either repeat (either makehistory (const ignore0))++	repeat cur = putSP (Right cur) $ ignore cur+	makehistory new = putSP (Left (Left new)) $ ignore new+	replace new = putSP (Left (Right new)) $ ignore new++	ignore cur@(MP m op) = getSP $ either repeat (either newmod updpos)+          where+	    newmod new@(MP m' Nothing) | m'==m = ignore cur+	    newmod new = makehistory new++	    updpos new | new==cur = ignore cur+	    updpos new@(MP m' _) | m'==m && isNothing op = replace new+	    updpos new = makehistory new++    nodeF = (moduleF>*<dynImportMenusF)  >=^^< filterLeftSP+    moduleF = post . parseModuleName >^=< ldispF "Module:" >=^< pp.fst.snd.fst+      where post m = Left (m,Nothing)++    ldispF l = l `labLeftOfF` strF+      where strF = stringInputF --' (setSizing Dynamic)++    dynImportMenusF =+       dynModuleMenuF "Imports" >=^< snd.snd.fst+        >*<dynModuleMenuF "Imported By" >=^< snd+ +    dynModuleMenuF lbl = popupMenuF' 1 [] (menuLblF lbl)>=^<pre+      where pre ms = Left [((m,Nothing),pp m)|m<-take 30 ms]+			   -- !! no indication if menu is truncated++    menuLblF lbl = labelF' pm (hboxcD [g lbl,g menuIcon])+      where pm = setBorderWidth 1 . setBgColor paperColor++    --fud1>|<fud2 = stripEither>^=<prodF fud1 fud2++sourceDispF :: F ToSource FromSource+sourceDispF =+    wCreateGCtx rootGCtx (gcFontA sourceFont) $ \ gctx ->+    loadColorsF gctx sourceDispF'++sourceDispF' colgc =+    scrollF (mousePointSP>^^=<hyperGraphicsF2' pm init)>=^<either replace id+  where+    pm = setFont sourceFont . setGfxEventMask [GfxButtonMask,GfxMotionMask]+    init = drawLex undefined undefined undefined colgc [] [] [] empty+    empty = lexerPass0 (replicate 24 '\n'++replicate 80 ' ') -- for initial size+    replace (dir,icons,(path,(m,_)),ts,rs,cs,na) =+      replaceGfx rootLabel $ drawLex dir icons m colgc rs cs na ts++    mousePointSP = idempotSP -==- mapFilterSP label+      where+        label event =+          do (lbl,_):_ <- gfxEventPaths event+	     case event of+	       GfxButtonEvent {gfxType=Pressed,gfxButton=b} -> Just (Just b,lbl)+	       GfxMotionEvent {} -> Just (Nothing,lbl)+	       _ -> Nothing++highlightGfxs off on = ChangeGfx $ change off False++change on True+  where change paths on = [(path,(on,Nothing))|path<-paths]++hilite off on = Right (highlightGfxs off on)+mkvis lbl = Right (ShowGfx lbl (Nothing,Nothing))+setwaitcursor =  Right (ChangeGfxFontCursor 150)+setlinkcursor =  Right (ChangeGfxFontCursor 60)+setnormalcursor = Right (ChangeGfxCursor cursorNone)+showsrctext = Right . replaceGfx rootLabel . fakeLex++isCertTokenRef = isCertToken . fst+isCertToken token =+  do (NestedComment,(_,s)) <- return token+     isCertAnnot s+++-- Moved file path definitions to ../../property/pfe/PFE_Certs.hs++sourceFont = argKey "sourcefont" defaultFont+refFont = argKey "reffont" defaultFont
+ tools/pfe/Browser/PfeBrowserMenu.hs view
@@ -0,0 +1,77 @@+module PfeBrowserMenu where+import ContribFudgets+import Fudgets++-- If Haskell only had first class constructors...+#define CON(c) (Transl (c) (\x->case x of c y->Just y;_->Nothing))++data MenuCmd w+  = File FileCmd+  | View ViewCmd+  | Windows (WindowCmd w)+  | Cert CertCmd+  deriving (Eq)++data FileCmd+  = ReloadModule+  | EditModule+  | Quit+  deriving (Eq)++view0 = Hyper+data ViewCmd+  = Hyper+  | Typed+  deriving (Eq)++data WindowCmd w = WindowCmd w Bool deriving (Eq)++data CertCmd+  = NewCert+  | NewAll String+  | TodoCert+  | RevalidateAllQuick+  | ValidateAll+  deriving (Eq)++pfeMenuBarF certtypes =+   spacer1F (noStretchS False True `compS` leftS) (menuBarF menuBar)+  where+    menuBar =+      [item fileMenu  "File",+       item viewMenu  "View",+       item windowsMenu "Windows",+       item certMenu "Cert"]++    fileMenu =+      menu CON(File)+      [cmdItem ReloadModule     "Reload Module" `key` "r",+       cmdItem EditModule       "Edit Module"   `key` "e",+       cmdItem Quit		"Quit"		`key` "q"]++    viewMenu = menu idT [radioGroupItem CON(View) views view0 "Module View"]+      where+	views =+	  [--cmdItem Plain "Plain Source Text",+	   item Hyper "Highlighted & Hyperlinked" `key` "h",+	   item Typed "Type info" `key` "t"]+        idT = Transl id Just -- why not this?++    windowsMenu =+	menu CON(Windows)+	[toggleItem (wcon w) False (show w)|w<-[minBound..maxBound]]+      where+	wcon w = Transl (WindowCmd w) (inv w)+	inv w (WindowCmd w' b) = if w'==w then Just b else Nothing++    certMenu =+      menu CON(Cert)+      [cmdItem NewCert "Add one new Certificate..." `key` "n",+       subMenuItem CON(NewAll) newAllMenu "Add certificates to all assertions",+       cmdItem TodoCert "ToDo" `key` "d",+       cmdItem RevalidateAllQuick "Quick Revalidate All" `key` "v",+       cmdItem ValidateAll "Validate All"]++    newAllMenu = map strCmdItem certtypes++    strCmdItem s = cmdItem s s
+ tools/pfe/Browser/PfeBrowserMonad.hs view
@@ -0,0 +1,98 @@+module PfeBrowserMonad where+import Maybe(isJust)+import Monad(when)+import MT(lift)+import AbstractIO++import FudgetIOMonad1+import PfePlumbing+import PfeBrowserMenu(WindowCmd,ViewCmd,MenuCmd(..),WindowCmd(..))+import PfeBrowserGUI+import PNT(PNT)+import SimpleGraphs(Graph)++import PropParser(parse)+import PropLexer({-LexerFlags,-}pLexerPass0)+import PPU(PPHsMode)+import TiPropDecorate(TiDecls) -- to choose result type from the type checker+import PropPosSyntax(Id,HsName,HsDecl)+import FreeNamesProp()+import ScopeNamesProp()+import NameMapsProp()+import ReAssocProp()+import MapDeclMProp() -- for removing pattern bindings in Pfe3Cmds.+--import TiModule() -- instance ValueId PNT+import TiProp()+import PFE4+import PFEdeps+import PFE0+import PFE_Certs+import CertCmd(CertCmd)++type Opts = ({-LexerFlags,-}((Bool, PPHsMode), String, [String]))++-- PFE Browser monad:+--type PfeFM = PFE0MT Id HsName [HsDecl] () (WithState PfeBrowserState FIOM)+--type PfeFM = WithState PfeBrowserState (PFE0MT Id HsName [HsDecl] () FIOM)+type PfeFM = PFE5MT Id HsName PNT [HsDecl] (TiDecls PNT) PfeBrowserState FIOM+++runPfeFM pfeFM ({-lexeropts,-}opts) =+    runPFE5 undefined (\n a->pfeFM) (pLexerPass0 {-lexeropts-},parse) opts++pfeGet = lift getFM :: PfeFM In+pfePut = lift . putFM+pfeQuit = lift quitFM++withWaitCursor :: PfeFM a -> PfeFM a -- polymorphic recursion...+withWaitCursor cmd =+  do pfePut (toSource setwaitcursor)+     tryThen cmd $ pfePut (toSource setnormalcursor)++putInfoWindow (w,x) = pfePut . toInfoWindows $ (w,Right x)++popupInfoWindow (w,up) =+  do pfePut (toMenuBar (Windows (WindowCmd w up)))+     when (not up && w==CertInfo) $+       updStBr $ \ st ->st{certDisplay=Nothing}++popupCertInfo qcert info =+    do putInfoWindow (CertInfo,info)+       popupInfoWindow (CertInfo,True)+       updStBr $ \ st -> st{certDisplay=Just qcert}++getStBr :: PfeFM PfeBrowserState+updStBr :: (PfeBrowserState->PfeBrowserState)->PfeFM ()++getStBr = getSt5ext+updStBr = updSt5ext+setStBr = updStBr . const++type TInfo = PFE4Info PNT (TiDecls PNT)+type ViewMode = ViewCmd++data PfeBrowserState+   = St { -- Mode+	  viewMode :: ViewMode,+          -- The selected module:+	  modnode::ModuleNode,+	  mrefs::[XRefInfo],hilbls::[Label],+	  types::Maybe TInfo,+	  certs::[CertInfo],+	  -- Project info:+	  revgraph::Graph ModuleName,+	  -- Cert display/state info:+	  certDisplay    :: Maybe QCertName,  -- currently displayed cert+	  certInProgress :: [CertCmd],  -- server command in progress or queued+	  -- Project independent info:+	  certServers :: CertServers,+	  certIcons :: CertIcons,+	  sadIcon :: PixmapImage }++haveTypes = isJust . types+modname = fst . snd . modnode+noModuleNode = ("",(undefined,[])) -- for the initial state+isNoModule (path,_) = null path+--sccs = fst . snd . pfe2info+--graph = concat . sccs+icons st = (sadIcon st,certIcons st)
+ tools/pfe/Browser/PfePlumbing.hs view
@@ -0,0 +1,138 @@+module PfePlumbing(module PfePlumbing,module P) where+import AllFudgets as P(PixmapImage,Drawing,Gfx,Graphic(..),Button,Click,GfxCommand)++import PFE0 as P(ModuleNode,ModuleGraph)+import PFE_Certs as P(CertType,CertName,QCertName,CertStatus)+import HsModule as P(ModuleName)+import HsTokens as P(Token)+import HsLexerPos as P(Pos(..))+--import RefsTypes(Orig,Refs,isDef)+import ScopeModule as P(XRefInfo)+import PNT(PNT)+import HsIdent(HsIdentI)+import SrcLoc(SrcLoc,srcPath,srcLoc)+import ConvRefsTypes(simpSrcLoc)+import NameMaps(Role(..),Context(..))+import TypedIds(IdTy(Assertion))+import PfeBrowserMenu as P(MenuCmd)+import OpTypes(eqBy,cmpBy)+import CertServers as P(CertServers,Attrs,Name)+import CertCmd(CertCmd)+import StatusIndicator(Status)+import Now(compileDate)++myname = "Programatica Haskell Browser"+myversion = myname++" version "++compileDate++type Refs=[XRefInfo]+type Orig=XRefInfo++type CertIcons = [(CertType,(PixmapImage,PixmapImage,PixmapImage))]+                           --(valid,invalid,unknown)+type Icons = (PixmapImage,CertIcons) -- (bad,certicons)+type CertsStatus = [(CertName,CertStatus)]+type CertsNoAnnot = [(String{-AssertionName-},[CertName])]++type SrcToken = (Token,(Pos,String))+newtype Label = Lbl {unLbl::(SrcToken,Maybe Orig)} --deriving (Show)++lblPos = fst.snd.fst.unLbl++assertionDefLbl (Lbl ((_,(_,s)),Just ((Def _,_),_,[(_,Assertion)]))) = Just s+assertionDefLbl _ = Nothing++isDefLbl (Lbl (_,Just ((r,_),_,_))) = isDef r+isDefLbl _ = False++isDef (Def (Instance _)) = False+isDef (Def _) = True+isDef _ = False++refPos :: XRefInfo -> Pos+addRefPos :: XRefInfo -> (Pos,XRefInfo)+refPos r@(_,n,_) = simpSrcLoc (srcLoc n)+addRefPos r = (refPos r,r)+srcLocLbl loc = SrcLocLbl (srcPath loc,simpSrcLoc loc)++instance Eq Label where (==) = eqBy lblPos+instance Ord Label where compare = cmpBy lblPos++type LexDrawing = Drawing Label Gfx++data InfoWindow+  = CertInfo | CertTypes | PendingCmds+  | ErrorMsg | Evidence | Exports | Interface | Pretty+  deriving (Eq,Show,Bounded,Enum)++data InfoLbl+   = CertLbl CertName+   | DefLbl (HsIdentI PNT) | SrcLocLbl (FilePath,Pos) | ModuleLbl ModuleName+   | CertCmd CertCmd | CreateCert (CertName,String)+   | CertEdit (CertType,(CertName,Attrs))+   | CertShowText String+   | ShowErrorMsg InfoDrawing+   deriving (Show)++type InfoDrawing = Drawing InfoLbl Gfx++instance Graphic InfoWindow where measureGraphicK = measureGraphicK . show++type PfeMenuCmd = MenuCmd InfoWindow++type FromMenuBar = PfeMenuCmd+type FromInfoWindows = Either (InfoWindow,Bool) (InfoWindow,InfoLbl)+type FromGraph = ModuleNode+type FromNodeInfo = Either (ModuleName,Maybe Label) FilePath+type FromSource = (Maybe Button,Label)+type FromRefs = InfoLbl+type FromMessagePopup = Click+type FromModuleDisp = Either FromNodeInfo (Either FromSource FromRefs)++type ToModuleDisp = Either ToNodeInfo (Either ToSource ToRefs)+toSource = _toModuleDisp . Right . Left+toRefs = _toModuleDisp . Right . Right++type FromPopups = Either (Either FromMessagePopup FromNewCertPopup)+		         (Either FromCertAttrsEditors FromTextEditor)+type ToPopups = Either (Either ToMessagePopup ToNewCertPopup)+	               (Either ToCertAttrsEditors ToTextEditor)++type FromCertServer = (Bool,[Either String String])+type ToCertServer = String++type ToNewCertPopup = (CertIcons,(CertName,String))+type FromNewCertPopup = (CertType,(CertName,String))++type ToCertAttrsEditors = Either CertServers (CertType,(CertName,Attrs))+type FromCertAttrsEditors = (CertType,(CertName,Attrs))++type ToTextEditor = (Maybe String, Maybe String)+type FromTextEditor = (ToTextEditor,String)++type ToMenuBar = PfeMenuCmd+type ToInfoWindows = (InfoWindow,Either Bool InfoDrawing)+type ToGraph = ModuleGraph+type ToNodeInfo = Either (ModuleNode,[ModuleName]) -- (...,imported by)+                         (ModuleName,Label) -- add position to history+type ToSource =+    Either (FilePath,Icons,ModuleNode,[SrcToken],Refs,CertsStatus,CertsNoAnnot)+           (GfxCommand Label LexDrawing)+type ToRefs = InfoDrawing+type ToMessagePopup = [String]++data Level = Syntax | Scoping | Typing deriving (Eq,Show,Bounded,Enum)++type ToStatus = (Level,Status)+type FromStatus = ()++type In  = Either (Either (Either (Either FromMenuBar FromStatus)+                                  FromInfoWindows)+			  (Either FromGraph FromModuleDisp))+		  (Either FromPopups FromCertServer)+type Out = Either (Either (Either (Either ToMenuBar ToStatus) ToInfoWindows)+                          (Either ToGraph ToModuleDisp))+	          (Either ToPopups ToCertServer)+toMenuBar = toOut . Left . Left . Left . Left+toInfoWindows = toOut . Left  . Left . Right+_toModuleDisp = toOut . Left . Right . Right+toOut = Right -- see FudgetIOMonad1
+ tools/pfe/Browser/README.html view
@@ -0,0 +1,9 @@+<h1>Programatica Haskell Browser</h1>++<h2>What is in this directory (pfe/Browser)</h2>++This directory contains modules implementing pfebrowser, the graphical+Haskell Browser.+<hr>+<address>Authors: TH</address>+<address>Contact: <a href="http://www.cse.ogi.edu/~hallgren/">TH</address>
+ tools/pfe/Browser/StatusIndicator.hs view
@@ -0,0 +1,42 @@+module StatusIndicator where+import Fudgets++data Status = Unknown | InProgress | InError | Good deriving (Eq,Ord)++statusF :: (Eq a,Enum a,Bounded a) => F (a,Status) b+statusF =+    nullF >==< +    (createDrawStatus $ \ draw ->+     let u = draw Unknown+         pm = setBgColor bgColor . setInitDisp u . setBorderWidth 0+              . setMargin 0+     in placerF (horizontalP' 0) $+        listF [(l,displayF' pm>=^<draw)|l<-[minBound..maxBound]])++createDrawStatus cont =+    fg ["black"] $ \ black ->+    fg ["red","#ff3300","#ff0033","#cc0000","grey40","black"] $ \ red ->+    fg ["yellow","#ffff33","white"] $ \ yellow ->+    fg ["green3","#00cc00","#00c000","green","black"] $ \ green ->+    --fg ["blue3","#0000cc","#0000c0","blue","black"] $ \ blue ->+    let drawStatus status =+          g $ FixCD 12 $+	  case status of+	    Unknown     -> [noLight]+	    InProgress  -> yellowLight+	    InError     -> redLight+	    Good        -> greenLight++	redLight = colLight red+	greenLight = colLight green+	yellowLight = colLight yellow+	colLight fg = [light fg,noLight]+	light fg = (fg,[FillArc (Rect 2 9) 0 (64*360)])+	noLight = (black,[DrawArc (Rect 2 9) 0 (64*360)])+    in cont drawStatus+  where+    fg colspec cont =+      wCreateGCtx rootGCtx (gcFgA colspec) $ cont . gctx2gc+++--instance Graphic Status where measureGraphicK = measureGraphicK . drawStatus
+ tools/pfe/Browser/pfebrowser.hs view
@@ -0,0 +1,22 @@+import Fudgets(fudlogue)+import PfeBrowserF(mainF)+import PPU(getPPopts)+--import PFE0(maybeF)+--import LexerOptions+import PFE_Certs(getProgramaticaDir,getCertServers')++--import Maybe(fromMaybe)+--import MUtils+--import FileUtils(readFileMaybe)++main =+  do (opts,name,args0) <- getPPopts+   --lexerflags1 <- fromMaybe lexerflags0 # maybeF readFileMaybe lexerflagsPath+   --lexerflags1 <- return lexerflags0+     let --(lexerflags,args1) = lexerOptions lexerflags1 args0+         args1 = args0+     pdir <- getProgramaticaDir+     servers <- getCertServers' pdir+     fudlogue $ mainF ({-lexerflags,-}(opts,name,args1)) pdir servers++--exerflagsPath dir=dir++"lexeroptions" -- copied from ppfe.hs !!
+ tools/pfe/Browser/pfebrowser.sh view
@@ -0,0 +1,9 @@+#!/bin/bash++# Wrapper script for pfebrowser, to set the PROGRAMATICA environment variable.++defaultPROGRAMATICA="/home/project/pacsoft/tools/lib/Programatica"+PROGRAMATICA="${PROGRAMATICA-$defaultPROGRAMATICA}"+export PROGRAMATICA++exec "$PROGRAMATICA/bin/pfebrowser" "$@"
+ tools/pfe/Flags.ghc view
@@ -0,0 +1,20 @@+PFE0.hs: -fallow-undecidable-instances+PFE2.hs: -fno-monomorphism-restriction+PFE3.hs: -fno-monomorphism-restriction+PFEdeps.hs: -fno-monomorphism-restriction+PFE4.hs: -fno-monomorphism-restriction+PFE_StdNames.hs: -fno-monomorphism-restriction+PFE_Rewrites.hs: -fno-monomorphism-restriction+PFE_Rewrite.hs: -fno-monomorphism-restriction+Pfe0Cmds.hs: -fno-monomorphism-restriction+Pfe1Cmds.hs: -fno-monomorphism-restriction+Pfe2Cmds.hs: -fno-monomorphism-restriction+Pfe3Cmds.hs: -fno-monomorphism-restriction+Pfe3Metrics.hs: -fno-monomorphism-restriction+Pfe4Cmds.hs: -fno-monomorphism-restriction+PfeHtmlCmds.hs: -fno-monomorphism-restriction+PfeDepCmds.hs: -fno-monomorphism-restriction+PfeVersionCmd.hs: -fno-monomorphism-restriction+PfeChase.hs: -fno-monomorphism-restriction+PfeParse.hs: -fno-monomorphism-restriction+PfeTransformCmds.hs: -fno-monomorphism-restriction
+ tools/pfe/HEADER.html view
@@ -0,0 +1,15 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<head>+<title>Programatica Tools, tools/pfe</title>+<link rel=parent href="../" title="Programatica Tools">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../web/icon1.png">+</head>+<body>+<h1><img align=right src="../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/pfe</h2>++The README file is displayed below the directory index.
+ tools/pfe/HuMakefile view
@@ -0,0 +1,9 @@++PFE_DIR=${PFE_DIR-.}+BASE=${BASE-../base}+HS2HTML_DIR=${HS2HTML_DIR-$PFE_DIR/../hs2html}+. $BASE/HuMakefile++SRC_DIRS=$PFE_DIR:$MODSRC_DIRS:$BPARSE_DIRS:$HS2HTML_DIR++GHCFLAGS="-package network $GHCFLAGS"
+ tools/pfe/Makefile view
@@ -0,0 +1,44 @@+TARGETS=pfeclient++### Optimization and other compiler options:+OPT=+#OPT=-O2+HFLAGS=++### Tools:+RM=rm -f+HMAKE=sh ../scripts/hsmake.sh++################################################################################+### Rules for compiling the programs++all: $(TARGETS)++pfe:: baseparser+	@sh ../scripts/updateNow.sh Now.hs+	$(HMAKE) $(OPT) $(HFLAGS) pfe -o pfe++pfeclient::+	$(HMAKE) $(OPT) $(HFLAGS) pfeclient -o pfeclient++baseparser::+	@$(MAKE) -C ../base/parse2++################################################################################+### Rules for generating HTML++hi/srclist.txt:+	$(MAKE) baseparser+	PFE_LIBS=../base/tests pfesetup cpp pfe.hs++html:: hi/srclist.txt+	-[ -d hi/html ] && cd hi/html && gunzip *.gz+	pfe htmlfiles+	cd hi/html && gzip -9 *.html++################################################################################+### Rules for cleaning up++clean:+	$(RM) -r $(TARGETS) hi+	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'
+ tools/pfe/PFE0.hs view
@@ -0,0 +1,522 @@+-- Programatica Front-End, level 0, see README.html+module PFE0(+    PFE0MT,runPFE0,clean0,+    pput,epput,+    Upd,getSt0ext,updSt0ext,setSt0ext, -- for extending the state+    ModuleNode,ModuleGraph,+    getCurrentModuleGraph,sortCurrentModuleGraph,getSortedSubGraph,getSubGraph,+    allModules,allFiles,moduleList,+    findFile,findFile',findNode,findNode',+    getModuleInfixes,getModuleImports,+    updateModuleGraph,+    parserFlags,ppFlags,+    batchMode,setBatchMode,+    newProject,addPaths,removePaths,saveSrcList,checkProject,projectStatus,+    lex0SourceFile,preparseModule,preparseSourceFile,lexAndPreparseSourceFile,+    projectDir,projPath,maybeF,withProjectDir,withProjectDir',newProjectHelp,+    moduleInfoPath,+    -- Pure functions:+    optSubGraph,subGraph,+    -- Independent of PFE:+    moduleNode,newerThan+  ) where+import Prelude hiding (readFile,writeFile,putStr,putStrLn,catch,ioError)+import List(sort,nub,(\\))+import Monad(when,unless)+import Maybe(fromMaybe,fromJust,isJust)++import HsModule+import HsAssocStruct+import HsIdent+import ReAssoc(HasInfixDecls,getInfixes)+import NamesEntities(getQualified)+import QualNames(QualNames) +import SourceNames(SN,fakeSN)+import HasBaseName(getBaseName)++import MUtils(( # ),(@@),done,collectByFst,mapFst,apFst,apSnd,ifM,seqMaybe)+import SimpleGraphs(reverseGraph,reachable)+--import EnvMT+import MT (MT(..))+import StateMT(WithState,withSt,withStS,getSt,setSt,updSt,updSt_)+import DirUtils+import FileUtils+import AbstractIO+import NewSCC(scc)+import PPU+import ParserOptions+import ParseMonad(PM)++import Unlit(readHaskellFile)+import ParseMonad(parseTokens)+import HsLexerPass1(Lexer)+import HsLexMerge(mergeLex)++--------------------------------------------------------------------------------+-- Types manipulated at PFE level 0:++type ModuleNode = (FilePath,(ModuleName,[ModuleName]))+type ModuleGraph = [ModuleNode]+type SortedModuleGraph = [ModuleGraph] -- strongly connected components++type Fixities n = [(HsIdentI n,HsFixity)]+type ModuleFixities n = [(ModuleName,Fixities n)]++--------------------------------------------------------------------------------++--type PFE i ds m a = WithEnv (Parser i ds m) m a+--type Parser i ds m = FilePath -> m (HsModuleI i ds)++--pfe :: (PFE_IO m, DefinedNames (SN HsName) ds, HasInfixDecls (SN HsName) ds)+--    => (Maybe String->Parser (SN HsName) ds m) -> [String] -> m ()++--type PFE0Env i ds = ((Flags,(Bool,PPHsMode)),(Lexer,PM (HsModuleI i ds)))++data State0 n i ds = PFE0 { myname :: String,+			    batch :: Bool,+			    cacheDir :: Maybe FilePath,+			    parserOpts :: ParserOptions.Flags,+			    ppOpts :: (Bool,PPHsMode),+			    lexer :: Bool->Lexer,+			    parser :: PM (HsModuleI (SN ModuleName) i ds),+			    fixities :: ModuleFixities n,+			    srclist :: [FilePath],+			    tgraph :: Maybe (Maybe ClockTime,ModuleGraph),+			    sortedgraph :: Maybe SortedModuleGraph }++initState0 name (lexer,parser)+  = PFE0 { myname = name, -- name of command, for usage message+	   batch = True, -- batch mode (always trust data in internal caches)+	   cacheDir = Nothing, -- location of current project cache+	   parserOpts = flags0,+	   ppOpts = ppOpts0,+	   lexer = lexer,+	   parser = parser,+	   fixities = [],+	   srclist = [],+	   tgraph = Nothing,+	   sortedgraph = Nothing }++graph st = snd # tgraph st+-- Old:+--type PFE0Info n = (ModuleGraph,ModuleFixities n)+--pfe0info st = (graph st,fixities st)+++-- Leave room for extending the state (poor man's subtyping):+type PFE0State n i ds nextlevel = (State0 n i ds,nextlevel)++type PFE0MT n i ds ext m = WithState (PFE0State n i ds ext) m+withPFE0 :: Monad m => PFE0State n i ds ext -> PFE0MT n i ds ext m a -> m a+withPFE0 = withSt ++{-++All level 0 functions work in arbitrary monads that provide access to+the level 0 state (and some other things). The following type+signatures *restricts* level 0 functions to the PFE0MT monad transformer.+We don't need the extra generality at the moment and the restriction+should make the inferred types more readable (but since+GHC doesn't do any context reduction, they are still not very+readable...)+-}+type Upd s = s->s+getSt0 :: Monad m => PFE0MT n i ds ext m (State0 n i ds)+updSt0 :: Monad m => Upd (State0 n i ds)->PFE0MT n i ds ext m ()+getSt0ext :: Monad m => PFE0MT n i ds ext m ext+updSt0ext :: Monad m => Upd ext->PFE0MT n i ds ext m ()++getSt0 = fst # getSt+updSt0 = updSt_ . apFst+setSt0 x = updSt0 (const x)++getSt0ext = snd # getSt+updSt0ext = updSt_ . apSnd+setSt0ext x = updSt0ext (const x)++batchMode :: Monad m => PFE0MT n i ds ext m Bool+batchMode = batch # getSt0+setBatchMode b = updSt0 $ \st->st{batch=b}++getLexer () = do PFE0{lexer=l,parserOpts=flags} <- getSt0+	         return (l (plogic flags))+              +runPFE0 ext pfeM lexerAndParser (opts,name,args0) =+  do let st0 = (initState0 name lexerAndParser){ppOpts=opts}+     withPFE0 (st0,ext) $ pfeM (name++" [options]") =<< initProject args0++initProject args0 =+  do res <- try (loadSrcList ())+     case res of+       Left err ->+         if isDoesNotExistError err+	 then blankProject args0+	 else ioError err+       Right files -> openProject projdir args0+  where+    projdir = defaultProjectDir++    loadSrcList () =+      do paths <- lines # readFile (srclistPath projdir)+	 setSrcList paths+	 clearGraph ()+	 return paths++    clearGraph () =+      updSt0 $ \st->st{fixities=[],tgraph=Nothing,sortedgraph=Nothing}++blankProject args0 =+  do flags0 <- parserFlags+     let (flags,args) = parserOptions flags0 args0+     updSt0 $ \st->st{parserOpts=flags}+     return args++openProject dir args0 =+  do updSt0 $ \st->st{cacheDir=Just dir}+     flags0 <- parserFlags+     let opath = optionsPath dir+     flags1 <- fromMaybe flags0 # (readFileMaybe opath)+     let (flags,args) = parserOptions flags1 args0+     updSt0 $ \st->st{parserOpts=flags}+     --quietUpdateModuleGraph+     when (flags/=flags1) $ writeFile opath (show flags)+     return args++setpfe0info (tg,fs) =+     updSt0 $ \st->st{tgraph=Just tg,fixities=fs,sortedgraph=Nothing}++newProject ::+  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+  PFE0MT n i ds ext m ()+newProject =+  do let dir=defaultProjectDir+     optCreateDirectory dir+     updSt0 $ \st->st{cacheDir=Just dir}+     setSrcList []+     setpfe0info ((Nothing,[]),[])+     let opath = optionsPath dir+     writeFile opath . show =<< parserFlags+     updateModuleGraph++saveSrcList paths =+  do setSrcList paths+     flip updateFile_ (unlines . set $ paths) `projPath` srclistPath++setSrcList paths = updSt0 $ \st->st{srclist=paths}++preparseModule m = preparseSourceFile =<< findFile m++preparseSourceFile path =+  do flags <- parserFlags+     optAddPrelude fakeSN (prel flags) #+	(parseFile path =<< readHaskellFile (cpp flags) path)+  where+    parseFile path (litcmnts,code) = +      do parseModule <- parser # getSt0+	 lexerPass0 <- getLexer()+	 parseTokens parseModule path (lexerPass0 code)++-- lexAndPreparseSourceFile :: (HasEnv m PFE0Env, FileIO m) =>+--  => FilePath -> m ([(Token,(Pos,String))],HsModuleI i)+lexAndPreparseSourceFile path =+  do PFE0{parserOpts=flags,parser=parseModule} <- getSt0+     lexerPass0 <- getLexer()+     lts@(_,ts) <- apSnd lexerPass0 # readHaskellFile (cpp flags) path+     m <- optAddPrelude fakeSN (prel flags) # parseTokens parseModule path ts+     return (mergeLex lts,m)++lex0SourceFile path =+  do PFE0{parserOpts=flags} <- getSt0+     lexerPass0 <- getLexer()+     apSnd lexerPass0 # readHaskellFile (cpp flags) path++parserFlags :: (Functor m,Monad m) => PFE0MT n i ds ext m (ParserOptions.Flags)+parserFlags = parserOpts # getSt0++ppFlags :: (Functor m,Monad m) => PFE0MT n i ds ext m (Bool,PPHsMode)+ppFlags = ppOpts # getSt0++-- Pretty print with options from PFE environment and put on stdout:+pput x =+  do o <- ppFlags+     putStrLn$ ppu o $ x++-- Pretty print with options from PFE environment and put on stderr:+epput x =+  do o <- ppFlags+     ePutStrLn$ ppu o $ x++findFile m = fst # findNode m+findNode m = findNode' m =<< getCurrentModuleGraph+++findFile' :: (Functor m, Monad m) => ModuleName -> ModuleGraph -> m FilePath+findFile' m g = fst # findNode' m g++findNode' :: Monad m => ModuleName -> ModuleGraph -> m ModuleNode+findNode' m g =+    case  [n|n@(_,(m',_))<-g,m'==m] of+      [n] -> return n+      []  -> fail $ pp $ "Unknown module:"<+>m+      _   -> fail $ pp $ "Module defined in several files:"<+>m++getModuleImports m = snd . snd # findNode m++getCurrentModuleGraph ::+  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)+   => PFE0MT n i ds ext m ModuleGraph+getCurrentModuleGraph =+  do ifM (isJust . graph # getSt0) done quietUpdateModuleGraph+     fromJust . graph # getSt0++sortCurrentModuleGraph ::+  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)+   => PFE0MT n i ds ext m [ModuleGraph]+sortCurrentModuleGraph =+  do optsg <- sortedgraph # getSt0+     case optsg of+       Just sg -> return sg+       _ -> do g <- getCurrentModuleGraph+	       case checkGraph g of+	         Just errs -> fail $ pp $ moduleGraphReport errs+	         _ -> do let sg = sortGraph g+			 updSt0 $ \st->st{sortedgraph=Just sg}+			 return sg++getSubGraph optms = concat # getSortedSubGraph optms+getSortedSubGraph optms = flip optSubGraph optms # sortCurrentModuleGraph++projectDir :: (Functor m,Monad m) => PFE0MT n i ds ext m (Maybe FilePath)+projectDir = cacheDir # getSt0+withProjectDir' n m = maybe n m =<< projectDir+withProjectDir x = withProjectDir' done x++allModules ::+  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)+   => PFE0MT n i ds ext m [ModuleName]+allModules = moduleList # sortCurrentModuleGraph++allFiles :: (Functor m,Monad m) => PFE0MT n i ds ext m [FilePath]+allFiles = srclist # getSt0++getModuleInfixes :: (Functor m,Monad m) => PFE0MT n i ds ext m (ModuleFixities n)+getModuleInfixes = fixities # getSt0++moduleList g = [m|scc<-g,(_,(m,_))<-scc]++projectStatus ::+  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+  PFE0MT n i ds ext m ()+projectStatus =+  do checkProject+     files <- allFiles+     if null files+       then do putStrLn "You have a new, empty project."+	       putStrLn "Add files to it by using: pfe add <files>"+       else do let n = length files+	       putStrLn $ "The project contains "+++			       if n==1+			       then "one source file."+			       else show (length files)++" source files."+	       putStrLn "(To list the files, use: pfe files)"+	       updateModuleGraph -- skip?++checkProject :: (Functor m,Monad m) => PFE0MT n i ds ext m FilePath+checkProject = withProjectDir' newProjectHelp return++newProjectHelp :: (Functor m,Monad m) => PFE0MT n i ds ext m a+newProjectHelp =+    do name <- myname # getSt0+       fail $ "Start by creating a new project using "+++	      name++" new or pfesetup"++addPaths q = changePaths (++) q+removePaths q = changePaths (\\) q++changePaths op quiet paths =+  do checkProject+     old <- allFiles+     new <- expand paths+     let files = old `op` paths+     saveSrcList files+     --optUpdateModuleGraph+     updateModuleGraph' quiet++sortGraph :: ModuleGraph -> [ModuleGraph]+sortGraph g = map (map post) . scc . map snd $ g+  where+    mfs = [(n,f)|(f,(n,_))<-g]+    post (n,is) = (fromMaybe (error "PFE0.sortGraph") $ lookup n mfs,(n,is))+++checkGraph g =+    if null dups && null missing+    then Nothing+    else Just (dups,missing)+  where+    dups = filter duplicated mfs+      where duplicated (m,fs) = length fs/=1+    mfs = collectByFst [(m,f)|(f,(m,_))<-g]+    known = set (map fst mfs)+    missing = collectByFst [(i,m)|(_,(m,is))<-g,i<-is,i `notElem` known]+++moduleGraphReport (mfs,missing) = reportDuplicates $$ reportMissing+  where+    reportDuplicates = sep (map reportDuplicate mfs)++    reportMissing = if null missing+		    then empty+		    else sep [ppi "Source files missing for (add files with 'pfe add' or 'pfe chase'): ",+			      nest 4 (vcat (map needed missing))]+        where needed (i,ms) = i<>","<+>"needed by"<+>fsep ms++    reportDuplicate (m,fs) = m<+>"defined in more than one file:"<+>fsep fs++optUpdateModuleGraph,quietUpdateModuleGraph,updateModuleGraph ::+  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+  PFE0MT n i ds ext m ()+optUpdateModuleGraph = ifM (isJust . graph # getSt0) updateModuleGraph done++quietUpdateModuleGraph = updateModuleGraph' True+updateModuleGraph      = updateModuleGraph' False ++-- Another type signature to improve the readablility of inferred types:+updateModuleGraph' ::+  (PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>+  Bool -> PFE0MT n i ds ext m ()++updateModuleGraph' quiet =+    do files <- allFiles+       tg <- optLoadModuleGraph files+       ofix <- getModuleInfixes+       (g,fixities) <- unzip # mapM (updateModuleImports ofix tg) files+       -- The graph written to modgraphPath must be current, since source files+       -- are reread only if they are newer than modgraphPath!+       flip writeFile (show g) `projPath` modgraphPath+       t <- maybe getClockTime return =<<+              getModificationTime' `projPath` modgraphPath+       updateGraphTextFiles g+       let r = maybe [] (pp . moduleGraphReport) (checkGraph g)+       unless (quiet || null r) $ ePutStrLn r+       --saveSrcList files+       setpfe0info ((Just t,g),fixities)+  where++    optLoadModuleGraph files =+        maybe (loadModuleGraph files) return . tgraph =<< getSt0++    loadModuleGraph files =+      do optgpath <- fmap modgraphPath # projectDir+	 case optgpath of+	   Just gpath ->+	     do g <- (readM =<< readFile gpath) `catch` const (return [])+	        t <- if null g+		     then return Nothing+		     else Just # getModificationTime' gpath+	        return (t,g::ModuleGraph)+	   _ -> return (Nothing,[])++    updateModuleImports ofix (gt,g) modulePath =+        case lookup modulePath g of+	  Nothing -> getModuleImports modulePath+	  Just mi ->+	    ifM ((`newerThan` gt) # getModificationTime' modulePath)+	        (getModuleImports modulePath)+	        (useOldImports ofix modulePath mi)++    getModuleImports modulePath =+        do m <- preparseSourceFile modulePath+	   m_infixes <- updateInfixes m+	   let node = moduleNode m+	   return ((modulePath,node),m_infixes)++    useOldImports oldfixities modulePath mi@(mn,_) =+      do infixes <- case lookup mn oldfixities of+	              Just infixes -> return infixes+	              _ -> withProjectDir' no yes+		       where yes dir = readM=<<readFile (infixFile dir mn)+			     no = fail$"Missing fixity info for: "++show mn+	 return ((modulePath,mi),(mn,infixes))++    --updateInfixes :: (Printable i,HasInfixDecls i ds,HasIO m) => HsModuleI i ds -> m Bool+    updateInfixes m =+	do let infixes = mapFst getQualified (getInfixes (hsModDecls m))+	       mn = getBaseName (hsModName m)+	       upd dir = do optCreateDirectory (infixdir dir)+			    updateFile_ (infixFile dir mn) (show infixes)+           withProjectDir upd+	   return (mn,infixes)++    updateGraphTextFiles fg = withProjectDir upd+      where+        upd dir = do updateFile_ (dir++"ModuleSourceFiles.txt") (txt2 fg)+	             updateFile_ (dir++"ModuleGraphRev.txt") (txtn rg)+        g = map snd fg+	rg = reverseGraph g+        txtn = unlines . map (\(m,is)->pp m++" "++unwords (map pp is))+        txt2 = unlines . map (\(f,(m,_))->pp m++" "++f)++moduleNode m = (getBaseName (hsModName m),{-set$-} map getBaseName (hsModImportsFrom m))+--------------------------------------------------------------------------------++t `newerThan` Nothing = True+t `newerThan` Just t' = t>t'++set xs = sort (nub xs)++optSubGraph g = maybe g (subGraph g)++subGraph g ms = [scc|scc<-g,any (`elem` r) [m|(_,(m,_))<-scc]]+  where r = reachable (map snd (concat g)) ms++updateFile_ path str = updateFile path str >> done++maybeF m f = maybe (return Nothing) (m.f) =<< projectDir++m `projPath` f = do d <- fmap f # projectDir+		    seqMaybe (fmap m d)++--------------------------------------------------------------------------------++clean0 :: SystemIO m =>  PFE0MT n i ds ext m ()+clean0 = withProjectDir clean+  where+    clean dir =+      rmR [modgraphPath dir,+	   dir++"ModuleSourceFiles.txt",+	   dir++"ModuleGraphRev.txt",+	   infixdir dir]+      >>done++--------------------------------------------------------------------------------++defaultProjectDir = "hi/"+infixdir dir=dir++"infix/"+srclistPath dir= dir++"srclist.txt"+modgraphPath dir= dir++"FileModules.hv"+optionsPath dir= dir++"options"++infixFile dir m = infixdir dir++moduleInfoPath m++".hv"++moduleInfoPath m = map conv (pp (m::ModuleName))+  where+    conv '/' = '-'+    conv c = c++--------------------------------------------------------------------------------+{-+instance CatchIO err m => CatchIO err (WithEnv e m) where+  m `catch` f = do e <- getEnv+                   lift (withEnv e m `catch` (withEnv e . f))+  ioError = lift . ioError+-}+instance CatchIO err m => CatchIO err (WithState s m) where+  m `catch` f = do s0 <- getSt+                   (a,s1) <- lift $ withStS s0 m `catch` (withStS s0 . f)+		   setSt s1+		   return a+  ioError = lift . ioError++-- a class synonym:+class (FileIO m,DirectoryIO m,CatchIO e m,StdIO m,SystemIO m,TimeIO m) => PFE0_IO e m | m->e+instance (FileIO m,DirectoryIO m,CatchIO e m,StdIO m,SystemIO m, TimeIO m) => PFE0_IO e m
+ tools/pfe/PFE1.hs view
@@ -0,0 +1,1 @@+module PFE1 where
+ tools/pfe/PFE2.hs view
@@ -0,0 +1,166 @@+-- Programatica Front-End, level 2, see README.html+module PFE2(+  PFE2MT,runPFE2,clean2,+  getSt2ext,updSt2ext,setSt2ext,+  getAllExports,getExports,getModuleExports,getModuleExportsTime,getModuleTime+  ) where+import Prelude hiding (readFile,putStrLn)+import Maybe(isJust,isNothing,fromJust)+import List(nub,intersect,(\\))++import HsModule+import WorkModule(analyzeSCM,expRel,ExpRel,readRel,showRel)+import Relations(Rel)+--import Ents(Ent)+import PFE0++import PrettyPrint(pp,fsep,(<+>))+import MUtils+import StateMT(getSt,updSt_)+import AbstractIO+import FileUtils+import DirUtils(optCreateDirectory,getModificationTimeMaybe,rmR)++type Exports n = [(ModuleName,(ClockTime,ExpRel n))]++type PFE2Info n = Exports n+pfe2info0 = []::PFE2Info n++type PFE2MT n i ds ext m =  PFE0MT n i ds (PFE2Info n,ext) m++runPFE2 ext = runPFE0 (pfe2info0,ext)++getSt2 :: Monad m => PFE2MT n i ds ext m (PFE2Info n)+updSt2 :: Monad m => Upd (PFE2Info n)->PFE2MT n i ds ext m ()+getSt2ext :: Monad m => PFE2MT n i ds ext m ext+updSt2ext :: Monad m => Upd ext->PFE2MT n i ds ext m ()++getSt2 = fst # getSt0ext+updSt2 = updSt0ext . apFst +setSt2 = updSt2 . const++getSt2ext = snd # getSt0ext+updSt2ext = updSt0ext . apSnd+setSt2ext = updSt2ext . const++-- The latest time at which the module or one of its imports was modified:+getModuleTime m =+    do (path,(_,imports)) <- findNode m+       srct <- getModificationTime path+       expts <- mapM getModuleExportsTime imports+       return (maximum (srct:expts))++getModuleExportsTime m = fst # getModuleExports m     ++getModuleExports m =+    maybe (fail $ pp $ "Unknown module:"<+>m) return . lookup m+      =<< getExports (Just [m])++getAllExports = getExports Nothing++getExports optms =+  do oldExports <- getSt2+     ms <- maybe allModules return optms+     b <- batchMode+     if b && haveAll oldExports ms+       then return oldExports+       else do exports <- analyzeModules' oldExports optms+               setSt2 exports+               return exports+  where+    haveAll old ms = null (nub ms\\map fst old)++-- Compute the WorkModules for all modules in the project:+--analyzeModules = analyzeModules' pfe2info0 Nothing++-- Compute the WorkModules for a selected set of modules in the project:+analyzeModules' oldExports optms =+    do optCreateDirectory `projPath` scopedir+       g <- sortCurrentModuleGraph+       exports <- scopeScms [] [] (optSubGraph g optms)+       let newms = map fst exports+           oldexports = [oe|oe@(m,_)<-oldExports,m `notElem` newms]+       return (exports++oldexports)+  where++    scopeScms exports updated [] = return exports+    scopeScms exports updated (scm:scms) =+      do (exports',updated') <- scopeScm exports updated scm+	 scopeScms (exports'++exports) (updated'++updated) scms++    scopeScm exports updated scm =+      do es <- mapM getOldExport scm+	 let imps = imports scm+	     updimps = imps `intersect` updated -- updated imports+         case mapM id es of+	   Just exports' | null updimps ->+	        do let ms = map (fst.snd) scm+		   return (zip ms exports',[])+	   _ -> do epput $ "Analyzing:" <+>fsep (map fst scm)+		   a <- analyzeSCM (mapSnd snd exports) # preparseSCM scm+		   case a of+		     Left err -> fail (pp err)+		     Right wms' ->+		       do (unchanged,ts) <- unzip # mapM updateWorkModule wms'+			  let updated' = [m|((m,_),False)<-zip wms' unchanged]+			      exports' = zipWith f ts wms' +			      f t (m,wm) = (m,(t,expRel wm))+			  return (exports',updated')++    imports scm = nub [i|(f,(m,is))<-scm,i<-is]+    preparseSCM = mapM (preparseSourceFile.fst)++    getOldExport (f,(m,_)) =+      do let opt_oexp = lookup m oldExports+	     oexpt = fmap fst opt_oexp+         -- Is the export relation in the internal cache present and fresh?+	 b <- batchMode+	 srct <- if b then return undefined else getModificationTime f+	 if if b then isNothing oexpt else srct `newerThan` oexpt+	   then do optdir <- projectDir+		   case optdir of+		     Nothing -> return Nothing -- no external cache+		     Just dir ->+		       do let expf = exportsFile dir m+			  expt <- getModificationTimeMaybe expf+			  srct <- if b+				  then getModificationTime f+				  else return srct+			  --Ditto for the export relation in the external cache?+			  if srct `newerThan` expt+			    then return Nothing+			    else maybeM (((,) (fromJust expt) . readRel)+                                          # readFileNow expf)+	   else return opt_oexp+    --fromJust' = fromMaybe (error "PFE2.getOldExport")++    --getInscope (_,(m,_)) = read # readFile (inscopeFile m)++    updateWorkModule (m,wm) =+      do optdir <- projectDir +         case optdir of+           Nothing ->+	     do --No access to the old exports here, so we have to assume+	        --they have changed!! (This should be easy to improve.)+                t <- getClockTime+		return (True,t)+	   Just dir ->+             do --updateFile (inscopeFile dir m) (show (inscpRel wm))+                let expf = exportsFile dir m+		updated <- updateFile' expf (showRel (expRel wm))+		t <- getModificationTime expf+		return (updated,t)+--------------------------------------------------------------------------------+clean2 = withProjectDir clean+  where+    clean dir = do rmR [scopedir dir]+		   clean0++--------------------------------------------------------------------------------++scopedir dir=dir++"scope/"++exportsFile dir m = scopedir dir++moduleInfoPath m++".exports"+--inscopeFile dir (Module s) = scopedir dir++s++".inscope"++--------------------------------------------------------------------------------
+ tools/pfe/PFE3.hs view
@@ -0,0 +1,101 @@+{-++PFE level 3: proper parsing of Haskell modules.+-}+module PFE3(module PFE3,XRefInfo) where++import ReAssocModule(reAssocModule)+import ScopeModule(scopeModule,XRefInfo,checkRefs)+import AST4ModSys(toMod)+import Modules(inscope)+import WorkModule(mkWM)+import Relations(emptyRel)+import PrettyPrint(pp,vcat,($$),(<>),(<+>))++import PFE0(Upd,moduleNode,findFile,lexAndPreparseSourceFile,getModuleInfixes,+            getModuleImports,updateModuleGraph,batchMode)+import PFE2--(getExports,getModuleExports)++import MUtils+import Monad(when)++--------------------------------------------------------------------------------+type PFE3MT n i ds ext m = PFE2MT n i ds ext m++runPFE3 ext = runPFE2 ext+clean3 = clean2++--getSt3 :: Monad m => PFE3MT n i ds ext m (PFE3Info n)+--updSt3 :: Monad m => Upd (PFE3Info n)->PFE3MT n i ds ext m ()+getSt3ext :: Monad m => PFE3MT n i ds ext m ext+updSt3ext :: Monad m => Upd ext->PFE3MT n i ds ext m ()++--getSt3 = fst # getSt0ext+--updSt3 = updSt0ext . apFst +--setSt3 = updSt3 . const++getSt3ext = getSt2ext+updSt3ext = updSt2ext+setSt3ext = updSt3ext . const+--------------------------------------------------------------------------------+--parseModule :: ... => ModuleName -> m (WorkModule ..,HsModule ...)+--parseSourceFile :: ... => FilePath -> m (WorkModule ..,HsModule ...)+parseModule       = parseSourceFile @@ findFile+parseSourceFile f = fst . snd # parseSourceFile' f++refsModule = refsSourceFile @@ findFile+refsSourceFile f = snd . snd # parseSourceFile'' f++parseModule' = parseSourceFile' @@ findFile++-- Parse, rewrite infix applications, check identifiers+parseScopeSourceFile = checkScope . snd @@ parseSourceFile'+  where+    checkScope (m,refs) = check (checkRefs refs) >> return m++    check [] = done+    check errs =+        fail $ pp $ "Scoping errors" $$ vcat [loc<>":"<+>err|(loc,err)<-errs]+    +-- Parse and rewrite infix applications according to their fixities+parseSourceFile' path =+    do infixes <- getModuleInfixes+       let re wm = reAssocModule wm infixes+       parseSourceFile''' re path++-- Parse *without* rewriting infixes+parseSourceFile'' = parseSourceFile''' (const id)++-- rewrite:  does the rewriting to fix the parse tree when the +--           fixities of operators are known+-- filepath: the file to be parsed   ++parseSourceFile''' rewrite filepath =+     do (ts,mod) <- lexAndPreparseSourceFile filepath+	let n@(m,imports) = moduleNode mod+	unlessM batchMode $+	  do oldimports <- getModuleImports m+	     when (imports/=oldimports) updateModuleGraph+	exp <- snd # getModuleExports m+	exports <- getExports (Just imports)+	let insc = inscope (toMod mod) (expOf exports)+	    wm = mkWM (insc,exp)+	    ex = mapSnd snd exports -- drop datestamp+	    (mod',refs) = scopeModule (wm,ex) (rewrite wm mod)+	return (ts,(((wm,ex),mod'),refs))+  where++{-++To prevent pfebrower from crashing if the module graph is inconsistent,+expOf does not fail on references to unknown modules. Instead it returns+an empty export relation...+-}++    expOf exports m = maybe emptyRel snd (lookup m exports)++    {-+    -- For debugging:+    expOf exports m =+      case lookup m exports of+	Just (_,es) -> es+	_ -> error $ "PFE3: Didn't find export relation for: "++show m+    -}
+ tools/pfe/PFE4.hs view
@@ -0,0 +1,270 @@+module PFE4(+  PFE4MT,PFE4Info,runPFE4,clean4,+  getSt4ext,updSt4ext,setSt4ext,modEnv,+  typeCheckModule,rewriteAndTypeCheckModule,+  typeCheck,rewriteAndTypeCheck,topTypes,typeCheck',exTypeCheck,+  ) where+import Prelude hiding (putStrLn,readFile,catch,ioError)++--import Monad(when)+import List(intersect)+import Maybe(fromMaybe,isNothing)++import HsConstants(mod_Prelude,mod_Ix)+import HsModule(HsModuleI,ModuleName(..),hsModName)+import HsModuleMaps(mapDecls)+import TiModule(tcModuleGroup,representative,monomorphismRestriction)+import TiNames(topName)+import Relations(applyRel)+import WorkModule(Ent(..))+import TiPNT()+import TI(DeclsType,extendIEnv,extendEnv,concDeclsType,moduleContext,Typing(..),unzipTyped,run)+import TiError(Error)+import TiInstanceDB(Instance)++import PNT(PNT(..))+import HsIdent(HsIdentI(..))+import TypedIds(IdTy(Value),NameSpace(..),namespace)+import UniqueNames(noSrcLoc)+import HasBaseName(getBaseName)+import SourceNames(SN,fakeSN)+import ScopeModule(origName)++import PFE3(parseScopeSourceFile)+import PFE3(PFE3MT,runPFE3,getSt3ext,updSt3ext,clean3)+import PFE2(getExports)+import PFE0(Upd,epput,newerThan,optSubGraph,sortCurrentModuleGraph,projPath,projectDir,maybeF,withProjectDir,moduleInfoPath,allModules)+import PFE_Rewrites(getStdNames,prelValue,flRewrite)+import PFE_Rewrite+import PrettyPrint+import qualified Lift+import MUtils+import ExceptMT+--import StateMT(getSt,updSt_)+import SimpleGraphs(reachable)+import AbstractIO+import FileUtils(updateFile')+import DirUtils(optCreateDirectory,getModificationTimeMaybe,latestModTime,rmR)+++type ModuleTypeInfo i ds =+    (ClockTime,([(RewriteName,HsModuleI (SN ModuleName) i ds)],+		([Instance i],DeclsType i)))++type PFE4Info i ds = [(ModuleName,ModuleTypeInfo i ds)]+++modEnv :: PFE4Info i ds -> ModuleName -> Maybe (DeclsType i)+modEnv pfe4info m = snd . snd . snd # lookup m pfe4info++--id4 :: Upd (PFE4Info i ds)+--id4 = id++pfe4info0 = []::PFE4Info i ds++type PFE4MT n i1 i2 ds1 ds2 ext m = PFE3MT n i1 ds1 (PFE4Info i2 ds2,ext) m++-- Extra exeption monad transformer,+-- to be able to keep the structured type for type errors.+-- It's just only locally for now because of the extra lifting involved+type ExPFE4MT n i1 i2 ds1 ds2 ext m+  = WithExcept (Error (HsIdentI i2)) (PFE4MT n i1 i2 ds1 ds2 ext m)++runPFE4 ext = runPFE3 (pfe4info0,ext)++getSt4 :: Monad m => ExPFE4MT n i1 i2 ds1 ds2 ext m (PFE4Info i2 ds2)+updSt4 :: Monad m => Upd (PFE4Info i2 ds2)->ExPFE4MT n i1 i2 ds1 ds2 ext m ()+getSt4ext :: Monad m => PFE4MT n i1 i2 ds1 ds2 ext m ext+updSt4ext :: Monad m => Upd ext->PFE4MT n i1 i2 ds1 ds2 ext m ()++getSt4 = fst # lift getSt3ext+updSt4 = lift . updSt3ext . apFst +setSt4 = updSt4 . const++getSt4ext = snd # getSt3ext+updSt4ext = updSt3ext . apSnd+setSt4ext = updSt4ext . const++expfe4 = id :: Upd (ExPFE4MT n i1 i2 ds1 ds2 ext m a) -- a type signature with holes+pfe4 = id :: Upd (PFE4MT n i1 i2 ds1 ds2 ext m a) -- a type signature with holes++typeCheckModule m = rewriteAndTypeCheckModule idRw m++rewriteAndTypeCheckModule rewrite@(Rewrite rwname0 _) m =+  do --epput $ "rewriteAndTypeCheckModule"<+>m+     r <- lookuprw.fst.snd.fromJust' "PFE4.hs:108b" .lookup m+            # rewriteAndTypeCheck rewrite (Just [m])+     --seq r $ epput $ "return from rewriteAndTypeCheckModule"<+>m+     return r+  where+    rwname = rwname0++"fl"+    lookuprw rws =+      fromJust' ("PFE4.hs:108a "++rwname++" "++show (map fst rws))+		(lookup rwname rws)++rewriteAndTypeCheck f = rewriteAndTypeCheck' f True+typeCheck             = typeCheck' True+topTypes              = typeCheck' False++exTypeCheck           = removeExcept . exRewriteAndTypeCheck' idRw True++{-+typeCheck' :: ... => Bool -> [ModuleName] -> t m (PFE4Info i2 ds)+-}+typeCheck' = rewriteAndTypeCheck' idRw++rewriteAndTypeCheck' rewrite wantAST optms =+  pfe4 $ +  Lift.lift =<< removeExcept (exRewriteAndTypeCheck' rewrite wantAST optms)++exRewriteAndTypeCheck' userRewrite wantAST optms =+  do subsg <- flip optSubGraph optms # lift sortCurrentModuleGraph+     oldTypes <- getSt4+     stdNames <- lift getStdNames+     let rewrite = userRewrite `compRw` flRewrite+     types <- rewriteAndTypeCheck'' stdNames rewrite wantAST optms oldTypes subsg+     let newTypes = types++[old|old@(m,_)<-oldTypes,m `notElem` newms]+	 newms = map fst types+     setSt4 newTypes+     return types++rewriteAndTypeCheck'' stdNames (Rewrite rwname rwM) wantAST optms oldTypes subsg =+    expfe4 $+    do lift $ optCreateDirectory `projPath` typesdir+       rewrite <- lift rwM+       tcSccs rewrite [] [] subsg+  where+    subg = map snd (concat subsg)+    ms = fromMaybe (map fst subg) optms+    rms = map (fst.snd.head) subsg -- representative from each scc++    tcSccs rewrite types updated [] = return types+    tcSccs rewrite types updated (scc:sccs) =+	  do let sccms = map (fst.snd) scc+		 wanted = wantAST && (not.null $ sccms `intersect` ms)+             --lift $ epput $ "wantAST="<>wantAST<+>"wanted="<>wanted+	     (types',updated') <- tcScc rewrite wanted sccms types updated scc+	     tcSccs rewrite (types'++types) (updated'++updated) sccs++    tcScc rewrite wanted mns types updated scc@(_:_) =+        if wanted && any isNothing [lookup rwname.fst.snd=<<lookup m oldTypes|m<-mns]+           || not (null updated_imports)+	then tcAgain+	else useOld+      where+	updated_imports = imports_approx `intersect` updated++        -- A coarse approximation to what is needed by a module:+        -- (Advantage: this is the right thing for instances)+        imports_approx = reachable subg mns++	useOld =+	  do srct <- latestModTime srcfs+	     let opt_oldtypes = mapM (flip lookup oldTypes) mns+		 oldtt = minimum.map fst # opt_oldtypes+	     if srct `newerThan` oldtt+		then do tt <- lift $ maybeF getModificationTimeMaybe typesf+	                if srct `newerThan` tt+			  then tcAgain+			  else do --lift $ epput $ "Using old types:"<+>fsep mns+                                  types' <- readTypeFiles+				  let t = fromJust' "PFE4.hs:177" tt+				  -- !!! Type info is duplicated here:+				  return ([(m,(t,([],types')))|m<-mns],[])+		else return (zip mns (fromJust' "PFE4.hs:180" opt_oldtypes),[])++        parseSCM = mapM ((mapDecls rewrite . snd # ) .+                         parseScopeSourceFile .fst)++	tcAgain =+	  do ms <- lift (parseSCM scc)+             lift $ epput $ "Type checking:"<+>fsep mns+             tms:>:types' <- tcScc' ms+	     optdir <- lift projectDir+	     (updated,t) <-+               case optdir of+		 Nothing ->+	           do --No access to the old types here, so we have to assume+	              --they have changed!! (This should be easy to improve.)+                      t <- getClockTime+		      return (True,t)+		 Just dir ->+		   do updated <- updateTypeFiles dir types'+		      t <- getModificationTime (typesf dir)+		      return (updated,t)+	     --lift $ epput $ [(getBaseName (hsModName tm),(show t,([(rwname,"()")],"()")))|tm<-tms]+	     -- !!! Type info is duplicated here:+	     return ([(getBaseName (hsModName tm),(t,([(rwname,tm)],types')))|tm<-tms],+		     if updated then mns else [])+++        tcScc' ms =+           do mono <- (/=Just "no") # maybeM (getEnv "PFE_monomorphism")+	      --Lift.lift $+              either raise return . run $+                 tcScc'' mono ms++	tcScc'' mono ms@(_:_) =+	    monomorphismRestriction mono $+	    extendIEnv (concat insts) $ extendEnv (concDeclsType envs) $+	    moduleContext mns $ tcModuleGroup stdNames rewrite ms+	  where+	    (insts,envs) = unzip [mt|(m,(_,(_,mt)))<-types,+				     m `elem` imports_approx,m `elem` rms]++	srcfs = map fst scc+	mn = representative mns -- pick one representative from the scc+	kindsf = kindsFile mn+	typesf = typesFile mn+	instsf = instsFile mn++        updateTypeFiles dir (insts,(kinds,types)) =+	  do uk <- updateFile' (kindsf dir) (showTypings kinds)+	     ut <- updateFile' (typesf dir) (showTypings types)+             ui <- updateFile' (instsf dir) (show insts)+	     return (uk||ut||ui)++        readTypeFiles =+	  do dir <- fromJust' "PFE4.hs:233" # lift projectDir+             kinds <- readTypings # readFile (kindsf dir)+	     types <- readTypings # readFile (typesf dir)+	     insts <- let path = instsf dir+                      in read'' path # readFile path+	     return (insts,(kinds,types))++showTypings xys = shl (length xs).shls (map (fmap pn) xs) . shls ys $ ""+  where+     shls xs r = foldr shl r xs+     shl x = shows x.showChar '\n'+     xs:>:ys = unzipTyped xys+     pn (PNT n _ _) = n -- hmm++readTypings s = rdls (lines s)+  where+     rdls (n:ls) = uncurry zipTypings (splitAt (rd n) ls)+     zipTypings [] _ = []+     zipTypings (x:xs) ~(y:ys) = (fmap pnt (rd x):>:rd y):zipTypings xs ys+     pnt n = PNT n Value noSrcLoc -- hmm!+     rd s = read'' "PFE4.readTypings" s++--------------------------------------------------------------------------------+clean4 = withProjectDir clean+  where+    clean dir = do rmR [typesdir dir]+		   clean3++--------------------------------------------------------------------------------++typesdir dir=dir++"types/"++typesFile m dir = typesdir dir++moduleInfoPath m++".types"+kindsFile m dir = typesdir dir++moduleInfoPath m++".kinds"+instsFile m dir = typesdir dir++moduleInfoPath m++".insts"++--------------------------------------------------------------------------------+instance CatchIO err m => CatchIO err (WithExcept e m) where+  m `catch` f = do r <- lift $ try $ removeExcept m+	           case r of+                     Left ioe -> f ioe+		     Right ok -> either raise return ok+  ioError = lift . ioError
+ tools/pfe/PFE_HTML.hs view
@@ -0,0 +1,56 @@+module PFE_HTML where+import Prelude hiding(putStrLn,writeFile)+--import Maybe(fromJust)+import Monad(when,unless)++--import HsName(ModuleName(Module))+--import ScopeModule(scopeModule)++import ConvRefsTypes(simplifyRefsTypes')+import HLex2html(hlex2html')+import HsLexerPass1(line,column) -- hmm++import PFE0(findFile,newerThan,getCurrentModuleGraph,allModules,checkProject,moduleInfoPath)+import PFE2(getModuleTime)+import PFE3(parseSourceFile'')++import PathUtils(normf)+import DirUtils(getModificationTimeMaybe,optCreateDirectory)+--import FileUtils(updateFile)+import AbstractIO+--import MUtils+import PrettyPrint(pp)++toHtmlFiles outDir srcURL modHTML optms =+    do ms <- maybe allModules return optms+       dir <- checkProject+       unless (null ms) $ optCreateDirectory (outDir dir)+       mapM_ (module2html dir) ms+  where+    module2html dir m =+      do let out_path = outDir dir++htmlFile m+	 t_mod <- getModuleTime m+	 t_html <- getModificationTimeMaybe out_path+	 when (t_mod `newerThan` t_html) $ -- hmm!!+	      do putStrLn $ "Updating: "++out_path+                 writeFile out_path =<< file2html srcURL m++    file2html srcURL m =+      do path <- findFile m+	 g <- getCurrentModuleGraph+	 (ts,(_,rs0)) <- parseSourceFile'' path+	 let rs = simplifyRefsTypes' rs0+	     ffm = (path,[(normf f,m)|(f,(m,_))<-g])+	 return (modHTML m (hlex2html' srcURL ffm (rs,ts)))++--------------------------------------------------------------------------------++htmlFile m = moduleInfoPath m++".html"++htmlDir dir = dir++"html/"+--htmlPath m dir = htmldir dir++htmlFile m++wwwDir  dir = dir++"www/"+--wwwPath m dir = wwwdir dir++htmlFile m++--------------------------------------------------------------------------------
+ tools/pfe/PFE_Rewrite.hs view
@@ -0,0 +1,16 @@+{-++Sometimes we need to apply some rewrites before type checking,+but we need to record what rewrite was applied so that cached results+with different rewrites can be kept apart. Rewrites are therefore paired+with names that uniquely identify them.+-}+module PFE_Rewrite where+import MUtils++type RewriteName = String+data Rewrite m ds = Rewrite {rwName::RewriteName, rwFun::m (ds->ds)}++idRw = Rewrite "" (return id)+compRw (Rewrite n1 m1) (Rewrite n2 m2) = Rewrite (n1++n2) ((.) # m1 <# m2)+-- Note: composing with idRw doesn't change the name of the rewrite+
+ tools/pfe/PFE_Rewrites.hs view
@@ -0,0 +1,21 @@+{-++Packaging some of the available source transformations as named rewrites.+-}+module PFE_Rewrites(module PFE_Rewrites,module PFE_Rewrite,module PFE_StdNames)+where+import RemovePatBinds(remPats)+import RemoveListComp(rmAllListComp)+import SimpPatMatch(simpAllPatMatch,getSimpPatIds)+import SimpFunBind(simpAllFunBind)+import SimpFieldLabels(simpFieldLabels)+import PFE_Rewrite+import PFE_StdNames+import MUtils++pbRewrite = Rewrite "pb" (remPats # getPrelValue "error")+lcRewrite = Rewrite "lc" (rmAllListComp # getPrelValue "concatMap")+pmRewrite = Rewrite "pm" $ do stdName <- getStdNames+			      ids <- getSimpPatIds (prelValue stdName)+			      return (simpAllPatMatch ids.simpAllFunBind)+fbRewrite = Rewrite "fb" (return simpAllFunBind)+flRewrite = Rewrite "fl" (simpFieldLabels # getPrelValue "error")
+ tools/pfe/PFE_StdNames.hs view
@@ -0,0 +1,53 @@+{-++Some source transformations need to refer to entities defined in the Prelude+or other standard library modules.+-}+module PFE_StdNames where+import List(intersect)++import TypedIds(NameSpace(..),namespace)+import HsConstants(mod_Prelude,mod_Ix)+import PFE0(allModules)+import PFE2(getExports)+import TiNames(topName)+import ScopeModule(origName)+import HasBaseName(getBaseName)+import HsIdent(HsIdentI(..))+import SourceNames(fakeSN)+import Relations(applyRel)+import WorkModule(Ent(..))++import PrettyPrint(pp,(<+>),(<>))+import MUtils(( # ))++stdValue stdName m n = stdName ValueNames (m,n)+prelValue stdName = stdValue stdName mod_Prelude++getPrelValue n = getStdValue mod_Prelude n++getStdValue m n =+  do stdName <- getStdNames+     stdValue stdName m n++getStdNames =+  --pfe4 $+  do allms <- allModules+     stdNames . prune # getExports (Just (stdms `intersect` allms))+  where+    prune = filter ((`elem` stdms).fst)+    stdms = [mod_Prelude,mod_Ix]++    stdNames es ns (m,n) = maybe merr (find n . snd) (lookup m es)+       where+         merr = fail $ pp $ "Standard library module not avaialble:"<+>m+	 find n exprel =+           case filter ((==ns).namespace) $ applyRel exprel (fakeSN n) of+	     [e] -> return (ent2pnt e)+	     [] -> fail $ pp $ "Standard entity not avaialble:"<+>m<>"."<>n+	     _ ->  fail $ pp $ "Standard entity is ambiguous:"<+>m<>"."<>n++    ent2pnt (Ent m (HsCon i) t) = HsCon (topName Nothing m (bn i) (origt m t))+    ent2pnt (Ent m (HsVar i) t) = HsVar (topName Nothing m (bn i) (origt m t))+    bn i = getBaseName i+    origt m = fmap (osub m) +    osub m n = origName n m n
+ tools/pfe/PFEdeps.hs view
@@ -0,0 +1,244 @@+module PFEdeps(+   PFE5MT,runPFE5,clean5,getSt5ext,updSt5ext,setSt5ext,+   --Dep,Deps,deps0,+   tdepModules,tdepModules',depModules,depModules',+   tdefinedNames,isDefaultDecl,isInstDecl,splitDecls)+ where+import Prelude hiding (readFile,readIO)+import Maybe(fromMaybe)+import List(nub,sort)++import HsModule+import HsIdent(getHSName,HsIdentI(..))+import HasBaseStruct(basestruct,hsTypeSig,hsInfixDecl)+import HasBaseName(getBaseName)+import HsDeclStruct(DI(..))+import SrcLoc1(srcLoc)+import TypedIds(IdTy(..))++import QualNames(mkUnqual)+import PNT(PNT(..))+import UniqueNames(noSrcLoc)+--import TiNames(idTy)+--import TiModule() -- instance HasIdTy PNT -- grr!++import PFE0+import PFE2(getModuleTime)+import PFE3(parseModule)+import PFE4(PFE4MT,getSt4ext,updSt4ext,clean4,runPFE4,typeCheckModule)+import TiClasses(fromDefs)+import TiNames(instName,defaultName,derivedInstName)+import DefinedNames(definedNames,addName,classMethods,contextSize)+import TiDefinedNames(definedTypeName)+import FreeNames(freeNames) --freeValues+import PrettyPrint+import MUtils+import AbstractIO+import FileUtils+import DirUtils(optCreateDirectory,getModificationTimeMaybe,rmR)++type Dep n = [([n],([n],[Hash]))] -- tricky to use correctly, should be abstract!!+type Deps n = [(ModuleName,(ClockTime,Dep n))]+type Deps2 n = (Deps n,Deps n)++deps0 = [] :: Deps n++type PFE5MT n i1 i2 ds1 ds2 ext m = PFE4MT n i1 i2 ds1 ds2 (Deps2 i2,ext) m++runPFE5 ext = runPFE4 ((deps0,deps0),ext)++getSt5 :: Monad m => PFE5MT n i1 i2 ds1 ds2 ext m (Deps2 i2)+updSt5 :: Monad m => Upd (Deps2 i2)->PFE5MT n i1 i2 ds1 ds2 ext m ()+getSt5ext :: Monad m => PFE5MT n i1 i2 ds1 ds2 ext m ext+updSt5ext :: Monad m => Upd ext->PFE5MT n i1 i2 ds1 ds2 ext m ()++getSt5 = fst # getSt4ext+updSt5 = updSt4ext . apFst +setSt5 = updSt5 . const++getSt5ext = snd # getSt4ext+updSt5ext = updSt4ext . apSnd+setSt5ext = updSt5ext . const++type Hash = Int++hash =+    checksum . quickrender . withPPEnv hashmode . ppi+  where+    checksum = foldr (\c h->3*h+fromEnum c) 0+    hashmode = defaultMode{layoutType=PPNoLayout,typeInfo=False}++-- Compute the dependency info for all modules in the project:+depModules = depModules' Nothing+tdepModules = tdepModules' Nothing++-- Update the dependeny info for a selected set of modules in the project:+depModules' optms =+    do (olddeps,oldtdeps) <- getSt5+       newdeps <- depModules'' olddeps syntaxDeps optms+       setSt5 (newdeps,oldtdeps)+       return newdeps+  where+    syntaxDeps = (depFile,untypedParse,True)+    untypedParse = fmap dup . parseModule'++tdepModules' optms =+    do (olddeps,oldtdeps) <- getSt5+       newtdeps <- depModules'' oldtdeps typedDeps optms+       setSt5 (olddeps,newtdeps)+       return newtdeps+  where+    typedDeps = (tdepFile,typedParse,False)+    typedParse m = (,) # parseModule' m <# typeCheckModule m+                   -- The module is parsed twice!++parseModule' = fmap snd . parseModule++depModules'' olddeps depsrc optms =+    do optCreateDirectory `projPath` depdir+       ms <- maybe allModules return optms+       updateDeps depsrc olddeps ms+++updateDeps (depFile,parseMod,allInst) olddeps ms =+    do newdeps <- mapM upd ms+       let changed = map fst newdeps+           deps = newdeps++filter ((`notElem` changed).fst) olddeps+       return deps+  where+    +    upd m =+      do let olddep = lookup m olddeps+	 t <- getModuleTime m+	 if t `newerThan` (fst # olddep)+           then do dept <- maybeF getModificationTimeMaybe depf+		   if t `newerThan` dept then again else useOld dept+	   else return (m,fromJust' "PFEdeps.hs:124" olddep)++      where+        depf = depFile m+		   +        again =+          do epput $ "Extracting dependencies:"<+>m+             dep <- dependencies allInst # parseMod m+	     t <- updateDep depf dep+	     return (m,(t,dep))++        useOld dept =+           do dir <- fromJust' "PFEdeps.hs:120" # projectDir+	      let path = depf dir+		  ret dep = return (m,(fromJust' "PFEdeps.hs:123" dept,dep))+              --ret . read'' path =<< readFile path -- lazy+	      maybe again ret =<< maybeM (readIO =<< readFile path) -- strict++    updateDep depf dep =+      do optdir <- projectDir+         case optdir of+           Nothing -> getClockTime+	   Just dir ->+             do updated <- updateFile' (depf dir) (show dep)+	        getModificationTime (depf dir)++{-++The hash is computed from the source AST, while the set of free names in+a declaration is computed from the type checked AST, to catch dependencies+on instances, which are made explicit by the dictionary translation.+Things like derived instances that do not appear in the source code+will be assigned hash value [].+-}+dependencies allInst (untyped,typed) = udeps++deps+  where+    deps0 = [(rdefs d,rfree d)|d<-fromDefs (hsModDecls typed)]+    udeps = [([],(fvs,[]))|([],fvs@(_:_))<-deps0]+    deps1 = mapSnd (nub.concat) $ collectByFst [(n,fvs)|(ns,fvs)<-deps0,n<-ns]+    deps  = [([n],(fvs,findHash n))|(n,fvs)<-deps1]+    findHash n = nub $ sort [h|(n',h)<-hs,n'==n]+    hs = [(n,h)|d<-fromDefs (hsModDecls untyped),let h=hash d,n<-rdefs d]++    mn = getBaseName (hsModName typed)+    rdefs = map getHSName . tdefinedNames allInst mn+    rfree = restrict . tfreeNames mn+    restrict = nub . concatMap (addowner.getHSName)+    --restrict = map getHSName++    addowner x = if o==x then [x] else [o,x]+      where o = owner x++    -- Map subordinate names to their owner (reduces the total number of names):+    owner x =+	case idty x of+	  ConstrOf t ty -> pnt t (Type ty)+	  FieldOf t ty -> pnt t (Type ty)+	  MethodOf c n ms -> pnt c (Class n ms)+	  _ -> x+      where+	pnt t idty = PNT (mkUnqual t) idty noSrcLoc+	idty (PNT _ ty _) = ty+++-- To track dependencies on instances, include the names assigned to+-- instances by the type checker.+-- Also, to keep relevant type signatures and infix declarations, pretend that+-- they are part of the definitions of the identifiers the mention.+tdefinedNames allInst m d =+  case basestruct d of+    Just (HsInstDecl s optn ctx inst ds) -> if allInst then [] else [HsVar n]+      where n = fromMaybe (instName m s inst) optn+    Just (HsTypeSig s is c t) -> map HsVar is+    Just (HsInfixDecl s f is) -> is+    _ -> ns+  where ns = map fst (definedNames (addName d))++{-+Since the type checker lifts default methods out from the class declaration+to the top level, we make the class declaration depend on the default+methods, under the assumption that they will be included in slices if+the class is included...+-}+tfreeNames m d =+  case basestruct d of+    Just (HsDataDecl s c tp cs cls) ->+        [HsVar (derivedInstName m cl tn)|cl<-cls]++ns+      where tn = definedTypeName tp+    Just (HsClassDecl s c t fd ds) ->+         map fst (freeNames d)++map (fmap defaultName) methods+       where+         methods = map fst (classMethods undefined (contextSize c) ds)+    _ -> ns+  where ns = map fst (freeNames d)++isDefaultDecl d =+  case basestruct d of+    Just (HsDefaultDecl{}) -> True+    _ -> False++isInstDecl d =+  case basestruct d of+    Just (HsInstDecl{}) -> True+    _ -> False++{-++To make it ease to include the right infix declarations and type signatures,+split them. For example, if * is needed but / is not, you can't keep or throw+away all of the infix declaration "infixl 7 *,/".+-}+splitDecls = concatMap splitDecl+splitDecl d =+  case basestruct d of+    Just (HsTypeSig s is c t) -> [hsTypeSig s [i] c t|i<-is]+    Just (HsInfixDecl s f is) -> [hsInfixDecl s f [i]|i<-is]+    _ -> [d]++--------------------------------------------------------------------------------+clean5 = withProjectDir clean+  where+    clean dir = do rmR [depdir dir]+		   clean4++--------------------------------------------------------------------------------++depdir dir=dir++"dep/"++depFile m dir = depdir dir++moduleInfoPath m++".g"+tdepFile m dir = depdir dir++moduleInfoPath m++".tg"+--------------------------------------------------------------------------------
+ tools/pfe/Pfe0Cmds.hs view
@@ -0,0 +1,182 @@+-- Programatica Front-End Commands, level 0+module Pfe0Cmds where+import Prelude hiding (print,putStr,putStrLn,catch,readFile)+import List((\\))+import Monad(unless,when)+import Maybe(fromJust)++import PFE0++import HsName(ModuleName(..),isMainModule,sameModuleName)+--import HsConstants(main_mod)+import HsLexerPass1(rmSpace,Pos(line)) -- for lines of code metrics++import PfeParse+import PrettyPrint+import MUtils+import SimpleGraphs(reverseGraph,reachable)+import DirUtils(optCreateDirectory)+import AbstractIO+import Statistics++pfe0 parseModule args = runPFE0Cmds () pfe0Cmds parseModule args++--runPFE0Cmds ext cmds = runPFE0 ext $ doCmd (cmds, projectStatus)+runPFE0Cmds ext cmds = runCmds (runPFE0 ext) cmds++pfe0Cmds = projman++graphqueries++addHelpCmd prg cmds0 = cmds where cmds=cmds0++helpCmd prg cmds++helpCmd prg cmds =+  [("help",(noArgs (putStrLn (usage prg cmds)),"list available commands"))]++projman =+  -- Project management (a project is a set of source files)+  [("new"     , (qfileArgs  new, "create a new project containing zero or more files")),+   ("add"     , (qfileArgs  add, "add files to the project")),+   ("remove"  , (qfileArgs  remove, "remove files from the project")),+   ("prune"   , (moduleArgs prune,"remove unreachable modules from the project")),+   ("files"   , (noArgs     files,"list files in the project")),+   ("options" , (noArgs     options,"show options in effect"))]++graphqueries =+  -- Module graph queries+  [("modules" , (moduleArgs modules,"show a topologically sorted list of modules")),+   ("graph"   , (graphArgs graph,"show module dependecy (sub)graph")),+--   ("dirgraph", (moduleArgs dirgraph,"show source directory dependecy (sub)graph")),+--   ("dotdirgraph", (moduleArgs dotdirgraph,"dot format source directory dependecy (sub)graph")),+   ("unused"  , (moduleArgs unused,"list unimported and unreachable modules")),+   ("file"    , (moduleArg  file,"which file is the module in")),+   ("module"  , (fileArg    module',"which module does the file contain")),+   ("loc"     , (moduleArgs locModules, "number of lines of code")),+   ("sizemetrics" , (noArgs sizeMetrics, "number of lines per module metrics")),+   ("locmetrics" , (noArgs locMetrics, "number of lines of code per module metrics")),+   ("importmetrics",(noArgs importMetrics, "number of imports per module metrics")),+   ("exportmetrics",(noArgs exportMetrics, "number of exports (importers) per module metrics"))]++--- Project management ---------------------------------------------------------+new    quiet args = do newProject; addPaths quiet args+add    quiet args = addPaths quiet args+remove quiet args = removePaths quiet args++files = putStr . unlines =<< allFiles++options = print =<< parserFlags++qfileArgs f = f #@ kwOption "-quiet" <@ filenames++--- Module graph queries -------------------------------------------------------+modules ms = do g <- getSortedSubGraph (just ms)+	        let sccs = map (map (fst.snd)) g+	        putStrLn "Topologically sorted strongly connected components:"+	        putStr (unlines (map (unwords.map pp) sccs))++graphArgs = moduleArgs' graphOpts+  where+    graphOpts = (,,) #@ kwOption "-rev" <@ kwOption "-dot" <@ kwOption "-dir"++graph (rev,dot,dir) =+    pput . out_conv_dirs @@ getSubGraph . just+  where+    out_conv_dirs  = if dir then out_conv . srcdirGraph  else out_conv . map snd+    out_conv = out . conv+    out   = if dot then dotFormat    else makeFormat+    conv  = if rev then reverseGraph else id++-- Dot format functions contributed by Claus Reinke:+     +dotFormat g =+   "digraph ModuleGraph {size=\"7.5,10.5\";ratio=fill;" $$+   vcat [q x<>"->"<>braces (fsep [q d<>";"|d<-xs])|(x,xs)<-g] $$+   "}"+  where+    q = doubleQuotes++makeFormat g = vcat [x<>":"<+>fsep xs|(x,xs)<-g]++--dirgraph    ms = pput . makeFormat =<< srcdirGraph ms+--dotdirgraph ms = pput . dotFormat =<< srcdirGraph ms++srcdirGraph g = dg+  where moddirs = [(m,dirname path)|(path,(m,_))<-g]+	moddir m = fromJust (lookup m moddirs)+	dg = mapSnd usort $+	     collectByFst+	       [(moddir m,dir')|(_,(m,ms))<-g,dir'<-usort (map moddir ms)]++dirname = current . reverse . dropWhile (/='/') . reverse+  where current "" = "./"+	current path = path+     +file m =+    do g <- getCurrentModuleGraph+       pput $ vcat [m<>":"<+>f|(f,(m',_))<-g,m'==m]++module' f =+    do g <- getCurrentModuleGraph+       pput $ vcat [f<>":"<+>m|(f',(m,_))<-g,f'==f]++getUnused ms =+  do fg <- getCurrentModuleGraph+     let g = map snd fg+         unimported = map fst g \\ [m|(m,_:_)<-reverseGraph g]+	 roots = if null ms then mains else ms+	   where mains = [m|(m,_)<-g,isMainModule m]+	 r = reachable g roots+	 unreached = map fst g \\ r+     when (null roots) $+       fail "No root modules given, no Main module in the project"+     return (fg,roots,unimported,unreached)++mainModules =+  do fg <- getCurrentModuleGraph+     return [m|(f,(m,_))<-fg,isMainModule m]++unused ms =+  do (_,roots,us,unr) <- getUnused ms+     if null us -- unlikely...+       then putStrLn "All modules are imported somewhere"+       else pput $ "The following modules are never imported:" $$+	           nest 4 (fsep us)+     unless (null unr) $+       do pput $+	    sep [ppi "The following modules are unreachable from",+		 nest 2 (fsep roots<>":")]+	  pput $ nest 4 (fsep unr)++prune ms =+  do (fg,_,_,unreached) <- getUnused ms+     removePaths False [f|(f,(m,_))<-fg,m `elem` unreached]++sizeMetrics =+    pput . ppStatistics "number of lines" "module"+      =<< mapM (forkM (fst.snd) (size #. readFile . fst))+      =<< getCurrentModuleGraph+  where+    size = length . lines++locMetrics =+    pput . ppStatistics "number of lines of code" "module"+      =<< mapM (forkM (fst.snd) (loc . snd #. lex0SourceFile.fst))+      =<< getCurrentModuleGraph++--forkM f g x = (,) (f x) # g x+forkM f g x =+  do y <- g x+      -- seq to process one file at a time in locMetrics & sizeMetrics+     seq y (return (f x,y))++loc = length . squeezeDups . map (line.fst.snd) . rmSpace++locModules = mapM_ locModule+locModule = locFile @@ findFile+locFile = pput . loc . snd @@ lex0SourceFile+++importMetrics = graphMetrics id "number of imports"+exportMetrics = graphMetrics reverseGraph "number of importers"++graphMetrics f lbl =+    do g <- mapSnd length . f . map snd # getCurrentModuleGraph+       pput $ ppStatistics lbl "module" g
+ tools/pfe/Pfe1Cmds.hs view
@@ -0,0 +1,58 @@+-- Programatica Front-End Commands, level 1+module Pfe1Cmds where+import Prelude hiding (putStr,putStrLn,print)+import Pfe0Cmds(pfe0Cmds,runPFE0Cmds)+import PfeParse(moduleArg,fileArg,filename,( #@ ), (<@),kwOption)+import PFE0(pput,lex0SourceFile,preparseSourceFile,findFile)++import DefinedNames+import FreeNames+import HsTokens+import HsLexerPass1(lexerPass1Only)+import HsLexMerge(mergeLex)++import PrettyPrint+import AbstractIO+import MUtils+import Maybe(mapMaybe)+import PPModules() -- for PFE++pfe1 ext = runPFE0Cmds ext pfe1Cmds++pfe1Cmds =+     pfe0Cmds +++     [-- Simple, local module queries+      ("defined" , (moduleArg defined,"list entities defined in the module")),+      ("free"    , (moduleArg free,"list names referenced but not defined in the module")),+      ("pragmas",  (moduleArg pragmas,"extract pragmas from modules")),+      ("lex",      (lFileArg tstlex ,"show the result of lexical analysis")),+      ("lexl",     (lFileArg tstlexl,"show the result of lexical analysis + layout preprocessing")),+      ("preparse", (fileArg preparse,"preparse and show abstract syntax"))+     ]++--- Simple module queries ------------------------------------------------------++free = simple freeNames+defined = simple definedNames+preparse = print @@ preparseSourceFile++simple f = pput.vcat.f @@ preparseSourceFile @@ findFile++pragmas = putStr.unlines.map show.lex2pragmas.snd @@ lex0SourceFile @@ findFile++tstlex  one = printLex one . mergeLex @@ lex0SourceFile+tstlexl one = printLex one . lexerPass1Only . mergeLex @@ lex0SourceFile++printLex True = putStrLn . unlines . map show+printLex False = print++lFileArg f = f #@ kwOption "-1" <@ filename++lex2pragmas = mapMaybe pragma+  where+    pragma (NestedComment,(p,'{':'-':'#':s)) | last3 s=="#-}" =+      Just (p,droplast3 s)+    pragma _ = Nothing++    last3 = reverse . take 3 . reverse+    droplast3 = reverse . drop 3 . reverse
+ tools/pfe/Pfe2Cmds.hs view
@@ -0,0 +1,50 @@+module Pfe2Cmds where+--import Prelude hiding (putStr,putStrLn)++--import WorkModule(analyzeSCM,expRel,inscpRel,mkWM)+import Relations(applyRel)+import SourceNames(SN(..))+import SrcLoc1(loc0)++import Pfe1Cmds(pfe1Cmds)+import PfeParse(moduleArg,idArgs,runCmds)+import PFE2(runPFE2,getModuleExports,getAllExports)+import PFE0(pput,allModules)++--import AbstractIO+import PrettyPrint+import MUtils(done)++pfe2 ext = runPFE2Cmds ext pfe2Cmds++runPFE2Cmds ext = runCmds (runPFE2 ext)++pfe2Cmds =+    pfe1Cmds +++    [-- Module system queries (import/export, top level environment)+  -- ("topenv"  , (Null      topenv, "check all import and export specifications")), -- just update, no output+     ("exports" , (moduleArg exports,"list entities exported by the modules")),+     ("find"    , (idArgs    find,"find exported entities with the given names"))+    ]++--- Module system queries (import/export, top level environment) ---------------+exports = showModuleInfo snd++showModuleInfo sel m = pput . ppModuleInfo sel m =<< getModuleExports m++ppExports = ppModuleInfo snd+ppModuleInfo sel m info = sep [m<>":",nest 2 . ppi $ sel info]++find ids = do exports <- getAllExports+	      mapM_ (mapM_ pp1 . find1 exports) ids+ where+   pp1 (m,ents) = pput (m<>":"<+>vcat ents)++   find1 mes id = +     [(m,ents)|(m,(t,es))<-mes,+	       let ents=applyRel es (sn id),+	       not (null ents)]++--topenv = analyzeModules >> done++sn n = SN n loc0 -- !!
+ tools/pfe/Pfe3Cmds.hs view
@@ -0,0 +1,35 @@+module Pfe3Cmds where+import Prelude hiding (putStr,putStrLn)++import PfeParse(moduleArg)+import Pfe2Cmds(pfe2Cmds,runPFE2Cmds)+import PFE0(pput)+import PFE3(parseModule)+import WorkModule(inscpRel)++--import AbstractIO+import PrettyPrint+import MUtils((@@))++pfe3 ext = runPFE3Cmds ext pfe3Cmds+runPFE3Cmds ext = runPFE2Cmds ext++pfe3Cmds =+  pfe2Cmds +++  [-- Analyzing the contents of modules+   ("inscope", (moduleArg inscope,"list entities in modules' top-level environment")),+   ("parse"  , (moduleArg (pp'' show id),"parse and show abstract syntax")),+   ("pp"     , (moduleArg pp_plain,      "parse and pretty-print modules"))+  ]++inscope m = showInscope . fst . fst =<< parseModule m+  where+    showInscope wm = pput $ sep [m<>":",nest 2 . ppi $ inscpRel wm]++pp_plain = pp' id+--ppscope = pp' withDebug++pp' = pp'' id++pp'' f ppOpts = (pput.ppOpts.ppi.f.snd) @@ parseModule+
+ tools/pfe/Pfe3Metrics.hs view
@@ -0,0 +1,37 @@+module Pfe3Metrics where+import Maybe(mapMaybe)++import PFE0(allModules,pput)+import PFE3(parseModule)+import HsDeclStruct(DI(..))+import HsModule(hsModDecls)+import DefinedNames(definedType)+import HasBaseStruct(basestruct)+import Statistics++import PfeParse+import MUtils++pfe3MetricsCmds =+  [("classmetrics", (noArgs classMetrics,"number of instances per class metrics"))]+classMetrics =+  do ms <- allModules+     (classes,insts) <- apBoth concat . unzip # mapM getClassInstDecls ms+     let cinstcnt = [(c,length [()|i<-insts,i==c])|c<-classes]+     pput (ppStatistics "number of instances" "class" cinstcnt)++getClassInstDecls m = cls_insts . hsModDecls . snd # parseModule m++cls_insts ds = (mapMaybe className ds,concatMap instClass ds)++className d =+  case basestruct d of+    Just (HsClassDecl _ _ tp _ _) -> Just (definedType tp)+    _ -> Nothing++instClass d =+  case basestruct d of+    Just (HsInstDecl _ _ _ tp _) -> [definedType tp]+    Just (HsDataDecl _ _ _ _ cls) -> cls+    Just (HsNewTypeDecl _ _ _ _ cls) -> cls+    _ -> []
+ tools/pfe/Pfe4Cmds.hs view
@@ -0,0 +1,218 @@+module Pfe4Cmds where++import PfeParse(runCmds,moduleArgs,moduleArgs',just,qualIds,( #@ ),(<@),+		kwOption)+import Pfe3Cmds(pfe3Cmds)++import PFE0(pput,epput)+import PFE2(getExports)+import PFE4(runPFE4,topTypes,typeCheck,rewriteAndTypeCheck,modEnv)+import PFE_Rewrites+import Ents(Ent(..))+import QualNames(mkUnqual,unqual)+import Relations(relToList)+import TypedIds(isValue,IdTy(MethodOf),owner,belongsTo,idTy)+import TI(Typing(..),TypeInfo(..),tdom,envFrom,topVal,topType,ppKinded)+import TiInstanceDB(InstEntry(..))+import HasBaseName(getBaseName)+import HsIdent(HsIdentI(..),accHsIdent2,getHSName,mapHsIdent)+import SrcLoc1(srcLoc)+import UniqueNames(orig,Orig(G),noSrcLoc)+import MUtils(( # ),( <# ),apBoth)+import PrettyPrint+import PrettySymbols hiding (not)+import PrettyUtil(ppContext,ppWhere)+import Products((><))+import OpTypes(cmpBy)+import List(partition,sortBy)++{-++The type checker can return different types, so to avoid an ambiguity when+the result is used only for pretty printing, the function tcOutput can be passed+in to restrict the result type.+-}++pfe4 ext tcOutput = runPFE4Cmds ext (pfe4Cmds tcOutput)++runPFE4Cmds ext = runCmds (runPFE4 ext)++pfe4Cmds tcOutput=+    pfe3Cmds +++    [("tc",       (tcmd tcrw,     "type check and display decorated modules")),+     ("types",    (tcmd0 types,    "show types/kinds of top-level entities")),+     ("typeof",   (tqcmd typeof,  "show types of named top-level entities")),+     ("kindof",   (tqcmd kindof,  "show kinds of named top-level entities")),+     ("instances",(tcmd0 instances,"list instances defined in a module")),+     ("iface",    (tcmd0 ppIfaces, "show the interfaces of modules")),+     ("usedtypes",(tcmd0 utypes,   "show what types identifers are used at"))]+  where+    tcmd0 f = moduleArgs (f tcOutput)+    tcmd f = moduleArgs' rwopts (f tcOutput)+    tqcmd f = qualIds (f tcOutput)++    rwopts = o pmRewrite ## o pbRewrite ## o lcRewrite++    o rw@(Rewrite n _) = (\ b -> if b then rw else idRw) # kwOption ('-':n)+    rw1 ## rw2 = compRw #@ rw1 <@ rw2++instances tcOutput ms =+  do pfe4info <- tcOutput # topTypes (Just ms)+     pput.vcat $ [ppContext ps<+>p |(m,(_,(_,(insts,_))))<-pfe4info,+		                    m `elem` ms,+		                    (p,IE _ _ ps)<-insts]++types tcOutput ms =+  do pfe4info <- tcOutput # topTypes (Just ms)+     pput.vcat $ [map (fmap fst) ks$$ts |(m,(_,(_,(_,(ks,ts)))))<-pfe4info,+		                    m `elem` ms]++typeof tcOutput qids =+  do pfe4info <- tcOutput # topTypes (Just (map fst qids))+     mapM_ (typeof1 pfe4info) qids+{-+typeof1 pfe4info (m,s) = pput (vcat bs)+  where+    q=topVal m s+    bs = [b|(m',(_,(_,(_,(ks,ts)))))<-pfe4info,+		m'==m,+		b@(x:>:_)<-ts,+		getHSName x==q]+-}+kindof tcOutput qids =+  do pfe4info <- tcOutput # topTypes (Just (map fst qids))+     mapM_ (kindof1 pfe4info) qids+{-+kindof1 pfe4info (m,s) = pput (vcat bs)+  where+    q=topType m s+    bs = [fmap fst b|(m',(_,(_,(_,(ks,ts)))))<-pfe4info,+		     m'==m,+		     b@(x:>:_)<-ks,+		     getHSName x==q]+-}+typeof1 = info1 snd id+kindof1 = info1 fst fst++info1 envsel infosel pfe4info (m,s) = pput (vcat bs)+  where+    q=topType m s+    bs = [fmap infosel b|Just env<-[modEnv pfe4info m],+		     b@(x:>:_)<-envsel env,+		     getHSName x==q]++utypes tcOutput ms =+  do pfe4info <- tcOutput # typeCheck (Just ms)+     mapM_ (utypes1' pfe4info) ms+  where+    utypes1' pfe4info mn =+        maybe (epput $ "Unknown module:"<+>mn) utypes1+		      (lookup "".fst.snd=<<lookup mn pfe4info)+      where+        utypes1 m =+          pput (mn<>":"$$+		nest 2 (vcat.map u.sortBy (cmpBy fst).map pos.snd.envFrom $ m))++        pos xt@(x:>:_) = (srcLoc x,xt)++        u (pos,x:>:(sc,optt)) =+	    sep [x<+>"at"<+>pos<+>"::",+		 nest 4 (maybe (ppi sc) ppi optt)]++tc tcOutput ms = pptc ms =<< (tcOutput # typeCheck (just ms))++pptc ms = pptc' "" ms++pptc' rname ms pfe4info =+  pput.vcat $ [tm |(m,(_,(tms,_)))<-pfe4info, m `elem` ms,(n,tm)<-tms,n==rname++"fl"]++tcrw tcOutput rw@(Rewrite rwn _) ms =+  pptc' rwn ms . tcOutput =<< rewriteAndTypeCheck rw (just ms)++ppIfaces tcOutput ms =+  do exports <- getExports (Just ms)+     pfe4info <- tcOutput # topTypes (Just ms)+     mapM_ (pput.ppIface.iface exports pfe4info) ms++moduleInterface m =+  do exports <- getExports (Just [m])+     types <- topTypes (Just [m])+     return (iface exports types m)++iface expRels pfe4info m =+    (m,((types><kinds).partition isValue.map snd.relToList.snd+        # lookup m expRels))+  where+    kinds = map (info fst id)+    types = map (info snd id)++    info envsel infosel e@(Ent m' n _) = (e,i)+      where+        Just env = conv . envsel # modEnv pfe4info m'+	i = lift n (infosel # lookup (mkUnqual(getBaseName n)) env)+++    conv env = [(unqual' (getBaseName x),y)|x:>:y<-env]+    unqual' = unqual `asTypeOf` id++    lift x = maybe (error $ pp $ "Not found:"<+>x) id+      +ppIface (m,Nothing) = "Unknown module:"<+>m+ppIface (m,Just (ts,ks)) =+    kw "module"<+>modn m<>":" $$+    nest 2 (vcat (map ppTInfo ks) $$+	    "" $$+	    vcat (map ppVInfo vs))+  where+    (subs,vs) = partition isExportedSubordinate ts++    ppV = accHsIdent2 ppi con+    ppTInfo (e,(k,ti)) = ppTypeInfo e k ti+    ppVInfo (Ent m' n _,ty) = {-ppName m'-}ppV n<+>el<+>ty+    {-+    ppName m' n =+      if m'==m+      then ppi n+      else m'<>"."<>n+    -}++    isExportedValue (x:>:_) = mapHsIdent orig x `elem` values++    isExportedSubordinate (e,_) = maybe False (`elem` types) (origOwner e)++    ppTypeInfo e@(Ent m n idty) k ti =+	case ti of+          Data    -> ppData "data"+	  Newtype -> ppData "newtype"+	  Class ps aks pds allms ->+	      sep [kw "class"<+>+		   sep [ppContext ps,+			tcon n<+>hsep (map ppKinded aks)<+>ppDeps vds],+		   nest 2 $ ppWhere (map ppi visms++more)]+	    where+	      as = tdom aks+              vds = map (apBoth (map (as!!))) pds+	      (visms,hidms) = partition isExportedValue allms+	      more = if null hidms then [] else [kw "..."]+	  Synonym as t ->+              sep [kw "type"<+>tcon n<+>hsep as<+>equals,nest 4 (ppi t)]+	  Tyvar -> var n<+>el<+>k -- ??+      where+        o = ent2orig e++        ppData dkw =+	    sep [kw dkw<+>tcon n<+>el<+>k,+		 nest 2 $ ppWhere (map ppVInfo ss)]+	  where+	    ss = filter ((==Just o).origOwner.fst) subs++    ppDeps [] = empty+    ppDeps ds = kw "|"<+>ppiFSeq (map ppDep ds)+    ppDep (as,bs) = hsep as<+>rarrow<+>hsep bs++    values = map (ent2orig.fst) ts+    types = map (ent2orig.fst) ks++    ent2orig (Ent m n _) = mapHsIdent (\n->G m n noSrcLoc) (getBaseName n)++    origOwner (Ent m n idty) = fmap orig (owner idty)+      where orig t = ent2orig (Ent m (HsCon t) undefined)
+ tools/pfe/PfeChase.hs view
@@ -0,0 +1,82 @@+{-++Chase source files through imports, assuming module names and file names agree.+-}+module PfeChase where+import Prelude hiding (putStrLn)+import List(nub,partition,(\\))+import Monad(unless,filterM)++import HsName(moduleName,ModuleName(..),isHierarchical)++--import Pfe0Cmds+import PFE0++import PfeParse+import AbstractIO+import PathUtils+import DirUtils(expand)+import PrettyPrint+import MUtils++pfeChaseCmds = [("chase",(fileArgs findMissing,"look for imported modules in given files/directories"))]++findMissing args =+  do checkProject+     fg <- getCurrentModuleGraph+     dirs <- filterM doesDirectoryExist args+     allfiles <- map normf # expand args+     let (ignored,newfiles) +		 = partition (null.path2moduleName) (allfiles \\ map fst fg)+	 missing = nub [i|(_,(_,is))<-fg,i<-is] \\ map (fst.snd) fg+	 new = [(path,moduleName path (path2moduleName path))|path<-newfiles]++     unless (null ignored) $ pput $ "Ignoring:"<+>fsep ignored+     files <- map fst # chase dirs fg missing new+     --when (length files/=length (nub files)) $ pput "duplicates in file list"+     saveSrcList (nub files)+     projectStatus -- will report modules that are still missing+  where+    chase dirs fg missing new =+	case missing of+	  [] -> return fg+	  m:ms ->+	   do (fms,new') <- find m+	      case fms of+		[] -> chase dirs fg ms new' --didn't find m, skip & report later+		((f,_):fms) ->+		    do unless (null fms) $+		         pput $ "Using the first file for"<+>m<>":"<+>+			        fsep (f:map fst fms)+		       use f ms new'+      where+        find m =+          if isHierarchical m+	  then findHierarchical m+	  else return $ partition ((==m).snd) new++        findHierarchical m =+	     do let paths = [dir++[pathSep]++path|dir<-dirs,path<-moduleName2Paths m]+		fs <- filterM doesFileExist paths+		return ([(f,m)|f<-fs],new)++	use f ms new' =+	  do n@(m,is) <- moduleNode # preparseSourceFile f+	     let fg' = ((f,n):fg)+                 missing' = filter (isNew fg') is++ms+	     pput $ "Adding"<+>m<+>"from"<+>f+	     chase dirs fg' missing' new'++    isNew fg m = null . filter ((m==).fst.snd) $ fg++-- from a path like foo/bar/M.hs, extract M+path2moduleName =+    reverse . takeWhile (/=pathSep) . drop 1 . dropWhile (/='.') . reverse++moduleName2Paths m = +  case m of+    MainModule path -> [path]+    PlainModule s -> [base++".lhs",base++".hs"]+      where+        base = map sep s+	sep '.' = pathSep+	sep c   = c
+ tools/pfe/PfeCleanCmd.hs view
@@ -0,0 +1,4 @@+module PfeCleanCmd where+import PfeParse(noArgs)++pfeCleanCmd clean = [("clean", (noArgs clean,"remove cache files"))]
+ tools/pfe/PfeDepCmds.hs view
@@ -0,0 +1,200 @@+module PfeDepCmds where+import Prelude hiding (print)+import List(nub,intersect)+import Monad(unless)++import HsName(HsName(..))+import HsIdent(getHSName)+--import HsConstants(main_name)+import SourceNames(SN(..))+import SrcLoc1(loc0,srcLoc,srcLine,srcColumn)+import PFEdeps(runPFE5,depModules',tdepModules')+import Pfe0Cmds(mainModules)+import PfeParse+import PFE0(allModules,pput,epput,getCurrentModuleGraph,getSubGraph,preparseModule)+import PFE2(getModuleExports)+import AbstractIO+import MUtils+import QualNames(getQualified)+import HasBaseName(getBaseName)+import DefinedNames(definedNames)+import UniqueNames(HasOrig(..),PN(..),Orig(..),noSrcLoc,origModule)+import PNT(PNT(..))+import TiPNT() -- instances for PNT+--import TiNames(instName)+import TypedIds(IdTy(..),idTy,NameSpace(..),namespace)+import Ents(Ent(..))+import Relations(applyRel)+import SimpleGraphs(graph,nodes,reachable,isReachable,listReachable,reverseGraph)+--import OrdGraph --slower than Graph!+import PrettyPrint++import PFE3(refsModule)+--import RefsTypes(isDef,shPos)+--import ConvRefsTypes(simplifyRefsTypes')++runPFE5Cmds ext = runCmds (runPFE5 ext)++pfeDepCmds =+    [("deps" ,        (tModuleArgs deps,+	               "compute dependency graph for definitions")),+     ("needed",       (tQualIds needed',"needed definitions")),+     ("neededmodules",(tQualIds neededmodules',+		       "names of modules containing needed definitions")),+     ("dead",         (tQualIds dead',"dead code (default: Main.main)")),+--   ("refs",         (moduleArgs refs,"list what idenfifiers refer to")),+     ("uses",         (entityId uses,"find uses of an entity"))]++tModuleArgs = moduleArgs' opts . uncurry+  where opts = (,) #@ dot <@ untyped+        dot = kwOption "-dot"++tQualIds cmd = f #@ untyped <@ many (arg "<M.x>")+  where f depM = cmd depM @@ parseQualIds++untyped = depM #@ kwOption "-untyped"+  where+    depM untyped optms = pick # depM' untyped optms+      where pick = maybe id (\ms -> filter(\ d@(m,ds)->m `elem` ms)) optms+    depM' untyped = if untyped then depModules' else tdepModules'++--needed = needed' depModules'+--tneeded = needed' tdepModules'++needed' dm qids =+  do (_,_,used) <- snd # depgraph' dm qids+     pput $ ppOrigs (listReachable used)++--neededmodules = neededmodules' depModules'+--tneededmodules = neededmodules' tdepModules'++neededmodules' dm qids =+  do (_,_,used) <- snd # depgraph' dm qids+     pput $ fsep (nub $ map origModule (listReachable used))++--dead = dead' depModules'+--tdead = dead' tdepModules'++dead' dm [] = do mains <- mainModules+                 dead'' dm [(m,"main")|m<-mains]+dead' dm qids = dead'' dm qids++dead'' dm qids =+  do (g,ids,used) <- snd # depgraph' dm qids+     let unused = [n|n<-nodes g,not (isReachable used n)]+     pput $ fsep (map ppOrig unused)++uses (optns,q@(m,n)) =+  do pnts <- definedPNTs m+     let ppq =  m<>"."<>n+     case pnts of+       [] -> fail.pp $ "No such"<+>ppns optns<>":"<+>ppq+       _ -> do let n=length pnts+               unless (n<2) $+                 epput$ ppq<+>"matches"<+>n<+>"entities, showing uses of all"+	       findUses pnts+  where+    ppns = maybe (pp "entity") ppns'+    ppns' ValueNames = pp "value"+    ppns' ClassOrTypeNames = "class or type"++    findUses pnts =+      mapM_ (usesIn pnts) . flip reachable [m] . reverseGraph . map snd+        =<< getCurrentModuleGraph++    definedPNTs =  map pnt . filter same . definedNames #. preparseModule+    same (i,ty) = getQualified (getBaseName (getHSName i)) == n+	          && maybe True (namespace ty ==) optns+    pnt (i,ty) = pnt' (getQualified # ty) m n++refs ms = mapM_ ref1 ms+  where+    ref1 = pput.ppRefs @@ refsModule+    ppRefs = vcat . map ppRef+    ppRef (_,r,os) = r<+>"at"<+>srcLoc r<>":" $$+		     nest 4 (vcat [pp (srcLoc o)|(o,_)<-os])++usesIn pnts m =+  do refs <- refsModule m+     let qs = sp pnts+         uses = [ppLineCol (srcLoc r)|(_,r,origs)<-refs,+                               --not (isDef r),+			       let os = sp (origs2PNT origs),+		               os `intersects` qs]+     unless (null uses) $ pput (m<>":"<+>fsep uses)+  where+    sp xs = [(x,namespace (idTy x))|x<-xs]+    origs2PNT origs =+      [PNT (getHSName pn) ty noSrcLoc|(pn,ty)<-origs]++ppLineCol p = srcLine p<>","<>srcColumn p++intersects xs ys = not . null $ intersect xs ys++depgraph = depgraph' depModules'+tdepgraph = depgraph' tdepModules'++depgraph' depModules' qids =+  do let ms = nub (map fst qids)+     deps <- depModules' . Just . map (fst.snd) =<< getSubGraph (Just ms)+     ids <- concatMapM origpnt qids+     let g = depGraph [(n,ns)|(m,(t,ds))<-deps,(ns1,(ns,h))<-ds,n<-ns1]+         always = [n|(m,(t,ds))<-deps,([],(ns,h))<-ds,n<-ns]+	 used = reachable g (nub (ids++always))+     return (deps,(g,ids,used))++depGraph = graph . mapSnd concat . collectByFst+                           -- because of names from typesigs...++origpnt (m,n) =+  do (t,rel) <- getModuleExports m+     return $ case map ent2pnt (applyRel rel (SN n loc0)) of+                [] -> [pnt m n]+                ns -> ns+  where+    ent2pnt (Ent m i ty) = pnt' ty m n+      where SN n _ = getHSName i+    pnt = pnt' Value++pnt' ty m n = PNT (PN (Qual m n) (g m n)) (conv # ty) noSrcLoc+  where+    conv (SN n s) = PN n (S s)+    g m n = G m n noSrcLoc++--dotdeps depM = pput.pdotdeps @@ depM . just+--tdotdeps = pput.pdotdeps @@ tdepModules' . just++pdotdeps deps =+    "digraph DepGraph"$$+    braces ("size=\"7.5,10.5\";ratio=fill;"$$+            vcat [p d<>"->"<>braces (fsep [p f<>";"|f<-fs])+                  |(m,(t,mdeps))<-deps,(ds,(fs,h))<-mdeps,d<-ds])+  where+    p = doubleQuotes . ppOrig++--tdeps = pput.vcat.map pdeps @@ tdepModules' . just++deps dot depM = pput.fmt @@ depM . just+  where+    fmt = if dot then pdotdeps else vcat.map pdeps++    pdeps  (m,(t,deps)) =+      sep ["module"<+>m<>":",nest 2 (vcat $ map pdep deps)]+      where+	pdep (ds,(fs,h)) = sep [fsep ds <> ":",nest 2 (fsep (map ppOrig fs))]+	ppOrig = ppOrig' (Just m)++ppOrig = ppOrig' Nothing++ppOrig' optm n =+    if Just m'==optm then ppi x else m'<>"."<>x+  where+    (m',x) = origId n++origId n =+    case orig n of+      G m' n' _ -> (m', n')+--    I m' loc  -> (m',instName m' loc)+      _ -> error ("Bug: PfeDepCmds.origId "++show n)++ppOrigs qs = vcat [m<>":"<+>fsep xs|(m,xs)<-collectByFst (map origId qs)]
+ tools/pfe/PfeHtmlCmds.hs view
@@ -0,0 +1,43 @@+module PfeHtmlCmds where+import Prelude hiding (putStr,putStrLn,writeFile)++import HsName(ModuleName(..))+import PFE_HTML+import PfeParse(moduleArgs,just)++import AbstractIO+import PrettyPrint(pp)+--import CmdLineParser++pfeHtmlCmds =+     [--("html"     , moduleArgs showHtml),+      ("htmlfiles", (moduleArgs htmlfiles,"generate HTML files for modules")),+      ("webpages",  (moduleArgs webpages, "generate web pages for modules"))]++--showHtml = toHtml pfeURL (const putStrLn) . Just++htmlfiles ms = toHtmlFiles htmlDir pfeURL (const id) (just ms)+webpages ms = toHtmlFiles wwwDir wwwURL addHead (just ms)+  where+    addHead m body = unlines head++body+       where+         head = [doctype,"<html><head>", title (pp m),style,+	        "<body>",h1 (pp m)]+++wwwURL m = htmlFile m+pfeURL m = "pfe.cgi?"++simpModuleName m++simpModuleName (PlainModule m) = m+simpModuleName (MainModule path) = path++--- Some HTML combinators that belong somewhere else...+title=wrap "title"+h1=wrap "h1"+style=+ "<link rel=stylesheet type=\"text/css\" href=\"haskell.css\" title=Haskell>"+doctype = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">"++wrap tag html = start tag++html++end tag+start tag = "<"++tag++">"+end tag = start ('/':tag)
+ tools/pfe/PfeInteractive.hs view
@@ -0,0 +1,54 @@+module PfeInteractive(pfeiCmd,pfeiAllCmds,runSIO) where+import Prelude hiding (getContents,print,catch,putStrLn,writeFile)+import AbstractIO+import PfeParse+import PFE0(projectStatus,checkProject,setBatchMode,withProjectDir',newProjectHelp)+import Pfe0Cmds(addHelpCmd)+import PfeSocket(listenOnPFE,acceptPFE,removePFE,serverOps,sResult,errorString)++import qualified IO+import SIO++pfeiAllCmds pfeCmds prg = addHelpCmd prg (pfeCmds++pfeiCmd pfeCmds prg)++pfeiCmd pfeCmds prg =+    [("interactive",(noArgs pfeI,"read pfe commands from stdin")),+     ("server",     (noArgs pfeS,"start a PFE server"))]+  where+    pfeI =+      do setBatchMode False+         putStrLn "--- pfe interactive starts ---"+         mapM_ (doPfeCmd . words) . lines =<< getContents+	 putStrLn "--- pfe interactive ends ---"++    doPfeICmd cmd =+      do doPfeCmd cmd `catch` printError+         putStrLn "--- pfe interactive ---"++    doPfeCmd cmd = doCmd (pfeCmds',projectStatus) prg cmd++    pfeCmds' = addHelpCmd prg pfeCmds++    pfeS =+      do --s <- inBase $ listenOn (PortNumber 9999)+	 --withServerFile (flip writeFile "9999")+	 s <- withProjectDir'' (inBase . listenOnPFE)+	 setBatchMode False+	 tryThen (loop $ server s) (withProjectDir'' (inBase . removePFE))++    server s =+      do (h,host,port) <- inBase $ acceptPFE s+	 --print (host,port)+	 r <- try $ withStdio (serverOps h) (serve h)+	 inBase $ sResult h r+	 --putStrLn "done"+	 inBase $ IO.hClose h+      where+        serve h = doPfeCmd . words =<< inBase (IO.hGetLine h)+++withProjectDir'' m = withProjectDir' newProjectHelp m++loop m = l where l = m >> l++printError e = ePutStrLn (errorString e)
+ tools/pfe/PfeParse.hs view
@@ -0,0 +1,124 @@+{-+ PFE command line parsing utilities+-}+module PfeParse(module PfeParse,arg,(<@),( #@ ),many) where+import Char(isUpper)+import Monad(when)+import Maybe(isJust)++import HsName(ModuleName(..),sameModuleName,parseModuleName,isMainModule)+import TypedIds(NameSpace(..))++import PFE0(getCurrentModuleGraph,projectStatus)++import PrettyPrint(pp,(<+>),fsep)+import CmdLineParser3 as P+import MUtils((@@),( # ),concatMapM,swap,apBoth)++runCmds run cmds = run $ doCmd (cmds, projectStatus)++--type Cmd r = (String,(P r,String))++--doCmd :: ([Cmd (m ()], (m ())) -> String -> m ()+doCmd cmds _ = parseAll (cmdGrammar cmds)++cmdGrammar (cmds,default_cmd) =+    named "command" $+    foldr (!) (nil default_cmd)+          [nil id `chk` kw cmd <@ p :-- usage|(cmd,(p,usage))<-cmds]++usage prg cmds = P.usage prg (cmdGrammar (cmds,projectStatus))++kwOption w = isJust # opt (kw w)++noArgs = nil+args s f = f # many (arg s) -- s should now be in singular form!++filename = arg "<filename>"+filenames = many filename++fileArgs f = f # filenames+fileArg f = fileArgs (mapM_ f)++moduleArg f = moduleArgs (mapM_ f)+moduleArgs f = f @@ checkModuleNames # many (arg "<module>")++moduleArg' opts f = moduleArgs' opts (mapM_ . f)+moduleArgs' opts f = f' #@ opts <@ many (arg "<module>")+  where f' o = f o @@ checkModuleNames++checkModuleNames = concatMapM checkModuleName+checkModuleName s =+  do ms <- filter sameModule . map (fst.snd) # getCurrentModuleGraph+     when (null ms) $ fail (s++": unknown module")+     return ms+  where+    m = parseModuleName s+    sameModule = if isMainModule m then (==) m else sameModuleName s+    -- "Main{-file.hs-}" selects one particular Main module,+    -- "Main" select all main modules in a project++just ms = if null ms then Nothing else Just ms++idArgs f = f # many (arg "<identifier>")++qualIds f = (f @@ parseQualIds) # many (arg "<M.x>")+qualId f =  (f @@ parseQualId) # arg "<M.x>"++parseQualIds = mapM parseQualId+{-+parseOneQualId = parseQualId @@ one+  where+     one [q] = return q+     one qs = fail $ "Exactly one qualified name is required: "++unwords qs+-}++parseQualId s =+    case splitQualName s of+      Just (m,n) -> flip (,) n # checkModuleName1 m+             -- TODO: also check that m.n is defined!+      _ -> fail $ "Qaulified name required: "++s+  where+    splitQualName = fmap (apBoth reverse . swap) . split . reverse++    split s = case break (=='.') s of+		     (s1,'.':s2) -> Just (s1,s2)+		     _ -> Nothing+{-+    isQual s =+      case break (=='.') s of+	(c:_,'.':_:_) -> isUpper c+	_ -> False+-}+    checkModuleName1 = one @@ checkModuleName+      where+     one [q] = return q+     one qs = fail $ pp $ "Ambiguous module name:"<+>fsep qs++entityId f = (f' # opt idty) <@ arg "<M.x>"+  where+    f' ns = f . (,) ns @@ parseQualId++    -- This could be done with cmd and !,+    -- but the usage printer isn't good enough yet.+    idty = Token conv "type|class|value|con"++    conv arg | isClassOrType arg = Just ClassOrTypeNames+             | isValue       arg = Just ValueNames+             | otherwise         = Nothing++    isClassOrType arg = arg `elem` ["type","class"]+    isValue arg = arg `elem` ["value","con"]++{-+entityId f = Args "[type|class|value] <M.x>" (f @@ parseEntId)+  where+    parseEntId args0 = (,) ns # parseOneQualId args1+       where+         (ns,args1) =+           case args0 of+	     arg:args | isClassOrType arg -> (Just ClassOrTypeNames,args)+		      | isValue arg       -> (Just ValueNames,args)+	     _ -> (Nothing,args0)+         isClassOrType arg = arg `elem` ["type","class"]+	 isValue arg = arg `elem` ["value","con"]+-}
+ tools/pfe/PfeSocket.hs view
@@ -0,0 +1,79 @@+module PfeSocket(listenOnPFE,connectToPFE,acceptPFE,removePFE,+                 pfeClient,clientOps,serverOps,sResult,errorString) where+import Prelude hiding (putStr,readIO)+import Network(listenOn,accept,connectTo,PortID(..))+import IO(hPutStrLn,hPrint,hGetLine,hGetContents,hClose,hSetBuffering,BufferMode(..))+import AbstractIO+import MUtils(ifM,done)+import SIO++listenOnPFE dir = ifM (doesFileExist (pfePath dir)) tryConnect listen+  where+    listen = listenOn (pfePort dir)++    tryConnect =+      do r <- try connect+         case r of+           Left _ -> cleanUp>>listen+	   Right _ -> backoff++    connect = do h <- connectToPFE dir+		 hPutStrLn h ""+		 s <- hGetContents h+		 seq (length s) done -- to avoid crashing the server+                 hClose h++    backoff = fail "PFE Server is already running"++    cleanUp = removePFE dir++acceptPFE s = do a@(h,_,_) <- accept s+		 hSetBuffering h IO.LineBuffering+		 return a++connectToPFE dir =+  do h <- connectTo "localhost" (pfePort dir)+     hSetBuffering h LineBuffering+     return h++pfeClient h args =+  do inBase $ hPutStrLn h (unwords args)+     clientLoop+     inBase $ hClose h+  where+    clientLoop =+       do msg <- inBase $ hReadLn h+	  case msg of+	    Stdout s -> putStr s >> clientLoop+	    Stderr s -> ePutStr s >> clientLoop+	    Result r -> case r of+			  Left s -> fail s+			  Right () -> done+			   ++removePFE = removeFile . pfePath++pfePort = UnixSocket . pfePath+pfePath dir = dir++"/pfeserver"++data Msg = Stdout String | Stderr String | Result Result deriving (Read,Show)+type Result = Either String ()++serverOps h = StdIO {put=sPut h, eput=sePut h}+clientOps   = StdIO {put=putStr, eput=ePutStr {-. color-}}+--  where color s = "\ESC[31m"++s++"\ESC[m"++sPut h = hPrint h . Stdout+sePut h = hPrint h . Stderr+sResult h = hPrint h . Result . either (Left . show) Right++hReadLn h = readIO =<< hGetLine h++-- Work around the ugly way GHC prints user errors...+errorString e =+    if isUserError e+    then dropPrefix "user error\nReason: " (ioeGetErrorString e)+    else show e++dropPrefix (x:xs) (y:ys) | x==y = dropPrefix xs ys+dropPrefix _ ys = ys
+ tools/pfe/PfeTransformCmds.hs view
@@ -0,0 +1,42 @@+module PfeTransformCmds where+import Pfe3Cmds(pp'')+import PfeParse(moduleArg)+import PFE_StdNames(getStdNames,prelValue,getPrelValue)+import RemovePatBinds+--import RemoveIrrefPats -- appers not to be reusable in extensions!+import SimpPatMatch(simpAllPatMatch,getSimpPatIds)+import SimpFunBind(simpAllFunBind)+import HsModuleMaps(mapDecls)++import PNT(PNT)+import TiNames(localVal)+--import StateM+import TiPNT()       -- to get instances for ValueId PNT++pfeTransformCmds =+    [("rmpatbind", (moduleArg rmpatbind,  "remove pattern bindings")),+--   ("rmirrpat",  (moduleArg rmirrpat,   "remove irrefutable patterns")),+--   ("onlynested",(moduleArg onlynested, "remove pattern bindings and irrefutable patterns")),+     ("patmatch",  (moduleArg patmatch,   "simplify pattern matches")),+     ("funbind",  (moduleArg funbind,   "simplify function bindings"))+    ]++rmpatbind m =+  do pErr <- getPrelValue "error"+     pp'' (mapDecls (remPatBinds' pErr bind_names)) id m++--rmirrpat    = pp'' (removeIrrefPats arg_names) id+--onlynested  = pp'' (remPatBinds' bind_names . removeIrrefPats arg_names) id+++arg_names, bind_names :: [PNT]+arg_names   = [ localVal ("arg" ++ show n) | n <- [1..]] +bind_names  = [ localVal ("bind" ++ show n) | n <- [1..]] +++patmatch m =+  do stdName <- getStdNames+     ids <- getSimpPatIds (prelValue stdName)+     pp'' (simpAllPatMatch ids.mapDecls simpAllFunBind) id m++funbind  = pp'' (mapDecls simpAllFunBind) id
+ tools/pfe/PfeVersionCmd.hs view
@@ -0,0 +1,9 @@+module PfeVersionCmd where+import PfeParse(noArgs)+import PFE0(pput)++import Now++pfeVersionCmd = [("version", (noArgs version,"display version number"))]++version = pput compileDate
+ tools/pfe/README.html view
@@ -0,0 +1,104 @@+<h1>Extensible Haskell front-end for the Programatica project</h1>++<h2>What is in this directory (pfe)</h2>++This directory contains modules implementing PFE, the Preliminary Front-End.++<p>+PFE provides the infrastructure to work with Haskell programs consisting of+a number of interdependent modules, stored in files. We use the term+<em>project</em> to denote a collection of Haskell modules that are to be+processed together by PFE.++<p>+PFE has built-in make(1)-like functionality: it+automatically processes files in the right order, and caches results between+runs to avoid reparsing and reanalyzing files that haven't changed.++<h3>Functionality</h3>+PFE provides the following functionality, which is available both in the+form of command line tools and as Haskell functions:++<dl>+  <dt>Level 0+  <dd>Project management: creating a project, adding/removing files to+      a project. Computing the module dependency graph. Various module level+      queries.+  <dt>Level 1+  <dd>Computing some module properties that can be determined locally and that+      does not require proper parsing.+  <dt>Level 2+  <dd>Analysis of import/export specifications, to determine what is in scope+      on the top level of each module. This is based on the code decribed+      in our paper+      <a href="http://www.cse.ogi.edu/~diatchki/hsmod/">A Formal Specification+      for the Haskell 98 Module System</a>.+  <dt>Level 3+  <dd>Proper parsing of Haskell modules, taking fixity declarations into+      account. The identifiers in the output of the proper parser are+      decorated so that they are unique and you can tell what original entity+      they refer to.+  <dt>Level 4+  <dd>Type checking. The type checker can output a syntax tree decorated with+      type annotations. It can also perform the dictionary translation.+  <dt>Level 5+  <dd>Function level dependency graph. This is done after type checking, to+      properly account for dependencies involving instance declarations.+      (The module is called <code>PFEdeps</code>.)+  <dt>Chase (built on top of level 0)+  <dd>Import chasing. Searches for source files containing needed modules in+      specified directories. This function assumes that a module <code>M</code>+      is stored in a file called <code>M.hs</code> or <code>M.lhs</code>.+      (This is the only function of PFE that assumes a relation between file+      names and module names.)+  <dt>HTML (built on top of level 3)+  <dd>Conversion to HTML, with highlighting and cross references.+</dl>+++<h3>Extensibility</h3>++PFE is designed to be extensible in several dimensions:++<dl>+  <dt>Functionality+  <dd>It should be ease to create new command line tools that+      inherits and extends the provided functionality.+  <dt>Language extensions. +  <dd>PFE is parameterized over the source language parser, so the source+      language is not hardwired in PFE, but there are some restrictions:+      <ul>+        <li>The type of the lexer is fixed and the parser is expected to+	    cooperate with the lexer to implement Haskell's layout conventions.+	    (See module <a href="pfe.cgi?ParseMonad"><code>ParseMonad</code></a>.)+        <li>The source file parser is expected to return something of+	    type <code>HsModuleI</code> <var>i</var> <var>ds</var>,+	    for <em>some</em> types <var>i</var> and <var>ds</var>.+	    (See module <a href="pfe.cgi?HsModule"><code>HsModule</code></a>.)+	<li>The types returned by the parser are required to be instances+	    of a number of classes: a small number of instances are required+	    for level 0 functionality, more instances are required+	    for higher levels.+      </ul>+      See <a href="../property/"><code>../property</code></a> for an example+      of reusing PFE in an extended language.+  <dt>Monadic abstraction+  <dd><ul>+	<li>The PFE functions are operations in a monad, but the exact monad+	    type is left open. Code providing new functionality can use an+	    extended monad. The monad is constructed using+	    <a href="http://www.cse.ogi.edu/~diatchki/MonadTransformers/">monad+            transformers</a>.+        <li>Although various forms of IO are used by PFE, there are no+	    hardwired dependencies on the <code>IO</code> monad. Instead+	    we have defined classes of <em>abstract IO operations</em>+	    (see module <a href="pfe.cgi?AbstractIO"><code>AbstractIO</code></a>.)+	    and provide instances for the ordinary <code>IO</code> monad and+	    some monad transformers. It should be possible to use PFE in+            contexts where the standard monadic IO system is not directly+            available (e.g., inside a Fudget).+     </ul>+</dl>+<hr>+<address>Authors: TH</address>+<address>Contact: <a href="http://www.cse.ogi.edu/~hallgren/">TH</address>
+ tools/pfe/myghci view
@@ -0,0 +1,6 @@+#!/bin/sh++. HuMakefile+GHCFLAGS="$GHCFLAGS -fno-monomorphism-restriction -fallow-undecidable-instances"+ghci $GHCFLAGS -i${SRC_DIRS} $*+
+ tools/pfe/pfe.hs view
@@ -0,0 +1,43 @@++--import System(getArgs)+import PPU(getPPopts)++import HsParser(parse)+import HsLexerPass1(lexerPass0)+--import DefinedNamesBase()+import FreeNamesBase()+import ScopeNamesBase()+import NameMapsBase()+import ReAssocBase()+import RemoveListCompBase()+import SimpPatMatchBase()++import TiDecorate(TiDecls) -- to choose result type from the type checker+import HsModule++import Pfe0Cmds(addHelpCmd)+import Pfe4Cmds(pfe4Cmds)+import PFE4(PFE4Info)+import Pfe3Metrics(pfe3MetricsCmds)+import PFEdeps(clean5)+import PfeHtmlCmds(pfeHtmlCmds)+import PfeChase(pfeChaseCmds)+import PfeTransformCmds(pfeTransformCmds)+import PfeDepCmds(runPFE5Cmds,pfeDepCmds)+import PfeCleanCmd(pfeCleanCmd)+import PfeInteractive(pfeiAllCmds,runSIO)+import MapDeclMBase() -- for removing pattern bindings in PfeTransformCmds.+--import RemoveIrrefPatsBase()++main =+  do ao@(opts,prg,args) <- getPPopts+     let lp = (const lexerPass0,parse)+     runSIO (runPFE5Cmds () (pfeiAllCmds pfeCmds prg) lp ao)++pfeCmds = pfe4Cmds tcOutput++pfe3MetricsCmds++pfeTransformCmds+          ++pfeChaseCmds++pfeHtmlCmds++pfeDepCmds++pfeCleanCmd clean5+++tcOutput = id :: I (PFE4Info i2 (TiDecls i2))+--tcOutput = id :: I [[HsModuleR]]+type I a = a->a
+ tools/pfe/pfeclient.hs view
@@ -0,0 +1,8 @@+import System(getArgs)+import PfeSocket(connectToPFE,pfeClient)+import ImpUtils()++main =+  do h <- connectToPFE "hi"+     args <- getArgs+     pfeClient h args
+ tools/pfe/pfeclient.sh view
@@ -0,0 +1,9 @@+#!/bin/bash ++if [ -r "hi/pfeserver" ] ; then+  read port <hi/pfeserver+  { echo "$*" >&3; cat <&3; } 3<>"/dev/tcp/localhost/$port"+else+  echo >&2 "No PFE server available"+  exit 1+fi
+ tools/pfe/pfesetup view
@@ -0,0 +1,90 @@+#!/bin/bash++# This script assist in creating a new PFE project and adding source files to+# it.++defaultPROGRAMATICA="/home/projects/pacsoft/tools/lib/Programatica/libs"++PFE="${PFE-pfe}"+PROGRAMATICA="${PROGRAMATICA-$defaultPROGRAMATICA}"+PFE_LIBS=${PFE_LIBS-$PROGRAMATICA/libs}++[ -r HuMakefile ] && . HuMakefile # Reuse the list of source directories!++flags=""+libs=""+prelude=yes+hierarchical=no++while+  case "$1" in+    prelude)+      prelude=yes+      flags="$flags $1"+      shift+      ;;+    noprelude)+      prelude=no+      flags="$flags $1"+      shift+      ;;+    plogic|noplogic|nocpp|cpp|cpp=*)+      flags="$flags $1"+      shift+      ;;+    -[PIi])+      shift+      libs="$libs $1"+      shift+      ;;+    -[PIi]*)+      libs="$libs ${1#-[PIi]}"+      shift+      ;;+    +h|hierarchical)+      hierarchical=yes+      shift+      ;;+    -h|nohierarchical)+      hierarchical=no+      shift+      ;;+    *)+    false+  esac+do+:+done++L="hi/libs"+extralibs="$L/GhcLibraries $L/HbcLibraries"+pfelibs="$L/HaskellLibraries $extralibs"+hugslibs="$L/HugsLibraries $extralibs"++case "$prelude" in+  yes)+    if [ -d "$PFE_LIBS" ]; then+      case "$hierarchical" in+        yes) libs="$libs $hugslibs" ;;+	*) libs="$libs $pfelibs"+      esac+    else+      echo "$PFE_LIBS is missing."+      echo "The Prelude and standard libraries will not be included automatically."+      echo "Perhaps you need to set PROGRAMATICA to point where you installed it."+    fi+    ;;+esac++rm -rf hi/options+#rm -rf hi # Is it better to clean away all old stuff?++echo $PFE $flags new -quiet "$*"+$PFE $flags new -quiet "$@" && {+  case "$PFE_LIBS" in+    /*) ln -s "$PFE_LIBS" hi/libs;; #Absolute path+    *) ln -s "../$PFE_LIBS" hi/libs # Relative path, adjust it!+  esac+  echo "$PFE $flags chase `echo ${SRC_DIRS-.} $libs | sed  's/:/ /g'`"+  $PFE $flags chase `echo ${SRC_DIRS-.} $libs | sed  's/:/ /g'`+}
+ tools/pfe/tstpfe0.hs view
@@ -0,0 +1,10 @@+import System(getArgs)++import HsParser(parse)+import ReAssocBase()+--import NameMapsBase()+--import FreeNamesBase()++import Pfe0Cmds(pfe0)++main = pfe0 parse =<< getArgs
+ tools/pfe/tstpfe1.hs view
@@ -0,0 +1,10 @@+import System(getArgs)++import HsParser(parse)+import ReAssocBase()+import FreeNamesBase()+import PPModules()++import Pfe1Cmds(pfe1)++main = pfe1 parse =<< getArgs
+ tools/pfe/tstpfe2.hs view
@@ -0,0 +1,10 @@+import System(getArgs)++import HsParser(parse)+import ReAssocBase()+import FreeNamesBase()+import PPModules()++import Pfe2Cmds(pfe2)++main = pfe2 parse =<< getArgs
+ tools/pfe/tstpfe3.hs view
@@ -0,0 +1,18 @@+import System(getArgs)++import HsParser(parse)++-- moved to PFe3Cmds+--import DefinedNamesBase()+-- import FreeNamesBase()+-- import ScopeNamesBase()+-- import NameMapsBase()+-- import ReAssocBase()+-- import MapDeclMBase()++import Pfe3Cmds(pfe3)+import PPU(getPPopts)+++-- main = pfe3 parse =<< getArgs+main = pfe3 parse =<< getPPopts
+ tools/pg2hol/HOLOps.hs view
@@ -0,0 +1,28 @@+-- $Id: HOLOps.hs,v 1.3 2001/07/19 22:17:37 wlh Exp $++module HOLOps (getHOLTyCon, getHOLOp) where++holOps = [ ("===",   (True, "=")),+           ("==>",   (True, "==>")),+           ("&&&",   (True, "/\\")),+           ("|||",   (True, "\\/")),+           (".",     (True, "o")),+           ("==",    (True, "=")),+           ("$",     (False, "(\\ f . \\ x . f x)")),+           ("True",  (False, "true")),+           ("False", (False, "false"))+         ]++holTyCons = [ ("[]",  "list"),+              ("()",  "unit"),+              ("Int", "int"),+              ("Nat", "num")+            ]++-- lookup n db = filter ((== n) . fst) db++getHOLTyCon :: String -> Maybe String+getHOLTyCon con = lookup con holTyCons++getHOLOp :: String -> Maybe (Bool, String)+getHOLOp n = lookup n holOps
+ tools/pg2hol/HS2Hol.hs view
@@ -0,0 +1,93 @@+module HS2Hol where++import Syntax+import PrettyPrint++import Observe+++data2hol :: HsDecl -> Doc+data2hol (Dec (HsDataDecl srcloc _ ((Typ (HsTyCon name)):params) cons _))  +    = comment $$ holDatatype $$ nest 4 holCons $$ text "`;"+    where+    comment     = text "(* From" <+> text (show srcloc) <+> text ": *)"+    holDatatype = text "val _ = Hol_datatype `" +                    <+> text (show name) +    holCons     = text "=" <+> (foldr1 (\d d' -> d $$ text "|" <+> d') $+                    map (hsConDecl2holConDecl [name]) cons)++data2hol _ = error"data2hol: only wokrs on HsDataDecl"+++hsConDecl2holConDecl :: [HsName] -> HsConDecl HsType  -> Doc +hsConDecl2holConDecl excl (HsConDecl _ name params)+    = hsName2hol name <+> ps+    where+    ps = case params of+        []  -> empty+        xs  -> text "of" <+> (hsep $ punctuate (text " =>") $+                                map (hsType2hol excl . hsBangType2Type) xs)++hsConDecl2holConDecl _ _  = error "hsConDecl2holConDecl: records not implemented"+++-- the list of names specifies constructors,+-- which should not be applied to arguments+-- even if they have any.  this is useful in Hol_datatype+-- definitions, where one cannot specify aruments to+-- whatever is currently being defined+hsType2hol :: [HsName] -> HsType -> Doc +hsType2hol excl (Typ typ)+    = case typ of+        HsTyVar name    -> text "'" <> hsName2hol name+        HsTyCon name    -> hsName2hol name+        HsTyApp t1@(Typ (HsTyCon n)) t2+            | n `elem` excl -> hsType2hol excl t1+            | otherwise     -> parens (hsType2hol excl t2) <+>+                               hsType2hol excl t1+        HsTyTuple ts    -> hsep $ punctuate (text "#") $+                            map (hsType2hol excl) ts+        HsTyForall n t  -> hsType2hol excl t+++++hsName2hol :: HsName -> Doc +hsName2hol (UnQual s)   = text s +hsName2hol _            = error "hsName2hol: only unqualified names work"++hsBangType2Type :: HsBangType t -> t+hsBangType2Type (HsUnBangedType t)  = t+hsBangType2Type  _ = error "hsBangType2Type: only unbaged types work"++++--------------------------------------------------------------------------------+-- tests+--++n = UnQual +loc = SrcLoc "MyFile" 1 1++t1 :: HsDecl+t1 = hsDataDecl loc []+        {-data-} [hsTyCon $ n "List", hsTyVar $ n "a"]+        [ HsConDecl loc (n "Nil") []+        , HsConDecl loc (n "Cons")+            [ HsUnBangedType (hsTyVar $ n "a")+            , HsUnBangedType (hsTyApp (hsTyCon $ n "List") (hsTyVar $n "a"))+            ]+        ]+        {-deriving-} []++++--+--------------------------------------------------------------------------------+++++++
+ tools/pg2hol/HuMakefile view
@@ -0,0 +1,4 @@+B=../base+P=../property+SRC_DIRS=$B/parse:$B/pretty:$B/AST:$B/SA:$B/TC:$B/lib:$P/AST:$P/parse/extras:$P/syntax:$P/command:.+GHCFLAGS="-fglasgow-exts -package lang"
+ tools/pg2hol/Main.hs view
@@ -0,0 +1,183 @@+-- $Id: Main.hs,v 1.5 2001/10/10 23:43:23 hallgren Exp $++-- Currently a test harness for lexer/parser/pretty printer/prop2hol.++module Main (main) where+++import IO+import Lexer+import ParseMonad+import PropParser+import ParseUtil+import Syntax+import PrettyPrint+import System+import GetOpt+import IOExts+import List+import Rewrite(rewriteModule)+import HsAssocInitEnv(initEnv)+import Prop2HOL(prop2HOL)+++data Flag = LexOnlyLength          -- print number of tokens only+          | LexOnlyRev             -- print tokens in reverse order+          | LexOnly                -- print tokens+          | ParseLength            -- print number of declarations only+          | ParseInternal          -- print abstract syntax in internal format+          | ParsePretty PPLayout   -- pretty print in this style+          | ToHOL                  -- produces naive HOL version+          | TestStatic             -- test static checker+          | TestTypeCheck+          | ShowNames+          | Help                   -- give short usage info++usage = "usage: prop2hol [option] [filename]"++options =+   [ Option ['n']  ["numtokens"] (NoArg LexOnlyLength)+         "print number of tokens only",+     Option ['r']  ["revtokens"] (NoArg LexOnlyRev)+         "print tokens in reverse order",+     Option ['t']  ["tokens"]    (NoArg LexOnly)+         "print tokens",+     Option ['d']  ["numdecls"]  (NoArg ParseLength)+         "print number of declarations only",+     Option ['a']  ["abstract"]  (NoArg ParseInternal)+         "print abstract syntax in internal format",+     Option ['p']  ["pretty"]    (OptArg style "STYLE")+         "pretty print in STYLE[(o)ffside|(s)emicolon|(u)trecht|(i)nline|\+                    \(n)one] (default = offside)",+     Option ['h','?'] ["help"]   (NoArg Help)+         "display this help and exit",+     Option ['s'] ["static"] (NoArg TestStatic) +         "run stattic checker",+     Option ['c'] ["typecheck"] (NoArg TestTypeCheck) "run typechecker",+     Option ['m'] ["names"]     (NoArg ShowNames)      "show all defined names"+   ]++style :: Maybe String -> Flag+style Nothing  = ToHOL+style (Just s) = ParsePretty $+         case s of+         "o"         -> PPOffsideRule+         "offside"   -> PPOffsideRule+         "s"         -> PPSemiColon+         "semicolon" -> PPSemiColon+         "u"         -> PPUtrecht+         "utrecht  " -> PPUtrecht+         "i"         -> PPInLine+         "inline"    -> PPInLine+         "n"         -> PPNoLayout+         "none"      -> PPNoLayout+         _           -> PPOffsideRule++main :: IO ()+main = do cmdline <- getArgs+          mainHugs cmdline++mainHugs :: [String] -> IO ()+mainHugs cmdline =+   case getOpt Permute options cmdline of+      (flags, args, [])    ->+       do (file, inp) <- case args of+			 []  -> do inp <- getContents+				   return ("stdio", inp)+			 [f] -> do inp <- readFile f+				   return (f, inp)+			 _   -> error usage+          putStrLn (handleFlag (getFlag flags) file inp)+      (    _,   _, errors) ->+        error (concat errors ++ usageInfo usage options)++getFlag :: [Flag] -> Flag+getFlag []  = ToHOL+getFlag [f] = f+getFlag _   = error usage++handleFlag :: Flag -> FilePath -> String -> String+handleFlag LexOnlyLength    f = show . numToks . testLexerRev f+handleFlag LexOnlyRev       f = show . testLexerRev f+handleFlag LexOnly          f = show . testLexer f+handleFlag ShowNames        f = +    error "Main.handleFlag: name extraction not implemented yet."+-- show . getAllNames . testParser f+handleFlag ParseLength      f = show . allLengths . testParser f+   where allLengths (HsModule _ _ imp d) =+            length imp + length d+handleFlag ParseInternal    f = show . testParser f+handleFlag ToHOL            f = render . testProp2HOL f+handleFlag TestStatic       f =+    error "Main.handleFlag: static analysis test not implemented yet."+{-+handleFlag TestStatic       f = \s -> +    unsafePerformIO $ +    do { r <- testStatic $ testParser f s ;+         return "Done static checking." }+-}+handleFlag TestTypeCheck    f =+    error "Main.handleFlag: type check test not implemented yet."+{-+handleFlag TestTypeCheck    f = \s -> +    unsafePerformIO $ +    do  { let { m = testParser f s } ;+          r <- testStatic m ;+          print $ (typeCheckDecls . (\ (HsModule _ _ _ _ ds) -> ds)) m;+          return "Done static checking." }+-}+handleFlag (ParsePretty lo) f+    = renderWithMode mode . ppi . testParser f+      where mode = defaultMode { layoutType = lo }+handleFlag Help             f          +    = const $+      usageInfo+          ("A simple test program for *The Haskell Parser*" ++ usage)+      options++numToks :: ParseResult () [Token] -> Int+numToks (Ok _ toks)  = length toks+numToks (Failed err) = error ("Huh? " ++ err)++testLexerRev :: FilePath -> String -> ParseResult () [Token]+testLexerRev f s =+    (unPM $ loop []) s (SrcLoc f 1 0) 1 (error "Initial environment", []) +    where loop toks =+	      lexer (\t -> case t of +                           EOF -> returnPM toks+                           _   -> loop (t:toks))++testLexer :: FilePath -> String -> ParseResult () [Token]+testLexer f s = (unPM $ loop []) s  (SrcLoc f 1 0) 1 ((), [])+  where loop toks =+         lexer (\t -> case t of +              EOF -> returnPM (reverse toks) -- space leak?+              _   -> loop (t:toks))++testParser :: FilePath -> String -> HsModuleR+testParser f s =+    case (unPM parse) s  (SrcLoc f 1 1) 0 ((), []) of+    Ok state mod -> rewriteModule initEnv mod+    Failed err -> error err++testProp2HOL f s = prop2HOL $ testParser f s++------------------------------------------------------------------------------+-- tests+--++n = UnQual +loc = SrcLoc "MyFile" 1 1+{-+t1 :: HsDecl+t1 = hsDataDecl loc []+        {-data-} [hsTyCon $ n "List", hsTyVar $ n "a"]+        [ HsConDecl loc (n "Nil") []+        , HsConDecl loc (n "Cons")+            [ HsUnBangedType (hsTyVar $ n "a")+            , HsUnBangedType (hsTyApp (hsTyCon $ n "List") (hsTyVar $n "a"))+            ]+        ]+        {-deriving-} []+-}+----------------------------------------------------------------------------
+ tools/pg2hol/Makefile view
@@ -0,0 +1,61 @@+# $Id: Makefile,v 1.1 2001/05/04 18:51:20 moran Exp $++HC         = ghc+HC_LOCAL_LIB = ${HOME}/lib+BASE       = ../base+PROP       = ../property+HC_INC     = ${BASE}/parse ${BASE}/pretty ${BASE}/AST ${BASE}/SA ${BASE}/TC \+             ${BASE}/lib ${HC_LOCAL_LIB} ${PROP}/AST ${PROP}/parse/extras   \+             ${PROP}/syntax ${PROP}/command .++HC_PKG = lang concurrent util+HC_DEP = ${HC} -M+HC_INCI = ${addprefix -i,${HC_INC}}+HC_PKGI = ${addprefix -package,${HC_PKG}}+HC_LIBI = ${addprefix -l,${HC_LIBS}}+HC_XOPTS = -recomp -fwarn-incomplete-patterns -H128M -fglasgow-exts+HC_OPTS = ${$*_HC_OPTS} ${HC_XOPTS} ${HC_INCI} ${HC_PKGI}++HINT_OPTS = ${HC_OPTS}++DEP_OPTS   = ${HC_INCI}+HC_LDOPTS  = ${HC_OPTS} ${addprefix -L,${HC_INC}} ${HC_LIBI}++HAPPY      = happy+HAPPYFLAGS = # --ghc makes parser unusable for Hugs+RUNTIMEFLAGS = # +RTS -H75M+PRINTER    = lj12+ENSCRIPT   = enscript++HAPPYSRC   = ${PROP}/parse/extras/PropParser.y+MAINSRC    = Main.hs++RM         = rm -f++MAIN       = pg2hol++%.hs: %.y+	$(HAPPY) $(HAPPYFLAGS) $< --info $(RUNTIMEFLAGS) -o $(HAPPYSRC:.y=.hs)++$(MAIN): $(HAPPYSRC:.y=.hs)+	${HC} --make $(MAINSRC) -o $@ ${HC_OPTS}++develop:+	$(HINT) $(MAINSRC) ${HINT_OPTS}++tidy:+	$(RM) ${BASE}/parse/Lexer.hi++clean:+	$(RM) ${HC_OBJ} $(MAIN).aux $(MAIN).hp $(MAIN).prof core \+           $(MAIN).ps profile.* *~ .depend* $(HAPPYSRC:.y=.info) \++printsource:+	$(ENSCRIPT) -1 -d $(PRINTER) -G $(HC_SRC)++veryclean: clean+	$(RM) $(MAIN) TAGS $(HAPPYSRC:.y=.hs)++TAGS: ${HC_SRC}+	hstags ${HC_SRC}+
+ tools/pg2hol/Makefile.ghc-4.08 view
@@ -0,0 +1,122 @@+# $Id: Makefile.ghc-4.08,v 1.1 2001/05/04 18:51:20 moran Exp $++HC = ghc+HC_LOCAL_LIB = ${HOME}/lib+BASE = ../base+PROP = ../property+HC_INC = ${BASE}/parse ${BASE}/pretty ${BASE}/AST ${BASE}/SA ${BASE}/TC \+         ${BASE}/lib ${HC_LOCAL_LIB} ${BASE} ${PROP} .++HC_DEP = ${HC} -M+HC_INCI = ${addprefix -i,${HC_INC}}+HC_PKGI = ${addprefix -package,${HC_PKG}}+HC_LIBI = ${addprefix -l,${HC_LIBS}}+HC_OPTS = ${$*_HC_OPTS} ${HC_XOPTS} ${HC_INCI} ${HC_PKGI} \+          -recomp -fwarn-incomplete-patterns -H55M \+          -fglasgow-exts -fmax-simplifier-iterations5 \+	  -package lang -package concurrent #-Wall ++DEP_OPTS = ${HC_INCI}+HC_LDOPTS = ${HC_OPTS} ${addprefix -L,${HC_INC}} ${HC_LIBI}++HAPPY      = happy+HAPPYFLAGS = # --ghc makes parser unusable for Hugs+RUNTIMEFLAGS = # +RTS -H75M+PRINTER    = lj12+ENSCRIPT   = enscript++RM         = rm -f++HAPPYSRC = ${PROP}/PropParser.y+AST_COMMON_SRC = ${BASE}/AST/SrcLoc.hs ${BASE}/AST/HsLiteral.hs \+           ${BASE}/AST/HsName.hs ${BASE}/AST/HsModule.hs \+           ${BASE}/AST/HsGuards.hs ${BASE}/AST/HsExpStruct.hs \ +           ${BASE}/AST/HsPatStruct.hs ${BASE}/AST/HsDeclStruct.hs \+           ${BASE}/AST/HsTypeStruct.hs ${BASE}/AST/HsAssoc.hs \+	   ${BASE}/AST/ListUtil.hs ${BASE}/AST/HsConstants.hs+PP_SRC   = ${BASE}/pretty/PrettyPrint.hs ${BASE}/pretty/Pretty.lhs \+           ${BASE}/pretty/PrettyM.hs ${BASE}/pretty/PrettyUtil.hs +BASE_AST_SRC = ${BASE}/BaseSyntaxStruct.hs +PROP_SRC =  ${PROP}/HsPropStruct.hs ${PROP}PropSyntaxUtil.hs \+            ${PROP}/PropRewrite.hs ${PROP}/Syntax.hs \+            ${PROP}/SyntaxStruct.hs ${PROP}/SyntaxRec.hs \+             ${PROP}/SyntaxUtil.hs ${PROP}/Rewrite.hs+PARSE_SRC = ${BASE}/parse/Lexer.hs ${BASE}/parse/LexUtil.hs \+            ${BASE}/parse/ParseMonad.lhs ${BASE}/parse/ParseUtil.hs +SA_SRC   = ${BASE}/SA/Scope.hs ${BASE}/SA/Scope2.hs ${BASE}/SA/SCC.hs+TC_SRC   = ${BASE}/TC/InferenceMonad.hs ${BASE}/TC/TypeGenerics.hs \+           ${BASE}/TC/TypeCheck.hs ${BASE}/TC/TypeCheckTest.hs \+           ${BASE}/TC/Components.hs+OBS_SRC  = ${HC_LOCAL_LIB}/Observe.lhs+OPT_SRC  = ${BASE}/lib/GetOpt.hs +HS2HOL_SRC = Hs2HOL.hs+HC_SRC   = ${AST_COMMON_SRC} ${PP_SRC} ${BASE_AST_SRC} ${PARSE_SRC} \+	   ${PROP_SRC} ${HS2HOL_SRC} \+	   $(HAPPYSRC:.y=.hs) \+	   ${OPT_SRC} Main.hs++HC_INT1  = $(HC_SRC:.hs=.hi)   # no way to get rid of this?+HC_INT   = $(HC_INT1:.lhs=.hi)+HC_OBJ   = $(HC_INT:.hi=.o)++MAIN       = hs2hol++# trick  :-)+ifeq (.depend,$(wildcard .depend))+all: $(MAIN)+include .depend+else+all: depend $(MAIN)+endif++%.hs: %.y+	$(HAPPY) $(HAPPYFLAGS) $< --info $(RUNTIMEFLAGS) -o $(HAPPYSRC:.y=.hs)++%.o : %.lhs+	${HC} ${HC_OPTS} -c $< -o $@++%.o : %.hs+	${HC} ${HC_OPTS} -c $< -o $@++%.hi : %.o+	@if [ ! -f $@ ] ; then \+	    echo Panic! $< exists, but $@ does not. \+	    exit 1; \+	else exit 0; \+	fi                                                      ++%.ps : %.hs+	${ENSCRIPT} -1 -o $@ -G $<++%.ps : %.lhs +	${ENSCRIPT} -1 -o $@ -G $<+++$(MAIN): ${HC_OBJ}+	${HC} -o $@ ${HC_OPTS} ${HC_OBJ}++$(HAPPYSRC:.y=.o): $(HAPPYSRC:.y=.hs)+	$(RM) $@+	${HC} ${HC_OPTS} -H95M -c $< -o $@++Main.o: Main.hs+	$(RM) $@+	${HC} ${HC_OPTS} -c $< -o $@++clean:+	$(RM) ${HC_OBJ} ${HC_INT} $(MAIN).aux $(MAIN).hp $(MAIN).prof core \+           $(MAIN).ps profile.* *~ .depend* $(HAPPYSRC:.y=.info) ++printsource:+	$(ENSCRIPT) -1 -d $(PRINTER) -G $(HC_SRC)+veryclean: clean+	$(RM) $(MAIN) TAGS $(HAPPYSRC:.y=.hs)++depend: .depend++.depend: ${HC_SRC}+	${HC_DEP} -optdep-f -optdep.depend ${HC_OPTS} ${HC_SRC}++TAGS: ${HC_SRC}+	hstags ${HC_SRC}+
+ tools/pg2hol/Prop2HOL.hs view
@@ -0,0 +1,335 @@++-- $Id: Prop2HOL.hs,v 1.7 2001/10/17 21:37:51 hallgren Exp $++module Prop2HOL(prop2HOL) where++import Syntax+import SCC+import PrettyPrint+import HOLOps+++prop2HOL :: HsModuleR -> Doc+prop2HOL = module2HOL++module2HOL :: HsModuleR -> Doc+module2HOL (HsModule m Nothing imports {- infixes -} decls)+    = fsep [ vcat $ map import2HOL imports,+--           vcat $ map infix2HOL infixes,+             vcat $ map hsDecl2HOL decls ]+--      where (dss, _) = bindingGroups decls+module2HOL (HsModule m (Just exports) imports {- infixes -} decls)+    = fsep [ vcat $ map export2HOL exports,+             vcat $ map import2HOL imports,+--           vcat $ map infix2HOL infixes,+             vcat $ map hsDecl2HOL decls ]+--      where (dss, _) = bindingGroups decls++export2HOL _ = notsupported0 "export declaration"++import2HOL _ = notsupported0 "import declaration"++infix2HOL (HsInfixDecl loc fixity ops) = notsupported loc "infix declaration"++decls2HOL :: [HsDecl] -> Doc+decls2HOL [] = empty+decls2HOL ds =+    vcat $ (text "let" <+> dhol :+            map (\dhol -> text "and" <+> dhol) dhols)+    where (dhol:dhols) = map hsDecl2HOL ds++hsDecl2HOL :: HsDecl -> Doc+hsDecl2HOL (Dec (HsTypeDecl loc ((Typ (HsTyCon con)):params) t))          +    -- notsupported loc "type synonym declaration"+    = blankline $ from loc+      $$ (text "Hol_datatype" <+>+          (backQuotes $+           ppi con <+> equals <+> hsType2HOL [con] t))+      $$ handleThm (text "Type synonym" <+> ppi con)+hsDecl2HOL (Dec (HsNewTypeDecl loc c ((Typ (HsTyCon con)):params) t ders))+    -- notsupported loc "newtype declaration"+    = blankline $ from loc+      $$ (text "Hol_datatype" <+>+          (backQuotes $+           ppi con <+> equals <+> hsConDecl2HOL [con] t))+      $$ handleThm  (text "Newtype" <+> ppi con)+hsDecl2HOL (Dec (HsDataDecl loc c ((Typ (HsTyCon con)):params) summands ders))+    = blankline $ from loc+      $$ (text "Hol_datatype" <+>+          (backQuotes $+           ppi con <+> equals <+>+           foldr1 (\d d' -> d $$ char '|' <+> d')+                  (map (hsConDecl2HOL [con]) summands)))+      $$ handleThm  (text "Datatype" <+> ppi con)+hsDecl2HOL (Dec (HsTypeSig loc nms c t))  +    = notsupported loc "type signature declaration"+hsDecl2HOL (Dec (HsFunBind loc ms))+    = blankline $ from loc+      $$ (text "val" <+> ppi fun <> text "_def" <+> equals <+>+          text "Define" <+>+          (backQuotes $+           foldr1 (\d d' -> parens d <+> text "/\\"+                            $$ d')+                  (map hsMatch2HOL ms)))+      $$ handleThm  (text "Function" <+> ppi fun)+    where (HsMatch _ fun _ _ _):_ = ms+hsDecl2HOL (Dec (HsPatBind loc (Pat (HsPId (HsVar v))) rhs ds))+    = blankline $ from loc+      $$ (text "val" <+> ppi v <> text "_def" <+> equals <+>+          text "Define" <+>+          (backQuotes $+           funRhs2HOL loc (ppi v) rhs ds))+      $$ handleThm  (text "CAF" <+> ppi v)+hsDecl2HOL (Dec (HsPatBind loc p rhs ds))+    = notsupported loc "pattern binding"+hsDecl2HOL (Dec (HsClassDecl loc c tp ds))+    = notsupported loc "class declaration"+hsDecl2HOL (Dec (HsInstDecl loc c tp ds))+    = notsupported loc "instance declaration"+hsDecl2HOL (Dec (HsDefaultDecl loc t))+    = notsupported loc "default declaration"+hsDecl2HOL (Dec (HsPrimitiveTypeDecl loc cntxt nm))+    = notsupported loc "Hugs-style primitive type declaration"+hsDecl2HOL (Dec (HsPrimitiveBind loc nm t))+    = notsupported loc "Hugs-style primitive type declaration"+hsDecl2HOL (PropDec (HsProperty loc (ns @ (prop:_)) e))+    = blankline $ from loc+      $$ (holComment $ text "Property:" <+> pns)+      $$ fsep [ text "val prop_" <> pprop <+> equals,+                letNest $ parens $ backQuotes $ backQuotes $ hsExp2HOL e ]+      $$ handleTerm (text "Property" <+> pprop)+      where pns = sep $ map ppi ns+            pprop = ppi prop        +++hsConDecl2HOL :: [HsName] -> HsConDecl HsType  -> Doc +hsConDecl2HOL excl (HsConDecl loc con params)+    = hsName2HOL con <+> ps+      where ps = case params of+                 [] -> empty+                 xs -> text "of" <+>+                       (hsep $ punctuate (text " =>") $+                        map (hsType2HOL excl . hsBangType2Type) xs)+hsConDecl2HOL excl (HsRecDecl loc _ _)+    = notsupported loc "record declaration"++hsMatch2HOL :: HsMatch HsExp HsPat [HsDecl] -> Doc+hsMatch2HOL (HsMatch loc fun ps rhs ds)+    = funRhs2HOL loc (wrap fun <+> (fsep $ map wrap ps)) rhs ds++funRhs2HOL :: SrcLoc -> Doc -> HsRhs HsExp -> [HsDecl] -> Doc+funRhs2HOL loc lhs (HsBody e)   ds =+    fsep [ lhs <+> equals,+	   funNest $+           hsLet2HOL ds e ]+funRhs2HOL loc lhs (HsGuard gs) ds =+    -- should convert guards to ifs, but need to factor in other function+    -- branches, since a missing "otherwise" or "True" leaves us without an+    -- else branch.  This involves some of the patterm match compilation+    -- machinery.  This may be needed anyway, since it's not clear how complex+    -- case expressions can be.+    notsupported loc "guarded function/CAF definiton"++hsLet2HOL :: [HsDecl] -> HsExp -> Doc+hsLet2HOL []     e = hsExp2HOL e+hsLet2HOL (d:ds) e = fsep [ text "let" <+> hsLetDecl2HOL d,+                            text "in" $$+                            (letNest $ hsLet2HOL ds e) ]+    +hsLetDecl2HOL (Dec (HsFunBind loc [m]))    =+    hsMatch2HOL m+hsLetDecl2HOL (Dec (HsFunBind loc ms))     =+    notsupported loc "function definitions with many cases in lets"+hsLetDecl2HOL (Dec (HsPatBind loc p rhs ds)) =+    funRhs2HOL loc (wrap p) rhs ds+hsLetDecl2HOL _                              =+    notsupported0 "non-function/pattern definitions in lets"++--hsExp2HOL :: HsExp -> Doc    +hsExp2HOL (Exp (HsId n))                 = hsIdent2HOL n+hsExp2HOL (Exp (HsLit l))                = ppi l+hsExp2HOL (Exp (HsInfixApp x (HsVar (UnQual "$")) y)) =+    fsep [ hsExp2HOL x, letNest $ parens $ hsExp2HOL y ]+hsExp2HOL (Exp (HsInfixApp x op y))      = hsInfixOp2HOL+                                               (hsOp2HOL op)+                                               (hsExp2HOL x)+                                               (letNest $ hsExp2HOL y)+hsExp2HOL (Exp (HsApp x y))              = fsep [ hsExp2HOL x,+                                                  letNest $ hsExp2HOL y ]+hsExp2HOL (Exp (HsNegApp x))             = char '-' <> hsExp2HOL x+hsExp2HOL (Exp (HsLambda ps e))          = fsep+                                           [ char '\\' <+>+					     sep (map (hsPat2HOL wrap) ps) <+>+				             char '.',+					     letNest $ hsExp2HOL e ]+hsExp2HOL (Exp (HsLet ds e))             = hsLet2HOL ds e+hsExp2HOL (Exp (HsIf x y z))             = text "if" <+> hsExp2HOL x <+>+                                           text "then"+				           $$ (letNest $ hsExp2HOL y)+				           $$ text "else"+				           $$ (letNest $ hsExp2HOL z)+hsExp2HOL (Exp (HsCase e alts))          =+    text "case" <+> hsExp2HOL e <+> text "of"+    $$ (vcat $ (nest 2 halt) : map (char '|' <+>) talt)+    where (halt:talt) = map hsAlt2HOL alts+hsExp2HOL (Exp (HsDo stmts))             =+    notsupported0 "do notation"+hsExp2HOL (Exp (HsTuple xs))             = ppiFTuple xs+hsExp2HOL (Exp (HsList xs))              = ppiList xs+hsExp2HOL (Exp (HsParen e))              = parens $ hsExp2HOL e+hsExp2HOL (Exp (HsLeftSection x op))     =+    parens $+    fsep [ char '\\' <+> ppi y <+> char '.',+           hsInfixOp2HOL (hsOp2HOL op) (hsExp2HOL x) (ppi y) ]+    where y :: HsExp+          y = hsEVar $ UnQual "_y" -- Must be replaced by unique name+hsExp2HOL (Exp (HsRightSection op y))    =+    parens $+    fsep [ char '\\' <+> ppi x <+> char '.',+           hsInfixOp2HOL (hsOp2HOL op) (ppi x) (hsExp2HOL y) ]+    where x :: HsExp+	  x = hsEVar $ UnQual "_x" -- Must be replaced by unique name+--hsExp2HOL (Exp (HsRecConstr n []))       = -- "A{}" is NOT the same as "A"...+--    notsupported0 "record construction"+hsExp2HOL (Exp (HsRecConstr n upds))     =+    notsupported0 "record construction"+hsExp2HOL (Exp (HsRecUpdate e []))       =+    notsupported0 "record update"+hsExp2HOL (Exp (HsRecUpdate e upds))     =+    notsupported0 "record update"+hsExp2HOL (Exp (HsEnumFrom x))           =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsEnumFromTo x y))       =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsEnumFromThen x y))     =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsEnumFromThenTo x y z)) =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsListComp stmts))       =+    notsupported0 "list comprehension"+hsExp2HOL (Exp (HsExpTypeSig s e c t))   =+    notsupported0 "type signature"+hsExp2HOL (Exp (HsAsPat n p))            =+    error "hsExp2HOL: pattern exp in expression"+hsExp2HOL (Exp (HsWildCard))             =+    error "hsExp2HOL: pattern exp in expression"+hsExp2HOL (Exp (HsIrrPat p))             =+    error "hsExp2HOL: pattern exp in expression"+hsExp2HOL (PropExp (HsQuant q ps e))       =+    fsep [ hsQuantifier2HOL q <+>+           sep (map (hsPat2HOL wrap) ps) <+>+           char '.',+           letNest $ hsExp2HOL e ]++hsAlt2HOL (HsAlt loc p rhs ds) =+    fsep [ hsPat2HOL wrap p, text "=>", caseRhs2HOL loc rhs ds ]++caseRhs2HOL loc (HsBody e)   ds =+    hsLet2HOL ds e+caseRhs2HOL loc (HsGuard gs) ds =+    -- should convert guards to ifs, but need to factor in other function+    -- branches, since a missing "otherwise" or "True" leaves us without an+    -- else branch.  This involves some of the patterm match compilation+    -- machinery.  This may be needed anyway, since it's not clear how complex+    -- case expressions can be.+    notsupported loc "guarded pattern in case expression"++hsQuantifier2HOL HsPropForall        = char '!'+hsQuantifier2HOL HsPropExists        = char '?'+hsQuantifier2HOL HsPropForallDefined = char '!' <+>+                                       (holComment $ text "defined")+hsQuantifier2HOL HsPropExistsUnique  = text "?!"++hsPat2HOL :: (HsPat -> Doc) -> HsPat -> Doc+hsPat2HOL ppf (Pat (HsPId id))             = ppi id+hsPat2HOL ppf (Pat (HsPLit lit))           = ppi lit+hsPat2HOL ppf (Pat (HsPNeg p))             = notsupported0 "negation pattern"+hsPat2HOL ppf (Pat (HsPInfixApp p1 op p2)) = fsep [ ppi op, ppf p1, ppf p2 ]+hsPat2HOL ppf (Pat (HsPApp id ps))         = fsep (ppi id : map ppf ps)+hsPat2HOL ppf (Pat (HsPTuple ps))          = ppiTuple ps+hsPat2HOL ppf (Pat (HsPList ps))           = ppiList ps+hsPat2HOL ppf (Pat (HsPParen p))           = parens $ ppi p+hsPat2HOL ppf (Pat (HsPRec _ _))           = notsupported0 "record pattern"+hsPat2HOL ppf (Pat (HsPRecUpdate _ _))     = notsupported0 "record pattern"+hsPat2HOL ppf (Pat (HsPAsPat id p))        = parens $+                                             ppi id <+> text "as" <+> ppf p+hsPat2HOL ppf (Pat (HsPWildCard))          = text "_dummy"+hsPat2HOL ppf (Pat (HsPIrrPat p))          = ppf p+hsPat2HOL ppf (PropPat (HsPatTypeSig p c t)) = ppf p++hsType2HOL :: [HsName] -> HsType -> Doc +hsType2HOL excl (Typ typ)+    = case typ of+        HsTyVar v     -> quote <> hsName2HOL v+        HsTyCon c     -> hsTyCon2HOL c+        HsTyApp (t1@(Typ (HsTyCon c))) t2+            | c `elem` excl -> hsType2HOL excl t1+        HsTyApp t1 t2 -> parens (hsType2HOL excl t2) <+> hsType2HOL excl t1+        HsTyTuple ts  -> hsep $ punctuate (text " #")+                              $ map (hsType2HOL excl) ts+        HsTyFun t1 t2 ->+            hsType2HOL excl t1 <+> text "->" <+> hsType2HOL excl t2++hsBangType2Type (HsBangedType t)   = t+hsBangType2Type (HsUnBangedType t) = t -- ignore strictness annotations++hsIdent2HOL :: HsIdent -> Doc+hsIdent2HOL = snd . hsOp2HOL++hsInfixOp2HOL (inf, op) x y | inf       = fsep [ x, op, y ]+                            | otherwise = fsep [ op, x, y ]++hsOp2HOL (HsCon (id @ (Qual _ n))) =+    case getHOLOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2HOL (HsCon (id @ (UnQual n))) =+    case getHOLOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2HOL (HsVar (id @ (Qual _ n))) =+    case getHOLOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2HOL (HsVar (id @ (UnQual n))) =+    case getHOLOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)++hsTyCon2HOL (id @ (Qual _ n)) =+    case getHOLTyCon n of+    Just holtycon -> text holtycon+    Nothing       -> hsName2HOL id+hsTyCon2HOL (id @ (UnQual n)) =+    case getHOLTyCon n of+    Just holtycon -> text holtycon+    Nothing       -> hsName2HOL id++hsName2HOL :: HsName -> Doc +hsName2HOL (UnQual n)        = text n +hsName2HOL (id @ (Qual _ n)) = text n <+> (holComment $ ppi id)++holComment d = text "(*" <+> d <+> text "*)"+from loc     = holComment $ text "From" <+> ppi loc <+> char ':'++notsupported loc msg+    = holComment $+      text "Not supported:" <+> text msg <+> text "from" <+> ppi loc+notsupported0 msg+    = holComment $ text "Not supported:" <+> text msg++handle failed backup =+    text "handle e =>" <+>+    (parens $+     (vcat [ text "print" <+>+             (doubleQuotes $ (failed <+> text "failed with exception"))+             <> semi,+             text "Exception.print_HOL_ERR e" <> semi,+             backup +           ])+    )+    $$+    semi++handleThm  failed = handle failed (text "dummyThm")+handleTerm failed = handle failed (text "dummyTerm")
+ tools/pg2hol/Prop2SVC.hs view
@@ -0,0 +1,351 @@++module Prop2SVC(prop2SVC) where++import Syntax+import SCC+import PrettyPrint+import HOLOps+++prop2SVC :: HsModuleR -> Doc+prop2SVC = module2HOL++module2HOL :: HsModuleR -> Doc+module2HOL (HsModule m Nothing imports infixes decls)+    = fsep [ vcat $ map import2HOL imports,+             vcat $ map infix2HOL infixes,+             vcat $ map hsDecl2HOL decls ]+--      where (dss, _) = bindingGroups decls+module2HOL (HsModule m (Just exports) imports infixes decls)+    = fsep [ vcat $ map export2HOL exports,+             vcat $ map import2HOL imports,+             vcat $ map infix2HOL infixes,+             vcat $ map hsDecl2HOL decls ]+--      where (dss, _) = bindingGroups decls++export2HOL _ = notsupported0 "export declaration"++import2HOL _ = notsupported0 "import declaration"++infix2HOL (HsInfixDecl loc fixity ops) = notsupported loc "infix declaration"++decls2HOL :: [HsDecl] -> Doc+decls2HOL [] = empty+decls2HOL ds =+    vcat $ (text "let" <+> dhol :+            map (\dhol -> text "and" <+> dhol) dhols)+    where (dhol:dhols) = map hsDecl2HOL ds++hsDecl2HOL :: HsDecl -> Doc+hsDecl2HOL (Dec (HsTypeDecl loc ((Typ (HsTyCon con)):params) t))          +    -- notsupported loc "type synonym declaration"+    = blankline $ from loc+      $$ (text "Hol_datatype" <+>+          (backQuotes $+           ppi con <+> equals <+> hsType2HOL [con] t))+      $$ handleThm (text "Type synonym" <+> ppi con)+hsDecl2HOL (Dec (HsNewTypeDecl loc c ((Typ (HsTyCon con)):params) t ders))+    -- notsupported loc "newtype declaration"+    = blankline $ from loc+      $$ (text "Hol_datatype" <+>+          (backQuotes $+           ppi con <+> equals <+> hsConDecl2HOL [con] t))+      $$ handleThm  (text "Newtype" <+> ppi con)+hsDecl2HOL (Dec (HsDataDecl loc c ((Typ (HsTyCon con)):params) summands ders))+    = blankline $ from loc+      $$ (text "Hol_datatype" <+>+          (backQuotes $+           ppi con <+> equals <+>+           foldr1 (\d d' -> d $$ char '|' <+> d')+                  (map (hsConDecl2HOL [con]) summands)))+      $$ handleThm  (text "Datatype" <+> ppi con)+hsDecl2HOL (Dec (HsTypeSig loc nms c t))  +    = notsupported loc "type signature declaration"+hsDecl2HOL (Dec (HsFunBind loc ms))+    = blankline $ from loc+      $$ (text "val" <+> ppi fun <> text "_def" <+> equals <+>+          text "Define" <+>+          (backQuotes $+           foldr1 (\d d' -> parens d <+> text "/\\"+                            $$ d')+                  (map hsMatch2HOL ms)))+      $$ handleThm  (text "Function" <+> ppi fun)+    where (HsMatch _ fun _ _ _):_ = ms+hsDecl2HOL (Dec (HsPatBind loc (Pat (HsPId (HsVar v))) rhs ds))+    = blankline $ from loc+      $$ (text "val" <+> ppi v <> text "_def" <+> equals <+>+          text "Define" <+>+          (backQuotes $+           funRhs2HOL loc (ppi v) rhs ds))+      $$ handleThm  (text "CAF" <+> ppi v)+hsDecl2HOL (Dec (HsPatBind loc p rhs ds))+    = notsupported loc "pattern binding"+hsDecl2HOL (Dec (HsClassDecl loc c tp ds))+    = notsupported loc "class declaration"+hsDecl2HOL (Dec (HsInstDecl loc c tp ds))+    = notsupported loc "instance declaration"+hsDecl2HOL (Dec (HsDefaultDecl loc t))+    = notsupported loc "default declaration"+hsDecl2HOL (Dec (HsPrimitiveTypeDecl loc cntxt nm))+    = notsupported loc "Hugs-style primitive type declaration"+hsDecl2HOL (Dec (HsPrimitiveBind loc nm t))+    = notsupported loc "Hugs-style primitive type declaration"+hsDecl2HOL (PropDec (HsProperty loc (ns @ (prop:_)) e))+    = blankline $ from loc+      $$ (holComment $ text "Property:" <+> pns)+      $$ fsep [ {-text "val prop_" <> pprop <+> equals,-}+                letNest $ {- parens $ backQuotes $ backQuotes $-} hsExp2HOL e ]+{-      $$ handleTerm (text "Property" <+> pprop)  -}+      where pns = sep $ map ppi ns+            pprop = ppi prop        +++hsConDecl2HOL :: [HsName] -> HsConDecl HsType  -> Doc +hsConDecl2HOL excl (HsConDecl loc con params)+    = hsName2HOL con <+> ps+      where ps = case params of+                 [] -> empty+                 xs -> text "of" <+>+                       (hsep $ punctuate (text " =>") $+                        map (hsType2HOL excl . hsBangType2Type) xs)+hsConDecl2HOL excl (HsRecDecl loc _ _)+    = notsupported loc "record declaration"++hsMatch2HOL (HsMatch loc fun ps rhs ds)+    = funRhs2HOL loc (wrap fun <+> (fsep $ map wrap ps)) rhs ds++funRhs2HOL loc lhs (HsBody e)   ds =+    fsep [ lhs <+> equals,+	   funNest $+           hsLet2HOL ds e ]+funRhs2HOL loc lhs (HsGuard gs) ds =+    -- should convert guards to ifs, but need to factor in other function+    -- branches, since a missing "otherwise" or "True" leaves us without an+    -- else branch.  This involves some of the patterm match compilation+    -- machinery.  This may be needed anyway, since it's not clear how complex+    -- case expressions can be.+    notsupported loc "guarded function/CAF definiton"++hsLet2HOL []     e = hsExp2HOL e+hsLet2HOL (d:ds) e = fsep [ text "let" <+> hsLetDecl2HOL d,+                            text "in" $$+                            (letNest $ hsLet2HOL ds e) ]+    +hsLetDecl2HOL (Dec (HsFunBind loc [m]))    =+    hsMatch2HOL m+hsLetDecl2HOL (Dec (HsFunBind loc ms))     =+    notsupported loc "function definitions with many cases in lets"+hsLetDecl2HOL (Dec (HsPatBind loc p rhs ds)) =+    funRhs2HOL loc (wrap p) rhs ds+hsLetDecl2HOL _                              =+    notsupported0 "non-function/pattern definitions in lets"+    +hsExp2HOL (Exp (HsId n))                 = hsIdent2HOL n+hsExp2HOL (Exp (HsLit l))                = ppi l+hsExp2HOL (Exp (HsInfixApp x (HsVar (UnQual "$")) y)) =+    fsep [ hsExp2HOL x, letNest $ parens $ hsExp2HOL y ]++hsExp2HOL (Exp (HsInfixApp x op y))      = hsInfixOp2SVC+                                               (hsOp2SVC op)+                                               (hsExp2HOL x)+                                               (letNest $ hsExp2HOL y)++hsExp2HOL (Exp (HsApp x y))              = +           (parens . fsep) [ hsExp2HOL x, letNest $ hsExp2HOL y ]+hsExp2HOL (Exp (HsNegApp x))             = char '-' <> hsExp2HOL x+hsExp2HOL (Exp (HsIf x y z)) = text "(ite" <+> hsExp2HOL x +			       $$ (letNest $ hsExp2HOL y)+			       $$ (letNest $ hsExp2HOL z) <+> text ")"+                                ++--- Above are definitely important, below maybe not.++hsExp2HOL (Exp (HsLambda ps e))          = fsep+                                           [ char '\\' <+>+					     sep (map (hsPat2HOL wrap) ps) <+>+				             char '.',+					     letNest $ hsExp2HOL e ]+hsExp2HOL (Exp (HsLet ds e))             = hsLet2HOL ds e+hsExp2HOL (Exp (HsCase e alts))          =+    text "case" <+> hsExp2HOL e <+> text "of"+    $$ (vcat $ (nest 2 halt) : map (char '|' <+>) talt)+    where (halt:talt) = map hsAlt2HOL alts+hsExp2HOL (Exp (HsDo stmts))             =+    notsupported0 "do notation"+hsExp2HOL (Exp (HsTuple xs))             = ppiFTuple xs+hsExp2HOL (Exp (HsList xs))              = ppiList xs+hsExp2HOL (Exp (HsParen e))              = parens $ hsExp2HOL e+hsExp2HOL (Exp (HsLeftSection x op))     =+    parens $+    fsep [ char '\\' <+> ppi y <+> char '.',+           hsInfixOp2HOL (hsOp2HOL op) (hsExp2HOL x) (ppi y) ]+    where y = hsEVar $ UnQual "_y" -- Must be replaced by unique name+hsExp2HOL (Exp (HsRightSection op y))    =+    parens $+    fsep [ char '\\' <+> ppi x <+> char '.',+           hsInfixOp2HOL (hsOp2HOL op) (ppi x) (hsExp2HOL y) ]+    where x = hsEVar $ UnQual "_x" -- Must be replaced by unique name+hsExp2HOL (Exp (HsRecConstr n []))       =+    notsupported0 "record construction"+hsExp2HOL (Exp (HsRecConstr n upds))     =+    notsupported0 "record construction"+hsExp2HOL (Exp (HsRecUpdate e []))       =+    notsupported0 "record update"+hsExp2HOL (Exp (HsRecUpdate e upds))     =+    notsupported0 "record update"+hsExp2HOL (Exp (HsEnumFrom x))           =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsEnumFromTo x y))       =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsEnumFromThen x y))     =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsEnumFromThenTo x y z)) =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsListComp stmts))       =+    notsupported0 "list comprehension"+hsExp2HOL (Exp (HsExpTypeSig s e t))     =+    notsupported0 "type signature"+hsExp2HOL (Exp (HsAsPat n p))            =+    error "hsExp2HOL: pattern exp in expression"+hsExp2HOL (Exp (HsWildCard))             =+    error "hsExp2HOL: pattern exp in expression"+hsExp2HOL (Exp (HsIrrPat p))             =+    error "hsExp2HOL: pattern exp in expression"+hsExp2HOL (PropExp (HsQuant q ps e))       =+    fsep [ hsQuantifier2HOL q <+>+           sep (map (hsPat2HOL wrap) ps) <+>+           char '.',+           letNest $ hsExp2HOL e ]++hsAlt2HOL (HsAlt loc p rhs ds) =+    fsep [ hsPat2HOL wrap p, text "=>", caseRhs2HOL loc rhs ds ]++caseRhs2HOL loc (HsBody e)   ds =+    hsLet2HOL ds e+caseRhs2HOL loc (HsGuard gs) ds =+    -- should convert guards to ifs, but need to factor in other function+    -- branches, since a missing "otherwise" or "True" leaves us without an+    -- else branch.  This involves some of the patterm match compilation+    -- machinery.  This may be needed anyway, since it's not clear how complex+    -- case expressions can be.+    notsupported loc "guarded pattern in case expression"++hsQuantifier2HOL HsPropForall        = char '!'+hsQuantifier2HOL HsPropExists        = char '?'+hsQuantifier2HOL HsPropForallDefined = char '!' <+>+                                       (holComment $ text "defined")+hsQuantifier2HOL HsPropExistsUnique  = text "?!"++hsPat2HOL :: (HsPat -> Doc) -> HsPat -> Doc+hsPat2HOL ppf (Pat (HsPId id))             = ppi id+hsPat2HOL ppf (Pat (HsPLit lit))           = ppi lit+hsPat2HOL ppf (Pat (HsPNeg p))             = notsupported0 "negation pattern"+hsPat2HOL ppf (Pat (HsPInfixApp p1 op p2)) = fsep [ ppi op, ppf p1, ppf p2 ]+hsPat2HOL ppf (Pat (HsPApp id ps))         = fsep (ppi id : map ppf ps)+hsPat2HOL ppf (Pat (HsPTuple ps))          = ppiTuple ps+hsPat2HOL ppf (Pat (HsPList ps))           = ppiList ps+hsPat2HOL ppf (Pat (HsPParen p))           = parens $ ppi p+hsPat2HOL ppf (Pat (HsPRec _ _))           = notsupported0 "record pattern"+hsPat2HOL ppf (Pat (HsPRecUpdate _ _))     = notsupported0 "record pattern"+hsPat2HOL ppf (Pat (HsPAsPat id p))        = parens $+                                             ppi id <+> text "as" <+> ppf p+hsPat2HOL ppf (Pat (HsPWildCard))          = text "_dummy"+hsPat2HOL ppf (Pat (HsPIrrPat p))          = ppf p+hsPat2HOL ppf (PropPat (HsPatTypeSig p t)) = ppf p++hsType2HOL :: [HsName] -> HsType -> Doc +hsType2HOL excl (Typ typ)+    = case typ of+        HsTyVar v     -> quote <> hsName2HOL v+        HsTyCon c     -> hsTyCon2HOL c+        HsTyApp (t1@(Typ (HsTyCon c))) t2+            | c `elem` excl -> hsType2HOL excl t1+        HsTyApp t1 t2 -> parens (hsType2HOL excl t2) <+> hsType2HOL excl t1+        HsTyTuple ts  -> hsep $ punctuate (text " #")+                              $ map (hsType2HOL excl) ts+        HsTyFun t1 t2 ->+            hsType2HOL excl t1 <+> text "->" <+> hsType2HOL excl t2++hsBangType2Type (HsBangedType t)   = t+hsBangType2Type (HsUnBangedType t) = t -- ignore strictness annotations++hsIdent2HOL :: HsIdent -> Doc+hsIdent2HOL = snd . hsOp2HOL++hsInfixOp2HOL (inf, op) x y | inf       = parens  (fsep [ x, op, y ])+                            | otherwise = curlies (fsep [ op, x, y ])++hsInfixOp2SVC (int, op) x y | int       = curlies (fsep [ op, x, y ])+                            | otherwise = parens  (fsep [ op, x, y ])++hsOp2SVC (HsCon (id @ (Qual _ n))) =+    case getSVCOp n of+    Just (int, holop) -> (int,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2SVC (HsCon (id @ (UnQual n))) =+    case getSVCOp n of+    Just (int, holop) -> (int,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2SVC (HsVar (id @ (Qual _ n))) =+    case getSVCOp n of+    Just (int, holop) -> (int,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2SVC (HsVar (id @ (UnQual n))) =+    case getSVCOp n of+    Just (int, holop) -> (int,   text holop)+    Nothing           -> (False, hsName2HOL id)++hsOp2HOL (HsCon (id @ (Qual _ n))) =+    case getSVCOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2HOL (HsCon (id @ (UnQual n))) =+    case getSVCOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2HOL (HsVar (id @ (Qual _ n))) =+    case getSVCOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2HOL (HsVar (id @ (UnQual n))) =+    case getSVCOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)++hsTyCon2HOL (id @ (Qual _ n)) =+    case getHOLTyCon n of+    Just holtycon -> text holtycon+    Nothing       -> hsName2HOL id+hsTyCon2HOL (id @ (UnQual n)) =+    case getHOLTyCon n of+    Just holtycon -> text holtycon+    Nothing       -> hsName2HOL id++hsName2HOL :: HsName -> Doc +hsName2HOL (UnQual n)        = text n +hsName2HOL (id @ (Qual _ n)) = text n <+> (holComment $ ppi id)++holComment d = text "(*" <+> d <+> text "*)"+from loc     = holComment $ text "From" <+> ppi loc <+> char ':'++notsupported loc msg+    = holComment $+      text "Not supported:" <+> text msg <+> text "from" <+> ppi loc+notsupported0 msg+    = holComment $ text "Not supported:" <+> text msg++handle failed backup =+    text "handle e =>" <+>+    (parens $+     (vcat [ text "print" <+>+             (doubleQuotes $ (failed <+> text "failed with exception"))+             <> semi,+             text "Exception.print_HOL_ERR e" <> semi,+             backup +           ])+    )+    $$+    semi++handleThm  failed = handle failed (text "dummyThm")+handleTerm failed = handle failed (text "dummyTerm")
+ tools/pg2hol/examples/Alg.hol view
@@ -0,0 +1,36 @@+(* Not supported: import declaration *)+(* Not supported: import declaration *)+(* Not supported: import declaration *)+(* From ../../examples/ChannelSeparation/Alg.hs:8,14 : *)+Hol_datatype `Alg = Addr -> RegFile -> Code`+handle e => (print "Type synonym Alg failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/Alg.hs:9,14 : *)+Hol_datatype `RegFile = Memory`+handle e => (print "Type synonym RegFile failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/Alg.hs:11,6 : *)+Hol_datatype `Code = Done of RegFile+		     | Read of Addr => Word -> Code+		       | Write of Addr => Word => Code`+handle e => (print "Datatype Code failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/Alg.hs:15,24 *)+(* From ../../examples/ChannelSeparation/Alg.hs:16,25 : *)+val runAlg_def = Define `(runAlg (Done regs) = return regs) /\+			 (runAlg (Read a cont) = (* Not supported: do notation *)) /\+			 runAlg (Write a v cont) = (* Not supported: do notation *)`+handle e => (print "Function runAlg failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ 
+ tools/pg2hol/examples/FM.hol view
@@ -0,0 +1,33 @@+(* From ../../examples/ChannelSeparation/FM.hs:4,25 : *)+Hol_datatype `FM = ('a # 'b) list`+handle e => (print "Type synonym FM failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/FM.hs:6,24 *)+(* From ../../examples/ChannelSeparation/FM.hs:7,25 : *)+val emptyFM_def = Define `emptyFM = []`+handle e => (print "CAF emptyFM failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/FM.hs:9,24 *)+(* From ../../examples/ChannelSeparation/FM.hs:10,25 : *)+val at_def = Define `at fm x =+			 head (* Not supported: list comprehension *)`+handle e => (print "Function at failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/FM.hs:12,24 *)+(* From ../../examples/ChannelSeparation/FM.hs:13,25 : *)+val extend_def = Define `(extend x fx [] = [(x, fx)]) /\+			 (* Not supported: guarded function/CAF definiton from ../../examples/ChannelSeparation/FM.hs:15,13 *)`+handle e => (print "Function extend failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ 
+ tools/pg2hol/examples/MemMonad.hol view
@@ -0,0 +1,31 @@+(* Not supported: import declaration *)+(* Not supported: import declaration *)+(* Not supported: import declaration *)+(* Not supported: class declaration from ../../examples/ChannelSeparation/MemMonad.hs:8,7 *)+(* Not supported: instance declaration from ../../examples/ChannelSeparation/MemMonad.hs:23,10 *)+(* Not supported: type signature declaration from ../../examples/ChannelSeparation/MemMonad.hs:27,15 *)+(* From ../../examples/ChannelSeparation/MemMonad.hs:28,16 : *)+val malloc_def = Define `malloc ws = ST (allocMem ws)`+handle e => (print "Function malloc failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/MemMonad.hs:30,15 *)+(* From ../../examples/ChannelSeparation/MemMonad.hs:31,16 : *)+val readPacket_def = Define `readPacket rng =+				 ST (\ s . (readRange rng s, s))`+handle e => (print "Function readPacket failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: instance declaration from ../../examples/ChannelSeparation/MemMonad.hs:35,10 *)+(* Not supported: type signature declaration from ../../examples/ChannelSeparation/MemMonad.hs:41,14 *)+(* From ../../examples/ChannelSeparation/MemMonad.hs:44,15 : *)+val runProtected_def = Define `runProtected = runStateE`+handle e => (print "CAF runProtected failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ 
+ tools/pg2hol/examples/Memory.hol view
@@ -0,0 +1,95 @@+(* Not supported: import declaration *)+(* From ../../examples/ChannelSeparation/Memory.hs:6,19 : *)+Hol_datatype `Addr = Word`+handle e => (print "Type synonym Addr failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/Memory.hs:7,19 : *)+Hol_datatype `Word = int`+handle e => (print "Type synonym Word failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/Memory.hs:8,19 : *)+Hol_datatype `Memory = Addr # Addr -> Word`+handle e => (print "Type synonym Memory failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/Memory.hs:9,19 : *)+Hol_datatype `Range = Addr # Addr`+handle e => (print "Type synonym Range failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/Memory.hs:11,18 *)+(* From ../../examples/ChannelSeparation/Memory.hs:12,19 : *)+val initMem_def = Define `initMem = (0, \ a -> 0)`+handle e => (print "CAF initMem failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/Memory.hs:14,18 *)+(* From ../../examples/ChannelSeparation/Memory.hs:15,19 : *)+val readMem_def = Define `readMem a m = snd m a`+handle e => (print "Function readMem failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/Memory.hs:17,18 *)+(* From ../../examples/ChannelSeparation/Memory.hs:19,19 : *)+val writeMem_def = Define `writeMem a w (free, mem) =+			       (free,+				\ a' ->+				    if a == a' then+					w+				    else+					mem a')`+handle e => (print "Function writeMem failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/Memory.hs:21,17 *)+(* From ../../examples/ChannelSeparation/Memory.hs:22,19 : *)+val readRange_def = Define `readRange (l, u) m =+				(* Not supported: list comprehension *)`+handle e => (print "Function readRange failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/Memory.hs:24,18 *)+(* From ../../examples/ChannelSeparation/Memory.hs:26,19 : *)+val allocMem_def = Define `allocMem ws (free, mem) =+			       let size = length ws+			       in  let lb = free+				   in  let ub = + free size+				       in  let rng = (lb, ub)+					   in  let mem' =+						       \ a .+							   if includes rng a then+							       !! ws (- a lb)+							   else+							       mem a+					       in  (rng, (ub, mem'))`+handle e => (print "Function allocMem failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/Memory.hs:35,18 *)+(* From ../../examples/ChannelSeparation/Memory.hs:36,19 : *)+val includes_def = Define `includes (l, u) a = < && <= l a a u`+handle e => (print "Function includes failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ 
+ tools/pg2hol/examples/NewChipModel.hol view
@@ -0,0 +1,242 @@+(* Not supported: import declaration *)+(* Not supported: import declaration *)+(* Not supported: import declaration *)+(* Not supported: import declaration *)+(* Not supported: import declaration *)+(* Not supported: import declaration *)+(* Not supported: import declaration *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:12,14 : *)+Hol_datatype `Channel = int`+handle e => (print "Type synonym Channel failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:13,14 : *)+Hol_datatype `Packet = Channel # Data`+handle e => (print "Type synonym Packet failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:14,14 : *)+Hol_datatype `Data = (Word) list`+handle e => (print "Type synonym Data failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:16,14 : *)+Hol_datatype `Algs = (Alg) (Channel) FM`+handle e => (print "Type synonym Algs failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:17,14 : *)+Hol_datatype `Regs = (RegFile) (Channel) FM`+handle e => (print "Type synonym Regs failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:19,13 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:21,2 : *)+val onePacket_def = Define `onePacket algs (chan, ws) =+				(* Not supported: do notation *)`+handle e => (print "Function onePacket failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:36,10 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:37,11 : *)+val maxChan_def = Define `maxChan = 8`+handle e => (print "CAF maxChan failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:39,10 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:40,11 : *)+val initRegs_def = Define `initRegs =+			       foldr (\ f . \ x . f x) emptyFM+				   (* Not supported: list comprehension *)`+handle e => (print "CAF initRegs failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:42,10 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:43,11 : *)+val chip_def = Define `chip algs =+			   catMaybes o loop (onePacket algs) (initMem, initRegs)`+handle e => (print "Function chip failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:60,6 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:61,6 : *)+val alg0_def = Define `alg0 =+			   \ a . \ rf . Write 0 99 (Done ((77, \ a -> undefined)))`+handle e => (print "CAF alg0 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:63,6 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:64,6 : *)+val alg1_def = Define `alg1 =+			   \ a . \ rf . Write a 101 (Done ((88, \ a -> undefined)))`+handle e => (print "CAF alg1 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:66,10 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:67,10 : *)+val programs_def = Define `programs =+			       extend 0 alg0 (extend 1 alg1 [])`+handle e => (print "CAF programs failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:69,7 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:70,7 : *)+val input_def = Define `input =+			    : (1, [1, 2, 3, 4]) (: (0, [5, 6]) [])`+handle e => (print "CAF input failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:72,8 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:73,8 : *)+val input'_def = Define `input' = (: (0, [5, 6]) [])`+handle e => (print "CAF input' failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:75,10 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:76,10 : *)+val onlyZero_def = Define `onlyZero = \ ch . ch = 0`+handle e => (print "CAF onlyZero failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:78,8 : *)+val before_def = Define `before =+			     \ algs . \ ch . \ ps . chip algs (filter (ch o fst) ps)`+handle e => (print "CAF before failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:80,7 : *)+val after_def = Define `after =+			    \ algs . \ ch . \ ps . filter (ch o fst) (chip algs ps)`+handle e => (print "CAF after failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:100,8 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:101,14 : *)+val towire_def = Define `towire p phi =+			     >>= phi \ outpackets . return (: p outpackets)`+handle e => (print "Function towire failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:103,8 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:106,16 : *)+val driver_def = Define `(driver proc [] = return []) /\+			 driver proc (p : ps) =+			     >>= proc p+				 \ resultpkt .+				     case resultpkt of+				       Just p' => towire p' (driver proc ps)+				     | Nothing => driver proc ps`+handle e => (print "Function driver failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:112,15 : *)+val initRegisters_def = Define `initRegisters =+				    inSnd (setState initRegs)`+handle e => (print "CAF initRegisters failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:113,12 : *)+val initShared_def = Define `initShared = inFst (setState initMem)`+handle e => (print "CAF initShared failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:115,7 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:116,17 : *)+val start_def = Define `start algs pkts =+			    let proc = onePacket algs+			    in  >> >> initRegisters initShared driver proc pkts`+handle e => (print "Function start failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:122,9 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:123,16 : *)+val channel_def = Define `channel i pkts =+			      filter (\ (x, y) . x = i) pkts`+handle e => (print "Function channel failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/NewChipModel.hs:125,7 *)+(* From ../../examples/ChannelSeparation/NewChipModel.hs:126,16 : *)+val reify_def = Define `reify (ST phi) =+			    fst (phi (undefined, undefined))`+handle e => (print "Function reify failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:131,11 : *)+val regmask_def = Define `regmask i =+			      inSnd+				  (>>= readState \ regs . setState (extend i (at regs i) emptyFM))`+handle e => (print "Function regmask failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:135,5 : *)+val bef_def = Define `bef =+			  \ algs . \ ps . \ i . reify (start algs (channel i ps))`+handle e => (print "CAF bef failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/NewChipModel.hs:137,5 : *)+val aft_def = Define `aft =+			  \ algs .+			      \ ps .+				  \ i .+				      reify+					  (>>= start algs ps+					       \ theta . >> regmask i return (channel i theta))`+handle e => (print "CAF aft failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ 
+ tools/pg2hol/examples/Prelude.hol view
@@ -0,0 +1,21 @@+load "bossLib";+open bossLib; +load "stringLib";+load "setLib";+load "integerTheory";+load "arithmeticTheory";+load "pairTools";+open pairTools;+load "simpLib";+open simpLib;+load "pairTheory";+open pairTheory;+load "listTheory";+open listTheory;++show_types := true;++val dummy_thm = CURRY_UNCURRY_THM;+val dummy_term = ``0``;++
+ tools/pg2hol/examples/State.hol view
@@ -0,0 +1,76 @@+(* From ../../examples/ChannelSeparation/State.hs:6,9 : *)+Hol_datatype `State = ST of 's -> 'a # 's`+handle e => (print "Newtype State failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: instance declaration from ../../examples/ChannelSeparation/State.hs:8,10 *)+(* Not supported: type signature declaration from ../../examples/ChannelSeparation/State.hs:14,16 *)+(* From ../../examples/ChannelSeparation/State.hs:15,17 : *)+val runState_def = Define `runState (ST c) = c`+handle e => (print "Function runState failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/State.hs:17,16 *)+(* From ../../examples/ChannelSeparation/State.hs:18,17 : *)+val readState_def = Define `readState = ST (\ s . (s, s))`+handle e => (print "CAF readState failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/State.hs:20,16 *)+(* From ../../examples/ChannelSeparation/State.hs:21,17 : *)+val setState_def = Define `setState s = ST (\ s' . ((), s))`+handle e => (print "Function setState failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/State.hs:23,16 *)+(* From ../../examples/ChannelSeparation/State.hs:24,17 : *)+val inFst_def = Define `inFst (ST c) =+			    ST (\ (s, s') . let (x, t') = c s in  (x, (t', s')))`+handle e => (print "Function inFst failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/State.hs:26,16 *)+(* From ../../examples/ChannelSeparation/State.hs:27,17 : *)+val inSnd_def = Define `inSnd (ST c) =+			    ST (\ (s', s) . let (x, t') = c s in  (x, (s', t')))`+handle e => (print "Function inSnd failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: type signature declaration from ../../examples/ChannelSeparation/State.hs:29,16 *)+(* From ../../examples/ChannelSeparation/State.hs:30,17 : *)+val loop_def = Define `(loop f s [] = []) /\+		       loop f s (p : ps) =+			   let (q, s') = runState (f p) s in  : q loop f s' ps`+handle e => (print "Function loop failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* From ../../examples/ChannelSeparation/State.hs:38,9 : *)+Hol_datatype `StateE = SE of 'e -> 's -> ('a) Maybe # 's`+handle e => (print "Newtype StateE failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ +(* Not supported: instance declaration from ../../examples/ChannelSeparation/State.hs:40,10 *)+(* Not supported: type signature declaration from ../../examples/ChannelSeparation/State.hs:48,19 *)+(* From ../../examples/ChannelSeparation/State.hs:49,20 : *)+val runStateE_def = Define `runStateE e (SE c) = ST (\ s . c e s)`+handle e => (print "Function runStateE failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyThm)+;+ 
+ tools/pg2hol/examples/TypeCheckedChipProof.hol view
@@ -0,0 +1,788 @@+(* Not supported: import declaration *)+(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:20,10 : *)+(* Property: SeparateChannels *)+val prop_SeparateChannels =+    (``! algs i packets .+	   (>>= start algs (channel i packets)+		\ opkt . >> regmask i return opkt)+	   =   (>>= start algs packets+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property SeparateChannels failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:77,10 : *)+(* Property: MLICS1 *)+val prop_MLICS1 =+    (``! algs i packets .+	   (>>= start algs (channel i packets)+		\ opkt . >> regmask i return opkt)+	   =   (>>=+		>> >> initRegisters initShared+		    driver (onePacket algs) (channel i packets)+		    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLICS1 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:88,10 : *)+(* Property: MLICS2 *)+val prop_MLICS2 =+    (``! algs i packets .+	   (>>= start algs (channel i packets)+		\ opkt . >> regmask i return opkt)+	   =   (>>=+		>> >> initRegisters initShared driver (onePacket algs) packets+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property MLICS2 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:96,10 : *)+(* Property: MLICS3 *)+val prop_MLICS3 =+    (``! algs i packets .+	   (>>= >> >> initRegisters initShared driver (onePacket algs) packets+		\ opkt . >> regmask i return (channel i opkt))+	   =   (>>= start algs packets+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property MLICS3 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:107,10 : *)+(* Property: MainLemma *)+val prop_MainLemma =+    (``! algs i pkts .+	   (>>= >> initShared driver (onePacket algs) (channel i pkts)+		\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared driver (onePacket algs) pkts+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property MainLemma failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:119,10 : *)+(* Property: MLproof1 *)+val prop_MLproof1 =+    (``! algs i .+	   (>>= >> initShared driver (onePacket algs) (channel i [])+		\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared driver (onePacket algs) []+		    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof1 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:125,10 : *)+(* Property: MLproof2 *)+val prop_MLproof2 =+    (``! algs i .+	   (>>= >> initShared driver (onePacket algs) []+		\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared driver (onePacket algs) (channel i [])+		    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof2 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:131,10 : *)+(* Property: MLproof3 *)+val prop_MLproof3 =+    (``! algs i .+	   (>>= >> initShared driver (onePacket algs) (channel i [])+		\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared driver (onePacket algs) (channel i [])+		    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof3 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:137,10 : *)+(* Property: MLproof4 *)+val prop_MLproof4 =+    (``! algs i .+	   (>>= >> initShared driver (onePacket algs) (channel i [])+		\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared driver (onePacket algs) []+		    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof4 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:148,10 : *)+(* Property: MLproof5 *)+val prop_MLproof5 =+    (``! algs i .+	   (>>= >> initShared driver (onePacket algs) []+		\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared driver (onePacket algs) []+		    \ opkt . >> regmask i return [])``)+handle e => (print "Property MLproof5 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:155,10 : *)+(* Property: MLproof6 *)+val prop_MLproof6 =+    (``! algs i .+	   (>>= >> initShared driver (onePacket algs) []+		\ opkt . >> regmask i return [])+	   =   (>>= >> initShared driver (onePacket algs) []+		    \ opkt . >> regmask i return (channel i []))``)+handle e => (print "Property MLproof6 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:164,10 : *)+(* Property: MLproof7 *)+val prop_MLproof7 =+    (``! algs i .+	   (>>= >> initShared driver (onePacket algs) []+		\ opkt . >> regmask i return (channel i []))+	   =   (>>= >> initShared driver (onePacket algs) []+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property MLproof7 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:177,10 : *)+(* Property: MLproof8 *)+val prop_MLproof8 =+    (``! algs i p ps .+	   (>>= >> initShared driver (onePacket algs) (channel i (: p ps))+		\ opkt . >> regmask i return opkt)+	   =   (>>=+		>> initShared+		    (>>= (onePacket algs) p+			 \ resultpkt .+			     case resultpkt of+			       Just p' => (towire p' (driver (onePacket algs) (channel i ps)))+			     | Nothing => driver (onePacket algs) (channel i ps))+		    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof8 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:192,10 : *)+(* Property: MLproof9 *)+val prop_MLproof9 =+    (``! algs i p ps .+	   (>>=+	    >> initShared+		(>>= (onePacket algs) p+		     \ resultpkt .+			 case resultpkt of+			   Just p' => (towire p' (driver (onePacket algs) (channel i ps)))+			 | Nothing => driver (onePacket algs) (channel i ps))+		\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared (onePacket algs) p+		    \ resultpkt .+			>>=+			(case resultpkt of+			   Just p' => towire p' (driver (onePacket algs) (channel i ps))+			 | Nothing => driver (onePacket algs) (channel i ps))+			    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof9 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:213,10 : *)+(* Property: MLproof10 *)+val prop_MLproof10 =+    (``! algs i p ps .+	   (>>= >> initShared (onePacket algs) p+		\ resultpkt .+		    >>=+		    (case resultpkt of+		       Just p' => towire p' (driver (onePacket algs) (channel i ps))+		     | Nothing => driver (onePacket algs) (channel i ps))+			\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared (onePacket algs) p+		    \ resultpkt .+			>>=+			>> initShared+			    (case resultpkt of+			       Just p' => towire p' (driver (onePacket algs) (channel i ps))+			     | Nothing => driver (onePacket algs) (channel i ps))+			    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof10 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:238,10 : *)+(* Property: MLproof11 *)+val prop_MLproof11 =+    (``! algs i p ps .+	   (>>= >> initShared (onePacket algs) p+		\ resultpkt .+		    >>=+		    >> initShared+			(case resultpkt of+			   Just p' => towire p' (driver (onePacket algs) (channel i ps))+			 | Nothing => driver (onePacket algs) (channel i ps))+			\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared (onePacket algs) p+		    \ resultpkt .+			>>=+			(case resultpkt of+			   Just p' =>+			   >> initShared towire p' (driver (onePacket algs) (channel i ps))+			 | Nothing => >> initShared driver (onePacket algs) (channel i ps))+			    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof11 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:264,10 : *)+(* Property: MLproof12 *)+val prop_MLproof12 =+    (``! algs i p ps .+	   (>>= >> initShared (onePacket algs) p+		\ resultpkt .+		    >>=+		    (case resultpkt of+		       Just p' =>+		       >> initShared towire p' (driver (onePacket algs) (channel i ps))+		     | Nothing => >> initShared driver (onePacket algs) (channel i ps))+			\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared (onePacket algs) p+		    \ resultpkt .+			>>=+			(case resultpkt of+			   Just p' =>+			   towire p' (>> initShared (driver (onePacket algs) (channel i ps)))+			 | Nothing => >> initShared driver (onePacket algs) (channel i ps))+			    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof12 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:292,10 : *)+(* Property: MLproof13 *)+val prop_MLproof13 =+    (``! algs i p ps .+	   (>>= >> initShared (onePacket algs) p+		\ resultpkt .+		    >>=+		    (case resultpkt of+		       Just p' =>+		       towire p' (>> initShared (driver (onePacket algs) (channel i ps)))+		     | Nothing => >> initShared driver (onePacket algs) (channel i ps))+			\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared (onePacket algs) p+		    \ resultpkt .+			(case resultpkt of+			   Just p' =>+			   >>=+			   (towire p'+				(>> initShared (driver (onePacket algs) (channel i ps))))+			       \ opkt . >> regmask i return opkt+			 | Nothing =>+			   >>= >> initShared driver (onePacket algs) (channel i ps)+			       \ opkt . >> regmask i return opkt))``)+handle e => (print "Property MLproof13 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:324,10 : *)+(* Property: MLproof14 *)+val prop_MLproof14 =+    (``! algs i p ps .+	   (>>= >> initShared (onePacket algs) p+		\ resultpkt .+		    (case resultpkt of+		       Just p' =>+		       >>=+		       (towire p'+			    (>> initShared (driver (onePacket algs) (channel i ps))))+			   \ opkt . >> regmask i return opkt+		     | Nothing =>+		       >>= >> initShared driver (onePacket algs) (channel i ps)+			   \ opkt . >> regmask i return opkt))+	   =   (>>= >> initShared (onePacket algs) p+		    \ resultpkt .+			(case resultpkt of+			   Just p' =>+			   towire p'+			       (>>= >> initShared driver (onePacket algs) (channel i ps)+				    \ opkt . >> regmask i return opkt)+			 | Nothing =>+			   >>= >> initShared driver (onePacket algs) (channel i ps)+			       \ opkt . >> regmask i return opkt))``)+handle e => (print "Property MLproof14 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:359,10 : *)+(* Property: MLproof15 *)+val prop_MLproof15 =+    (``! algs i p ps .+	   (>>= >> initShared (onePacket algs) p+		\ resultpkt .+		    (case resultpkt of+		       Just p' =>+		       towire p'+			   (>>= >> initShared driver (onePacket algs) (channel i ps)+				\ opkt . >> regmask i return opkt)+		     | Nothing =>+		       >>= >> initShared driver (onePacket algs) (channel i ps)+			   \ opkt . >> regmask i return opkt))+	   =   (>>= >> initShared (onePacket algs) p+		    \ resultpkt .+			(case resultpkt of+			   Just p' =>+			   towire p'+			       (>>= >> initShared driver (onePacket algs) ps+				    \ opkt . >> regmask i return (channel i opkt))+			 | Nothing =>+			   >>= >> initShared driver (onePacket algs) ps+			       \ opkt . >> regmask i return (channel i opkt)))``)+handle e => (print "Property MLproof15 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:395,10 : *)+(* Property: MLproof16 *)+val prop_MLproof16 =+    (``! algs i p ps .+	   (>>= >> initShared (onePacket algs) p+		\ resultpkt .+		    (case resultpkt of+		       Just p' =>+		       towire p'+			   (>>= >> initShared driver (onePacket algs) ps+				\ opkt . >> regmask i return (channel i opkt))+		     | Nothing =>+		       >>= >> initShared driver (onePacket algs) ps+			   \ opkt . >> regmask i return (channel i opkt)))+	   =   (>>= >> initShared driver (onePacket algs) (: p ps)+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property MLproof16 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:427,10 : *)+(* Property: MLproof17 *)+val prop_MLproof17 =+    (``! algs i p ps .+	   (>>= >> initShared driver (onePacket algs) (: p ps)+		\ opkt . >> regmask i return (channel i opkt))+	   =   (>>=+		>> initShared+		    (>>= ((onePacket algs) p)+			 \ res .+			     (case res of+				Just p' => towire p' (driver (onePacket algs) ps)+			      | Nothing => driver (onePacket algs) ps))+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property MLproof17 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:447,10 : *)+(* Property: MLproof18 *)+val prop_MLproof18 =+    (``! algs i p ps .+	   (>>=+	    >> initShared+		(>>= ((onePacket algs) p)+		     \ res .+			 (case res of+			    Just p' => towire p' (driver (onePacket algs) ps)+			  | Nothing => driver (onePacket algs) ps))+		\ opkt . >> regmask i return (channel i opkt))+	   =   (>>= >> initShared ((onePacket algs) p)+		    \ res .+			(case res of+			   Just p' =>+			   >>= towire p' (driver (onePacket algs) ps)+			       \ opkt . >> regmask i return (channel i opkt)+			 | Nothing =>+			   >>= driver (onePacket algs) ps+			       \ opkt . >> regmask i return (channel i opkt)))``)+handle e => (print "Property MLproof18 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:474,10 : *)+(* Property: MLproof19 *)+val prop_MLproof19 =+    (``! algs i p ps .+	   (>>= >> initShared ((onePacket algs) p)+		\ res .+		    (case res of+		       Just p' =>+		       >>= towire p' (driver (onePacket algs) ps)+			   \ opkt . >> regmask i return (channel i opkt)+		     | Nothing =>+		       >>= driver (onePacket algs) ps+			   \ opkt . >> regmask i return (channel i opkt)))+	   =   (>>= >> initShared ((onePacket algs) p)+		    \ res .+			(case res of+			   Just p' =>+			   >>= (driver (onePacket algs) ps)+			       \ opkt . >> regmask i return (channel i opkt)+			 | Nothing =>+			   >>= driver (onePacket algs) ps+			       \ opkt . >> regmask i return (channel i opkt)))``)+handle e => (print "Property MLproof19 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:502,10 : *)+(* Property: MLproof20 *)+val prop_MLproof20 =+    (``! algs i p ps .+	   (>>= >> initShared ((onePacket algs) p)+		\ res .+		    (case res of+		       Just p' =>+		       >>= (driver (onePacket algs) ps)+			   \ opkt . >> regmask i return (channel i opkt)+		     | Nothing =>+		       >>= driver (onePacket algs) ps+			   \ opkt . >> regmask i return (channel i opkt)))+	   =   (>>=+		>> initShared+		    (>>= (onePacket algs) p+			 \ res .+			     case res of+			       Just p' => driver (onePacket algs) ps+			     | Nothing => driver (onePacket algs) ps)+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property MLproof20 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:528,10 : *)+(* Property: MLproof21 *)+val prop_MLproof21 =+    (``! algs i p ps .+	   (>>=+	    >> initShared+		(>>= (onePacket algs) p+		     \ res .+			 case res of+			   Just p' => driver (onePacket algs) ps+			 | Nothing => driver (onePacket algs) ps)+		\ opkt . >> regmask i return (channel i opkt))+	   =   (>>= >> initShared driver (onePacket algs) ps+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property MLproof21 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:546,10 : *)+(* Property: MLproof22 *)+val prop_MLproof22 =+    (``! algs i p ps .+	   (>>= >> initShared driver (onePacket algs) ps+		\ opkt . >> regmask i return (channel i opkt))+	   =   (>>= >> initShared driver (onePacket algs) (channel i ps)+		    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof22 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:558,10 : *)+(* Property: MLproof23 *)+val prop_MLproof23 =+    (``! algs i p ps .+	   (>>= >> initShared driver (onePacket algs) (channel i ps)+		\ opkt . >> regmask i return opkt)+	   =   (>>= >> initShared driver (onePacket algs) (channel i (: p ps))+		    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property MLproof23 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:577,10 : *)+(* Property: Lemma1 *)+val prop_Lemma1 =+    (``! algs p .+	   (>> initShared onePacket algs p) =+	       (>>= >> initShared onePacket algs p+		    \ opkt . >> initShared return opkt)``)+handle e => (print "Property Lemma1 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:588,10 : *)+(* Property: Lemma2 *)+val prop_Lemma2 =+    (``! x p .+	   (>> initShared towire p x) = (towire p (>> initShared x))``)+handle e => (print "Property Lemma2 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:596,10 : *)+(* Property: Lemma2_proof1 *)+val prop_Lemma2_proof1 =+    (``! x p .+	   (>> initShared towire p x) =+	       (>>= >> initShared x \ opkts . return (: p opkts))``)+handle e => (print "Property Lemma2_proof1 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:602,10 : *)+(* Property: Lemma2_proof2 *)+val prop_Lemma2_proof2 =+    (``! x p .+	   (>>= >> initShared x \ opkts . return (: p opkts)) =+	       (>>= (>> initShared x) \ opkts . return (: p opkts))``)+handle e => (print "Property Lemma2_proof2 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:608,10 : *)+(* Property: Lemma2_proof3 *)+val prop_Lemma2_proof3 =+    (``! x p .+	   (>>= (>> initShared x) \ opkts . return (: p opkts)) =+	       (towire p (>> initShared x))``)+handle e => (print "Property Lemma2_proof3 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:617,10 : *)+(* Property: Lemma3 *)+val prop_Lemma3 =+    (``! x p i .+	   (>>= (towire p x) \ opkt . >> regmask i return opkt) =+	       (towire p (>>= x \ opkt . >> regmask i return opkt))``)+handle e => (print "Property Lemma3 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:628,10 : *)+(* Property: Lemma3_proof1 *)+val prop_Lemma3_proof1 =+    (``! x p i .+	   (>>= (towire p x) \ opkt . >> regmask i return opkt) =+	       (>>= (>>= x \ theta . return (: p theta))+		    \ opkt . >> regmask i return opkt)``)+handle e => (print "Property Lemma3_proof1 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:636,10 : *)+(* Property: Lemma3_proof2 *)+val prop_Lemma3_proof2 =+    (``! x p i .+	   (>>= (>>= x \ theta . return (: p theta))+		\ opkt . >> regmask i return opkt)+	   =   (>>= x+		    \ theta .+			>>= return (: p theta) \ opkt . >> regmask i return opkt)``)+handle e => (print "Property Lemma3_proof2 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:645,10 : *)+(* Property: Lemma3_proof3 *)+val prop_Lemma3_proof3 =+    (``! x p i .+	   (>>= x+		\ theta . >>= return (: p theta) \ opkt . >> regmask i return opkt)+	   = (>>= x \ theta . >> regmask i return (: p theta))``)+handle e => (print "Property Lemma3_proof3 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:653,10 : *)+(* Property: Lemma3_proof4 *)+val prop_Lemma3_proof4 =+    (``! x p i .+	   (>>= x \ theta . >> regmask i return (: p theta)) =+	       (>>= (>>= x \ theta . >> regmask i return (theta))+		    \ opkt . return (: p opkt))``)+handle e => (print "Property Lemma3_proof4 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:661,10 : *)+(* Property: Lemma3_proof5 *)+val prop_Lemma3_proof5 =+    (``! x p i .+	   (>>= (>>= x \ theta . >> regmask i return (theta))+		\ opkt . return (: p opkt))+	   = (towire p (>>= x \ opkt . >> regmask i return opkt))``)+handle e => (print "Property Lemma3_proof5 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:672,10 : *)+(* Property: Lemma4 *)+val prop_Lemma4 =+    (``! phi ws i j .+	   ((=/= i j) ==>+		(>>= towire (j, ws) phi+		     \ opkt . >> regmask i return (channel i opkt))+	    = (>>= phi \ opkt . >> regmask i return (channel i opkt)))``)+handle e => (print "Property Lemma4 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:684,10 : *)+(* Property: Lemma4_proof1 *)+val prop_Lemma4_proof1 =+    (``! phi ws i j .+	   (>>= towire (j, ws) phi+		\ opkt . >> regmask i return (channel i opkt))+	   =   (>>= (>>= phi \ out . return (: (j, ws) out))+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property Lemma4_proof1 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:693,10 : *)+(* Property: Lemma4_proof2 *)+val prop_Lemma4_proof2 =+    (``! phi ws i j .+	   (>>= (>>= phi \ out . return (: (j, ws) out))+		\ opkt . >> regmask i return (channel i opkt))+	   =   (>>= phi+		    \ out .+			>>= return (: (j, ws) out)+			    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property Lemma4_proof2 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:703,10 : *)+(* Property: Lemma4_proof3 *)+val prop_Lemma4_proof3 =+    (``! phi ws i j .+	   (>>= phi+		\ out .+		    >>= return (: (j, ws) out)+			\ opkt . >> regmask i return (channel i opkt))+	   =   (>>= phi+		    \ out .+			>>= return (: (j, ws) out)+			    \ opkt . >> regmask i return (channel i (: (j, ws) out)))``)+handle e => (print "Property Lemma4_proof3 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:713,10 : *)+(* Property: Lemma4_proof4 *)+val prop_Lemma4_proof4 =+    (``! phi ws i j .+	   (>>= phi+		\ out .+		    >>= return (: (j, ws) out)+			\ opkt . >> regmask i return (channel i (: (j, ws) out)))+	   =   (>>= phi+		    \ out .+			>>= return (: (j, ws) out)+			    \ opkt . >> regmask i return (channel i out))``)+handle e => (print "Property Lemma4_proof4 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:728,10 : *)+(* Property: Lemma4_proof5 *)+val prop_Lemma4_proof5 =+    (``! phi ws i j .+	   (>>= phi+		\ out .+		    >>= return (: (j, ws) out)+			\ opkt . >> regmask i return (channel i out))+	   =   (>>= phi+		    \ out .+			>>= return (out) \ opkt . >> regmask i return (channel i out))``)+handle e => (print "Property Lemma4_proof5 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:739,10 : *)+(* Property: Lemma4_proof6 *)+val prop_Lemma4_proof6 =+    (``! phi ws i j .+	   (>>= phi+		\ out .+		    >>= return (out) \ opkt . >> regmask i return (channel i out))+	   =   (>>= phi+		    \ out .+			>>= return (out) \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property Lemma4_proof6 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:752,10 : *)+(* Property: Lemma4_proof7 *)+val prop_Lemma4_proof7 =+    (``! phi ws i j .+	   (>>= phi+		\ out .+		    >>= return (out) \ opkt . >> regmask i return (channel i opkt))+	   =   (>>= (>>= phi \ out . return (out))+		    \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property Lemma4_proof7 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ +(* From ../../examples/ChannelSeparation/TypeCheckedChipProof.hs:766,10 : *)+(* Property: Lemma4_proof8 *)+val prop_Lemma4_proof8 =+    (``! phi ws i j .+	   (>>= (>>= phi \ out . return (out))+		\ opkt . >> regmask i return (channel i opkt))+	   = (>>= phi \ opkt . >> regmask i return (channel i opkt))``)+handle e => (print "Property Lemma4_proof8 failed with exception";+	     Exception.print_HOL_ERR e;+	     dummyTerm)+;+ 
+ tools/pg2hol/foo.hs view
@@ -0,0 +1,39 @@++property Foo1 +    =   1 + 2 === 3++property Foo2+    =   True ||| False++property Foo3+    =   not False++property Foo4+    =   (f x === 0) ||| not (f x === 0)+++{-+(or+ (/= z (f {+ x {* -1 y}}))+ (/= x {+ z y})+ (= y {+ x {* -1 (f (f z))}})+)+-}++property Foo5 +    =   (not (z === f (x + (-1 * y))))+  |||   (not (x === (z + y)))+  |||   (y === (x + (-1 * (f (f z)))))+++{-+(ite+ (and+  (= (f (f (f (f (f x))))) x)+  (= (f (f (f x))) x)+ )+ (= (f x) x)+ true+)+-}+
+ tools/pg2hol/myhugs view
@@ -0,0 +1,2 @@+#!/bin/bash+hugs -98 -P{Hugs}/lib:{Hugs}/lib/hugs:{Hugs}/lib/exts:.:..:../base/AST:../base/TC:../base/parse:../property/AST:../property/command:../property/parse/extras:../base/pretty:../base/SA:../property/syntax -h4M
+ tools/pg2svc/Main.hs view
@@ -0,0 +1,183 @@++module Main (main) where+++import IO+import Lexer+import ParseMonad+import PropParser+import ParseUtil+import Syntax+import PrettyPrint+import System+import GetOpt+import IOExts+import List+import Rewrite(rewriteDec)+import HsAssoc(initEnv, OperatorEnv)+import Prop2SVC(prop2SVC)+++data Flag = LexOnlyLength          -- print number of tokens only+          | LexOnlyRev             -- print tokens in reverse order+          | LexOnly                -- print tokens+          | ParseLength            -- print number of declarations only+          | ParseInternal          -- print abstract syntax in internal format+          | ParsePretty PPLayout   -- pretty print in this style+          | ToHOL                  -- produces naive HOL version+          | TestStatic             -- test static checker+          | TestTypeCheck+          | ShowNames+          | Help                   -- give short usage info++usage = "usage: prop2hol [option] [filename]"++options =+   [ Option ['n']  ["numtokens"] (NoArg LexOnlyLength)+         "print number of tokens only",+     Option ['r']  ["revtokens"] (NoArg LexOnlyRev)+         "print tokens in reverse order",+     Option ['t']  ["tokens"]    (NoArg LexOnly)+         "print tokens",+     Option ['d']  ["numdecls"]  (NoArg ParseLength)+         "print number of declarations only",+     Option ['a']  ["abstract"]  (NoArg ParseInternal)+         "print abstract syntax in internal format",+     Option ['p']  ["pretty"]    (OptArg style "STYLE")+         "pretty print in STYLE[(o)ffside|(s)emicolon|(u)trecht|(i)nline|\+                    \(n)one] (default = offside)",+     Option ['h','?'] ["help"]   (NoArg Help)+         "display this help and exit",+     Option ['s'] ["static"] (NoArg TestStatic) +         "run stattic checker",+     Option ['c'] ["typecheck"] (NoArg TestTypeCheck) "run typechecker",+     Option ['m'] ["names"]     (NoArg ShowNames)      "show all defined names"+   ]++style :: Maybe String -> Flag+style Nothing  = ToHOL+style (Just s) = ParsePretty $+         case s of+         "o"         -> PPOffsideRule+         "offside"   -> PPOffsideRule+         "s"         -> PPSemiColon+         "semicolon" -> PPSemiColon+         "u"         -> PPUtrecht+         "utrecht  " -> PPUtrecht+         "i"         -> PPInLine+         "inline"    -> PPInLine+         "n"         -> PPNoLayout+         "none"      -> PPNoLayout+         _           -> PPOffsideRule++main :: IO ()+main = do cmdline <- getArgs+          mainHugs cmdline++toSVC = mainHugs ["foo.hs"]++mainHugs :: [String] -> IO ()+mainHugs cmdline =+   case getOpt Permute options cmdline of+      (flags, args, [])    ->+       do (file, inp) <- case args of+			 []  -> do inp <- getContents+				   return ("stdio", inp)+			 [f] -> do inp <- readFile f+				   return (f, inp)+			 _   -> error usage+          putStrLn (handleFlag (getFlag flags) file inp)+      (    _,   _, errors) ->+        error (concat errors ++ usageInfo usage options)++getFlag :: [Flag] -> Flag+getFlag []  = ToHOL+getFlag [f] = f+getFlag _   = error usage++handleFlag :: Flag -> FilePath -> String -> String+handleFlag LexOnlyLength    f = show . numToks . testLexerRev f+handleFlag LexOnlyRev       f = show . testLexerRev f+handleFlag LexOnly          f = show . testLexer f+handleFlag ShowNames        f = +    error "Main.handleFlag: name extraction not implemented yet."+-- show . getAllNames . testParser f+handleFlag ParseLength      f = show . allLengths . testParser f+   where allLengths (HsModule _ _ imp inf d) =+            length imp + length inf + length d+handleFlag ParseInternal    f = show . testParser f+handleFlag ToHOL            f = render . testProp2HOL f+handleFlag TestStatic       f =+    error "Main.handleFlag: static analysis test not implemented yet."+{-+handleFlag TestStatic       f = \s -> +    unsafePerformIO $ +    do { r <- testStatic $ testParser f s ;+         return "Done static checking." }+-}+handleFlag TestTypeCheck    f =+    error "Main.handleFlag: type check test not implemented yet."+{-+handleFlag TestTypeCheck    f = \s -> +    unsafePerformIO $ +    do  { let { m = testParser f s } ;+          r <- testStatic m ;+          print $ (typeCheckDecls . (\ (HsModule _ _ _ _ ds) -> ds)) m;+          return "Done static checking." }+-}+handleFlag (ParsePretty lo) f+    = renderWithMode mode . ppi . testParser f+      where mode = defaultMode { layoutType = lo }+handleFlag Help             f          +    = const $+      usageInfo+          ("A simple test program for *The Haskell Parser*" ++ usage)+      options++numToks :: ParseResult OperatorEnv [Token] -> Int+numToks (Ok _ toks)  = length toks+numToks (Failed err) = error ("Huh? " ++ err)++testLexerRev :: FilePath -> String -> ParseResult OperatorEnv [Token]+testLexerRev f s =+    (unPM $ loop []) s (SrcLoc f 1 0) 1 (error "Initial environment", []) +    where loop toks =+	      lexer (\t -> case t of +                           EOF -> returnPM toks+                           _   -> loop (t:toks))++testLexer :: FilePath -> String -> ParseResult OperatorEnv [Token]+testLexer f s = (unPM $ loop []) s  (SrcLoc f 1 0) 1 (initEnv, [])+  where loop toks =+         lexer (\t -> case t of +              EOF -> returnPM (reverse toks) -- space leak?+              _   -> loop (t:toks))++testParser :: FilePath -> String -> HsModuleR+testParser f s =+    case (unPM parse) s  (SrcLoc f 1 1) 0 (initEnv, []) of+    Ok state (HsModule m ex im inf decls) ->+	(HsModule m ex im inf (map (rewriteDec initEnv) decls))+    Failed err -> error err++testProp2HOL f s = prop2SVC $ testParser f s++------------------------------------------------------------------------------+-- tests+--++n = UnQual +loc = SrcLoc "MyFile" 1 1++t1 :: HsDecl+t1 = hsDataDecl loc []+        {-data-} [hsTyCon $ n "List", hsTyVar $ n "a"]+        [ HsConDecl loc (n "Nil") []+        , HsConDecl loc (n "Cons")+            [ HsUnBangedType (hsTyVar $ n "a")+            , HsUnBangedType (hsTyApp (hsTyCon $ n "List") (hsTyVar $n "a"))+            ]+        ]+        {-deriving-} []++----------------------------------------------------------------------------
+ tools/pg2svc/Prop2SVC.hs view
@@ -0,0 +1,351 @@++module Prop2SVC(prop2SVC) where++import Syntax+import SCC+import PrettyPrint+import SVCOps+++prop2SVC :: HsModuleR -> Doc+prop2SVC = module2HOL++module2HOL :: HsModuleR -> Doc+module2HOL (HsModule m Nothing imports infixes decls)+    = fsep [ vcat $ map import2HOL imports,+             vcat $ map infix2HOL infixes,+             vcat $ map hsDecl2HOL decls ]+--      where (dss, _) = bindingGroups decls+module2HOL (HsModule m (Just exports) imports infixes decls)+    = fsep [ vcat $ map export2HOL exports,+             vcat $ map import2HOL imports,+             vcat $ map infix2HOL infixes,+             vcat $ map hsDecl2HOL decls ]+--      where (dss, _) = bindingGroups decls++export2HOL _ = notsupported0 "export declaration"++import2HOL _ = notsupported0 "import declaration"++infix2HOL (HsInfixDecl loc fixity ops) = notsupported loc "infix declaration"++decls2HOL :: [HsDecl] -> Doc+decls2HOL [] = empty+decls2HOL ds =+    vcat $ (text "let" <+> dhol :+            map (\dhol -> text "and" <+> dhol) dhols)+    where (dhol:dhols) = map hsDecl2HOL ds++hsDecl2HOL :: HsDecl -> Doc+hsDecl2HOL (Dec (HsTypeDecl loc ((Typ (HsTyCon con)):params) t))          +    -- notsupported loc "type synonym declaration"+    = blankline $ from loc+      $$ (text "Hol_datatype" <+>+          (backQuotes $+           ppi con <+> equals <+> hsType2HOL [con] t))+      $$ handleThm (text "Type synonym" <+> ppi con)+hsDecl2HOL (Dec (HsNewTypeDecl loc c ((Typ (HsTyCon con)):params) t ders))+    -- notsupported loc "newtype declaration"+    = blankline $ from loc+      $$ (text "Hol_datatype" <+>+          (backQuotes $+           ppi con <+> equals <+> hsConDecl2HOL [con] t))+      $$ handleThm  (text "Newtype" <+> ppi con)+hsDecl2HOL (Dec (HsDataDecl loc c ((Typ (HsTyCon con)):params) summands ders))+    = blankline $ from loc+      $$ (text "Hol_datatype" <+>+          (backQuotes $+           ppi con <+> equals <+>+           foldr1 (\d d' -> d $$ char '|' <+> d')+                  (map (hsConDecl2HOL [con]) summands)))+      $$ handleThm  (text "Datatype" <+> ppi con)+hsDecl2HOL (Dec (HsTypeSig loc nms c t))  +    = notsupported loc "type signature declaration"+hsDecl2HOL (Dec (HsFunBind loc ms))+    = blankline $ from loc+      $$ (text "val" <+> ppi fun <> text "_def" <+> equals <+>+          text "Define" <+>+          (backQuotes $+           foldr1 (\d d' -> parens d <+> text "/\\"+                            $$ d')+                  (map hsMatch2HOL ms)))+      $$ handleThm  (text "Function" <+> ppi fun)+    where (HsMatch _ fun _ _ _):_ = ms+hsDecl2HOL (Dec (HsPatBind loc (Pat (HsPId (HsVar v))) rhs ds))+    = blankline $ from loc+      $$ (text "val" <+> ppi v <> text "_def" <+> equals <+>+          text "Define" <+>+          (backQuotes $+           funRhs2HOL loc (ppi v) rhs ds))+      $$ handleThm  (text "CAF" <+> ppi v)+hsDecl2HOL (Dec (HsPatBind loc p rhs ds))+    = notsupported loc "pattern binding"+hsDecl2HOL (Dec (HsClassDecl loc c tp ds))+    = notsupported loc "class declaration"+hsDecl2HOL (Dec (HsInstDecl loc c tp ds))+    = notsupported loc "instance declaration"+hsDecl2HOL (Dec (HsDefaultDecl loc t))+    = notsupported loc "default declaration"+hsDecl2HOL (Dec (HsPrimitiveTypeDecl loc cntxt nm))+    = notsupported loc "Hugs-style primitive type declaration"+hsDecl2HOL (Dec (HsPrimitiveBind loc nm t))+    = notsupported loc "Hugs-style primitive type declaration"+hsDecl2HOL (PropDec (HsProperty loc (ns @ (prop:_)) e))+    = blankline $ from loc+      $$ (holComment $ text "Property:" <+> pns)+      $$ fsep [ {-text "val prop_" <> pprop <+> equals,-}+                letNest $ {- parens $ backQuotes $ backQuotes $-} hsExp2HOL e ]+{-      $$ handleTerm (text "Property" <+> pprop)  -}+      where pns = sep $ map ppi ns+            pprop = ppi prop        +++hsConDecl2HOL :: [HsName] -> HsConDecl HsType  -> Doc +hsConDecl2HOL excl (HsConDecl loc con params)+    = hsName2HOL con <+> ps+      where ps = case params of+                 [] -> empty+                 xs -> text "of" <+>+                       (hsep $ punctuate (text " =>") $+                        map (hsType2HOL excl . hsBangType2Type) xs)+hsConDecl2HOL excl (HsRecDecl loc _ _)+    = notsupported loc "record declaration"++hsMatch2HOL (HsMatch loc fun ps rhs ds)+    = funRhs2HOL loc (wrap fun <+> (fsep $ map wrap ps)) rhs ds++funRhs2HOL loc lhs (HsBody e)   ds =+    fsep [ lhs <+> equals,+	   funNest $+           hsLet2HOL ds e ]+funRhs2HOL loc lhs (HsGuard gs) ds =+    -- should convert guards to ifs, but need to factor in other function+    -- branches, since a missing "otherwise" or "True" leaves us without an+    -- else branch.  This involves some of the patterm match compilation+    -- machinery.  This may be needed anyway, since it's not clear how complex+    -- case expressions can be.+    notsupported loc "guarded function/CAF definiton"++hsLet2HOL []     e = hsExp2HOL e+hsLet2HOL (d:ds) e = fsep [ text "let" <+> hsLetDecl2HOL d,+                            text "in" $$+                            (letNest $ hsLet2HOL ds e) ]+    +hsLetDecl2HOL (Dec (HsFunBind loc [m]))    =+    hsMatch2HOL m+hsLetDecl2HOL (Dec (HsFunBind loc ms))     =+    notsupported loc "function definitions with many cases in lets"+hsLetDecl2HOL (Dec (HsPatBind loc p rhs ds)) =+    funRhs2HOL loc (wrap p) rhs ds+hsLetDecl2HOL _                              =+    notsupported0 "non-function/pattern definitions in lets"+    +hsExp2HOL (Exp (HsId n))                 = hsIdent2HOL n+hsExp2HOL (Exp (HsLit l))                = ppi l+hsExp2HOL (Exp (HsInfixApp x (HsVar (UnQual "$")) y)) =+    fsep [ hsExp2HOL x, letNest $ parens $ hsExp2HOL y ]++hsExp2HOL (Exp (HsInfixApp x op y))      = hsInfixOp2SVC+                                               (hsOp2SVC op)+                                               (hsExp2HOL x)+                                               (letNest $ hsExp2HOL y)++hsExp2HOL (Exp (HsApp x y))              = +           (parens . fsep) [ hsExp2HOL x, letNest $ hsExp2HOL y ]+hsExp2HOL (Exp (HsNegApp x))             = char '-' <> hsExp2HOL x+hsExp2HOL (Exp (HsIf x y z)) = text "(ite" <+> hsExp2HOL x +			       $$ (letNest $ hsExp2HOL y)+			       $$ (letNest $ hsExp2HOL z) <+> text ")"+                                ++--- Above are definitely important, below maybe not.++hsExp2HOL (Exp (HsLambda ps e))          = fsep+                                           [ char '\\' <+>+					     sep (map (hsPat2HOL wrap) ps) <+>+				             char '.',+					     letNest $ hsExp2HOL e ]+hsExp2HOL (Exp (HsLet ds e))             = hsLet2HOL ds e+hsExp2HOL (Exp (HsCase e alts))          =+    text "case" <+> hsExp2HOL e <+> text "of"+    $$ (vcat $ (nest 2 halt) : map (char '|' <+>) talt)+    where (halt:talt) = map hsAlt2HOL alts+hsExp2HOL (Exp (HsDo stmts))             =+    notsupported0 "do notation"+hsExp2HOL (Exp (HsTuple xs))             = ppiFTuple xs+hsExp2HOL (Exp (HsList xs))              = ppiList xs+hsExp2HOL (Exp (HsParen e))              = parens $ hsExp2HOL e+hsExp2HOL (Exp (HsLeftSection x op))     =+    parens $+    fsep [ char '\\' <+> ppi y <+> char '.',+           hsInfixOp2HOL (hsOp2HOL op) (hsExp2HOL x) (ppi y) ]+    where y = hsEVar $ UnQual "_y" -- Must be replaced by unique name+hsExp2HOL (Exp (HsRightSection op y))    =+    parens $+    fsep [ char '\\' <+> ppi x <+> char '.',+           hsInfixOp2HOL (hsOp2HOL op) (ppi x) (hsExp2HOL y) ]+    where x = hsEVar $ UnQual "_x" -- Must be replaced by unique name+hsExp2HOL (Exp (HsRecConstr n []))       =+    notsupported0 "record construction"+hsExp2HOL (Exp (HsRecConstr n upds))     =+    notsupported0 "record construction"+hsExp2HOL (Exp (HsRecUpdate e []))       =+    notsupported0 "record update"+hsExp2HOL (Exp (HsRecUpdate e upds))     =+    notsupported0 "record update"+hsExp2HOL (Exp (HsEnumFrom x))           =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsEnumFromTo x y))       =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsEnumFromThen x y))     =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsEnumFromThenTo x y z)) =+    notsupported0 "numeric enumeration"+hsExp2HOL (Exp (HsListComp stmts))       =+    notsupported0 "list comprehension"+hsExp2HOL (Exp (HsExpTypeSig s e t))     =+    notsupported0 "type signature"+hsExp2HOL (Exp (HsAsPat n p))            =+    error "hsExp2HOL: pattern exp in expression"+hsExp2HOL (Exp (HsWildCard))             =+    error "hsExp2HOL: pattern exp in expression"+hsExp2HOL (Exp (HsIrrPat p))             =+    error "hsExp2HOL: pattern exp in expression"+hsExp2HOL (PropExp (HsQuant q ps e))       =+    fsep [ hsQuantifier2HOL q <+>+           sep (map (hsPat2HOL wrap) ps) <+>+           char '.',+           letNest $ hsExp2HOL e ]++hsAlt2HOL (HsAlt loc p rhs ds) =+    fsep [ hsPat2HOL wrap p, text "=>", caseRhs2HOL loc rhs ds ]++caseRhs2HOL loc (HsBody e)   ds =+    hsLet2HOL ds e+caseRhs2HOL loc (HsGuard gs) ds =+    -- should convert guards to ifs, but need to factor in other function+    -- branches, since a missing "otherwise" or "True" leaves us without an+    -- else branch.  This involves some of the patterm match compilation+    -- machinery.  This may be needed anyway, since it's not clear how complex+    -- case expressions can be.+    notsupported loc "guarded pattern in case expression"++hsQuantifier2HOL HsPropForall        = char '!'+hsQuantifier2HOL HsPropExists        = char '?'+hsQuantifier2HOL HsPropForallDefined = char '!' <+>+                                       (holComment $ text "defined")+hsQuantifier2HOL HsPropExistsUnique  = text "?!"++hsPat2HOL :: (HsPat -> Doc) -> HsPat -> Doc+hsPat2HOL ppf (Pat (HsPId id))             = ppi id+hsPat2HOL ppf (Pat (HsPLit lit))           = ppi lit+hsPat2HOL ppf (Pat (HsPNeg p))             = notsupported0 "negation pattern"+hsPat2HOL ppf (Pat (HsPInfixApp p1 op p2)) = fsep [ ppi op, ppf p1, ppf p2 ]+hsPat2HOL ppf (Pat (HsPApp id ps))         = fsep (ppi id : map ppf ps)+hsPat2HOL ppf (Pat (HsPTuple ps))          = ppiTuple ps+hsPat2HOL ppf (Pat (HsPList ps))           = ppiList ps+hsPat2HOL ppf (Pat (HsPParen p))           = parens $ ppi p+hsPat2HOL ppf (Pat (HsPRec _ _))           = notsupported0 "record pattern"+hsPat2HOL ppf (Pat (HsPRecUpdate _ _))     = notsupported0 "record pattern"+hsPat2HOL ppf (Pat (HsPAsPat id p))        = parens $+                                             ppi id <+> text "as" <+> ppf p+hsPat2HOL ppf (Pat (HsPWildCard))          = text "_dummy"+hsPat2HOL ppf (Pat (HsPIrrPat p))          = ppf p+hsPat2HOL ppf (PropPat (HsPatTypeSig p t)) = ppf p++hsType2HOL :: [HsName] -> HsType -> Doc +hsType2HOL excl (Typ typ)+    = case typ of+        HsTyVar v     -> quote <> hsName2HOL v+        HsTyCon c     -> hsTyCon2HOL c+        HsTyApp (t1@(Typ (HsTyCon c))) t2+            | c `elem` excl -> hsType2HOL excl t1+        HsTyApp t1 t2 -> parens (hsType2HOL excl t2) <+> hsType2HOL excl t1+        HsTyTuple ts  -> hsep $ punctuate (text " #")+                              $ map (hsType2HOL excl) ts+        HsTyFun t1 t2 ->+            hsType2HOL excl t1 <+> text "->" <+> hsType2HOL excl t2++hsBangType2Type (HsBangedType t)   = t+hsBangType2Type (HsUnBangedType t) = t -- ignore strictness annotations++hsIdent2HOL :: HsIdent -> Doc+hsIdent2HOL = snd . hsOp2HOL++hsInfixOp2HOL (inf, op) x y | inf       = parens  (fsep [ x, op, y ])+                            | otherwise = curlies (fsep [ op, x, y ])++hsInfixOp2SVC (int, op) x y | int       = curlies (fsep [ op, x, y ])+                            | otherwise = parens  (fsep [ op, x, y ])++hsOp2SVC (HsCon (id @ (Qual _ n))) =+    case getSVCOp n of+    Just (int, holop) -> (int,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2SVC (HsCon (id @ (UnQual n))) =+    case getSVCOp n of+    Just (int, holop) -> (int,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2SVC (HsVar (id @ (Qual _ n))) =+    case getSVCOp n of+    Just (int, holop) -> (int,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2SVC (HsVar (id @ (UnQual n))) =+    case getSVCOp n of+    Just (int, holop) -> (int,   text holop)+    Nothing           -> (False, hsName2HOL id)++hsOp2HOL (HsCon (id @ (Qual _ n))) =+    case getSVCOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2HOL (HsCon (id @ (UnQual n))) =+    case getSVCOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2HOL (HsVar (id @ (Qual _ n))) =+    case getSVCOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)+hsOp2HOL (HsVar (id @ (UnQual n))) =+    case getSVCOp n of+    Just (inf, holop) -> (inf,   text holop)+    Nothing           -> (False, hsName2HOL id)++hsTyCon2HOL (id @ (Qual _ n)) =+    case getHOLTyCon n of+    Just holtycon -> text holtycon+    Nothing       -> hsName2HOL id+hsTyCon2HOL (id @ (UnQual n)) =+    case getHOLTyCon n of+    Just holtycon -> text holtycon+    Nothing       -> hsName2HOL id++hsName2HOL :: HsName -> Doc +hsName2HOL (UnQual n)        = text n +hsName2HOL (id @ (Qual _ n)) = text n <+> (holComment $ ppi id)++holComment d = text "(*" <+> d <+> text "*)"+from loc     = holComment $ text "From" <+> ppi loc <+> char ':'++notsupported loc msg+    = holComment $+      text "Not supported:" <+> text msg <+> text "from" <+> ppi loc+notsupported0 msg+    = holComment $ text "Not supported:" <+> text msg++handle failed backup =+    text "handle e =>" <+>+    (parens $+     (vcat [ text "print" <+>+             (doubleQuotes $ (failed <+> text "failed with exception"))+             <> semi,+             text "Exception.print_HOL_ERR e" <> semi,+             backup +           ])+    )+    $$+    semi++handleThm  failed = handle failed (text "dummyThm")+handleTerm failed = handle failed (text "dummyTerm")
+ tools/pg2svc/SVCOps.hs view
@@ -0,0 +1,32 @@+-- $Id: SVCOps.hs,v 1.1 2001/07/19 22:36:04 wlh Exp $++module SVCOps (getHOLTyCon, getSVCOp) where++--- Now the first bit in "(tf, string)" means: is it an+--- *interpreted* function symbol? N.b., all operators are+--- prefix in SVC.+svcOps = [ ("True",  (True, "true")),+           ("False", (True, "false")),+           ("+",     (True, "+")), +           ("*",     (True, "*")), +           ("not",   (False, "not")),+           ("&&&",   (False, "and")),+           ("|||",   (False, "or")),+           ("==>",   (False, "=>")),+	   ("===",   (False, "="))+         ]++-- lookup n db = filter ((== n) . fst) db++getSVCOp :: String -> Maybe (Bool, String)+getSVCOp n = lookup n svcOps++--- Probably not needed for SVC:+getHOLTyCon :: String -> Maybe String+getHOLTyCon con = lookup con holTyCons++holTyCons = [ ("[]",  "list"),+              ("()",  "unit"),+              ("Int", "int"),+              ("Nat", "num")+            ]
+ tools/property/AST/HsPropMaps.hs view
@@ -0,0 +1,138 @@+module HsPropMaps where+import HsPropStruct+import HsIdent++import AccList+import MUtils+import Products((><))++--- Maps -----------------------------------------------------------------------++mapPD :: (i1->i2) -> (pa1->pa2) -> (pp1->pp2) -> PD i1 pa1 pp1 -> PD i2 pa2 pp2+mapPD idf paf ppf pd =+  case pd of+    HsPropDecl s n ns p ->HsPropDecl s (idf n) (map (mapHsIdent idf) ns) (ppf p)+    HsAssertion s optn a->HsAssertion s (idf # optn) (paf a)++mapPP idf = mapPP2 idf idf++mapPP2 :: (i1->i2)->(i1->i2)->(e1->e2)->(p1->p2)+          ->(t1->t2)->(pa1->pa2)->(pp1->pp2)+          -> PP i1 e1 p1 t1 pa1 pp1 -> PP i2 e2 p2 t2 pa2 pp2+mapPP2 vf cf ef pf tf paf m pp =+  case pp of+--  PredId i -> PredId (cf i)+    PredApp i ts ps -> PredApp (cf i) (map tf ts) (map (mapEither ef m) ps)+    PredArrow p1 p2 -> PredArrow (m p1) (m p2)+    PredInfixApp p1 i p2 -> PredInfixApp (m p1) (cf i) (m p2)+    PredNeg optt p -> PredNeg (tf # optt) (m p)+    PredOp op optt p1 p2 -> PredOp op (tf # optt) (m p1) (m p2)+    PredLfp i optt p -> PredLfp (cf i) (tf # optt) (m p)+    PredGfp i optt p -> PredGfp (cf i) (tf # optt) (m p)+    PredNil -> PredNil+    PredLifted e -> PredLifted (ef e)+    PredStrong p -> PredStrong (m p)+    PredParen p -> PredParen (m p)+    PredComp pts a -> PredComp (map (pf><fmap tf) pts) (paf a)++mapPA idf = mapPA2 idf idf++mapPA2 :: (i1->i2)->(i1->i2)->(e1->e2)->(t1->t2)->(pa1->pa2)->(pp1->pp2)+           -> PA i1 e1 t1 pa1 pp1 -> PA i2 e2 t2 pa2 pp2+mapPA2 vf cf ef tf m ppf pa =+    case pa of+      Quant q i optt pa -> Quant q (vf i) (tf # optt) (m pa)+--    PropId i -> PropId (cf i)+      PropApp i ts ps -> PropApp (cf i) (map tf ts) (map (mapEither ef ppf) ps)+      PropNeg a -> PropNeg (m a)+      PropOp op a1 a2 -> PropOp op (m a1) (m a2)+      PropEqual e1 e2 -> PropEqual (ef e1) (ef e2)+      PropHas e p -> PropHas (ef e) (ppf p)+      PropParen a -> PropParen (m a)+--    PropLambda i a -> PropLambda (vf i) (m a)+--    PropLet i optt e a -> PropLet (vf i) (tf # optt) (ef e) (m a)++--- Accumulators ---------------------------------------------------------------++type Acc i b = i->b->b++accPD :: Acc i b->Acc pa b->Acc pp b->Acc (PD i pa pp) b+accPD idf paf ppf pd =+  case pd of+    HsPropDecl s n ns p  -> idf n . accList (accHsIdent idf) ns . ppf p+    HsAssertion s optn a -> maybe id idf optn . paf a++accPP :: Acc i b->Acc e b->Acc p b->Acc t b->Acc pa b->Acc pp b->Acc (PP i e p t pa pp) b+accPP idf ef pf tf paf ppf pp =+  case pp of+--  PredId i -> idf i+    PredApp i ts as -> idf i . accList tf ts . accList (either ef ppf) as+    PredArrow pp1 pp2 -> ppf pp1 . ppf pp2+    PredInfixApp pp1 i pp2 -> ppf pp1 . idf i . ppf pp2+    PredNeg optt p -> maybe id tf optt . ppf p+    PredOp op optt p1 p2 -> maybe id tf optt . ppf p1 . ppf p2+    PredLfp i optt pp -> idf i . maybe id tf optt . ppf pp+    PredGfp i optt pp -> idf i . maybe id tf optt . ppf pp+    PredNil -> id+    PredLifted e -> ef e+    PredStrong pp -> ppf pp+    PredComp pts pa -> accList accComp pts . paf pa+    PredParen pp  -> ppf pp+  where+    accComp (p,optt) = pf p . maybe id tf optt++accPA :: Acc i b->Acc e b->Acc t b->Acc pa b->Acc pp b->Acc (PA i e t pa pp) b+accPA idf ef tf paf ppf pa =+    case pa of+      Quant q i optt pa -> idf i . maybe id tf optt . paf pa+--    PropId i -> idf i+      PropApp i ts es -> idf i . accList tf ts . accList (either ef ppf) es+      PropNeg a -> paf a+      PropOp op a1 a2 -> paf a1 . paf a2+      PropEqual e1 e2 -> ef e1 . ef e2+      PropHas e p -> ef e . ppf p+      PropParen a -> paf a+--    PropLambda i a -> idf i . paf a+--    PropLet i optt e a -> idf i . maybe id tf optt . ef e . paf a++--- Sequencers -----------------------------------------------------------------++seqPD :: (Functor m,Monad m) => PD (m i) (m pa) (m pp) -> m (PD i pa pp)+seqPD pd =+  case pd of+    HsPropDecl  s n ns p -> HsPropDecl s # n <# mapM seqHsIdent ns <# p+    HsAssertion s optn a -> HsAssertion s # seqMaybe optn  <# a++seqPP :: (Functor m,Monad m) => PP (m i) (m e) (m p) (m t) (m pa) (m pp)+          -> m (PP i e p t pa pp)+seqPP pp =+  case pp of+--  PredId i -> PredId # i+    PredApp i ts ps -> PredApp # i <# sequence ts <# mapM seqEither ps+    PredArrow p1 p2 -> PredArrow # p1 <# p2+    PredInfixApp p1 i p2 -> PredInfixApp # p1 <# i <# p2+    PredNeg optt p -> PredNeg # seqMaybe optt <# p+    PredOp op optt p1 p2 -> PredOp op # seqMaybe optt <# p1 <# p2+    PredLfp i optt p -> PredLfp # i <# seqMaybe optt <# p+    PredGfp i optt p -> PredGfp # i <# seqMaybe optt <# p+    PredNil -> return PredNil+    PredLifted e -> PredLifted # e+    PredStrong p -> PredStrong # p+    PredParen p -> PredParen # p+    PredComp pts a -> PredComp # mapM spts pts <# a+      where spts (mp,optmt) = (,) # mp <# seqMaybe optmt++seqPA :: (Functor m,Monad m) => PA (m i) (m e) (m t) (m pa) (m pp)+         -> m (PA i e t pa pp)+seqPA pa =+  case pa of+    Quant q i optt pa -> Quant q # i <# seqMaybe optt <# pa+--  PropId i -> PropId # i+    PropApp i ts ps -> PropApp # i <# sequence ts <# mapM seqEither ps+    PropNeg a -> PropNeg # a+    PropOp op a1 a2 -> PropOp op # a1 <# a2+    PropEqual e1 e2 -> PropEqual # e1 <# e2+    PropHas e p -> PropHas # e <# p+    PropParen a -> PropParen # a+--  PropLambda i a -> PropLambda # i <# a+--  PropLet i optt e a -> PropLet # i <# seqMaybe optt <# e <# a
+ tools/property/AST/HsPropPretty.hs view
@@ -0,0 +1,83 @@+module HsPropPretty where+import HsPropStruct+import PrettyPrint+import PrettySymbols as S+import HsIdentPretty()++--delta = kwIfUnicode '\x0394' "$"+delta = "$"++instance Printable Quantifier where+  ppi All = S.all+  ppi Exist = exist++instance (Printable i,Printable pa,Printable pp) => Printable (PD i pa pp) where+  wrap = ppi+  ppi pd =+    case pd of+      HsPropDecl s n ns p -> sep [kw "property" <+> n <+> fsep ns <+> equals,+				  funNest p]+      HsAssertion s optn a -> sep [kw "assert" <+> maybe empty (<+>equals) optn,+                                   funNest a]++instance (Printable i,Printable e,Printable t,Printable pa,Printable pp)+       => Printable (PA i e t pa pp) where+  wrap pa =+    case pa of+      PropApp i _ [] -> wrap i+      PropParen p -> parens p+      _ -> parens pa++  ppi pa =+    case pa of+      Quant q i optt pa -> sep [q <+> i <+> ppOptType optt <+> kw ".", ppi pa]+      --PropId i -> ppi i+      PropApp i ts [] -> wrap i+      PropApp i ts ps -> wrap i <+> fsep (map ppPredArg ps)+      PropNeg a -> S.not <+> a		   +      PropOp op a1 a2 -> ppiBinOp (wrap a1) (ppOp op) (wrap a2)+      PropEqual e1 e2 -> ppiBinOp (braces e1) (kw "===") (braces e2)+      PropHas e p -> ppiBinOp (braces e) (kw ":::") (ppi p)+      PropParen p -> parens p+--    PropLambda i pa -> lambda<+>i<+>rarrow<+>pa+--    PropLet i optt e pa -> sep ["let"<+>i<+>ppOptType optt<+>"="<+>e,+--				  "in"<+>pa]++instance Printable PropOp where ppi = ppOp++ppOp op =+  ppi $ case op of+	  Conj  -> S.and+	  Disj  -> S.or+	  Imp   -> implies+	  Equiv -> equiv++instance (PrintableOp i,Printable e,Printable p,Printable t,Printable pa,Printable pp)+       => Printable (PP i e p t pa pp) where+  wrap pp =+    case pp of+      PredApp i _ [] -> wrap i+      PredNil -> kw "[]"+      PredLifted e -> kw "!"<>braces e+      PredStrong p -> delta<>wrap p+      PredParen p -> parens p+      PredComp pts a -> kw "{|"<+>ppiFSeq (map ppts pts)<+>kw "|"<+>a<+>kw "|}"+        where ppts (p,optt) = p<+>ppOptType optt+      _ -> parens pp++  ppi pp =+    case pp of+      PredApp i ts [] -> wrap i+      PredApp i ts ps -> wrap i <+> fsep (ppPredArgs ps)+      PredArrow p1 p2 -> ppiBinOp (wrap p1) rarrow (wrap p2)+      PredInfixApp p1 i p2 -> ppiBinOp (wrap p1) (ppiOp i) (wrap p2)+      PredNeg optt p -> S.not <+> p+      PredOp op optt p1 p2 -> ppiBinOp (wrap p1) (ppOp op) (wrap p2)+      PredLfp i optt p -> mu <+> i <+> ppOptType optt <+> kw "." <+> p+      PredGfp i optt p -> nu <+> i <+> ppOptType optt <+> kw "." <+> p+      _ -> wrap pp++ppPredArgs as = map ppPredArg as+ppPredArg a = either braces wrap a++ppOptType x = maybe empty (el<+>) x
+ tools/property/AST/HsPropStruct.hs view
@@ -0,0 +1,62 @@+module HsPropStruct where++import HsIdent(HsIdentI)+import SrcLoc++-------- Properties --------------------------------------------------------++data Quantifier = All | Exist deriving (Eq, Show)++-- Although we do not expect to extend these, so we don't tie the recursive+-- knots immmediately, to be consistent with the programming style used for+-- the base syntax.++-- Declarations extensions:+data PD i pa pp+  = HsAssertion SrcLoc (Maybe i) pa+  | HsPropDecl SrcLoc i [HsIdentI i] pp+  deriving (Eq, Show)++data PropOp = Conj | Disj | Imp | Equiv deriving (Eq,Show)++-- Property assertions:+data PA i e t pa pp+  = Quant Quantifier i (Maybe t) pa+--  | PropId i -- just a special case of PropApp+  | PropApp i [t] [PredArg e pp] -- type arguments are added by the type checker+  | PropNeg pa+  | PropOp PropOp pa pa+  | PropEqual e e+  | PropHas e pp+  | PropParen pa -- preserve parens to rewrite infix apps after parsing+  -- Extra, primarily for the dictionary translation:+--  | PropLambda i pa+--  | PropLet i (Maybe t) e pa+  deriving (Eq,Show)++type PredArg e pp = Either e pp++-- Predicate formulas:+data PP i e p t pa pp+--  = PredId i -- just a special case of PredApp+  = PredApp i [t] [PredArg e pp] -- type arguments are added by the type checker+  | PredArrow pp pp+  | PredInfixApp pp i pp+  | PredNeg (Maybe t) pp+  | PredOp PropOp (Maybe t) pp pp+  | PredLfp i (Maybe t) pp+  | PredGfp i (Maybe t) pp+  | PredNil+  | PredLifted e+  | PredStrong pp+  | PredComp [(p,Maybe t)] pa+  | PredParen pp -- preserve parens to rewrite infix apps after parsing+  deriving (Eq,Show)++++--- Source locations -----------------------------------------------------------++instance HasSrcLoc (PD i e t) where+   srcLoc (HsAssertion s _ _)   = s+   srcLoc (HsPropDecl  s _ _ _) = s
+ tools/property/Flags.ghc view
@@ -0,0 +1,1 @@+PPfeCmds.hs: -fno-monomorphism-restriction
+ tools/property/HEADER.html view
@@ -0,0 +1,15 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<head>+<title>Programatica Tools, tools/property</title>+<link rel=parent href="../" title="Programatica Tools">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="../web/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="../web/src.css" title="Normal">+<link rel=icon type="image/gif" href="../web/icon1.png">+</head>+<base>+<h1><img align=right src="../web/icon1.png" alt="">Programatica Tools</h1>++<h2>Directory tools/property</h2>++The README file is displayed below the directory index.
+ tools/property/HuMakefile view
@@ -0,0 +1,21 @@++BASE=${BASE-../base}+PFE_DIR=${PFE_DIR-../pfe}+PROP=${PROP-.}+P=$PROP++. $PFE_DIR/HuMakefile++NEW_PPARSE_DIRS=$P/parse2:$P/parse2/Parser+PPARSE_DIRS=$NEW_PPARSE_DIRS++PDIRS=$P/pfe:$P/syntax:$P/AST:$P/TI:$P/defs:$P/transforms:$P/command+HS2HTML_DIR=${HS2HTML_DIR-$P/../hs2html}+#PHUGS_DIRS=$P/../Phugs+STRATEGO=${STRATEGO-$P/../hs2stratego}+STRATEGO_DIRS=$STRATEGO:$STRATEGO/AST+ISABELLE=${ISABELLE-$P/../hs2isabelle}+ISABELLE_DIRS=$ISABELLE:$ISABELLE/AST++PPFE_DIRS=$P:$MODSRC_DIRS:$B:$PPARSE_DIRS:$PDIRS:$PFE_DIR:$HS2HTML_DIR:$STRATEGO_DIRS:$ISABELLE_DIRS+SRC_DIRS=$PPFE_DIRS
+ tools/property/Main.hs view
@@ -0,0 +1,62 @@+-- $Id: Main.hs,v 1.14 2001/10/10 23:36:06 hallgren Exp $++-- Currently a test harness for the lexer/parser/pretty printer.++--ToDo: Are initial values for SrcLoc/current column correct?++module Main (main) where+++import IO+import Lexer+import ParseMonad+import PropParser+import ParseUtil+import Syntax+import PrettyPrint+import System+import GetOpt+import IOExts+import List+import Rewrite(rewriteModule)+import HsAssocInitEnv(initEnv)+import CommandLine+import Compile+import Monad+import MUtils(( # ))++main :: IO ()+main = case commandLine of+         (flags, args, [])    ->+           do (file, inp) <- case args of+			     []  -> do inp <- getContents+				       return ("stdio", inp)+			     [f] -> do inp <- readFile f+				       return (f, inp)+			     _   -> error $ usageInfo usage options+              case handleFlag (getFlag flags) file inp of+                Good output          -> putStrLn output+                CompileError message ->+                    error $ "Compilation had errors:\n\n" ++ message+         (    _,   _, errors) ->+             error $ concat errors ++ usageInfo usage options+++handleFlag :: Flag -> FilePath -> String -> Compile String+handleFlag ParseInternal f s    = liftM show $ parseModule f s+handleFlag (ParsePretty lo) f s = liftM (renderWithMode+                                            defaultMode { layoutType = lo } .+                                         ppi)+                                  (parseModule f s)+handleFlag ToHaskell f s        = liftM pp $ parseModule f s+handleFlag StaticAnalysis f s   = compileError+                                  "progc: static analysis not yet implemented"+handleFlag TypeCheck f s        = compileError+                                  "progc: type checking not yet implemented"+handleFlag Help f s             = return $+                                  usageInfo ("The Programatica Compiler\n" +++                                             usage)+                                  options++parseModule :: FilePath -> String -> Compile HsModuleR+parseModule f s =  rewriteModule initEnv # parseFile parse f s
+ tools/property/Makefile view
@@ -0,0 +1,43 @@+TARGETS=ppfe++### Optimization and other compiler options:+#OPT=+#OPT=-O2+OPT=-O+HFLAGS=++### Tools:+RM=rm -f+HMAKE=sh ../scripts/hsmake.sh++################################################################################+### Rules for compiling the programs++all: $(TARGETS)++ppfe:: propparser+	@sh ../scripts/updateNow.sh ../pfe/Now.hs+	$(HMAKE) $(OPT) $(HFLAGS) ppfe -o ppfe++propparser::+	@$(MAKE) -C parse2++################################################################################+### Rules for generating HTML (using previously installed pfe)++hi/srclist.txt:+	@$(MAKE) propparser+	PFE_LIBS=../base/tests pfesetup noplogic cpp ppfe.hs++html:: hi/srclist.txt+	-[ -d hi/html ] && cd hi/html && gunzip *.gz+	pfe noplogic htmlfiles+	cd hi/html && gzip -9 *.html++################################################################################+### Rules for cleaning up++clean:+	@$(MAKE) -C parse2 clean+	$(RM) -r $(TARGETS) hi+	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'
+ tools/property/Makefile.ghc-4.08 view
@@ -0,0 +1,120 @@+# $Id: Makefile.ghc-4.08,v 1.4 2001/04/28 01:02:19 moran Exp $++HC = ghc-4.08+HC_LOCAL_LIB = ${HOME}/lib+BASE = ../base+HC_INC = ${BASE}/parse ${BASE}/pretty ${BASE}/AST ${BASE}/SA ${BASE}/TC \+         ${BASE}/lib ${HC_LOCAL_LIB} \+         parse parse/util parse/token syntax rewrite AST .++HC_DEP = ${HC} -M+HC_INCI = ${addprefix -i,${HC_INC}}+HC_PKGI = ${addprefix -package,${HC_PKG}}+HC_LIBI = ${addprefix -l,${HC_LIBS}}+HC_OPTS = ${$*_HC_OPTS} ${HC_XOPTS} ${HC_INCI} ${HC_PKGI}               \+        -recomp -fwarn-incomplete-patterns -H55M                        \+        -fglasgow-exts -fmax-simplifier-iterations5                     \+        -package lang -package concurrent #-Wall ++DEP_OPTS = ${HC_INCI}+HC_LDOPTS = ${HC_OPTS} ${addprefix -L,${HC_INC}} ${HC_LIBI}++HAPPY = happy+HAPPYFLAGS = # --ghc makes parser unusable for Hugs+RUNTIMEFLAGS = # +RTS -H75M+PRINTER = lj12+ENSCRIPT = enscript++RM = rm -f++HAPPYSRC = PropParser.y+AST_COMMON_SRC = ${BASE}/AST/SrcLoc.hs ${BASE}/AST/HsLiteral.hs          \+        ${BASE}/AST/HsName.hs ${BASE}/AST/HsModule.hs                    \+        ${BASE}/AST/HsGuards.hs ${BASE}/AST/HsExpStruct.hs               \  +        ${BASE}/AST/HsPatStruct.hs ${BASE}/AST/HsDeclStruct.hs           \+        ${BASE}/AST/HsTypeStruct.hs ${BASE}/AST/HsAssoc.hs               \+        ${BASE}/AST/ListUtil.hs ${BASE}/AST/HsConstants.hs               \+        ${BASE}/BaseSyntaxStruct.hs +PP_SRC = ${BASE}/pretty/PrettyPrint.hs ${BASE}/pretty/Pretty.lhs         \+        ${BASE}/pretty/PrettyM.hs ${BASE}/pretty/PrettyUtil.hs +SYNTAX_SRC = syntax/Syntax.hs syntax/SyntaxStruct.hs syntax/SyntaxRec.hs \+        syntax/SyntaxUtil.hs syntax/Rewrite.hs syntax/PropSyntaxUtil.hs+PROP_AST_SRC = AST/HsPropStruct.hs+PARSE_SRC = ${BASE}/parse/Lexer.hs ${BASE}/parse/LexUtil.hs              \+        ${BASE}/parse/ParseMonad.lhs parse/util/ParseUtil.hs             \+        parse/token/Token.hs+SA_SRC = ${BASE}/SA/Scope.hs ${BASE}/SA/Scope2.hs                        \+        ${BASE}/SA/SCC.hs+TC_SRC = ${BASE}/TC/InferenceMonad.hs ${BASE}/TC/TypeGenerics.hs         \+        ${BASE}/TC/TypeCheck.hs ${BASE}/TC/TypeCheckTest.hs              \+        ${BASE}/TC/Components.hs+OBS_SRC = ${HC_LOCAL_LIB}/Observe.lhs+OPT_SRC = ${BASE}/lib/GetOpt.hs +HC_SRC = ${AST_COMMON_SRC} ${PP_SRC} ${SYNTAX_SRC} ${PARSE_SRC}          \+        ${PROP_AST_SRC}                                                  \+        $(HAPPYSRC:.y=.hs) ${OPT_SRC} Main.hs++HC_INT1 = $(HC_SRC:.hs=.hi)   # no way to get rid of this?+HC_INT = $(HC_INT1:.lhs=.hi)+HC_OBJ = $(HC_INT:.hi=.o)++MAIN = propparse++# trick  :-)+ifeq (.depend,$(wildcard .depend))+all: $(MAIN)+include .depend+else+all: depend $(MAIN)+endif++%.hs: %.y+	$(HAPPY) $(HAPPYFLAGS) $< --info $(RUNTIMEFLAGS)++%.o : %.lhs+	${HC} ${HC_OPTS} -c $< -o $@++%.o : %.hs+	${HC} ${HC_OPTS} -c $< -o $@++%.hi : %.o+	@if [ ! -f $@ ] ; then \+	    echo Panic! $< exists, but $@ does not. \+	    exit 1; \+	else exit 0; \+	fi                                                      ++%.ps : %.hs+	${ENSCRIPT} -1 -o $@ -G $<++%.ps : %.lhs +	${ENSCRIPT} -1 -o $@ -G $<++$(MAIN): ${HC_OBJ}+	${HC} -o $@ ${HC_OPTS} ${HC_OBJ}++$(HAPPYSRC:.y=.o): $(HAPPYSRC:.y=.hs)+	$(RM) $@+	${HC} ${HC_OPTS} -H95M -c $< -o $@++Main.o: Main.hs+	$(RM) $@+	${HC} ${HC_OPTS} -c $< -o $@++clean:+	$(RM) ${HC_OBJ} ${HC_INT} $(MAIN).aux $(MAIN).hp $(MAIN).prof core \+           $(MAIN).ps profile.* *~ .depend* $(HAPPYSRC:.y=.info) ++printsource:+	$(ENSCRIPT) -1 -d $(PRINTER) -G $(HC_SRC)+veryclean: clean+	$(RM) $(MAIN) TAGS $(HAPPYSRC:.y=.hs)++depend: .depend++.depend: ${HC_SRC}+	${HC_DEP} -optdep-f -optdep.depend ${HC_OPTS} ${HC_SRC}++TAGS: ${HC_SRC}+	hstags ${HC_SRC}+
+ tools/property/Makefile.old view
@@ -0,0 +1,63 @@+# $Id: Makefile.old,v 1.1 2002/03/25 22:40:36 hallgren Exp $++HC = ghc+HINT = ghci+HC_LOCAL_LIB = ${HOME}/lib+BASE = ../base+HC_INC = ${BASE}/parse ${BASE}/pretty ${BASE}/AST ${BASE}/SA ${BASE}/TC \+         ${BASE}/lib ${HC_LOCAL_LIB} \+         parse/extras syntax AST command .++HC_PKG = lang concurrent util+HC_DEP = ${HC} -M+HC_INCI = ${addprefix -i,${HC_INC}}+HC_PKGI = ${addprefix -package,${HC_PKG}}+HC_LIBI = ${addprefix -l,${HC_LIBS}}+HC_XOPTS = -recomp -fno-monomorphism-restriction -fwarn-incomplete-patterns -H128M -fglasgow-exts+HC_OPTS = ${$*_HC_OPTS} ${HC_XOPTS} ${HC_INCI} ${HC_PKGI}++HINT_OPTS = ${HC_OPTS}+DEP_OPTS = ${HC_INCI}+HC_LDOPTS = ${HC_OPTS} ${addprefix -L,${HC_INC}} ${HC_LIBI}++HAPPY      = happy+HAPPYFLAGS = # --ghc makes parser unusable for Hugs+RUNTIMEFLAGS = # +RTS -H75M+PRINTER    = lj12+ENSCRIPT   = enscript++HAPPYSRC   = parse/extras/PropParser.y+MAINSRC    = Main.hs++RM         = rm -f++MAIN       = pgc++%.hs: %.y+	$(HAPPY) $(HAPPYFLAGS) $< --info $(RUNTIMEFLAGS) -o $(HAPPYSRC:.y=.hs)++$(MAIN): $(HAPPYSRC:.y=.hs)+	${HC} --make $(MAINSRC) -o $@ ${HC_OPTS}++parser: parse/extras/PropParser.hs++develop:+	$(HINT) $(MAINSRC) ${HINT_OPTS}++tidy:+	${RM} ${BASE}/parse/Lexer.hi++clean:+	$(RM) ${HC_OBJ} $(MAIN).aux $(MAIN).hp $(MAIN).prof core \+           $(MAIN).ps profile.* *~ .depend* $(HAPPYSRC:.y=.info) +	find . '(' -name '*.o' -o -name '*.hi' ')' -exec $(RM) '{}' ';'++printsource:+	$(ENSCRIPT) -1 -d $(PRINTER) -G $(HC_SRC)++veryclean: clean+	$(RM) $(MAIN) TAGS $(HAPPYSRC:.y=.hs)++TAGS: ${HC_SRC}+	hstags ${HC_SRC}+
+ tools/property/PPfeCmds.hs view
@@ -0,0 +1,30 @@+module PPfeCmds where++import TiPropDecorate(TiDecls) -- to choose result type from the type checker+--import PropSyntax(HsDeclI) -- to choose result type from the type checker++import SimpPatMatchProp()++--import Pfe3Cmds(pfe3Cmds)+import Pfe4Cmds(pfe4Cmds)+import PFE4(PFE4Info)+import Pfe3Metrics(pfe3MetricsCmds)+import PFEdeps(clean5)+import PfeHtmlCmds(pfeHtmlCmds)+import PfeDepCmds(pfeDepCmds)+import PfeCleanCmd(pfeCleanCmd)+import PfeVersionCmd(pfeVersionCmd)+import PfeChase(pfeChaseCmds)+import PfeTransformCmds(pfeTransformCmds)+import PfePropCmds(pfePropCmds)+import StrategoCmds(strategoCmds)+import IsabelleCmds(isabelleCmds)++--pfeCmds = pfe3Cmds++pfeChaseCmds++pfeHtmlCmds+ppfeCmds = pfe4Cmds tcOutput++pfe3MetricsCmds++pfeTransformCmds++pfeChaseCmds+	   ++pfeHtmlCmds++pfeDepCmds++pfePropCmds++strategoCmds++isabelleCmds+	   ++pfeCleanCmd clean5++pfeVersionCmd++tcOutput = id :: I (PFE4Info i2 (TiDecls i2))+--tcOutput = id :: I ([[HsModuleI i1 [HsDeclI i2]]],x,y)+type I a = a->a
+ tools/property/PPfeInstances.hs view
@@ -0,0 +1,9 @@+module PPfeInstances where++import FreeNamesProp()+import ScopeNamesProp()+import NameMapsProp()+import MapDeclMProp() -- needed for removing pattern bindings.+import TiProp()+import RemoveListCompProp()+import ReAssocProp()
+ tools/property/PPfeMain.hs view
@@ -0,0 +1,29 @@+module PPfeMain where+import AbstractIO(ePutStrLn,try)+import PPU(getPPopts)+--import LexerOptions(lexerOptions,lexerflags0)+import PropLexer(pLexerPass0)+import PropParser(parse)+import SIO(runSIO,withStdio)+import PfeDepCmds(runPFE5Cmds)+import ReAssocProp() -- instance HasInfixDecls for output from parse+import PfeSocket(connectToPFE,pfeClient,clientOps)++mainPFE pfeCmds =+  do (opts,prgname,args0) <- getPPopts+     let --(lexerflags,args1) = lexerOptions lexerflags0 args0+	 args1 = args0+	 ao=(opts,prgname,args1)+	 lp=(pLexerPass0 {-lexerflags-},parse)+     r <- try (connectToPFE "hi") -- hardwired project directory path?!+     runSIO $ withStdio clientOps $+      case r of+       Left _  -> runPFE5Cmds () (pfeCmds (prgname++" [<options>]")) lp ao+       Right h -> do ePutStrLn "Using PFE server, command line options ignored."+                     pfeClient h args1+++     --lexerflags1 <- fromMaybe lexerflags0 # readFileMaybe lexerflagsPath+--     lexerflags1 <- return lexerflags0 -- grr!+--   when (lexerflags/=lexerflags1) $ writeFile lexerflagsPath (show lexerflags)+--lexerflagsPath dir=dir++"lexeroptions"
+ tools/property/Plogic.html view
@@ -0,0 +1,136 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<html>+<head>+<title>P-logic syntax, as implemented by PFE</title>+<link rel=stylesheet href="../web/src.css" title=Normal>+<link rel=parent href="./">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel=icon type="image/gif" href="../web/icon1.png">+</head>+<body>+<h1><img align=right src="../web/icon1.png" alt="">P-logic syntax,+as implemented by PFE</h1>++<small>Extracted from+<a href="parse2/Parser/PropParser.y">parse2/Parser/PropParser.y</a>+on 2004-09-01.</small>++<h3>Notational Conventions</h3>+<p>+As in the <a href="http://www.haskell.org/onlinereport/syntax-iso.html">+Haskell 98 syntax reference</a>:+</p>++<table>+<tr><th>Notation<th>Meaning+<tr><td class=code>[<i>pattern</i>]+    <td>optional+<tr><td class=code>{<i>pattern</i>}+    <td>zero or more repetitions+<tr><td class=code>(<i>pattern</i>)+    <td>grouping+<tr><td class=code><i>pat<sub>1</sub></i>|<i>pat<sub>2</sub></i>+    <td>choice+<tr><td class=code><code><b>assert</b></code>+    <td>terminal syntax+</table>++<h2>Context-Free Syntax</h2>+P-logic is added to Haskell 98 by extending the declaration syntax with+<em>property assertions</em> and <em>predicate definitions</em>,+as defined by the nonterminals+<code>assertion</code> and <code>property</code> below, respectively.++<pre class=code>+assertion : <b>assert</b> [conid <b>=</b>] prop++property  : <b>property</b> conid {var|con} <b>=</b> formula++prop    : pqcon {predarg}+        | (<b>All</b> | <b>Exist</b>) var [<b>::</b> ctype] <b>.</b> prop+        | <b>-/</b> prop+        | prop propop prop+        | pexp <b>===</b> pexp+        | pexp <b>:::</b> formula+        | <b>(</b> prop <b>)</b>++propop : <b>/\</b> | <b>\/</b> | <b>==&gt;</b> | <b>&lt;==&gt;</b>++pexp    : <b>{</b> exp <b>}</b>+        | qvar+        | pqcon+	| literal		++formula : aformula+        | formula <b>-&gt;</b> formula+        | formula qconop formula+        | <b>-/</b> formula		+        | formula propop formula		+        | <b>Lfp</b> conid <b>.</b> formula+        | <b>Gfp</b> conid <b>.</b> formula+        | pqcon {predarg}++predarg : <b>{</b> exp <b>}</b>+        | qvar+	| literal		+        | aformula++aformula+        : pqcon+        | <b>[</b> <b>]</b>+	| <b>!</b> aexp1+        | <b>$</b> aformula+        | <b>(</b> formulas <b>)</b>+        | <b>{|</b> typedpats <b>|</b> prop <b>|}</b>++typedpats : typedpat { <b>,</b> typedpat }++typedpat : pat [<b>::</b> ctype]++formulas : formula { <b>,</b> formula }++pqconid	: CONID | QCONID | tupcon++pqcon   : pqconid+	| <b>(</b> gconsym <b>)</b>+</pre>+<h2>Reserverd keywords</h2>+<dl>+<dt>In Haskell+<dd>Two new keywords are reserved:+    <code class=code><b>assert</b></code> and+    <code class=code><b>property</b></code>.+Apart from this, all valid Haskell 98 syntax remains valid in the extended+language.++<dt>In P-logic+<dd><ul>+     <li>All words that are reserved in Haskell 98 are reserved in P-logic.+     <li>The following additional words are reserved within the P-logic syntax:+         <blockquote class=code>+         <b><code>All</code></b>, <b><code>Exist</code></b>,+	 <b><code>Gfp</code></b>, <b><code>Lfp</code></b>,+	 <br>+	<b><code>!</code></b>, <b><code>.</code></b>, <b><code>$</code></b>, <b><code>-/</code></b>,+	 <b><code>/\</code></b>, <b><code>\/</code></b>, <b><code>===</code></b>, <b><code>==></code></b>,+	  <b><code>&lt;==></code></b>+	  </blockquote>+     </ul> +</dl>++<h2>Precedences</h2>+<table>+<caption>Precedences, from lowest to highest</caption>+<tr><th>Associativity<th>Operator+<tr><td>right<td class=code><b><code>Gfp</code></b>, <b><code>Lfp</code></b>,+                 <b><code>All</code></b>, <b><code>Exist</code></b>+<tr><td>right<td class=code><b><code>-></code></b>, qconop+<tr><td>left<td class=code><b><code><==></code></b>+<tr><td>right<td class=code><b><code>==></code></b>+<tr><td>left<td class=code><b><code>/\</code></b>, <b><code>\/</code></b>, <b><code>-/</code></b>,+                <b><code>===</code></b>+<tr><td>left<td class=code><b><code>:::</code></b>+</table>++</body>+</html>
+ tools/property/README.html view
@@ -0,0 +1,23 @@+<h1>Tools for Haskell extended with property declarations</h1>++<h2>What is in this directory (property)</h2>++The code in this directory defines an extended version of Haskell that+has declaration of properties. The syntax is defined by extending the+structures defined in the directory+<a href="../base/"><code>../base</code></a>.+The corresponding code for type checking etc is reused.++<p>+The main tool, <code>ppfe</code>,+reuses the extensible front-end defined in the directory+<a href="../pfe/"><code>../pfe</code></a>.++<p>+The language provided for describing properties is P-logic.+A separate page describes the <a href="Plogic.html">P-logic syntax,+as implemented by PFE</a>.++<hr>+<address>Authors: various</address>+<address>Contact: <a href="http://www.cse.ogi.edu/~hallgren/">TH</address>
+ tools/property/TI/Flags.ghc view
@@ -0,0 +1,4 @@+TiPropStruct.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+TiProp.hs: -fallow-undecidable-instances+TiPropDecorate.hs: -fallow-undecidable-instances+TiPropInstances.hs: -fallow-undecidable-instances
+ tools/property/TI/NameMapsPropDecorate.hs view
@@ -0,0 +1,83 @@+module NameMapsPropDecorate where+import NameMaps+import TiPropDecorate+--import PropSyntax(AssertionI,PredicateI)+import NameMapsDecorate(mts)+import TiTypes+--import TiKinds+import NameMapsProp()+--import NameMapsPropStruct(bothtype,bothval)+import HsIdent(mapHsIdent2)+import MapDeclM+--import MapDeclMBaseStruct()+import MapDeclMPropStruct()+import MUtils+import AccList++instance AccNames i (TiDecls i) where+  accNames f (Decs ds (ks,ts)) = accNames f ds . accNames f ts -- hmm, ks?++instance AccNames i (TiDecl i) where+  accNames f (Dec d) = accNames f d++instance AccNames i (TiExp i) where+  accNames f (Exp e) = accNames f e+  accNames f (TiSpec i _ ts) = accNames f i . accNames f ts+  accNames f (TiTyped e t) = a e . a t+    where a x = accNames f x++instance AccNames i (TiAssertion i) where accNames = accNamesRec+instance AccNames i (TiPredicate i) where accNames = accNamesRec++instance AccNames i (OTiAssertion i) where+  accNames f (OA is ds pa) = accList f is . accNames f ds . accNames f pa++--------------------------------------------------------------------------------++instance MapNames i1 (TiDecls i1) i2 (TiDecls i2) where+  mapNames2 c f (Decs ds (ks,ts)) = Decs (m ds) (mks ks,mts c f ts)+    where+      m x = mapNames2 c f x+      mks = map mk+      mk (i:>:(k,ti)) = bothtype mapHsIdent2 f i:>:(k,m ti)++instance MapNames i1 (TiDecl i1) i2 (TiDecl i2) where+  mapNames2 c f (Dec d) = Dec (mapNames2 c f d)++instance MapNames i1 (TiExp i1) i2 (TiExp i2) where+  mapNames2 c f (Exp e) = Exp (mapNames2 c f e)+  mapNames2 c f (TiSpec i sc ts)= TiSpec (bothval mapHsIdent2 f i) (m sc) (m ts)+    where m x = mapNames2 c f x+  mapNames2 c f (TiTyped e t) = TiTyped (m e) (m t)+    where m x = mapNames2 c f x++instance MapNames i1 (TiAssertion i1) i2 (TiAssertion i2) where+  mapNames2 = mapNames2Rec+instance MapNames i1 (TiPredicate i1) i2 (TiPredicate i2) where+  mapNames2 = mapNames2Rec++instance MapNames i1 (OTiAssertion i1) i2 (OTiAssertion i2) where+  mapNames2 c f@(vf,cf) (OA is ds pa) = OA is' ds' (m pa)+    where+       is' = map (vf (defval Pattern)) is+       ds' = [(vf (defval Local) i:>:m' t,m e)|(i:>:t,e)<-ds]+       m x = mapNames2 c f x+       m' x = mapNames2 Local f x++--------------------------------------------------------------------------------++instance MapDeclM (TiDecls i) (TiDecls i) where+  mapDeclM f (Decs ds dt) = flip Decs dt # mapDeclM f ds++instance MapDeclM (TiDecl i) (TiDecls i) where mapDeclM  = std_mapDeclM++instance MapDeclM (TiExp i) (TiDecls i) where+  mapDeclM f (Exp e) = Exp # mapDeclM f e+  mapDeclM f (TiTyped e t) = flip TiTyped t # mapDeclM f e+  mapDeclM f e@(TiSpec{}) = return e++instance MapDeclM (TiAssertion i) (TiDecls i) where mapDeclM = std_mapDeclM+instance MapDeclM (TiPredicate i) (TiDecls i) where mapDeclM = std_mapDeclM++instance MapDeclM (OTiAssertion i) (TiDecls i) where+  mapDeclM f (OA is ds pa) = OA is ds # mapDeclM f pa
+ tools/property/TI/TiProp.hs view
@@ -0,0 +1,37 @@+module TiProp where+import PropSyntax+import TI+--import TiBaseStruct+import FreeNamesProp+import DefinedNamesProp+import NameMapsProp+import TiPropStruct(tcPD,checkPredicateRec)+import TiBaseStruct(tcE,tcD,checkTypeSynRec,checkClassRec)+import TiPropInstances+import PrettyPrint+--import MUtils(( # ))++instance (TypeId i,ValueId i,PrintableOp i,Fresh i,HasSrcLoc i,TypedId PId i)+      => TypeCheckDecl i (HsDeclI i) [HsDeclI i] where+  tcDecl bs = recprop (tcD bs) (tcPD bs)++instance Eq i => CheckRecursion i (HsDeclI i) where+  checkRecursion ds = do checkTypeSynRec ds+			 checkClassRec ds+		         checkPredicateRec ds++instance (TypeId i,ValueId i,PrintableOp i,Fresh i,HasSrcLoc i,TypedId PId i)+      => TypeCheck i (HsExpI i) (Typed i (HsExpI i)) where+  tc (Exp e) = tcE e++instance (TypeId i,ValueId i,PrintableOp i,Fresh i,HasSrcLoc i,TypedId PId i)+      => TypeCheck i (AssertionI i) (Typed i (AssertionI i)) where+  tc (PA e) = tc e++instance (TypeId i,ValueId i,PrintableOp i,Fresh i,HasSrcLoc i,TypedId PId i)+      => TypeCheck i (PredicateI i) (Typed i (PredicateI i)) where+  tc (PP e) = tc e++instance ({-ValueId i,-}TypeVar i) => KindCheck i (HsDeclI i) () where+  kc = recprop kc kcPD+    where kcPD _ = return () -- hmm
+ tools/property/TI/TiPropDecorate.hs view
@@ -0,0 +1,305 @@+{-++This module provides type inference for the base+property syntax.+This type checker outputs an abstract syntax tree where all declaration lists+have been decorated with the kinds and types of the entities defined in+the list, and all applications of polymorphic functions have been decorated+with the instantiation of the quantified variables.+-}+module TiPropDecorate where+import PropSyntaxStruct+import HasBaseStruct+import HasPropStruct+import Substitute+import SubstituteBaseStruct+import FreeNames+import DefinedNames+import FreeNamesProp()+import PropSyntax(HsDeclI,HsExpI,HsPatI,HsTypeI,HsQualTypeI,AssertionI,PredicateI,Rec(..))+import qualified PropSyntax as S+import PrettyPrint+import PrettySymbols+import TI hiding (Qual(..),Subst)+import TiDecorate(TiPat,DeclsUseType,no_use,specType,mapTiDeclsNames)+--import TiD(GetSigs(..),DeclInfo(..))+import TiProp()+import TiPropStruct+import TiBaseStruct(tcE,tcD)+import Lists((\\\))+import MUtils(( # ),mapSnd)+--import Maybe(mapMaybe)+--import IOExts(trace)++--------------------------------------------------------------------------------+type TiModule i = HsModuleI i (TiDecls i)+data TiDecls i = Decs [TiDecl i] (DeclsType i) deriving Show+newtype TiDecl i = Dec (DStruct i) deriving Show+newtype TiAssertion i = PA (PropPA i) deriving Show+newtype TiPredicate i = PP (PropPP i) deriving Show++-- Overloaded assertions:+data OTiAssertion i = OA [i] [(Typed i i,TiExp i)] (TiAssertion i) deriving Show++data TiExp i+  = Exp (EStruct i)+  | TiSpec (HsIdentI i) (Scheme i) [HsTypeI i] -- specialize a polymorphic identifier+  | TiTyped (TiExp i) (HsTypeI i) -- decorate expression with inferred type+  deriving Show++----++type DStruct i = PropDI i (TiExp i) (TiPat i) (TiDecls i) (HsTypeI i) [HsTypeI i] (HsTypeI i) (OTiAssertion i) (TiPredicate i)++type DBase i = DI i (TiExp i) (TiPat i) (TiDecls i) (HsTypeI i) [HsTypeI i] (HsTypeI i)+type EStruct i = EBase i+type EBase i = EI i (TiExp i) (TiPat i) (TiDecls i) (HsTypeI i) [HsTypeI i]++--type PropDecl i =  PropDI i (TiExp i) (HsPatI i) (TiDecls i) (HsTypeI i) [HsTypeI i] (HsTypeI i) (TiAssertion i) (TiPredicate i)+type PropPA i = PA i (TiExp i) (HsQualTypeI i) (TiAssertion i) (TiPredicate i)+type PropPP i = PP i (TiExp i) (HsPatI i) (HsQualTypeI i) (TiAssertion i) (TiPredicate i)++--------------------------------------------------------------------------------+instance Rec (TiDecl i) (DStruct i) where rec = Dec; struct (Dec d) = d+instance Rec (TiExp i) (EStruct i) where rec = Exp -- ; struct = ???+instance Rec (TiAssertion i) (PropPA i) where rec = PA; struct (PA pa) = pa+instance Rec (TiPredicate i) (PropPP i) where rec = PP; struct (PP pp) = pp+--------------------------------------------------------------------------------+instance MapExp (TiExp i) (TiDecl i) where mapExp = mapExpRec+instance MapExp (TiExp i) (TiAssertion i) where mapExp = mapExpRec+instance MapExp (TiExp i) (TiPredicate i) where mapExp = mapExpRec++instance MapExp (TiExp i) (TiDecls i) where+  mapExp f (Decs ds dt) = Decs (mapExp f ds) dt++instance Subst i (TiExp i) where+  subst s e =+    case e of+      Exp be -> substE' Exp s be+      TiTyped e t -> TiTyped (subst s e) t+      TiSpec (HsVar x) sc ts ->+          case isId sx of+            Just y -> TiSpec y sc ts+	    _ -> sx -- type annotation is lost!+	where sx = s x+      _ -> e ++instance MapExp (TiExp i) (OTiAssertion i) where+  mapExp f (OA is ds pa) = OA is (mapSnd f ds) (mapExp f pa)++--------------------------------------------------------------------------------++instance (ValueId i, TypeId i, Fresh i, PrintableOp i,HasSrcLoc i,TypedId PId i)+      => TypeCheckDecl i (HsDeclI i) (TiDecls i) where+  tcDecl bs = recprop (tcD bs) (tcPD bs)++instance AddDeclsType i (TiDecls i) where+  addDeclsType dt1 (Decs ds dt2) = Decs ds (dt1+++dt2)+  rmDeclsType (Decs ds dt2) = Decs ds ([],[])++instance (ValueId i, TypeId i, Fresh i, PrintableOp i,HasSrcLoc i,TypedId PId i)+      => TypeCheck i (HsExpI i) (Typed i (TiExp i)) where+  tc = tcE . struct ++instance (ValueId i, TypeId i, Fresh i, PrintableOp i,HasSrcLoc i,TypedId PId i)+      => TypeCheck i (AssertionI i) (Typed i (TiAssertion i)) where+  tc = tc . struct ++instance (ValueId i, TypeId i, Fresh i, PrintableOp i,HasSrcLoc i,TypedId PId i)+      => TypeCheck i (AssertionI i) (Typed i (OTiAssertion i)) where+  tc a = emap (OA [] []) # tc (struct a)++instance (ValueId i, TypeId i, Fresh i, PrintableOp i,HasSrcLoc i,TypedId PId i)+      => TypeCheck i (PredicateI i) (Typed i (TiPredicate i)) where+  tc = tc . struct +{-+instance GetSigs i [Pred i] (Type i) (TiDecls i) where+  getSigs (Decs ds _) = mapMaybe getSig ds+    where+      getSig (Dec (Base (HsTypeSig s is c tp))) = Just (s,is,c,tp)+      getSig _                                  = Nothing+-}+instance (TypeVar i,ValueId i) => DeclInfo i (TiDecl i) where+  explicitlyTyped kenv tinfo bs  = prop e e . struct+    where e x = explicitlyTyped kenv tinfo bs x++instance DeclInfo i (TiDecls i)++--------------------------------------------------------------------------------++instance TypeVar i => EnvFrom (TiDecls i) (DeclsUseType i) where+  accEnv (Decs ds dt) = (no_use dt+++) . accEnv ds++instance TypeVar i => EnvFrom (TiDecl i) (DeclsUseType i) where+  accEnv = accEnv . struct++instance TypeVar i => EnvFrom (TiExp i) (DeclsUseType i) where+  accEnv (Exp e) = accEnv e+  accEnv (TiSpec v@(HsVar _) t as) = (([],[v:>:(t,specType t as)])+++)+  accEnv (TiTyped e t) = accEnv e+  accEnv _ = id+++instance (EnvFrom b e,EnvFrom p e) => EnvFrom (Prop b p) e where+  accEnv = prop accEnv accEnv++instance EnvFrom (PD i pa pp) (DeclsUseType i) where accEnv = ignore -- hmm++ignore = const id++--------------------------------------------------------------------------------++--instance HasBaseStruct (TiDecls i) [TiDecl i] where base ds = Decs (base ds) ([],[])+instance HasBaseStruct (TiDecl i) (DBase i) where base    = Dec . base+instance GetBaseStruct (TiDecl i) (DBase i) where basestruct = basestruct . struct+instance HasBaseStruct (TiExp i) (EBase i)  where base    = Exp++instance HasPropStruct (TiDecl i) (PD i (OTiAssertion i) (TiPredicate i)) where+  proprec = rec . Prop++instance HasPropStruct (TiAssertion i) (PropPA i) where proprec = rec+instance HasPropStruct (TiPredicate i) (PropPP i) where proprec = rec++instance HasId i (TiExp i) where+  ident = Exp . ident+  isId (Exp e) = isId e+  isId (TiSpec x _ []) = Just x+  isId _ = Nothing --hmm++--instance HasLit (TiExp i) where lit = hsLit loc0+----instance HasLit (TiPat i) where lit = hsPLit++instance HasCoreSyntax i (TiExp i) where+  app = hsApp+  tuple = hsTuple+  list = hsList+--paren = hsParen++instance HasTypeApp i (TiExp i) where spec = TiSpec++instance HasTypeAnnot i (TiExp i) where typeAnnot = TiTyped++instance HasDef (TiDecls i) (TiDecl i) where+  nullDef (Decs ds _) = null ds+  noDef = Decs [] ([],[])+  consDef d (Decs ds ts) = Decs (d:ds) ts+  toDefs ds = Decs ds ([],[])+  appendDef (Decs ds1 ts1) (Decs ds2 ts2) = Decs (ds1++ds2) (ts1+++ts2)+  filterDefs p (Decs ds ts) = Decs (filter p ds) ts -- keep all type info?!++instance HasDefs (TiDecls i) (TiDecl i) where+  fromDefs (Decs ds _) = ds++instance HasSrcLoc (TiDecl i) where srcLoc (Dec d) = srcLoc d++instance HasAbstr i (TiDecl i) where abstract xs = mapRec (mapProp (abstract xs) (abstract xs))+instance HasAbstr i (TiDecls i) where abstract xs (Decs ds ti) = Decs (abstract xs ds) ti++--instance HasAbstr i (TiAssertion i) where+--  abstract is pa = foldr propLambda pa is++instance HasAbstr i (OTiAssertion i) where+  abstract is1 (OA is2 ds pa) = OA (is1++is2) ds pa++instance HasLocalDef i (TiExp i) (OTiAssertion i) where+  letvar it e (OA is ds pa) = OA is ((it,e):ds) pa++instance (HasAbstr i b, HasAbstr i p) => HasAbstr i (Prop b p) where+  abstract xs = mapProp (abstract xs) (abstract xs)++--------------------------------------------------------------------------------+instance DefinedNames i (TiDecls i) where definedNames (Decs ds ti) = definedNames ds+instance ClassMethods i (TiDecls i) where classMethods c cnt (Decs ds ti) = classMethods c cnt ds+instance MapDefinedNames i (TiDecls i) where+   mapDefinedNames f (Decs ds ti) = mapTiDeclsNames Decs f ds ti++instance DefinedNames i (TiDecl i) where definedNames = definedNamesRec+instance ClassMethods i (TiDecl i) where classMethods = classMethodsRec+instance ValueId i => AddName i (TiDecl i) where addName = addNameRec++instance MapDefinedNames i (TiDecl i) where+   mapDefinedNames = mapDefinedNamesRec++instance Eq i => FreeNames i (TiDecl i) where freeNames = freeNamesRec+instance Eq i => FreeNames i (TiAssertion i) where freeNames = freeNamesRec+instance Eq i => FreeNames i (TiPredicate i) where freeNames = freeNamesRec+instance Eq i => FreeNames i (TiDecls i) where freeNames (Decs ds ti) = freeNames ds+instance Eq i => FreeNames i (TiExp i) where+  freeNames (Exp e) = freeNames e+  freeNames (TiSpec x sc ts) = [val x] -- hmm+  freeNames (TiTyped e t) = freeNames e -- hmm++instance Eq i => FreeNames i (OTiAssertion i) where+  freeNames (OA is ds pa) = freeNames (es,pa,ts) \\\ map FreeNames.var (is++is2)+    where (tis,es) = unzip ds+	  is2:>:ts = unzipTyped tis+-------------------------------------------------------------------------------++instance Eq i => HasLocalDef i (TiExp i) (TiDecl i) where+   letvar x e = mapRec (mapProp (letvar x e) (letvar x e))++instance Eq i => HasLocalDef i (TiExp i) (TiDecls i) where+   letvar x e (Decs ds ts) = Decs (letvar x e ds) ts++instance TypeVar i => Types i (TiDecl i) where+  tmap f = mapRec (mapProp (tmap f) (mapPD id (tmap f) (tmap f)))+--tv = ...++instance TypeVar i => Types i (TiDecls i) where+  tmap f (Decs ds (ks,ts)) = Decs (tmap f ds) (ks,tmap f ts)+--tv = ...++instance TypeVar i => Types i (TiExp i) where+  tmap f (Exp e) = Exp (mapEI id (tmap f) (tmap f) (tmap f) id id e)+  tmap f (TiSpec x sch ts) = TiSpec x (tmap f sch) (tmap f ts)+  tmap f (TiTyped e t) = TiTyped (tmap f e) (f t)+--tv = ...++instance (Types i c,Types i t) => Types i (Q c t) where+  tmap f (c:=>t) = tmap f c:=>tmap f t++instance TypeVar i => Types i (TiAssertion i) where+  tmap f (PA pa) = PA (mapPA id (tmap f) (tmap f) (tmap f) (tmap f) pa)++instance TypeVar i => Types i (TiPredicate i) where+  tmap f (PP pp) = PP (mapPP id (tmap f) id (tmap f) (tmap f) (tmap f) pp)++instance TypeVar i => Types i (OTiAssertion i) where+  tmap f (OA is ds pa) = OA is (tmap f ds) (tmap f pa)++--------------------------------------------------------------------------------+instance (TypeId i,ValueId i,PrintableOp i) => Printable (TiDecl i) where+  ppi (Dec d)      = ppi d++instance (TypeId i,ValueId i,PrintableOp i) => Printable (TiDecls i) where+  ppi (Decs ds (ks,ts)) = vcat ds $$+			  ppIfTypeInfo (sep [ppi "{-",ppi ks,ppi ts,ppi "-}"])+  ppis (Decs ds ([],[])) = ppis ds+  ppis (Decs ds (ks,ts)) = ppis ds +++                           map ppIfTypeInfo [ppi "{-",ppi ks,ppi ts,ppi "-}"]++instance (TypeId i,ValueId i,PrintableOp i) => Printable (TiExp i) where+   ppi (Exp e)      = ppi e+   ppi (TiSpec x _ []) = wrap x+   ppi (TiSpec x _ ts) = wrap x <> ppIfTypeInfo ("{-"<>fsep (map wrap ts)<>"-}")+   ppi (TiTyped e t) = e <> ppIfDebug ("{-"<>el<>t<>"-}")++   wrap (Exp e) = wrap e+   wrap e = ppi e++instance (TypeId i,ValueId i,PrintableOp i) => Printable (TiAssertion i) where+  ppi=ppi.struct+  wrap=wrap.struct++instance (TypeId i,ValueId i,PrintableOp i) => Printable (TiPredicate i) where+  ppi=ppi.struct+  wrap=wrap.struct++instance (TypeId i,ValueId i,PrintableOp i) => Printable (OTiAssertion i) where+  ppi (OA is ds pa) = ppLam is (ppLet ds (ppi pa))+   where+     ppLam [] d = d+     ppLam is d = sep [lambda<+>hsep is<+>rarrow,d]++     ppLet [] d = d+     ppLet ds d = sep ["let"<+>vcat (map ppD ds),"in"<+>d]++     ppD (it,e) = it<+>"="<+>e
+ tools/property/TI/TiPropInstances.hs view
@@ -0,0 +1,139 @@+{-++The various auxiliary operations required by the extensible type checker+are defined here.+-}+module TiPropInstances where+import List(partition)+import Maybe(isJust)+--import Maybe(mapMaybe)++import HasBaseStruct+import PropSyntax+import TI hiding (Subst,Qual(..))+--import TiD(DeclInfo(..),HasMethodSigs(..))+--import TiHsName+--import TiBaseStruct(pApp)+import TiBase()+--import TiPrelude(pt)+import HsPropStruct+import MUtils+import DefinedNamesProp()+import FreeNamesProp()+import Substitute+import SubstituteProp++instance HasId i (HsExpI i) where+  ident = base . ident+  isId = isId @@ basestruct++--instance HasLit (HsExpI i) where lit = hsLit loc0+----instance HasLit (HsPatI i) where lit = hsPLit++instance HasCoreSyntax i (HsExpI i) where+  app e1 e2 = hsApp e1 e2+  tuple = hsTuple+  list = hsList++instance HasAbstr i (HsExpI i) where+  abstract = hsLambda . map var+{-+instance HasId i (HsPatI i) where+  ident = base . ident+  isId = isId @@ basestruct++instance HasCoreSyntax i (HsPatI i) where+  app (Pat (Base p1)) p2 = base $ pApp p1 p2 -- hmm+  tuple = hsPTuple+  list = hsPList+-}++instance HasAbstr i (HsDeclI i) where+  abstract is = mapRec (mapProp (abstract is) id) -- !!++instance HasAbstr i pa => HasAbstr i (PD i pa pp) where+  abstract is pd =+    case pd of+      HsAssertion s optn pa -> HsAssertion s optn (abstract is pa)+      HsPropDecl s n ns pp -> HsPropDecl s n (map HsVar is++ns) pp++--instance HasAbstr i (AssertionI i) where+--  abstract is pa = foldr propLambda pa is++instance Eq i => HasLocalDef i (HsExpI i) (HsDeclI i) where+  letvar xt e = mapRec (mapProp (letvar xt e) id) -- !!++instance (FreeNames i pa,MapExp e pa,HasAbstr i pa,+	  HasLocalDef i e pa,+	  FreeNames i pp,MapExp e pp,+	  HasId i e,Subst i e)+      => HasLocalDef i e (PD i pa pp) where+  letvar xt@(i:>:t) e pd =+    case pd of+      HsPropDecl s n ns pp ->+	  if HsVar i `elem` freeVars pp+          then if isJust (isId e)+	       then HsPropDecl s n ns (esubst1 var e i pp)+	       else --pd -- hmm!!+                    HsPropDecl s n ns (esubst1 var e i pp) --code duplication...+                    +	  else pd+      HsAssertion s optn pa -> +	  if HsVar i `elem` freeVars pa+          then if isJust (isId e)+	       then HsAssertion s optn (esubst1 var e i pa)+	       else HsAssertion s optn (letvar xt e pa)+	  else pd++instance AddDeclsType i [HsDeclI i]++instance HasDef [HsDeclI i] (HsDeclI i) where+  nullDef = null+  noDef = []+  consDef = (:)+  appendDef = (++)+  toDefs = id+  filterDefs = filter++instance (ValueId i,TypeVar i) => DeclInfo i (HsDeclI i) where+  explicitlyTyped kenv tinfo ctx =+      recprop (explicitlyTyped kenv tinfo ctx) (explicitlyTyped kenv tinfo ctx)+  --isTypeDecl = isBase isTypeDecl . struct+  isUnrestricted expl = recprop (isUnrestricted expl) (isUnrestricted expl)+  keepAmbigTypes = recprop keepAmbigTypes keepAmbigTypes++instance DeclInfo i (PD i pa pp) where+  explicitlyTyped _ _ _ pd =+    case pd of+      --HsAssertion s (Just n) pa -> ([],[HsCon n:>:mono (pt "Prop")])+      _ -> ([],[]) -- no explitit type info here...+  isUnrestricted _ _ = True+  keepAmbigTypes pd =+    case pd of+      HsAssertion {} -> True+      _ -> False+++--- Dummy instances ---+-- Need something sensible when decorating the syntax tree with types...+instance TypeVar i => Types i (HsDeclI i)    where tmap f = id; tv d = []+instance TypeVar i => Types i (AssertionI i) where tmap f = id; tv d = []+instance TypeVar i => Types i (PredicateI i) where tmap f = id; tv d = []++instance HasTypeApp i (HsExpI i) where spec x _ ts = ident x+--instance HasTypeApp i (HsPatI i) where spec x _ ts = ident x++instance HasTypeAnnot i (HsExpI i)++instance HasMethodSigs [HsDeclI i] where+  splitMethodSigs = partition isSig+    where+      isSig (Dec (Base (HsTypeSig {}))) = True+      --isSig (Dec (Prop (HsAssertion _ (Just _) _))) = True+      isSig _                           = False+{-+instance GetSigs i [Pred i] (Type i) [HsDeclI i] where+  getSigs = mapMaybe getSig+    where+      getSig (Dec (Base (HsTypeSig s is c tp))) = Just (s,is,c,tp)+      getSig _                                  = Nothing+-}
+ tools/property/TI/TiPropStruct.hs view
@@ -0,0 +1,293 @@+module TiPropStruct where+import PropSyntax hiding (Q(..))+import qualified PropSyntax as P(Q(..))+import PropSyntaxStruct(Prop,prop)+import TI hiding (TI)+--import TiHsName+--import TiT(kcStar,kcPred)+import TiE(tcLambda')+import TiPrelude(pt)+import SrcLoc+import TypedIds(HasIdTy)+import MUtils+import Monad(unless)+import PrettySymbols(el)+import PrettyPrint hiding (var)+import SimpleGraphs(reachable')++-- For debugging:+--import IOExts(trace)++-- I wish there was an easier way to declare instances in Haskell...++instance (TypeCheck i be e,TypeCheck i pe e) => TypeCheck i (Prop be pe) e where+  tc = prop tc tc+{-+instance (Printable bd,Printable pd,+          TypeCheckDecl i bd d,TypeCheckDecl i pd d)+       => TypeCheckDecl i (Prop bd pd) d where+  tcDecl bs d = --trace (pp d)  $+                prop (tcDecl bs) (tcDecl bs) d++instance (Fresh i,TypeId i,ValueId i,TypeVar i,HasSrcLoc i,--HasIdTy i,+          Printable i,Printable pa,Printable pp,+          TypeCheck i pa (Typed i pa2),+          TypeCheck i pp (Typed i pp2),+	  HasDef ds2 d2,+	  HasPropStruct d2 (PD i pa2 pp2))+      => TypeCheckDecl i (PD i pa pp) ds2+  where tcDecl = tcPD+-}+instance (TypeId i,ValueId i,Fresh i,HasSrcLoc i,HasIdTy x i,+          Printable i,Printable e1,--Printable t,+	  TypeCheck i e1 (Typed i e2),+	  TypeCheck i pa1 (Typed i pa2),+	  TypeCheck i pp1 (Typed i pp2),+	  HasTypeAnnot i e2,HasId i e2,+	  HasPropStruct r (PA i e2 (HsQualTypeI i) pa2 pp2))+      => TypeCheck i (PA i e1 (HsQualTypeI i) pa1 pp1) (Typed i r)+  where tc = tcPA++instance (TypeId i,ValueId i,Fresh i,HasSrcLoc i,HasIdTy x i,+          Printable t,Printable e1,Printable p1,+	  Printable pa1,Printable pp1,PrintableOp i,+	  DefinedNames i p1,+          TypeCheck i e1 (Typed i e2),+          TypeCheck i p1 (Typed i p2),+	  TypeCheck i pa1 (Typed i pa2),+	  TypeCheck i pp1 (Typed i pp2),+	  HasId i e2,+	  HasBaseStruct t (TI i t'),+	  HasPropStruct r (PP i e2 p2 (P.Q [t] (Type i)) pa2 pp2)) =>+         TypeCheck i (PP i e1 p1 (P.Q [t] (Type i)) pa1 pp1) (Typed i r)+  where tc = tcPP++{-+predAp i [] = predId i+predAp i as = predApp i as+-}+targs vs = map (([]P.:=>).tyvar) vs++tcPP p =+  case p of+--  PredId q -> do t <- propinst q+--		   predId q>:t+{-+    PredId q -> do (_,ds):>:t <- propinst_loc q -- add type params!!+                   predAp q (map Left ds)>:t+-}+    PredApp i [] es -> do ((sc,vs),ds):>:ti <- propinst_loc i+		          es':>:ts <- unzipTyped # mapM tcArg es+		          v <- pfresh+		          ti=:=funT (ts++[v])+		          tpredApp i (targs vs) (map Left ds++es') >: v+    PredArrow p1 p2 -> do p1':>:t1 <- tcPred p1+			  p2':>:t2 <- tcPred p2+			  predArrow p1' p2'>:tPred (funT [t1,t2])+    PredInfixApp p1 i p2 -> do ((sc,vs),ds):>:ti <- propinst_loc i+                               p1':>:t1 <- tc p1+			       p2':>:t2 <- tc p2+		               v <- pfresh+		               ti=:=funT [t1,t2,v]+			       let p' = if null ds && null vs+			                then predInfixApp p1' i p2'+				        else tpredApp i (targs vs) (map Left ds++map Right [p1',p2'])+			       p'>:v+    PredNeg optt p -> do p':>:t <- tc p+			 checkOptT optt t+		         predNeg (Just ([]P.:=>t)) p'>:t+    PredOp op optt p1 p2 -> tcBinPred (predOp op) optt p1 p2+    PredLfp i optt p -> tcFp predLfp' i optt p+    PredGfp i optt p -> tcFp predGfp' i optt p+    PredNil -> do v<-tfresh+		  listType <- getListType+                  predNil>:tPred (listType v)+    PredLifted e -> do e':>:t <- tc e+		       v <- tfresh+		       tBool <- getBoolType+		       t=:=funT [v,tBool]+		       predLifted e'>:tPred v+    PredStrong p -> do p':>:t <- tc p+		       isPred t+		       predStrong p'>:t++    PredParen p -> emap predParen # tc p+    PredComp pts a -> do let (ps,ts) = unzip pts+		             --ts' = ts -- repeat Nothing -- hmm!!+		         (ps',a') :>: (tps,t') <- tcLambda' ps a+			 isProp t'+			 let tps' = [Just ([]P.:=>tp)|tp<-tps]+			 {- No rank 2 polymorphism: type variables in the+			    type signatures are treated as free type variables+			    that can be unified with other types. The type+			    signature can only be used to make the+			    inferred type more specific, not more general. -}+			 sequence_ [tp=:=t|(tp,Just (_ P.:=>t))<-zip tps ts]--hm+			 predComp (zip ps' tps') a'>:tPredn tps+    _ -> error (pp p)++tcArg a = either (\e->emap Left # tc e) (\p->emap Right # tc p) a++tcFp f i optt p =+    do --v <- pfresh -- too general (ok if proper kind checking is done)+       vv <- tfresh+       let v = tPred vv -- restricted to unary predicates+       p':>:t <-extend1 (HsCon i) (mono v) (tc p)+       t=:=v+       checkOptT optt v+       let qv= []P.:=>vv -- vv is more appropriate than v in the Alfa transl+       f i qv p'>:t++checkOptT optt v =+    case optt of+      Nothing -> done+      Just ([]P.:=>ta) -> ta=:=v+      _ -> fail "qualified type annotation not supported"+++----++tProp :: TypeCon i => Type i+tProp = pt "Prop"+tPred v = funT [v,tProp]+tPredn ts = funT (ts++[tProp])++isProp t = t=:=tProp++tcProp a = do a':>:t <- tc a+              isProp t+	      return a'++tcPred a = do ta@(a':>:t) <- tc a+              t'<-isPred t+	      a'>:t' -- hmm++isPred t = do v <- tfresh+              t=:=tPred v+	      return v++tcBinProp op a1 a2 = do p' <- propOp op # tcProp a1 <# tcProp a2+		        p'>:tProp++tcBinPred op optt p1 p2 = do p1':>:t1 <- tc p1+			     p2':>:t2 <- tc p2+			     t1=:=t2+			     checkOptT optt t1 -- hmm+			     op (Just ([]P.:=>t1)) p1' p2'>:t1++propAp i [] = propId i+propAp i es = propApp i es++tcPA pa =+  case pa of+    Quant q i optt pa ->+       do t <- tfresh+	  let bs = [HsVar i:>:t]+	  --bs <- intro [HsVar i]+	  check t optt+          pa' <- extendts ((map.fmap) mono bs) $ tcProp pa+          --quant q i optt pa' >: tProp+	  quant q i (Just ([] P.:=> t)) pa' >: tProp+      where+       check t (Just (_ P.:=>t')) = t=:=t' -- !!+       check _ _ = return ()++--  PropId q -> do t <- propinst q+--		   propId q>:t+{-+    PropId q -> do (_,ds):>:t <- propinst_loc q -- add type params!!+                   propAp q ds>:t+-}+    PropApp i [] es -> do ((sc,vs),ds):>:ti <- propinst_loc i+		          es':>:ts <- unzipTyped # mapM tcArg es+		          v <- pfresh+		          ti=:=funT (ts++[v])+		          tpropApp i (targs vs) (map Left ds++es') >: v+    PropNeg a -> do a' <- tcProp a; propNeg a' >: tProp+    PropOp op a1 a2 -> tcBinProp op a1 a2+    PropEqual e1 e2 -> do e1':>:t1 <- tc e1+			  e2':>:t2 <- tc e2+			  t1=:=t2+			  propEqual (typeAnnot e1' t1) e2' >: tProp+    PropHas e p -> do e':>:te <- tc e+		      p':>:tp <- tc p+		      tp=:=funT [te,tProp]+		      propHas e' p' >: tProp+    PropParen a -> emap propParen # tc a++tcPD bs d =+  case d of+    HsAssertion s optn pa ->+       posContext' s "in assertion" $+       do pa' <- tcProp pa+	  maybe done (isProp @@ coninst' bs) optn+	  return $ oneDef $ hsAssertion s optn pa'+    HsPropDecl s n ns pp ->+       do lbs <- ptintro ns+	  tn <- coninst' bs n+	  pp':>:t <- extendts ((map.fmap) mono lbs) $ tc pp+	  tn=:=funT ([ t | _:>:t<-lbs]++[t])+          return $ oneDef $ hsPropDecl s n ns pp'++ptintro xs = do ts <- freshlist (length xs)+		let lbs = zipTyped (xs:>:ts)+	        addptypes lbs+	        return lbs++addptypes ts = mapM_ addptype ts+addptype (HsVar _:>:t) = addtype t+addptype (HsCon _:>:t) = addprop t++coninst' bs n =+  case [ t | HsCon x:>:t<-bs,x==n] of+    t:_ -> return t+    _ -> fail$"Type checker bug: no type introduced for: "++pp n++{-+propinst x =+  do s <- sch (HsCon x)+     ctx :=> t <- sinst s+     unless (null ctx) $+       fail.pp $+	 sep [srcLoc x<+>"overloaded predicates are not supported (yet):",+	      nest 4 (x<+>el<+>s)]+     return (toPredType (isCon x) t)+-}++propinst_loc x = propinst_loc' (Just (srcLoc x)) x+propinst_loc' s x =+  do sc@(Forall ags gs qt) <- sch (HsCon x)+     vs <- freshvars gs+     let ctx:=> t = freshen' vs (tdom gs) qt+     ds <- newdicts s ctx+     ((sc,{-map tyvar-} vs),map var ds) >: toPredType (isCon x) t++toPredType False = id+toPredType True  = liftCon++liftCon x = funT . map tPred . flatFunT $ x++flatFunT t =+  case isFunT t of+    Just (t1,t2) -> t1:flatFunT t2+    _ -> [t]++pfresh = do t <- fresh+	    addprop t+	    return t++addprop t = addkinst (t:>:kprop)++{-++Predicate definition can not use explicit recursion. The Gfp & Lfp operators+have to be used instead.+-}+checkPredicateRec ds =+    unless (null recpreds) $ +      declContext recpreds $+        fail "Recursive predicates"+  where+    recpreds = [pred|(pred,_)<-g,pred `elem` reachable' g [pred]]+    g = [(i,free) | Just d@(HsPropDecl {})<-map propstruct ds,+	            let free=freeValueNames d,+	            i<-definedValueNames d]
+ tools/property/command/CommandLine.hs view
@@ -0,0 +1,63 @@+-- $Id: CommandLine.hs,v 1.2 2002/05/18 20:40:57 hallgren Exp $++module CommandLine where++import System+import GetOpt+import IOExts+import PrettyPrint+++data Flag = ParseInternal          -- print abstract syntax in internal format+          | ParsePretty PPLayout   -- pretty print in given style+          | ToHaskell              -- forgetful functor from Programatica+          | StaticAnalysis         -- run static analysis+          | TypeCheck              -- run type checker+          | Help                   -- give short usage info+            deriving Eq++options =+   [ Option []        ["ast", "abstract-syntax-tree"]+         (NoArg ParseInternal)+         "print abstract syntax in internal format",+     Option []        ["pretty"]+         (OptArg style "STYLE")+         "pretty print in STYLE[(o)ffside|(s)emicolon|(u)trecht|(i)nline|(n)one] (default = offside)",+     Option []        ["hs", "haskell"]+         (NoArg ToHaskell)+         "produce Haskell code with Programatica constructs commented out",+     Option []        ["sa", "static", "static-analysis"]+         (NoArg StaticAnalysis) +         "run static analysis",+     Option []        ["tc", "typecheck"]+         (NoArg TypeCheck)+         "run typechecker",+     Option ['h','?'] ["help"]      +         (NoArg Help)+         "display this help message and exit"+   ]++style :: Maybe String -> Flag+style Nothing  = ParsePretty PPOffsideRule+style (Just s) = ParsePretty $+         case s of+         "o"         -> PPOffsideRule+         "offside"   -> PPOffsideRule+         "s"         -> PPSemiColon+         "semicolon" -> PPSemiColon+         "u"         -> PPUtrecht+         "utrecht  " -> PPUtrecht+         "i"         -> PPInLine+         "inline"    -> PPInLine+         "n"         -> PPNoLayout+         "none"      -> PPNoLayout+         _           -> PPOffsideRule++getFlag :: [Flag] -> Flag+getFlag []  = ParsePretty PPOffsideRule+getFlag [f] = f+getFlag _   = error usage++usage = "usage: pgc [option] [filename]"++commandLine = getOpt Permute options $ unsafePerformIO getArgs
+ tools/property/command/Compile.hs view
@@ -0,0 +1,18 @@+-- $Id: Compile.hs,v 1.2 2001/09/20 21:34:13 hallgren Exp $++module Compile where++import Monad(liftM)++data Compile a = Good a | CompileError String+++instance Functor Compile where fmap = liftM++instance Monad Compile where+    return = Good+    m >>= f = case m of+              Good s           -> f s+              CompileError err -> CompileError err++compileError = CompileError
+ tools/property/defs/DefinedNamesProp.hs view
@@ -0,0 +1,34 @@+module DefinedNamesProp where+import DefinedNames+import DefinedNamesPropStruct()+import DefinedNamesBase()+import PropSyntax(HsDeclI,Prop,prop,mapProp,struct,listBase)+import TiNames(ValueId)++instance DefinedNames i (HsDeclI i) where+  definedNames = definedNamesRec++instance ClassMethods i (HsDeclI i) where+  classMethods c cnt = listBase (classMethods c cnt) . struct++instance ValueId i => AddName i (HsDeclI i) where addName = addNameRec++instance MapDefinedNames i (HsDeclI i) where mapDefinedNames = mapDefinedNamesRec+{-+instance DefinedNames i (HsPatI i) where+  definedNames = definedNamesRec+-}++instance (DefinedNames i b,DefinedNames i p) => DefinedNames i (Prop b p) where+  definedNames = prop definedNames definedNames++instance (ClassMethods i b,ClassMethods i p) => ClassMethods i (Prop b p) where+  classMethods c cnt = prop (classMethods c cnt) (classMethods c cnt)++instance (AddName i b,AddName i p) => AddName i (Prop b p) where+  addName = mapProp addName addName++instance (MapDefinedNames i b,MapDefinedNames i p)+      => MapDefinedNames i (Prop b p) where+  mapDefinedNames f = mapProp m m+    where m x = mapDefinedNames f x
+ tools/property/defs/DefinedNamesPropStruct.hs view
@@ -0,0 +1,27 @@+module DefinedNamesPropStruct where+import DefinedNames+import HsPropStruct+import HsIdent+import SrcLocPretty(shLineCol)+import TiNames(ValueId,localVal')++instance DefinedNames i (PD i e t) where+  definedNames (HsPropDecl s n ns e) = [(HsCon n,propName)] -- hmm+  definedNames (HsAssertion s (Just n) pa) = [(HsCon n,assertionName)] -- hmm+  definedNames _ = []++instance ClassMethods i (PD i e t) where+  classMethods c _ _ = []		++instance ValueId i => AddName i (PD i e t) where+  addName (HsAssertion s Nothing pa) = HsAssertion s (Just (defaultName s)) pa +    where+      defaultName s =+         localVal' ("UnnamedAssertion__"++shLineCol s) (Just s)+  addName d = d++propName = Property -- hmm, properties names are in a separate name space,+                    -- but data constructors can be used as properties...+assertionName = Assertion -- assertions can be used as properties too++instance MapDefinedNames i (PD i e t) where mapDefinedNames f = id
+ tools/property/defs/FreeNamesProp.hs view
@@ -0,0 +1,14 @@+module FreeNamesProp where+import PropSyntax+import FreeNames+import FreeNamesPropStruct+import FreeNamesBase+import DefinedNamesProp++instance Eq i => FreeNames i (HsDeclI i)    where freeNames = freeNamesRec+instance Eq i => FreeNames i (HsExpI i)     where freeNames = freeNamesRec+instance Eq i => FreeNames i (AssertionI i) where freeNames = freeNamesRec+instance Eq i => FreeNames i (PredicateI i) where freeNames = freeNamesRec++instance (FreeNames i b,FreeNames i p) => FreeNames i (Prop b p) where+ freeNames = prop freeNames freeNames
+ tools/property/defs/FreeNamesPropStruct.hs view
@@ -0,0 +1,53 @@+module FreeNamesPropStruct where+import FreeNames+import DefinedNames(DefinedNames)+import PropSyntaxStruct+import HsIdent+import Lists((\\\))++-- !!! Predicates are treated as constructors, which is probably not useful...++instance (Eq i,FreeNames i pa,FreeNames i pp) => FreeNames i (PD i pa pp) where+  freeNames (HsAssertion s optn pa) = filter (not.istyvar) (freeNames pa)+  freeNames (HsPropDecl s n ns pp) =+      filter (not.istyvar) (freeNames pp \\\ map val ns)+			  -- Assuming property declarations are recursive++instance (Eq i,FreeNames i e,FreeNames i t,FreeNames i pa,FreeNames i pp)+       => FreeNames i (PA i e t pa pp) where+  freeNames a =+    case a of+      Quant q i optt a -> freeNames optt ++ (freeNames a \\\ [var i])+--    PropId i ->  [val (HsCon i)]+      PropApp i ts e -> con i:freeNames (ts,e)+      PropNeg a -> freeNames a+      PropOp _ a1 a2 -> freeNames (a1,a2)+      PropEqual e1 e2 -> freeNames (e1,e2)+      PropHas e p -> freeNames (e,p) -- !!+      PropParen pa -> freeNames pa+--    PropLambda i pa -> freeNames pa \\\ [var i]+--    PropLet i optt e pa -> freeNames (optt,e)++(freeNames pa\\\ [var i])++instance (Eq i,FreeNames i e,FreeNames i p,FreeNames i t,+	  DefinedNames i p,+	  FreeNames i pa,FreeNames i pp)+      => FreeNames i (PP i e p t pa pp) where+  freeNames p =+    case p of+--    PredId i -> [val (HsCon i)]+      PredApp i ts p -> con i:freeNames (ts,p)+      PredArrow p1 p2 -> freeNames (p1,p2)+      PredInfixApp p1 i p2 -> con i:freeNames (p1,p2)+      PredNeg optt a -> freeNames (optt,a)+      PredOp _ optt a1 a2 -> freeNames (optt,a1,a2)+      PredLfp i optt p -> freeNames (p,optt)\\\[con i]+      PredGfp i optt p -> freeNames (p,optt)\\\[con i]+      PredNil -> []+      PredLifted e -> freeNames e+      PredStrong p -> freeNames p+      PredParen p -> freeNames p+      PredComp pts a -> freeNames ps ++ (freeNames a \\\ defs ps)+         where ps = map fst pts++instance (FreeNames i c,FreeNames i t) => FreeNames i (Q c t) where+   freeNames (c:=>t) = freeNames (c,t)
+ tools/property/defs/NameMapsProp.hs view
@@ -0,0 +1,35 @@+module NameMapsProp where+import NameMaps+import NameMapsPropStruct()+import NameMapsBaseStruct()+import NameMapsBase()+import PropSyntax+--import MUtils++instance AccNames i (HsExpI i) where accNames = accNamesRec+instance AccNames i (HsDeclI i) where accNames = accNamesRec+instance AccNames i (AssertionI i) where accNames = accNamesRec+instance AccNames i (PredicateI i) where accNames = accNamesRec++instance MapNames i1 (HsDeclI i1) i2 (HsDeclI i2) where mapNames2 = mapNames2Rec+instance MapNames i1 (HsExpI  i1) i2 (HsExpI  i2) where mapNames2 = mapNames2Rec+instance MapNames i1 (AssertionI i1) i2 (AssertionI i2) where mapNames2 = mapNames2Rec+instance MapNames i1 (PredicateI i1) i2 (PredicateI i2) where mapNames2 = mapNames2Rec++instance (Monad m,Functor m) => SeqNames m (HsDeclI (m i)) (HsDeclI i) where+  seqNames = seqNamesRec+instance (Monad m,Functor m) => SeqNames m (HsExpI (m i)) (HsExpI i) where+  seqNames = seqNamesRec+instance (Monad m,Functor m) => SeqNames m (AssertionI (m i)) (AssertionI i) where+  seqNames = seqNamesRec+instance (Monad m,Functor m) => SeqNames m (PredicateI (m i)) (PredicateI i) where+  seqNames = seqNamesRec++instance (MapNames i1 b1 i2 b2,MapNames i1 p1 i2 p2)+      => MapNames i1 (Prop b1 p1) i2 (Prop b2 p2)+  where mapNames2 d f = mapProp (mapNames2 d f) (mapNames2 d f)++instance (SeqNames m b1 b2,SeqNames m p1 p2)+       => SeqNames m (Prop b1 p1) (Prop b2 p2) where+  seqNames = seqProp . mapProp seqNames seqNames+
+ tools/property/defs/NameMapsPropStruct.hs view
@@ -0,0 +1,77 @@+module NameMapsPropStruct where+import NameMaps+import PropSyntaxStruct+import MUtils++instance (AccNames i e,AccNames i t,AccNames i pa,AccNames i pp)+      => AccNames i (PA i e t pa pp) where+  accNames f = accPA f a a a a+    where a x = accNames f x++instance (AccNames i e,AccNames i p,AccNames i t,AccNames i pa,AccNames i pp)+       => AccNames i (PP i e p t pa pp) where+  accNames f = accPP f a a a a a+    where a x = accNames f x++instance (AccNames i pa,AccNames i pp) => AccNames i (PD i pa pp) where+  accNames f = accPD f a a+    where a x = accNames f x++instance (MapNames i1 e1 i2 e2, MapNames i1 t1 i2 t2,+          MapNames i1 pa1 i2 pa2, MapNames i1 pp1 i2 pp2)+      => MapNames i1 (PA i1 e1 t1 pa1 pp1) i2 (PA i2 e2 t2 pa2 pp2) where+  mapNames2 d f@(vf,cf) pa =+      case pa of+        Quant q i optt pa -> Quant q (vf (defval Local) i) (ml # optt) (m pa)+        _ -> mapPA2 undefined (cf logic) m ml m m pa+    where+      m x = m' d x+      ml x = m' Local x+      m' dctx = mapNames2 dctx f++logic = (Logic,ValueNames)++instance (MapNames i1 e1 i2 e2, MapNames i1 p1 i2 p2, MapNames i1 t1 i2 t2,+          MapNames i1 pa1 i2 pa2, MapNames i1 pp1 i2 pp2)+      => MapNames i1 (PP i1 e1 p1 t1 pa1 pp1) i2 (PP i2 e2 p2 t2 pa2 pp2) where+  mapNames2 d f@(vf,cf) =+      mapPP2 undefined (cf logic) m m ml m m+    where+      m x = m' d x+      ml x = m' Local x+      m' dctx = mapNames2 dctx f++instance (MapNames i1 pa1 i2 pa2, MapNames i1 pp1 i2 pp2)+      => MapNames i1 (PD i1 pa1 pp1) i2 (PD i2 pa2 pp2) where+  mapNames2 d f@(vf,cf) pd =+      case pd of+        HsAssertion s optn a -> HsAssertion s (cf (defval d) # optn) (m a)+        HsPropDecl s n ns p -> HsPropDecl s (cf (defval d) n) (map dp ns) (m p)+    where+      m x = mapNames2 d f x+      dp = both (Def Pattern,ValueNames) mapHsIdent2 f++instance (SeqNames m e1 e2,SeqNames m t1 t2,+	  SeqNames m pa1 pa2,SeqNames m pp1 pp2)+      => SeqNames m (PA (m i) e1 t1 pa1 pp1) (PA i e2 t2 pa2 pp2) where+  seqNames = seqPA . mapPA id seqNames seqNames seqNames seqNames++instance (SeqNames m e1 e2,SeqNames m p1 p2,SeqNames m t1 t2,+	  SeqNames m pa1 pa2,SeqNames m pp1 pp2)+      => SeqNames m (PP (m i) e1 p1 t1 pa1 pp1) (PP i e2 p2 t2 pa2 pp2) where+  seqNames = seqPP . mapPP id seqNames seqNames seqNames seqNames seqNames++instance (SeqNames m pa1 pa2,SeqNames m pp1 pp2)+      => SeqNames m (PD (m i) pa1 pp1) (PD i pa2 pp2) where+  seqNames = seqPD . mapPD id seqNames seqNames++---++instance (SeqNames m c1 c2,SeqNames m t1 t2)+      => SeqNames m (Q c1 t1) (Q c2 t2) where+   seqNames (c:=>t) = (:=>) # seqNames c <# seqNames t++instance (MapNames i1 c1 i2 c2,MapNames i1 t1 i2 t2)+      => MapNames i1 (Q c1 t1) i2 (Q c2 t2) where+   mapNames2 d f (c:=>t) = m c:=>m t+      where m x = mapNames2 d f x
+ tools/property/defs/ReAssocProp.hs view
@@ -0,0 +1,25 @@+module ReAssocProp where+import HsAssoc+import ReAssoc+import ReAssocPropStruct+import ReAssocBaseStruct+import DefinedNamesProp+import PropSyntax+import HasBaseStruct+import ReAssocBase()++-- The property extension doesn't add any new kinds of infix declarations,+-- so it is enough to extract the ones in the base syntax.+instance HasInfixDecls i (HsDeclI i) where+  getInfixDecls = maybe emptyOE getInfixDecls . basestruct++instance Eq i => ReAssoc i (HsDeclI i)    where reAssoc = pReAssoc+instance Eq i => ReAssoc i (HsExpI i)     where reAssoc = reAssocRec+instance Eq i => ReAssoc i (AssertionI i) where reAssoc = reAssocRec+instance Eq i => ReAssoc i (PredicateI i) where reAssoc = reAssocRec++instance HasInfixApp i (HsExpI i) (HsExpI i) where+  infixApp e1 op e2 = base $ infixApp e1 op e2+  isInfixApp = isInfixApp . struct++pReAssoc env = mapRec $ mapProp (reAssoc env) (reAssoc env)
+ tools/property/defs/ReAssocPropStruct.hs view
@@ -0,0 +1,16 @@+module ReAssocPropStruct where+import ReAssoc+import HsPropStruct+import HsPropMaps(mapPD,mapPA,mapPP)++instance (ReAssoc i pa,ReAssoc i pp) => ReAssoc i (PD i pa pp) where+  reAssoc env = mapPD id (reAssoc env) (reAssoc env)++instance (ReAssoc i e,ReAssoc i pa,ReAssoc i pp) => ReAssoc i (PA i e t pa pp)+   where reAssoc env = mapPA id (reAssoc env) id (reAssoc env) (reAssoc env)++instance (ReAssoc i e,ReAssoc i p,ReAssoc i pa,ReAssoc i pp)+       => ReAssoc i (PP i e p t pa pp)+   where+     reAssoc env = mapPP id r r id r r+       where r x = reAssoc env x
+ tools/property/defs/ScopeNamesProp.hs view
@@ -0,0 +1,33 @@+module ScopeNamesProp where+import ScopeNames+import ScopeNamesPropStruct+import ScopeNamesBaseStruct+import ScopeNamesBase() -- instance for HsTypeI+import DefinedNamesProp()+import FreeNamesProp()+import PropSyntax+import MUtils++instance Eq i => ScopeNames i e (HsExpI i) (HsExpI (i,e)) where+   scopeNames = scopeNamesRec++instance Eq i => ScopeNames i e (HsDeclI i) (HsDeclI (i,e)) where+   scopeNames = scopeNamesRec++instance Eq i => ScopeNames i e (AssertionI i) (AssertionI (i,e)) where+   scopeNames = scopeNamesRec++instance Eq i => ScopeNames i e (PredicateI i) (PredicateI (i,e)) where+   scopeNames = scopeNamesRec++instance (ScopeNames i e b1 b2,ScopeNames i e p1 p2)+      => ScopeNames i e (Prop b1 p1) (Prop b2 p2) where+  scopeNames ext p = mapMProp sc sc p+    where sc x = scopeNames ext x++---++instance (ScopeNames i e c1 c2,ScopeNames i e t1 t2)+      => ScopeNames i e (Q c1 t1) (Q c2 t2) where+  scopeNames ext (c:=>t) = (:=>) # sc c <# sc t+     where sc x = scopeNames ext x
+ tools/property/defs/ScopeNamesPropStruct.hs view
@@ -0,0 +1,52 @@+module ScopeNamesPropStruct where+import ScopeNames+import ScopeNamesBaseStruct(extdef,exttvar,pairEnv)+import DefinedNames+import DefinedNamesPropStruct()+import FreeNames+import PropSyntaxStruct+--import MUtils+import EnvM++--extdef ext b = inModEnv . ext $ definedNames b++instance (ScopeNames i e pa1 pa2,ScopeNames i e pp1 pp2)+      => ScopeNames i e (PD i pa1 pp1) (PD (i,e) pa2 pp2) where+  scopeNames ext pd =+      case pd of+	HsPropDecl s n is p -> ex is scAll+	_ -> scAll+    where+      scAll = seqPD $ mapPD pairEnv m m pd+      ex ns = inModEnv (ext [(n,Value)|n<-ns])+      m x = scopeNames ext x++instance (ScopeNames i e e1 e2, ScopeNames i e t1 t2,FreeNames i t1,+          ScopeNames i e pa1 pa2, ScopeNames i e pp1 pp2)+      => ScopeNames i e (PA i e1 t1 pa1 pp1) (PA (i,e) e2 t2 pa2 pp2) where+  scopeNames ext pa =+      case pa of+	   -- The type variables in t scope over the whole expression+	Quant q i t pa' -> exttvar ext t (ex [HsVar i] scAll)+        _ -> scAll+    where+      scAll = seqPA $ mapPA pairEnv sc sc sc sc pa+      ex ns = inModEnv (ext [(n,Value)|n<-ns])+      sc x = scopeNames ext x++instance (ScopeNames i e e1 e2, ScopeNames i e p1 p2, ScopeNames i e t1 t2,+          ScopeNames i e pa1 pa2, ScopeNames i e pp1 pp2,+	  DefinedNames i p1,FreeNames i t1)+      => ScopeNames i e (PP i e1 p1 t1 pa1 pp1) (PP (i,e) e2 p2 t2 pa2 pp2) where+  scopeNames ext pp =+      case pp of+	PredLfp i optt pp' -> ex [HsCon i] scAll+	PredGfp i optt pp' -> ex [HsCon i] scAll+	PredComp pts pa ->+	   -- The type variables in pts scope over the whole expression+	  extdef ext (map fst pts) (exttvar ext (map snd pts) scAll)+        _ -> scAll+    where+      scAll = seqPP $ mapPP pairEnv m m m m m pp+      ex ns = inModEnv (ext [(n,Property)|n<-ns])+      m x = scopeNames ext x
+ tools/property/myhugs view
@@ -0,0 +1,4 @@++. HuMakefile+hugs -98 -P$SRC_DIRS: "$@"+# -h4M
+ tools/property/parse/extras/ParseUtil.hs view
@@ -0,0 +1,170 @@+-- $Id: ParseUtil.hs,v 1.7 2001/11/06 06:33:37 hallgren Exp $++{-++Utilities for the parser.++Author(s): Simon Marlow 1997, 1998;+           Emir Pasalic, Bill Harrison, Andrew Moran 2001++-}++module ParseUtil (--setInfix,        -- HsInfixDecl -> PM ()+		  splitTyConApp,   -- HsType -> PM (HsName, [HsType])+                  mkQuant,         -- HsQuantifier -> [HsPat] -> HsExp -> HsExp+		  mkValDef,        -- HsExp -> SrcLoc -> HsRhs HsExp+		                   --   -> [HsDecl] -> PM HsDecl+                  mkFunDef,        -- HsExp -> SrcLoc -> HsRhs HsExp+                                   --   -> [HsDecl] -> PM HsDecl+                  expToPat)        -- HsExp -> PM HsPat+where++import ParseMonad+--import Rewrite+--import HsAssoc+import PropSyntax+import PropSyntaxUtil(isConE)+import PrettyPrint++{-+-- Update the infix environment with infix information from declaration.+setInfix (HsInfixDecl sl (HsFixity prec assoc) names) = +  mapM (addToEnv prec assoc) names+  where +      addToEnv prec HsAssocNone  n =+	  do { s <- getInfixEnv ;+	       setInfixEnv $ extend s (HsInfix HsAssocNone  prec n)+	     }+      addToEnv prec HsAssocRight n =+	  do { s <- getInfixEnv ;+	       setInfixEnv $ extend s (HsInfix HsAssocLeft  prec n)+	     }+      addToEnv prec HsAssocLeft  n =+	  do { s <- getInfixEnv ;+	       setInfixEnv $ extend s (HsInfix HsAssocRight prec n)+	     }+-}++splitTyConApp :: HsType -> PM (HsName, [HsType])+splitTyConApp t = split t []+    where+    split :: HsType -> [HsType] -> PM (HsName, [HsType])+    split (Typ (HsTyApp t u)) ts = split t (u:ts)+    split (Typ (HsTyCon t))   ts = return (t, ts)+    split _                   _+        = parseError "illegal data/newtype declaration"++mkQuant :: HsQuantifier -> [HsPat] -> HsExp -> HsExp+mkQuant q ps (e @ (Exp (Prop (HsQuant q' ps' e'))))+    | q == q'   = hsQuant q (ps ++ ps') e'+    | otherwise = hsQuant q ps e+mkQuant q ps e  = hsQuant q ps e++mkValDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> PM HsDecl+mkValDef lhs sloc (HsBody b) wheres = +    do { lpat <- expToPat lhs ;+	 return $ hsPatBind sloc lpat (HsBody b) wheres+       }+mkValDef lhs sloc (HsGuard gds) wheres = +    do { lpat <- expToPat lhs ;+	 return $ hsPatBind sloc lpat (HsGuard gds) wheres+       }++mkFunDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> PM HsDecl+mkFunDef lhs sloc rhs wheres = +    do { (fnamePat, ps) <- getFundefPats lhs ; +	 case fnamePat of +         Pat (Base (HsPId (HsVar nm))) ->+              return $ hsFunBind sloc [HsMatch sloc nm ps rhs  wheres]+         _                      ->+              parseError $ "invalid function name in:\n\n" ++ pp lhs+       }+++getFundefPats :: HsExp -> PM (HsPat, [HsPat])+getFundefPats (Exp (Base pexp)) = +    case pexp of +    HsId (HsVar nm) -> return (hsPVar nm, [])+    HsApp l r ->  +        do { (pv, ps) <- getFundefPats l ;+             p        <- expToPat r ;+             return (pv, ps ++ [p])+	   }+    HsInfixApp l (HsVar n) r -> +        do { lp  <- expToPat l ;+             rp  <- expToPat r ;+             return (hsPVar n, [lp, rp])+	   }+    HsInfixApp l (HsCon n) r -> +        do { lp  <- expToPat l ;+             rp  <- expToPat r ;+             return (hsPCon n, [lp, rp])+	   }+    HsParen e -> getFundefPats e+    _     -> parseError $+	     "cannot use\n\n" ++ pp pexp +++	     "\n\nas a function definition pattern."+getFundefPats p =+    parseError $+    "cannot use\n\n" ++ pp p +++    "\n\nas a function definition pattern."+++expToPat :: HsExp -> PM HsPat+expToPat l@(Exp (Base lhexp))  = +    case lhexp of +      HsId (HsVar n) -> return $ hsPVar n+      HsId (HsCon n) -> return $ hsPCon n+      HsLit literal  -> return $ hsPLit literal+      HsNegApp  e    -> do { p <- expToPat e ; return $ hsPNeg p }+      HsLambda _ _   -> parseError "lambdas not allowed in patterns."+      HsList es      -> do { ps <- sequence (map expToPat es) ;+			     return $ hsPList ps+			   }+      HsTuple es     -> do { ps <- sequence (map expToPat es) ;+			     return $ hsPTuple ps+			   }+      HsWildCard     -> return hsPWildCard+      HsIrrPat e     -> do { p <- expToPat e ; return $ hsPIrrPat p }+      HsAsPat nm e   -> do { p <- expToPat e ; return $ hsPAsPat nm p}+      HsApp l r | isConE l  -> +                        do { let { Exp (Base (HsId (HsCon n))) = l } ;+			     rp <- expToPat r ;+			     return $ hsPApp n [rp]+			   }+                | otherwise ->+                        do { lp <- expToPat l ;+                             rp <- expToPat r ;+                             case lp of +                             Pat (Base (HsPApp n ps)) ->+			         return $ hsPApp n (ps ++ [rp])+                             _                 ->+			         parseError $+			         "Cannot use:\n\n" +++			         pp lhexp +++			         "\n\n as a pattern."+                           }+      HsInfixApp l (HsCon n) r -> +                        do { lp <- expToPat l ;+                             rp <- expToPat r ;+                             return $ hsPInfixApp lp (HsCon n) rp +			   }+      HsParen e                -> expToPat e+      HsRecConstr con fields   ->+                        do { pfs <- mapM fieldToPat fields ;+			     return $ hsPRec con pfs+			   }+      HsExpTypeSig _ e c t     ->+                        do { p <- expToPat e ;+                             return $ hsPatTypeSig p c t+                           }+      _                        ->+          parseError $ "ParseUtil.expToPat: not a valid/supported pattern:\n\n"+                       ++ pp lhexp+    where --fieldToPat (HsFieldBind f)     = return $ HsPFieldPun f+	  fieldToPat (HsFieldUpdate f e) = do { p <- expToPat e ;+						return $ HsPFieldPat f p+					      }+expToPat e  =+    parseError $ "ParseUtil.expToPat: not a valid/supported pattern:\n\n"+                 ++ pp e
+ tools/property/parse/extras/PropParser.hs view
@@ -0,0 +1,8205 @@+-- parser produced by Happy Version 1.11++module PropParser (parse) where+ ++import PropSyntax+import PropSyntaxUtil+import ParseMonad+import Lexer+import LexUtil(readInteger, readRational)+import ParseUtil+--import Rewrite+import IOExts+import Char(showLitChar)++data HappyAbsSyn +	= HappyTerminal Token+	| HappyErrorToken Int+	| HappyAbsSyn4 (HsModuleR)+	| HappyAbsSyn5 (([HsImportDecl], [HsDecl]))+	| HappyAbsSyn7 (())+	| HappyAbsSyn8 (Maybe [HsExportSpec])+	| HappyAbsSyn9 ([HsExportSpec])+	| HappyAbsSyn12 (HsExportSpec)+	| HappyAbsSyn13 ([HsName])+	| HappyAbsSyn14 (HsName)+	| HappyAbsSyn15 ([HsImportDecl])+	| HappyAbsSyn16 (HsImportDecl)+	| HappyAbsSyn17 (Bool)+	| HappyAbsSyn18 (Maybe Module)+	| HappyAbsSyn19 (Maybe (Bool, [HsImportSpec]))+	| HappyAbsSyn20 ((Bool, [HsImportSpec]))+	| HappyAbsSyn21 ([HsImportSpec])+	| HappyAbsSyn22 (HsImportSpec)+	| HappyAbsSyn25 ([HsDecl])+	| HappyAbsSyn26 (HsDecl)+	| HappyAbsSyn27 (Int)+	| HappyAbsSyn28 (HsAssoc)+	| HappyAbsSyn29 ([HsIdent])+	| HappyAbsSyn37 (HsType)+	| HappyAbsSyn41 (([HsType],HsType))+	| HappyAbsSyn42 ([HsType])+	| HappyAbsSyn43 (([HsType], [HsType]))+	| HappyAbsSyn46 (([HsType], HsName))+	| HappyAbsSyn47 ([HsConDecl HsType ])+	| HappyAbsSyn48 (HsConDecl HsType)+	| HappyAbsSyn49 ((HsName, [HsBangType HsType]))+	| HappyAbsSyn51 (HsBangType HsType)+	| HappyAbsSyn53 ([([HsName], HsBangType HsType)])+	| HappyAbsSyn54 (([HsName], HsBangType HsType))+	| HappyAbsSyn66 (HsRhs HsExp)+	| HappyAbsSyn67 ([(SrcLoc, HsExp, HsExp)])+	| HappyAbsSyn68 ((SrcLoc, HsExp, HsExp))+	| HappyAbsSyn69 (HsExp)+	| HappyAbsSyn73 ([HsExp])+	| HappyAbsSyn80 ([HsStmtAtom HsExp HsPat [HsDecl] ])+	| HappyAbsSyn81 (HsStmtAtom HsExp HsPat [HsDecl])+	| HappyAbsSyn82 ([HsAlt HsExp HsPat [HsDecl]])+	| HappyAbsSyn84 (HsAlt HsExp HsPat [HsDecl])+	| HappyAbsSyn88 ([HsStmtAtom HsExp HsPat [HsDecl]])+	| HappyAbsSyn91 ([HsFieldUpdate HsExp])+	| HappyAbsSyn92 (HsFieldUpdate HsExp)+	| HappyAbsSyn102 (HsIdent)+	| HappyAbsSyn115 (SrcLoc)+	| HappyAbsSyn119 (Module)+	| HappyAbsSyn126 (HsQuantifier)++type HappyReduction = +	   Int +	-> (Token)+	-> HappyState (Token) (HappyStk HappyAbsSyn -> PM(HappyAbsSyn))+	-> [HappyState (Token) (HappyStk HappyAbsSyn -> PM(HappyAbsSyn))] +	-> HappyStk HappyAbsSyn +	-> PM(HappyAbsSyn)++action_0,+ action_1,+ action_2,+ action_3,+ action_4,+ action_5,+ action_6,+ action_7,+ action_8,+ action_9,+ action_10,+ action_11,+ action_12,+ action_13,+ action_14,+ action_15,+ action_16,+ action_17,+ action_18,+ action_19,+ action_20,+ action_21,+ action_22,+ action_23,+ action_24,+ action_25,+ action_26,+ action_27,+ action_28,+ action_29,+ action_30,+ action_31,+ action_32,+ action_33,+ action_34,+ action_35,+ action_36,+ action_37,+ action_38,+ action_39,+ action_40,+ action_41,+ action_42,+ action_43,+ action_44,+ action_45,+ action_46,+ action_47,+ action_48,+ action_49,+ action_50,+ action_51,+ action_52,+ action_53,+ action_54,+ action_55,+ action_56,+ action_57,+ action_58,+ action_59,+ action_60,+ action_61,+ action_62,+ action_63,+ action_64,+ action_65,+ action_66,+ action_67,+ action_68,+ action_69,+ action_70,+ action_71,+ action_72,+ action_73,+ action_74,+ action_75,+ action_76,+ action_77,+ action_78,+ action_79,+ action_80,+ action_81,+ action_82,+ action_83,+ action_84,+ action_85,+ action_86,+ action_87,+ action_88,+ action_89,+ action_90,+ action_91,+ action_92,+ action_93,+ action_94,+ action_95,+ action_96,+ action_97,+ action_98,+ action_99,+ action_100,+ action_101,+ action_102,+ action_103,+ action_104,+ action_105,+ action_106,+ action_107,+ action_108,+ action_109,+ action_110,+ action_111,+ action_112,+ action_113,+ action_114,+ action_115,+ action_116,+ action_117,+ action_118,+ action_119,+ action_120,+ action_121,+ action_122,+ action_123,+ action_124,+ action_125,+ action_126,+ action_127,+ action_128,+ action_129,+ action_130,+ action_131,+ action_132,+ action_133,+ action_134,+ action_135,+ action_136,+ action_137,+ action_138,+ action_139,+ action_140,+ action_141,+ action_142,+ action_143,+ action_144,+ action_145,+ action_146,+ action_147,+ action_148,+ action_149,+ action_150,+ action_151,+ action_152,+ action_153,+ action_154,+ action_155,+ action_156,+ action_157,+ action_158,+ action_159,+ action_160,+ action_161,+ action_162,+ action_163,+ action_164,+ action_165,+ action_166,+ action_167,+ action_168,+ action_169,+ action_170,+ action_171,+ action_172,+ action_173,+ action_174,+ action_175,+ action_176,+ action_177,+ action_178,+ action_179,+ action_180,+ action_181,+ action_182,+ action_183,+ action_184,+ action_185,+ action_186,+ action_187,+ action_188,+ action_189,+ action_190,+ action_191,+ action_192,+ action_193,+ action_194,+ action_195,+ action_196,+ action_197,+ action_198,+ action_199,+ action_200,+ action_201,+ action_202,+ action_203,+ action_204,+ action_205,+ action_206,+ action_207,+ action_208,+ action_209,+ action_210,+ action_211,+ action_212,+ action_213,+ action_214,+ action_215,+ action_216,+ action_217,+ action_218,+ action_219,+ action_220,+ action_221,+ action_222,+ action_223,+ action_224,+ action_225,+ action_226,+ action_227,+ action_228,+ action_229,+ action_230,+ action_231,+ action_232,+ action_233,+ action_234,+ action_235,+ action_236,+ action_237,+ action_238,+ action_239,+ action_240,+ action_241,+ action_242,+ action_243,+ action_244,+ action_245,+ action_246,+ action_247,+ action_248,+ action_249,+ action_250,+ action_251,+ action_252,+ action_253,+ action_254,+ action_255,+ action_256,+ action_257,+ action_258,+ action_259,+ action_260,+ action_261,+ action_262,+ action_263,+ action_264,+ action_265,+ action_266,+ action_267,+ action_268,+ action_269,+ action_270,+ action_271,+ action_272,+ action_273,+ action_274,+ action_275,+ action_276,+ action_277,+ action_278,+ action_279,+ action_280,+ action_281,+ action_282,+ action_283,+ action_284,+ action_285,+ action_286,+ action_287,+ action_288,+ action_289,+ action_290,+ action_291,+ action_292,+ action_293,+ action_294,+ action_295,+ action_296,+ action_297,+ action_298,+ action_299,+ action_300,+ action_301,+ action_302,+ action_303,+ action_304,+ action_305,+ action_306,+ action_307,+ action_308,+ action_309,+ action_310,+ action_311,+ action_312,+ action_313,+ action_314,+ action_315,+ action_316,+ action_317,+ action_318,+ action_319,+ action_320,+ action_321,+ action_322,+ action_323,+ action_324,+ action_325,+ action_326,+ action_327,+ action_328,+ action_329,+ action_330,+ action_331,+ action_332,+ action_333,+ action_334,+ action_335,+ action_336,+ action_337,+ action_338,+ action_339,+ action_340,+ action_341,+ action_342,+ action_343,+ action_344,+ action_345,+ action_346,+ action_347,+ action_348,+ action_349,+ action_350,+ action_351,+ action_352,+ action_353,+ action_354,+ action_355,+ action_356,+ action_357,+ action_358,+ action_359,+ action_360,+ action_361,+ action_362,+ action_363,+ action_364,+ action_365,+ action_366,+ action_367,+ action_368,+ action_369,+ action_370,+ action_371,+ action_372,+ action_373,+ action_374,+ action_375,+ action_376,+ action_377,+ action_378,+ action_379,+ action_380,+ action_381,+ action_382,+ action_383,+ action_384,+ action_385,+ action_386,+ action_387,+ action_388,+ action_389,+ action_390,+ action_391,+ action_392,+ action_393,+ action_394,+ action_395,+ action_396,+ action_397,+ action_398,+ action_399,+ action_400,+ action_401,+ action_402,+ action_403,+ action_404,+ action_405,+ action_406,+ action_407,+ action_408,+ action_409,+ action_410,+ action_411,+ action_412,+ action_413,+ action_414,+ action_415,+ action_416,+ action_417,+ action_418,+ action_419,+ action_420,+ action_421,+ action_422,+ action_423,+ action_424,+ action_425,+ action_426,+ action_427,+ action_428,+ action_429,+ action_430,+ action_431,+ action_432,+ action_433,+ action_434,+ action_435,+ action_436,+ action_437,+ action_438,+ action_439,+ action_440,+ action_441,+ action_442,+ action_443,+ action_444,+ action_445,+ action_446,+ action_447,+ action_448,+ action_449,+ action_450,+ action_451,+ action_452,+ action_453,+ action_454,+ action_455,+ action_456,+ action_457,+ action_458,+ action_459,+ action_460,+ action_461,+ action_462,+ action_463,+ action_464,+ action_465,+ action_466,+ action_467,+ action_468,+ action_469,+ action_470,+ action_471,+ action_472,+ action_473,+ action_474,+ action_475,+ action_476,+ action_477,+ action_478,+ action_479,+ action_480,+ action_481,+ action_482,+ action_483,+ action_484,+ action_485,+ action_486,+ action_487,+ action_488,+ action_489,+ action_490,+ action_491,+ action_492,+ action_493,+ action_494,+ action_495,+ action_496,+ action_497,+ action_498,+ action_499,+ action_500,+ action_501,+ action_502,+ action_503,+ action_504,+ action_505,+ action_506,+ action_507,+ action_508,+ action_509,+ action_510,+ action_511,+ action_512,+ action_513,+ action_514,+ action_515,+ action_516,+ action_517,+ action_518,+ action_519,+ action_520,+ action_521,+ action_522,+ action_523,+ action_524,+ action_525,+ action_526,+ action_527,+ action_528,+ action_529,+ action_530,+ action_531,+ action_532 :: Int -> HappyReduction++happyReduce_1,+ happyReduce_2,+ happyReduce_3,+ happyReduce_4,+ happyReduce_5,+ happyReduce_6,+ happyReduce_7,+ happyReduce_8,+ happyReduce_9,+ happyReduce_10,+ happyReduce_11,+ happyReduce_12,+ happyReduce_13,+ happyReduce_14,+ happyReduce_15,+ happyReduce_16,+ happyReduce_17,+ happyReduce_18,+ happyReduce_19,+ happyReduce_20,+ happyReduce_21,+ happyReduce_22,+ happyReduce_23,+ happyReduce_24,+ happyReduce_25,+ happyReduce_26,+ happyReduce_27,+ happyReduce_28,+ happyReduce_29,+ happyReduce_30,+ happyReduce_31,+ happyReduce_32,+ happyReduce_33,+ happyReduce_34,+ happyReduce_35,+ happyReduce_36,+ happyReduce_37,+ happyReduce_38,+ happyReduce_39,+ happyReduce_40,+ happyReduce_41,+ happyReduce_42,+ happyReduce_43,+ happyReduce_44,+ happyReduce_45,+ happyReduce_46,+ happyReduce_47,+ happyReduce_48,+ happyReduce_49,+ happyReduce_50,+ happyReduce_51,+ happyReduce_52,+ happyReduce_53,+ happyReduce_54,+ happyReduce_55,+ happyReduce_56,+ happyReduce_57,+ happyReduce_58,+ happyReduce_59,+ happyReduce_60,+ happyReduce_61,+ happyReduce_62,+ happyReduce_63,+ happyReduce_64,+ happyReduce_65,+ happyReduce_66,+ happyReduce_67,+ happyReduce_68,+ happyReduce_69,+ happyReduce_70,+ happyReduce_71,+ happyReduce_72,+ happyReduce_73,+ happyReduce_74,+ happyReduce_75,+ happyReduce_76,+ happyReduce_77,+ happyReduce_78,+ happyReduce_79,+ happyReduce_80,+ happyReduce_81,+ happyReduce_82,+ happyReduce_83,+ happyReduce_84,+ happyReduce_85,+ happyReduce_86,+ happyReduce_87,+ happyReduce_88,+ happyReduce_89,+ happyReduce_90,+ happyReduce_91,+ happyReduce_92,+ happyReduce_93,+ happyReduce_94,+ happyReduce_95,+ happyReduce_96,+ happyReduce_97,+ happyReduce_98,+ happyReduce_99,+ happyReduce_100,+ happyReduce_101,+ happyReduce_102,+ happyReduce_103,+ happyReduce_104,+ happyReduce_105,+ happyReduce_106,+ happyReduce_107,+ happyReduce_108,+ happyReduce_109,+ happyReduce_110,+ happyReduce_111,+ happyReduce_112,+ happyReduce_113,+ happyReduce_114,+ happyReduce_115,+ happyReduce_116,+ happyReduce_117,+ happyReduce_118,+ happyReduce_119,+ happyReduce_120,+ happyReduce_121,+ happyReduce_122,+ happyReduce_123,+ happyReduce_124,+ happyReduce_125,+ happyReduce_126,+ happyReduce_127,+ happyReduce_128,+ happyReduce_129,+ happyReduce_130,+ happyReduce_131,+ happyReduce_132,+ happyReduce_133,+ happyReduce_134,+ happyReduce_135,+ happyReduce_136,+ happyReduce_137,+ happyReduce_138,+ happyReduce_139,+ happyReduce_140,+ happyReduce_141,+ happyReduce_142,+ happyReduce_143,+ happyReduce_144,+ happyReduce_145,+ happyReduce_146,+ happyReduce_147,+ happyReduce_148,+ happyReduce_149,+ happyReduce_150,+ happyReduce_151,+ happyReduce_152,+ happyReduce_153,+ happyReduce_154,+ happyReduce_155,+ happyReduce_156,+ happyReduce_157,+ happyReduce_158,+ happyReduce_159,+ happyReduce_160,+ happyReduce_161,+ happyReduce_162,+ happyReduce_163,+ happyReduce_164,+ happyReduce_165,+ happyReduce_166,+ happyReduce_167,+ happyReduce_168,+ happyReduce_169,+ happyReduce_170,+ happyReduce_171,+ happyReduce_172,+ happyReduce_173,+ happyReduce_174,+ happyReduce_175,+ happyReduce_176,+ happyReduce_177,+ happyReduce_178,+ happyReduce_179,+ happyReduce_180,+ happyReduce_181,+ happyReduce_182,+ happyReduce_183,+ happyReduce_184,+ happyReduce_185,+ happyReduce_186,+ happyReduce_187,+ happyReduce_188,+ happyReduce_189,+ happyReduce_190,+ happyReduce_191,+ happyReduce_192,+ happyReduce_193,+ happyReduce_194,+ happyReduce_195,+ happyReduce_196,+ happyReduce_197,+ happyReduce_198,+ happyReduce_199,+ happyReduce_200,+ happyReduce_201,+ happyReduce_202,+ happyReduce_203,+ happyReduce_204,+ happyReduce_205,+ happyReduce_206,+ happyReduce_207,+ happyReduce_208,+ happyReduce_209,+ happyReduce_210,+ happyReduce_211,+ happyReduce_212,+ happyReduce_213,+ happyReduce_214,+ happyReduce_215,+ happyReduce_216,+ happyReduce_217,+ happyReduce_218,+ happyReduce_219,+ happyReduce_220,+ happyReduce_221,+ happyReduce_222,+ happyReduce_223,+ happyReduce_224,+ happyReduce_225,+ happyReduce_226,+ happyReduce_227,+ happyReduce_228,+ happyReduce_229,+ happyReduce_230,+ happyReduce_231,+ happyReduce_232,+ happyReduce_233,+ happyReduce_234,+ happyReduce_235,+ happyReduce_236,+ happyReduce_237,+ happyReduce_238,+ happyReduce_239,+ happyReduce_240,+ happyReduce_241,+ happyReduce_242,+ happyReduce_243,+ happyReduce_244,+ happyReduce_245,+ happyReduce_246,+ happyReduce_247,+ happyReduce_248,+ happyReduce_249,+ happyReduce_250,+ happyReduce_251,+ happyReduce_252,+ happyReduce_253,+ happyReduce_254,+ happyReduce_255,+ happyReduce_256,+ happyReduce_257,+ happyReduce_258,+ happyReduce_259,+ happyReduce_260,+ happyReduce_261,+ happyReduce_262,+ happyReduce_263,+ happyReduce_264,+ happyReduce_265,+ happyReduce_266,+ happyReduce_267,+ happyReduce_268,+ happyReduce_269,+ happyReduce_270,+ happyReduce_271,+ happyReduce_272,+ happyReduce_273,+ happyReduce_274,+ happyReduce_275,+ happyReduce_276,+ happyReduce_277,+ happyReduce_278,+ happyReduce_279,+ happyReduce_280,+ happyReduce_281,+ happyReduce_282,+ happyReduce_283,+ happyReduce_284,+ happyReduce_285,+ happyReduce_286,+ happyReduce_287,+ happyReduce_288,+ happyReduce_289,+ happyReduce_290,+ happyReduce_291,+ happyReduce_292,+ happyReduce_293,+ happyReduce_294,+ happyReduce_295 :: HappyReduction++action_0 (145) = happyShift action_6+action_0 (182) = happyShift action_2+action_0 (4) = happyGoto action_3+action_0 (5) = happyGoto action_4+action_0 (118) = happyGoto action_5+action_0 _ = happyReduce_282++action_1 (182) = happyShift action_2+action_1 _ = happyFail++action_2 (130) = happyShift action_73+action_2 (119) = happyGoto action_72+action_2 _ = happyFail++action_3 (195) = happyAccept+action_3 _ = happyFail++action_4 _ = happyReduce_2++action_5 (128) = happyShift action_34+action_5 (129) = happyShift action_35+action_5 (130) = happyShift action_36+action_5 (131) = happyShift action_37+action_5 (132) = happyShift action_38+action_5 (137) = happyShift action_39+action_5 (138) = happyShift action_40+action_5 (139) = happyShift action_41+action_5 (140) = happyShift action_42+action_5 (141) = happyShift action_43+action_5 (142) = happyShift action_44+action_5 (148) = happyShift action_45+action_5 (151) = happyShift action_46+action_5 (157) = happyShift action_47+action_5 (162) = happyShift action_48+action_5 (165) = happyShift action_49+action_5 (166) = happyShift action_50+action_5 (167) = happyShift action_51+action_5 (168) = happyShift action_52+action_5 (169) = happyShift action_53+action_5 (171) = happyShift action_54+action_5 (173) = happyShift action_55+action_5 (174) = happyShift action_56+action_5 (175) = happyShift action_57+action_5 (177) = happyShift action_58+action_5 (178) = happyShift action_59+action_5 (179) = happyShift action_60+action_5 (180) = happyShift action_61+action_5 (181) = happyShift action_62+action_5 (183) = happyShift action_63+action_5 (186) = happyShift action_64+action_5 (188) = happyShift action_65+action_5 (189) = happyShift action_66+action_5 (190) = happyShift action_67+action_5 (191) = happyShift action_68+action_5 (192) = happyShift action_69+action_5 (193) = happyShift action_70+action_5 (194) = happyShift action_71+action_5 (6) = happyGoto action_8+action_5 (15) = happyGoto action_9+action_5 (16) = happyGoto action_10+action_5 (25) = happyGoto action_11+action_5 (26) = happyGoto action_12+action_5 (28) = happyGoto action_13+action_5 (30) = happyGoto action_14+action_5 (33) = happyGoto action_15+action_5 (35) = happyGoto action_16+action_5 (36) = happyGoto action_17+action_5 (64) = happyGoto action_18+action_5 (70) = happyGoto action_19+action_5 (71) = happyGoto action_20+action_5 (72) = happyGoto action_21+action_5 (74) = happyGoto action_22+action_5 (75) = happyGoto action_23+action_5 (93) = happyGoto action_24+action_5 (95) = happyGoto action_25+action_5 (97) = happyGoto action_26+action_5 (104) = happyGoto action_27+action_5 (105) = happyGoto action_28+action_5 (106) = happyGoto action_29+action_5 (108) = happyGoto action_30+action_5 (114) = happyGoto action_31+action_5 (125) = happyGoto action_32+action_5 (126) = happyGoto action_33+action_5 _ = happyReduce_8++action_6 (117) = happyGoto action_7+action_6 _ = happyReduce_281++action_7 (128) = happyShift action_34+action_7 (129) = happyShift action_35+action_7 (130) = happyShift action_36+action_7 (131) = happyShift action_37+action_7 (132) = happyShift action_38+action_7 (137) = happyShift action_39+action_7 (138) = happyShift action_40+action_7 (139) = happyShift action_41+action_7 (140) = happyShift action_42+action_7 (141) = happyShift action_43+action_7 (142) = happyShift action_44+action_7 (148) = happyShift action_45+action_7 (151) = happyShift action_46+action_7 (157) = happyShift action_47+action_7 (162) = happyShift action_48+action_7 (165) = happyShift action_49+action_7 (166) = happyShift action_50+action_7 (167) = happyShift action_51+action_7 (168) = happyShift action_52+action_7 (169) = happyShift action_53+action_7 (171) = happyShift action_54+action_7 (173) = happyShift action_55+action_7 (174) = happyShift action_56+action_7 (175) = happyShift action_57+action_7 (177) = happyShift action_58+action_7 (178) = happyShift action_59+action_7 (179) = happyShift action_60+action_7 (180) = happyShift action_61+action_7 (181) = happyShift action_62+action_7 (183) = happyShift action_63+action_7 (186) = happyShift action_64+action_7 (188) = happyShift action_65+action_7 (189) = happyShift action_66+action_7 (190) = happyShift action_67+action_7 (191) = happyShift action_68+action_7 (192) = happyShift action_69+action_7 (193) = happyShift action_70+action_7 (194) = happyShift action_71+action_7 (6) = happyGoto action_148+action_7 (15) = happyGoto action_9+action_7 (16) = happyGoto action_10+action_7 (25) = happyGoto action_11+action_7 (26) = happyGoto action_12+action_7 (28) = happyGoto action_13+action_7 (30) = happyGoto action_14+action_7 (33) = happyGoto action_15+action_7 (35) = happyGoto action_16+action_7 (36) = happyGoto action_17+action_7 (64) = happyGoto action_18+action_7 (70) = happyGoto action_19+action_7 (71) = happyGoto action_20+action_7 (72) = happyGoto action_21+action_7 (74) = happyGoto action_22+action_7 (75) = happyGoto action_23+action_7 (93) = happyGoto action_24+action_7 (95) = happyGoto action_25+action_7 (97) = happyGoto action_26+action_7 (104) = happyGoto action_27+action_7 (105) = happyGoto action_28+action_7 (106) = happyGoto action_29+action_7 (108) = happyGoto action_30+action_7 (114) = happyGoto action_31+action_7 (125) = happyGoto action_32+action_7 (126) = happyGoto action_33+action_7 _ = happyReduce_8++action_8 (1) = happyShift action_146+action_8 (147) = happyShift action_147+action_8 (116) = happyGoto action_145+action_8 _ = happyFail++action_9 (144) = happyShift action_144+action_9 (7) = happyGoto action_143+action_9 _ = happyReduce_10++action_10 _ = happyReduce_30++action_11 (144) = happyShift action_142+action_11 (7) = happyGoto action_141+action_11 _ = happyReduce_10++action_12 _ = happyReduce_75++action_13 (115) = happyGoto action_140+action_13 _ = happyReduce_278++action_14 _ = happyReduce_52++action_15 _ = happyReduce_69++action_16 _ = happyReduce_74++action_17 (150) = happyShift action_139+action_17 (115) = happyGoto action_138+action_17 _ = happyReduce_278++action_18 _ = happyReduce_76++action_19 (132) = happyShift action_137+action_19 (133) = happyShift action_118+action_19 (134) = happyShift action_119+action_19 (135) = happyShift action_120+action_19 (136) = happyShift action_121+action_19 (152) = happyShift action_124+action_19 (153) = happyShift action_125+action_19 (164) = happyShift action_126+action_19 (99) = happyGoto action_109+action_19 (101) = happyGoto action_110+action_19 (103) = happyGoto action_133+action_19 (109) = happyGoto action_134+action_19 (110) = happyGoto action_113+action_19 (111) = happyGoto action_135+action_19 (112) = happyGoto action_115+action_19 (113) = happyGoto action_116+action_19 (115) = happyGoto action_136+action_19 _ = happyReduce_278++action_20 _ = happyReduce_161++action_21 (128) = happyShift action_34+action_21 (129) = happyShift action_35+action_21 (130) = happyShift action_36+action_21 (131) = happyShift action_37+action_21 (137) = happyShift action_39+action_21 (138) = happyShift action_40+action_21 (139) = happyShift action_41+action_21 (140) = happyShift action_42+action_21 (141) = happyShift action_43+action_21 (142) = happyShift action_44+action_21 (148) = happyShift action_45+action_21 (151) = happyShift action_46+action_21 (162) = happyShift action_48+action_21 (165) = happyShift action_49+action_21 (173) = happyShift action_55+action_21 (188) = happyShift action_65+action_21 (74) = happyGoto action_132+action_21 (75) = happyGoto action_23+action_21 (93) = happyGoto action_24+action_21 (95) = happyGoto action_90+action_21 (97) = happyGoto action_26+action_21 (104) = happyGoto action_27+action_21 (105) = happyGoto action_28+action_21 (106) = happyGoto action_29+action_21 (108) = happyGoto action_30+action_21 (114) = happyGoto action_31+action_21 _ = happyReduce_170++action_22 (145) = happyShift action_131+action_22 _ = happyReduce_172++action_23 _ = happyReduce_176++action_24 _ = happyReduce_178++action_25 (150) = happyReduce_82+action_25 (155) = happyReduce_82+action_25 (161) = happyShift action_130+action_25 _ = happyReduce_177++action_26 _ = happyReduce_232++action_27 _ = happyReduce_235++action_28 _ = happyReduce_253++action_29 _ = happyReduce_239++action_30 _ = happyReduce_259++action_31 _ = happyReduce_179++action_32 _ = happyReduce_77++action_33 (128) = happyShift action_34+action_33 (129) = happyShift action_35+action_33 (130) = happyShift action_36+action_33 (131) = happyShift action_37+action_33 (137) = happyShift action_39+action_33 (138) = happyShift action_40+action_33 (139) = happyShift action_41+action_33 (140) = happyShift action_42+action_33 (141) = happyShift action_43+action_33 (142) = happyShift action_44+action_33 (148) = happyShift action_45+action_33 (151) = happyShift action_46+action_33 (162) = happyShift action_48+action_33 (165) = happyShift action_49+action_33 (173) = happyShift action_55+action_33 (188) = happyShift action_65+action_33 (73) = happyGoto action_129+action_33 (74) = happyGoto action_100+action_33 (75) = happyGoto action_23+action_33 (93) = happyGoto action_24+action_33 (95) = happyGoto action_90+action_33 (97) = happyGoto action_26+action_33 (104) = happyGoto action_27+action_33 (105) = happyGoto action_28+action_33 (106) = happyGoto action_29+action_33 (108) = happyGoto action_30+action_33 (114) = happyGoto action_31+action_33 _ = happyFail++action_34 _ = happyReduce_255++action_35 _ = happyReduce_254++action_36 _ = happyReduce_263++action_37 _ = happyReduce_260++action_38 (128) = happyShift action_34+action_38 (129) = happyShift action_35+action_38 (130) = happyShift action_36+action_38 (131) = happyShift action_37+action_38 (137) = happyShift action_39+action_38 (138) = happyShift action_40+action_38 (139) = happyShift action_41+action_38 (140) = happyShift action_42+action_38 (141) = happyShift action_43+action_38 (142) = happyShift action_44+action_38 (148) = happyShift action_45+action_38 (151) = happyShift action_46+action_38 (162) = happyShift action_48+action_38 (165) = happyShift action_49+action_38 (173) = happyShift action_55+action_38 (188) = happyShift action_65+action_38 (72) = happyGoto action_128+action_38 (74) = happyGoto action_22+action_38 (75) = happyGoto action_23+action_38 (93) = happyGoto action_24+action_38 (95) = happyGoto action_90+action_38 (97) = happyGoto action_26+action_38 (104) = happyGoto action_27+action_38 (105) = happyGoto action_28+action_38 (106) = happyGoto action_29+action_38 (108) = happyGoto action_30+action_38 (114) = happyGoto action_31+action_38 _ = happyFail++action_39 (153) = happyShift action_127+action_39 _ = happyFail++action_40 _ = happyReduce_274++action_41 _ = happyReduce_277++action_42 _ = happyReduce_275++action_43 _ = happyReduce_276++action_44 (128) = happyShift action_34+action_44 (129) = happyShift action_35+action_44 (130) = happyShift action_36+action_44 (131) = happyShift action_37+action_44 (132) = happyShift action_117+action_44 (133) = happyShift action_118+action_44 (134) = happyShift action_119+action_44 (135) = happyShift action_120+action_44 (136) = happyShift action_121+action_44 (137) = happyShift action_39+action_44 (138) = happyShift action_40+action_44 (139) = happyShift action_41+action_44 (140) = happyShift action_42+action_44 (141) = happyShift action_43+action_44 (142) = happyShift action_44+action_44 (143) = happyShift action_122+action_44 (148) = happyShift action_45+action_44 (150) = happyShift action_123+action_44 (151) = happyShift action_46+action_44 (152) = happyShift action_124+action_44 (153) = happyShift action_125+action_44 (157) = happyShift action_47+action_44 (162) = happyShift action_48+action_44 (164) = happyShift action_126+action_44 (165) = happyShift action_49+action_44 (166) = happyShift action_50+action_44 (171) = happyShift action_54+action_44 (173) = happyShift action_55+action_44 (174) = happyShift action_56+action_44 (181) = happyShift action_62+action_44 (188) = happyShift action_65+action_44 (191) = happyShift action_68+action_44 (192) = happyShift action_69+action_44 (193) = happyShift action_70+action_44 (194) = happyShift action_71+action_44 (69) = happyGoto action_105+action_44 (70) = happyGoto action_106+action_44 (71) = happyGoto action_20+action_44 (72) = happyGoto action_21+action_44 (74) = happyGoto action_22+action_44 (75) = happyGoto action_23+action_44 (76) = happyGoto action_107+action_44 (77) = happyGoto action_108+action_44 (93) = happyGoto action_24+action_44 (95) = happyGoto action_90+action_44 (97) = happyGoto action_26+action_44 (99) = happyGoto action_109+action_44 (101) = happyGoto action_110+action_44 (103) = happyGoto action_111+action_44 (104) = happyGoto action_27+action_44 (105) = happyGoto action_28+action_44 (106) = happyGoto action_29+action_44 (108) = happyGoto action_30+action_44 (109) = happyGoto action_112+action_44 (110) = happyGoto action_113+action_44 (111) = happyGoto action_114+action_44 (112) = happyGoto action_115+action_44 (113) = happyGoto action_116+action_44 (114) = happyGoto action_31+action_44 (126) = happyGoto action_33+action_44 _ = happyFail++action_45 (128) = happyShift action_34+action_45 (129) = happyShift action_35+action_45 (130) = happyShift action_36+action_45 (131) = happyShift action_37+action_45 (132) = happyShift action_38+action_45 (137) = happyShift action_39+action_45 (138) = happyShift action_40+action_45 (139) = happyShift action_41+action_45 (140) = happyShift action_42+action_45 (141) = happyShift action_43+action_45 (142) = happyShift action_44+action_45 (148) = happyShift action_45+action_45 (149) = happyShift action_104+action_45 (151) = happyShift action_46+action_45 (157) = happyShift action_47+action_45 (162) = happyShift action_48+action_45 (165) = happyShift action_49+action_45 (166) = happyShift action_50+action_45 (171) = happyShift action_54+action_45 (173) = happyShift action_55+action_45 (174) = happyShift action_56+action_45 (181) = happyShift action_62+action_45 (188) = happyShift action_65+action_45 (191) = happyShift action_68+action_45 (192) = happyShift action_69+action_45 (193) = happyShift action_70+action_45 (194) = happyShift action_71+action_45 (69) = happyGoto action_101+action_45 (70) = happyGoto action_89+action_45 (71) = happyGoto action_20+action_45 (72) = happyGoto action_21+action_45 (74) = happyGoto action_22+action_45 (75) = happyGoto action_23+action_45 (78) = happyGoto action_102+action_45 (79) = happyGoto action_103+action_45 (93) = happyGoto action_24+action_45 (95) = happyGoto action_90+action_45 (97) = happyGoto action_26+action_45 (104) = happyGoto action_27+action_45 (105) = happyGoto action_28+action_45 (106) = happyGoto action_29+action_45 (108) = happyGoto action_30+action_45 (114) = happyGoto action_31+action_45 (126) = happyGoto action_33+action_45 _ = happyFail++action_46 _ = happyReduce_186++action_47 (128) = happyShift action_34+action_47 (129) = happyShift action_35+action_47 (130) = happyShift action_36+action_47 (131) = happyShift action_37+action_47 (137) = happyShift action_39+action_47 (138) = happyShift action_40+action_47 (139) = happyShift action_41+action_47 (140) = happyShift action_42+action_47 (141) = happyShift action_43+action_47 (142) = happyShift action_44+action_47 (148) = happyShift action_45+action_47 (151) = happyShift action_46+action_47 (162) = happyShift action_48+action_47 (165) = happyShift action_49+action_47 (173) = happyShift action_55+action_47 (188) = happyShift action_65+action_47 (73) = happyGoto action_99+action_47 (74) = happyGoto action_100+action_47 (75) = happyGoto action_23+action_47 (93) = happyGoto action_24+action_47 (95) = happyGoto action_90+action_47 (97) = happyGoto action_26+action_47 (104) = happyGoto action_27+action_47 (105) = happyGoto action_28+action_47 (106) = happyGoto action_29+action_47 (108) = happyGoto action_30+action_47 (114) = happyGoto action_31+action_47 _ = happyFail++action_48 (128) = happyShift action_34+action_48 (129) = happyShift action_35+action_48 (130) = happyShift action_36+action_48 (131) = happyShift action_37+action_48 (137) = happyShift action_39+action_48 (138) = happyShift action_40+action_48 (139) = happyShift action_41+action_48 (140) = happyShift action_42+action_48 (141) = happyShift action_43+action_48 (142) = happyShift action_44+action_48 (148) = happyShift action_45+action_48 (151) = happyShift action_46+action_48 (162) = happyShift action_48+action_48 (165) = happyShift action_49+action_48 (173) = happyShift action_55+action_48 (188) = happyShift action_65+action_48 (75) = happyGoto action_98+action_48 (93) = happyGoto action_24+action_48 (95) = happyGoto action_90+action_48 (97) = happyGoto action_26+action_48 (104) = happyGoto action_27+action_48 (105) = happyGoto action_28+action_48 (106) = happyGoto action_29+action_48 (108) = happyGoto action_30+action_48 (114) = happyGoto action_31+action_48 _ = happyFail++action_49 _ = happyReduce_256++action_50 (128) = happyShift action_34+action_50 (129) = happyShift action_35+action_50 (130) = happyShift action_36+action_50 (131) = happyShift action_37+action_50 (132) = happyShift action_38+action_50 (137) = happyShift action_39+action_50 (138) = happyShift action_40+action_50 (139) = happyShift action_41+action_50 (140) = happyShift action_42+action_50 (141) = happyShift action_43+action_50 (142) = happyShift action_44+action_50 (148) = happyShift action_45+action_50 (151) = happyShift action_46+action_50 (157) = happyShift action_47+action_50 (162) = happyShift action_48+action_50 (165) = happyShift action_49+action_50 (166) = happyShift action_50+action_50 (171) = happyShift action_54+action_50 (173) = happyShift action_55+action_50 (174) = happyShift action_56+action_50 (181) = happyShift action_62+action_50 (188) = happyShift action_65+action_50 (191) = happyShift action_68+action_50 (192) = happyShift action_69+action_50 (193) = happyShift action_70+action_50 (194) = happyShift action_71+action_50 (69) = happyGoto action_97+action_50 (70) = happyGoto action_89+action_50 (71) = happyGoto action_20+action_50 (72) = happyGoto action_21+action_50 (74) = happyGoto action_22+action_50 (75) = happyGoto action_23+action_50 (93) = happyGoto action_24+action_50 (95) = happyGoto action_90+action_50 (97) = happyGoto action_26+action_50 (104) = happyGoto action_27+action_50 (105) = happyGoto action_28+action_50 (106) = happyGoto action_29+action_50 (108) = happyGoto action_30+action_50 (114) = happyGoto action_31+action_50 (126) = happyGoto action_33+action_50 _ = happyFail++action_51 (115) = happyGoto action_96+action_51 _ = happyReduce_278++action_52 (115) = happyGoto action_95+action_52 _ = happyReduce_278++action_53 (115) = happyGoto action_94+action_53 _ = happyReduce_278++action_54 (145) = happyShift action_93+action_54 (88) = happyGoto action_91+action_54 (118) = happyGoto action_92+action_54 _ = happyReduce_282++action_55 _ = happyReduce_258++action_56 (128) = happyShift action_34+action_56 (129) = happyShift action_35+action_56 (130) = happyShift action_36+action_56 (131) = happyShift action_37+action_56 (132) = happyShift action_38+action_56 (137) = happyShift action_39+action_56 (138) = happyShift action_40+action_56 (139) = happyShift action_41+action_56 (140) = happyShift action_42+action_56 (141) = happyShift action_43+action_56 (142) = happyShift action_44+action_56 (148) = happyShift action_45+action_56 (151) = happyShift action_46+action_56 (157) = happyShift action_47+action_56 (162) = happyShift action_48+action_56 (165) = happyShift action_49+action_56 (166) = happyShift action_50+action_56 (171) = happyShift action_54+action_56 (173) = happyShift action_55+action_56 (174) = happyShift action_56+action_56 (181) = happyShift action_62+action_56 (188) = happyShift action_65+action_56 (191) = happyShift action_68+action_56 (192) = happyShift action_69+action_56 (193) = happyShift action_70+action_56 (194) = happyShift action_71+action_56 (69) = happyGoto action_88+action_56 (70) = happyGoto action_89+action_56 (71) = happyGoto action_20+action_56 (72) = happyGoto action_21+action_56 (74) = happyGoto action_22+action_56 (75) = happyGoto action_23+action_56 (93) = happyGoto action_24+action_56 (95) = happyGoto action_90+action_56 (97) = happyGoto action_26+action_56 (104) = happyGoto action_27+action_56 (105) = happyGoto action_28+action_56 (106) = happyGoto action_29+action_56 (108) = happyGoto action_30+action_56 (114) = happyGoto action_31+action_56 (126) = happyGoto action_33+action_56 _ = happyFail++action_57 (115) = happyGoto action_87+action_57 _ = happyReduce_278++action_58 _ = happyReduce_56++action_59 _ = happyReduce_57++action_60 _ = happyReduce_58++action_61 (115) = happyGoto action_86+action_61 _ = happyReduce_278++action_62 (145) = happyShift action_85+action_62 (34) = happyGoto action_83+action_62 (118) = happyGoto action_84+action_62 _ = happyReduce_282++action_63 (115) = happyGoto action_82+action_63 _ = happyReduce_278++action_64 (130) = happyShift action_36+action_64 (44) = happyGoto action_79+action_64 (108) = happyGoto action_80+action_64 (121) = happyGoto action_81+action_64 _ = happyFail++action_65 _ = happyReduce_257++action_66 (115) = happyGoto action_78+action_66 _ = happyReduce_278++action_67 (115) = happyGoto action_77+action_67 _ = happyReduce_278++action_68 _ = happyReduce_290++action_69 _ = happyReduce_291++action_70 _ = happyReduce_292++action_71 _ = happyReduce_293++action_72 (142) = happyShift action_76+action_72 (8) = happyGoto action_74+action_72 (9) = happyGoto action_75+action_72 _ = happyReduce_12++action_73 _ = happyReduce_283++action_74 (187) = happyShift action_244+action_74 _ = happyFail++action_75 _ = happyReduce_11++action_76 (128) = happyShift action_34+action_76 (129) = happyShift action_35+action_76 (130) = happyShift action_36+action_76 (131) = happyShift action_200+action_76 (142) = happyShift action_241+action_76 (143) = happyShift action_242+action_76 (165) = happyShift action_49+action_76 (173) = happyShift action_55+action_76 (182) = happyShift action_243+action_76 (188) = happyShift action_65+action_76 (11) = happyGoto action_236+action_76 (12) = happyGoto action_237+action_76 (95) = happyGoto action_238+action_76 (104) = happyGoto action_27+action_76 (105) = happyGoto action_28+action_76 (107) = happyGoto action_239+action_76 (108) = happyGoto action_80+action_76 (121) = happyGoto action_198+action_76 (122) = happyGoto action_240+action_76 _ = happyFail++action_77 (130) = happyShift action_36+action_77 (108) = happyGoto action_235+action_77 _ = happyFail++action_78 (128) = happyShift action_34+action_78 (142) = happyShift action_157+action_78 (165) = happyShift action_49+action_78 (173) = happyShift action_55+action_78 (188) = happyShift action_65+action_78 (94) = happyGoto action_234+action_78 (105) = happyGoto action_156+action_78 _ = happyFail++action_79 (115) = happyGoto action_233+action_79 _ = happyReduce_278++action_80 _ = happyReduce_285++action_81 (128) = happyShift action_34+action_81 (165) = happyShift action_49+action_81 (173) = happyShift action_55+action_81 (188) = happyShift action_65+action_81 (45) = happyGoto action_231+action_81 (105) = happyGoto action_196+action_81 (124) = happyGoto action_232+action_81 _ = happyReduce_107++action_82 (128) = happyShift action_34+action_82 (130) = happyShift action_36+action_82 (131) = happyShift action_200+action_82 (137) = happyShift action_201+action_82 (142) = happyShift action_202+action_82 (148) = happyShift action_203+action_82 (165) = happyShift action_49+action_82 (173) = happyShift action_55+action_82 (188) = happyShift action_65+action_82 (37) = happyGoto action_228+action_82 (38) = happyGoto action_192+action_82 (39) = happyGoto action_193+action_82 (40) = happyGoto action_194+action_82 (43) = happyGoto action_229+action_82 (44) = happyGoto action_206+action_82 (105) = happyGoto action_196+action_82 (107) = happyGoto action_197+action_82 (108) = happyGoto action_80+action_82 (121) = happyGoto action_230+action_82 (124) = happyGoto action_199+action_82 _ = happyFail++action_83 (176) = happyShift action_227+action_83 _ = happyFail++action_84 (128) = happyShift action_34+action_84 (129) = happyShift action_35+action_84 (130) = happyShift action_36+action_84 (131) = happyShift action_37+action_84 (132) = happyShift action_38+action_84 (137) = happyShift action_39+action_84 (138) = happyShift action_40+action_84 (139) = happyShift action_41+action_84 (140) = happyShift action_42+action_84 (141) = happyShift action_43+action_84 (142) = happyShift action_44+action_84 (144) = happyShift action_226+action_84 (148) = happyShift action_45+action_84 (151) = happyShift action_46+action_84 (157) = happyShift action_47+action_84 (162) = happyShift action_48+action_84 (165) = happyShift action_49+action_84 (166) = happyShift action_50+action_84 (171) = happyShift action_54+action_84 (173) = happyShift action_55+action_84 (174) = happyShift action_56+action_84 (177) = happyShift action_58+action_84 (178) = happyShift action_59+action_84 (179) = happyShift action_60+action_84 (181) = happyShift action_62+action_84 (188) = happyShift action_65+action_84 (190) = happyShift action_67+action_84 (191) = happyShift action_68+action_84 (192) = happyShift action_69+action_84 (193) = happyShift action_70+action_84 (194) = happyShift action_71+action_84 (7) = happyGoto action_222+action_84 (26) = happyGoto action_12+action_84 (28) = happyGoto action_13+action_84 (31) = happyGoto action_223+action_84 (32) = happyGoto action_224+action_84 (33) = happyGoto action_225+action_84 (35) = happyGoto action_16+action_84 (36) = happyGoto action_17+action_84 (64) = happyGoto action_18+action_84 (70) = happyGoto action_19+action_84 (71) = happyGoto action_20+action_84 (72) = happyGoto action_21+action_84 (74) = happyGoto action_22+action_84 (75) = happyGoto action_23+action_84 (93) = happyGoto action_24+action_84 (95) = happyGoto action_25+action_84 (97) = happyGoto action_26+action_84 (104) = happyGoto action_27+action_84 (105) = happyGoto action_28+action_84 (106) = happyGoto action_29+action_84 (108) = happyGoto action_30+action_84 (114) = happyGoto action_31+action_84 (125) = happyGoto action_32+action_84 (126) = happyGoto action_33+action_84 _ = happyReduce_10++action_85 (117) = happyGoto action_221+action_85 _ = happyReduce_281++action_86 (128) = happyShift action_34+action_86 (130) = happyShift action_36+action_86 (131) = happyShift action_200+action_86 (137) = happyShift action_201+action_86 (142) = happyShift action_202+action_86 (148) = happyShift action_203+action_86 (165) = happyShift action_49+action_86 (173) = happyShift action_55+action_86 (188) = happyShift action_65+action_86 (37) = happyGoto action_191+action_86 (38) = happyGoto action_192+action_86 (39) = happyGoto action_193+action_86 (40) = happyGoto action_194+action_86 (41) = happyGoto action_220+action_86 (105) = happyGoto action_196+action_86 (107) = happyGoto action_197+action_86 (108) = happyGoto action_80+action_86 (121) = happyGoto action_198+action_86 (124) = happyGoto action_199+action_86 _ = happyFail++action_87 (188) = happyShift action_219+action_87 (17) = happyGoto action_218+action_87 _ = happyReduce_33++action_88 (185) = happyShift action_217+action_88 _ = happyFail++action_89 (132) = happyShift action_137+action_89 (133) = happyShift action_118+action_89 (134) = happyShift action_119+action_89 (135) = happyShift action_120+action_89 (136) = happyShift action_121+action_89 (152) = happyShift action_124+action_89 (153) = happyShift action_125+action_89 (155) = happyShift action_181+action_89 (164) = happyShift action_126+action_89 (99) = happyGoto action_109+action_89 (101) = happyGoto action_110+action_89 (103) = happyGoto action_133+action_89 (109) = happyGoto action_134+action_89 (110) = happyGoto action_113+action_89 (111) = happyGoto action_135+action_89 (112) = happyGoto action_115+action_89 (113) = happyGoto action_116+action_89 _ = happyReduce_160++action_90 (161) = happyShift action_130+action_90 _ = happyReduce_177++action_91 _ = happyReduce_169++action_92 (128) = happyShift action_34+action_92 (129) = happyShift action_35+action_92 (130) = happyShift action_36+action_92 (131) = happyShift action_37+action_92 (132) = happyShift action_38+action_92 (137) = happyShift action_39+action_92 (138) = happyShift action_40+action_92 (139) = happyShift action_41+action_92 (140) = happyShift action_42+action_92 (141) = happyShift action_43+action_92 (142) = happyShift action_44+action_92 (148) = happyShift action_45+action_92 (151) = happyShift action_46+action_92 (157) = happyShift action_47+action_92 (162) = happyShift action_48+action_92 (165) = happyShift action_49+action_92 (166) = happyShift action_50+action_92 (171) = happyShift action_54+action_92 (173) = happyShift action_55+action_92 (174) = happyShift action_56+action_92 (181) = happyShift action_216+action_92 (188) = happyShift action_65+action_92 (191) = happyShift action_68+action_92 (192) = happyShift action_69+action_92 (193) = happyShift action_70+action_92 (194) = happyShift action_71+action_92 (69) = happyGoto action_211+action_92 (70) = happyGoto action_212+action_92 (71) = happyGoto action_20+action_92 (72) = happyGoto action_21+action_92 (74) = happyGoto action_22+action_92 (75) = happyGoto action_23+action_92 (81) = happyGoto action_213+action_92 (89) = happyGoto action_214+action_92 (90) = happyGoto action_215+action_92 (93) = happyGoto action_24+action_92 (95) = happyGoto action_90+action_92 (97) = happyGoto action_26+action_92 (104) = happyGoto action_27+action_92 (105) = happyGoto action_28+action_92 (106) = happyGoto action_29+action_92 (108) = happyGoto action_30+action_92 (114) = happyGoto action_31+action_92 (126) = happyGoto action_33+action_92 _ = happyFail++action_93 (117) = happyGoto action_210+action_93 _ = happyReduce_281++action_94 (128) = happyShift action_34+action_94 (130) = happyShift action_36+action_94 (131) = happyShift action_200+action_94 (137) = happyShift action_201+action_94 (142) = happyShift action_202+action_94 (148) = happyShift action_203+action_94 (165) = happyShift action_49+action_94 (173) = happyShift action_55+action_94 (188) = happyShift action_65+action_94 (37) = happyGoto action_209+action_94 (38) = happyGoto action_192+action_94 (39) = happyGoto action_193+action_94 (40) = happyGoto action_194+action_94 (105) = happyGoto action_196+action_94 (107) = happyGoto action_197+action_94 (108) = happyGoto action_80+action_94 (121) = happyGoto action_198+action_94 (124) = happyGoto action_199+action_94 _ = happyFail++action_95 (128) = happyShift action_34+action_95 (130) = happyShift action_36+action_95 (131) = happyShift action_200+action_95 (137) = happyShift action_201+action_95 (142) = happyShift action_202+action_95 (148) = happyShift action_203+action_95 (165) = happyShift action_49+action_95 (173) = happyShift action_55+action_95 (188) = happyShift action_65+action_95 (37) = happyGoto action_204+action_95 (38) = happyGoto action_192+action_95 (39) = happyGoto action_193+action_95 (40) = happyGoto action_194+action_95 (43) = happyGoto action_205+action_95 (44) = happyGoto action_206+action_95 (46) = happyGoto action_207+action_95 (105) = happyGoto action_196+action_95 (107) = happyGoto action_197+action_95 (108) = happyGoto action_80+action_95 (121) = happyGoto action_208+action_95 (124) = happyGoto action_199+action_95 _ = happyFail++action_96 (128) = happyShift action_34+action_96 (130) = happyShift action_36+action_96 (131) = happyShift action_200+action_96 (137) = happyShift action_201+action_96 (142) = happyShift action_202+action_96 (148) = happyShift action_203+action_96 (165) = happyShift action_49+action_96 (173) = happyShift action_55+action_96 (188) = happyShift action_65+action_96 (37) = happyGoto action_191+action_96 (38) = happyGoto action_192+action_96 (39) = happyGoto action_193+action_96 (40) = happyGoto action_194+action_96 (41) = happyGoto action_195+action_96 (105) = happyGoto action_196+action_96 (107) = happyGoto action_197+action_96 (108) = happyGoto action_80+action_96 (121) = happyGoto action_198+action_96 (124) = happyGoto action_199+action_96 _ = happyFail++action_97 (184) = happyShift action_190+action_97 _ = happyFail++action_98 _ = happyReduce_187++action_99 (128) = happyShift action_34+action_99 (129) = happyShift action_35+action_99 (130) = happyShift action_36+action_99 (131) = happyShift action_37+action_99 (137) = happyShift action_39+action_99 (138) = happyShift action_40+action_99 (139) = happyShift action_41+action_99 (140) = happyShift action_42+action_99 (141) = happyShift action_43+action_99 (142) = happyShift action_44+action_99 (148) = happyShift action_45+action_99 (151) = happyShift action_46+action_99 (160) = happyShift action_189+action_99 (162) = happyShift action_48+action_99 (165) = happyShift action_49+action_99 (173) = happyShift action_55+action_99 (188) = happyShift action_65+action_99 (74) = happyGoto action_167+action_99 (75) = happyGoto action_23+action_99 (93) = happyGoto action_24+action_99 (95) = happyGoto action_90+action_99 (97) = happyGoto action_26+action_99 (104) = happyGoto action_27+action_99 (105) = happyGoto action_28+action_99 (106) = happyGoto action_29+action_99 (108) = happyGoto action_30+action_99 (114) = happyGoto action_31+action_99 _ = happyFail++action_100 (145) = happyShift action_131+action_100 _ = happyReduce_174++action_101 (150) = happyShift action_186+action_101 (154) = happyShift action_187+action_101 (158) = happyShift action_188+action_101 _ = happyReduce_192++action_102 (149) = happyShift action_185+action_102 _ = happyFail++action_103 (150) = happyShift action_184+action_103 _ = happyReduce_193++action_104 _ = happyReduce_227++action_105 (143) = happyShift action_182+action_105 (150) = happyShift action_183+action_105 _ = happyFail++action_106 (132) = happyShift action_137+action_106 (133) = happyShift action_118+action_106 (134) = happyShift action_119+action_106 (135) = happyShift action_120+action_106 (136) = happyShift action_121+action_106 (152) = happyShift action_124+action_106 (153) = happyShift action_125+action_106 (155) = happyShift action_181+action_106 (164) = happyShift action_126+action_106 (99) = happyGoto action_109+action_106 (101) = happyGoto action_110+action_106 (103) = happyGoto action_180+action_106 (109) = happyGoto action_134+action_106 (110) = happyGoto action_113+action_106 (111) = happyGoto action_135+action_106 (112) = happyGoto action_115+action_106 (113) = happyGoto action_116+action_106 _ = happyReduce_160++action_107 (143) = happyShift action_178+action_107 (150) = happyShift action_179+action_107 _ = happyFail++action_108 (143) = happyShift action_176+action_108 (150) = happyShift action_177+action_108 _ = happyFail++action_109 _ = happyReduce_251++action_110 _ = happyReduce_252++action_111 (128) = happyShift action_34+action_111 (129) = happyShift action_35+action_111 (130) = happyShift action_36+action_111 (131) = happyShift action_37+action_111 (132) = happyShift action_38+action_111 (137) = happyShift action_39+action_111 (138) = happyShift action_40+action_111 (139) = happyShift action_41+action_111 (140) = happyShift action_42+action_111 (141) = happyShift action_43+action_111 (142) = happyShift action_44+action_111 (148) = happyShift action_45+action_111 (151) = happyShift action_46+action_111 (157) = happyShift action_47+action_111 (162) = happyShift action_48+action_111 (165) = happyShift action_49+action_111 (166) = happyShift action_50+action_111 (171) = happyShift action_54+action_111 (173) = happyShift action_55+action_111 (174) = happyShift action_56+action_111 (181) = happyShift action_62+action_111 (188) = happyShift action_65+action_111 (191) = happyShift action_68+action_111 (192) = happyShift action_69+action_111 (193) = happyShift action_70+action_111 (194) = happyShift action_71+action_111 (70) = happyGoto action_175+action_111 (71) = happyGoto action_20+action_111 (72) = happyGoto action_21+action_111 (74) = happyGoto action_22+action_111 (75) = happyGoto action_23+action_111 (93) = happyGoto action_24+action_111 (95) = happyGoto action_90+action_111 (97) = happyGoto action_26+action_111 (104) = happyGoto action_27+action_111 (105) = happyGoto action_28+action_111 (106) = happyGoto action_29+action_111 (108) = happyGoto action_30+action_111 (114) = happyGoto action_31+action_111 (126) = happyGoto action_33+action_111 _ = happyFail++action_112 (143) = happyShift action_174+action_112 _ = happyReduce_247++action_113 _ = happyReduce_264++action_114 (143) = happyShift action_173+action_114 _ = happyReduce_243++action_115 _ = happyReduce_267++action_116 _ = happyReduce_268++action_117 (128) = happyShift action_34+action_117 (129) = happyShift action_35+action_117 (130) = happyShift action_36+action_117 (131) = happyShift action_37+action_117 (137) = happyShift action_39+action_117 (138) = happyShift action_40+action_117 (139) = happyShift action_41+action_117 (140) = happyShift action_42+action_117 (141) = happyShift action_43+action_117 (142) = happyShift action_44+action_117 (148) = happyShift action_45+action_117 (151) = happyShift action_46+action_117 (162) = happyShift action_48+action_117 (165) = happyShift action_49+action_117 (173) = happyShift action_55+action_117 (188) = happyShift action_65+action_117 (72) = happyGoto action_128+action_117 (74) = happyGoto action_22+action_117 (75) = happyGoto action_23+action_117 (93) = happyGoto action_24+action_117 (95) = happyGoto action_90+action_117 (97) = happyGoto action_26+action_117 (104) = happyGoto action_27+action_117 (105) = happyGoto action_28+action_117 (106) = happyGoto action_29+action_117 (108) = happyGoto action_30+action_117 (114) = happyGoto action_31+action_117 _ = happyReduce_270++action_118 _ = happyReduce_269++action_119 _ = happyReduce_266++action_120 _ = happyReduce_273++action_121 _ = happyReduce_265++action_122 _ = happyReduce_226++action_123 _ = happyReduce_189++action_124 (128) = happyShift action_34+action_124 (129) = happyShift action_35+action_124 (130) = happyShift action_36+action_124 (131) = happyShift action_37+action_124 (165) = happyShift action_49+action_124 (173) = happyShift action_55+action_124 (188) = happyShift action_65+action_124 (104) = happyGoto action_171+action_124 (105) = happyGoto action_28+action_124 (106) = happyGoto action_172+action_124 (108) = happyGoto action_30+action_124 _ = happyFail++action_125 _ = happyReduce_272++action_126 _ = happyReduce_271++action_127 (142) = happyShift action_169+action_127 (148) = happyShift action_170+action_127 _ = happyFail++action_128 (128) = happyShift action_34+action_128 (129) = happyShift action_35+action_128 (130) = happyShift action_36+action_128 (131) = happyShift action_37+action_128 (137) = happyShift action_39+action_128 (138) = happyShift action_40+action_128 (139) = happyShift action_41+action_128 (140) = happyShift action_42+action_128 (141) = happyShift action_43+action_128 (142) = happyShift action_44+action_128 (148) = happyShift action_45+action_128 (151) = happyShift action_46+action_128 (162) = happyShift action_48+action_128 (165) = happyShift action_49+action_128 (173) = happyShift action_55+action_128 (188) = happyShift action_65+action_128 (74) = happyGoto action_132+action_128 (75) = happyGoto action_23+action_128 (93) = happyGoto action_24+action_128 (95) = happyGoto action_90+action_128 (97) = happyGoto action_26+action_128 (104) = happyGoto action_27+action_128 (105) = happyGoto action_28+action_128 (106) = happyGoto action_29+action_128 (108) = happyGoto action_30+action_128 (114) = happyGoto action_31+action_128 _ = happyReduce_168++action_129 (128) = happyShift action_34+action_129 (129) = happyShift action_35+action_129 (130) = happyShift action_36+action_129 (131) = happyShift action_37+action_129 (137) = happyShift action_39+action_129 (138) = happyShift action_40+action_129 (139) = happyShift action_41+action_129 (140) = happyShift action_42+action_129 (141) = happyShift action_43+action_129 (142) = happyShift action_44+action_129 (148) = happyShift action_45+action_129 (151) = happyShift action_46+action_129 (153) = happyShift action_168+action_129 (162) = happyShift action_48+action_129 (165) = happyShift action_49+action_129 (173) = happyShift action_55+action_129 (188) = happyShift action_65+action_129 (74) = happyGoto action_167+action_129 (75) = happyGoto action_23+action_129 (93) = happyGoto action_24+action_129 (95) = happyGoto action_90+action_129 (97) = happyGoto action_26+action_129 (104) = happyGoto action_27+action_129 (105) = happyGoto action_28+action_129 (106) = happyGoto action_29+action_129 (108) = happyGoto action_30+action_129 (114) = happyGoto action_31+action_129 _ = happyFail++action_130 (128) = happyShift action_34+action_130 (129) = happyShift action_35+action_130 (130) = happyShift action_36+action_130 (131) = happyShift action_37+action_130 (137) = happyShift action_39+action_130 (138) = happyShift action_40+action_130 (139) = happyShift action_41+action_130 (140) = happyShift action_42+action_130 (141) = happyShift action_43+action_130 (142) = happyShift action_44+action_130 (148) = happyShift action_45+action_130 (151) = happyShift action_46+action_130 (162) = happyShift action_48+action_130 (165) = happyShift action_49+action_130 (173) = happyShift action_55+action_130 (188) = happyShift action_65+action_130 (75) = happyGoto action_166+action_130 (93) = happyGoto action_24+action_130 (95) = happyGoto action_90+action_130 (97) = happyGoto action_26+action_130 (104) = happyGoto action_27+action_130 (105) = happyGoto action_28+action_130 (106) = happyGoto action_29+action_130 (108) = happyGoto action_30+action_130 (114) = happyGoto action_31+action_130 _ = happyFail++action_131 (117) = happyGoto action_165+action_131 _ = happyReduce_281++action_132 (145) = happyShift action_131+action_132 _ = happyReduce_171++action_133 (128) = happyShift action_34+action_133 (129) = happyShift action_35+action_133 (130) = happyShift action_36+action_133 (131) = happyShift action_37+action_133 (132) = happyShift action_38+action_133 (137) = happyShift action_39+action_133 (138) = happyShift action_40+action_133 (139) = happyShift action_41+action_133 (140) = happyShift action_42+action_133 (141) = happyShift action_43+action_133 (142) = happyShift action_44+action_133 (148) = happyShift action_45+action_133 (151) = happyShift action_46+action_133 (157) = happyShift action_47+action_133 (162) = happyShift action_48+action_133 (165) = happyShift action_49+action_133 (166) = happyShift action_50+action_133 (171) = happyShift action_54+action_133 (173) = happyShift action_55+action_133 (174) = happyShift action_56+action_133 (181) = happyShift action_62+action_133 (188) = happyShift action_65+action_133 (191) = happyShift action_68+action_133 (192) = happyShift action_69+action_133 (193) = happyShift action_70+action_133 (194) = happyShift action_71+action_133 (71) = happyGoto action_164+action_133 (72) = happyGoto action_21+action_133 (74) = happyGoto action_22+action_133 (75) = happyGoto action_23+action_133 (93) = happyGoto action_24+action_133 (95) = happyGoto action_90+action_133 (97) = happyGoto action_26+action_133 (104) = happyGoto action_27+action_133 (105) = happyGoto action_28+action_133 (106) = happyGoto action_29+action_133 (108) = happyGoto action_30+action_133 (114) = happyGoto action_31+action_133 (126) = happyGoto action_33+action_133 _ = happyFail++action_134 _ = happyReduce_247++action_135 _ = happyReduce_243++action_136 (156) = happyShift action_162+action_136 (158) = happyShift action_163+action_136 (66) = happyGoto action_159+action_136 (67) = happyGoto action_160+action_136 (68) = happyGoto action_161+action_136 _ = happyFail++action_137 _ = happyReduce_270++action_138 (155) = happyShift action_158+action_138 _ = happyFail++action_139 (128) = happyShift action_34+action_139 (142) = happyShift action_157+action_139 (165) = happyShift action_49+action_139 (173) = happyShift action_55+action_139 (188) = happyShift action_65+action_139 (94) = happyGoto action_155+action_139 (105) = happyGoto action_156+action_139 _ = happyFail++action_140 (138) = happyShift action_154+action_140 (27) = happyGoto action_153+action_140 _ = happyReduce_54++action_141 _ = happyReduce_6++action_142 (128) = happyShift action_34+action_142 (129) = happyShift action_35+action_142 (130) = happyShift action_36+action_142 (131) = happyShift action_37+action_142 (132) = happyShift action_38+action_142 (137) = happyShift action_39+action_142 (138) = happyShift action_40+action_142 (139) = happyShift action_41+action_142 (140) = happyShift action_42+action_142 (141) = happyShift action_43+action_142 (142) = happyShift action_44+action_142 (148) = happyShift action_45+action_142 (151) = happyShift action_46+action_142 (157) = happyShift action_47+action_142 (162) = happyShift action_48+action_142 (165) = happyShift action_49+action_142 (166) = happyShift action_50+action_142 (167) = happyShift action_51+action_142 (168) = happyShift action_52+action_142 (169) = happyShift action_53+action_142 (171) = happyShift action_54+action_142 (173) = happyShift action_55+action_142 (174) = happyShift action_56+action_142 (177) = happyShift action_58+action_142 (178) = happyShift action_59+action_142 (179) = happyShift action_60+action_142 (180) = happyShift action_61+action_142 (181) = happyShift action_62+action_142 (183) = happyShift action_63+action_142 (186) = happyShift action_64+action_142 (188) = happyShift action_65+action_142 (189) = happyShift action_66+action_142 (190) = happyShift action_67+action_142 (191) = happyShift action_68+action_142 (192) = happyShift action_69+action_142 (193) = happyShift action_70+action_142 (194) = happyShift action_71+action_142 (26) = happyGoto action_12+action_142 (28) = happyGoto action_13+action_142 (30) = happyGoto action_152+action_142 (33) = happyGoto action_15+action_142 (35) = happyGoto action_16+action_142 (36) = happyGoto action_17+action_142 (64) = happyGoto action_18+action_142 (70) = happyGoto action_19+action_142 (71) = happyGoto action_20+action_142 (72) = happyGoto action_21+action_142 (74) = happyGoto action_22+action_142 (75) = happyGoto action_23+action_142 (93) = happyGoto action_24+action_142 (95) = happyGoto action_25+action_142 (97) = happyGoto action_26+action_142 (104) = happyGoto action_27+action_142 (105) = happyGoto action_28+action_142 (106) = happyGoto action_29+action_142 (108) = happyGoto action_30+action_142 (114) = happyGoto action_31+action_142 (125) = happyGoto action_32+action_142 (126) = happyGoto action_33+action_142 _ = happyReduce_9++action_143 _ = happyReduce_7++action_144 (128) = happyShift action_34+action_144 (129) = happyShift action_35+action_144 (130) = happyShift action_36+action_144 (131) = happyShift action_37+action_144 (132) = happyShift action_38+action_144 (137) = happyShift action_39+action_144 (138) = happyShift action_40+action_144 (139) = happyShift action_41+action_144 (140) = happyShift action_42+action_144 (141) = happyShift action_43+action_144 (142) = happyShift action_44+action_144 (148) = happyShift action_45+action_144 (151) = happyShift action_46+action_144 (157) = happyShift action_47+action_144 (162) = happyShift action_48+action_144 (165) = happyShift action_49+action_144 (166) = happyShift action_50+action_144 (167) = happyShift action_51+action_144 (168) = happyShift action_52+action_144 (169) = happyShift action_53+action_144 (171) = happyShift action_54+action_144 (173) = happyShift action_55+action_144 (174) = happyShift action_56+action_144 (175) = happyShift action_57+action_144 (177) = happyShift action_58+action_144 (178) = happyShift action_59+action_144 (179) = happyShift action_60+action_144 (180) = happyShift action_61+action_144 (181) = happyShift action_62+action_144 (183) = happyShift action_63+action_144 (186) = happyShift action_64+action_144 (188) = happyShift action_65+action_144 (189) = happyShift action_66+action_144 (190) = happyShift action_67+action_144 (191) = happyShift action_68+action_144 (192) = happyShift action_69+action_144 (193) = happyShift action_70+action_144 (194) = happyShift action_71+action_144 (16) = happyGoto action_150+action_144 (25) = happyGoto action_151+action_144 (26) = happyGoto action_12+action_144 (28) = happyGoto action_13+action_144 (30) = happyGoto action_14+action_144 (33) = happyGoto action_15+action_144 (35) = happyGoto action_16+action_144 (36) = happyGoto action_17+action_144 (64) = happyGoto action_18+action_144 (70) = happyGoto action_19+action_144 (71) = happyGoto action_20+action_144 (72) = happyGoto action_21+action_144 (74) = happyGoto action_22+action_144 (75) = happyGoto action_23+action_144 (93) = happyGoto action_24+action_144 (95) = happyGoto action_25+action_144 (97) = happyGoto action_26+action_144 (104) = happyGoto action_27+action_144 (105) = happyGoto action_28+action_144 (106) = happyGoto action_29+action_144 (108) = happyGoto action_30+action_144 (114) = happyGoto action_31+action_144 (125) = happyGoto action_32+action_144 (126) = happyGoto action_33+action_144 _ = happyReduce_9++action_145 _ = happyReduce_4++action_146 _ = happyReduce_280++action_147 _ = happyReduce_279++action_148 (146) = happyShift action_149+action_148 _ = happyFail++action_149 _ = happyReduce_3++action_150 _ = happyReduce_29++action_151 (144) = happyShift action_142+action_151 (7) = happyGoto action_325+action_151 _ = happyReduce_10++action_152 _ = happyReduce_51++action_153 (132) = happyShift action_137+action_153 (133) = happyShift action_118+action_153 (134) = happyShift action_119+action_153 (152) = happyShift action_324+action_153 (153) = happyShift action_125+action_153 (164) = happyShift action_126+action_153 (29) = happyGoto action_318+action_153 (98) = happyGoto action_319+action_153 (100) = happyGoto action_320+action_153 (102) = happyGoto action_321+action_153 (110) = happyGoto action_322+action_153 (112) = happyGoto action_323+action_153 _ = happyFail++action_154 _ = happyReduce_55++action_155 _ = happyReduce_81++action_156 _ = happyReduce_233++action_157 (132) = happyShift action_137+action_157 (133) = happyShift action_118+action_157 (153) = happyShift action_125+action_157 (164) = happyShift action_126+action_157 (112) = happyGoto action_317+action_157 _ = happyFail++action_158 (128) = happyShift action_34+action_158 (130) = happyShift action_36+action_158 (131) = happyShift action_200+action_158 (137) = happyShift action_201+action_158 (142) = happyShift action_202+action_158 (148) = happyShift action_203+action_158 (165) = happyShift action_49+action_158 (173) = happyShift action_55+action_158 (188) = happyShift action_65+action_158 (37) = happyGoto action_191+action_158 (38) = happyGoto action_192+action_158 (39) = happyGoto action_193+action_158 (40) = happyGoto action_194+action_158 (41) = happyGoto action_316+action_158 (105) = happyGoto action_196+action_158 (107) = happyGoto action_197+action_158 (108) = happyGoto action_80+action_158 (121) = happyGoto action_198+action_158 (124) = happyGoto action_199+action_158 _ = happyFail++action_159 (187) = happyShift action_315+action_159 (65) = happyGoto action_314+action_159 _ = happyReduce_153++action_160 (158) = happyShift action_163+action_160 (68) = happyGoto action_313+action_160 _ = happyReduce_155++action_161 _ = happyReduce_157++action_162 (128) = happyShift action_34+action_162 (129) = happyShift action_35+action_162 (130) = happyShift action_36+action_162 (131) = happyShift action_37+action_162 (132) = happyShift action_38+action_162 (137) = happyShift action_39+action_162 (138) = happyShift action_40+action_162 (139) = happyShift action_41+action_162 (140) = happyShift action_42+action_162 (141) = happyShift action_43+action_162 (142) = happyShift action_44+action_162 (148) = happyShift action_45+action_162 (151) = happyShift action_46+action_162 (157) = happyShift action_47+action_162 (162) = happyShift action_48+action_162 (165) = happyShift action_49+action_162 (166) = happyShift action_50+action_162 (171) = happyShift action_54+action_162 (173) = happyShift action_55+action_162 (174) = happyShift action_56+action_162 (181) = happyShift action_62+action_162 (188) = happyShift action_65+action_162 (191) = happyShift action_68+action_162 (192) = happyShift action_69+action_162 (193) = happyShift action_70+action_162 (194) = happyShift action_71+action_162 (69) = happyGoto action_312+action_162 (70) = happyGoto action_89+action_162 (71) = happyGoto action_20+action_162 (72) = happyGoto action_21+action_162 (74) = happyGoto action_22+action_162 (75) = happyGoto action_23+action_162 (93) = happyGoto action_24+action_162 (95) = happyGoto action_90+action_162 (97) = happyGoto action_26+action_162 (104) = happyGoto action_27+action_162 (105) = happyGoto action_28+action_162 (106) = happyGoto action_29+action_162 (108) = happyGoto action_30+action_162 (114) = happyGoto action_31+action_162 (126) = happyGoto action_33+action_162 _ = happyFail++action_163 (128) = happyShift action_34+action_163 (129) = happyShift action_35+action_163 (130) = happyShift action_36+action_163 (131) = happyShift action_37+action_163 (132) = happyShift action_38+action_163 (137) = happyShift action_39+action_163 (138) = happyShift action_40+action_163 (139) = happyShift action_41+action_163 (140) = happyShift action_42+action_163 (141) = happyShift action_43+action_163 (142) = happyShift action_44+action_163 (148) = happyShift action_45+action_163 (151) = happyShift action_46+action_163 (157) = happyShift action_47+action_163 (162) = happyShift action_48+action_163 (165) = happyShift action_49+action_163 (166) = happyShift action_50+action_163 (171) = happyShift action_54+action_163 (173) = happyShift action_55+action_163 (174) = happyShift action_56+action_163 (181) = happyShift action_62+action_163 (188) = happyShift action_65+action_163 (191) = happyShift action_68+action_163 (192) = happyShift action_69+action_163 (193) = happyShift action_70+action_163 (194) = happyShift action_71+action_163 (69) = happyGoto action_311+action_163 (70) = happyGoto action_89+action_163 (71) = happyGoto action_20+action_163 (72) = happyGoto action_21+action_163 (74) = happyGoto action_22+action_163 (75) = happyGoto action_23+action_163 (93) = happyGoto action_24+action_163 (95) = happyGoto action_90+action_163 (97) = happyGoto action_26+action_163 (104) = happyGoto action_27+action_163 (105) = happyGoto action_28+action_163 (106) = happyGoto action_29+action_163 (108) = happyGoto action_30+action_163 (114) = happyGoto action_31+action_163 (126) = happyGoto action_33+action_163 _ = happyFail++action_164 _ = happyReduce_162++action_165 (128) = happyShift action_34+action_165 (129) = happyShift action_35+action_165 (142) = happyShift action_241+action_165 (165) = happyShift action_49+action_165 (173) = happyShift action_55+action_165 (188) = happyShift action_65+action_165 (91) = happyGoto action_308+action_165 (92) = happyGoto action_309+action_165 (95) = happyGoto action_310+action_165 (104) = happyGoto action_27+action_165 (105) = happyGoto action_28+action_165 _ = happyFail++action_166 _ = happyReduce_185++action_167 (145) = happyShift action_131+action_167 _ = happyReduce_173++action_168 (128) = happyShift action_34+action_168 (129) = happyShift action_35+action_168 (130) = happyShift action_36+action_168 (131) = happyShift action_37+action_168 (132) = happyShift action_38+action_168 (137) = happyShift action_39+action_168 (138) = happyShift action_40+action_168 (139) = happyShift action_41+action_168 (140) = happyShift action_42+action_168 (141) = happyShift action_43+action_168 (142) = happyShift action_44+action_168 (148) = happyShift action_45+action_168 (151) = happyShift action_46+action_168 (157) = happyShift action_47+action_168 (162) = happyShift action_48+action_168 (165) = happyShift action_49+action_168 (166) = happyShift action_50+action_168 (171) = happyShift action_54+action_168 (173) = happyShift action_55+action_168 (174) = happyShift action_56+action_168 (181) = happyShift action_62+action_168 (188) = happyShift action_65+action_168 (191) = happyShift action_68+action_168 (192) = happyShift action_69+action_168 (193) = happyShift action_70+action_168 (194) = happyShift action_71+action_168 (69) = happyGoto action_307+action_168 (70) = happyGoto action_89+action_168 (71) = happyGoto action_20+action_168 (72) = happyGoto action_21+action_168 (74) = happyGoto action_22+action_168 (75) = happyGoto action_23+action_168 (93) = happyGoto action_24+action_168 (95) = happyGoto action_90+action_168 (97) = happyGoto action_26+action_168 (104) = happyGoto action_27+action_168 (105) = happyGoto action_28+action_168 (106) = happyGoto action_29+action_168 (108) = happyGoto action_30+action_168 (114) = happyGoto action_31+action_168 (126) = happyGoto action_33+action_168 _ = happyFail++action_169 (143) = happyShift action_306+action_169 (150) = happyShift action_123+action_169 (76) = happyGoto action_305+action_169 _ = happyFail++action_170 (149) = happyShift action_304+action_170 _ = happyFail++action_171 (152) = happyShift action_303+action_171 _ = happyFail++action_172 (152) = happyShift action_302+action_172 _ = happyFail++action_173 _ = happyReduce_236++action_174 _ = happyReduce_240++action_175 (132) = happyShift action_137+action_175 (133) = happyShift action_118+action_175 (134) = happyShift action_119+action_175 (135) = happyShift action_120+action_175 (136) = happyShift action_121+action_175 (143) = happyShift action_301+action_175 (152) = happyShift action_124+action_175 (153) = happyShift action_125+action_175 (164) = happyShift action_126+action_175 (99) = happyGoto action_109+action_175 (101) = happyGoto action_110+action_175 (103) = happyGoto action_133+action_175 (109) = happyGoto action_134+action_175 (110) = happyGoto action_113+action_175 (111) = happyGoto action_135+action_175 (112) = happyGoto action_115+action_175 (113) = happyGoto action_116+action_175 _ = happyFail++action_176 _ = happyReduce_181++action_177 (128) = happyShift action_34+action_177 (129) = happyShift action_35+action_177 (130) = happyShift action_36+action_177 (131) = happyShift action_37+action_177 (132) = happyShift action_38+action_177 (137) = happyShift action_39+action_177 (138) = happyShift action_40+action_177 (139) = happyShift action_41+action_177 (140) = happyShift action_42+action_177 (141) = happyShift action_43+action_177 (142) = happyShift action_44+action_177 (148) = happyShift action_45+action_177 (151) = happyShift action_46+action_177 (157) = happyShift action_47+action_177 (162) = happyShift action_48+action_177 (165) = happyShift action_49+action_177 (166) = happyShift action_50+action_177 (171) = happyShift action_54+action_177 (173) = happyShift action_55+action_177 (174) = happyShift action_56+action_177 (181) = happyShift action_62+action_177 (188) = happyShift action_65+action_177 (191) = happyShift action_68+action_177 (192) = happyShift action_69+action_177 (193) = happyShift action_70+action_177 (194) = happyShift action_71+action_177 (69) = happyGoto action_300+action_177 (70) = happyGoto action_89+action_177 (71) = happyGoto action_20+action_177 (72) = happyGoto action_21+action_177 (74) = happyGoto action_22+action_177 (75) = happyGoto action_23+action_177 (93) = happyGoto action_24+action_177 (95) = happyGoto action_90+action_177 (97) = happyGoto action_26+action_177 (104) = happyGoto action_27+action_177 (105) = happyGoto action_28+action_177 (106) = happyGoto action_29+action_177 (108) = happyGoto action_30+action_177 (114) = happyGoto action_31+action_177 (126) = happyGoto action_33+action_177 _ = happyFail++action_178 _ = happyReduce_228++action_179 _ = happyReduce_188++action_180 (128) = happyShift action_34+action_180 (129) = happyShift action_35+action_180 (130) = happyShift action_36+action_180 (131) = happyShift action_37+action_180 (132) = happyShift action_38+action_180 (137) = happyShift action_39+action_180 (138) = happyShift action_40+action_180 (139) = happyShift action_41+action_180 (140) = happyShift action_42+action_180 (141) = happyShift action_43+action_180 (142) = happyShift action_44+action_180 (143) = happyShift action_299+action_180 (148) = happyShift action_45+action_180 (151) = happyShift action_46+action_180 (157) = happyShift action_47+action_180 (162) = happyShift action_48+action_180 (165) = happyShift action_49+action_180 (166) = happyShift action_50+action_180 (171) = happyShift action_54+action_180 (173) = happyShift action_55+action_180 (174) = happyShift action_56+action_180 (181) = happyShift action_62+action_180 (188) = happyShift action_65+action_180 (191) = happyShift action_68+action_180 (192) = happyShift action_69+action_180 (193) = happyShift action_70+action_180 (194) = happyShift action_71+action_180 (71) = happyGoto action_164+action_180 (72) = happyGoto action_21+action_180 (74) = happyGoto action_22+action_180 (75) = happyGoto action_23+action_180 (93) = happyGoto action_24+action_180 (95) = happyGoto action_90+action_180 (97) = happyGoto action_26+action_180 (104) = happyGoto action_27+action_180 (105) = happyGoto action_28+action_180 (106) = happyGoto action_29+action_180 (108) = happyGoto action_30+action_180 (114) = happyGoto action_31+action_180 (126) = happyGoto action_33+action_180 _ = happyFail++action_181 (115) = happyGoto action_298+action_181 _ = happyReduce_278++action_182 _ = happyReduce_180++action_183 (128) = happyShift action_34+action_183 (129) = happyShift action_35+action_183 (130) = happyShift action_36+action_183 (131) = happyShift action_37+action_183 (132) = happyShift action_38+action_183 (137) = happyShift action_39+action_183 (138) = happyShift action_40+action_183 (139) = happyShift action_41+action_183 (140) = happyShift action_42+action_183 (141) = happyShift action_43+action_183 (142) = happyShift action_44+action_183 (148) = happyShift action_45+action_183 (151) = happyShift action_46+action_183 (157) = happyShift action_47+action_183 (162) = happyShift action_48+action_183 (165) = happyShift action_49+action_183 (166) = happyShift action_50+action_183 (171) = happyShift action_54+action_183 (173) = happyShift action_55+action_183 (174) = happyShift action_56+action_183 (181) = happyShift action_62+action_183 (188) = happyShift action_65+action_183 (191) = happyShift action_68+action_183 (192) = happyShift action_69+action_183 (193) = happyShift action_70+action_183 (194) = happyShift action_71+action_183 (69) = happyGoto action_297+action_183 (70) = happyGoto action_89+action_183 (71) = happyGoto action_20+action_183 (72) = happyGoto action_21+action_183 (74) = happyGoto action_22+action_183 (75) = happyGoto action_23+action_183 (93) = happyGoto action_24+action_183 (95) = happyGoto action_90+action_183 (97) = happyGoto action_26+action_183 (104) = happyGoto action_27+action_183 (105) = happyGoto action_28+action_183 (106) = happyGoto action_29+action_183 (108) = happyGoto action_30+action_183 (114) = happyGoto action_31+action_183 (126) = happyGoto action_33+action_183 _ = happyFail++action_184 (128) = happyShift action_34+action_184 (129) = happyShift action_35+action_184 (130) = happyShift action_36+action_184 (131) = happyShift action_37+action_184 (132) = happyShift action_38+action_184 (137) = happyShift action_39+action_184 (138) = happyShift action_40+action_184 (139) = happyShift action_41+action_184 (140) = happyShift action_42+action_184 (141) = happyShift action_43+action_184 (142) = happyShift action_44+action_184 (148) = happyShift action_45+action_184 (151) = happyShift action_46+action_184 (157) = happyShift action_47+action_184 (162) = happyShift action_48+action_184 (165) = happyShift action_49+action_184 (166) = happyShift action_50+action_184 (171) = happyShift action_54+action_184 (173) = happyShift action_55+action_184 (174) = happyShift action_56+action_184 (181) = happyShift action_62+action_184 (188) = happyShift action_65+action_184 (191) = happyShift action_68+action_184 (192) = happyShift action_69+action_184 (193) = happyShift action_70+action_184 (194) = happyShift action_71+action_184 (69) = happyGoto action_296+action_184 (70) = happyGoto action_89+action_184 (71) = happyGoto action_20+action_184 (72) = happyGoto action_21+action_184 (74) = happyGoto action_22+action_184 (75) = happyGoto action_23+action_184 (93) = happyGoto action_24+action_184 (95) = happyGoto action_90+action_184 (97) = happyGoto action_26+action_184 (104) = happyGoto action_27+action_184 (105) = happyGoto action_28+action_184 (106) = happyGoto action_29+action_184 (108) = happyGoto action_30+action_184 (114) = happyGoto action_31+action_184 (126) = happyGoto action_33+action_184 _ = happyFail++action_185 _ = happyReduce_182++action_186 (128) = happyShift action_34+action_186 (129) = happyShift action_35+action_186 (130) = happyShift action_36+action_186 (131) = happyShift action_37+action_186 (132) = happyShift action_38+action_186 (137) = happyShift action_39+action_186 (138) = happyShift action_40+action_186 (139) = happyShift action_41+action_186 (140) = happyShift action_42+action_186 (141) = happyShift action_43+action_186 (142) = happyShift action_44+action_186 (148) = happyShift action_45+action_186 (151) = happyShift action_46+action_186 (157) = happyShift action_47+action_186 (162) = happyShift action_48+action_186 (165) = happyShift action_49+action_186 (166) = happyShift action_50+action_186 (171) = happyShift action_54+action_186 (173) = happyShift action_55+action_186 (174) = happyShift action_56+action_186 (181) = happyShift action_62+action_186 (188) = happyShift action_65+action_186 (191) = happyShift action_68+action_186 (192) = happyShift action_69+action_186 (193) = happyShift action_70+action_186 (194) = happyShift action_71+action_186 (69) = happyGoto action_295+action_186 (70) = happyGoto action_89+action_186 (71) = happyGoto action_20+action_186 (72) = happyGoto action_21+action_186 (74) = happyGoto action_22+action_186 (75) = happyGoto action_23+action_186 (93) = happyGoto action_24+action_186 (95) = happyGoto action_90+action_186 (97) = happyGoto action_26+action_186 (104) = happyGoto action_27+action_186 (105) = happyGoto action_28+action_186 (106) = happyGoto action_29+action_186 (108) = happyGoto action_30+action_186 (114) = happyGoto action_31+action_186 (126) = happyGoto action_33+action_186 _ = happyFail++action_187 (128) = happyShift action_34+action_187 (129) = happyShift action_35+action_187 (130) = happyShift action_36+action_187 (131) = happyShift action_37+action_187 (132) = happyShift action_38+action_187 (137) = happyShift action_39+action_187 (138) = happyShift action_40+action_187 (139) = happyShift action_41+action_187 (140) = happyShift action_42+action_187 (141) = happyShift action_43+action_187 (142) = happyShift action_44+action_187 (148) = happyShift action_45+action_187 (151) = happyShift action_46+action_187 (157) = happyShift action_47+action_187 (162) = happyShift action_48+action_187 (165) = happyShift action_49+action_187 (166) = happyShift action_50+action_187 (171) = happyShift action_54+action_187 (173) = happyShift action_55+action_187 (174) = happyShift action_56+action_187 (181) = happyShift action_62+action_187 (188) = happyShift action_65+action_187 (191) = happyShift action_68+action_187 (192) = happyShift action_69+action_187 (193) = happyShift action_70+action_187 (194) = happyShift action_71+action_187 (69) = happyGoto action_294+action_187 (70) = happyGoto action_89+action_187 (71) = happyGoto action_20+action_187 (72) = happyGoto action_21+action_187 (74) = happyGoto action_22+action_187 (75) = happyGoto action_23+action_187 (93) = happyGoto action_24+action_187 (95) = happyGoto action_90+action_187 (97) = happyGoto action_26+action_187 (104) = happyGoto action_27+action_187 (105) = happyGoto action_28+action_187 (106) = happyGoto action_29+action_187 (108) = happyGoto action_30+action_187 (114) = happyGoto action_31+action_187 (126) = happyGoto action_33+action_187 _ = happyReduce_194++action_188 (128) = happyShift action_34+action_188 (129) = happyShift action_35+action_188 (130) = happyShift action_36+action_188 (131) = happyShift action_37+action_188 (132) = happyShift action_38+action_188 (137) = happyShift action_39+action_188 (138) = happyShift action_40+action_188 (139) = happyShift action_41+action_188 (140) = happyShift action_42+action_188 (141) = happyShift action_43+action_188 (142) = happyShift action_44+action_188 (148) = happyShift action_45+action_188 (151) = happyShift action_46+action_188 (157) = happyShift action_47+action_188 (162) = happyShift action_48+action_188 (165) = happyShift action_49+action_188 (166) = happyShift action_50+action_188 (171) = happyShift action_54+action_188 (173) = happyShift action_55+action_188 (174) = happyShift action_56+action_188 (181) = happyShift action_216+action_188 (188) = happyShift action_65+action_188 (191) = happyShift action_68+action_188 (192) = happyShift action_69+action_188 (193) = happyShift action_70+action_188 (194) = happyShift action_71+action_188 (69) = happyGoto action_291+action_188 (70) = happyGoto action_212+action_188 (71) = happyGoto action_20+action_188 (72) = happyGoto action_21+action_188 (74) = happyGoto action_22+action_188 (75) = happyGoto action_23+action_188 (80) = happyGoto action_292+action_188 (81) = happyGoto action_293+action_188 (93) = happyGoto action_24+action_188 (95) = happyGoto action_90+action_188 (97) = happyGoto action_26+action_188 (104) = happyGoto action_27+action_188 (105) = happyGoto action_28+action_188 (106) = happyGoto action_29+action_188 (108) = happyGoto action_30+action_188 (114) = happyGoto action_31+action_188 (126) = happyGoto action_33+action_188 _ = happyFail++action_189 (128) = happyShift action_34+action_189 (129) = happyShift action_35+action_189 (130) = happyShift action_36+action_189 (131) = happyShift action_37+action_189 (132) = happyShift action_38+action_189 (137) = happyShift action_39+action_189 (138) = happyShift action_40+action_189 (139) = happyShift action_41+action_189 (140) = happyShift action_42+action_189 (141) = happyShift action_43+action_189 (142) = happyShift action_44+action_189 (148) = happyShift action_45+action_189 (151) = happyShift action_46+action_189 (157) = happyShift action_47+action_189 (162) = happyShift action_48+action_189 (165) = happyShift action_49+action_189 (166) = happyShift action_50+action_189 (171) = happyShift action_54+action_189 (173) = happyShift action_55+action_189 (174) = happyShift action_56+action_189 (181) = happyShift action_62+action_189 (188) = happyShift action_65+action_189 (191) = happyShift action_68+action_189 (192) = happyShift action_69+action_189 (193) = happyShift action_70+action_189 (194) = happyShift action_71+action_189 (69) = happyGoto action_290+action_189 (70) = happyGoto action_89+action_189 (71) = happyGoto action_20+action_189 (72) = happyGoto action_21+action_189 (74) = happyGoto action_22+action_189 (75) = happyGoto action_23+action_189 (93) = happyGoto action_24+action_189 (95) = happyGoto action_90+action_189 (97) = happyGoto action_26+action_189 (104) = happyGoto action_27+action_189 (105) = happyGoto action_28+action_189 (106) = happyGoto action_29+action_189 (108) = happyGoto action_30+action_189 (114) = happyGoto action_31+action_189 (126) = happyGoto action_33+action_189 _ = happyFail++action_190 (145) = happyShift action_289+action_190 (82) = happyGoto action_287+action_190 (118) = happyGoto action_288+action_190 _ = happyReduce_282++action_191 (163) = happyShift action_286+action_191 _ = happyReduce_101++action_192 (128) = happyShift action_34+action_192 (130) = happyShift action_36+action_192 (131) = happyShift action_200+action_192 (137) = happyShift action_201+action_192 (142) = happyShift action_202+action_192 (148) = happyShift action_203+action_192 (160) = happyShift action_285+action_192 (165) = happyShift action_49+action_192 (173) = happyShift action_55+action_192 (188) = happyShift action_65+action_192 (39) = happyGoto action_284+action_192 (40) = happyGoto action_194+action_192 (105) = happyGoto action_196+action_192 (107) = happyGoto action_197+action_192 (108) = happyGoto action_80+action_192 (121) = happyGoto action_198+action_192 (124) = happyGoto action_199+action_192 _ = happyReduce_84++action_193 _ = happyReduce_86++action_194 _ = happyReduce_87++action_195 (187) = happyShift action_283+action_195 (58) = happyGoto action_282+action_195 _ = happyReduce_138++action_196 _ = happyReduce_288++action_197 _ = happyReduce_92++action_198 _ = happyReduce_261++action_199 _ = happyReduce_88++action_200 _ = happyReduce_262++action_201 (153) = happyShift action_281+action_201 _ = happyFail++action_202 (128) = happyShift action_34+action_202 (130) = happyShift action_36+action_202 (131) = happyShift action_200+action_202 (137) = happyShift action_201+action_202 (142) = happyShift action_202+action_202 (143) = happyShift action_279+action_202 (148) = happyShift action_203+action_202 (150) = happyShift action_123+action_202 (160) = happyShift action_280+action_202 (165) = happyShift action_49+action_202 (173) = happyShift action_55+action_202 (188) = happyShift action_65+action_202 (37) = happyGoto action_276+action_202 (38) = happyGoto action_192+action_202 (39) = happyGoto action_193+action_202 (40) = happyGoto action_194+action_202 (42) = happyGoto action_277+action_202 (76) = happyGoto action_278+action_202 (105) = happyGoto action_196+action_202 (107) = happyGoto action_197+action_202 (108) = happyGoto action_80+action_202 (121) = happyGoto action_198+action_202 (124) = happyGoto action_199+action_202 _ = happyFail++action_203 (128) = happyShift action_34+action_203 (130) = happyShift action_36+action_203 (131) = happyShift action_200+action_203 (137) = happyShift action_201+action_203 (142) = happyShift action_202+action_203 (148) = happyShift action_203+action_203 (149) = happyShift action_275+action_203 (165) = happyShift action_49+action_203 (173) = happyShift action_55+action_203 (188) = happyShift action_65+action_203 (37) = happyGoto action_274+action_203 (38) = happyGoto action_192+action_203 (39) = happyGoto action_193+action_203 (40) = happyGoto action_194+action_203 (105) = happyGoto action_196+action_203 (107) = happyGoto action_197+action_203 (108) = happyGoto action_80+action_203 (121) = happyGoto action_198+action_203 (124) = happyGoto action_199+action_203 _ = happyFail++action_204 (163) = happyShift action_273+action_204 _ = happyFail++action_205 (156) = happyShift action_272+action_205 _ = happyFail++action_206 _ = happyReduce_105++action_207 _ = happyReduce_67++action_208 (128) = happyShift action_34+action_208 (130) = happyReduce_261+action_208 (131) = happyReduce_261+action_208 (137) = happyReduce_261+action_208 (142) = happyReduce_261+action_208 (148) = happyReduce_261+action_208 (156) = happyReduce_107+action_208 (160) = happyReduce_261+action_208 (163) = happyReduce_261+action_208 (165) = happyShift action_49+action_208 (173) = happyShift action_55+action_208 (188) = happyShift action_65+action_208 (45) = happyGoto action_231+action_208 (105) = happyGoto action_196+action_208 (124) = happyGoto action_232+action_208 _ = happyReduce_111++action_209 _ = happyReduce_66++action_210 (128) = happyShift action_34+action_210 (129) = happyShift action_35+action_210 (130) = happyShift action_36+action_210 (131) = happyShift action_37+action_210 (132) = happyShift action_38+action_210 (137) = happyShift action_39+action_210 (138) = happyShift action_40+action_210 (139) = happyShift action_41+action_210 (140) = happyShift action_42+action_210 (141) = happyShift action_43+action_210 (142) = happyShift action_44+action_210 (148) = happyShift action_45+action_210 (151) = happyShift action_46+action_210 (157) = happyShift action_47+action_210 (162) = happyShift action_48+action_210 (165) = happyShift action_49+action_210 (166) = happyShift action_50+action_210 (171) = happyShift action_54+action_210 (173) = happyShift action_55+action_210 (174) = happyShift action_56+action_210 (181) = happyShift action_216+action_210 (188) = happyShift action_65+action_210 (191) = happyShift action_68+action_210 (192) = happyShift action_69+action_210 (193) = happyShift action_70+action_210 (194) = happyShift action_71+action_210 (69) = happyGoto action_211+action_210 (70) = happyGoto action_212+action_210 (71) = happyGoto action_20+action_210 (72) = happyGoto action_21+action_210 (74) = happyGoto action_22+action_210 (75) = happyGoto action_23+action_210 (81) = happyGoto action_213+action_210 (89) = happyGoto action_271+action_210 (90) = happyGoto action_215+action_210 (93) = happyGoto action_24+action_210 (95) = happyGoto action_90+action_210 (97) = happyGoto action_26+action_210 (104) = happyGoto action_27+action_210 (105) = happyGoto action_28+action_210 (106) = happyGoto action_29+action_210 (108) = happyGoto action_30+action_210 (114) = happyGoto action_31+action_210 (126) = happyGoto action_33+action_210 _ = happyFail++action_211 (144) = happyReduce_204+action_211 _ = happyReduce_220++action_212 (132) = happyShift action_137+action_212 (133) = happyShift action_118+action_212 (134) = happyShift action_119+action_212 (135) = happyShift action_120+action_212 (136) = happyShift action_121+action_212 (152) = happyShift action_124+action_212 (153) = happyShift action_125+action_212 (155) = happyShift action_181+action_212 (159) = happyShift action_270+action_212 (164) = happyShift action_126+action_212 (99) = happyGoto action_109+action_212 (101) = happyGoto action_110+action_212 (103) = happyGoto action_133+action_212 (109) = happyGoto action_134+action_212 (110) = happyGoto action_113+action_212 (111) = happyGoto action_135+action_212 (112) = happyGoto action_115+action_212 (113) = happyGoto action_116+action_212 _ = happyReduce_160++action_213 _ = happyReduce_222++action_214 (1) = happyShift action_146+action_214 (147) = happyShift action_147+action_214 (116) = happyGoto action_269+action_214 _ = happyFail++action_215 (144) = happyShift action_268+action_215 _ = happyFail++action_216 (145) = happyShift action_85+action_216 (34) = happyGoto action_267+action_216 (118) = happyGoto action_84+action_216 _ = happyReduce_282++action_217 (128) = happyShift action_34+action_217 (129) = happyShift action_35+action_217 (130) = happyShift action_36+action_217 (131) = happyShift action_37+action_217 (132) = happyShift action_38+action_217 (137) = happyShift action_39+action_217 (138) = happyShift action_40+action_217 (139) = happyShift action_41+action_217 (140) = happyShift action_42+action_217 (141) = happyShift action_43+action_217 (142) = happyShift action_44+action_217 (148) = happyShift action_45+action_217 (151) = happyShift action_46+action_217 (157) = happyShift action_47+action_217 (162) = happyShift action_48+action_217 (165) = happyShift action_49+action_217 (166) = happyShift action_50+action_217 (171) = happyShift action_54+action_217 (173) = happyShift action_55+action_217 (174) = happyShift action_56+action_217 (181) = happyShift action_62+action_217 (188) = happyShift action_65+action_217 (191) = happyShift action_68+action_217 (192) = happyShift action_69+action_217 (193) = happyShift action_70+action_217 (194) = happyShift action_71+action_217 (69) = happyGoto action_266+action_217 (70) = happyGoto action_89+action_217 (71) = happyGoto action_20+action_217 (72) = happyGoto action_21+action_217 (74) = happyGoto action_22+action_217 (75) = happyGoto action_23+action_217 (93) = happyGoto action_24+action_217 (95) = happyGoto action_90+action_217 (97) = happyGoto action_26+action_217 (104) = happyGoto action_27+action_217 (105) = happyGoto action_28+action_217 (106) = happyGoto action_29+action_217 (108) = happyGoto action_30+action_217 (114) = happyGoto action_31+action_217 (126) = happyGoto action_33+action_217 _ = happyFail++action_218 (130) = happyShift action_73+action_218 (119) = happyGoto action_265+action_218 _ = happyFail++action_219 _ = happyReduce_32++action_220 (187) = happyShift action_264+action_220 (62) = happyGoto action_263+action_220 _ = happyReduce_148++action_221 (128) = happyShift action_34+action_221 (129) = happyShift action_35+action_221 (130) = happyShift action_36+action_221 (131) = happyShift action_37+action_221 (132) = happyShift action_38+action_221 (137) = happyShift action_39+action_221 (138) = happyShift action_40+action_221 (139) = happyShift action_41+action_221 (140) = happyShift action_42+action_221 (141) = happyShift action_43+action_221 (142) = happyShift action_44+action_221 (144) = happyShift action_226+action_221 (148) = happyShift action_45+action_221 (151) = happyShift action_46+action_221 (157) = happyShift action_47+action_221 (162) = happyShift action_48+action_221 (165) = happyShift action_49+action_221 (166) = happyShift action_50+action_221 (171) = happyShift action_54+action_221 (173) = happyShift action_55+action_221 (174) = happyShift action_56+action_221 (177) = happyShift action_58+action_221 (178) = happyShift action_59+action_221 (179) = happyShift action_60+action_221 (181) = happyShift action_62+action_221 (188) = happyShift action_65+action_221 (190) = happyShift action_67+action_221 (191) = happyShift action_68+action_221 (192) = happyShift action_69+action_221 (193) = happyShift action_70+action_221 (194) = happyShift action_71+action_221 (7) = happyGoto action_222+action_221 (26) = happyGoto action_12+action_221 (28) = happyGoto action_13+action_221 (31) = happyGoto action_262+action_221 (32) = happyGoto action_224+action_221 (33) = happyGoto action_225+action_221 (35) = happyGoto action_16+action_221 (36) = happyGoto action_17+action_221 (64) = happyGoto action_18+action_221 (70) = happyGoto action_19+action_221 (71) = happyGoto action_20+action_221 (72) = happyGoto action_21+action_221 (74) = happyGoto action_22+action_221 (75) = happyGoto action_23+action_221 (93) = happyGoto action_24+action_221 (95) = happyGoto action_25+action_221 (97) = happyGoto action_26+action_221 (104) = happyGoto action_27+action_221 (105) = happyGoto action_28+action_221 (106) = happyGoto action_29+action_221 (108) = happyGoto action_30+action_221 (114) = happyGoto action_31+action_221 (125) = happyGoto action_32+action_221 (126) = happyGoto action_33+action_221 _ = happyReduce_10++action_222 _ = happyReduce_71++action_223 (1) = happyShift action_146+action_223 (147) = happyShift action_147+action_223 (116) = happyGoto action_261+action_223 _ = happyFail++action_224 (144) = happyShift action_260+action_224 (7) = happyGoto action_259+action_224 _ = happyReduce_10++action_225 _ = happyReduce_73++action_226 _ = happyReduce_9++action_227 (128) = happyShift action_34+action_227 (129) = happyShift action_35+action_227 (130) = happyShift action_36+action_227 (131) = happyShift action_37+action_227 (132) = happyShift action_38+action_227 (137) = happyShift action_39+action_227 (138) = happyShift action_40+action_227 (139) = happyShift action_41+action_227 (140) = happyShift action_42+action_227 (141) = happyShift action_43+action_227 (142) = happyShift action_44+action_227 (148) = happyShift action_45+action_227 (151) = happyShift action_46+action_227 (157) = happyShift action_47+action_227 (162) = happyShift action_48+action_227 (165) = happyShift action_49+action_227 (166) = happyShift action_50+action_227 (171) = happyShift action_54+action_227 (173) = happyShift action_55+action_227 (174) = happyShift action_56+action_227 (181) = happyShift action_62+action_227 (188) = happyShift action_65+action_227 (191) = happyShift action_68+action_227 (192) = happyShift action_69+action_227 (193) = happyShift action_70+action_227 (194) = happyShift action_71+action_227 (69) = happyGoto action_258+action_227 (70) = happyGoto action_89+action_227 (71) = happyGoto action_20+action_227 (72) = happyGoto action_21+action_227 (74) = happyGoto action_22+action_227 (75) = happyGoto action_23+action_227 (93) = happyGoto action_24+action_227 (95) = happyGoto action_90+action_227 (97) = happyGoto action_26+action_227 (104) = happyGoto action_27+action_227 (105) = happyGoto action_28+action_227 (106) = happyGoto action_29+action_227 (108) = happyGoto action_30+action_227 (114) = happyGoto action_31+action_227 (126) = happyGoto action_33+action_227 _ = happyFail++action_228 (163) = happyShift action_257+action_228 _ = happyFail++action_229 (156) = happyShift action_256+action_229 _ = happyFail++action_230 (128) = happyShift action_34+action_230 (156) = happyReduce_107+action_230 (165) = happyShift action_49+action_230 (173) = happyShift action_55+action_230 (188) = happyShift action_65+action_230 (45) = happyGoto action_231+action_230 (105) = happyGoto action_196+action_230 (124) = happyGoto action_232+action_230 _ = happyReduce_261++action_231 (128) = happyShift action_34+action_231 (165) = happyShift action_49+action_231 (173) = happyShift action_55+action_231 (188) = happyShift action_65+action_231 (105) = happyGoto action_196+action_231 (124) = happyGoto action_255+action_231 _ = happyReduce_106++action_232 _ = happyReduce_109++action_233 (156) = happyShift action_254+action_233 _ = happyFail++action_234 (155) = happyShift action_253+action_234 _ = happyFail++action_235 (128) = happyShift action_34+action_235 (165) = happyShift action_49+action_235 (173) = happyShift action_55+action_235 (188) = happyShift action_65+action_235 (105) = happyGoto action_251+action_235 (127) = happyGoto action_252+action_235 _ = happyReduce_295++action_236 (150) = happyShift action_250+action_236 (10) = happyGoto action_249+action_236 _ = happyReduce_16++action_237 _ = happyReduce_18++action_238 _ = happyReduce_19++action_239 _ = happyReduce_286++action_240 (142) = happyShift action_248+action_240 _ = happyReduce_20++action_241 (132) = happyShift action_137+action_241 (133) = happyShift action_118+action_241 (135) = happyShift action_120+action_241 (153) = happyShift action_125+action_241 (164) = happyShift action_126+action_241 (111) = happyGoto action_247+action_241 (112) = happyGoto action_115+action_241 (113) = happyGoto action_116+action_241 _ = happyFail++action_242 _ = happyReduce_14++action_243 (130) = happyShift action_73+action_243 (119) = happyGoto action_246+action_243 _ = happyFail++action_244 (145) = happyShift action_6+action_244 (5) = happyGoto action_245+action_244 (118) = happyGoto action_5+action_244 _ = happyReduce_282++action_245 _ = happyReduce_1++action_246 _ = happyReduce_24++action_247 (143) = happyShift action_173+action_247 _ = happyFail++action_248 (128) = happyShift action_34+action_248 (129) = happyShift action_35+action_248 (130) = happyShift action_36+action_248 (131) = happyShift action_37+action_248 (142) = happyShift action_383+action_248 (143) = happyShift action_384+action_248 (154) = happyShift action_385+action_248 (165) = happyShift action_49+action_248 (173) = happyShift action_55+action_248 (188) = happyShift action_65+action_248 (13) = happyGoto action_379+action_248 (14) = happyGoto action_380+action_248 (95) = happyGoto action_381+action_248 (97) = happyGoto action_382+action_248 (104) = happyGoto action_27+action_248 (105) = happyGoto action_28+action_248 (106) = happyGoto action_29+action_248 (108) = happyGoto action_30+action_248 _ = happyFail++action_249 (143) = happyShift action_378+action_249 _ = happyFail++action_250 (128) = happyShift action_34+action_250 (129) = happyShift action_35+action_250 (130) = happyShift action_36+action_250 (131) = happyShift action_200+action_250 (142) = happyShift action_241+action_250 (165) = happyShift action_49+action_250 (173) = happyShift action_55+action_250 (182) = happyShift action_243+action_250 (188) = happyShift action_65+action_250 (12) = happyGoto action_377+action_250 (95) = happyGoto action_238+action_250 (104) = happyGoto action_27+action_250 (105) = happyGoto action_28+action_250 (107) = happyGoto action_239+action_250 (108) = happyGoto action_80+action_250 (121) = happyGoto action_198+action_250 (122) = happyGoto action_240+action_250 _ = happyReduce_15++action_251 (128) = happyShift action_34+action_251 (165) = happyShift action_49+action_251 (173) = happyShift action_55+action_251 (188) = happyShift action_65+action_251 (105) = happyGoto action_251+action_251 (127) = happyGoto action_376+action_251 _ = happyReduce_295++action_252 (156) = happyShift action_375+action_252 _ = happyFail++action_253 (128) = happyShift action_34+action_253 (130) = happyShift action_36+action_253 (131) = happyShift action_200+action_253 (137) = happyShift action_201+action_253 (142) = happyShift action_202+action_253 (148) = happyShift action_203+action_253 (165) = happyShift action_49+action_253 (173) = happyShift action_55+action_253 (188) = happyShift action_65+action_253 (37) = happyGoto action_374+action_253 (38) = happyGoto action_192+action_253 (39) = happyGoto action_193+action_253 (40) = happyGoto action_194+action_253 (105) = happyGoto action_196+action_253 (107) = happyGoto action_197+action_253 (108) = happyGoto action_80+action_253 (121) = happyGoto action_198+action_253 (124) = happyGoto action_199+action_253 _ = happyFail++action_254 (128) = happyShift action_34+action_254 (130) = happyShift action_36+action_254 (131) = happyShift action_200+action_254 (137) = happyShift action_201+action_254 (142) = happyShift action_202+action_254 (148) = happyShift action_203+action_254 (165) = happyShift action_49+action_254 (173) = happyShift action_55+action_254 (188) = happyShift action_65+action_254 (37) = happyGoto action_373+action_254 (38) = happyGoto action_192+action_254 (39) = happyGoto action_193+action_254 (40) = happyGoto action_194+action_254 (105) = happyGoto action_196+action_254 (107) = happyGoto action_197+action_254 (108) = happyGoto action_80+action_254 (121) = happyGoto action_198+action_254 (124) = happyGoto action_199+action_254 _ = happyFail++action_255 _ = happyReduce_108++action_256 (48) = happyGoto action_372+action_256 (115) = happyGoto action_360+action_256 _ = happyReduce_278++action_257 (130) = happyShift action_36+action_257 (44) = happyGoto action_356+action_257 (108) = happyGoto action_80+action_257 (121) = happyGoto action_81+action_257 _ = happyFail++action_258 _ = happyReduce_165++action_259 _ = happyReduce_70++action_260 (128) = happyShift action_34+action_260 (129) = happyShift action_35+action_260 (130) = happyShift action_36+action_260 (131) = happyShift action_37+action_260 (132) = happyShift action_38+action_260 (137) = happyShift action_39+action_260 (138) = happyShift action_40+action_260 (139) = happyShift action_41+action_260 (140) = happyShift action_42+action_260 (141) = happyShift action_43+action_260 (142) = happyShift action_44+action_260 (148) = happyShift action_45+action_260 (151) = happyShift action_46+action_260 (157) = happyShift action_47+action_260 (162) = happyShift action_48+action_260 (165) = happyShift action_49+action_260 (166) = happyShift action_50+action_260 (171) = happyShift action_54+action_260 (173) = happyShift action_55+action_260 (174) = happyShift action_56+action_260 (177) = happyShift action_58+action_260 (178) = happyShift action_59+action_260 (179) = happyShift action_60+action_260 (181) = happyShift action_62+action_260 (188) = happyShift action_65+action_260 (190) = happyShift action_67+action_260 (191) = happyShift action_68+action_260 (192) = happyShift action_69+action_260 (193) = happyShift action_70+action_260 (194) = happyShift action_71+action_260 (26) = happyGoto action_12+action_260 (28) = happyGoto action_13+action_260 (33) = happyGoto action_371+action_260 (35) = happyGoto action_16+action_260 (36) = happyGoto action_17+action_260 (64) = happyGoto action_18+action_260 (70) = happyGoto action_19+action_260 (71) = happyGoto action_20+action_260 (72) = happyGoto action_21+action_260 (74) = happyGoto action_22+action_260 (75) = happyGoto action_23+action_260 (93) = happyGoto action_24+action_260 (95) = happyGoto action_25+action_260 (97) = happyGoto action_26+action_260 (104) = happyGoto action_27+action_260 (105) = happyGoto action_28+action_260 (106) = happyGoto action_29+action_260 (108) = happyGoto action_30+action_260 (114) = happyGoto action_31+action_260 (125) = happyGoto action_32+action_260 (126) = happyGoto action_33+action_260 _ = happyReduce_9++action_261 _ = happyReduce_79++action_262 (146) = happyShift action_370+action_262 _ = happyFail++action_263 _ = happyReduce_65++action_264 (145) = happyShift action_369+action_264 (118) = happyGoto action_368+action_264 _ = happyReduce_282++action_265 (165) = happyShift action_367+action_265 (18) = happyGoto action_366+action_265 _ = happyReduce_35++action_266 (172) = happyShift action_365+action_266 _ = happyFail++action_267 (176) = happyShift action_227+action_267 _ = happyReduce_205++action_268 (128) = happyShift action_34+action_268 (129) = happyShift action_35+action_268 (130) = happyShift action_36+action_268 (131) = happyShift action_37+action_268 (132) = happyShift action_38+action_268 (137) = happyShift action_39+action_268 (138) = happyShift action_40+action_268 (139) = happyShift action_41+action_268 (140) = happyShift action_42+action_268 (141) = happyShift action_43+action_268 (142) = happyShift action_44+action_268 (148) = happyShift action_45+action_268 (151) = happyShift action_46+action_268 (157) = happyShift action_47+action_268 (162) = happyShift action_48+action_268 (165) = happyShift action_49+action_268 (166) = happyShift action_50+action_268 (171) = happyShift action_54+action_268 (173) = happyShift action_55+action_268 (174) = happyShift action_56+action_268 (181) = happyShift action_216+action_268 (188) = happyShift action_65+action_268 (191) = happyShift action_68+action_268 (192) = happyShift action_69+action_268 (193) = happyShift action_70+action_268 (194) = happyShift action_71+action_268 (69) = happyGoto action_363+action_268 (70) = happyGoto action_212+action_268 (71) = happyGoto action_20+action_268 (72) = happyGoto action_21+action_268 (74) = happyGoto action_22+action_268 (75) = happyGoto action_23+action_268 (81) = happyGoto action_364+action_268 (93) = happyGoto action_24+action_268 (95) = happyGoto action_90+action_268 (97) = happyGoto action_26+action_268 (104) = happyGoto action_27+action_268 (105) = happyGoto action_28+action_268 (106) = happyGoto action_29+action_268 (108) = happyGoto action_30+action_268 (114) = happyGoto action_31+action_268 (126) = happyGoto action_33+action_268 _ = happyFail++action_269 _ = happyReduce_218++action_270 (128) = happyShift action_34+action_270 (129) = happyShift action_35+action_270 (130) = happyShift action_36+action_270 (131) = happyShift action_37+action_270 (132) = happyShift action_38+action_270 (137) = happyShift action_39+action_270 (138) = happyShift action_40+action_270 (139) = happyShift action_41+action_270 (140) = happyShift action_42+action_270 (141) = happyShift action_43+action_270 (142) = happyShift action_44+action_270 (148) = happyShift action_45+action_270 (151) = happyShift action_46+action_270 (157) = happyShift action_47+action_270 (162) = happyShift action_48+action_270 (165) = happyShift action_49+action_270 (166) = happyShift action_50+action_270 (171) = happyShift action_54+action_270 (173) = happyShift action_55+action_270 (174) = happyShift action_56+action_270 (181) = happyShift action_62+action_270 (188) = happyShift action_65+action_270 (191) = happyShift action_68+action_270 (192) = happyShift action_69+action_270 (193) = happyShift action_70+action_270 (194) = happyShift action_71+action_270 (69) = happyGoto action_362+action_270 (70) = happyGoto action_89+action_270 (71) = happyGoto action_20+action_270 (72) = happyGoto action_21+action_270 (74) = happyGoto action_22+action_270 (75) = happyGoto action_23+action_270 (93) = happyGoto action_24+action_270 (95) = happyGoto action_90+action_270 (97) = happyGoto action_26+action_270 (104) = happyGoto action_27+action_270 (105) = happyGoto action_28+action_270 (106) = happyGoto action_29+action_270 (108) = happyGoto action_30+action_270 (114) = happyGoto action_31+action_270 (126) = happyGoto action_33+action_270 _ = happyFail++action_271 (146) = happyShift action_361+action_271 _ = happyFail++action_272 (47) = happyGoto action_358+action_272 (48) = happyGoto action_359+action_272 (115) = happyGoto action_360+action_272 _ = happyReduce_278++action_273 (130) = happyShift action_36+action_273 (44) = happyGoto action_356+action_273 (108) = happyGoto action_80+action_273 (121) = happyGoto action_357+action_273 _ = happyFail++action_274 (149) = happyShift action_355+action_274 _ = happyFail++action_275 _ = happyReduce_94++action_276 (143) = happyShift action_353+action_276 (150) = happyShift action_354+action_276 _ = happyFail++action_277 (143) = happyShift action_351+action_277 (150) = happyShift action_352+action_277 _ = happyFail++action_278 (143) = happyShift action_350+action_278 (150) = happyShift action_179+action_278 _ = happyFail++action_279 _ = happyReduce_93++action_280 (143) = happyShift action_349+action_280 _ = happyFail++action_281 (142) = happyShift action_347+action_281 (148) = happyShift action_348+action_281 _ = happyFail++action_282 _ = happyReduce_64++action_283 (145) = happyShift action_346+action_283 (118) = happyGoto action_345+action_283 _ = happyReduce_282++action_284 _ = happyReduce_85++action_285 (128) = happyShift action_34+action_285 (130) = happyShift action_36+action_285 (131) = happyShift action_200+action_285 (137) = happyShift action_201+action_285 (142) = happyShift action_202+action_285 (148) = happyShift action_203+action_285 (165) = happyShift action_49+action_285 (173) = happyShift action_55+action_285 (188) = happyShift action_65+action_285 (37) = happyGoto action_344+action_285 (38) = happyGoto action_192+action_285 (39) = happyGoto action_193+action_285 (40) = happyGoto action_194+action_285 (105) = happyGoto action_196+action_285 (107) = happyGoto action_197+action_285 (108) = happyGoto action_80+action_285 (121) = happyGoto action_198+action_285 (124) = happyGoto action_199+action_285 _ = happyFail++action_286 (128) = happyShift action_34+action_286 (130) = happyShift action_36+action_286 (131) = happyShift action_200+action_286 (137) = happyShift action_201+action_286 (142) = happyShift action_202+action_286 (148) = happyShift action_203+action_286 (165) = happyShift action_49+action_286 (173) = happyShift action_55+action_286 (188) = happyShift action_65+action_286 (37) = happyGoto action_343+action_286 (38) = happyGoto action_192+action_286 (39) = happyGoto action_193+action_286 (40) = happyGoto action_194+action_286 (105) = happyGoto action_196+action_286 (107) = happyGoto action_197+action_286 (108) = happyGoto action_80+action_286 (121) = happyGoto action_198+action_286 (124) = happyGoto action_199+action_286 _ = happyFail++action_287 _ = happyReduce_167++action_288 (128) = happyShift action_34+action_288 (129) = happyShift action_35+action_288 (130) = happyShift action_36+action_288 (131) = happyShift action_37+action_288 (132) = happyShift action_38+action_288 (137) = happyShift action_39+action_288 (138) = happyShift action_40+action_288 (139) = happyShift action_41+action_288 (140) = happyShift action_42+action_288 (141) = happyShift action_43+action_288 (142) = happyShift action_44+action_288 (148) = happyShift action_45+action_288 (151) = happyShift action_46+action_288 (157) = happyShift action_47+action_288 (162) = happyShift action_48+action_288 (165) = happyShift action_49+action_288 (166) = happyShift action_50+action_288 (171) = happyShift action_54+action_288 (173) = happyShift action_55+action_288 (174) = happyShift action_56+action_288 (181) = happyShift action_62+action_288 (188) = happyShift action_65+action_288 (191) = happyShift action_68+action_288 (192) = happyShift action_69+action_288 (193) = happyShift action_70+action_288 (194) = happyShift action_71+action_288 (70) = happyGoto action_340+action_288 (71) = happyGoto action_20+action_288 (72) = happyGoto action_21+action_288 (74) = happyGoto action_22+action_288 (75) = happyGoto action_23+action_288 (83) = happyGoto action_341+action_288 (84) = happyGoto action_342+action_288 (93) = happyGoto action_24+action_288 (95) = happyGoto action_90+action_288 (97) = happyGoto action_26+action_288 (104) = happyGoto action_27+action_288 (105) = happyGoto action_28+action_288 (106) = happyGoto action_29+action_288 (108) = happyGoto action_30+action_288 (114) = happyGoto action_31+action_288 (126) = happyGoto action_33+action_288 _ = happyFail++action_289 (117) = happyGoto action_339+action_289 _ = happyReduce_281++action_290 _ = happyReduce_163++action_291 _ = happyReduce_204++action_292 (150) = happyShift action_338+action_292 _ = happyReduce_198++action_293 _ = happyReduce_202++action_294 _ = happyReduce_196++action_295 (154) = happyShift action_337+action_295 _ = happyReduce_200++action_296 _ = happyReduce_199++action_297 _ = happyReduce_191++action_298 (128) = happyShift action_34+action_298 (130) = happyShift action_36+action_298 (131) = happyShift action_200+action_298 (137) = happyShift action_201+action_298 (142) = happyShift action_202+action_298 (148) = happyShift action_203+action_298 (165) = happyShift action_49+action_298 (173) = happyShift action_55+action_298 (188) = happyShift action_65+action_298 (37) = happyGoto action_191+action_298 (38) = happyGoto action_192+action_298 (39) = happyGoto action_193+action_298 (40) = happyGoto action_194+action_298 (41) = happyGoto action_336+action_298 (105) = happyGoto action_196+action_298 (107) = happyGoto action_197+action_298 (108) = happyGoto action_80+action_298 (121) = happyGoto action_198+action_298 (124) = happyGoto action_199+action_298 _ = happyFail++action_299 _ = happyReduce_183++action_300 _ = happyReduce_190++action_301 _ = happyReduce_184++action_302 _ = happyReduce_248++action_303 _ = happyReduce_244++action_304 _ = happyReduce_230++action_305 (143) = happyShift action_335+action_305 (150) = happyShift action_179+action_305 _ = happyFail++action_306 _ = happyReduce_229++action_307 _ = happyReduce_164++action_308 (146) = happyShift action_333+action_308 (150) = happyShift action_334+action_308 _ = happyFail++action_309 _ = happyReduce_224++action_310 (156) = happyShift action_332+action_310 _ = happyFail++action_311 (115) = happyGoto action_331+action_311 _ = happyReduce_278++action_312 _ = happyReduce_154++action_313 _ = happyReduce_156++action_314 _ = happyReduce_151++action_315 (145) = happyShift action_85+action_315 (34) = happyGoto action_330+action_315 (118) = happyGoto action_84+action_315 _ = happyReduce_282++action_316 _ = happyReduce_80++action_317 (143) = happyShift action_329+action_317 _ = happyFail++action_318 _ = happyReduce_53++action_319 _ = happyReduce_249++action_320 _ = happyReduce_250++action_321 (150) = happyShift action_328+action_321 _ = happyReduce_60++action_322 _ = happyReduce_245++action_323 _ = happyReduce_241++action_324 (128) = happyShift action_34+action_324 (130) = happyShift action_36+action_324 (165) = happyShift action_49+action_324 (173) = happyShift action_55+action_324 (188) = happyShift action_65+action_324 (105) = happyGoto action_326+action_324 (108) = happyGoto action_327+action_324 _ = happyFail++action_325 _ = happyReduce_5++action_326 (152) = happyShift action_436+action_326 _ = happyFail++action_327 (152) = happyShift action_435+action_327 _ = happyFail++action_328 (132) = happyShift action_137+action_328 (133) = happyShift action_118+action_328 (134) = happyShift action_119+action_328 (152) = happyShift action_324+action_328 (153) = happyShift action_125+action_328 (164) = happyShift action_126+action_328 (29) = happyGoto action_434+action_328 (98) = happyGoto action_319+action_328 (100) = happyGoto action_320+action_328 (102) = happyGoto action_321+action_328 (110) = happyGoto action_322+action_328 (112) = happyGoto action_323+action_328 _ = happyFail++action_329 _ = happyReduce_234++action_330 _ = happyReduce_152++action_331 (156) = happyShift action_433+action_331 _ = happyFail++action_332 (128) = happyShift action_34+action_332 (129) = happyShift action_35+action_332 (130) = happyShift action_36+action_332 (131) = happyShift action_37+action_332 (132) = happyShift action_38+action_332 (137) = happyShift action_39+action_332 (138) = happyShift action_40+action_332 (139) = happyShift action_41+action_332 (140) = happyShift action_42+action_332 (141) = happyShift action_43+action_332 (142) = happyShift action_44+action_332 (148) = happyShift action_45+action_332 (151) = happyShift action_46+action_332 (157) = happyShift action_47+action_332 (162) = happyShift action_48+action_332 (165) = happyShift action_49+action_332 (166) = happyShift action_50+action_332 (171) = happyShift action_54+action_332 (173) = happyShift action_55+action_332 (174) = happyShift action_56+action_332 (181) = happyShift action_62+action_332 (188) = happyShift action_65+action_332 (191) = happyShift action_68+action_332 (192) = happyShift action_69+action_332 (193) = happyShift action_70+action_332 (194) = happyShift action_71+action_332 (69) = happyGoto action_432+action_332 (70) = happyGoto action_89+action_332 (71) = happyGoto action_20+action_332 (72) = happyGoto action_21+action_332 (74) = happyGoto action_22+action_332 (75) = happyGoto action_23+action_332 (93) = happyGoto action_24+action_332 (95) = happyGoto action_90+action_332 (97) = happyGoto action_26+action_332 (104) = happyGoto action_27+action_332 (105) = happyGoto action_28+action_332 (106) = happyGoto action_29+action_332 (108) = happyGoto action_30+action_332 (114) = happyGoto action_31+action_332 (126) = happyGoto action_33+action_332 _ = happyFail++action_333 _ = happyReduce_175++action_334 (128) = happyShift action_34+action_334 (129) = happyShift action_35+action_334 (142) = happyShift action_241+action_334 (165) = happyShift action_49+action_334 (173) = happyShift action_55+action_334 (188) = happyShift action_65+action_334 (92) = happyGoto action_431+action_334 (95) = happyGoto action_310+action_334 (104) = happyGoto action_27+action_334 (105) = happyGoto action_28+action_334 _ = happyFail++action_335 _ = happyReduce_231++action_336 _ = happyReduce_159++action_337 (128) = happyShift action_34+action_337 (129) = happyShift action_35+action_337 (130) = happyShift action_36+action_337 (131) = happyShift action_37+action_337 (132) = happyShift action_38+action_337 (137) = happyShift action_39+action_337 (138) = happyShift action_40+action_337 (139) = happyShift action_41+action_337 (140) = happyShift action_42+action_337 (141) = happyShift action_43+action_337 (142) = happyShift action_44+action_337 (148) = happyShift action_45+action_337 (151) = happyShift action_46+action_337 (157) = happyShift action_47+action_337 (162) = happyShift action_48+action_337 (165) = happyShift action_49+action_337 (166) = happyShift action_50+action_337 (171) = happyShift action_54+action_337 (173) = happyShift action_55+action_337 (174) = happyShift action_56+action_337 (181) = happyShift action_62+action_337 (188) = happyShift action_65+action_337 (191) = happyShift action_68+action_337 (192) = happyShift action_69+action_337 (193) = happyShift action_70+action_337 (194) = happyShift action_71+action_337 (69) = happyGoto action_430+action_337 (70) = happyGoto action_89+action_337 (71) = happyGoto action_20+action_337 (72) = happyGoto action_21+action_337 (74) = happyGoto action_22+action_337 (75) = happyGoto action_23+action_337 (93) = happyGoto action_24+action_337 (95) = happyGoto action_90+action_337 (97) = happyGoto action_26+action_337 (104) = happyGoto action_27+action_337 (105) = happyGoto action_28+action_337 (106) = happyGoto action_29+action_337 (108) = happyGoto action_30+action_337 (114) = happyGoto action_31+action_337 (126) = happyGoto action_33+action_337 _ = happyReduce_195++action_338 (128) = happyShift action_34+action_338 (129) = happyShift action_35+action_338 (130) = happyShift action_36+action_338 (131) = happyShift action_37+action_338 (132) = happyShift action_38+action_338 (137) = happyShift action_39+action_338 (138) = happyShift action_40+action_338 (139) = happyShift action_41+action_338 (140) = happyShift action_42+action_338 (141) = happyShift action_43+action_338 (142) = happyShift action_44+action_338 (148) = happyShift action_45+action_338 (151) = happyShift action_46+action_338 (157) = happyShift action_47+action_338 (162) = happyShift action_48+action_338 (165) = happyShift action_49+action_338 (166) = happyShift action_50+action_338 (171) = happyShift action_54+action_338 (173) = happyShift action_55+action_338 (174) = happyShift action_56+action_338 (181) = happyShift action_216+action_338 (188) = happyShift action_65+action_338 (191) = happyShift action_68+action_338 (192) = happyShift action_69+action_338 (193) = happyShift action_70+action_338 (194) = happyShift action_71+action_338 (69) = happyGoto action_291+action_338 (70) = happyGoto action_212+action_338 (71) = happyGoto action_20+action_338 (72) = happyGoto action_21+action_338 (74) = happyGoto action_22+action_338 (75) = happyGoto action_23+action_338 (81) = happyGoto action_429+action_338 (93) = happyGoto action_24+action_338 (95) = happyGoto action_90+action_338 (97) = happyGoto action_26+action_338 (104) = happyGoto action_27+action_338 (105) = happyGoto action_28+action_338 (106) = happyGoto action_29+action_338 (108) = happyGoto action_30+action_338 (114) = happyGoto action_31+action_338 (126) = happyGoto action_33+action_338 _ = happyFail++action_339 (128) = happyShift action_34+action_339 (129) = happyShift action_35+action_339 (130) = happyShift action_36+action_339 (131) = happyShift action_37+action_339 (132) = happyShift action_38+action_339 (137) = happyShift action_39+action_339 (138) = happyShift action_40+action_339 (139) = happyShift action_41+action_339 (140) = happyShift action_42+action_339 (141) = happyShift action_43+action_339 (142) = happyShift action_44+action_339 (148) = happyShift action_45+action_339 (151) = happyShift action_46+action_339 (157) = happyShift action_47+action_339 (162) = happyShift action_48+action_339 (165) = happyShift action_49+action_339 (166) = happyShift action_50+action_339 (171) = happyShift action_54+action_339 (173) = happyShift action_55+action_339 (174) = happyShift action_56+action_339 (181) = happyShift action_62+action_339 (188) = happyShift action_65+action_339 (191) = happyShift action_68+action_339 (192) = happyShift action_69+action_339 (193) = happyShift action_70+action_339 (194) = happyShift action_71+action_339 (70) = happyGoto action_340+action_339 (71) = happyGoto action_20+action_339 (72) = happyGoto action_21+action_339 (74) = happyGoto action_22+action_339 (75) = happyGoto action_23+action_339 (83) = happyGoto action_428+action_339 (84) = happyGoto action_342+action_339 (93) = happyGoto action_24+action_339 (95) = happyGoto action_90+action_339 (97) = happyGoto action_26+action_339 (104) = happyGoto action_27+action_339 (105) = happyGoto action_28+action_339 (106) = happyGoto action_29+action_339 (108) = happyGoto action_30+action_339 (114) = happyGoto action_31+action_339 (126) = happyGoto action_33+action_339 _ = happyFail++action_340 (132) = happyShift action_137+action_340 (133) = happyShift action_118+action_340 (134) = happyShift action_119+action_340 (135) = happyShift action_120+action_340 (136) = happyShift action_121+action_340 (152) = happyShift action_124+action_340 (153) = happyShift action_125+action_340 (164) = happyShift action_126+action_340 (99) = happyGoto action_109+action_340 (101) = happyGoto action_110+action_340 (103) = happyGoto action_133+action_340 (109) = happyGoto action_134+action_340 (110) = happyGoto action_113+action_340 (111) = happyGoto action_135+action_340 (112) = happyGoto action_115+action_340 (113) = happyGoto action_116+action_340 (115) = happyGoto action_427+action_340 _ = happyReduce_278++action_341 (144) = happyShift action_426+action_341 (7) = happyGoto action_425+action_341 _ = happyReduce_10++action_342 _ = happyReduce_209++action_343 _ = happyReduce_100++action_344 _ = happyReduce_83++action_345 (128) = happyShift action_34+action_345 (129) = happyShift action_35+action_345 (142) = happyShift action_241+action_345 (144) = happyShift action_226+action_345 (165) = happyShift action_49+action_345 (173) = happyShift action_55+action_345 (188) = happyShift action_65+action_345 (7) = happyGoto action_420+action_345 (35) = happyGoto action_421+action_345 (36) = happyGoto action_17+action_345 (59) = happyGoto action_422+action_345 (60) = happyGoto action_423+action_345 (95) = happyGoto action_424+action_345 (104) = happyGoto action_27+action_345 (105) = happyGoto action_28+action_345 _ = happyReduce_10++action_346 (117) = happyGoto action_419+action_346 _ = happyReduce_281++action_347 (143) = happyShift action_418+action_347 (150) = happyShift action_123+action_347 (76) = happyGoto action_417+action_347 _ = happyFail++action_348 (149) = happyShift action_416+action_348 _ = happyFail++action_349 _ = happyReduce_95++action_350 _ = happyReduce_96++action_351 _ = happyReduce_89++action_352 (128) = happyShift action_34+action_352 (130) = happyShift action_36+action_352 (131) = happyShift action_200+action_352 (137) = happyShift action_201+action_352 (142) = happyShift action_202+action_352 (148) = happyShift action_203+action_352 (165) = happyShift action_49+action_352 (173) = happyShift action_55+action_352 (188) = happyShift action_65+action_352 (37) = happyGoto action_415+action_352 (38) = happyGoto action_192+action_352 (39) = happyGoto action_193+action_352 (40) = happyGoto action_194+action_352 (105) = happyGoto action_196+action_352 (107) = happyGoto action_197+action_352 (108) = happyGoto action_80+action_352 (121) = happyGoto action_198+action_352 (124) = happyGoto action_199+action_352 _ = happyFail++action_353 _ = happyReduce_91++action_354 (128) = happyShift action_34+action_354 (130) = happyShift action_36+action_354 (131) = happyShift action_200+action_354 (137) = happyShift action_201+action_354 (142) = happyShift action_202+action_354 (148) = happyShift action_203+action_354 (165) = happyShift action_49+action_354 (173) = happyShift action_55+action_354 (188) = happyShift action_65+action_354 (37) = happyGoto action_414+action_354 (38) = happyGoto action_192+action_354 (39) = happyGoto action_193+action_354 (40) = happyGoto action_194+action_354 (105) = happyGoto action_196+action_354 (107) = happyGoto action_197+action_354 (108) = happyGoto action_80+action_354 (121) = happyGoto action_198+action_354 (124) = happyGoto action_199+action_354 _ = happyFail++action_355 _ = happyReduce_90++action_356 _ = happyReduce_104++action_357 (128) = happyShift action_34+action_357 (156) = happyReduce_107+action_357 (165) = happyShift action_49+action_357 (173) = happyShift action_55+action_357 (188) = happyShift action_65+action_357 (45) = happyGoto action_231+action_357 (105) = happyGoto action_196+action_357 (124) = happyGoto action_232+action_357 _ = happyReduce_110++action_358 (158) = happyShift action_413+action_358 (170) = happyShift action_392+action_358 (56) = happyGoto action_412+action_358 _ = happyReduce_130++action_359 _ = happyReduce_113++action_360 (128) = happyShift action_34+action_360 (130) = happyShift action_36+action_360 (131) = happyShift action_200+action_360 (137) = happyShift action_201+action_360 (142) = happyShift action_410+action_360 (148) = happyShift action_203+action_360 (164) = happyShift action_411+action_360 (165) = happyShift action_49+action_360 (173) = happyShift action_55+action_360 (188) = happyShift action_65+action_360 (38) = happyGoto action_404+action_360 (39) = happyGoto action_193+action_360 (40) = happyGoto action_194+action_360 (49) = happyGoto action_405+action_360 (50) = happyGoto action_406+action_360 (52) = happyGoto action_407+action_360 (96) = happyGoto action_408+action_360 (105) = happyGoto action_196+action_360 (107) = happyGoto action_197+action_360 (108) = happyGoto action_409+action_360 (121) = happyGoto action_198+action_360 (124) = happyGoto action_199+action_360 _ = happyFail++action_361 _ = happyReduce_217++action_362 _ = happyReduce_203++action_363 (144) = happyReduce_204+action_363 _ = happyReduce_219++action_364 _ = happyReduce_221++action_365 (128) = happyShift action_34+action_365 (129) = happyShift action_35+action_365 (130) = happyShift action_36+action_365 (131) = happyShift action_37+action_365 (132) = happyShift action_38+action_365 (137) = happyShift action_39+action_365 (138) = happyShift action_40+action_365 (139) = happyShift action_41+action_365 (140) = happyShift action_42+action_365 (141) = happyShift action_43+action_365 (142) = happyShift action_44+action_365 (148) = happyShift action_45+action_365 (151) = happyShift action_46+action_365 (157) = happyShift action_47+action_365 (162) = happyShift action_48+action_365 (165) = happyShift action_49+action_365 (166) = happyShift action_50+action_365 (171) = happyShift action_54+action_365 (173) = happyShift action_55+action_365 (174) = happyShift action_56+action_365 (181) = happyShift action_62+action_365 (188) = happyShift action_65+action_365 (191) = happyShift action_68+action_365 (192) = happyShift action_69+action_365 (193) = happyShift action_70+action_365 (194) = happyShift action_71+action_365 (69) = happyGoto action_403+action_365 (70) = happyGoto action_89+action_365 (71) = happyGoto action_20+action_365 (72) = happyGoto action_21+action_365 (74) = happyGoto action_22+action_365 (75) = happyGoto action_23+action_365 (93) = happyGoto action_24+action_365 (95) = happyGoto action_90+action_365 (97) = happyGoto action_26+action_365 (104) = happyGoto action_27+action_365 (105) = happyGoto action_28+action_365 (106) = happyGoto action_29+action_365 (108) = happyGoto action_30+action_365 (114) = happyGoto action_31+action_365 (126) = happyGoto action_33+action_365 _ = happyFail++action_366 (142) = happyShift action_401+action_366 (173) = happyShift action_402+action_366 (19) = happyGoto action_399+action_366 (20) = happyGoto action_400+action_366 _ = happyReduce_37++action_367 (130) = happyShift action_73+action_367 (119) = happyGoto action_398+action_367 _ = happyFail++action_368 (128) = happyShift action_34+action_368 (129) = happyShift action_35+action_368 (130) = happyShift action_36+action_368 (131) = happyShift action_37+action_368 (132) = happyShift action_38+action_368 (137) = happyShift action_39+action_368 (138) = happyShift action_40+action_368 (139) = happyShift action_41+action_368 (140) = happyShift action_42+action_368 (141) = happyShift action_43+action_368 (142) = happyShift action_44+action_368 (144) = happyShift action_226+action_368 (148) = happyShift action_45+action_368 (151) = happyShift action_46+action_368 (157) = happyShift action_47+action_368 (162) = happyShift action_48+action_368 (165) = happyShift action_49+action_368 (166) = happyShift action_50+action_368 (171) = happyShift action_54+action_368 (173) = happyShift action_55+action_368 (174) = happyShift action_56+action_368 (181) = happyShift action_62+action_368 (188) = happyShift action_65+action_368 (191) = happyShift action_68+action_368 (192) = happyShift action_69+action_368 (193) = happyShift action_70+action_368 (194) = happyShift action_71+action_368 (7) = happyGoto action_394+action_368 (61) = happyGoto action_395+action_368 (63) = happyGoto action_396+action_368 (64) = happyGoto action_397+action_368 (70) = happyGoto action_19+action_368 (71) = happyGoto action_20+action_368 (72) = happyGoto action_21+action_368 (74) = happyGoto action_22+action_368 (75) = happyGoto action_23+action_368 (93) = happyGoto action_24+action_368 (95) = happyGoto action_90+action_368 (97) = happyGoto action_26+action_368 (104) = happyGoto action_27+action_368 (105) = happyGoto action_28+action_368 (106) = happyGoto action_29+action_368 (108) = happyGoto action_30+action_368 (114) = happyGoto action_31+action_368 (126) = happyGoto action_33+action_368 _ = happyReduce_10++action_369 (117) = happyGoto action_393+action_369 _ = happyReduce_281++action_370 _ = happyReduce_78++action_371 _ = happyReduce_72++action_372 (170) = happyShift action_392+action_372 (56) = happyGoto action_391+action_372 _ = happyReduce_130++action_373 _ = happyReduce_61++action_374 _ = happyReduce_68++action_375 (128) = happyShift action_34+action_375 (129) = happyShift action_35+action_375 (130) = happyShift action_36+action_375 (131) = happyShift action_37+action_375 (132) = happyShift action_38+action_375 (137) = happyShift action_39+action_375 (138) = happyShift action_40+action_375 (139) = happyShift action_41+action_375 (140) = happyShift action_42+action_375 (141) = happyShift action_43+action_375 (142) = happyShift action_44+action_375 (148) = happyShift action_45+action_375 (151) = happyShift action_46+action_375 (157) = happyShift action_47+action_375 (162) = happyShift action_48+action_375 (165) = happyShift action_49+action_375 (166) = happyShift action_50+action_375 (171) = happyShift action_54+action_375 (173) = happyShift action_55+action_375 (174) = happyShift action_56+action_375 (181) = happyShift action_62+action_375 (188) = happyShift action_65+action_375 (191) = happyShift action_68+action_375 (192) = happyShift action_69+action_375 (193) = happyShift action_70+action_375 (194) = happyShift action_71+action_375 (69) = happyGoto action_390+action_375 (70) = happyGoto action_89+action_375 (71) = happyGoto action_20+action_375 (72) = happyGoto action_21+action_375 (74) = happyGoto action_22+action_375 (75) = happyGoto action_23+action_375 (93) = happyGoto action_24+action_375 (95) = happyGoto action_90+action_375 (97) = happyGoto action_26+action_375 (104) = happyGoto action_27+action_375 (105) = happyGoto action_28+action_375 (106) = happyGoto action_29+action_375 (108) = happyGoto action_30+action_375 (114) = happyGoto action_31+action_375 (126) = happyGoto action_33+action_375 _ = happyFail++action_376 _ = happyReduce_294++action_377 _ = happyReduce_17++action_378 _ = happyReduce_13++action_379 (143) = happyShift action_388+action_379 (150) = happyShift action_389+action_379 _ = happyFail++action_380 _ = happyReduce_26++action_381 _ = happyReduce_27++action_382 _ = happyReduce_28++action_383 (132) = happyShift action_137+action_383 (133) = happyShift action_118+action_383 (134) = happyShift action_119+action_383 (135) = happyShift action_120+action_383 (136) = happyShift action_121+action_383 (153) = happyShift action_125+action_383 (164) = happyShift action_126+action_383 (109) = happyGoto action_387+action_383 (110) = happyGoto action_113+action_383 (111) = happyGoto action_247+action_383 (112) = happyGoto action_115+action_383 (113) = happyGoto action_116+action_383 _ = happyFail++action_384 _ = happyReduce_22++action_385 (143) = happyShift action_386+action_385 _ = happyFail++action_386 _ = happyReduce_21++action_387 (143) = happyShift action_174+action_387 _ = happyFail++action_388 _ = happyReduce_23++action_389 (128) = happyShift action_34+action_389 (129) = happyShift action_35+action_389 (130) = happyShift action_36+action_389 (131) = happyShift action_37+action_389 (142) = happyShift action_383+action_389 (165) = happyShift action_49+action_389 (173) = happyShift action_55+action_389 (188) = happyShift action_65+action_389 (14) = happyGoto action_474+action_389 (95) = happyGoto action_381+action_389 (97) = happyGoto action_382+action_389 (104) = happyGoto action_27+action_389 (105) = happyGoto action_28+action_389 (106) = happyGoto action_29+action_389 (108) = happyGoto action_30+action_389 _ = happyFail++action_390 _ = happyReduce_289++action_391 _ = happyReduce_63++action_392 (130) = happyShift action_36+action_392 (131) = happyShift action_200+action_392 (142) = happyShift action_473+action_392 (107) = happyGoto action_471+action_392 (108) = happyGoto action_80+action_392 (121) = happyGoto action_198+action_392 (123) = happyGoto action_472+action_392 _ = happyFail++action_393 (128) = happyShift action_34+action_393 (129) = happyShift action_35+action_393 (130) = happyShift action_36+action_393 (131) = happyShift action_37+action_393 (132) = happyShift action_38+action_393 (137) = happyShift action_39+action_393 (138) = happyShift action_40+action_393 (139) = happyShift action_41+action_393 (140) = happyShift action_42+action_393 (141) = happyShift action_43+action_393 (142) = happyShift action_44+action_393 (144) = happyShift action_226+action_393 (148) = happyShift action_45+action_393 (151) = happyShift action_46+action_393 (157) = happyShift action_47+action_393 (162) = happyShift action_48+action_393 (165) = happyShift action_49+action_393 (166) = happyShift action_50+action_393 (171) = happyShift action_54+action_393 (173) = happyShift action_55+action_393 (174) = happyShift action_56+action_393 (181) = happyShift action_62+action_393 (188) = happyShift action_65+action_393 (191) = happyShift action_68+action_393 (192) = happyShift action_69+action_393 (193) = happyShift action_70+action_393 (194) = happyShift action_71+action_393 (7) = happyGoto action_394+action_393 (61) = happyGoto action_395+action_393 (63) = happyGoto action_470+action_393 (64) = happyGoto action_397+action_393 (70) = happyGoto action_19+action_393 (71) = happyGoto action_20+action_393 (72) = happyGoto action_21+action_393 (74) = happyGoto action_22+action_393 (75) = happyGoto action_23+action_393 (93) = happyGoto action_24+action_393 (95) = happyGoto action_90+action_393 (97) = happyGoto action_26+action_393 (104) = happyGoto action_27+action_393 (105) = happyGoto action_28+action_393 (106) = happyGoto action_29+action_393 (108) = happyGoto action_30+action_393 (114) = happyGoto action_31+action_393 (126) = happyGoto action_33+action_393 _ = happyReduce_10++action_394 _ = happyReduce_150++action_395 (144) = happyShift action_469+action_395 (7) = happyGoto action_468+action_395 _ = happyReduce_10++action_396 (1) = happyShift action_146+action_396 (147) = happyShift action_147+action_396 (116) = happyGoto action_467+action_396 _ = happyFail++action_397 _ = happyReduce_145++action_398 _ = happyReduce_34++action_399 _ = happyReduce_31++action_400 _ = happyReduce_36++action_401 (128) = happyShift action_34+action_401 (130) = happyShift action_36+action_401 (142) = happyShift action_157+action_401 (165) = happyShift action_49+action_401 (173) = happyShift action_55+action_401 (188) = happyShift action_65+action_401 (21) = happyGoto action_462+action_401 (22) = happyGoto action_463+action_401 (94) = happyGoto action_464+action_401 (105) = happyGoto action_156+action_401 (108) = happyGoto action_465+action_401 (120) = happyGoto action_466+action_401 _ = happyFail++action_402 (142) = happyShift action_461+action_402 _ = happyFail++action_403 _ = happyReduce_166++action_404 (128) = happyShift action_34+action_404 (130) = happyShift action_36+action_404 (131) = happyShift action_200+action_404 (134) = happyReduce_123+action_404 (137) = happyShift action_201+action_404 (142) = happyShift action_202+action_404 (148) = happyShift action_203+action_404 (152) = happyReduce_123+action_404 (164) = happyShift action_460+action_404 (165) = happyShift action_49+action_404 (173) = happyShift action_55+action_404 (188) = happyShift action_65+action_404 (39) = happyGoto action_284+action_404 (40) = happyGoto action_194+action_404 (105) = happyGoto action_196+action_404 (107) = happyGoto action_197+action_404 (108) = happyGoto action_80+action_404 (121) = happyGoto action_198+action_404 (124) = happyGoto action_199+action_404 _ = happyReduce_117++action_405 _ = happyReduce_114++action_406 (128) = happyShift action_34+action_406 (130) = happyShift action_36+action_406 (131) = happyShift action_200+action_406 (137) = happyShift action_201+action_406 (142) = happyShift action_202+action_406 (148) = happyShift action_203+action_406 (164) = happyShift action_459+action_406 (165) = happyShift action_49+action_406 (173) = happyShift action_55+action_406 (188) = happyShift action_65+action_406 (39) = happyGoto action_457+action_406 (40) = happyGoto action_194+action_406 (51) = happyGoto action_458+action_406 (105) = happyGoto action_196+action_406 (107) = happyGoto action_197+action_406 (108) = happyGoto action_80+action_406 (121) = happyGoto action_198+action_406 (124) = happyGoto action_199+action_406 _ = happyReduce_118++action_407 (134) = happyShift action_119+action_407 (152) = happyShift action_456+action_407 (100) = happyGoto action_455+action_407 (110) = happyGoto action_322+action_407 _ = happyFail++action_408 (145) = happyShift action_454+action_408 _ = happyFail++action_409 (145) = happyReduce_237+action_409 _ = happyReduce_285++action_410 (128) = happyShift action_34+action_410 (130) = happyShift action_36+action_410 (131) = happyShift action_200+action_410 (134) = happyShift action_119+action_410 (137) = happyShift action_201+action_410 (142) = happyShift action_202+action_410 (143) = happyShift action_279+action_410 (148) = happyShift action_203+action_410 (150) = happyShift action_123+action_410 (160) = happyShift action_280+action_410 (165) = happyShift action_49+action_410 (173) = happyShift action_55+action_410 (188) = happyShift action_65+action_410 (37) = happyGoto action_276+action_410 (38) = happyGoto action_192+action_410 (39) = happyGoto action_193+action_410 (40) = happyGoto action_194+action_410 (42) = happyGoto action_277+action_410 (76) = happyGoto action_278+action_410 (105) = happyGoto action_196+action_410 (107) = happyGoto action_197+action_410 (108) = happyGoto action_80+action_410 (110) = happyGoto action_453+action_410 (121) = happyGoto action_198+action_410 (124) = happyGoto action_199+action_410 _ = happyFail++action_411 (128) = happyShift action_34+action_411 (130) = happyShift action_36+action_411 (131) = happyShift action_200+action_411 (137) = happyShift action_201+action_411 (142) = happyShift action_202+action_411 (148) = happyShift action_203+action_411 (165) = happyShift action_49+action_411 (173) = happyShift action_55+action_411 (188) = happyShift action_65+action_411 (39) = happyGoto action_452+action_411 (40) = happyGoto action_194+action_411 (105) = happyGoto action_196+action_411 (107) = happyGoto action_197+action_411 (108) = happyGoto action_80+action_411 (121) = happyGoto action_198+action_411 (124) = happyGoto action_199+action_411 _ = happyFail++action_412 _ = happyReduce_62++action_413 (48) = happyGoto action_451+action_413 (115) = happyGoto action_360+action_413 _ = happyReduce_278++action_414 _ = happyReduce_103++action_415 _ = happyReduce_102++action_416 _ = happyReduce_98++action_417 (143) = happyShift action_450+action_417 (150) = happyShift action_179+action_417 _ = happyFail++action_418 _ = happyReduce_97++action_419 (128) = happyShift action_34+action_419 (129) = happyShift action_35+action_419 (142) = happyShift action_241+action_419 (144) = happyShift action_226+action_419 (165) = happyShift action_49+action_419 (173) = happyShift action_55+action_419 (188) = happyShift action_65+action_419 (7) = happyGoto action_420+action_419 (35) = happyGoto action_421+action_419 (36) = happyGoto action_17+action_419 (59) = happyGoto action_449+action_419 (60) = happyGoto action_423+action_419 (95) = happyGoto action_424+action_419 (104) = happyGoto action_27+action_419 (105) = happyGoto action_28+action_419 _ = happyReduce_10++action_420 _ = happyReduce_141++action_421 _ = happyReduce_143++action_422 (1) = happyShift action_146+action_422 (147) = happyShift action_147+action_422 (116) = happyGoto action_448+action_422 _ = happyFail++action_423 (144) = happyShift action_447+action_423 (7) = happyGoto action_446+action_423 _ = happyReduce_10++action_424 _ = happyReduce_82++action_425 (1) = happyShift action_146+action_425 (147) = happyShift action_147+action_425 (116) = happyGoto action_445+action_425 _ = happyFail++action_426 (128) = happyShift action_34+action_426 (129) = happyShift action_35+action_426 (130) = happyShift action_36+action_426 (131) = happyShift action_37+action_426 (132) = happyShift action_38+action_426 (137) = happyShift action_39+action_426 (138) = happyShift action_40+action_426 (139) = happyShift action_41+action_426 (140) = happyShift action_42+action_426 (141) = happyShift action_43+action_426 (142) = happyShift action_44+action_426 (148) = happyShift action_45+action_426 (151) = happyShift action_46+action_426 (157) = happyShift action_47+action_426 (162) = happyShift action_48+action_426 (165) = happyShift action_49+action_426 (166) = happyShift action_50+action_426 (171) = happyShift action_54+action_426 (173) = happyShift action_55+action_426 (174) = happyShift action_56+action_426 (181) = happyShift action_62+action_426 (188) = happyShift action_65+action_426 (191) = happyShift action_68+action_426 (192) = happyShift action_69+action_426 (193) = happyShift action_70+action_426 (194) = happyShift action_71+action_426 (70) = happyGoto action_340+action_426 (71) = happyGoto action_20+action_426 (72) = happyGoto action_21+action_426 (74) = happyGoto action_22+action_426 (75) = happyGoto action_23+action_426 (84) = happyGoto action_444+action_426 (93) = happyGoto action_24+action_426 (95) = happyGoto action_90+action_426 (97) = happyGoto action_26+action_426 (104) = happyGoto action_27+action_426 (105) = happyGoto action_28+action_426 (106) = happyGoto action_29+action_426 (108) = happyGoto action_30+action_426 (114) = happyGoto action_31+action_426 (126) = happyGoto action_33+action_426 _ = happyReduce_9++action_427 (158) = happyShift action_442+action_427 (160) = happyShift action_443+action_427 (85) = happyGoto action_439+action_427 (86) = happyGoto action_440+action_427 (87) = happyGoto action_441+action_427 _ = happyFail++action_428 (144) = happyShift action_426+action_428 (7) = happyGoto action_438+action_428 _ = happyReduce_10++action_429 _ = happyReduce_201++action_430 _ = happyReduce_197++action_431 _ = happyReduce_223++action_432 _ = happyReduce_225++action_433 (128) = happyShift action_34+action_433 (129) = happyShift action_35+action_433 (130) = happyShift action_36+action_433 (131) = happyShift action_37+action_433 (132) = happyShift action_38+action_433 (137) = happyShift action_39+action_433 (138) = happyShift action_40+action_433 (139) = happyShift action_41+action_433 (140) = happyShift action_42+action_433 (141) = happyShift action_43+action_433 (142) = happyShift action_44+action_433 (148) = happyShift action_45+action_433 (151) = happyShift action_46+action_433 (157) = happyShift action_47+action_433 (162) = happyShift action_48+action_433 (165) = happyShift action_49+action_433 (166) = happyShift action_50+action_433 (171) = happyShift action_54+action_433 (173) = happyShift action_55+action_433 (174) = happyShift action_56+action_433 (181) = happyShift action_62+action_433 (188) = happyShift action_65+action_433 (191) = happyShift action_68+action_433 (192) = happyShift action_69+action_433 (193) = happyShift action_70+action_433 (194) = happyShift action_71+action_433 (69) = happyGoto action_437+action_433 (70) = happyGoto action_89+action_433 (71) = happyGoto action_20+action_433 (72) = happyGoto action_21+action_433 (74) = happyGoto action_22+action_433 (75) = happyGoto action_23+action_433 (93) = happyGoto action_24+action_433 (95) = happyGoto action_90+action_433 (97) = happyGoto action_26+action_433 (104) = happyGoto action_27+action_433 (105) = happyGoto action_28+action_433 (106) = happyGoto action_29+action_433 (108) = happyGoto action_30+action_433 (114) = happyGoto action_31+action_433 (126) = happyGoto action_33+action_433 _ = happyFail++action_434 _ = happyReduce_59++action_435 _ = happyReduce_246++action_436 _ = happyReduce_242++action_437 _ = happyReduce_158++action_438 (146) = happyShift action_497+action_438 _ = happyFail++action_439 (187) = happyShift action_496+action_439 _ = happyReduce_210++action_440 (158) = happyShift action_442+action_440 (87) = happyGoto action_495+action_440 _ = happyReduce_213++action_441 _ = happyReduce_215++action_442 (115) = happyGoto action_494+action_442 _ = happyReduce_278++action_443 (128) = happyShift action_34+action_443 (129) = happyShift action_35+action_443 (130) = happyShift action_36+action_443 (131) = happyShift action_37+action_443 (132) = happyShift action_38+action_443 (137) = happyShift action_39+action_443 (138) = happyShift action_40+action_443 (139) = happyShift action_41+action_443 (140) = happyShift action_42+action_443 (141) = happyShift action_43+action_443 (142) = happyShift action_44+action_443 (148) = happyShift action_45+action_443 (151) = happyShift action_46+action_443 (157) = happyShift action_47+action_443 (162) = happyShift action_48+action_443 (165) = happyShift action_49+action_443 (166) = happyShift action_50+action_443 (171) = happyShift action_54+action_443 (173) = happyShift action_55+action_443 (174) = happyShift action_56+action_443 (181) = happyShift action_62+action_443 (188) = happyShift action_65+action_443 (191) = happyShift action_68+action_443 (192) = happyShift action_69+action_443 (193) = happyShift action_70+action_443 (194) = happyShift action_71+action_443 (69) = happyGoto action_493+action_443 (70) = happyGoto action_89+action_443 (71) = happyGoto action_20+action_443 (72) = happyGoto action_21+action_443 (74) = happyGoto action_22+action_443 (75) = happyGoto action_23+action_443 (93) = happyGoto action_24+action_443 (95) = happyGoto action_90+action_443 (97) = happyGoto action_26+action_443 (104) = happyGoto action_27+action_443 (105) = happyGoto action_28+action_443 (106) = happyGoto action_29+action_443 (108) = happyGoto action_30+action_443 (114) = happyGoto action_31+action_443 (126) = happyGoto action_33+action_443 _ = happyFail++action_444 _ = happyReduce_208++action_445 _ = happyReduce_207++action_446 _ = happyReduce_140++action_447 (128) = happyShift action_34+action_447 (129) = happyShift action_35+action_447 (130) = happyShift action_36+action_447 (131) = happyShift action_37+action_447 (132) = happyShift action_38+action_447 (137) = happyShift action_39+action_447 (138) = happyShift action_40+action_447 (139) = happyShift action_41+action_447 (140) = happyShift action_42+action_447 (141) = happyShift action_43+action_447 (142) = happyShift action_44+action_447 (148) = happyShift action_45+action_447 (151) = happyShift action_46+action_447 (157) = happyShift action_47+action_447 (162) = happyShift action_48+action_447 (165) = happyShift action_49+action_447 (166) = happyShift action_50+action_447 (171) = happyShift action_54+action_447 (173) = happyShift action_55+action_447 (174) = happyShift action_56+action_447 (181) = happyShift action_62+action_447 (188) = happyShift action_65+action_447 (191) = happyShift action_68+action_447 (192) = happyShift action_69+action_447 (193) = happyShift action_70+action_447 (194) = happyShift action_71+action_447 (35) = happyGoto action_491+action_447 (36) = happyGoto action_17+action_447 (61) = happyGoto action_492+action_447 (64) = happyGoto action_397+action_447 (70) = happyGoto action_19+action_447 (71) = happyGoto action_20+action_447 (72) = happyGoto action_21+action_447 (74) = happyGoto action_22+action_447 (75) = happyGoto action_23+action_447 (93) = happyGoto action_24+action_447 (95) = happyGoto action_25+action_447 (97) = happyGoto action_26+action_447 (104) = happyGoto action_27+action_447 (105) = happyGoto action_28+action_447 (106) = happyGoto action_29+action_447 (108) = happyGoto action_30+action_447 (114) = happyGoto action_31+action_447 (126) = happyGoto action_33+action_447 _ = happyReduce_9++action_448 _ = happyReduce_137++action_449 (146) = happyShift action_490+action_449 _ = happyFail++action_450 _ = happyReduce_99++action_451 _ = happyReduce_112++action_452 _ = happyReduce_124++action_453 (143) = happyShift action_489+action_453 _ = happyFail++action_454 (117) = happyGoto action_488+action_454 _ = happyReduce_281++action_455 (128) = happyShift action_34+action_455 (130) = happyShift action_36+action_455 (131) = happyShift action_200+action_455 (137) = happyShift action_201+action_455 (142) = happyShift action_202+action_455 (148) = happyShift action_203+action_455 (164) = happyShift action_411+action_455 (165) = happyShift action_49+action_455 (173) = happyShift action_55+action_455 (188) = happyShift action_65+action_455 (38) = happyGoto action_486+action_455 (39) = happyGoto action_193+action_455 (40) = happyGoto action_194+action_455 (52) = happyGoto action_487+action_455 (105) = happyGoto action_196+action_455 (107) = happyGoto action_197+action_455 (108) = happyGoto action_80+action_455 (121) = happyGoto action_198+action_455 (124) = happyGoto action_199+action_455 _ = happyFail++action_456 (130) = happyShift action_36+action_456 (108) = happyGoto action_327+action_456 _ = happyFail++action_457 _ = happyReduce_121++action_458 _ = happyReduce_120++action_459 (128) = happyShift action_34+action_459 (130) = happyShift action_36+action_459 (131) = happyShift action_200+action_459 (137) = happyShift action_201+action_459 (142) = happyShift action_202+action_459 (148) = happyShift action_203+action_459 (165) = happyShift action_49+action_459 (173) = happyShift action_55+action_459 (188) = happyShift action_65+action_459 (39) = happyGoto action_485+action_459 (40) = happyGoto action_194+action_459 (105) = happyGoto action_196+action_459 (107) = happyGoto action_197+action_459 (108) = happyGoto action_80+action_459 (121) = happyGoto action_198+action_459 (124) = happyGoto action_199+action_459 _ = happyFail++action_460 (128) = happyShift action_34+action_460 (130) = happyShift action_36+action_460 (131) = happyShift action_200+action_460 (137) = happyShift action_201+action_460 (142) = happyShift action_202+action_460 (148) = happyShift action_203+action_460 (165) = happyShift action_49+action_460 (173) = happyShift action_55+action_460 (188) = happyShift action_65+action_460 (39) = happyGoto action_484+action_460 (40) = happyGoto action_194+action_460 (105) = happyGoto action_196+action_460 (107) = happyGoto action_197+action_460 (108) = happyGoto action_80+action_460 (121) = happyGoto action_198+action_460 (124) = happyGoto action_199+action_460 _ = happyFail++action_461 (128) = happyShift action_34+action_461 (130) = happyShift action_36+action_461 (142) = happyShift action_157+action_461 (165) = happyShift action_49+action_461 (173) = happyShift action_55+action_461 (188) = happyShift action_65+action_461 (21) = happyGoto action_483+action_461 (22) = happyGoto action_463+action_461 (94) = happyGoto action_464+action_461 (105) = happyGoto action_156+action_461 (108) = happyGoto action_465+action_461 (120) = happyGoto action_466+action_461 _ = happyFail++action_462 (150) = happyShift action_482+action_462 (10) = happyGoto action_481+action_462 _ = happyReduce_16++action_463 _ = happyReduce_41++action_464 _ = happyReduce_42++action_465 _ = happyReduce_284++action_466 (142) = happyShift action_480+action_466 _ = happyReduce_43++action_467 _ = happyReduce_147++action_468 _ = happyReduce_149++action_469 (128) = happyShift action_34+action_469 (129) = happyShift action_35+action_469 (130) = happyShift action_36+action_469 (131) = happyShift action_37+action_469 (132) = happyShift action_38+action_469 (137) = happyShift action_39+action_469 (138) = happyShift action_40+action_469 (139) = happyShift action_41+action_469 (140) = happyShift action_42+action_469 (141) = happyShift action_43+action_469 (142) = happyShift action_44+action_469 (148) = happyShift action_45+action_469 (151) = happyShift action_46+action_469 (157) = happyShift action_47+action_469 (162) = happyShift action_48+action_469 (165) = happyShift action_49+action_469 (166) = happyShift action_50+action_469 (171) = happyShift action_54+action_469 (173) = happyShift action_55+action_469 (174) = happyShift action_56+action_469 (181) = happyShift action_62+action_469 (188) = happyShift action_65+action_469 (191) = happyShift action_68+action_469 (192) = happyShift action_69+action_469 (193) = happyShift action_70+action_469 (194) = happyShift action_71+action_469 (64) = happyGoto action_479+action_469 (70) = happyGoto action_19+action_469 (71) = happyGoto action_20+action_469 (72) = happyGoto action_21+action_469 (74) = happyGoto action_22+action_469 (75) = happyGoto action_23+action_469 (93) = happyGoto action_24+action_469 (95) = happyGoto action_90+action_469 (97) = happyGoto action_26+action_469 (104) = happyGoto action_27+action_469 (105) = happyGoto action_28+action_469 (106) = happyGoto action_29+action_469 (108) = happyGoto action_30+action_469 (114) = happyGoto action_31+action_469 (126) = happyGoto action_33+action_469 _ = happyReduce_9++action_470 (146) = happyShift action_478+action_470 _ = happyFail++action_471 _ = happyReduce_287++action_472 _ = happyReduce_131++action_473 (130) = happyShift action_36+action_473 (131) = happyShift action_200+action_473 (143) = happyShift action_477+action_473 (57) = happyGoto action_475+action_473 (107) = happyGoto action_471+action_473 (108) = happyGoto action_80+action_473 (121) = happyGoto action_198+action_473 (123) = happyGoto action_476+action_473 _ = happyFail++action_474 _ = happyReduce_25++action_475 (143) = happyShift action_515+action_475 (150) = happyShift action_516+action_475 _ = happyFail++action_476 _ = happyReduce_135++action_477 _ = happyReduce_132++action_478 _ = happyReduce_146++action_479 _ = happyReduce_144++action_480 (128) = happyShift action_34+action_480 (130) = happyShift action_36+action_480 (142) = happyShift action_512+action_480 (143) = happyShift action_513+action_480 (154) = happyShift action_514+action_480 (165) = happyShift action_49+action_480 (173) = happyShift action_55+action_480 (188) = happyShift action_65+action_480 (23) = happyGoto action_507+action_480 (24) = happyGoto action_508+action_480 (94) = happyGoto action_509+action_480 (96) = happyGoto action_510+action_480 (105) = happyGoto action_156+action_480 (108) = happyGoto action_511+action_480 _ = happyFail++action_481 (143) = happyShift action_506+action_481 _ = happyFail++action_482 (128) = happyShift action_34+action_482 (130) = happyShift action_36+action_482 (142) = happyShift action_157+action_482 (165) = happyShift action_49+action_482 (173) = happyShift action_55+action_482 (188) = happyShift action_65+action_482 (22) = happyGoto action_505+action_482 (94) = happyGoto action_464+action_482 (105) = happyGoto action_156+action_482 (108) = happyGoto action_465+action_482 (120) = happyGoto action_466+action_482 _ = happyReduce_15++action_483 (150) = happyShift action_482+action_483 (10) = happyGoto action_504+action_483 _ = happyReduce_16++action_484 _ = happyReduce_119++action_485 _ = happyReduce_122++action_486 (128) = happyShift action_34+action_486 (130) = happyShift action_36+action_486 (131) = happyShift action_200+action_486 (137) = happyShift action_201+action_486 (142) = happyShift action_202+action_486 (148) = happyShift action_203+action_486 (165) = happyShift action_49+action_486 (173) = happyShift action_55+action_486 (188) = happyShift action_65+action_486 (39) = happyGoto action_284+action_486 (40) = happyGoto action_194+action_486 (105) = happyGoto action_196+action_486 (107) = happyGoto action_197+action_486 (108) = happyGoto action_80+action_486 (121) = happyGoto action_198+action_486 (124) = happyGoto action_199+action_486 _ = happyReduce_123++action_487 _ = happyReduce_115++action_488 (128) = happyShift action_34+action_488 (129) = happyShift action_35+action_488 (142) = happyShift action_241+action_488 (165) = happyShift action_49+action_488 (173) = happyShift action_55+action_488 (188) = happyShift action_65+action_488 (36) = happyGoto action_501+action_488 (53) = happyGoto action_502+action_488 (54) = happyGoto action_503+action_488 (95) = happyGoto action_424+action_488 (104) = happyGoto action_27+action_488 (105) = happyGoto action_28+action_488 _ = happyFail++action_489 _ = happyReduce_238++action_490 _ = happyReduce_136++action_491 _ = happyReduce_142++action_492 (144) = happyShift action_469+action_492 (7) = happyGoto action_500+action_492 _ = happyReduce_10++action_493 _ = happyReduce_212++action_494 (128) = happyShift action_34+action_494 (129) = happyShift action_35+action_494 (130) = happyShift action_36+action_494 (131) = happyShift action_37+action_494 (132) = happyShift action_38+action_494 (137) = happyShift action_39+action_494 (138) = happyShift action_40+action_494 (139) = happyShift action_41+action_494 (140) = happyShift action_42+action_494 (141) = happyShift action_43+action_494 (142) = happyShift action_44+action_494 (148) = happyShift action_45+action_494 (151) = happyShift action_46+action_494 (157) = happyShift action_47+action_494 (162) = happyShift action_48+action_494 (165) = happyShift action_49+action_494 (166) = happyShift action_50+action_494 (171) = happyShift action_54+action_494 (173) = happyShift action_55+action_494 (174) = happyShift action_56+action_494 (181) = happyShift action_62+action_494 (188) = happyShift action_65+action_494 (191) = happyShift action_68+action_494 (192) = happyShift action_69+action_494 (193) = happyShift action_70+action_494 (194) = happyShift action_71+action_494 (69) = happyGoto action_499+action_494 (70) = happyGoto action_89+action_494 (71) = happyGoto action_20+action_494 (72) = happyGoto action_21+action_494 (74) = happyGoto action_22+action_494 (75) = happyGoto action_23+action_494 (93) = happyGoto action_24+action_494 (95) = happyGoto action_90+action_494 (97) = happyGoto action_26+action_494 (104) = happyGoto action_27+action_494 (105) = happyGoto action_28+action_494 (106) = happyGoto action_29+action_494 (108) = happyGoto action_30+action_494 (114) = happyGoto action_31+action_494 (126) = happyGoto action_33+action_494 _ = happyFail++action_495 _ = happyReduce_214++action_496 (145) = happyShift action_85+action_496 (34) = happyGoto action_498+action_496 (118) = happyGoto action_84+action_496 _ = happyReduce_282++action_497 _ = happyReduce_206++action_498 _ = happyReduce_211++action_499 (160) = happyShift action_525+action_499 _ = happyFail++action_500 _ = happyReduce_139++action_501 (150) = happyShift action_139+action_501 (155) = happyShift action_524+action_501 _ = happyFail++action_502 (146) = happyShift action_522+action_502 (150) = happyShift action_523+action_502 _ = happyFail++action_503 _ = happyReduce_126++action_504 (143) = happyShift action_521+action_504 _ = happyFail++action_505 _ = happyReduce_40++action_506 _ = happyReduce_38++action_507 (143) = happyShift action_519+action_507 (150) = happyShift action_520+action_507 _ = happyFail++action_508 _ = happyReduce_48++action_509 _ = happyReduce_49++action_510 _ = happyReduce_50++action_511 _ = happyReduce_237++action_512 (132) = happyShift action_137+action_512 (133) = happyShift action_118+action_512 (134) = happyShift action_119+action_512 (153) = happyShift action_125+action_512 (164) = happyShift action_126+action_512 (110) = happyGoto action_453+action_512 (112) = happyGoto action_317+action_512 _ = happyFail++action_513 _ = happyReduce_45++action_514 (143) = happyShift action_518+action_514 _ = happyFail++action_515 _ = happyReduce_133++action_516 (130) = happyShift action_36+action_516 (131) = happyShift action_200+action_516 (107) = happyGoto action_471+action_516 (108) = happyGoto action_80+action_516 (121) = happyGoto action_198+action_516 (123) = happyGoto action_517+action_516 _ = happyFail++action_517 _ = happyReduce_134++action_518 _ = happyReduce_44++action_519 _ = happyReduce_46++action_520 (128) = happyShift action_34+action_520 (130) = happyShift action_36+action_520 (142) = happyShift action_512+action_520 (165) = happyShift action_49+action_520 (173) = happyShift action_55+action_520 (188) = happyShift action_65+action_520 (24) = happyGoto action_531+action_520 (94) = happyGoto action_509+action_520 (96) = happyGoto action_510+action_520 (105) = happyGoto action_156+action_520 (108) = happyGoto action_511+action_520 _ = happyFail++action_521 _ = happyReduce_39++action_522 _ = happyReduce_116++action_523 (128) = happyShift action_34+action_523 (129) = happyShift action_35+action_523 (142) = happyShift action_241+action_523 (165) = happyShift action_49+action_523 (173) = happyShift action_55+action_523 (188) = happyShift action_65+action_523 (36) = happyGoto action_501+action_523 (54) = happyGoto action_530+action_523 (95) = happyGoto action_424+action_523 (104) = happyGoto action_27+action_523 (105) = happyGoto action_28+action_523 _ = happyFail++action_524 (128) = happyShift action_34+action_524 (130) = happyShift action_36+action_524 (131) = happyShift action_200+action_524 (137) = happyShift action_201+action_524 (142) = happyShift action_202+action_524 (148) = happyShift action_203+action_524 (164) = happyShift action_529+action_524 (165) = happyShift action_49+action_524 (173) = happyShift action_55+action_524 (188) = happyShift action_65+action_524 (37) = happyGoto action_527+action_524 (38) = happyGoto action_192+action_524 (39) = happyGoto action_193+action_524 (40) = happyGoto action_194+action_524 (55) = happyGoto action_528+action_524 (105) = happyGoto action_196+action_524 (107) = happyGoto action_197+action_524 (108) = happyGoto action_80+action_524 (121) = happyGoto action_198+action_524 (124) = happyGoto action_199+action_524 _ = happyFail++action_525 (128) = happyShift action_34+action_525 (129) = happyShift action_35+action_525 (130) = happyShift action_36+action_525 (131) = happyShift action_37+action_525 (132) = happyShift action_38+action_525 (137) = happyShift action_39+action_525 (138) = happyShift action_40+action_525 (139) = happyShift action_41+action_525 (140) = happyShift action_42+action_525 (141) = happyShift action_43+action_525 (142) = happyShift action_44+action_525 (148) = happyShift action_45+action_525 (151) = happyShift action_46+action_525 (157) = happyShift action_47+action_525 (162) = happyShift action_48+action_525 (165) = happyShift action_49+action_525 (166) = happyShift action_50+action_525 (171) = happyShift action_54+action_525 (173) = happyShift action_55+action_525 (174) = happyShift action_56+action_525 (181) = happyShift action_62+action_525 (188) = happyShift action_65+action_525 (191) = happyShift action_68+action_525 (192) = happyShift action_69+action_525 (193) = happyShift action_70+action_525 (194) = happyShift action_71+action_525 (69) = happyGoto action_526+action_525 (70) = happyGoto action_89+action_525 (71) = happyGoto action_20+action_525 (72) = happyGoto action_21+action_525 (74) = happyGoto action_22+action_525 (75) = happyGoto action_23+action_525 (93) = happyGoto action_24+action_525 (95) = happyGoto action_90+action_525 (97) = happyGoto action_26+action_525 (104) = happyGoto action_27+action_525 (105) = happyGoto action_28+action_525 (106) = happyGoto action_29+action_525 (108) = happyGoto action_30+action_525 (114) = happyGoto action_31+action_525 (126) = happyGoto action_33+action_525 _ = happyFail++action_526 _ = happyReduce_216++action_527 _ = happyReduce_128++action_528 _ = happyReduce_127++action_529 (128) = happyShift action_34+action_529 (130) = happyShift action_36+action_529 (131) = happyShift action_200+action_529 (137) = happyShift action_201+action_529 (142) = happyShift action_202+action_529 (148) = happyShift action_203+action_529 (165) = happyShift action_49+action_529 (173) = happyShift action_55+action_529 (188) = happyShift action_65+action_529 (39) = happyGoto action_532+action_529 (40) = happyGoto action_194+action_529 (105) = happyGoto action_196+action_529 (107) = happyGoto action_197+action_529 (108) = happyGoto action_80+action_529 (121) = happyGoto action_198+action_529 (124) = happyGoto action_199+action_529 _ = happyFail++action_530 _ = happyReduce_125++action_531 _ = happyReduce_47++action_532 _ = happyReduce_129++happyReduce_1 = happyReduce 5 4 happyReduction_1+happyReduction_1 ((HappyAbsSyn5  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn8  happy_var_3) `HappyStk`+	(HappyAbsSyn119  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn4+		 (hsModule happy_var_2 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_2 = happySpecReduce_1 4 happyReduction_2+happyReduction_2 (HappyAbsSyn5  happy_var_1)+	 =  HappyAbsSyn4+		 (hsModule main_mod Nothing happy_var_1+	)+happyReduction_2 _  = notHappyAtAll ++happyReduce_3 = happyReduce 4 5 happyReduction_3+happyReduction_3 (_ `HappyStk`+	(HappyAbsSyn5  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn5+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_4 = happySpecReduce_3 5 happyReduction_4+happyReduction_4 _+	(HappyAbsSyn5  happy_var_2)+	_+	 =  HappyAbsSyn5+		 (happy_var_2+	)+happyReduction_4 _ _ _  = notHappyAtAll ++happyReduce_5 = happyReduce 4 6 happyReduction_5+happyReduction_5 (_ `HappyStk`+	(HappyAbsSyn25  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn15  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn5+		 ((happy_var_1, happy_var_3)+	) `HappyStk` happyRest++happyReduce_6 = happySpecReduce_2 6 happyReduction_6+happyReduction_6 _+	(HappyAbsSyn25  happy_var_1)+	 =  HappyAbsSyn5+		 (([], happy_var_1)+	)+happyReduction_6 _ _  = notHappyAtAll ++happyReduce_7 = happySpecReduce_2 6 happyReduction_7+happyReduction_7 _+	(HappyAbsSyn15  happy_var_1)+	 =  HappyAbsSyn5+		 ((happy_var_1, [])+	)+happyReduction_7 _ _  = notHappyAtAll ++happyReduce_8 = happySpecReduce_0 6 happyReduction_8+happyReduction_8  =  HappyAbsSyn5+		 (([], [])+	)++happyReduce_9 = happySpecReduce_1 7 happyReduction_9+happyReduction_9 _+	 =  HappyAbsSyn7+		 (()+	)++happyReduce_10 = happySpecReduce_0 7 happyReduction_10+happyReduction_10  =  HappyAbsSyn7+		 (()+	)++happyReduce_11 = happySpecReduce_1 8 happyReduction_11+happyReduction_11 (HappyAbsSyn9  happy_var_1)+	 =  HappyAbsSyn8+		 (Just happy_var_1+	)+happyReduction_11 _  = notHappyAtAll ++happyReduce_12 = happySpecReduce_0 8 happyReduction_12+happyReduction_12  =  HappyAbsSyn8+		 (Nothing+	)++happyReduce_13 = happyReduce 4 9 happyReduction_13+happyReduction_13 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn9  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn9+		 (reverse happy_var_2+	) `HappyStk` happyRest++happyReduce_14 = happySpecReduce_2 9 happyReduction_14+happyReduction_14 _+	_+	 =  HappyAbsSyn9+		 ([]+	)++happyReduce_15 = happySpecReduce_1 10 happyReduction_15+happyReduction_15 _+	 =  HappyAbsSyn7+		 (()+	)++happyReduce_16 = happySpecReduce_0 10 happyReduction_16+happyReduction_16  =  HappyAbsSyn7+		 (()+	)++happyReduce_17 = happySpecReduce_3 11 happyReduction_17+happyReduction_17 (HappyAbsSyn12  happy_var_3)+	_+	(HappyAbsSyn9  happy_var_1)+	 =  HappyAbsSyn9+		 (happy_var_3 : happy_var_1+	)+happyReduction_17 _ _ _  = notHappyAtAll ++happyReduce_18 = happySpecReduce_1 11 happyReduction_18+happyReduction_18 (HappyAbsSyn12  happy_var_1)+	 =  HappyAbsSyn9+		 ([happy_var_1]+	)+happyReduction_18 _  = notHappyAtAll ++happyReduce_19 = happySpecReduce_1 12 happyReduction_19+happyReduction_19 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn12+		 (HsEVar happy_var_1+	)+happyReduction_19 _  = notHappyAtAll ++happyReduce_20 = happySpecReduce_1 12 happyReduction_20+happyReduction_20 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn12+		 (HsEAbs happy_var_1+	)+happyReduction_20 _  = notHappyAtAll ++happyReduce_21 = happyReduce 4 12 happyReduction_21+happyReduction_21 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn12+		 (HsEThingAll happy_var_1+	) `HappyStk` happyRest++happyReduce_22 = happySpecReduce_3 12 happyReduction_22+happyReduction_22 _+	_+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn12+		 (HsEThingWith happy_var_1 []+	)+happyReduction_22 _ _ _  = notHappyAtAll ++happyReduce_23 = happyReduce 4 12 happyReduction_23+happyReduction_23 (_ `HappyStk`+	(HappyAbsSyn13  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn12+		 (HsEThingWith happy_var_1 (reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_24 = happySpecReduce_2 12 happyReduction_24+happyReduction_24 (HappyAbsSyn119  happy_var_2)+	_+	 =  HappyAbsSyn12+		 (HsEModuleContents happy_var_2+	)+happyReduction_24 _ _  = notHappyAtAll ++happyReduce_25 = happySpecReduce_3 13 happyReduction_25+happyReduction_25 (HappyAbsSyn14  happy_var_3)+	_+	(HappyAbsSyn13  happy_var_1)+	 =  HappyAbsSyn13+		 (happy_var_3 : happy_var_1+	)+happyReduction_25 _ _ _  = notHappyAtAll ++happyReduce_26 = happySpecReduce_1 13 happyReduction_26+happyReduction_26 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn13+		 ([happy_var_1]+	)+happyReduction_26 _  = notHappyAtAll ++happyReduce_27 = happySpecReduce_1 14 happyReduction_27+happyReduction_27 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_27 _  = notHappyAtAll ++happyReduce_28 = happySpecReduce_1 14 happyReduction_28+happyReduction_28 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_28 _  = notHappyAtAll ++happyReduce_29 = happySpecReduce_3 15 happyReduction_29+happyReduction_29 (HappyAbsSyn16  happy_var_3)+	_+	(HappyAbsSyn15  happy_var_1)+	 =  HappyAbsSyn15+		 (happy_var_3 : happy_var_1+	)+happyReduction_29 _ _ _  = notHappyAtAll ++happyReduce_30 = happySpecReduce_1 15 happyReduction_30+happyReduction_30 (HappyAbsSyn16  happy_var_1)+	 =  HappyAbsSyn15+		 ([happy_var_1]+	)+happyReduction_30 _  = notHappyAtAll ++happyReduce_31 = happyReduce 6 16 happyReduction_31+happyReduction_31 ((HappyAbsSyn19  happy_var_6) `HappyStk`+	(HappyAbsSyn18  happy_var_5) `HappyStk`+	(HappyAbsSyn119  happy_var_4) `HappyStk`+	(HappyAbsSyn17  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn16+		 (HsImportDecl happy_var_2 happy_var_4 happy_var_3 happy_var_5 happy_var_6+	) `HappyStk` happyRest++happyReduce_32 = happySpecReduce_1 17 happyReduction_32+happyReduction_32 _+	 =  HappyAbsSyn17+		 (True+	)++happyReduce_33 = happySpecReduce_0 17 happyReduction_33+happyReduction_33  =  HappyAbsSyn17+		 (False+	)++happyReduce_34 = happySpecReduce_2 18 happyReduction_34+happyReduction_34 (HappyAbsSyn119  happy_var_2)+	_+	 =  HappyAbsSyn18+		 (Just happy_var_2+	)+happyReduction_34 _ _  = notHappyAtAll ++happyReduce_35 = happySpecReduce_0 18 happyReduction_35+happyReduction_35  =  HappyAbsSyn18+		 (Nothing+	)++happyReduce_36 = happySpecReduce_1 19 happyReduction_36+happyReduction_36 (HappyAbsSyn20  happy_var_1)+	 =  HappyAbsSyn19+		 (Just happy_var_1+	)+happyReduction_36 _  = notHappyAtAll ++happyReduce_37 = happySpecReduce_0 19 happyReduction_37+happyReduction_37  =  HappyAbsSyn19+		 (Nothing+	)++happyReduce_38 = happyReduce 4 20 happyReduction_38+happyReduction_38 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn21  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn20+		 ((False, reverse happy_var_2)+	) `HappyStk` happyRest++happyReduce_39 = happyReduce 5 20 happyReduction_39+happyReduction_39 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn21  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn20+		 ((True,  reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_40 = happySpecReduce_3 21 happyReduction_40+happyReduction_40 (HappyAbsSyn22  happy_var_3)+	_+	(HappyAbsSyn21  happy_var_1)+	 =  HappyAbsSyn21+		 (happy_var_3 : happy_var_1+	)+happyReduction_40 _ _ _  = notHappyAtAll ++happyReduce_41 = happySpecReduce_1 21 happyReduction_41+happyReduction_41 (HappyAbsSyn22  happy_var_1)+	 =  HappyAbsSyn21+		 ([happy_var_1]+	)+happyReduction_41 _  = notHappyAtAll ++happyReduce_42 = happySpecReduce_1 22 happyReduction_42+happyReduction_42 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn22+		 (HsIVar happy_var_1+	)+happyReduction_42 _  = notHappyAtAll ++happyReduce_43 = happySpecReduce_1 22 happyReduction_43+happyReduction_43 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn22+		 (HsIAbs happy_var_1+	)+happyReduction_43 _  = notHappyAtAll ++happyReduce_44 = happyReduce 4 22 happyReduction_44+happyReduction_44 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn22+		 (HsIThingAll happy_var_1+	) `HappyStk` happyRest++happyReduce_45 = happySpecReduce_3 22 happyReduction_45+happyReduction_45 _+	_+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn22+		 (HsIThingWith happy_var_1 []+	)+happyReduction_45 _ _ _  = notHappyAtAll ++happyReduce_46 = happyReduce 4 22 happyReduction_46+happyReduction_46 (_ `HappyStk`+	(HappyAbsSyn13  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn22+		 (HsIThingWith happy_var_1 (reverse happy_var_3)+	) `HappyStk` happyRest++happyReduce_47 = happySpecReduce_3 23 happyReduction_47+happyReduction_47 (HappyAbsSyn14  happy_var_3)+	_+	(HappyAbsSyn13  happy_var_1)+	 =  HappyAbsSyn13+		 (happy_var_3 : happy_var_1+	)+happyReduction_47 _ _ _  = notHappyAtAll ++happyReduce_48 = happySpecReduce_1 23 happyReduction_48+happyReduction_48 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn13+		 ([happy_var_1]+	)+happyReduction_48 _  = notHappyAtAll ++happyReduce_49 = happySpecReduce_1 24 happyReduction_49+happyReduction_49 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_49 _  = notHappyAtAll ++happyReduce_50 = happySpecReduce_1 24 happyReduction_50+happyReduction_50 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_50 _  = notHappyAtAll ++happyReduce_51 = happySpecReduce_3 25 happyReduction_51+happyReduction_51 (HappyAbsSyn26  happy_var_3)+	_+	(HappyAbsSyn25  happy_var_1)+	 =  HappyAbsSyn25+		 (funCons happy_var_3 happy_var_1+	)+happyReduction_51 _ _ _  = notHappyAtAll ++happyReduce_52 = happySpecReduce_1 25 happyReduction_52+happyReduction_52 (HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn25+		 ([happy_var_1]+	)+happyReduction_52 _  = notHappyAtAll ++happyReduce_53 = happyReduce 4 26 happyReduction_53+happyReduction_53 ((HappyAbsSyn29  happy_var_4) `HappyStk`+	(HappyAbsSyn27  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	(HappyAbsSyn28  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (hsInfixDecl happy_var_2 (HsFixity happy_var_1 happy_var_3) happy_var_4+	) `HappyStk` happyRest++happyReduce_54 = happySpecReduce_0 27 happyReduction_54+happyReduction_54  =  HappyAbsSyn27+		 (9+	)++happyReduce_55 = happySpecReduce_1 27 happyReduction_55+happyReduction_55 (HappyTerminal (IntTok happy_var_1))+	 =  HappyAbsSyn27+		 (fromInteger (readInteger happy_var_1)+	)+happyReduction_55 _  = notHappyAtAll ++happyReduce_56 = happySpecReduce_1 28 happyReduction_56+happyReduction_56 _+	 =  HappyAbsSyn28+		 (HsAssocNone+	)++happyReduce_57 = happySpecReduce_1 28 happyReduction_57+happyReduction_57 _+	 =  HappyAbsSyn28+		 (HsAssocLeft+	)++happyReduce_58 = happySpecReduce_1 28 happyReduction_58+happyReduction_58 _+	 =  HappyAbsSyn28+		 (HsAssocRight+	)++happyReduce_59 = happySpecReduce_3 29 happyReduction_59+happyReduction_59 (HappyAbsSyn29  happy_var_3)+	_+	(HappyAbsSyn102  happy_var_1)+	 =  HappyAbsSyn29+		 (happy_var_1 : happy_var_3+	)+happyReduction_59 _ _ _  = notHappyAtAll ++happyReduce_60 = happySpecReduce_1 29 happyReduction_60+happyReduction_60 (HappyAbsSyn102  happy_var_1)+	 =  HappyAbsSyn29+		 ([happy_var_1]+	)+happyReduction_60 _  = notHappyAtAll ++happyReduce_61 = happyReduce 5 30 happyReduction_61+happyReduction_61 ((HappyAbsSyn37  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn115  happy_var_3) `HappyStk`+	(HappyAbsSyn42  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (hsTypeDecl happy_var_3 happy_var_2 happy_var_5+	) `HappyStk` happyRest++happyReduce_62 = happyReduce 6 30 happyReduction_62+happyReduction_62 ((HappyAbsSyn13  happy_var_6) `HappyStk`+	(HappyAbsSyn47  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn43  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (hsDataDecl happy_var_2 (fst happy_var_3) (snd happy_var_3) (reverse happy_var_5) happy_var_6+	) `HappyStk` happyRest++happyReduce_63 = happyReduce 6 30 happyReduction_63+happyReduction_63 ((HappyAbsSyn13  happy_var_6) `HappyStk`+	(HappyAbsSyn48  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn43  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (hsNewTypeDecl happy_var_2 (fst happy_var_3) (snd happy_var_3) happy_var_5 happy_var_6+	) `HappyStk` happyRest++happyReduce_64 = happyReduce 4 30 happyReduction_64+happyReduction_64 ((HappyAbsSyn25  happy_var_4) `HappyStk`+	(HappyAbsSyn41  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (hsClassDecl  happy_var_2 (fst happy_var_3) (snd happy_var_3) [] happy_var_4+	) `HappyStk` happyRest++happyReduce_65 = happyReduce 4 30 happyReduction_65+happyReduction_65 ((HappyAbsSyn25  happy_var_4) `HappyStk`+	(HappyAbsSyn41  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (hsInstDecl happy_var_2 (fst happy_var_3) (snd happy_var_3) happy_var_4+	) `HappyStk` happyRest++happyReduce_66 = happySpecReduce_3 30 happyReduction_66+happyReduction_66 (HappyAbsSyn37  happy_var_3)+	(HappyAbsSyn115  happy_var_2)+	_+	 =  HappyAbsSyn26+		 (hsDefaultDecl happy_var_2 happy_var_3+	)+happyReduction_66 _ _ _  = notHappyAtAll ++happyReduce_67 = happySpecReduce_3 30 happyReduction_67+happyReduction_67 (HappyAbsSyn46  happy_var_3)+	(HappyAbsSyn115  happy_var_2)+	_+	 =  HappyAbsSyn26+		 (hsPrimitiveTypeDecl happy_var_2 (fst happy_var_3) (snd happy_var_3)+	)+happyReduction_67 _ _ _  = notHappyAtAll ++happyReduce_68 = happyReduce 5 30 happyReduction_68+happyReduction_68 ((HappyAbsSyn37  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (hsPrimitiveBind happy_var_2 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_69 = happySpecReduce_1 30 happyReduction_69+happyReduction_69 (HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (happy_var_1+	)+happyReduction_69 _  = notHappyAtAll ++happyReduce_70 = happySpecReduce_2 31 happyReduction_70+happyReduction_70 _+	(HappyAbsSyn25  happy_var_1)+	 =  HappyAbsSyn25+		 (reverse happy_var_1+	)+happyReduction_70 _ _  = notHappyAtAll ++happyReduce_71 = happySpecReduce_1 31 happyReduction_71+happyReduction_71 _+	 =  HappyAbsSyn25+		 ([]+	)++happyReduce_72 = happySpecReduce_3 32 happyReduction_72+happyReduction_72 (HappyAbsSyn26  happy_var_3)+	_+	(HappyAbsSyn25  happy_var_1)+	 =  HappyAbsSyn25+		 (funCons happy_var_3 happy_var_1+	)+happyReduction_72 _ _ _  = notHappyAtAll ++happyReduce_73 = happySpecReduce_1 32 happyReduction_73+happyReduction_73 (HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn25+		 ([happy_var_1]+	)+happyReduction_73 _  = notHappyAtAll ++happyReduce_74 = happySpecReduce_1 33 happyReduction_74+happyReduction_74 (HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (happy_var_1+	)+happyReduction_74 _  = notHappyAtAll ++happyReduce_75 = happySpecReduce_1 33 happyReduction_75+happyReduction_75 (HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (happy_var_1+	)+happyReduction_75 _  = notHappyAtAll ++happyReduce_76 = happySpecReduce_1 33 happyReduction_76+happyReduction_76 (HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (happy_var_1+	)+happyReduction_76 _  = notHappyAtAll ++happyReduce_77 = happySpecReduce_1 33 happyReduction_77+happyReduction_77 (HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn26+		 (happy_var_1+	)+happyReduction_77 _  = notHappyAtAll ++happyReduce_78 = happyReduce 4 34 happyReduction_78+happyReduction_78 (_ `HappyStk`+	(HappyAbsSyn25  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn25+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_79 = happySpecReduce_3 34 happyReduction_79+happyReduction_79 _+	(HappyAbsSyn25  happy_var_2)+	_+	 =  HappyAbsSyn25+		 (happy_var_2+	)+happyReduction_79 _ _ _  = notHappyAtAll ++happyReduce_80 = happyReduce 4 35 happyReduction_80+happyReduction_80 ((HappyAbsSyn41  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	(HappyAbsSyn13  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (hsTypeSig happy_var_2 (reverse happy_var_1) (fst happy_var_4) (snd happy_var_4)+	) `HappyStk` happyRest++happyReduce_81 = happySpecReduce_3 36 happyReduction_81+happyReduction_81 (HappyAbsSyn14  happy_var_3)+	_+	(HappyAbsSyn13  happy_var_1)+	 =  HappyAbsSyn13+		 (happy_var_3 : happy_var_1+	)+happyReduction_81 _ _ _  = notHappyAtAll ++happyReduce_82 = happyMonadReduce 1 36 happyReduction_82+happyReduction_82 ((HappyAbsSyn14  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( case happy_var_1 of+				   Qual _ _ -> parseError "bad qvar in vars."+				   _        -> return [happy_var_1]+	) (\r -> happyReturn (HappyAbsSyn13 r))++happyReduce_83 = happySpecReduce_3 37 happyReduction_83+happyReduction_83 (HappyAbsSyn37  happy_var_3)+	_+	(HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn37+		 (hsTyFun happy_var_1 happy_var_3+	)+happyReduction_83 _ _ _  = notHappyAtAll ++happyReduce_84 = happySpecReduce_1 37 happyReduction_84+happyReduction_84 (HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn37+		 (happy_var_1+	)+happyReduction_84 _  = notHappyAtAll ++happyReduce_85 = happySpecReduce_2 38 happyReduction_85+happyReduction_85 (HappyAbsSyn37  happy_var_2)+	(HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn37+		 (hsTyApp happy_var_1 happy_var_2+	)+happyReduction_85 _ _  = notHappyAtAll ++happyReduce_86 = happySpecReduce_1 38 happyReduction_86+happyReduction_86 (HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn37+		 (happy_var_1+	)+happyReduction_86 _  = notHappyAtAll ++happyReduce_87 = happySpecReduce_1 39 happyReduction_87+happyReduction_87 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn37+		 (hsTyCon happy_var_1+	)+happyReduction_87 _  = notHappyAtAll ++happyReduce_88 = happySpecReduce_1 39 happyReduction_88+happyReduction_88 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn37+		 (hsTyVar happy_var_1+	)+happyReduction_88 _  = notHappyAtAll ++happyReduce_89 = happySpecReduce_3 39 happyReduction_89+happyReduction_89 _+	(HappyAbsSyn42  happy_var_2)+	_+	 =  HappyAbsSyn37+		 (hsTyTuple (reverse happy_var_2)+	)+happyReduction_89 _ _ _  = notHappyAtAll ++happyReduce_90 = happySpecReduce_3 39 happyReduction_90+happyReduction_90 _+	(HappyAbsSyn37  happy_var_2)+	_+	 =  HappyAbsSyn37+		 (hsTyApp list_tycon happy_var_2+	)+happyReduction_90 _ _ _  = notHappyAtAll ++happyReduce_91 = happySpecReduce_3 39 happyReduction_91+happyReduction_91 _+	(HappyAbsSyn37  happy_var_2)+	_+	 =  HappyAbsSyn37+		 (happy_var_2+	)+happyReduction_91 _ _ _  = notHappyAtAll ++happyReduce_92 = happySpecReduce_1 40 happyReduction_92+happyReduction_92 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_92 _  = notHappyAtAll ++happyReduce_93 = happySpecReduce_2 40 happyReduction_93+happyReduction_93 _+	_+	 =  HappyAbsSyn14+		 (unit_tycon_name+	)++happyReduce_94 = happySpecReduce_2 40 happyReduction_94+happyReduction_94 _+	_+	 =  HappyAbsSyn14+		 (list_tycon_name+	)++happyReduce_95 = happySpecReduce_3 40 happyReduction_95+happyReduction_95 _+	_+	_+	 =  HappyAbsSyn14+		 (fun_tycon_name+	)++happyReduce_96 = happySpecReduce_3 40 happyReduction_96+happyReduction_96 _+	(HappyAbsSyn27  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (tuple_tycon_name happy_var_2+	)+happyReduction_96 _ _ _  = notHappyAtAll ++happyReduce_97 = happyReduce 4 40 happyReduction_97+happyReduction_97 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal (QModId happy_var_1)) `HappyStk`+	happyRest)+	 = HappyAbsSyn14+		 (qualify happy_var_1 "()"+	) `HappyStk` happyRest++happyReduce_98 = happyReduce 4 40 happyReduction_98+happyReduction_98 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal (QModId happy_var_1)) `HappyStk`+	happyRest)+	 = HappyAbsSyn14+		 (qualify happy_var_1 "[]"+	) `HappyStk` happyRest++happyReduce_99 = happyReduce 5 40 happyReduction_99+happyReduction_99 (_ `HappyStk`+	(HappyAbsSyn27  happy_var_4) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal (QModId happy_var_1)) `HappyStk`+	happyRest)+	 = HappyAbsSyn14+		 (qualify happy_var_1 (tuple happy_var_4)+	) `HappyStk` happyRest++happyReduce_100 = happySpecReduce_3 41 happyReduction_100+happyReduction_100 (HappyAbsSyn37  happy_var_3)+	_+	(HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn41+		 ((reverse (tupleTypeToContext happy_var_1), happy_var_3)+	)+happyReduction_100 _ _ _  = notHappyAtAll ++happyReduce_101 = happySpecReduce_1 41 happyReduction_101+happyReduction_101 (HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn41+		 (([], happy_var_1)+	)+happyReduction_101 _  = notHappyAtAll ++happyReduce_102 = happySpecReduce_3 42 happyReduction_102+happyReduction_102 (HappyAbsSyn37  happy_var_3)+	_+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn42+		 (happy_var_3 : happy_var_1+	)+happyReduction_102 _ _ _  = notHappyAtAll ++happyReduce_103 = happySpecReduce_3 42 happyReduction_103+happyReduction_103 (HappyAbsSyn37  happy_var_3)+	_+	(HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn42+		 ([happy_var_3, happy_var_1]+	)+happyReduction_103 _ _ _  = notHappyAtAll ++happyReduce_104 = happySpecReduce_3 43 happyReduction_104+happyReduction_104 (HappyAbsSyn42  happy_var_3)+	_+	(HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn43+		 ((reverse (tupleTypeToContext happy_var_1), happy_var_3)+	)+happyReduction_104 _ _ _  = notHappyAtAll ++happyReduce_105 = happySpecReduce_1 43 happyReduction_105+happyReduction_105 (HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn43+		 (([], happy_var_1)+	)+happyReduction_105 _  = notHappyAtAll ++happyReduce_106 = happySpecReduce_2 44 happyReduction_106+happyReduction_106 (HappyAbsSyn42  happy_var_2)+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn42+		 (hsTyCon happy_var_1 : (reverse happy_var_2)+	)+happyReduction_106 _ _  = notHappyAtAll ++happyReduce_107 = happySpecReduce_1 44 happyReduction_107+happyReduction_107 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn42+		 ([hsTyCon happy_var_1]+	)+happyReduction_107 _  = notHappyAtAll ++happyReduce_108 = happySpecReduce_2 45 happyReduction_108+happyReduction_108 (HappyAbsSyn14  happy_var_2)+	(HappyAbsSyn42  happy_var_1)+	 =  HappyAbsSyn42+		 ((hsTyVar happy_var_2) : happy_var_1+	)+happyReduction_108 _ _  = notHappyAtAll ++happyReduce_109 = happySpecReduce_1 45 happyReduction_109+happyReduction_109 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn42+		 ([hsTyVar happy_var_1]+	)+happyReduction_109 _  = notHappyAtAll ++happyReduce_110 = happySpecReduce_3 46 happyReduction_110+happyReduction_110 (HappyAbsSyn14  happy_var_3)+	_+	(HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn46+		 ((reverse (tupleTypeToContext happy_var_1), happy_var_3)+	)+happyReduction_110 _ _ _  = notHappyAtAll ++happyReduce_111 = happySpecReduce_1 46 happyReduction_111+happyReduction_111 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn46+		 (([], happy_var_1)+	)+happyReduction_111 _  = notHappyAtAll ++happyReduce_112 = happySpecReduce_3 47 happyReduction_112+happyReduction_112 (HappyAbsSyn48  happy_var_3)+	_+	(HappyAbsSyn47  happy_var_1)+	 =  HappyAbsSyn47+		 (happy_var_3 : happy_var_1+	)+happyReduction_112 _ _ _  = notHappyAtAll ++happyReduce_113 = happySpecReduce_1 47 happyReduction_113+happyReduction_113 (HappyAbsSyn48  happy_var_1)+	 =  HappyAbsSyn47+		 ([happy_var_1]+	)+happyReduction_113 _  = notHappyAtAll ++happyReduce_114 = happySpecReduce_2 48 happyReduction_114+happyReduction_114 (HappyAbsSyn49  happy_var_2)+	(HappyAbsSyn115  happy_var_1)+	 =  HappyAbsSyn48+		 (HsConDecl happy_var_1 (fst happy_var_2) (snd happy_var_2)+	)+happyReduction_114 _ _  = notHappyAtAll ++happyReduce_115 = happyReduce 4 48 happyReduction_115+happyReduction_115 ((HappyAbsSyn51  happy_var_4) `HappyStk`+	(HappyAbsSyn14  happy_var_3) `HappyStk`+	(HappyAbsSyn51  happy_var_2) `HappyStk`+	(HappyAbsSyn115  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn48+		 (HsConDecl happy_var_1 happy_var_3 [happy_var_2, happy_var_4]+	) `HappyStk` happyRest++happyReduce_116 = happyReduce 6 48 happyReduction_116+happyReduction_116 (_ `HappyStk`+	(HappyAbsSyn53  happy_var_5) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn14  happy_var_2) `HappyStk`+	(HappyAbsSyn115  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn48+		 (HsRecDecl happy_var_1 happy_var_2 (reverse happy_var_5)+	) `HappyStk` happyRest++happyReduce_117 = happyMonadReduce 1 49 happyReduction_117+happyReduction_117 ((HappyAbsSyn37  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( do { (c, ts) <- splitTyConApp happy_var_1 ;+					    return (c, map HsUnBangedType ts)+					  }+	) (\r -> happyReturn (HappyAbsSyn49 r))++happyReduce_118 = happySpecReduce_1 49 happyReduction_118+happyReduction_118 (HappyAbsSyn49  happy_var_1)+	 =  HappyAbsSyn49+		 (happy_var_1+	)+happyReduction_118 _  = notHappyAtAll ++happyReduce_119 = happyMonadReduce 3 50 happyReduction_119+happyReduction_119 ((HappyAbsSyn37  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn37  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( do { (c, ts) <- splitTyConApp happy_var_1 ;+		      return (c, map HsUnBangedType ts ++ [HsBangedType happy_var_3])+		    }+	) (\r -> happyReturn (HappyAbsSyn49 r))++happyReduce_120 = happySpecReduce_2 50 happyReduction_120+happyReduction_120 (HappyAbsSyn51  happy_var_2)+	(HappyAbsSyn49  happy_var_1)+	 =  HappyAbsSyn49+		 ((fst happy_var_1, snd happy_var_1 ++ [happy_var_2] )+	)+happyReduction_120 _ _  = notHappyAtAll ++happyReduce_121 = happySpecReduce_1 51 happyReduction_121+happyReduction_121 (HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn51+		 (HsUnBangedType happy_var_1+	)+happyReduction_121 _  = notHappyAtAll ++happyReduce_122 = happySpecReduce_2 51 happyReduction_122+happyReduction_122 (HappyAbsSyn37  happy_var_2)+	_+	 =  HappyAbsSyn51+		 (HsBangedType   happy_var_2+	)+happyReduction_122 _ _  = notHappyAtAll ++happyReduce_123 = happySpecReduce_1 52 happyReduction_123+happyReduction_123 (HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn51+		 (HsUnBangedType happy_var_1+	)+happyReduction_123 _  = notHappyAtAll ++happyReduce_124 = happySpecReduce_2 52 happyReduction_124+happyReduction_124 (HappyAbsSyn37  happy_var_2)+	_+	 =  HappyAbsSyn51+		 (HsBangedType   happy_var_2+	)+happyReduction_124 _ _  = notHappyAtAll ++happyReduce_125 = happySpecReduce_3 53 happyReduction_125+happyReduction_125 (HappyAbsSyn54  happy_var_3)+	_+	(HappyAbsSyn53  happy_var_1)+	 =  HappyAbsSyn53+		 (happy_var_3 : happy_var_1+	)+happyReduction_125 _ _ _  = notHappyAtAll ++happyReduce_126 = happySpecReduce_1 53 happyReduction_126+happyReduction_126 (HappyAbsSyn54  happy_var_1)+	 =  HappyAbsSyn53+		 ([happy_var_1]+	)+happyReduction_126 _  = notHappyAtAll ++happyReduce_127 = happySpecReduce_3 54 happyReduction_127+happyReduction_127 (HappyAbsSyn51  happy_var_3)+	_+	(HappyAbsSyn13  happy_var_1)+	 =  HappyAbsSyn54+		 ((reverse happy_var_1, happy_var_3)+	)+happyReduction_127 _ _ _  = notHappyAtAll ++happyReduce_128 = happySpecReduce_1 55 happyReduction_128+happyReduction_128 (HappyAbsSyn37  happy_var_1)+	 =  HappyAbsSyn51+		 (HsUnBangedType happy_var_1+	)+happyReduction_128 _  = notHappyAtAll ++happyReduce_129 = happySpecReduce_2 55 happyReduction_129+happyReduction_129 (HappyAbsSyn37  happy_var_2)+	_+	 =  HappyAbsSyn51+		 (HsBangedType   happy_var_2+	)+happyReduction_129 _ _  = notHappyAtAll ++happyReduce_130 = happySpecReduce_0 56 happyReduction_130+happyReduction_130  =  HappyAbsSyn13+		 ([]+	)++happyReduce_131 = happySpecReduce_2 56 happyReduction_131+happyReduction_131 (HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn13+		 ([happy_var_2]+	)+happyReduction_131 _ _  = notHappyAtAll ++happyReduce_132 = happySpecReduce_3 56 happyReduction_132+happyReduction_132 _+	_+	_+	 =  HappyAbsSyn13+		 ([]+	)++happyReduce_133 = happyReduce 4 56 happyReduction_133+happyReduction_133 (_ `HappyStk`+	(HappyAbsSyn13  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn13+		 (reverse happy_var_3+	) `HappyStk` happyRest++happyReduce_134 = happySpecReduce_3 57 happyReduction_134+happyReduction_134 (HappyAbsSyn14  happy_var_3)+	_+	(HappyAbsSyn13  happy_var_1)+	 =  HappyAbsSyn13+		 (happy_var_3 : happy_var_1+	)+happyReduction_134 _ _ _  = notHappyAtAll ++happyReduce_135 = happySpecReduce_1 57 happyReduction_135+happyReduction_135 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn13+		 ([happy_var_1]+	)+happyReduction_135 _  = notHappyAtAll ++happyReduce_136 = happyReduce 5 58 happyReduction_136+happyReduction_136 (_ `HappyStk`+	(HappyAbsSyn25  happy_var_4) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn25+		 (happy_var_4+	) `HappyStk` happyRest++happyReduce_137 = happyReduce 4 58 happyReduction_137+happyReduction_137 (_ `HappyStk`+	(HappyAbsSyn25  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn25+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_138 = happySpecReduce_0 58 happyReduction_138+happyReduction_138  =  HappyAbsSyn25+		 ([]+	)++happyReduce_139 = happyReduce 4 59 happyReduction_139+happyReduction_139 (_ `HappyStk`+	(HappyAbsSyn25  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn25  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn25+		 (reverse happy_var_1 ++ reverse happy_var_3+	) `HappyStk` happyRest++happyReduce_140 = happySpecReduce_2 59 happyReduction_140+happyReduction_140 _+	(HappyAbsSyn25  happy_var_1)+	 =  HappyAbsSyn25+		 (reverse happy_var_1+	)+happyReduction_140 _ _  = notHappyAtAll ++happyReduce_141 = happySpecReduce_1 59 happyReduction_141+happyReduction_141 _+	 =  HappyAbsSyn25+		 ([]+	)++happyReduce_142 = happySpecReduce_3 60 happyReduction_142+happyReduction_142 (HappyAbsSyn26  happy_var_3)+	_+	(HappyAbsSyn25  happy_var_1)+	 =  HappyAbsSyn25+		 (funCons happy_var_3  happy_var_1+	)+happyReduction_142 _ _ _  = notHappyAtAll ++happyReduce_143 = happySpecReduce_1 60 happyReduction_143+happyReduction_143 (HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn25+		 ([happy_var_1]+	)+happyReduction_143 _  = notHappyAtAll ++happyReduce_144 = happySpecReduce_3 61 happyReduction_144+happyReduction_144 (HappyAbsSyn26  happy_var_3)+	_+	(HappyAbsSyn25  happy_var_1)+	 =  HappyAbsSyn25+		 (funCons happy_var_3  happy_var_1+	)+happyReduction_144 _ _ _  = notHappyAtAll ++happyReduce_145 = happySpecReduce_1 61 happyReduction_145+happyReduction_145 (HappyAbsSyn26  happy_var_1)+	 =  HappyAbsSyn25+		 ([happy_var_1]+	)+happyReduction_145 _  = notHappyAtAll ++happyReduce_146 = happyReduce 5 62 happyReduction_146+happyReduction_146 (_ `HappyStk`+	(HappyAbsSyn25  happy_var_4) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn25+		 (happy_var_4+	) `HappyStk` happyRest++happyReduce_147 = happyReduce 4 62 happyReduction_147+happyReduction_147 (_ `HappyStk`+	(HappyAbsSyn25  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn25+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_148 = happySpecReduce_0 62 happyReduction_148+happyReduction_148  =  HappyAbsSyn25+		 ([]+	)++happyReduce_149 = happySpecReduce_2 63 happyReduction_149+happyReduction_149 _+	(HappyAbsSyn25  happy_var_1)+	 =  HappyAbsSyn25+		 (reverse happy_var_1+	)+happyReduction_149 _ _  = notHappyAtAll ++happyReduce_150 = happySpecReduce_1 63 happyReduction_150+happyReduction_150 _+	 =  HappyAbsSyn25+		 ([]+	)++happyReduce_151 = happyMonadReduce 4 64 happyReduction_151+happyReduction_151 ((HappyAbsSyn25  happy_var_4) `HappyStk`+	(HappyAbsSyn66  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	(HappyAbsSyn69  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( if isPatternExp happy_var_1 +                                       then mkValDef happy_var_1 happy_var_2 happy_var_3 happy_var_4+                                       else mkFunDef happy_var_1 happy_var_2 happy_var_3 happy_var_4+	) (\r -> happyReturn (HappyAbsSyn26 r))++happyReduce_152 = happySpecReduce_2 65 happyReduction_152+happyReduction_152 (HappyAbsSyn25  happy_var_2)+	_+	 =  HappyAbsSyn25+		 (happy_var_2+	)+happyReduction_152 _ _  = notHappyAtAll ++happyReduce_153 = happySpecReduce_0 65 happyReduction_153+happyReduction_153  =  HappyAbsSyn25+		 ([]+	)++happyReduce_154 = happySpecReduce_2 66 happyReduction_154+happyReduction_154 (HappyAbsSyn69  happy_var_2)+	_+	 =  HappyAbsSyn66+		 (HsBody happy_var_2+	)+happyReduction_154 _ _  = notHappyAtAll ++happyReduce_155 = happySpecReduce_1 66 happyReduction_155+happyReduction_155 (HappyAbsSyn67  happy_var_1)+	 =  HappyAbsSyn66+		 (HsGuard (reverse happy_var_1)+	)+happyReduction_155 _  = notHappyAtAll ++happyReduce_156 = happySpecReduce_2 67 happyReduction_156+happyReduction_156 (HappyAbsSyn68  happy_var_2)+	(HappyAbsSyn67  happy_var_1)+	 =  HappyAbsSyn67+		 (happy_var_2 : happy_var_1+	)+happyReduction_156 _ _  = notHappyAtAll ++happyReduce_157 = happySpecReduce_1 67 happyReduction_157+happyReduction_157 (HappyAbsSyn68  happy_var_1)+	 =  HappyAbsSyn67+		 ([happy_var_1]+	)+happyReduction_157 _  = notHappyAtAll ++happyReduce_158 = happyReduce 5 68 happyReduction_158+happyReduction_158 ((HappyAbsSyn69  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn115  happy_var_3) `HappyStk`+	(HappyAbsSyn69  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn68+		 ((happy_var_3, happy_var_2, happy_var_5)+	) `HappyStk` happyRest++happyReduce_159 = happyReduce 4 69 happyReduction_159+happyReduction_159 ((HappyAbsSyn41  happy_var_4) `HappyStk`+	(HappyAbsSyn115  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn69  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsExpTypeSig happy_var_3 happy_var_1 (fst happy_var_4) (snd happy_var_4)+	) `HappyStk` happyRest++happyReduce_160 = happySpecReduce_1 69 happyReduction_160+happyReduction_160 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (happy_var_1+	)+happyReduction_160 _  = notHappyAtAll ++happyReduce_161 = happySpecReduce_1 70 happyReduction_161+happyReduction_161 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (happy_var_1+	)+happyReduction_161 _  = notHappyAtAll ++happyReduce_162 = happySpecReduce_3 70 happyReduction_162+happyReduction_162 (HappyAbsSyn69  happy_var_3)+	(HappyAbsSyn102  happy_var_2)+	(HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (hsInfixApp happy_var_1 happy_var_2 happy_var_3+	)+happyReduction_162 _ _ _  = notHappyAtAll ++happyReduce_163 = happyMonadReduce 4 71 happyReduction_163+happyReduction_163 ((HappyAbsSyn69  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn73  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = happyThen ( do { ps <- mapM expToPat happy_var_2 ;+                      return (hsLambda (reverse ps) happy_var_4)+		    }+	) (\r -> happyReturn (HappyAbsSyn69 r))++happyReduce_164 = happyMonadReduce 4 71 happyReduction_164+happyReduction_164 ((HappyAbsSyn69  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn73  happy_var_2) `HappyStk`+	(HappyAbsSyn126  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( do { ps <- mapM expToPat happy_var_2 ;+                      return (mkQuant happy_var_1 (reverse ps) happy_var_4)+		    }+	) (\r -> happyReturn (HappyAbsSyn69 r))++happyReduce_165 = happyReduce 4 71 happyReduction_165+happyReduction_165 ((HappyAbsSyn69  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn25  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsLet happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_166 = happyReduce 6 71 happyReduction_166+happyReduction_166 ((HappyAbsSyn69  happy_var_6) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn69  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn69  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsIf happy_var_2 happy_var_4 happy_var_6+	) `HappyStk` happyRest++happyReduce_167 = happyReduce 4 71 happyReduction_167+happyReduction_167 ((HappyAbsSyn82  happy_var_4) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn69  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsCase happy_var_2 happy_var_4+	) `HappyStk` happyRest++happyReduce_168 = happySpecReduce_2 71 happyReduction_168+happyReduction_168 (HappyAbsSyn69  happy_var_2)+	_+	 =  HappyAbsSyn69+		 (hsNegApp happy_var_2+	)+happyReduction_168 _ _  = notHappyAtAll ++happyReduce_169 = happySpecReduce_2 71 happyReduction_169+happyReduction_169 (HappyAbsSyn88  happy_var_2)+	_+	 =  HappyAbsSyn69+		 (hsDo (atoms2Stmt happy_var_2)+	)+happyReduction_169 _ _  = notHappyAtAll ++happyReduce_170 = happySpecReduce_1 71 happyReduction_170+happyReduction_170 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (happy_var_1+	)+happyReduction_170 _  = notHappyAtAll ++happyReduce_171 = happySpecReduce_2 72 happyReduction_171+happyReduction_171 (HappyAbsSyn69  happy_var_2)+	(HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (hsApp happy_var_1 happy_var_2+	)+happyReduction_171 _ _  = notHappyAtAll ++happyReduce_172 = happySpecReduce_1 72 happyReduction_172+happyReduction_172 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (happy_var_1+	)+happyReduction_172 _  = notHappyAtAll ++happyReduce_173 = happySpecReduce_2 73 happyReduction_173+happyReduction_173 (HappyAbsSyn69  happy_var_2)+	(HappyAbsSyn73  happy_var_1)+	 =  HappyAbsSyn73+		 (happy_var_2 : happy_var_1+	)+happyReduction_173 _ _  = notHappyAtAll ++happyReduce_174 = happySpecReduce_1 73 happyReduction_174+happyReduction_174 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn73+		 ([happy_var_1]+	)+happyReduction_174 _  = notHappyAtAll ++happyReduce_175 = happyReduce 5 74 happyReduction_175+happyReduction_175 (_ `HappyStk`+	(HappyAbsSyn91  happy_var_4) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn69  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (mkRecord happy_var_1 (reverse happy_var_4)+	) `HappyStk` happyRest++happyReduce_176 = happySpecReduce_1 74 happyReduction_176+happyReduction_176 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (happy_var_1+	)+happyReduction_176 _  = notHappyAtAll ++happyReduce_177 = happySpecReduce_1 75 happyReduction_177+happyReduction_177 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn69+		 (hsEVar (happy_var_1 :: HsName)+	)+happyReduction_177 _  = notHappyAtAll ++happyReduce_178 = happySpecReduce_1 75 happyReduction_178+happyReduction_178 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (happy_var_1+	)+happyReduction_178 _  = notHappyAtAll ++happyReduce_179 = happySpecReduce_1 75 happyReduction_179+happyReduction_179 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (happy_var_1+	)+happyReduction_179 _  = notHappyAtAll ++happyReduce_180 = happySpecReduce_3 75 happyReduction_180+happyReduction_180 _+	(HappyAbsSyn69  happy_var_2)+	_+	 =  HappyAbsSyn69+		 (hsParen happy_var_2+	)+happyReduction_180 _ _ _  = notHappyAtAll ++happyReduce_181 = happySpecReduce_3 75 happyReduction_181+happyReduction_181 _+	(HappyAbsSyn73  happy_var_2)+	_+	 =  HappyAbsSyn69+		 (hsTuple (reverse happy_var_2)+	)+happyReduction_181 _ _ _  = notHappyAtAll ++happyReduce_182 = happySpecReduce_3 75 happyReduction_182+happyReduction_182 _+	(HappyAbsSyn69  happy_var_2)+	_+	 =  HappyAbsSyn69+		 (happy_var_2+	)+happyReduction_182 _ _ _  = notHappyAtAll ++happyReduce_183 = happyReduce 4 75 happyReduction_183+happyReduction_183 (_ `HappyStk`+	(HappyAbsSyn102  happy_var_3) `HappyStk`+	(HappyAbsSyn69  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsLeftSection happy_var_2 happy_var_3+	) `HappyStk` happyRest++happyReduce_184 = happyReduce 4 75 happyReduction_184+happyReduction_184 (_ `HappyStk`+	(HappyAbsSyn69  happy_var_3) `HappyStk`+	(HappyAbsSyn102  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsRightSection happy_var_2 happy_var_3+	) `HappyStk` happyRest++happyReduce_185 = happySpecReduce_3 75 happyReduction_185+happyReduction_185 (HappyAbsSyn69  happy_var_3)+	_+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn69+		 (hsAsPat happy_var_1 happy_var_3+	)+happyReduction_185 _ _ _  = notHappyAtAll ++happyReduce_186 = happySpecReduce_1 75 happyReduction_186+happyReduction_186 _+	 =  HappyAbsSyn69+		 (hsWildCard+	)++happyReduce_187 = happySpecReduce_2 75 happyReduction_187+happyReduction_187 (HappyAbsSyn69  happy_var_2)+	_+	 =  HappyAbsSyn69+		 (hsIrrPat happy_var_2+	)+happyReduction_187 _ _  = notHappyAtAll ++happyReduce_188 = happySpecReduce_2 76 happyReduction_188+happyReduction_188 _+	(HappyAbsSyn27  happy_var_1)+	 =  HappyAbsSyn27+		 (happy_var_1 + 1+	)+happyReduction_188 _ _  = notHappyAtAll ++happyReduce_189 = happySpecReduce_1 76 happyReduction_189+happyReduction_189 _+	 =  HappyAbsSyn27+		 (1+	)++happyReduce_190 = happySpecReduce_3 77 happyReduction_190+happyReduction_190 (HappyAbsSyn69  happy_var_3)+	_+	(HappyAbsSyn73  happy_var_1)+	 =  HappyAbsSyn73+		 (happy_var_3 : happy_var_1+	)+happyReduction_190 _ _ _  = notHappyAtAll ++happyReduce_191 = happySpecReduce_3 77 happyReduction_191+happyReduction_191 (HappyAbsSyn69  happy_var_3)+	_+	(HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn73+		 ([happy_var_3, happy_var_1]+	)+happyReduction_191 _ _ _  = notHappyAtAll ++happyReduce_192 = happySpecReduce_1 78 happyReduction_192+happyReduction_192 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (hsList [happy_var_1]+	)+happyReduction_192 _  = notHappyAtAll ++happyReduce_193 = happySpecReduce_1 78 happyReduction_193+happyReduction_193 (HappyAbsSyn73  happy_var_1)+	 =  HappyAbsSyn69+		 (hsList (reverse happy_var_1)+	)+happyReduction_193 _  = notHappyAtAll ++happyReduce_194 = happySpecReduce_2 78 happyReduction_194+happyReduction_194 _+	(HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (hsEnumFrom happy_var_1+	)+happyReduction_194 _ _  = notHappyAtAll ++happyReduce_195 = happyReduce 4 78 happyReduction_195+happyReduction_195 (_ `HappyStk`+	(HappyAbsSyn69  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn69  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsEnumFromThen happy_var_1 happy_var_3+	) `HappyStk` happyRest++happyReduce_196 = happySpecReduce_3 78 happyReduction_196+happyReduction_196 (HappyAbsSyn69  happy_var_3)+	_+	(HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (hsEnumFromTo happy_var_1 happy_var_3+	)+happyReduction_196 _ _ _  = notHappyAtAll ++happyReduce_197 = happyReduce 5 78 happyReduction_197+happyReduction_197 ((HappyAbsSyn69  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn69  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn69  happy_var_1) `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsEnumFromThenTo happy_var_1 happy_var_3 happy_var_5+	) `HappyStk` happyRest++happyReduce_198 = happySpecReduce_3 78 happyReduction_198+happyReduction_198 (HappyAbsSyn80  happy_var_3)+	_+	(HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn69+		 (hsListComp (atoms2Stmt (reverse happy_var_3 ++ [HsQualifierAtom happy_var_1]))+	)+happyReduction_198 _ _ _  = notHappyAtAll ++happyReduce_199 = happySpecReduce_3 79 happyReduction_199+happyReduction_199 (HappyAbsSyn69  happy_var_3)+	_+	(HappyAbsSyn73  happy_var_1)+	 =  HappyAbsSyn73+		 (happy_var_3 : happy_var_1+	)+happyReduction_199 _ _ _  = notHappyAtAll ++happyReduce_200 = happySpecReduce_3 79 happyReduction_200+happyReduction_200 (HappyAbsSyn69  happy_var_3)+	_+	(HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn73+		 ([happy_var_3,happy_var_1]+	)+happyReduction_200 _ _ _  = notHappyAtAll ++happyReduce_201 = happySpecReduce_3 80 happyReduction_201+happyReduction_201 (HappyAbsSyn81  happy_var_3)+	_+	(HappyAbsSyn80  happy_var_1)+	 =  HappyAbsSyn80+		 (happy_var_3 : happy_var_1+	)+happyReduction_201 _ _ _  = notHappyAtAll ++happyReduce_202 = happySpecReduce_1 80 happyReduction_202+happyReduction_202 (HappyAbsSyn81  happy_var_1)+	 =  HappyAbsSyn80+		 ([happy_var_1]+	)+happyReduction_202 _  = notHappyAtAll ++happyReduce_203 = happyMonadReduce 3 81 happyReduction_203+happyReduction_203 ((HappyAbsSyn69  happy_var_3) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn69  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( do { p <- expToPat happy_var_1 ; +                                                return (HsGeneratorAtom p happy_var_3)+					      }+	) (\r -> happyReturn (HappyAbsSyn81 r))++happyReduce_204 = happySpecReduce_1 81 happyReduction_204+happyReduction_204 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn81+		 (HsQualifierAtom happy_var_1+	)+happyReduction_204 _  = notHappyAtAll ++happyReduce_205 = happySpecReduce_2 81 happyReduction_205+happyReduction_205 (HappyAbsSyn25  happy_var_2)+	_+	 =  HappyAbsSyn81+		 (HsLetStmtAtom   happy_var_2+	)+happyReduction_205 _ _  = notHappyAtAll ++happyReduce_206 = happyReduce 5 82 happyReduction_206+happyReduction_206 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn82  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn82+		 (reverse happy_var_3+	) `HappyStk` happyRest++happyReduce_207 = happyReduce 4 82 happyReduction_207+happyReduction_207 (_ `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn82  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn82+		 (reverse happy_var_2+	) `HappyStk` happyRest++happyReduce_208 = happySpecReduce_3 83 happyReduction_208+happyReduction_208 (HappyAbsSyn84  happy_var_3)+	_+	(HappyAbsSyn82  happy_var_1)+	 =  HappyAbsSyn82+		 (happy_var_3 : happy_var_1+	)+happyReduction_208 _ _ _  = notHappyAtAll ++happyReduce_209 = happySpecReduce_1 83 happyReduction_209+happyReduction_209 (HappyAbsSyn84  happy_var_1)+	 =  HappyAbsSyn82+		 ([happy_var_1]+	)+happyReduction_209 _  = notHappyAtAll ++happyReduce_210 = happyMonadReduce 3 84 happyReduction_210+happyReduction_210 ((HappyAbsSyn66  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	(HappyAbsSyn69  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( do { p <- expToPat happy_var_1 ;+	              return (HsAlt happy_var_2 p happy_var_3 [])+		    }+	) (\r -> happyReturn (HappyAbsSyn84 r))++happyReduce_211 = happyMonadReduce 5 84 happyReduction_211+happyReduction_211 ((HappyAbsSyn25  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn66  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	(HappyAbsSyn69  happy_var_1) `HappyStk`+	happyRest)+	 = happyThen ( do { p <- expToPat happy_var_1 ;+		      return (HsAlt happy_var_2 p happy_var_3 happy_var_5)+		    }+	) (\r -> happyReturn (HappyAbsSyn84 r))++happyReduce_212 = happySpecReduce_2 85 happyReduction_212+happyReduction_212 (HappyAbsSyn69  happy_var_2)+	_+	 =  HappyAbsSyn66+		 (HsBody happy_var_2+	)+happyReduction_212 _ _  = notHappyAtAll ++happyReduce_213 = happySpecReduce_1 85 happyReduction_213+happyReduction_213 (HappyAbsSyn67  happy_var_1)+	 =  HappyAbsSyn66+		 (HsGuard (reverse happy_var_1)+	)+happyReduction_213 _  = notHappyAtAll ++happyReduce_214 = happySpecReduce_2 86 happyReduction_214+happyReduction_214 (HappyAbsSyn68  happy_var_2)+	(HappyAbsSyn67  happy_var_1)+	 =  HappyAbsSyn67+		 (happy_var_2 : happy_var_1+	)+happyReduction_214 _ _  = notHappyAtAll ++happyReduce_215 = happySpecReduce_1 86 happyReduction_215+happyReduction_215 (HappyAbsSyn68  happy_var_1)+	 =  HappyAbsSyn67+		 ([happy_var_1]+	)+happyReduction_215 _  = notHappyAtAll ++happyReduce_216 = happyReduce 5 87 happyReduction_216+happyReduction_216 ((HappyAbsSyn69  happy_var_5) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn69  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn68+		 ((happy_var_2, happy_var_3, happy_var_5)+	) `HappyStk` happyRest++happyReduce_217 = happyReduce 4 88 happyReduction_217+happyReduction_217 (_ `HappyStk`+	(HappyAbsSyn88  happy_var_3) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn88+		 (happy_var_3+	) `HappyStk` happyRest++happyReduce_218 = happySpecReduce_3 88 happyReduction_218+happyReduction_218 _+	(HappyAbsSyn88  happy_var_2)+	_+	 =  HappyAbsSyn88+		 (happy_var_2+	)+happyReduction_218 _ _ _  = notHappyAtAll ++happyReduce_219 = happySpecReduce_3 89 happyReduction_219+happyReduction_219 (HappyAbsSyn69  happy_var_3)+	_+	(HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (reverse (HsQualifierAtom happy_var_3 : happy_var_1)+	)+happyReduction_219 _ _ _  = notHappyAtAll ++happyReduce_220 = happySpecReduce_1 89 happyReduction_220+happyReduction_220 (HappyAbsSyn69  happy_var_1)+	 =  HappyAbsSyn88+		 ([HsQualifierAtom happy_var_1]+	)+happyReduction_220 _  = notHappyAtAll ++happyReduce_221 = happySpecReduce_3 90 happyReduction_221+happyReduction_221 (HappyAbsSyn81  happy_var_3)+	_+	(HappyAbsSyn88  happy_var_1)+	 =  HappyAbsSyn88+		 (happy_var_3 : happy_var_1+	)+happyReduction_221 _ _ _  = notHappyAtAll ++happyReduce_222 = happySpecReduce_1 90 happyReduction_222+happyReduction_222 (HappyAbsSyn81  happy_var_1)+	 =  HappyAbsSyn88+		 ([happy_var_1]+	)+happyReduction_222 _  = notHappyAtAll ++happyReduce_223 = happySpecReduce_3 91 happyReduction_223+happyReduction_223 (HappyAbsSyn92  happy_var_3)+	_+	(HappyAbsSyn91  happy_var_1)+	 =  HappyAbsSyn91+		 (happy_var_3 : happy_var_1+	)+happyReduction_223 _ _ _  = notHappyAtAll ++happyReduce_224 = happySpecReduce_1 91 happyReduction_224+happyReduction_224 (HappyAbsSyn92  happy_var_1)+	 =  HappyAbsSyn91+		 ([happy_var_1]+	)+happyReduction_224 _  = notHappyAtAll ++happyReduce_225 = happySpecReduce_3 92 happyReduction_225+happyReduction_225 (HappyAbsSyn69  happy_var_3)+	_+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn92+		 (HsFieldUpdate happy_var_1 (happy_var_3)+	)+happyReduction_225 _ _ _  = notHappyAtAll ++happyReduce_226 = happySpecReduce_2 93 happyReduction_226+happyReduction_226 _+	_+	 =  HappyAbsSyn69+		 (hsECon (qualify "Prelude" "()")+	)++happyReduce_227 = happySpecReduce_2 93 happyReduction_227+happyReduction_227 _+	_+	 =  HappyAbsSyn69+		 (hsList []+	)++happyReduce_228 = happySpecReduce_3 93 happyReduction_228+happyReduction_228 _+	(HappyAbsSyn27  happy_var_2)+	_+	 =  HappyAbsSyn69+		 (hsECon (qualify "Prelude" (tuple happy_var_2))+	)+happyReduction_228 _ _ _  = notHappyAtAll ++happyReduce_229 = happyReduce 4 93 happyReduction_229+happyReduction_229 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal (QModId happy_var_1)) `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsECon (qualify happy_var_1 "()")+	) `HappyStk` happyRest++happyReduce_230 = happyReduce 4 93 happyReduction_230+happyReduction_230 (_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsList []+	) `HappyStk` happyRest++happyReduce_231 = happyReduce 5 93 happyReduction_231+happyReduction_231 (_ `HappyStk`+	(HappyAbsSyn27  happy_var_4) `HappyStk`+	_ `HappyStk`+	_ `HappyStk`+	(HappyTerminal (QModId happy_var_1)) `HappyStk`+	happyRest)+	 = HappyAbsSyn69+		 (hsECon (qualify happy_var_1 (tuple happy_var_4))+	) `HappyStk` happyRest++happyReduce_232 = happySpecReduce_1 93 happyReduction_232+happyReduction_232 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn69+		 (hsECon happy_var_1+	)+happyReduction_232 _  = notHappyAtAll ++happyReduce_233 = happySpecReduce_1 94 happyReduction_233+happyReduction_233 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_233 _  = notHappyAtAll ++happyReduce_234 = happySpecReduce_3 94 happyReduction_234+happyReduction_234 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_234 _ _ _  = notHappyAtAll ++happyReduce_235 = happySpecReduce_1 95 happyReduction_235+happyReduction_235 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_235 _  = notHappyAtAll ++happyReduce_236 = happySpecReduce_3 95 happyReduction_236+happyReduction_236 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_236 _ _ _  = notHappyAtAll ++happyReduce_237 = happySpecReduce_1 96 happyReduction_237+happyReduction_237 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_237 _  = notHappyAtAll ++happyReduce_238 = happySpecReduce_3 96 happyReduction_238+happyReduction_238 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_238 _ _ _  = notHappyAtAll ++happyReduce_239 = happySpecReduce_1 97 happyReduction_239+happyReduction_239 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_239 _  = notHappyAtAll ++happyReduce_240 = happySpecReduce_3 97 happyReduction_240+happyReduction_240 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_240 _ _ _  = notHappyAtAll ++happyReduce_241 = happySpecReduce_1 98 happyReduction_241+happyReduction_241 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_241 _  = notHappyAtAll ++happyReduce_242 = happySpecReduce_3 98 happyReduction_242+happyReduction_242 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_242 _ _ _  = notHappyAtAll ++happyReduce_243 = happySpecReduce_1 99 happyReduction_243+happyReduction_243 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_243 _  = notHappyAtAll ++happyReduce_244 = happySpecReduce_3 99 happyReduction_244+happyReduction_244 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_244 _ _ _  = notHappyAtAll ++happyReduce_245 = happySpecReduce_1 100 happyReduction_245+happyReduction_245 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_245 _  = notHappyAtAll ++happyReduce_246 = happySpecReduce_3 100 happyReduction_246+happyReduction_246 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_246 _ _ _  = notHappyAtAll ++happyReduce_247 = happySpecReduce_1 101 happyReduction_247+happyReduction_247 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_247 _  = notHappyAtAll ++happyReduce_248 = happySpecReduce_3 101 happyReduction_248+happyReduction_248 _+	(HappyAbsSyn14  happy_var_2)+	_+	 =  HappyAbsSyn14+		 (happy_var_2+	)+happyReduction_248 _ _ _  = notHappyAtAll ++happyReduce_249 = happySpecReduce_1 102 happyReduction_249+happyReduction_249 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn102+		 (hsVar happy_var_1+	)+happyReduction_249 _  = notHappyAtAll ++happyReduce_250 = happySpecReduce_1 102 happyReduction_250+happyReduction_250 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn102+		 (hsCon happy_var_1+	)+happyReduction_250 _  = notHappyAtAll ++happyReduce_251 = happySpecReduce_1 103 happyReduction_251+happyReduction_251 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn102+		 (hsVar happy_var_1+	)+happyReduction_251 _  = notHappyAtAll ++happyReduce_252 = happySpecReduce_1 103 happyReduction_252+happyReduction_252 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn102+		 (hsCon happy_var_1+	)+happyReduction_252 _  = notHappyAtAll ++happyReduce_253 = happySpecReduce_1 104 happyReduction_253+happyReduction_253 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_253 _  = notHappyAtAll ++happyReduce_254 = happySpecReduce_1 104 happyReduction_254+happyReduction_254 (HappyTerminal (QVarId happy_var_1))+	 =  HappyAbsSyn14+		 (uncurry (Qual . Module) happy_var_1+	)+happyReduction_254 _  = notHappyAtAll ++happyReduce_255 = happySpecReduce_1 105 happyReduction_255+happyReduction_255 (HappyTerminal (VarId happy_var_1))+	 =  HappyAbsSyn14+		 (UnQual happy_var_1+	)+happyReduction_255 _  = notHappyAtAll ++happyReduce_256 = happySpecReduce_1 105 happyReduction_256+happyReduction_256 _+	 =  HappyAbsSyn14+		 (as_name+	)++happyReduce_257 = happySpecReduce_1 105 happyReduction_257+happyReduction_257 _+	 =  HappyAbsSyn14+		 (qualified_name+	)++happyReduce_258 = happySpecReduce_1 105 happyReduction_258+happyReduction_258 _+	 =  HappyAbsSyn14+		 (hiding_name+	)++happyReduce_259 = happySpecReduce_1 106 happyReduction_259+happyReduction_259 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_259 _  = notHappyAtAll ++happyReduce_260 = happySpecReduce_1 106 happyReduction_260+happyReduction_260 (HappyTerminal (QConId happy_var_1))+	 =  HappyAbsSyn14+		 (uncurry (Qual . Module) happy_var_1+	)+happyReduction_260 _  = notHappyAtAll ++happyReduce_261 = happySpecReduce_1 107 happyReduction_261+happyReduction_261 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_261 _  = notHappyAtAll ++happyReduce_262 = happySpecReduce_1 107 happyReduction_262+happyReduction_262 (HappyTerminal (QConId happy_var_1))+	 =  HappyAbsSyn14+		 (uncurry (Qual . Module) happy_var_1+	)+happyReduction_262 _  = notHappyAtAll ++happyReduce_263 = happySpecReduce_1 108 happyReduction_263+happyReduction_263 (HappyTerminal (ConId happy_var_1))+	 =  HappyAbsSyn14+		 (UnQual happy_var_1+	)+happyReduction_263 _  = notHappyAtAll ++happyReduce_264 = happySpecReduce_1 109 happyReduction_264+happyReduction_264 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_264 _  = notHappyAtAll ++happyReduce_265 = happySpecReduce_1 109 happyReduction_265+happyReduction_265 (HappyTerminal (QConSym happy_var_1))+	 =  HappyAbsSyn14+		 (uncurry (Qual . Module) happy_var_1+	)+happyReduction_265 _  = notHappyAtAll ++happyReduce_266 = happySpecReduce_1 110 happyReduction_266+happyReduction_266 (HappyTerminal (ConSym happy_var_1))+	 =  HappyAbsSyn14+		 (UnQual happy_var_1+	)+happyReduction_266 _  = notHappyAtAll ++happyReduce_267 = happySpecReduce_1 111 happyReduction_267+happyReduction_267 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_267 _  = notHappyAtAll ++happyReduce_268 = happySpecReduce_1 111 happyReduction_268+happyReduction_268 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_268 _  = notHappyAtAll ++happyReduce_269 = happySpecReduce_1 112 happyReduction_269+happyReduction_269 (HappyTerminal (VarSym happy_var_1))+	 =  HappyAbsSyn14+		 (UnQual happy_var_1+	)+happyReduction_269 _  = notHappyAtAll ++happyReduce_270 = happySpecReduce_1 112 happyReduction_270+happyReduction_270 _+	 =  HappyAbsSyn14+		 (minus_name+	)++happyReduce_271 = happySpecReduce_1 112 happyReduction_271+happyReduction_271 _+	 =  HappyAbsSyn14+		 (pling_name+	)++happyReduce_272 = happySpecReduce_1 112 happyReduction_272+happyReduction_272 _+	 =  HappyAbsSyn14+		 (period_name+	)++happyReduce_273 = happySpecReduce_1 113 happyReduction_273+happyReduction_273 (HappyTerminal (QVarSym happy_var_1))+	 =  HappyAbsSyn14+		 (uncurry (Qual . Module) happy_var_1+	)+happyReduction_273 _  = notHappyAtAll ++happyReduce_274 = happySpecReduce_1 114 happyReduction_274+happyReduction_274 (HappyTerminal (IntTok happy_var_1))+	 =  HappyAbsSyn69+		 (hsLit (HsInt (readInteger happy_var_1))+	)+happyReduction_274 _  = notHappyAtAll ++happyReduce_275 = happySpecReduce_1 114 happyReduction_275+happyReduction_275 (HappyTerminal (Character happy_var_1))+	 =  HappyAbsSyn69+		 (hsLit (HsChar happy_var_1)+	)+happyReduction_275 _  = notHappyAtAll ++happyReduce_276 = happySpecReduce_1 114 happyReduction_276+happyReduction_276 (HappyTerminal (StringTok happy_var_1))+	 =  HappyAbsSyn69+		 (hsLit (HsString happy_var_1)+	)+happyReduction_276 _  = notHappyAtAll ++happyReduce_277 = happySpecReduce_1 114 happyReduction_277+happyReduction_277 (HappyTerminal (FloatTok happy_var_1))+	 =  HappyAbsSyn69+		 (hsLit (HsFrac (readRational happy_var_1))+	)+happyReduction_277 _  = notHappyAtAll ++happyReduce_278 = happyMonadReduce 0 115 happyReduction_278+happyReduction_278 (happyRest)+	 = happyThen ( getSrcLoc+	) (\r -> happyReturn (HappyAbsSyn115 r))++happyReduce_279 = happySpecReduce_1 116 happyReduction_279+happyReduction_279 _+	 =  HappyAbsSyn7+		 (()+	)++happyReduce_280 = happyMonadReduce 1 116 happyReduction_280+happyReduction_280 (_ `HappyStk`+	happyRest)+	 = happyThen ( popContext+	) (\r -> happyReturn (HappyAbsSyn7 r))++happyReduce_281 = happyMonadReduce 0 117 happyReduction_281+happyReduction_281 (happyRest)+	 = happyThen ( pushContext NoLayout+	) (\r -> happyReturn (HappyAbsSyn7 r))++happyReduce_282 = happyMonadReduce 0 118 happyReduction_282+happyReduction_282 (happyRest)+	 = happyThen ( do { SrcLoc _ _ c <- getSrcLoc ;+					pushContext (Layout c)+				      }+	) (\r -> happyReturn (HappyAbsSyn7 r))++happyReduce_283 = happySpecReduce_1 119 happyReduction_283+happyReduction_283 (HappyTerminal (ConId happy_var_1))+	 =  HappyAbsSyn119+		 (Module happy_var_1+	)+happyReduction_283 _  = notHappyAtAll ++happyReduce_284 = happySpecReduce_1 120 happyReduction_284+happyReduction_284 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_284 _  = notHappyAtAll ++happyReduce_285 = happySpecReduce_1 121 happyReduction_285+happyReduction_285 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_285 _  = notHappyAtAll ++happyReduce_286 = happySpecReduce_1 122 happyReduction_286+happyReduction_286 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_286 _  = notHappyAtAll ++happyReduce_287 = happySpecReduce_1 123 happyReduction_287+happyReduction_287 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_287 _  = notHappyAtAll ++happyReduce_288 = happySpecReduce_1 124 happyReduction_288+happyReduction_288 (HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn14+		 (happy_var_1+	)+happyReduction_288 _  = notHappyAtAll ++happyReduce_289 = happyReduce 6 125 happyReduction_289+happyReduction_289 ((HappyAbsSyn69  happy_var_6) `HappyStk`+	_ `HappyStk`+	(HappyAbsSyn13  happy_var_4) `HappyStk`+	(HappyAbsSyn14  happy_var_3) `HappyStk`+	(HappyAbsSyn115  happy_var_2) `HappyStk`+	_ `HappyStk`+	happyRest)+	 = HappyAbsSyn26+		 (hsProperty happy_var_2 happy_var_3 happy_var_4 happy_var_6+	) `HappyStk` happyRest++happyReduce_290 = happySpecReduce_1 126 happyReduction_290+happyReduction_290 _+	 =  HappyAbsSyn126+		 (hsPropForall+	)++happyReduce_291 = happySpecReduce_1 126 happyReduction_291+happyReduction_291 _+	 =  HappyAbsSyn126+		 (hsPropExists+	)++happyReduce_292 = happySpecReduce_1 126 happyReduction_292+happyReduction_292 _+	 =  HappyAbsSyn126+		 (hsPropForallDefined+	)++happyReduce_293 = happySpecReduce_1 126 happyReduction_293+happyReduction_293 _+	 =  HappyAbsSyn126+		 (hsPropExistsUnique+	)++happyReduce_294 = happySpecReduce_2 127 happyReduction_294+happyReduction_294 (HappyAbsSyn13  happy_var_2)+	(HappyAbsSyn14  happy_var_1)+	 =  HappyAbsSyn13+		 (happy_var_1 : happy_var_2+	)+happyReduction_294 _ _  = notHappyAtAll ++happyReduce_295 = happySpecReduce_0 127 happyReduction_295+happyReduction_295  =  HappyAbsSyn13+		 ([]+	)++happyNewToken action sts stk+	= lexer(\tk -> +	let cont i = action i i tk (HappyState action) sts stk in+	case tk of {+	EOF -> action 195 195 (error "reading EOF!") (HappyState action) sts stk;+	VarId happy_dollar_dollar -> cont 128;+	QVarId happy_dollar_dollar -> cont 129;+	ConId happy_dollar_dollar -> cont 130;+	QConId happy_dollar_dollar -> cont 131;+	VarSym "-" -> cont 132;+	VarSym happy_dollar_dollar -> cont 133;+	ConSym happy_dollar_dollar -> cont 134;+	QVarSym happy_dollar_dollar -> cont 135;+	QConSym happy_dollar_dollar -> cont 136;+	QModId happy_dollar_dollar -> cont 137;+	IntTok happy_dollar_dollar -> cont 138;+	FloatTok happy_dollar_dollar -> cont 139;+	Character happy_dollar_dollar -> cont 140;+	StringTok happy_dollar_dollar -> cont 141;+	LeftParen -> cont 142;+	RightParen -> cont 143;+	SemiColon -> cont 144;+	LeftCurly -> cont 145;+	RightCurly -> cont 146;+	VRightCurly -> cont 147;+	LeftSquare -> cont 148;+	RightSquare -> cont 149;+	Comma -> cont 150;+	Underscore -> cont 151;+	BackQuote -> cont 152;+	Period -> cont 153;+	DotDot -> cont 154;+	DoubleColon -> cont 155;+	Equals -> cont 156;+	Backslash -> cont 157;+	Bar -> cont 158;+	LeftArrow -> cont 159;+	RightArrow -> cont 160;+	At -> cont 161;+	Tilde -> cont 162;+	DoubleArrow -> cont 163;+	Exclamation -> cont 164;+	KW_As -> cont 165;+	KW_Case -> cont 166;+	KW_Class -> cont 167;+	KW_Data -> cont 168;+	KW_Default -> cont 169;+	KW_Deriving -> cont 170;+	KW_Do -> cont 171;+	KW_Else -> cont 172;+	KW_Hiding -> cont 173;+	KW_If -> cont 174;+	KW_Import -> cont 175;+	KW_In -> cont 176;+	KW_Infix -> cont 177;+	KW_InfixL -> cont 178;+	KW_InfixR -> cont 179;+	KW_Instance -> cont 180;+	KW_Let -> cont 181;+	KW_Module -> cont 182;+	KW_NewType -> cont 183;+	KW_Of -> cont 184;+	KW_Then -> cont 185;+	KW_Type -> cont 186;+	KW_Where -> cont 187;+	KW_Qualified -> cont 188;+	KW_Primitive -> cont 189;+	KW_Property -> cont 190;+	KW_QAll -> cont 191;+	KW_QExists -> cont 192;+	KW_QAllDef -> cont 193;+	KW_QExistsU -> cont 194;+	})++happyThen :: PM a -> (a -> PM b) -> PM b+happyThen = (thenPM)+happyReturn = (returnPM)+happyThen1 = happyThen+happyReturn1 = happyReturn++parse = happyThen (happyParse action_0) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })++happyError = parseError "parse error"+{-# LINE 1 "GenericTemplate.hs" #-}+{-# LINE 1 "GenericTemplate.hs" #-}+-- $Id: PropParser.hs,v 1.10 2001/11/06 06:33:37 hallgren Exp $++{-# LINE 15 "GenericTemplate.hs" #-}+++++++++++++++++++++++++++++++++++++++++++++++++++++++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++happyAccept j tk st sts (HappyStk ans _) = ++					   (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++{-# LINE 138 "GenericTemplate.hs" #-}+++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++++newtype HappyState b c = HappyState+        (Int ->                    -- token number+         Int ->                    -- token number (yes, again)+         b ->                           -- token semantic value+         HappyState b c ->              -- current state+         [HappyState b c] ->            -- state stack+         c)++++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =+     let i = (case x of { HappyErrorToken (i) -> i }) in+--     trace "shifting the error token" $+     new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)++happyShift new_state i tk st sts stk =+     happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk+     = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')+     = action nt j tk st sts (fn v1 `HappyStk` stk')++happySpecReduce_2 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')+     = action nt j tk st sts (fn v1 v2 `HappyStk` stk')++happySpecReduce_3 i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+     = action nt j tk st sts (fn v1 v2 v3 `HappyStk` stk')++happyReduce k i fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happyReduce k nt fn j tk st sts stk = action nt j tk st1 sts1 (fn stk)+       where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))++happyMonadReduce k nt fn (1) tk st sts stk+     = happyFail (1) tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+        happyThen1 (fn stk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))+       where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))+             drop_stk = happyDropStk k stk++happyDrop (0) l = l+happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t++happyDropStk (0) l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction++++++++++happyGoto action j tk st = action j j tk (HappyState action)+++-----------------------------------------------------------------------------+-- Error recovery ((1) is the error token)++-- parse error if we are in recovery and we fail again+happyFail  (1) tk old_st _ stk =+--	trace "failing" $ +    	happyError+++{-  We don't need state discarding for our restricted implementation of+    "error".  In fact, it can cause some bogus parses, so I've disabled it+    for now --SDM++-- discard a state+happyFail  (1) tk old_st (((HappyState (action))):(sts)) +						(saved_tok `HappyStk` _ `HappyStk` stk) =+--	trace ("discarding state, depth " ++ show (length stk))  $+	action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+--                       save the old token and carry on.+happyFail  i tk (HappyState (action)) sts stk =+--      trace "entering error recovery" $+	action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions++++++++-----------------------------------------------------------------------------+-- Don't inline any functions from the template.  GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.++++++++++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ tools/property/parse/extras/PropParser.y view
@@ -0,0 +1,970 @@+-- $Id: PropParser.y,v 1.11 2001/12/07 22:38:29 hallgren Exp $++-- New Low-level Haskell plus properties Parser+-- Bill Harrison and Emir Pasalic and Andrew Moran+--+-- Note: +--   This parser is based on Simon Marlow and Sven Panne's (1997,1998) Haskell+--   grammar for Happy.  It uses the Programatica abstract syntax. +--   The parser does not correspond strictly to the grammar of standard+--   Haskell.  Rather, it relies on a number of postprocessing steps that +--    (1) validate the rather leaky terms produced by the and discard invalid +--        programs +--    (2) perform a small amount of rewriting (e.g., for infix operator+--        precedences)++{+module PropParser (parse) where+ ++import PropSyntax+import PropSyntaxUtil+import ParseMonad+import Lexer+import LexUtil(readInteger, readRational)+import ParseUtil+--import Rewrite+import IOExts+import Char(showLitChar)++}++%token+        VARID 	 { VarId $$ }+	QVARID 	 { QVarId $$ }+	CONID	 { ConId $$ }+	QCONID   { QConId $$ }+	'-'	 { VarSym "-" }+	VARSYM	 { VarSym $$ }+	CONSYM	 { ConSym $$ }+	QVARSYM	 { QVarSym $$ }+	QCONSYM  { QConSym $$ }+	QMODID   { QModId $$ }+	INT	 { IntTok $$ }+	RATIONAL { FloatTok $$ }+	CHAR	 { Character $$ }+	STRING   { StringTok $$ }+{-++Symbols++-}+	'('	{ LeftParen }+	')'	{ RightParen }+	';'	{ SemiColon }+	'{'	{ LeftCurly }+	'}'	{ RightCurly }+	vccurly { VRightCurly }	      -- a virtual close brace+	'['	{ LeftSquare }+	']'	{ RightSquare }+  	','	{ Comma }+	'_'	{ Underscore }+	'`'	{ BackQuote }+        '.'     { Period }            -- must be a token so it can matched in+	                              -- property quantifier expressions; it+                                      -- must be turned into an id when not+                                      -- matched thus, or used in a float.++{-++Reserved operators++-}+	'..'	{ DotDot }+	'::'	{ DoubleColon }+	'='	{ Equals }+	'\\'	{ Backslash }+	'|'	{ Bar }+	'<-'	{ LeftArrow }+	'->'	{ RightArrow }+	'@'	{ At }+	'~'	{ Tilde }+	'=>'	{ DoubleArrow }+--	'-'	{ Minus }+	'!'	{ Exclamation }+{-++Reserved Ids++-}+	'as'		{ KW_As }+	'case'		{ KW_Case }+	'class'		{ KW_Class }+	'data'		{ KW_Data }+	'default'	{ KW_Default }+	'deriving'	{ KW_Deriving }+	'do'		{ KW_Do }+	'else'		{ KW_Else }+	'hiding'	{ KW_Hiding }+	'if'		{ KW_If }+	'import'	{ KW_Import }+	'in'		{ KW_In }+	'infix'		{ KW_Infix }+	'infixl'	{ KW_InfixL }+	'infixr'	{ KW_InfixR }+	'instance'	{ KW_Instance }+	'let'		{ KW_Let }+	'module'	{ KW_Module }+	'newtype'	{ KW_NewType }+	'of'		{ KW_Of }+	'then'		{ KW_Then }+	'type'		{ KW_Type }+	'where'		{ KW_Where }+	'qualified'	{ KW_Qualified }+	'primitive'     { KW_Primitive }+        'property'      { KW_Property } +        'All'           { KW_QAll } +        'Ex'            { KW_QExists } +        'AllDef'        { KW_QAllDef } +        'ExU'           { KW_QExistsU } ++%monad { PM } { thenPM } { returnPM }+%lexer { lexer } { EOF }+%name parse+%tokentype { Token }+%%+{-++-----------------------------------------------------------------------------+Module Header++-}+module :: { HsModuleR }+        : 'module' modid maybeexports 'where' body+			     { hsModule $2 $3 $5 }+        | body		     { hsModule main_mod Nothing $1 }++body :: { ([HsImportDecl], [HsDecl]) }+	:  '{' layout_off bodyaux '}'			{ $3 }+ 	|      layout_on  bodyaux close			{ $2 }++bodyaux :: { ([HsImportDecl], [HsDecl]) }+	: impdecls ';' topdecls optsemi    { ($1, $3) }+	|              topdecls optsemi    { ([], $1) }+	| impdecls              optsemi    { ($1, []) }+	| {- empty -}			   { ([], []) }++optsemi :: { () }+	: ';'						{ () }+	| {- empty -}					{ () }+{-++-----------------------------------------------------------------------------+The Export List++-}+maybeexports :: { Maybe [HsExportSpec] }+ 	:  exports				{ Just $1 }+ 	|  {- empty -}				{ Nothing }++exports :: { [HsExportSpec] }+	: '(' exportlist maybecomma ')'		{ reverse $2 }+	| '(' ')'				{ [] }++maybecomma :: { () }+	: ','					{ () }+	| {- empty -}				{ () }++exportlist :: { [HsExportSpec] }+ 	:  exportlist ',' export		{ $3 : $1 }+ 	|  export				{ [$1]  }++export :: { HsExportSpec }+ 	:  qvar				      { HsEVar $1 }+ 	|  qtyconorcls			      { HsEAbs $1 }+ 	|  qtyconorcls '(' '..' ')'	      { HsEThingAll $1 }+ 	|  qtyconorcls '(' ')'		      { HsEThingWith $1 [] }+ 	|  qtyconorcls '(' qcnames ')'	      { HsEThingWith $1 (reverse $3) }+ 	|  'module' modid		      { HsEModuleContents $2 }++qcnames :: { [HsName] }+ 	:  qcnames ',' qcname			{ $3 : $1 }+ 	|  qcname				{ [$1]  }++qcname :: { HsName }+	:  qvar					{ $1 }+ 	|  qcon					{ $1 }+{-++-----------------------------------------------------------------------------+Import Declarations++-}+impdecls :: { [HsImportDecl] }+	: impdecls ';' impdecl			{ $3 : $1 }+	| impdecl				{ [$1] }++impdecl :: { HsImportDecl }+	: 'import' srcloc optqualified modid maybeas maybeimpspec+ 		  		{ HsImportDecl $2 $4 $3 $5 $6 }++optqualified :: { Bool }+       : 'qualified'                            { True  }+       | {- empty -}				{ False }++maybeas :: { Maybe Module }+       : 'as' modid                             { Just $2 }+       | {- empty -}				{ Nothing }++maybeimpspec :: { Maybe (Bool, [HsImportSpec]) }+	: impspec				{ Just $1 }+	| {- empty -}				{ Nothing }++impspec :: { (Bool, [HsImportSpec]) }+ 	:  '(' importlist maybecomma ')'  	  { (False, reverse $2) }+ 	|  'hiding' '(' importlist maybecomma ')' { (True,  reverse $3) }++importlist :: { [HsImportSpec] }+ 	:  importlist ',' import		{ $3 : $1 }+ 	|  import				{ [$1]  }++import :: { HsImportSpec }+ 	:  var				      { HsIVar $1 }+ 	|  tyconorcls			      { HsIAbs $1 }+ 	|  tyconorcls '(' '..' ')'	      { HsIThingAll $1 }+ 	|  tyconorcls '(' ')'		      { HsIThingWith $1 [] }+ 	|  tyconorcls '(' cnames ')'	      { HsIThingWith $1 (reverse $3) }++cnames :: { [HsName] }+ 	:  cnames ',' cname			{ $3 : $1 }+ 	|  cname				{ [$1]  }++cname :: { HsName }+	:  var					{ $1 }+ 	|  con					{ $1 }++{-++-----------------------------------------------------------------------------+Top-level declarations.++-}++topdecls :: { [HsDecl] }+	: topdecls ';' topdecl     { funCons $3 $1 }+	| topdecl		      { [$1] }++{-++-----------------------------------------------------------------------------+Fixity Declarations++checkPrec has been eliminated; fixities may now be negative => must be added+to the static check.++-}++fix :: { HsDecl }+ 	: infix srcloc prec ops   { hsInfixDecl $2 (HsFixity $1 $3) $4 }+	                +prec :: { Int }+	: {- empty -}		  { 9 }+	| INT		          { fromInteger (readInteger $1) }++infix :: { HsAssoc }+	: 'infix'				{ HsAssocNone  }+	| 'infixl'				{ HsAssocLeft  }+	| 'infixr'				{ HsAssocRight }++ops   :: { [HsIdent] }+	: op ',' ops				{ $1 : $3 }+	| op					{ [$1] }++{-++-----------------------------------------------------------------------------+Top-Level Declarations++Note: The report allows topdecls to be empty. This would result in another+shift/reduce-conflict, so we don't handle this case here, but in bodyaux.++Not sure that these checkHeaders belong here; may be better for extensibility+to separate parsing from consistency checks.  Also, some of these use Dec, one+of the not-tying constructors.  This is inherently bad for extensibility.  But+then, we probably won't be able to use Happy any more anyway (since "parser+generator" and "easily extensible by many" don't go well together).  -- AKM++-}++topdecl :: { HsDecl }+	: 'type' tyconparams srcloc '=' type	+	       { hsTypeDecl $3 $2 $5 }+        | 'data' srcloc ctyconparams '=' constrs deriving+               { hsDataDecl $2 (fst $3) (snd $3) (reverse $5) $6 } +        | 'newtype' srcloc ctyconparams '=' constr deriving+               { hsNewTypeDecl $2 (fst $3) (snd $3) $5 $6 }+	| 'class' srcloc ctype optcbody	+	       { hsClassDecl  $2 (fst $3) (snd $3) [] $4+	       }+	| 'instance' srcloc ctype optvaldefs+               { hsInstDecl $2 (fst $3) (snd $3) $4+	       }	+	| 'default' srcloc type		+	       { hsDefaultDecl $2 $3 }+        -- Hugs compatibility+        | 'data' srcloc ctybinding+               { hsPrimitiveTypeDecl $2 (fst $3) (snd $3) }+	| 'primitive' srcloc var '::'  type+	       { hsPrimitiveBind $2 $3 $5 }+        +        | decl { $1 }+++decls :: { [HsDecl] }+	: decls1 optsemi		{ reverse $1 }+	| optsemi 			{ [] }++decls1 :: { [HsDecl] }+	: decls1 ';' decl		{ funCons $3 $1 }+	| decl				{ [$1] }++decl :: { HsDecl }+	: signdecl			{ $1 }+        | fix                           { $1 }+	| valdef			{ $1 }+        -- Property declarations+        | propdecl                      { $1 }++decllist :: { [HsDecl] }+	: '{' layout_off decls '}'	{ $3 }+	|     layout_on  decls close	{ $2 }++signdecl :: { HsDecl }+	: vars srcloc '::' ctype+	      { hsTypeSig $2 (reverse $1) (fst $4) (snd $4) }+{-+++ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var+instead of qvar, we get another shift/reduce-conflict. Consider the+following programs:++   { (+) :: ... }          A "signdecl" where everything to the left of the+                           :: is parsed as "vars" which should allow only var++   { (+) x y  = ... }      A "valdef" where everything to the left of the+                           = is parsed as an "infixexp" which (incorrectly+                           in this context) allows a "qvar", since "infixexp"+                           is also used to parse patterns where "qvar" is+                           allowed++This leads to a shift/reduce-conflict. The parser must decide without too much+lookahead.  By allowing a qvar as the first thing in "vars" the parser shifts+(until it sees a "," or a "::") and doesn't get confused.  Without this,+deciding what to do with requires more lookahead.  So let's allow "qvar" in+"vars" and then check for ourselves afterwards that this didn't happen.++-}+vars	:: { [HsName] }+	: vars ',' var		{ $3 : $1 }+	| qvar			{% case $1 of+				   Qual _ _ -> parseError "bad qvar in vars."+				   _        -> return [$1]+				}+{-++-----------------------------------------------------------------------------+Types++-}+type :: { HsType }+	: btype '->' type		{ hsTyFun $1 $3 }+	| btype				{ $1 }++btype :: { HsType }+        : btype atype                   { hsTyApp $1 $2 }+        | atype                         { $1 }++atype :: { HsType }+	: gtycon			{ hsTyCon $1 }+	| tyvar				{ hsTyVar $1 }+	| '(' types ')'			{ hsTyTuple (reverse $2) }+	| '[' type ']'			{ hsTyApp list_tycon $2 }+	| '(' type ')'			{ $2 }++gtycon :: { HsName }+	: qtycon			{ $1 }+	| '(' ')'			{ unit_tycon_name }+	| '[' ']'			{ list_tycon_name }+	| '(' '->' ')'			{ fun_tycon_name }+	| '(' commas ')'		{ tuple_tycon_name $2 }+        -- These next three are not strictly Haskell 98, but are accepted by+        -- GHC.  Their omission from the report seems to be a bug, since+	-- without this, one cannot import the Prelude qualified and refer to+        -- the type construtors (), [], or the tuple type constructors.+	| QMODID '.' '(' ')'		{ qualify $1 "()" }+	| QMODID '.' '[' ']'		{ qualify $1 "[]" }+	| QMODID '.' '(' commas ')'     { qualify $1 (tuple $4) }++{-++(Slightly edited) Comment from GHC's hsparser.y:+"context => type" vs  "type" is a problem, because you can't distinguish+between:++	foo :: (Baz a, Baz a)++	bar :: (Baz a, Baz a) => [a] -> [a] -> [a]++with one token of lookahead.  The HACK is to parse the context as a btype+(more specifically as a tuple type), then check that it has the right form+C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!++-}+ctype :: { ([HsType],HsType) }+	: type '=>' type      { (reverse (tupleTypeToContext $1), $3) }+	| type		      { ([], $1) }++types	:: { [HsType] }+	: types ',' type		{ $3 : $1 }+	| type  ',' type		{ [$3, $1] }++ctyconparams :: { ([HsType], [HsType]) }+        : type '=>' tyconparams     { (reverse (tupleTypeToContext $1), $3) }+        | tyconparams               { ([], $1) }+ +tyconparams :: { [HsType] }+        : tycon typarams            { hsTyCon $1 : (reverse $2) }+        | tycon                     { [hsTyCon $1] }+ +typarams :: { [HsType] }+        : typarams tyvar            { (hsTyVar $2) : $1 }+        | tyvar                     { [hsTyVar $1] }++ctybinding :: { ([HsType], HsName) }+        : type '=>' tycon          { (reverse (tupleTypeToContext $1), $3) }+        | tycon                    { ([], $1) }++{-++-----------------------------------------------------------------------------+Datatype declarations++-}+constrs :: { [HsConDecl HsType ] }+	: constrs '|' constr		{ $3 : $1 }+	| constr			{ [$1] }++constr :: { HsConDecl HsType }+	: srcloc scontype		{ HsConDecl $1 (fst $2) (snd $2) }+	| srcloc sbtype conop sbtype	{ HsConDecl $1 $3 [$2, $4] }+	| srcloc con '{' layout_off fielddecls '}' +					{ HsRecDecl $1 $2 (reverse $5) }++scontype :: { (HsName, [HsBangType HsType]) }+	: btype			    {% do { (c, ts) <- splitTyConApp $1 ;+					    return (c, map HsUnBangedType ts)+					  }+				    }+	| scontype1		    { $1 }++scontype1 :: { (HsName, [HsBangType HsType]) }+	: btype '!' atype+	      {% do { (c, ts) <- splitTyConApp $1 ;+		      return (c, map HsUnBangedType ts ++ [HsBangedType $3])+		    }+	      }+	| scontype1 satype		{ (fst $1, snd $1 ++ [$2] ) }++satype :: { HsBangType HsType}+	: atype				{ HsUnBangedType $1 }+	| '!' atype			{ HsBangedType   $2 }++sbtype :: { HsBangType HsType }+	: btype				{ HsUnBangedType $1 }+	| '!' atype			{ HsBangedType   $2 }++fielddecls :: { [([HsName], HsBangType HsType)] }+	: fielddecls ',' fielddecl	{ $3 : $1 }+	| fielddecl			{ [$1] }++fielddecl :: { ([HsName], HsBangType HsType) }+	: vars '::' stype		{ (reverse $1, $3) }++stype :: { HsBangType HsType}+	: type				{ HsUnBangedType $1 }	+	| '!' atype			{ HsBangedType   $2 }++deriving :: { [HsName] }+	: {- empty -}			{ [] }+	| 'deriving' qtycls		{ [$2] }+	| 'deriving' '('          ')'	{ [] }+	| 'deriving' '(' dclasses ')'	{ reverse $3 }++dclasses :: { [HsName] }+	: dclasses ',' qtycls		{ $3 : $1 }+        | qtycls			{ [$1] }+{-++-----------------------------------------------------------------------------+Class declarations++-}+optcbody :: { [HsDecl] }+	: 'where' '{' layout_off cbody '}'	{ $4 }+	| 'where' layout_on cbody close		{ $3 }+	| {- empty -}				{ [] }++cbody :: { [HsDecl] }+	: cmethods ';' cdefaults optsemi	{ reverse $1 ++ reverse $3 }+	| cmethods optsemi			{ reverse $1 }+	| optsemi				{ [] }++cmethods :: { [HsDecl] }+	: cmethods ';' signdecl			{ funCons $3  $1 }+	| signdecl				{ [$1] }++cdefaults :: { [HsDecl] }+	: cdefaults ';' valdef			{ funCons $3  $1 }+	| valdef				{ [$1] }+{-++-----------------------------------------------------------------------------+Instance declarations++-}+optvaldefs :: { [HsDecl] }+	: 'where' '{' layout_off valdefs '}'	{ $4 }+	| 'where' layout_on valdefs close	{ $3 }+	| {- empty -}				{ [] }+{-++Recycling...++-}+valdefs :: { [HsDecl] }+	: cdefaults optsemi			{ reverse $1 }+	| optsemi				{ [] }+{-++-----------------------------------------------------------------------------+Value definitions++-}++valdef :: { HsDecl }+	: infixexp srcloc rhs optwheredecls+				    {% if isPatternExp $1 +                                       then mkValDef $1 $2 $3 $4+                                       else mkFunDef $1 $2 $3 $4+				    }++optwheredecls :: { [HsDecl] }+        : 'where' decllist          { $2 }+        | {- empty -}               { [] }++rhs	:: { HsRhs HsExp }+	: '=' exp		    { HsBody $2 }+	| gdrhss		    { HsGuard (reverse $1) }++gdrhss :: { [(SrcLoc, HsExp, HsExp)] }+	: gdrhss gdrhs		    { $2 : $1 }+	| gdrhs			    { [$1] }++gdrhs :: { (SrcLoc, HsExp, HsExp) }+	: '|' exp srcloc '=' exp    { ($3, $2, $5) }++{-++-----------------------------------------------------------------------------+Expressions++-}+exp   :: { HsExp }+	: infixexp '::' srcloc ctype    { hsExpTypeSig $3 $1 (fst $4) (snd $4) }+	| infixexp	                { $1 }++infixexp :: { HsExp }+	: exp10				{ $1 }+	| infixexp qop exp10		{ hsInfixApp $1 $2 $3 }++{-++    From MPJ's Tool0 Hugs98 parser.y:++        | qfier pats '.' exp		{$$ = gc4(ap(QUANTIFY,+                                                     ap($1,+                                                        pair(rev($2),+                                                             pair($3,$4)))));}+-}++exp10 :: { HsExp }+	: '\\' aexps '->' exp+	      {% do { ps <- mapM expToPat $2 ;+                      return (hsLambda (reverse ps) $4)+		    }+              }+        -- Quantifier expressions in property declarations+        | quant aexps '.' exp+              {% do { ps <- mapM expToPat $2 ;+                      return (mkQuant $1 (reverse ps) $4)+		    }+              }+  	| 'let' decllist 'in' exp	 { hsLet $2 $4 }+	| 'if' exp 'then' exp 'else' exp { hsIf $2 $4 $6 }+   	| 'case' exp 'of' altslist	 { hsCase $2 $4 } +	| '-' fexp			 { hsNegApp $2 }+  	| 'do' stmtlist			 { hsDo (atoms2Stmt $2) }+	| fexp				 { $1 }++fexp :: { HsExp }+	: fexp aexp			{ hsApp $1 $2 }+  	| aexp				{ $1 }++aexps :: { [HsExp] }+	: aexps aexp			{ $2 : $1 }+  	| aexp				{ [$1] }+{-++Note: The first alternative of aexp is not neccessarily a record update, it+could be a labeled construction, too.++-}+aexp	:: { HsExp }+  	: aexp '{' layout_off fbinds '}'+ 	                             { mkRecord $1 (reverse $4) }+  	| aexp1			     { $1 }++aexp1	:: { HsExp }+	: qvar				{ hsEVar ($1 :: HsName) }+	| gcon				{ $1 }+  	| literal			{ $1 }+	| '(' exp ')'			{ hsParen $2 }+	| '(' texps ')'			{ hsTuple (reverse $2) }+	| '[' list ']'                  { $2 }+	| '(' infixexp qop ')'		{ hsLeftSection $2 $3 }+	| '(' qop infixexp ')'		{ hsRightSection $2 $3 }+	| qvar '@' aexp1		{ hsAsPat $1 $3 }+	| '_'				{ hsWildCard }+	| '~' aexp1			{ hsIrrPat $2 }++commas :: { Int }+	: commas ','			{ $1 + 1 }+	| ','				{ 1 }++texps :: { [HsExp] }+	: texps ',' exp			{ $3 : $1 }+	| exp ',' exp			{ [$3, $1] }+{-++-----------------------------------------------------------------------------+List expressions++The rules below are little bit contorted to keep lexps left-recursive while+avoiding another shift/reduce-conflict.++-}+list :: { HsExp }+	: exp				{ hsList [$1] }+	| lexps 			{ hsList (reverse $1) }+	| exp '..'			{ hsEnumFrom $1 }+	| exp ',' exp '..' 		{ hsEnumFromThen $1 $3 }+	| exp '..' exp	 		{ hsEnumFromTo $1 $3 }+	| exp ',' exp '..' exp		{ hsEnumFromThenTo $1 $3 $5 }+	| exp '|' quals			+          { hsListComp (atoms2Stmt (reverse $3 ++ [HsQualifierAtom $1])) }++lexps :: { [HsExp] }+	: lexps ',' exp 		{ $3 : $1 }+	| exp ',' exp			{ [$3,$1] }+{-++-----------------------------------------------------------------------------+List comprehensions++-}+quals :: { [HsStmtAtom HsExp HsPat [HsDecl] ] }+	: quals ',' qual		{ $3 : $1 }+	| qual				{ [$1] }++qual  :: { HsStmtAtom HsExp HsPat [HsDecl] }+	: infixexp '<-' exp		{% do { p <- expToPat $1 ; +                                                return (HsGeneratorAtom p $3)+					      }+					}+	| exp			  	{ HsQualifierAtom $1 }+  	| 'let' decllist		{ HsLetStmtAtom   $2 }++{-++-----------------------------------------------------------------------------+Case alternatives++-}+altslist :: { [HsAlt HsExp HsPat [HsDecl]] }+	: '{' layout_off alts optsemi '}'	{ reverse $3 }+	|     layout_on  alts optsemi close	{ reverse $2 }+++alts :: { [HsAlt HsExp HsPat [HsDecl]] }+	: alts ';' alt				{ $3 : $1 }+	| alt					{ [$1] }++alt :: { HsAlt HsExp HsPat [HsDecl] }+	: infixexp srcloc rhscasealts+	      {% do { p <- expToPat $1 ;+	              return (HsAlt $2 p $3 [])+		    }+	      } +        | infixexp srcloc rhscasealts 'where' decllist+	      {% do { p <- expToPat $1 ;+		      return (HsAlt $2 p $3 $5)+		    }+	      }++rhscasealts :: { HsRhs HsExp }+	: '->' exp		            { HsBody $2 }+	| gdcaserhss		            { HsGuard (reverse $1) }++gdcaserhss :: { [(SrcLoc, HsExp, HsExp)] }+	: gdcaserhss gdcaserhs		    { $2 : $1 }+	| gdcaserhs			    { [$1] }++gdcaserhs :: { (SrcLoc, HsExp, HsExp) }+	: '|' srcloc exp  '->' exp          { ($2, $3, $5) }++{-++-----------------------------------------------------------------------------+Statement sequences++-}+stmtlist :: { [HsStmtAtom HsExp HsPat [HsDecl]] }+	:  '{' layout_off stmts '}'	{ $3 }+	|   layout_on  stmts close	{ $2 }++stmts :: { [HsStmtAtom HsExp HsPat [HsDecl]] }+        : stmts1 ';' exp	      { reverse (HsQualifierAtom $3 : $1) }+ 	| exp               	      { [HsQualifierAtom $1] }++stmts1 :: { [HsStmtAtom HsExp HsPat [HsDecl]] }+  	: stmts1 ';' qual		{ $3 : $1 }+	| qual 				{ [$1] }+{-++-----------------------------------------------------------------------------+Record Field Update/Construction++-}+fbinds :: { [HsFieldUpdate HsExp] }+	: fbinds ',' fbind		{ $3 : $1 }+	| fbind				{ [$1] }++fbind	:: { HsFieldUpdate HsExp }+	: qvar '=' exp			{ HsFieldUpdate $1 ($3) }+--	| qvar				{ HsFieldBind $1 }+{-++-----------------------------------------------------------------------------+Variables, Constructors and Operators.++-}+gcon :: { HsExp }+  	: '(' ')'		     { hsECon (qualify "Prelude" "()") }+	| '[' ']'		     { hsList [] }+	| '(' commas ')'	     { hsECon (qualify "Prelude" (tuple $2)) }+        -- These next three are not strictly Haskell 98, but are accepted by+        -- GHC.  Their omission from the report seems to be a bug, since+	-- without this, one cannot import the Prelude qualified and refer to+        -- the values (), [], or the tuple constructors.  It's unclear what+	-- effect of qualifying the nil list would actually have, since it is+	-- otherwise treated separately (i.e., there is no VARSYM called+        -- "[]").  Since it can't reused, according to the report, I have+	-- treated the same as an unqualified [], ignoring the qualifying+	-- module.  AKM+	| QMODID '.' '(' ')'	     { hsECon (qualify $1 "()") }+	| QMODID '.' '[' ']'	     { hsList [] }+	| QMODID '.' '(' commas ')'  { hsECon (qualify $1 (tuple $4)) }+  	| qcon			     { hsECon $1 }++var 	:: { HsName }+	: varid			{ $1 }+	| '(' varsym ')'	{ $2 }++qvar 	:: { HsName }+	: qvarid		{ $1 }+	| '(' qvarsym ')'	{ $2 }++con	:: { HsName }+	: conid			{ $1 }+	| '(' consym ')'        { $2 }++qcon	:: { HsName }+	: qconid		{ $1 }+	| '(' qconsym ')'	{ $2 }++varop	:: { HsName }+	: varsym		{ $1 }+	| '`' varid '`'		{ $2 }++qvarop :: { HsName }+	: qvarsym		{ $1 }+	| '`' qvarid '`'	{ $2 }+{-+qvaropm :: { HsName }+	: qvarsymm		{ $1 }+	| '`' qvarid '`'	{ $2 }+-}+conop :: { HsName }+	: consym		{ $1 }	+	| '`' conid '`'		{ $2 }++qconop :: { HsName }+	: qconsym		{ $1 }+	| '`' qconid '`'	{ $2 }++op	:: { HsIdent }+	: varop			{ hsVar $1 }+	| conop 		{ hsCon $1 }++qop	:: { HsIdent }+	: qvarop		{ hsVar $1 }+	| qconop		{ hsCon $1 }+{-+qopm	:: { HsIdent }+	: qvaropm		{ hsVar $1 }+	| qconop		{ hsCon $1 }+-}+qvarid :: { HsName }+	: varid			{ $1 }+	| QVARID		{ uncurry (Qual . Module) $1 }++varid :: { HsName }+	: VARID			{ UnQual $1 }+	| 'as'			{ as_name }+	| 'qualified'           { qualified_name }+	| 'hiding'		{ hiding_name }++qconid :: { HsName }+	: conid			{ $1 }+        | QCONID		{ uncurry (Qual . Module) $1 }++qtycon :: { HsName }+	: tycon			{ $1 }+	| QCONID		{ uncurry (Qual . Module) $1 }++conid :: { HsName }+	: CONID			{ UnQual $1 }++qconsym :: { HsName }+	: consym		{ $1 }+	| QCONSYM		{ uncurry (Qual . Module) $1 }++consym :: { HsName }+	: CONSYM		{ UnQual $1 }++qvarsym :: { HsName }+	: varsym		{ $1 }+	| qvarsym1		{ $1 }+{-+qvarsymm :: { HsName }+	: varsymm		{ $1 }+	| qvarsym1		{ $1 }+-}+varsym :: { HsName }+	: VARSYM		{ UnQual $1 }+	| '-'			{ minus_name }+	| '!'			{ pling_name }+        | '.'                   { period_name }+{-+varsymm :: { HsName } -- varsym not including '-'+	: VARSYM		{ UnQual $1 }+	| '!'			{ pling_name }+        | '.'                   { period_name }+-}+qvarsym1 :: { HsName }+	: QVARSYM		{ uncurry (Qual . Module) $1 }++literal :: { HsExp }+	: INT 			{ hsLit (HsInt (readInteger $1)) }+	| CHAR 			{ hsLit (HsChar $1) }+	| STRING		{ hsLit (HsString $1) }+	| RATIONAL		{ hsLit (HsFrac (readRational $1)) }++srcloc :: { SrcLoc }	:	{% getSrcLoc }+{-+ +-----------------------------------------------------------------------------+Layout++-}+close :: { () }+	: vccurly		{ () } -- context popped in lexer.+	| error			{% popContext }++layout_off :: { () }	:	{% pushContext NoLayout }+layout_on  :: { () }	:	{% do { SrcLoc _ _ c <- getSrcLoc ;+					pushContext (Layout c)+				      }+				}+{-++-----------------------------------------------------------------------------+Miscellaneous (mostly renamings)++-}+modid :: { Module }+	: CONID			{ Module $1 }++tyconorcls :: { HsName }+	: conid			{ $1 }++tycon :: { HsName }+	: conid			{ $1 }++qtyconorcls :: { HsName }+	: qtycon		{ $1 }++qtycls :: { HsName }+	: qtycon		{ $1 }++tyvar :: { HsName }+	: varid			{ $1 }+{-++-----------------------------------------------------------------------------++     Property declarations++-----------------------------------------------------------------------------++From MPJ's Tool0 Hugs98 parser.y file:++gendecl   : PROPERTY pLhs '=' exp	{$$ = gc4(ap(PROP,ap($2,ap($3,$4))));}+	  | PROPERTY error		{syntaxError("property decl");}+	  ;+pLhs	  : pLhs varid			{$$ = gc2(ap($1,$2));}+	  | CONID			{$$ = $1;}+	  | error			{syntaxError("property defn lhs");}+	  ;+qfier	  : QALL			{$$ = gc1(quantAll);}+	  | QEX				{$$ = gc1(quantEx);}+	  | QALLDEF			{$$ = gc1(quantAlldef);}+	  | QEXU			{$$ = gc1(quantExu);}+	  ;++-}++propdecl :: { HsDecl }+	: 'property' srcloc conid varids '=' exp  { hsProperty $2 $3 $4 $6 }++quant :: { HsQuantifier } +	: 'All'                          { hsPropForall } +        | 'Ex'                           { hsPropExists }+	| 'AllDef'                       { hsPropForallDefined }+	| 'ExU'                          { hsPropExistsUnique }++varids :: { [HsName] }+        : varid varids                   { $1 : $2 }+        |                                { [] }+++{-++-----------------------------------------------------------------------------++-}++{+happyError = parseError "parse error"+}
+ tools/property/parse/extras/Token.hs view
@@ -0,0 +1,165 @@+-- $Id: Token.hs,v 1.2 2001/07/25 22:53:06 hallgren Exp $++module Token(Token(..),+             IntKind(..),+             reserved_ids,+             reserved_ops,+             tab_length)++where+++data Token +    = VarId String+    | QVarId (String, String)+    | ConId String+    | QConId (String, String)+    | VarSym String+    | ConSym String+    | QVarSym (String, String)+    | QConSym (String, String)+    | QModId String -- special case hack for M.(,,,).  The token QModId+                    -- holds the M, and the '.' and the list/tupe constructors+                    -- follow tokenized.  Must be matched in the grammar.+		    -- This isn't used for M.[N], since that must parse as+		    -- M . [N], most likely ending in an error.+    | IntTok String+    | FloatTok String+    | Character Char+    | StringTok String+{-++Symbols++-}+    | LeftParen+    | RightParen+    | SemiColon+    | LeftCurly+    | RightCurly+    | VRightCurly			-- a virtual close brace+    | LeftSquare+    | RightSquare+    | Comma+    | Underscore+    | BackQuote+    | Period                            -- needed for properties+{-++Reserved operators++-}+    | DotDot+    | DoubleColon+    | Equals+    | Backslash+    | Bar+    | LeftArrow+    | RightArrow+    | At+    | Tilde+    | DoubleArrow+    | Minus+    | Exclamation+{-++Reserved Ids++-}+    | KW_As       +    | KW_Case     +    | KW_Class    +    | KW_Data     +    | KW_Default  +    | KW_Deriving +    | KW_Do       +    | KW_Else     +    | KW_Hiding+    | KW_If       +    | KW_Import   +    | KW_In       +    | KW_Infix    +    | KW_InfixL   +    | KW_InfixR   +    | KW_Instance +    | KW_Let      +    | KW_Module   +    | KW_NewType  +    | KW_Of       +    | KW_Then     +    | KW_Type     +    | KW_Where    +    | KW_Qualified+    | KW_Primitive+    -- Keywords for Properties+    | KW_Property+    | KW_QAll+    | KW_QExists+    | KW_QAllDef+    | KW_QExistsU +    | EOF+      deriving (Eq, Show)+++reserved_ops :: [(String, Token)]+reserved_ops+    = [+        ( "..", DotDot ),    +	( "::", DoubleColon ),+	( "=",  Equals ),    +	( "\\", Backslash ), +	( "|",  Bar ),       +	( "<-", LeftArrow ), +	( "->", RightArrow ),+	( "@",  At ),        +	( "~",  Tilde ),     +	( "=>", DoubleArrow ),+--	( "-",  Minus ),	-- ToDo: shouldn't be here+	( "!",  Exclamation )	-- ditto+      ]+++reserved_ids :: [(String, Token)]+reserved_ids+    = [+	( "as",        KW_As ),       +        ( "case",      KW_Case ),     +	( "class",     KW_Class ),    +	( "data",      KW_Data ),     +	( "default",   KW_Default ),  +	( "deriving",  KW_Deriving ), +	( "do",        KW_Do ),       +	( "else",      KW_Else ),     +	( "if",        KW_If ),       +	( "import",    KW_Import ),   +	( "in",        KW_In ),       +	( "infix",     KW_Infix ),    +	( "infixl",    KW_InfixL ),   +	( "infixr",    KW_InfixR ),   +	( "instance",  KW_Instance ), +	( "let",       KW_Let ),      +	( "module",    KW_Module ),   +	( "newtype",   KW_NewType ),  +	( "of",        KW_Of ),       +	( "then",      KW_Then ),     +	( "type",      KW_Type ),     +	( "where",     KW_Where ),    +	( "qualified", KW_Qualified ),+	( "hiding",    KW_Hiding ),+	( "primitive", KW_Primitive ),+        -- Keywords for Properties+        ( "property",  KW_Property ),+	( "All",       KW_QAll ),+        ( "Ex",        KW_QExists ),+        ( "AllDef",    KW_QAllDef ),+        ( "ExU",       KW_QExistsU )+      ]+++data IntKind+    = Decimal     (String, String)+    | Octal       (String, String)+    | Hexadecimal (String, String)+++tab_length = 8 :: Int
+ tools/property/parse2/LexerOptions.hs view
@@ -0,0 +1,11 @@+module LexerOptions where++data LexerFlags = Flags { plogic :: Bool } deriving (Eq,Read,Show)++lexerflags0 = Flags True++lexerOptions flags args =+  case args of+    "noplogic":args -> lexerOptions flags{plogic=False } args+    "plogic"  :args -> lexerOptions flags{plogic=True  } args+    _               -> (flags,args)
+ tools/property/parse2/Makefile view
@@ -0,0 +1,12 @@+TARGETS=Parser/PropParser.hs++RM=rm -f++all: $(TARGETS)+	@$(MAKE) -C ../../base/parse2 lexer++Parser/PropParser.hs: Parser/PropParser.y+	cd Parser; happy PropParser.y++clean:+	$(RM) -f $(TARGETS)
+ tools/property/parse2/Parser/PropParseUtil.hs view
@@ -0,0 +1,158 @@+{-+Utilities for the parser.++Author(s): Simon Marlow 1997, 1998;+           Emir Pasalic, Bill Harrison, Andrew Moran 2001+           Thomas Hallgren 2001, 2002, 2003+-}++module PropParseUtil(+    chkTypeLhs,        -- ([HsType],HsType) -> m ([HsType],HsType)+    splitTyConApp,     -- HsType -> m (HsName, [HsType])+    mkValDef,          -- HsExp -> SrcLoc -> HsRhs HsExp+                       --   -> [HsDecl] -> m HsDecl+    mkFunDef,          -- HsExp -> SrcLoc -> HsRhs HsExp+                       --   -> [HsDecl] -> m HsDecl+    mkFunDef',+    expToPat,          -- HsExp -> m HsPat+    hsName2modName)    -- HsName -> ModuleName++                       -- Monad m => ...+		       -- The monad is used for error handling only+where++--import HsAssoc+import PropSyntax+--import HsConstants(plus_name)+import SourceNames(fakeSN)+import HsName+import SourceNames+--import PropSyntaxUtil(isConE)+import PrettyPrint+import MUtils++-- The LHSs of data/newtype/class declaration is parsed like a ctype (c=>t),+-- so this additional check is needed to ensure that they are well formed.+chkTypeLhs ct@(ctx,t) =+  do (c,as) <- splitTyConApp t+     if all isTyVar as+       then return ct+       else fail "bad lhs in data/newtype/class declaration"+  where+    isTyVar (Typ (HsTyVar _)) = True+    isTyVar _ = False++--splitTyConApp :: HsType -> m (HsName, [HsType])+splitTyConApp t = split t []+    where+    --split :: HsType -> [HsType] -> m (HsName, [HsType])+    split (Typ (HsTyApp t u)) ts = split t (u:ts)+    split (Typ (HsTyCon t))   ts = return (t, ts)+    split _                   _+        = fail "illegal data/newtype declaration"++--mkValDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> m HsDecl+mkValDef lhs sloc (HsBody b) wheres = +    do { lpat <- expToPat lhs ;+	 return $ hsPatBind sloc lpat (HsBody b) wheres+       }+mkValDef lhs sloc (HsGuard gds) wheres = +    do { lpat <- expToPat lhs ;+	 return $ hsPatBind sloc lpat (HsGuard gds) wheres+       }++--mkFunDef :: HsExp -> SrcLoc -> HsRhs HsExp -> [HsDecl] -> m HsDecl+mkFunDef lhs sloc rhs wheres = +    do { (fnamePat, ps) <- getFundefPats lhs ; +	 case fnamePat of +         Pat (HsPId (HsVar nm)) ->+              return $ hsFunBind sloc [HsMatch sloc nm ps rhs  wheres]+         _                      ->+              fail $ "invalid function name in:\n\n" ++ pp lhs+       }++mkFunDef' (nm,ps) sloc rhs wheres =+    hsFunBind sloc [HsMatch sloc nm ps rhs wheres]++--getFundefPats :: HsExp -> m (HsPat, [HsPat])+getFundefPats (Exp pexp) = + case pexp of +   HsId (HsVar nm) -> return (hsPVar nm, [])+   HsApp l r ->  +     do { (pv, ps) <- getFundefPats l ;+          p        <- expToPat r ;+          return (pv, ps ++ [p])+	}+   HsInfixApp l (HsVar n) r -> +     do { lp  <- expToPat l ;+          rp  <- expToPat r ;+          return (hsPVar n, [lp, rp])+	}+   HsInfixApp l (HsCon n) r -> +     do { lp  <- expToPat l ;+          rp  <- expToPat r ;+          return (hsPCon n, [lp, rp])+	}+   HsParen e -> getFundefPats e+   _     -> fail $+	    "cannot use\n\n" ++ pp pexp +++	   "\n\nas a function definition pattern."++expToPat l@(Exp lhexp)  = +    case lhexp of +      HsId (HsVar n) -> return $ hsPVar n+      HsId (HsCon n) -> return $ hsPCon n+      HsLit s literal -> return $ hsPLit s literal+      HsNegApp s e   -> do p <- expToPat e+			   case p of+			     Pat (HsPLit s l) -> return (hsPNeg s l)+			     _ -> fail "only literals can be negated in patterns"+      HsLambda _ _   -> fail "lambdas not allowed in patterns."+      HsList es      -> do { ps <- sequence (map expToPat es) ;+			     return $ hsPList loc0 ps -- !! loc0+			   }+      HsTuple es     -> do { ps <- sequence (map expToPat es) ;+			     return $ hsPTuple loc0 ps -- !! loc0+			   }+      HsWildCard     -> return hsPWildCard+      HsIrrPat e     -> do { p <- expToPat e ; return $ hsPIrrPat p }+      HsAsPat nm e   -> do { p <- expToPat e ; return $ hsPAsPat nm p}+      HsApp (Exp (HsId (HsCon n))) r -> +                      do { rp <- expToPat r ;+			   return $ hsPApp n [rp]+			 }+      HsApp l r -> +                      do { lp <- expToPat l ;+                           rp <- expToPat r ;+                           case lp of +                           Pat (HsPApp n ps) ->+			        return $ hsPApp n (ps ++ [rp])+                           _                 ->+			        fail $+			        "Cannot use:\n\n" +++			        pp lhexp +++			        "\n\n as a pattern."+                          }+      HsInfixApp l (HsCon n) r -> +                       do { lp <- expToPat l ;+                            rp <- expToPat r ;+                            return $ hsPInfixApp lp n rp +			  }+      HsInfixApp ne (HsVar (SN op _)) ke | op==UnQual "+" -> -- n+k patterns!!!+		       do np <- expToPat ne+			  kp <- expToPat ke+			  case (np,kp) of+			    (Pat (HsPId (HsVar n)),Pat (HsPLit s l)) ->+                               return $ hsPSucc s n l+			    _ -> fail$ pp $ "Mailformed n+k pattern:"<+>lhexp+      HsParen e      -> hsPParen # expToPat e+      HsRecConstr s con fields ->+                       do { pfs <- mapM fieldToPat fields ;+			    return $ hsPRec con pfs+			  }+      HsExpTypeSig s e c t -> expToPat e -- warning: type signature ignored!+      _              ->+          fail $ pp $+	    sep [ppi "PropParseUtil.expToPat: not a valid/supported pattern:",+                 nest 4 lhexp]+    where fieldToPat (HsField f e) = HsField f # expToPat e
+ tools/property/parse2/Parser/PropParser.y view
@@ -0,0 +1,1210 @@+-- A copied and modified version of ../base/parse2/Parser/HsParser.y...+{+module PropParser (parse) where+ +import PropPosSyntax+--import SyntaxUtil+import HsTokens(Token(..))+import ParseMonad+import HsLexer+import LexUtil(readInteger, readRational)+import PropParseUtil+import PropPlogic as P+--import IOExts++}++%token+--- Reserved Ids ----------------------+	'as'		{ (Varid     ,($$,"as")) }+	'case'		{ (Reservedid,($$,"case")) }+	'class'		{ (Reservedid,($$,"class")) }+	'data'		{ (Reservedid,($$,"data")) }+	'default'	{ (Reservedid,($$,"default")) }+	'deriving'	{ (Reservedid,($$,"deriving")) }+	'do'		{ (Reservedid,($$,"do")) }+	'else'		{ (Reservedid,($$,"else")) }++        -- higher rank poly extension+        'forall'        { (Varid     ,($$,"forall")) }++	'hiding'	{ (Varid     ,($$,"hiding")) }+	'if'		{ (Reservedid,($$,"if")) }+	'import'	{ (Reservedid,($$,"import")) }+	'in'		{ (Reservedid,($$,"in")) }+	'infix'		{ (Reservedid,($$,"infix")) }+	'infixl'	{ (Reservedid,($$,"infixl")) }+	'infixr'	{ (Reservedid,($$,"infixr")) }+	'instance'	{ (Reservedid,($$,"instance")) }+	'let'		{ (Reservedid,($$,"let")) }+	'module'	{ (Reservedid,($$,"module")) }+	'newtype'	{ (Reservedid,($$,"newtype")) }+	'of'		{ (Reservedid,($$,"of")) }+	'then'		{ (Reservedid,($$,"then")) }+	'type'		{ (Reservedid,($$,"type")) }+	'where'		{ (Reservedid,($$,"where")) }+	'qualified'	{ (Varid     ,($$,"qualified")) }+	'_'		{ (Reservedid,($$,"_")) }+        '+'             { (Varsym    ,($$,"+")) }+	'primitive'     { (Varid     ,($$,"primitive")) } -- Hugs extension+	'foreign'       { (Varid     ,($$,"foreign")) } -- FFI extension++--- Additions for property syntax+        'assert'        { (Reservedid,($$,"assert")) }+        'property'      { (Reservedid,($$,"property")) }+        'All'           { (Conid     ,($$,"All")) }+        'Exist'         { (Conid     ,($$,"Exist")) }+        'Lfp'           { (Conid     ,($$,"Lfp")) }+        'Gfp'           { (Conid     ,($$,"Gfp")) }+        '==='           { (Varsym    ,($$,"===")) }+        '=/='           { (Varsym    ,($$,"=/=")) }+        '==>'           { (Varsym    ,($$,"==>")) }+        '<==>'          { (Varsym    ,($$,"<==>")) }+        ':::'           { (Consym    ,($$,":::")) }+        '-/'            { (Varsym    ,($$,"-/")) }+        '/\\'           { (Varsym    ,($$,"/\\")) }+        '\\/'           { (Varsym    ,($$,"\\/")) }+	'$'	        { (Varsym    ,($$,"$")) }++--- Symbols --------------------------+	'('	{ (Special,($$,"(")) }+	')'	{ (Special,($$,")")) }+	';'	{ (Special,($$,";")) }+	'{'	{ (Special,($$,"{")) }+	'}'	{ (Special,($$,"}")) }+	VLCURLY { (Layout ,($$,"{")) }	      -- a virtual open brace+	VRCURLY { (Layout ,($$,"}")) }	      -- a virtual close brace+	'['	{ (Special,($$,"[")) }+	']'	{ (Special,($$,"]")) }+  	','	{ (Special,($$,",")) }+	'`'	{ (Special,($$,"`")) }++        '.'     { (Varsym, ($$,"."))}  -- must be a token so it can matched in+	                               -- property quantifier expressions; it+                                       -- must be turned into an id when not+                                       -- matched thus, or used in a float.+++--- Reserved operators ----------------++	'..'	{ (Reservedop,($$,"..")) }+	':'	{ (Reservedop,($$,":")) }+	'::'	{ (Reservedop,($$,"::")) }+	'='	{ (Reservedop,($$,"=")) }+	'\\'	{ (Reservedop,($$,"\\")) }+	'|'	{ (Reservedop,($$,"|")) }+	'<-'	{ (Reservedop,($$,"<-")) }+	'->'	{ (Reservedop,($$,"->")) }+	'@'	{ (Reservedop,($$,"@")) }+	'~'	{ (Reservedop,($$,"~")) }+	'=>'	{ (Reservedop,($$,"=>")) }+	'!'	{ (Varsym    ,($$,"!")) }++--- Open token classes:+        VARID 	 { (Varid,$$) }+	QVARID 	 { (Qvarid,$$) }+	CONID	 { (Conid,$$) }+	QCONID   { (Qconid,$$) }+	'-'	 { (Varsym,($$,"-")) }+	VARSYM	 { (Varsym,$$) }+	CONSYM	 { (Consym,$$) }+	QVARSYM	 { (Qvarsym,$$) }+	QCONSYM  { (Qconsym,$$) }+	INT	 { (IntLit,$$) }+	RATIONAL { (FloatLit,$$) }+	CHAR	 { (CharLit,$$) }+	STRING   { (StringLit,$$) }++        BADTOKEN { $$ } -- This is reported as an unused terminal.+		        -- It is included to turn lexical errors into syntax+		        -- errors, rather than pattern match failures in +			-- the generated parser.++%monad { PM } { thenPM } { returnPM }+%lexer { lexer } { (GotEOF,_) }+%name parse+%tokentype { HToken }++-- Precedences, from lowest to highest+%right 'Gfp' 'Lfp' 'All' 'Exist'+%right '->' 'in' 'else'+%right '::'+%left '@'+%left '{'+%left '<==>' -- FIRST(qop)+%right '==>' -- FIRST(qop)+%left '/\\' '\\/' '-/' '===' '=/=' -- FIRST(qop)+%left ':::' -- FIRST(qop)+%left VARSYM '+' '-' QVARSYM CONSYM QCONSYM '`' '!' ':' '.' '$' -- FIRST(qop)+%left 'as' 'hiding' 'qualified' 'foreign' VARID CONID QCONID '(' '[' -- FIRST(atype)+%%+{-++-----------------------------------------------------------------------------+Module Header++-}+module :: { HsModuleR }+        : 'module' modid maybeexports 'where' body+			     { hsModule $1 $2 $3 $5 }+        | srcloc body	     { hsMainModule $1 $2 }++body :: { ([HsImportDecl], [HsDecl]) }+	:   '{' bodyaux '}'			{ $2 }+ 	| open  bodyaux close			{ $2 }++bodyaux :: { ([HsImportDecl], [HsDecl]) }+	: impdecls semis1 topdecls semis    { ($1, $3) }+	|                 topdecls semis    { ([], $1) }+	| impdecls                 semis    { ($1, []) }+	| {- empty -}                       { ([], []) }++{-+optsemi :: { () }+	: ';'				    { () }+	| {- empty -}		            { () }+-}++semis1 :: { () }+        : ';' semis1                    { () }+        | ';'                           { () }++semis :: { () }+        : ';' semis                     { () }+        | {- empty -}                   { () }++++{-++-----------------------------------------------------------------------------+The Export List++-}+maybeexports :: { Maybe [HsExportSpec] }+ 	:  exports				{ Just $1 }+ 	|  {- empty -}				{ Nothing }++exports :: { [HsExportSpec] }+	: '(' optcomma exportlist optcomma ')'		{ reverse $3 }+	| '(' ')'				{ [] }++optcomma :: { () }+	: ','					{ () }+	| {- empty -}				{ () }++exportlist :: { [HsExportSpec] }+ 	:  exportlist ',' export		{ $3 : $1 }+ 	|  export				{ [$1]  }++export :: { HsExportSpec }+ 	:  qvar				     { EntE (Var $1) }+ 	|  qtyconorcls			     { EntE (Abs $1) }+ 	|  qtyconorcls '(' '..' ')'	     { EntE (AllSubs $1) }+ 	|  qtyconorcls '(' ')'		     { EntE (ListSubs $1 []) }+ 	|  qtyconorcls '(' qcnames ')'	     { EntE (ListSubs $1 (reverse $3)) }+ 	|  'module' modid		     { ModuleE $2 }++qcnames :: { [HsIdent] }+ 	:  qcnames ',' qcname			{ $3 : $1 }+ 	|  qcname				{ [$1] }++qcname :: { HsIdent }+	:  qvar					{ HsVar $1 }+ 	|  qcon					{ HsCon $1 }+{-++-----------------------------------------------------------------------------+Import Declarations++-}+impdecls :: { [HsImportDecl] }+	: impdecls semis1 impdecl		{ $3 : $1 }+	| impdecl				{ [$1] }++impdecl :: { HsImportDecl }+	: 'import' optqualified modid maybeas maybeimpspec+ 		  		{ HsImportDecl $1 $3 $2 $4 $5 }++optqualified :: { Bool }+        : 'qualified'                            { True  }+        | {- empty -}				{ False }++maybeas :: { Maybe ModuleName }+        : 'as' modid                             { Just $2 }+        | {- empty -}				{ Nothing }++maybeimpspec :: { Maybe (Bool, [HsImportSpec]) }+	: impspec				{ Just $1 }+	| {- empty -}				{ Nothing }++impspec :: { (Bool, [HsImportSpec]) }+ 	: optimportlist  	          { (False, reverse $1) }+ 	| 'hiding' optimportlist          { (True,  reverse $2) }++optimportlist :: { [HsImportSpec] }+        : '(' optcomma ')'		  { [] }+	| '(' importlist optcomma ')'	  { $2 }+	      +importlist :: { [HsImportSpec] }+ 	:  importlist ',' import		{ $3 : $1 }+ 	|  import				{ [$1]  }++import :: { HsImportSpec }+ 	:  var				      { Var $1 }+ 	|  tyconorcls			      { Abs $1 }+ 	|  tyconorcls '(' '..' ')'	      { AllSubs $1 }+ 	|  tyconorcls '(' ')'		      { ListSubs $1 [] }+ 	|  tyconorcls '(' cnames ')'	      { ListSubs $1 (reverse $3) }++cnames :: { [HsIdent] }+ 	:  cnames ',' cname			{ $3 : $1 }+ 	|  cname				{ [$1]  }++cname :: { HsIdent }+	:  var					{ HsVar $1 }+ 	|  con					{ HsCon $1 }++{-++-----------------------------------------------------------------------------+Top-level declarations.++-}++topdecls :: { [HsDecl] }+	: topdecls semis1 topdecl     { foldl (flip funCons) $1 $3 }+	| topdecl		      { $1 }+++{-++-----------------------------------------------------------------------------+Fixity Declarations++checkPrec has been eliminated; fixities may now be negative => must be added+to the static check.++-}++fixitydecl :: { HsDecl }+ 	: infix prec ops   { hsInfixDecl (fst $1) (HsFixity (snd $1) $2) $3 }+	                +prec :: { Int }+	: {- empty -}		  { 9 }+	| INT		          { fromInteger (readInteger (snd $1)) }++infix :: { (SrcLoc,HsAssoc) }+	: 'infix'				{ ($1,HsAssocNone)  }+	| 'infixl'				{ ($1,HsAssocLeft)  }+	| 'infixr'				{ ($1,HsAssocRight) }++ops   :: { [HsIdent] }+	: op ',' ops				{ $1 : $3 }+	| op					{ [$1] }++{-++-----------------------------------------------------------------------------+Top-Level Declarations++Note: The report allows topdecls to be empty. This would result in another+shift/reduce-conflict, so we don't handle this case here, but in bodyaux.++-}++topdecl :: { [HsDecl] }+  -- Hugs compatibility (quick hack)+  : 'primitive' vars optimpent '::' type     { [hsPrimitiveBind $1 v $5|v<-$2] }+  | topdecl1	{ [$1] }++optimpent :: { Maybe String }+	  :        { Nothing }+	  | impent { Just $1 }++topdecl1 :: { HsDecl }+  : decl                                        { $1 }+  | 'type' simpletype '=' type                  { hsTypeDecl $1 $2 $4 }+  | 'data' ctyconparams '=' constrs deriving    { uncurry (hsDataDecl $1) $2 (reverse $4) $5 } +  | 'newtype' ctyconparams '=' constr deriving  {% chkNewtype $4 >> return (uncurry (hsNewTypeDecl $1) $2 $4 $5) }+  | 'class' ctyconparams optfundeps optcbody    { uncurry (hsClassDecl $1) $2 $3 $4 }+  | 'instance' ctype optibody                   { uncurry (hsInstDecl $1 Nothing) $2 $3 }+  | 'default' '(' opttypes ')'                  { hsDefaultDecl $1 $3 }++  -- Hugs compatibility+  | 'data' ctyconparams            { uncurry (hsPrimitiveTypeDecl $1) $2 }+  -- Old FFI+  | 'foreign' 'import' var '::' type          { hsPrimitiveBind $1 $3 $5 }+  -- FFI, see http://www.cse.unsw.edu.au/~chak/haskell/ffi/+  | 'foreign' 'import' callconv var '::' type { hsPrimitiveBind $1 $4 $6 }+  | 'foreign' 'import' callconv safety var '::' type { hsPrimitiveBind $1 $5 $7 }+  | 'foreign' 'import' callconv impent var '::' type { hsPrimitiveBind $1 $5 $7 }+  | 'foreign' 'import' callconv safety impent var '::' type { hsPrimitiveBind $1 $6 $8 }++callconv :: { HsName }+         : varid        { $1 }++safety   :: { HsName }+          : varid        { $1 }++impent 	 :: { String }+          : STRING       { snd $1 }++optfundeps :: { HsFunDeps HsName }+	   :			 	{ [] }+	   | '|' fundeps		{ $2 }++fundeps	   :: { HsFunDeps HsName }+	   : fundep			{ [$1] }+	   | fundep ',' fundeps		{ $1:$3 }++fundep	   :: { HsFunDep HsName }+	   : tyvars '->' tyvars		{ ($1,$3) }++tyvars	   :: { [HsName] }+	   :				{ [] }+	   | tyvar tyvars		{ $1:$2 }++decls :: { [HsDecl] }+	: decls1 semis                  { reverse $1 }+	| semis                         { [] }++decls1 :: { [HsDecl] }+	: decls1 semis1 decl		{ funCons $3 $1 }+	| decl				{ [$1] }+++decl :: { HsDecl }+        : gendecl                       { $1 }+        | valdef			{ $1 }+        -- Property declarations+	| assertion                     { $1 }+        | property_decl                 { $1 }++gendecl :: { HsDecl }+        : signdecl              { $1 }+        | fixitydecl            { $1 }++decllist :: { [HsDecl] }+	:  '{' decls '}'	{ $2 }+	| open decls close	{ $2 }++signdecl :: { HsDecl }+	: vars '::' ctype+	      { uncurry (hsTypeSig $2 (reverse $1)) $3 }+{-+++ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var+instead of qvar, we get another shift/reduce-conflict. Consider the+following programs:++   { (+) :: ... }          A "signdecl" where everything to the left of the+                           :: is parsed as "vars" which should allow only var++   { (+) x y  = ... }      A "valdef" where everything to the left of the+                           = is parsed as an "exp0" which (incorrectly+                           in this context) allows a "qvar", since "exp0"+                           is also used to parse patterns where "qvar" is+                           allowed++This leads to a shift/reduce-conflict. The parser must decide without too much+lookahead.  By allowing a qvar as the first thing in "vars" the parser shifts+(until it sees a "," or a "::") and doesn't get confused.  Without this,+deciding what to do with requires more lookahead.  So let's allow "qvar" in+"vars" and then check for ourselves afterwards that this didn't happen.++-}+vars	:: { [HsName] }+	: vars ',' var		{ $3 : $1 }+	| unqvar		{ [$1] }++unqvar	:: { HsName }+        : qvar			{% if isQualified $1+				   then fail "Qualified names not allowed here ."+				   else return $1+				}++{-++-----------------------------------------------------------------------------+Types++-}+type :: { HsType }+	: btype '->' type           { hsTyFun $1 $3 }+	| btype         %prec '->'  { $1 }+        -- higher rank poly extension: -------------------+        | 'forall' tyvars '.' ctype { uncurry (hsTyForall $2) $4 }++btype :: { HsType }+        : btype atype   %prec '->'  { hsTyApp $1 $2 }+        | atype                     { $1 }++atype :: { HsType }+	: gtycon			{ hsTyCon $1 }+	| tyvar				{ hsTyVar $1 }+	| '[' type ']'			{ hsTyApp (list_tycon $1) $2 }+	| '(' types ')'			{ case $2 of+					    [t] -> t+					    ts -> hsTyTuple $1 ts }++opttypes :: { [HsType] }+	 :			   { [] }+	 | types		   { $1 }+++types	:: { [HsType] }+	: type ',' types	   { $1 : $3 }+	| type	                   { [$1] }++gtycon :: { HsName }+	: qtycon			{ $1 }+	| '(' ')'			{ unit_tycon_name $1 }+	| '[' ']'			{ list_tycon_name $1 }+	| '(' '->' ')'	                { fun_tycon_name $1 }+	| '(' commas ')'		{ tuple_tycon_name $2 $1 }+{-++(Slightly edited) Comment from GHC's hsparser.y:+"context => type" vs  "type" is a problem, because you can't distinguish+between:++	foo :: (Baz a, Baz a)++	bar :: (Baz a, Baz a) => [a] -> [a] -> [a]++with one token of lookahead.  The HACK is to parse the context as a btype+(more specifically as a tuple type), then check that it has the right form+C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!++-}+ctype :: { ([HsType],HsType) }+	: context '=>' type      { ($1, $3) }+	| type		       { ([], $1) }++context :: { [HsType] }+	: btype		       { tupleTypeToContext $1 }+++simpletype :: { HsType }+	: tycon tyvars         { foldl1 hsTyApp (hsTyCon $1:map hsTyVar $2) }++ctyconparams :: { ([HsType], HsType) }+        : ctype                {% chkTypeLhs $1 }++{-+ctyconparams :: { ([HsType], [HsType]) }+--	: type '=>' tyconparams     { (reverse (tupleTypeToContext $1), $3) }+	: tyconparams               { ([], $1) }++-- Replacing tycon with gtycon as an experiment: /TH+tyconparams :: { [HsType] }+        : gtycon typarams           { hsTyCon $1 : reverse $2 }+--	| gtycon		    { [hsTyCon $1] }++typarams :: { [HsType] }+	: typarams tyvar            { hsTyVar $2 : $1 }+	|			    { [] }+-}+{-+ctybinding :: { ([HsType], HsName) }+	: ctyconparams  {% case snd $1 of+		             Typ (HsTyCon nm) -> return (fst $1,nm)+			     _ -> fail "Primitive types are not allowed to have parameters" }+-}+++--- Datatype declarations ------------------------------------------------------++constrs :: { [HsConDecl HsType [HsType]] }+	: constrs '|' constr		{ $3 : $1 }+	| constr			{ [$1] }++-- Constructor with (optional) existential quantification:+constr :: { HsConDecl HsType [HsType] }+	: srcloc existq plain_constr	           { $3 $1 $2 [] }+	| srcloc existq context '=>' plain_constr  { $5 $1 $2 $3 }++-- Extension for existentially quantified types (with GHC compatible syntax):+existq :: { [HsName] }+       :				   { [] }+       | 'forall' tyvars '.'               { $2 }++plain_constr :: { SrcLoc -> [HsName] -> [HsType] -> HsConDecl HsType [HsType] }+	: scontype	         { conD $1 }+	| sbtype conop sbtype    { conD ($2,[$1,$3]) }+	| con '{' fielddecls '}' { fconD $1 (reverse $3) }++scontype :: { (HsName, [HsBangType HsType]) }+	: btype			    {% do { (c, ts) <- splitTyConApp $1 ;+					    return (c, map HsUnBangedType ts)+					  }+				    }+	| scontype1		        { $1 }+        | '(' consym ')' satype satype  { ($2,[$4,$5]) }++scontype1 :: { (HsName, [HsBangType HsType]) }+	: btype '!' atype+	      {% do { (c, ts) <- splitTyConApp $1 ;+		      return (c, map HsUnBangedType ts ++ [HsBangedType $3])+		    }+	      }+	| scontype1 satype		+              { (fst $1, snd $1 ++ [$2] ) }+{-+satypes :: { [HsBangType HsType] }+	:				{ [] }+	| satype satypes		{ $1:$2 }+-}+satype :: { HsBangType HsType }+	: atype				{ HsUnBangedType $1 }+	| '!' atype			{ HsBangedType   $2 }++sbtype :: { HsBangType HsType }+	: btype				{ HsUnBangedType $1 }+	| '!' atype			{ HsBangedType   $2 }++fielddecls :: { [([HsName], HsBangType HsType)] }+	: fielddecls ',' fielddecl	{ $3 : $1 }+	| fielddecl			{ [$1] }++fielddecl :: { ([HsName], HsBangType HsType) }+	: vars '::' stype		{ (reverse $1, $3) }++stype :: { HsBangType HsType}+	: type				{ HsUnBangedType $1 }	+	| '!' atype			{ HsBangedType   $2 }++deriving :: { [HsName] }+	: {- empty -}			{ [] }+	| 'deriving' qtycls		{ [$2] }+	| 'deriving' '('          ')'	{ [] }+	| 'deriving' '(' dclasses ')'	{ reverse $3 }++dclasses :: { [HsName] }+	: dclasses ',' qtycls		{ $3 : $1 }+        | qtycls			{ [$1] }++--- Class declarations ---------------------------------------------------------++optcbody :: { [HsDecl] }+	: 'where'  '{' cdecls '}'		{ $3 }+	| 'where' open cdecls close		{ $3 }+	| {- empty -}				{ [] }++cdecls :: { [HsDecl] }+	:                                       { [] }+	| cdecls1                               { reverse $1 }++cdecls1 :: { [HsDecl] }+	: cdecl                                 { [$1] }+	| cdecls1 semis1 cdecl                     { funCons $3 $1 }++cdecl :: { HsDecl }+      : decl                                    { $1 }+         {- except that pattern bindings aren't allowed! -}+++--- Instance declarations ------------------------------------------------------++optibody :: { [HsDecl] }+	: 'where'  '{' idecls '}'	{ $3 }+	| 'where' open idecls close	{ $3 }+	| {- empty -}			{ [] }++idecls :: { [HsDecl] }+	:                                       { [] }+	| idecls1                               { reverse $1 }++idecls1 :: { [HsDecl] }+	: idecl                                 { [$1] }+	| idecls1 semis1 idecl                     { funCons $3 $1 }++idecl :: { HsDecl }+	: valdef	       	                { $1 }++{-++-----------------------------------------------------------------------------+Value definitions++-}++{-+valdef :: { HsDecl }+	: exp0 srcloc rhs optwheredecls+				    {% if isPatternExp $1 +                                       then mkValDef $1 $2 $3 $4+                                       else mkFunDef $1 $2 $3 $4+				    }+-}++valdef :: { HsDecl }+	: funlhs srcloc rhs optwheredecls   { mkFunDef' $1 $2 $3 $4 }+        | pat0 srcloc rhs optwheredecls { hsPatBind $2 $1 $3 $4 }++funlhs :: { (HsName,[HsPat]) }+        : qvar apats1               { ($1,$2) }+        | pat0 qvarop pat0          { ($2,[$1,$3]) }+        | '(' funlhs ')' apats1     { (fst $2,snd $2++$4) }+	              -- ^ Haskell 98 requires apats1 (at least one apat)++optwheredecls :: { [HsDecl] }+        : 'where' decllist          { $2 }+        | {- empty -}               { [] }++rhs	:: { HsRhs HsExp }+	: '=' exp		    { HsBody $2 }+	| gdrhss		    { HsGuard (reverse $1) }++gdrhss :: { [(SrcLoc, HsExp, HsExp)] }+	: gdrhss gdrhs		    { $2 : $1 }+	| gdrhs			    { [$1] }++gdrhs :: { (SrcLoc, HsExp, HsExp) }+	: '|' exp '=' exp    { ($1, $2, $4) }++{-++-----------------------------------------------------------------------------+Expressions++-}+exp   :: { HsExp }+	: exp0 '::' ctype      	{ hsExpTypeSig $2 $1 (fst $3) (snd $3) }+        | exp0	     %prec '::' { $1 }++exp0 :: { HsExp }+	: exp0 qop exp0     %prec VARSYM { hsInfixApp $1 $2 $3 }+	| '\\' apats '->' exp            { hsLambda $2 $4 }+  	| 'let' decllist 'in' exp	 { hsLet $2 $4 }+	| 'if' exp 'then' exp 'else' exp { hsIf $2 $4 $6 }+   	| 'case' exp 'of' altslist	 { hsCase $2 $4 } +	| '-' fexp			 { hsNegApp $1 $2 }+  	| 'do' stmtlist			 {% hsDo `fmap` atoms2Stmt $2 }+	| fexp				 { $1 }++fexp :: { HsExp }+	: fexp aexp			{ hsApp $1 $2 }+  	| aexp				{ $1 }++{-++Note: The first alternative of aexp is not neccessarily a record update, it+could be a labeled construction, too.+-}+aexp	:: { HsExp }+  	: aexp '{' fbinds '}'        { mkRecord $2 $1 (reverse $3) }+  	| aexp1			     { $1 }++aexp1	:: { HsExp }+	: qvar			     { hsEVar ($1 :: HsName) }+	| gcon			     { $1 }+  	| literal		     { uncurry hsLit $1 }+--	| '(' exp ')'		     { hsParen $2 }+	| '(' exps ')'		     { case $2 of+                                         [e] -> hsParen e+				         es -> hsTuple es }+	| '[' list ']'               { $2 }+	| '(' exp0 qop ')'	     { hsLeftSection $2 $3 }+	| '(' qopm exp0 ')'	     { hsRightSection $2 $3 }+{-+	| '(' qvar '=' ')'	     { undefined {- record update -} }+	| '(' qvar '=' exp ')'	     { undefined {- record update -} }+-}+	| qvar '@' aexp	             { hsAsPat $1 $3 }+	| '_'			     { hsWildCard }+	| '~' aexp1		     { hsIrrPat $2 }++commas :: { Int }+	: commas ','		     { $1 + 1 }+	| ','			     { 1 }++exps :: { [HsExp] }+	: exp ',' exps		     { $1 : $3 }+	| exp		             { [$1] }++{-++-----------------------------------------------------------------------------+List expressions++The rules below are little bit contorted to keep lexps left-recursive while+avoiding another shift/reduce-conflict.++-}+list :: { HsExp }+	: exp				{ hsList [$1] }+	| lexps 			{ hsList (reverse $1) }+	| exp '..'			{ hsEnumFrom $1 }+	| exp ',' exp '..' 		{ hsEnumFromThen $1 $3 }+	| exp '..' exp	 		{ hsEnumFromTo $1 $3 }+	| exp ',' exp '..' exp		{ hsEnumFromThenTo $1 $3 $5 }+	| exp '|' quals			+          {% hsListComp `fmap` atoms2Stmt (reverse $3 ++ [HsQualifierAtom $1]) }++lexps :: { [HsExp] }+	: lexps ',' exp 		{ $3 : $1 }+	| exp ',' exp			{ [$3,$1] }+{-++-----------------------------------------------------------------------------+List comprehensions++-}+quals :: { [HsStmtAtom HsExp HsPat [HsDecl] ] }+	: quals ',' qual		{ $3 : $1 }+	| qual				{ [$1] }++qual  :: { HsStmtAtom HsExp HsPat [HsDecl] }+	: exp0 '<-' exp	                {% do { p <- expToPat $1 ; +                                                return (HsGeneratorAtom $2 p $3)+					      }+					}+	| exp			  	{ HsQualifierAtom $1 }+  	| 'let' decllist		{ HsLetStmtAtom   $2 }++{-++-----------------------------------------------------------------------------+Case alternatives++-}+altslist :: { [HsAlt HsExp HsPat [HsDecl]] }+	: '{'   alts semis '}'	  { reverse $2 }+	| open  alts semis close  { reverse $2 }+++alts :: { [HsAlt HsExp HsPat [HsDecl]] }+	: alts semis1 alt			{ $3 : $1 }+	| alt					{ [$1] }++alt :: { HsAlt HsExp HsPat [HsDecl] }+	: pat0 srcloc rhscasealts { HsAlt $2 $1 $3 [] }+	      {-% do { p <- expToPat $1 ;+	              return (HsAlt $2 p $3 [])+		    }+	      -} +        | pat0 srcloc rhscasealts 'where' decllist { HsAlt $2 $1 $3 $5 }+	      {-% do { p <- expToPat $1 ;+		      return (HsAlt $2 p $3 $5)+		    }+	      -}++rhscasealts :: { HsRhs HsExp }+	: '->' exp		            { HsBody $2 }+	| gdcaserhss		            { HsGuard (reverse $1) }++gdcaserhss :: { [(SrcLoc, HsExp, HsExp)] }+	: gdcaserhss gdcaserhs		    { $2 : $1 }+	| gdcaserhs			    { [$1] }++gdcaserhs :: { (SrcLoc, HsExp, HsExp) }+	: '|' exp  '->' exp          { ($1, $2, $4) }++{-++-----------------------------------------------------------------------------+Statement sequences++-}+stmtlist :: { [HsStmtAtom HsExp HsPat [HsDecl]] }+	:   '{' stmts '}'	{ $2 }+	| open  stmts close	{ $2 }++stmts :: { [HsStmtAtom HsExp HsPat [HsDecl]] }+  	:  qual semis1 stmts  	      { $1 : $3 }+        | semis1 stmts                   { $2 }+        | qual			      { [$1] }+        | qual semis1		      { [$1] }++--- Record Field Update/Construction -------------------------------------------++fbinds :: { [HsField HsExp] }+	  :				{ [] }+	  | fbinds1			{ $1 }++fbinds1 :: { [HsField HsExp] }+	: fbinds1 ',' fbind		{ $3 : $1 }+	| fbind				{ [$1] }++fbind	:: { HsField HsExp }+	: qvar '=' exp			{ HsField $1 $3 }+--	| qvar				{ HsFieldBind $1 }++--- Patterns -------------------------------------------------------------------++pat :: { HsPat }+        : pat0                { $1 }+        | qvar '+' integer    { let (s,i) = $3 in hsPSucc s $1 i }++pat0 :: { HsPat }+	: pat10                   { $1 }+	| pat0 qconop pat10   { hsPInfixApp $1 $2 $3 }++pat10 :: { HsPat }+        : qcon apats1             { hsPApp $1 $2 } -- should be gcon...+	| '-' numlit		  { hsPNeg $1 (snd $2) }+        | apat                    { $1 }++apat :: { HsPat }+        : qvar                    { hsPVar $1 }+        | qvar '@' apat           { hsPAsPat $1 $3 }+        | qcon                    { hsPCon $1 } -- should be gcon...+	| '(' ')'                 { hsPCon (qunit $1) }+        | qcon '{' fpats '}'      { hsPRec $1 $3 }+        | literal                 { uncurry hsPLit $1 }+        | '_'                     { hsPWildCard }+	| '(' pat ')'             { hsPParen $2 }+	| '(' tpats ')'           { hsPTuple $1 $2 }+	| '[' lpats ']'           { hsPList $1 $2 }+        | '~' apat                { hsPIrrPat $2 }++apats1 :: { [HsPat] }+        : apat apats              { $1 : $2 }++apats :: { [HsPat] }+	:                         { [] }+	| apat apats              { $1 : $2 }++fpats :: { [HsField HsPat] }+        :                         { [] }+        | fpats1                  { $1 }++fpats1 :: { [HsField HsPat] }+        : fpat ',' fpats1         { $1 : $3 }+	| fpat                    { [$1] }++fpat :: { HsField HsPat }+        : qvar '=' pat            { HsField $1 $3 }++tpats :: { [HsPat] }+        : pat ',' tpats           { $1 : $3 }+        | pat ',' pat             { [$1, $3] }++lpats :: { [HsPat] }+        :                         { [] }+	| lpats1                  { $1 }++lpats1 :: { [HsPat] }+        : pat ',' lpats           { $1 : $3 }+        | pat                     { [$1] }++{-++-----------------------------------------------------------------------------+Variables, Constructors and Operators.++-}+gcon :: { HsExp }+	: '[' ']'		     { hsList [] }+        | tupcon		     { hsECon $1 }+  	| qcon			     { hsECon $1 }++tupcon :: { HsName }+        : '(' ')'		     { qunit $1 }+	| '(' commas ')'	     { qtuple $2 $1 }++var 	:: { HsName }+	: varid			{ $1 }+	| '(' varsym ')'	{ $2 }++qvar 	:: { HsName }+	: qvarid		{ $1 }+	| '(' qvarsym ')'	{ $2 }++con	:: { HsName }+	: conid			{ $1 }+	| '(' consym ')'        { $2 }++qcon	:: { HsName }+	: qconid		{ $1 }+	| '(' gconsym ')'	{ $2 }++varop	:: { HsName }+	: varsym		{ $1 }+	| '`' varid '`'		{ $2 }++qvarop :: { HsName }+	: qvarsym		{ $1 }+	| '`' qvarid '`'	{ $2 }++qvaropm :: { HsName }+	: qvarsymm		{ $1 }+	| '`' qvarid '`'	{ $2 }++conop :: { HsName }+	: consym		{ $1 }	+	| '`' conid '`'		{ $2 }++qconop :: { HsName }+	: gconsym		{ $1 }+	| '`' qconid '`'	{ $2 }++op	:: { HsIdent }+	: varop			{ hsVar $1 }+	| conop 		{ hsCon $1 }++qop	:: { HsIdent }+	: qvarop		{ hsVar $1 }+	| qconop		{ hsCon $1 }++gconsym :: { HsName }+	: qconsym		{ $1 }++qopm	:: { HsIdent }+	: qvaropm		{ hsVar $1 }+	| qconop		{ hsCon $1 }++qvarid :: { HsName }+	: varid			{ $1 }+	| QVARID		{ qualid $1 }++varid1 :: { HsName }+	: VARID			{ unqualid $1 }+	| 'as'			{ unqualid ($1,"as") }+	| 'qualified'           { unqualid ($1,"qualified") }+	| 'hiding'		{ unqualid ($1,"hiding") }+        | 'foreign'	        { unqualid ($1,"foreign") }+--      | 'primitive'	        { unqualid ($1,"primitive") }++varid :: { HsName }+        : varid1                { $1 }+        | 'forall'	        { unqualid ($1,"forall") }+    ++qconid :: { HsName }+	: conid			{ $1 }+        | QCONID		{ qualid $1 }++qtycon :: { HsName }+	: tycon			{ $1 }+	| QCONID		{ qualid $1 }++conid :: { HsName }+	: CONID			{ unqualid $1 }+        | 'Gfp'                 { unqualid ($1,"Gfp") }+        | 'Lfp'                 { unqualid ($1,"Lfp") }+        | 'All'                 { unqualid ($1,"All") }+        | 'Exist'               { unqualid ($1,"Exist") }++qconsym :: { HsName }+	: consym		{ $1 }+	| QCONSYM		{ qualid $1 }++consym :: { HsName }+	: CONSYM		{ unqualid $1 }+	| ':'			{ unqualid ($1,":") }+	 -- ':' should really be part fo gconsym...+        | ':::'                 { unqualid ($1,":::") }++qvarsym :: { HsName }+	: varsym		{ $1 }+	| qvarsym1		{ $1 }++qvarsymm :: { HsName }+	: varsymm		{ $1 }+	| qvarsym1		{ $1 }++varsym :: { HsName }+	: '-'			{ unqualid ($1,"-") }+	| varsymm		{ $1 }++varsymm :: { HsName } -- varsym not including '-'+	: VARSYM		{ unqualid $1 }+        | '+'                   { unqualid ($1,"+") }+	| '!'			{ unqualid ($1,"!") }+        | '.'                   { unqualid ($1,".") }+        | '$'                   { unqualid ($1,"$") }+        | '-/'                  { unqualid ($1,"-/") }+        | '/\\'                 { unqualid ($1,"/\\") }+        | '\\/'                 { unqualid ($1,"\\/") }+        | '==='                 { unqualid ($1,"===") }+        | '=/='                 { unqualid ($1,"=/=") }+        | '==>'                 { unqualid ($1,"==>") }+        | '<==>'                { unqualid ($1,"<==>") }++qvarsym1 :: { HsName }+	: QVARSYM		{ qualid $1 }++literal :: { (SrcLoc,HsLiteral) }+	: numlit		{ $1 }+	| CHAR 			{ (fst $1,HsChar (read (snd $1))) }+	| STRING		{ (fst $1,HsString (read (snd $1))) }++numlit :: { (SrcLoc,HsLiteral) }+        : integer      	{ $1 }+	| float      	{ $1 }++integer :: { (SrcLoc,HsLiteral) }+	: INT	       	{ let (s,l)=$1 in (s,HsInt (readInteger l)) }+++float :: { (SrcLoc,HsLiteral) }+	: RATIONAL	{ let (s,l)=$1 in (s,HsFrac (readRational l)) }++srcloc :: { SrcLoc }	:	{% getSrcLoc }++--- Layout ---------------------------------------------------------------------++open  :: { () }+       : VLCURLY		{ () }++close :: { () }+	: VRCURLY		{ () } -- context popped in lexer.+	| error			{% popContext }++--- Miscellaneous (mostly renamings) -------------------------------------------++modid :: { ModuleName }+	-- : CONID		{ Module (snd $1) }+	: qconid                {% hsName2modName $1 }++tyconorcls :: { HsName }+	: conid			{ $1 }++tycon :: { HsName }+	: conid			{ $1 }++qtyconorcls :: { HsName }+	: qtycon		{ $1 }++qtycls :: { HsName }+	: qtycon		{ $1 }++tyvar :: { HsName }+	: varid1		{ $1 }+{-++-----------------------------------------------------------------------------++     Property declarations++-----------------------------------------------------------------------------++From MPJ's Tool0 Hugs98 parser.y file:++gendecl   : PROPERTY pLhs '=' exp	{$$ = gc4(ap(PROP,ap($2,ap($3,$4))));}+	  | PROPERTY error		{syntaxError("property decl");}+	  ;+pLhs	  : pLhs varid			{$$ = gc2(ap($1,$2));}+	  | CONID			{$$ = $1;}+	  | error			{syntaxError("property defn lhs");}+	  ;+qfier	  : QALL			{$$ = gc1(quantAll);}+	  | QEX				{$$ = gc1(quantEx);}+	  | QALLDEF			{$$ = gc1(quantAlldef);}+	  | QEXU			{$$ = gc1(quantExu);}+	  ;++-}++assertion :: { HsDecl }+	: 'assert'           proposition      { hsAssertion $1 Nothing   $2 }+	| 'assert' conid '=' proposition      { hsAssertion $1 (Just $2) $4 }++proposition :: { Assertion }+        : prop                                      {% plogicAssertion $1 }++quantifier :: { Quantifier } +	: 'All'                          { All }+        | 'Exist'                        { Exist }++optctype :: { Maybe HsQualType }+	:                                { Nothing }+	| '::' ctype                     { Just (uncurry (:=>) $2) }++prop :: { Plogic }+        : quantifier typedvars '.' prop %prec 'All'+				        { quants $1 $2 $4 }+        | '-/' prop                     { Neg $2 }+        | prop '/\\' prop               { Op Conj $1 $3 }+        | prop '\\/' prop               { Op Disj $1 $3 }+        | prop '==>' prop               { Op Imp $1 $3 }+        | prop '<==>' prop              { Op Equiv $1 $3 }+        | pexp '===' pexp               { Equal $1 $3 }+        | pexp '=/=' pexp               { Neg (Equal $1 $3) }+        | pexp ':::' prop               { Has $1 $3 }+        | pqcon predargs                { App $1 $2 }+        | aprop                          { $1 }+        | prop '->' prop                 { arrow $1 $3 }+        | prop qconop prop %prec '->'    { InfixApp $1 $2 $3 }+        | 'Lfp' conid '.' prop %prec 'Lfp'  { Lfp $2 $4 }+        | 'Gfp' conid '.' prop %prec 'Gfp'  { Gfp $2 $4 }++aprop :: { Plogic }+        : pqcon                         { App $1 [] }+        | '[' ']'                       { Nil }+	| '!' aexp1                     { Lifted $2 }+        | '$' aprop                     { Strong $2 }+        | '(' props ')'                 { case $2 of+					    [f] -> Paren f+					    fs -> predTuple fs $1+                                        }+        | '{' '|' typedpats '|' prop '|' '}' { Comp $3 $5 }++pexp :: { HsExp }+        : '{' exp '}'                   { $2 }+        | qvar                          { hsEVar $1 }+--      | pqcon                         { hsECon $1 } -- hmm, error prone...+	| literal		        { uncurry hsLit $1 }++typedvars :: { [(HsName,Maybe HsQualType)] }+        : var optctype                  { [($1,$2)] }+        | var optctype ',' typedvars    { ($1,$2):$4 }++{-+pexps :: { [HsExp] }+        : pexp                          { [$1] }+        | pexp pexps                    { $1:$2 }+-}+property_decl :: { HsDecl }+        : 'property' conid ids '=' prop {% propDecl $1 $2 $3 $5 }++ids :: { [HsIdent] }+        :                                  { [] }+        | var ids                        { HsVar $1:$2 }+        | con ids                        { HsCon $1:$2 }++predargs :: { [PredArg HsExp Plogic] }+        : predarg                       { [$1] }+        | predarg predargs              { $1:$2 }++predarg :: { PredArg HsExp Plogic }+	: '{' exp '}'			{ Left $2 }+        | qvar				{ Left (hsEVar $1) }+	| literal		        { Left (uncurry hsLit $1) }+        | aprop			{ Right $1 }++typedpats :: { [(HsPat,Maybe HsQualType)] }+      : pat optctype			{ [($1,$2)] }+      | pat optctype ',' typedpats	{ ($1,$2):$4 }+++props :: { [Plogic] }+        : prop                      { [$1] }+        | prop ',' props         { $1:$3 }++-- In logical formulas, some special conids are reserved...+pqconid :: { HsName }+	: CONID			{ unqualid $1 }+        | QCONID		{ qualid $1 }+	| tupcon		{ $1 }++pqcon	:: { HsName }+	: pqconid		{ $1 }+	| '(' gconsym ')'	{ $2 }++----------------------------------------------------------------------------+{+predTuple fs pos = App (qtuple n pos)  (map Right fs)+  where n = length fs-1++conD (con,ts) s vs ctx = HsConDecl s vs ctx con ts+fconD con fs  s vs ctx  = HsRecDecl s vs ctx con fs++happyError = parseError "syntax error"++quants q [] p = p+quants q ((v,t):vts) p = P.Quant q v t (quants q vts p)+}
+ tools/property/parse2/Parser/PropPlogic.hs view
@@ -0,0 +1,71 @@+module PropPlogic where+import Prelude hiding (pred)+import PropPosSyntax(HsName,HsIdentI(..),HsExp,HsPat,HsQualType,hsPVar,+                     Assertion,Predicate,PredArg,PropOp,Quantifier)+import HasPropStruct+import MUtils+import Monad(mplus)++data Plogic+  = Quant Quantifier HsName (Maybe HsQualType) Plogic+  | App HsName [PredArg HsExp Plogic]+  | InfixApp Plogic HsName Plogic+  | Neg Plogic+  | Op PropOp Plogic Plogic+  | Equal HsExp HsExp+  | Has HsExp Plogic+  | Arrow Plogic Plogic+  | Lfp HsName Plogic+  | Gfp HsName Plogic+  | Nil+  | Lifted HsExp+  | Strong Plogic+  | Comp [(HsPat,Maybe HsQualType)] Plogic+  | Paren Plogic -- preserve parens to rewrite infix apps after parsing++-- A hack to give '->' higher precedence than ':::' in Plogic assertions:+Has e p1 `arrow` p2 = Has e (p1 `Arrow` p2)+p1 `arrow` p2 = p1 `Arrow` p2++plogicAssertion p = prop p++prop :: (Functor m,Monad m) => Plogic -> m Assertion+prop p =+  case p of+    Quant q n optt p -> quant q n optt # prop p+    App n args -> propApp n # plogicArgs args+    Neg p -> propNeg # prop p+    Op op p1 p2 -> propOp op # prop p1 <# prop p2+    Equal e1 e2 -> return (propEqual e1 e2)+    Has e p -> propHas e # pred p+    Paren p -> propParen # prop p+    _ -> fail "Bad Plogic assertion" -- !!!++plogicArgs args = mapM plogicArg args+plogicArg args = either (return . Left) (Right #. pred) args++propDecl loc c xs p = uncurry (hsPropDecl loc c) # pred' xs p++pred' [] p = (,) [] # pred p+pred' args p = ((,) args # pred p) `mplus` pred'' args p+  where +    pred'' args p =+      do HsVar x <- return (last args)+         (,) (init args) . predComp [(hsPVar x,Nothing)] # prop p++pred :: (Functor m,Monad m) => Plogic -> m Predicate+pred p =+  case p of+    App n args       -> predApp n # plogicArgs args+    Arrow p1 p2      -> predArrow # pred p1 <# pred p2+    InfixApp p1 i p2 -> predInfixApp # pred p1 <# return i <# pred p2+    Neg p            -> predNeg Nothing # pred p+    Op op p1 p2      -> predOp op Nothing # pred p1 <# pred p2+    Lfp i p          -> predLfp i # pred p+    Gfp i p          -> predGfp i # pred p+    Nil              -> return predNil+    Lifted e         -> return (predLifted e)+    Strong p         -> predStrong # pred p+    Comp tps p       -> predComp tps # prop p+    Paren p          -> predParen # pred p+    _                -> fail "Bad Plogic predicate"
+ tools/property/parse2/Parser/PropPosSyntax.hs view
@@ -0,0 +1,76 @@+module PropPosSyntax(module PropPosSyntax,module PosName,module Hs,SN) where+import PropSyntax as Hs hiding (ModuleName,HsName,Id{-,HsIdent,HsField(),HsImportDecl(),HsConDecl(),HsExportSpec,HsImportSpec-},hsTyTuple)+import qualified PropSyntax as Hs+import HsConstants as Hs(main_mod,tuple,mod_Prelude')+import qualified HsConstants as Hs+--import PrettyPrint+import SourceNames+import PosName+--import SpecialNames as Hs+import QualNames(isQual)+--import Entity()++pos i p = SN i p++type HsExp = HsExpI HsName+type HsPat = HsPatI HsName+type HsDecl = HsDeclI HsName+type HsType = HsTypeI HsName++type HsQualType = HsQualTypeI HsName+type Assertion = AssertionI HsName+type Predicate = PredicateI HsName+++type HsField = Hs.HsFieldI HsName+type HsImportDecl = Hs.HsImportDeclI ModuleName HsName+type HsConDecl = Hs.HsConDeclI HsName+type HsExportSpec = Hs.HsExportSpecI ModuleName HsName+type HsImportSpec = Hs.HsImportSpecI HsName+type HsModuleR = Hs.HsModuleI ModuleName HsName [HsDecl]++qualid (p,s) = pos (splitQualName (srcFile p) s) p++unqualid (p,s) = pos (Hs.UnQual s) p++qualify m n = pos (Hs.Qual m n)++--qualified_name = pos Hs.qualified_name++{-++The special syntax for function types, tuples and list should always refer+to the entities defined in the Prelude, even if the corresponding names are+not in scope. But the AST output from the parser can only refer to things that+are in scope, and things that have special representation in the AST.+Some type constructors currently do not have a special representation in+the AST, so to be able to refer to them we deviate from Haskell 98 by+including 'import qualified Prelude' in all modules and refering to these+entities by qualified names.+-}+unit_con_name        = qualify mod_Prelude' "()"+tuple_con_name arity = qualify mod_Prelude' $ tuple arity++unit_tycon_name = unit_con_name+list_tycon_name = qualify mod_Prelude' "[]"+fun_tycon_name = qualify mod_Prelude' "->"+tuple_tycon_name arity = tuple_con_name arity++list_tycon = Hs.hsTyCon . list_tycon_name :: Hs.SrcLoc -> HsType+tuple_tycon n = hsTyCon . tuple_tycon_name n :: SrcLoc -> HsType++qtuple n pos = qualify mod_Prelude' (tuple n) pos+qunit = qualify mod_Prelude' "()"++hsTyTuple p ts = foldl hsTyApp (tuple_tycon (length ts-1) p) ts++isQualified = isQual :: HsName -> Bool++tupleTypeToContext t = tupleTypeToContext' is_unit_tycon_name is_tuple_tycon_name t+is_tuple_tycon_name arity n = n==tuple_tycon_name arity undefined+is_unit_tycon_name n = n==unit_tycon_name undefined++-- An omitted module header is equivalent to module Main(main) where ...+hsMainModule loc body =+    hsModule loc (pos (main_mod (srcFile loc)) loc)+             (Just [exportVar (main_name loc)]) body+main_name = pos Hs.main_name
+ tools/property/parse2/PropLexer.hs view
@@ -0,0 +1,36 @@+module PropLexer(module PropLexer{-,LexerFlags(..)-}) where+--import LexerOptions+import HsLexerPass1(lexerPass0,lexerPass0',startPos)+import HsTokens++{-++This module defines the lexical analyser for the P-logic extension of Haskell.++Differences from the plain Haskell 98 lexical syntax:++  - The identifiers "assert" and "property" are reserved.+  - The contents of nested comments of the form {-P: ... -} are parsed as+    normal code, providing a convenient way to hide assertions and predicate+    declarations from standard Haskell impementations.+-}++pLexerPass0 plogic =+    if plogic+    then propLexerPass0+    else lexerPass0+  where+    propLexerPass0 = propLexerPass0' startPos+    propLexerPass0' pos = concatMap plogicTokens . lexerPass0' pos++    plogicTokens t@(Varid,ps@(_,s)) =+      case s of+	"assert"   -> [(Reservedid,ps)]+	"property" -> [(Reservedid,ps)]+	_          -> [t]+    plogicTokens t@(NestedComment,ps@(p,'{':'-':'P':':':s)) =+        propLexerPass0' p (adjust s)+    plogicTokens t = [t]++    -- Replace the delimiting "{-P:" and "-}" with the same amount of space+    -- to preserve layout.+    adjust s = "    "++reverse ("  "++drop 2 (reverse s))
+ tools/property/pfe/Attrs.hs view
@@ -0,0 +1,24 @@+module Attrs where+import List(isPrefixOf)++{-++Types for attributes. Both certificate servers and certificates have attributes.+-}+type Name = String -- Tag+type Value = String+type Attr = (Name,Value)+type Attrs = [Attr]++printAttrs :: Attrs->String+printAttrs = unlines . map printAttr++printAttr :: Attr->String+printAttr (name,value) = name++": "++value++{-++Certificate attributes called file or file/xxx are assumed to refer to files+that are required to validate a certificate. +-}+namesFile :: Name -> Bool+namesFile name = takeWhile (/='/') name=="file"+
+ tools/property/pfe/CertAttrs.hs view
@@ -0,0 +1,18 @@+module CertAttrs(module CertAttrs,Name,Value) where+import Attrs(Name,Value)++{-++Some of the attributes of a certificate server describe what user editable+attributes certificates created by that server contain. The type CertAttrs+is used to represent descriptions of these certificate attributes.+-}++type CertAttrs = [(Name,CertAttr)]++data AType = String | File | Nat | Bool deriving Show++data CertAttr = Attr { atype :: AType,+		       label :: String,+		        --required::Bool, +		        adefault::Maybe Value }+		deriving Show
+ tools/property/pfe/CertServers.hs view
@@ -0,0 +1,47 @@+module CertServers(+   CertServer(..),CertServers,readCertServers,+   Attr,Attrs,Name,readAttrs,parseAttrs,printAttrs,certFiles,lookupServer+ ) where++import Prelude hiding (readFile)+import AbstractIO+import Maybe(catMaybes,mapMaybe,listToMaybe)+import List(partition)+import MUtils++import Attrs+import ParseAttrs+import ParseCertAttrs++data CertServer = Server {serverName :: Name,+			  serverDir :: FilePath,+			  serverAttrs :: Attrs,+			  certAttrs :: CertAttrs }+		deriving Show++type CertServers = [CertServer]++--readCertServers :: FilePath -> IO CertServer+readCertServers certServerDir =+  collectWith (readServer certServerDir) =<< getDirectoryContents certServerDir++--readServer :: String -> String -> IO CertServer+readServer certServerDir name+ = do let serverRoot = certServerDir++name+          serverAttr = serverRoot `fileSep` "server.attr"+	  splitAttrs = partition ((=="attribute").fst)+      (certattrs,servattrs) <- splitAttrs # readAttrs serverAttr+      return Server{serverName = name,+		    serverDir = serverRoot,+		    serverAttrs = servattrs,+		    certAttrs = mapMaybe parseCertAttr (map snd certattrs)}+				-- Hmm. Errors are silently ignored!!++--collect       :: (a->IO b) -> [a] -> IO [b]+collectWith m xs = catMaybes # mapM (maybeM . m) xs++fileSep :: FilePath->FilePath->FilePath+fileSep dir file = dir ++ "/" ++ file++lookupServer :: CertServers -> Name -> Maybe CertServer+lookupServer servers ctype = listToMaybe [s|s<-servers,serverName s==ctype]
+ tools/property/pfe/Flags.ghc view
@@ -0,0 +1,2 @@+PfePropCmds.hs: -fno-monomorphism-restriction+PFE_Certs.hs: -fno-monomorphism-restriction
+ tools/property/pfe/OneLineAttrs.hs view
@@ -0,0 +1,58 @@+module OneLineAttrs(parseOneLineAttrs) where+import Monad+import Maybe+import Char+--import Attrs++{-++A parser for attribute descriptions like these two:++  name=hyp, type=string, label="Depends on", optional++  name=conc, type=string/assertion, label="Conclusion", required+-}++--type Attr  = (String, String) -- tag, value+--type Attrs = [Attr]++--parseOneLineAttrs :: String -> Maybe Attrs+parseOneLineAttrs = complete parseOneLineAttrs'++parseOneLineAttrs' = manySep comma parseOneLineAttr+comma s = [((),r)|(",",r)<-lex s]++parseOneLineAttr s =+  [((name,value),r)|(name,r1)<-lex s,+		    (value,r)<-parseValue r1]++parseValue s =+  [(value,r)|("=" ,r1)<-lex s,+	     (value,r)<-lexval r1]+  `orelse`+  [("",s)]++lexval s =+  case s' of+    [] -> []+    '"':_ -> reads s' -- string literal+    _ -> [span isAttr s']+  where+    s'=dropWhile isSpace s+    isAttr c = c/=',' && isPrint c++-- Parsing combinators for the ReadS type:++xs `orelse` ys = take 1 (xs++ys)++many p s = some p s `orelse` empty s+some p s = [(x:xs,r)|(x,r1)<-p s,(xs,r)<-many p r1]+empty s = [([],s)]++prefix p1 p2 s = [xr|(_,r1)<-p1 s,xr<-p2 r1]++someSep sep p s = [(x:xs,r)|(x,r1)<-p s,+                            (xs,r)<-many (prefix sep p) r1]++manySep sep p s = someSep sep p s `orelse` [([],s)]++complete p s = listToMaybe [x|(x,r)<-p s,("","")<-lex r]
+ tools/property/pfe/PFE_Certs.hs view
@@ -0,0 +1,93 @@+module PFE_Certs(module PFE_Certs,CertServers,CertServer(..)) where+import Prelude hiding (putStrLn,ioError,catch,writeFile)+import Maybe(fromMaybe)++import HsModule+import HasPropStruct+import HsPropStruct(PD(..))+import PFE0(projectDir,moduleInfoPath,getSubGraph)+import CertServers++import AbstractIO+import DirUtils(getModificationTimeMaybe)+import MUtils++type CertType = String+type CertName = String+data QCertName = QCertName ModuleName CertName deriving (Eq,Show,Read)++-- Extract the named assertions from the top-level of a module:+assertions mod =+  [(n,pa)|Just (HsAssertion s (Just n) pa)<-map propstruct (hsModDecls mod)]++getCertServers = getCertServers' =<< getProgramaticaDir++getCertServers' = readCertServers . certTypesDir++getProgramaticaDir =+  do pdir <- fromMaybe defaultPDir # maybeM (getEnv pDirVar)+     unlessM (doesDirectoryExist pdir) $+       fail $ "Didn't find the Programatica directory "++pdir+     let pdir' = if take 1 (reverse pdir) == "/" then pdir else pdir++"/"+     return pdir'++type CertStatus = Maybe (Bool,ClockTime) -- (valid?,when)+--certStatus :: ... => Module -> CertName -> m CertStatus+certStatus m cert =+    do optdir <- projectDir+       case optdir of+         Nothing -> return Nothing+	 Just dir ->+	   status # getModificationTimeMaybe (certValidWhenPath m cert dir)+		 <# getModificationTimeMaybe (certInvalidWhenPath m cert dir)+  where+    status optvalid optinvalid =+      case (optvalid,optinvalid) of+	(Just v,Just inv) -> if v>inv then Just (True,v) else Just (False,inv)+	(Just v,_) -> Just (True,v)+	(_,Just inv) -> Just (False,inv)+	_ -> Nothing++type CertInfo = (CertName,(Maybe Attrs,CertStatus))++--certInfo :: ... => Module -> CertName -> CertInfo+certInfo m cert =+  do optdir <- projectDir+     (,) cert # case optdir of+	         Nothing -> return (Nothing,Nothing)+                 Just dir -> (,) # certAttrs dir <# certStatus m cert+  where+    certAttrs dir = maybeM (readAttrs path)+      where path = certAttrsPath m cert dir++markValid m cert =+  do optdir <- projectDir+     case optdir of+       Just dir -> do now <- getClockTime+                      writeFile (certValidWhenPath m cert dir) (show now)+		      srcfiles <- map fst # getSubGraph (Just [m])+		      writeFile (certSrcListPath m cert dir) (unlines srcfiles)+       _ -> done++--optCertsDir = certsDir # projectDir++--------------------------------------------------------------------------------++certsDir dir = dir++"cert/" -- or just "cert/", or "evidence/"? (dir="hi")+certModuleDir m dir = certsDir dir++moduleInfoPath m+certDir m f dir = certModuleDir m dir++"/"++f+--certIconPath m f = certDir m f++"/icon.gif"+certAttrsPath m f dir = certDir m f dir++"/cert.attr"+--certTextPath m f dir = certDir m f dir++"/cert.txt"+certDiagnosticsPath m f dir = certDir m f dir++"/output.txt"+badCertIconPath pdir = pdir++"icons/smiley.sad.gif"+--certDatestampPath m = certDir m "when"+certValidWhenPath m c dir = certDir m c dir++"/valid"+certInvalidWhenPath m c dir = certDir m c dir++"/invalid"+certSrcListPath m c dir = certDir m c dir++"/srclist.txt"+-- Programatica directory:+pDirVar = "PROGRAMATICA"+certTypesDir pdir = pdir++"types/certificate/"++-- Suitable builtin default for the PacSoft servers:+defaultPDir = "/home/projects/pacsoft/tools/lib/Programatica/"
+ tools/property/pfe/ParseAttrs.hs view
@@ -0,0 +1,60 @@+module ParseAttrs(module ParseAttrs,module Attrs) where+import Char(isSpace)+import FileUtils(readFileNow)+import MUtils++import Attrs++{-+Read an attribute file.++ Attribute files use a textual file format for association lists.+ Each line in an attribute file may specify a binding of a tag+ string to a value string using a single colon to separate the+ two.  If the colon is omitted, then a value of "" is assumed.+ Leading whitespace at the beginning of each line and preceding+ the value (i.e., after the first, if any, colon) is ignored.+ Lines containing only whitespace, or in which the first+ non-whitespace character is a '#' are treated as comments.+ (Despite this, we do not intend attribute files to be a+ human-readable format under normal circumstances.)+--+ Here is a sample attribute file:+--+ # This is a comment+ + foo: your name here!+ date:today+ + # here is a line with no value ...+ set filec+ + foo:bar+ # if the same tag is used more than once, then+ # we simply get multiple attribute values with+ # the same tag.+ +-}++--readAttrs  :: FilePath -> IO Attrs+readAttrs path = parseAttrs # readFileNow path++type Line  = String++parseAttrs = map readAttr . filter (not . comment) . map trim . lines+    where +	  trim           :: Line -> Line+	  trim            = dropWhile isSpace++	  comment        :: Line -> Bool+	  comment l       = null l || (head l == '#')++	  readAttr       :: String -> Attr+	  readAttr l      = case span (':'/=) l of+			      (tag, (c:val)) -> (tag, trim val)+			      prop           -> prop++{-++certFiles returns the list of files found in an attribute set.+-}+certFiles attrs = [path|(name,path)<-attrs,namesFile name]
+ tools/property/pfe/ParseCertAttrs.hs view
@@ -0,0 +1,27 @@+module ParseCertAttrs(parseCertAttr,CertAttrs) where+import CertAttrs+import OneLineAttrs+import Monad(mplus)+import MUtils++parseCertAttr :: String -> Maybe (Name,CertAttr)+parseCertAttr s = certAttrs =<< parseOneLineAttrs s++certAttrs attrs = (,) # attr "name" <# certAttrsFields+  where+    certAttrsFields = Attr # atype <# label <# return adefault++    atype = atypeP =<< attr "type"+    label = attr "label" `mplus` attr "name"+    adefault = attr "default"++    atypeP s =+      case break (=='/') s of+	("string","/file") -> return File+	("string",_) -> return String+	("nat","") -> return Nat+	("bool","") -> return Bool+	_ -> fail $ "Unknown attribute type: "++s+	     -- Error message is lost when using the Maybe monad.++    attr a = lookup a attrs
+ tools/property/pfe/PfePropCmds.hs view
@@ -0,0 +1,193 @@+module PfePropCmds where+import Prelude hiding (writeFile,print,readFile,readIO)+import Monad(when)+import List(sort,isPrefixOf)+import Maybe(fromJust,mapMaybe)+import Sets++import PFE0(pput,allModules,preparseModule,findFile,moduleInfoPath,getSubGraph)+import PFE3(parseModule) --parseSourceFile,+--import PFE2(analyzeModules',pfe2info0)+import PfeParse(moduleArgs,moduleArg,qualId,parseQualId) --,just+import PFE_Certs(assertions) --certDir,certsDir,certModuleDir,certDatestampPath+import PfeDepCmds(depgraph,tdepgraph,ppOrig,depGraph)++import PrettyPrint+import AbstractIO+import DirUtils(optCreateDirectory)+--import FileUtils(updateFile)+import MUtils+import PfeParse++import HsModule+import HsModulePretty+import HsModuleMaps(seqEntSpec,mapDecls,mapModMN)+import HsIdent(getHSName)+import ToQC(moduleToQC)+import HasBaseName(getBaseName)+import NameMaps(mapNames)+import PFEdeps(tdepModules',tdefinedNames,isDefaultDecl,isInstDecl,splitDecls)+import SimpleGraphs(reachable)+--import DefinedNames(definedNames)+import TiNames(topName)+import TiClasses(filterDefs)+import TypedIds(IdTy(Assertion))++pfePropCmds =+  [--("certscan",(moduleArgs certscan,"update certificate templates for assertions")),+   ("assertions",(moduleArgs assertionNames,"list names of named assertion")),+   ("asig",      (sequentArg asig,"write an assertion signature to stdout")),+   ("tasig",     (sequentArg tasig,"write an assertion signature to stdout")),+   ("adiff",     (diffArg adiff,"compare an assertion signature to a file")),+   ("tadiff",    (diffArg tadiff,"compare an assertion signature to a file")),+   ("qc",        (moduleArg toQC,"translate to QuickCheck")),+   ("slice",     (qualId slice,"extract a slice (needed part) of the program")),+   ("pqc",       (qualId prunedToQC,"pruned translation to QuickCheck")),+   ("qcslice",   (qualId qcslice,"translate a slice to QuickCheck"))]++diffArg f = args ("<path> "++sequentSyntax) (f @@ parseDiffArg)+parseDiffArg [] = fail "Was expecting a path and a sequent"+parseDiffArg (path:sequent) = (,) path # parseSequent sequent++sequentArg f = args sequentSyntax (f @@ parseSequent)+sequentSyntax = "<M.A> [ .. | <M1.A1 ... Mn.An> ]"++parseSequent [] = fail "At least a conclusion is required"+parseSequent (conc:hyps) = (,) # parseQualId conc <# parseHyps hyps+  where+    parseHyps [".."] = return Nothing -- everything+    parseHyps args = Just # mapM parseQualId args++asig = print @@ assertionSignature+tasig = print @@ tassertionSignature++assertionSignature = assertionSignature' depgraph+tassertionSignature = assertionSignature' tdepgraph++assertionSignature' depgr (qid,_) =+  do (deps,(g,ids,used)) <- depgr [qid]+     return $ sort [(n,h)|n<-used,(m,(t,ds))<-deps,(dns,(_,h))<-ds,n `elem` dns]++adiff (path,sequent) =+  do old <- readIO =<< readFile path+     new <- assertionSignature sequent+     signatureDiff old new++tadiff (path,sequent) =+  do old <- readIO =<< readFile path+     new <- tassertionSignature sequent+     signatureDiff old new++signatureDiff [] [] = return ()+signatureDiff ns [] = pput $ "No longer depends on:"<+>ppOrigs (map fst ns)+signatureDiff [] ns = pput $ "New dependencies:"<+>ppOrigs (map fst ns)+signatureDiff allold@((n1,h1):old) allnew@((n2,h2):new) =+  case compare n1 n2 of+    LT -> do pput $ "No longer depends on:"<+>n1+             signatureDiff old allnew+    GT -> do pput $ "New dependency:"<+>ppOrig n2+             signatureDiff allold new+    EQ -> do when (h1/=h2) $ pput $ "Changes have been made to:"<+>ppOrig n1+				  -- <+>parens (h1<>"/="<>h2) -- debug+	     signatureDiff old new++ppOrigs = ppiFSeq . map ppOrig++assertionNames optms =+  do ms <- if null optms then allModules else return optms+     mapM_ assertions1 ms+  where+    assertions1 m =+      mapM_ (pput. (m<+>)) =<< (map fst . assertions # preparseModule m)++toQC = pputModuleToQC @@ parseModule++--bnParseModule m = apSnd baseNames # parseModule m ++pputModuleToQC = pput . bnModuleToQC+bnModuleToQC = moduleToQC . apSnd baseNames++baseNames = mapModMN getBaseName . mapNames getBaseName++prunedToQC q@(m,n) =+  do (t,deps) <- fromJust . lookup m # tdepModules' (Just [m])+     let g = depGraph [(d,fs)|(ds,(fs,hash))<-deps,d<-ds]+	 needed = reachable g [topName Nothing m n Assertion]+	 isNeeded = any (`elem` needed) . map getHSName . tdefinedNames True m+         keepNeeded = mapDecls (filterDefs isNeeded)+     pputModuleToQC . apSnd keepNeeded =<< parseModule m++slice = tslice' snd+qcslice = slice' bnModuleToQC++slice' = slice'' True depgraph+tslice' = slice'' False tdepgraph++slice'' allInst depgraph trans q@(m,n) =+  do ms <- map (fst.snd) # getSubGraph (Just [m])+     (_,(_,_,used)) <- depgraph [q]+     let needed = mkSet used+     optCreateDirectory "slice"+     mapM_ (writeModuleSlice allInst trans needed) ms++writeModuleSlice allInst trans needed m =+  unlessM (isPrefixOf "hi/libs/" # findFile m) $ -- skip Prelude & std libs+  do let path = "slice/"++moduleInfoPath m++".hs" -- !!!+     pput (m<+>"in"<+>path)+     writeFile path.pp.+       trans.apSnd (sliceModule needed isNeeded.mapDecls splitDecls)+        =<< parseModule m+  where+    isNeeded d = isDefaultDecl d || allInst && isInstDecl d || isNeeded' d+    isNeeded' = any (`elementOf` needed) . map getHSName . tdefinedNames allInst m++sliceModule needed isNeeded (HsModule s m es is ds) =+    HsModule s m (fmap sliceExports es) (sliceImports is) (sliceDecls ds)+  where+    sliceDecls = filterDefs isNeeded+    sliceExports = mapMaybe sliceExport+    sliceImports = map sliceImport++    sliceImport (HsImportDecl s m q as optspecs) =+      HsImportDecl s m q as $ fmap (apSnd sliceEnts) optspecs++    sliceExport e =+      case e of+        ModuleE m -> Just e+	EntE ent -> EntE # sliceEnt ent++    sliceEnts = mapMaybe sliceEnt+    sliceEnt e =+      case e of+	ListSubs i is -> ListSubs # keep i <# return is+	_ -> seqEntSpec (fmap keep e)++    keep n = if n `elementOf` needed+	     then Just n+	     else Nothing+++{-+certscan ms =+  do info <- analyzeModules' pfe2info0 (just ms)+     optCreateDirectory certsDir+     mapM_ (updateModuleAssertions info) =<< getCurrentModuleGraph+  where+    updateModuleAssertions info (src,(m,_)) =+      do srct <- getModificationTime src+	 let stampfile = certDatestampPath m+         optct <- getModificationTimeMaybe stampfile+	 when (srct `newerThan` optct) $+            do optCreateDirectory (certModuleDir m)+               scan+	       writeFile stampfile ""+      where+        scan =+          mapM_ updAssertionCert.assertions.snd =<<parseSourceFile info src++        updAssertionCert (n,pa) =+           do let dir=certDir m (pp n)+              optCreateDirectory dir+	      unchanged <- updateFile (dir++"/assert.txt") (pp pa)+	      unless unchanged $ epput $ "Updated:"<+>m<>"."<>n+-}
+ tools/property/ppfe.hs view
@@ -0,0 +1,10 @@++import PPfeMain(mainPFE)+import PPfeInstances+import PfeInteractive(pfeiAllCmds)+import PPfeCmds(ppfeCmds)+--import TraceIO(traceIO)++--main = traceIO main'++main = mainPFE (pfeiAllCmds ppfeCmds)
+ tools/property/syntax/HasPropStruct.hs view
@@ -0,0 +1,44 @@+module HasPropStruct where+import HsPropStruct++class HasPropStruct rec prop | rec->prop where+  proprec :: prop -> rec++class GetPropStruct rec prop | rec->prop where+  propstruct :: rec -> Maybe prop++hsAssertion loc n a = proprec $ HsAssertion loc n a+hsPropDecl loc n ns p = proprec $ HsPropDecl loc n ns p++quant q i t pa = proprec $ Quant q i t pa+propId i = proprec $ PropApp i [] []+propApp i es = tpropApp i [] es+tpropApp i ts es = proprec $ PropApp i ts es+propNeg pa = proprec $ PropNeg pa+propOp op pa1 pa2 = proprec $ PropOp op pa1 pa2+propConj x = propOp Conj x+propDisj x = propOp Disj x+propEqual e1 e2 = proprec $ PropEqual e1 e2+propHas e pp = proprec $ PropHas e pp+propParen pa = proprec $ PropParen pa+--propLambda i pa = proprec $ PropLambda i pa+--propLet i t e pa = proprec $ PropLet i t e pa++predId i = proprec $ PredApp i [] []+predApp i as = tpredApp i [] as+tpredApp i ts as = proprec $ PredApp i ts as+predArrow pp1 pp2 = proprec $ PredArrow pp1 pp2+predInfixApp pp1 i pp2 = proprec $ PredInfixApp pp1 i pp2+predNeg optt pa = proprec $ PredNeg optt pa+predOp op optt pa1 pa2 = proprec $ PredOp op optt pa1 pa2+predLfp i pp = proprec $ PredLfp i Nothing pp+predGfp i pp = proprec $ PredGfp i Nothing pp+predLfp' i t pp = proprec $ PredLfp i (Just t) pp+predGfp' i t pp = proprec $ PredGfp i (Just t) pp+predNil = proprec PredNil+predLifted e = proprec $ PredLifted e+predStrong pp = proprec $ PredStrong pp+predComp pts pa = proprec $ PredComp pts pa+predParen pp = proprec $ PredParen pp++predNil :: HasPropStruct r (PP i e p t pa pp) => r
+ tools/property/syntax/PropSyntax.hs view
@@ -0,0 +1,5 @@++module PropSyntax (module P) where++import PropSyntaxStruct as P+import PropSyntaxRec as P
+ tools/property/syntax/PropSyntaxRec.hs view
@@ -0,0 +1,119 @@++module PropSyntaxRec(+  module PropSyntaxRec,+  module HasBaseStruct,+  module HasPropStruct,+  module Syntax+ ) where++import List+import PropSyntaxStruct+import HasBaseStruct+import HasPropStruct+import PrettyPrint+--import SrcLoc+import SpecialNames+--import ToHaskell(toHaskell)+-- Some things from the base syntax are reused unchanged:+import Syntax(HsPatI(..),+              HsTypeI(..),HsKind(..),Rec(..),HsModuleI(..),+	      HsName,ModuleName(..),Id,HsIdentI(..),HsFieldI(..),+	      hsModule,tupleTypeToContext',hsVar,hsCon)+++-- Tie the recursive knots+newtype HsDeclI i = Dec {unDec::PropDecl i} deriving (Eq, Show)+newtype AssertionI i = PA {unPA::PropPA i} deriving (Eq, Show)+newtype PredicateI i = PP {unPP::PropPP i} deriving (Eq, Show)+newtype HsExpI i  = Exp {unExp::PropExp  i} deriving (Eq, Show)++-- Recursion:+instance Rec (HsDeclI i)    (PropDecl i) where rec=Dec; struct=unDec+instance Rec (AssertionI i) (PropPA i)   where rec=PA; struct=unPA+instance Rec (PredicateI i) (PropPP i)   where rec=PP; struct=unPP+instance Rec (HsExpI  i) (PropExp  i) where rec=Exp; struct=unExp++instance HasPropStruct (HsDeclI i) (PD i (AssertionI i) (PredicateI i))+   where proprec=rec . Prop+instance HasPropStruct (AssertionI i) (PropPA i)   where proprec=rec+instance HasPropStruct (PredicateI i) (PropPP i)   where proprec=rec+instance HasPropStruct (HsExpI  i)    (PropExp  i) where proprec=rec++instance GetPropStruct (HsDeclI i) (PD i (AssertionI i) (PredicateI i)) where+  propstruct = propstruct . struct++-- Structure:+type HsQualTypeI i = Q [HsTypeI i] (HsTypeI i)++type PropDecl i =+  PropDI i (HsExpI i) (HsPatI i) [HsDeclI i] (HsTypeI i) [HsTypeI i] (HsTypeI i) (AssertionI i) (PredicateI i)+type PropPA i = PA i (HsExpI i) (HsQualTypeI i) (AssertionI i) (PredicateI i)+type PropPP i = PP i (HsExpI i) (HsPatI i) (HsQualTypeI i) (AssertionI i) (PredicateI i)++type PropExp i = BaseExp i++-- Base structure:+type BaseDecl i = DI i (HsExpI i) (HsPatI i) [HsDeclI i] (HsTypeI i) [HsTypeI i] (HsTypeI i)+type BaseExp i = EI i (HsExpI i) (HsPatI i) [HsDeclI i] (HsTypeI i) [HsTypeI i]++{-+type BasePat i = PI i (HsPatI i)+-}++-- This makes all the convenience constructor functions for the base syntax+-- available also for the extended syntax:+instance HasBaseStruct (HsDeclI i) (BaseDecl i) where base = rec . base+instance GetBaseStruct (HsDeclI i) (BaseDecl i) where basestruct = basestruct . struct+instance HasBaseStruct (HsExpI  i) (BaseExp  i) where base = rec+instance GetBaseStruct (HsExpI  i) (BaseExp  i) where basestruct = Just . struct++{-+instance HasBaseStruct (HsPatI  i) (BasePat  i) where base = rec . base+instance GetBaseStruct (HsPatI  i) (BasePat  i) where basestruct = basestruct . struct+-}++--type HsModuleR = HsModuleI HsName [HsDecl]+--type HsStmtR   = HsStmt HsExp HsPat [HsDecl]+--type HsAltR    = HsAlt HsExp HsPat [HsDecl]+++instance (IsSpecialName i,PrintableOp i) => Printable (HsDeclI i) where+    ppi = recprop ppi ({-property .-} ppi)+    wrap = recprop wrap ({-property .-} wrap)++    ppiList [] = empty+    ppiList ds = vcat $ (map (blankline . ppi) (init ds)) ++ [ppi (last ds)]++instance (IsSpecialName i,PrintableOp i) => Printable (HsExpI i) where+  ppi = ppi . struct; wrap = wrap . struct++instance (IsSpecialName i,PrintableOp i) => Printable (AssertionI i) where+  ppi = ppi . struct; wrap = wrap . struct++instance (IsSpecialName i,PrintableOp i) => Printable (PredicateI i) where+  ppi = ppi . struct; wrap = wrap . struct++instance HasSrcLoc (HsDeclI i) where srcLoc = srcLoc . struct++-- When consing a Decl onto a Decl list if the new Decl and the Decl on the+-- front of the list are for the same function, we can merge the Match lists+-- rather than just cons the new decl to the front of the list.+--funCons :: HsDecl -> [HsDecl] -> [HsDecl]+funCons (d1 @ (Dec (Base (HsFunBind s1 m1))))+	(ds @ ((d2 @ (Dec (Base (HsFunBind s2 m2)))) : more)) =+    if same m1 m2+    then hsFunBind s1 (m2 ++ m1) : more+    else d1 : ds+    where same ((HsMatch _ n1 _ _ _):_) ((HsMatch _ n2 _ _ _):_) = n1 == n2+	  same _                        _                        = False+funCons d ds = d : ds++--mkRecord :: HsExp -> [HsFieldUpdate HsExp] -> HsExp+mkRecord s (Exp (HsId (HsCon c))) fbinds = hsRecConstr s c fbinds+mkRecord s e                      fbinds = hsRecUpdate s e fbinds++--property d = if toHaskell then comment d else d++comment d = text "{-"+            $$ blankline d+            $$ text "-}"
+ tools/property/syntax/PropSyntaxStruct.hs view
@@ -0,0 +1,67 @@+module PropSyntaxStruct (module PropSyntaxStruct,module P) where++import BaseSyntax as P+import HsPropStruct as P+import HsPropMaps as P+import HsPropPretty+import HasBaseStruct +import HasPropStruct+import NameMaps+import PrettyPrint+import HsDeclPretty(ppContext)+import SrcLoc+import MUtils+import MapDeclM+import Recursive(struct)++data Q c t = c:=>t deriving (Eq,Show)++--type PropEI i e p ds t c = EI i e p ds t c+type PropDI i e p ds t c tp pa pp = Prop (DI i e p ds t c tp) (PD i pa pp)++data Prop b p = Base b | Prop p deriving (Eq,Show)++prop bf pf (Base b) = bf b+prop bf pf (Prop p) = pf p++recprop f g = prop f g . struct++mapProp bf pf = prop (Base . bf) (Prop . pf)+mapMProp bf pf = prop (fmap Base . bf) (fmap Prop . pf)+mapBase f = mapProp f id+isBase p = prop p (const False)+maybeBase f = prop f (const Nothing)+maybeProp = prop (const Nothing)+listBase f = prop f (const [])++seqProp (Base b) = Base # b+seqProp (Prop p) = Prop # p++instance HasBaseStruct (Prop b p) b where base = Base+instance GetBaseStruct (Prop b p) b where basestruct = maybeBase Just+instance HasPropStruct (Prop b p) p where proprec = Prop+instance GetPropStruct (Prop b p) p where propstruct = maybeProp Just++--------------------------------------------------------------------------------++instance (AccNames i b,AccNames i p) => AccNames i (Prop b p) where+  accNames f = prop (accNames f) (accNames f)++instance (AccNames i c,AccNames i t) => AccNames i (Q c t) where+  accNames f (c:=>t) = accNames f c . accNames f t++--------------------------------------------------------------------------------++instance (HasSrcLoc b,HasSrcLoc p) => HasSrcLoc (Prop b p) where+  srcLoc = prop srcLoc srcLoc++instance (MapDeclM b ds,MapDeclM p ds) => MapDeclM (Prop b p) ds where+    mapDeclM f = mapMProp (mapDeclM f) (mapDeclM f)++instance (Printable b,Printable p) => Printable (Prop b p) where+  ppi = prop ppi ppi+  wrap = prop wrap wrap++instance (Printable c,Printable t) => Printable (Q c t) where+  ppi (c:=>t) = ppContext (ppis c)<+>t+
+ tools/property/syntax/PropSyntaxUtil.hs view
@@ -0,0 +1,11 @@+module PropSyntaxUtil(module HsConstants,module PropSyntaxUtil) where++import HsConstants+import PropSyntax(hsTyCon,HsType)++-- Built-in type constructors/names++unit_tycon          = hsTyCon unit_tycon_name :: HsType+fun_tycon           = hsTyCon fun_tycon_name :: HsType+list_tycon          = hsTyCon list_tycon_name :: HsType+tuple_tycon i       = hsTyCon $ tuple_tycon_name i :: HsType
+ tools/property/syntax/Rewrite.hs view
@@ -0,0 +1,56 @@+-- $Id: Rewrite.hs,v 1.5 2001/10/19 04:10:12 hallgren Exp $++module Rewrite(rewriteModule, rewriteDecs, rewriteExp) where+{-+   This module supports rewriting of Haskell programs, mostly w.r.t., +   operator fixity and association.  In particular, the function rewriteExp+   takes an operator environment and reassociates the infix expressions +   as necessary.+-}++import PropSyntax+import PropSyntaxUtil+import HsExpStruct +import HsDeclStruct+import HsModule+import HsAssoc+import HsPropStruct++rewriteModule env (HsModule m ex im decls) =+    HsModule m ex im (rewriteDecs env decls)++rewriteDecs env ds = map (rewriteDec env') ds+  where+    env' = foldl extend env fs+    fs = fixitiesD [d | Dec d <- ds]+  {- To be Haskell 98 compliant, this function also needs to reset the+     fixities of all names defined in ds without a fixity declaration in ds to+     the default, infixl 9.+     Also, for local definitions, the fixity environment should be in scope+     not only in the declarations themselves, but also in the expression(s)+     where the declarations are in scope...+   -}++rewriteDec env (PropDec pd) = PropDec $ rewritePD rewriteExp env pd+rewriteDec env (Dec d)      = Dec $ rewriteAllD (rewriteExp env)+			                        (rewritePat env)+			                        (rewriteDecs env) d++rewriteExp env e = reassociateExp env e+rewritePat env p = reassociatePat env p++reassociateExp env (Exp e)     =+    Exp $ reassociateE isInfixApp hsInfixApp getOpAndArgs+                       reassociateExp reassociatePat rewriteDecs env e+reassociateExp env (PropExp e) = PropExp $ mapPE (reassociateExp env) id e++reassociatePat env (PropPat pp) = PropPat pp -- no rewriting needed here...+reassociatePat env (Pat p)     =+    Pat $ reassociateP isPInfixApp hsPInfixApp getPOpAndArgs+                       reassociatePat env p+++removeParens (Exp e)   = removeParensE Exp removeParens e++removeParens (PropExp e) = PropExp $ mapPE removeParens id e+
+ tools/property/syntax/ToHaskell.hs view
@@ -0,0 +1,17 @@+-- $Id: ToHaskell.hs,v 1.3 2002/03/25 22:40:41 hallgren Exp $++{-+   This would be more naturally an implicit parameter, but since it is used in+   a method instance of Printable, the class would need to be changed to have+   an implicit parameter, which would pollute the definition of+   PrettyPrint.hs.+-}+module ToHaskell (toHaskell) where++import CommandLine+++toHaskell :: Bool+toHaskell = let (flags, _, _) = commandLine+            in+                ToHaskell `elem` flags
+ tools/property/tests/Overload.hs view
@@ -0,0 +1,15 @@+module Overload where+import Maybe(isJust)++class ToBool a where toBool :: a -> Bool++instance ToBool (Maybe a) where toBool = maybeToBool++maybeToBool = isJust+++assert Trivial = {True} === {True}++assert Simple = {maybeToBool (Just 'a')} === {True}++assert Overloaded = {toBool (Just 'a')} === {True}
+ tools/property/tests/PreludeInt.hs view
@@ -0,0 +1,163 @@+module PreludeInt where++-- 32-bit Int:+newtype HInt = Int (Two (Two (Two (Two (Two Bit))))) deriving (Eq)+-- 4-bit Int:+--newtype HInt = Int (Two (Two Bit)) deriving (Eq)+-- 2-bit Int:+--newtype Int = Int (Two Bit) deriving (Eq{-,Show-})++data Two a = Two a a deriving (Eq)+data Bit = O | I deriving (Eq)++xor O O = O+xor I I = O+xor _ _ = I++--instance Show a=>Show (Two a) where+--  showsPrec n (Two a b) = showsPrec n a . showsPrec n b++class BitOps a where+  add :: Bit -> a -> a -> (a,Bit)+  one,zero :: a+--size :: a->Int+  msb :: a -> Bit+  invert :: a->a++m1 :: BitOps a => a+m1 = invert zero++instance BitOps Bit where+  add O O O = (O,O)+  add O O I = (I,O)+  add O I O = (I,O)+  add O I I = (O,I)+  add I O O = (I,O)+  add I O I = (O,I)+  add I I O = (O,I)+  add I I I = (I,I)++  zero = O+  one = I+--size _ = 1+  msb b = b++  invert O = I+  invert I = O++instance BitOps a => BitOps (Two a) where+  add c0 (Two x2 x1) (Two y2 y1) = (Two z2 z1,c2)+     where+       (z1,c1) = add c0 x1 y1+       (z2,c2) = add c1 x2 y2++  zero = Two zero zero+  one = Two zero one+--size ~(Two a _) = 2*size a+  msb (Two a _) = msb a+  invert (Two a b) = Two (invert a) (invert b)++instance BitOps HInt where+  add c0 (Int x) (Int y) = (Int z,c1)+     where (z,c1) = add c0 x y+  zero = Int zero+  one = Int one+--size (Int a) = size a+  msb (Int a) = msb a+  invert (Int a) = Int (invert a)++complement x = fst (add I zero (invert x))+add1 a b = fst (add O a b)++class BitOps a => Mul a where mul :: a->a->Two a++instance Mul Bit where+  mul O _ = Two O O+  mul I b = Two O b++instance Mul a => Mul (Two a) where+ mul (Two x2 x1) (Two y2 y1) = Two (Two z4 z3) (Two z2 z1)+  where+    Two z2a z1  = mul x1 y1+    Two z3a z2b = mul x1 y2+    Two z3b z2c = mul x2 y1+    Two z4a z3c = mul x2 y2+    (z2ab,c1)   = add O z2a z2b+    (z2,c2)     = add c1 z2ab z2c+    (z3ab,c3)   = add c2 z3a z3b+    (z3,c4)     = add c3 z3ab z3c+    (z4,O)      = add c4 z4a zero++{-+ -- (2*x2+x1)*(2*y2+y1) = 4*x2*y2 + 2*x2*y1 + 2*x1*y2 + x1*y1++ --  ab+     cd+ --------+     bd+    ad +    bc+   ac+-}++mul1 a b = c where Two _ c = mul a b+babs b =  if msb b==I then complement b else b+bsignum b = if msb b==I then m1 else if b==zero then zero else one++smul x = mul1 x+--smul a b = if msb a `xor` msb b ==I then complement p else p+--   where p = mul1 (babs a) (babs b)++instance Mul HInt where+ mul (Int a) (Int b) = Two zero (Int (smul a b))+{-+instance Num Bit where+  --fromInteger n = if even n then O else I+  (+) = add1+  negate = complement+  (*) = smul+  abs = babs++instance (Mul a,BitOps a,Num a) => Num (Two a) where+{-+  fromInteger n = Two b a+    where a = fromInteger n+          s = size a+          b = fromInteger (n `div` (2^s))+-}+  (+) = add1+  negate = complement+  (*) = smul+  abs = babs+  signum = bsignum+-}+{-P:+instance Num HInt where++  fromInteger = primFromInteger+  (+) = add1+  negate = complement+  (*) = smul+  abs = babs+  signum = bsignum+-}+++two,four,eight,ten :: HInt+two=add1 one one+four=add1 two two+eight=add1 four four+ten=add1 eight two++{-P:+primFromInteger i =  if primIntegerNeg i then complement d else d+  where d = fromDigits zero (primIntegerDigits i)+-}++fromDigits acc [] = acc+fromDigits acc (d:ds) =+  fromDigits ((ten `smul `acc) `add1` fromDigit zero d) ds++fromDigit acc [] = acc+fromDigit acc (b:bs) =+  fromDigit ((two `smul` acc) `add1` (if b then one else zero)) bs
+ tools/property/tests/PreludeProps.hs view
@@ -0,0 +1,252 @@+module PreludeProps where++{-P: {- -}+++property Univ      = Gfp X. X+property Undef     = Lfp X. X+property Absurdity = $Undef++assert undefined ::: Undef++property Finite = $ (Lfp P. ([] \/ Univ : $P))++property LeftUnit  op e = All x . {e `op` x} === x+property RightUnit op e = All x. {x `op` e} === x+property Assoc     op   = All x. All y. All z. {(x `op` y) `op` z} === {x `op` (y `op` z)}+property Monoid    op e = Assoc op /\ RightUnit op e /\ LeftUnit op e+++property Strict = Undef -> Undef++--assert P1 /\ P1++assert P1 = All x. All y. {const x y} === x+assert All f. All x. {const x . f} === {const x}+assert All f. All x. {f . const x} === {const (f x)}+assert sum === {foldr (+) 0}+assert {sum undefined} === undefined+assert {sum undefined} ::: Undef+assert {sum []} === 0+assert All x. All xs. {sum (x:xs)} === {x + sum xs} +assert All xs. All ys. {sum (xs ++ ys)} === {sum xs + sum ys}+assert {sum . map length} === {length . concat}+assert length === {sum . map (const 1)}+assert All xs. All ys. {length (xs ++ ys)} === {length xs + length ys}+assert {length undefined} === {undefined}+assert {length []} === 0+assert All x. All xs. {length (x:xs)} === {1 + length xs}+assert length === {foldl (\u us -> 1 + us) 0}++-- assert All xs. Finite xs ==> {length xs} =/= _|_+assert All xs. -/ Finite xs \/ -/ ({length xs} === {undefined})+assert All xs. -/ (Finite xs /\ {length xs} === {undefined})+assert All xs. -/ (Finite xs /\ {length xs} ::: Undef)++assert All xs. Finite xs ==> -/ {length xs} ::: Undef+assert All xs. {length xs} === 0 ==> xs === {[]}++assert All xs. -/ {length xs} === 0 \/ xs === {[]}+assert All xs. -/ {length xs} === 0 \/ xs ::: $[]+++assert All f. All xs. {length (map f xs)} === {length xs}+assert All xs. {length (reverse xs)} === {length xs}+assert All f. All a. {foldl f a undefined} === undefined+assert All f. All a. {foldl f a []} === a+assert All f. All a. All x. All xs. {foldl f a (x:xs)} === {foldl f (f a x) xs}+-- assert All f. All a. Monoid f a /\ (All x. {f x undefined} === undefined})+--               /\ (All y. {f undefined y} === undefomed) ===>+--              All xs. {foldr f a xs} === {foldl f a xs}++-- assert All f. All a. Monoid f a /\ (All x. {f x undefined} === undefined})+--               /\ (All y. {f undefined y} === undefomed) ===>+--              All x. All xs. {foldl f xs} === {f x (foldl f a xs)}++-- assert All p. {filter p} === {foldr q []+--    where q x us = if p x then x:us else us}+++assert All p. {filter p} === {let q x us = if p x then x:us else us +                              in foldr q []}++assert All p. {filter p undefined} === undefined+assert All p. {filter p []} === {[]}+assert All p. All xs. All ys. {filter p (xs ++ ys)} === +                                                {filter p xs ++ filter p ys}+assert All p. {filter p . concat} === {concat . map (filter p)}++-- assert All p. All x. All xs. case {p x} of +--  undefined   -> {filter p (x:xs)} === undefined+--  {True}      -> {filter p (x:xs)} === {x : filter p xs}+--  {False}     -> {filter p (x:xs) === {filter p xs}++-- assert All p. All x. All xs. {p x} ==> {filter p (x:xs)} === +--                                                          {x : filter p xs}++assert All p, x, xs. -/ ({p x} ::: $True) +                     \/ {filter p (x:xs)} === {x : filter p xs}++assert All p, x, xs. {p x} ::: $True ==>+                     {filter p (x:xs)} === {x : filter p xs}++assert All p. All x. All xs. ({p x} ::: False) +                            \/ {filter p (x:xs)} === {x : filter p xs}++assert All p. All x. All xs. -/ {p x} ::: $False +                            \/ {filter p (x:xs)} === {filter p xs}++assert All p. All x. All xs. {p x} ::: $False ==>+                             {filter p (x:xs)} === {filter p xs}++assert All p. All x. All xs. {p x} ::: True +                            \/ {filter p (x:xs)} === {filter p xs}++-- the above assertions use: +assert All x. (x ::: $True \/ x ::: False) /\ (x ::: True \/ x ::: $False)+++rev ys []       = ys+rev ys (u:us)   = rev (u:ys) us+    +assert All ys. {rev ys undefined} === undefined+assert All ys. {rev ys undefined} ::: Undef++assert All ys. {rev ys []} === ys+assert All x. All xs. All ys. {rev ys (x:xs)} === {rev (x:ys) xs}+assert All xs. All ys. {rev ys xs} === {reverse (xs ++ ys)}+assert All xs. {reverse xs} === {rev [] xs}++assert {head undefined} === {undefined}+assert {head undefined} ::: Undef++assert {head []} === undefined+assert {head []} ::: Undef++assert All x. All xs. {head (x:xs)} === x++assert {concat undefined} === undefined+assert {concat undefined} ::: Undef++assert {concat []} === {[]}+assert {concat []} ::: $[]++assert All xs. All xss. {concat (xs:xss)} === {xs ++ concat xss}+assert concat === {foldr (++) []}+assert {concat . concat} === {concat . map concat}++assert All f. All a. Monoid f a ==> {foldr f a . map (foldr f a)} === {foldr f a . concat}++assert All xss. All yss. {concat (xss ++ yss)} === {concat xss ++ concat yss}++assert Monoid (++) {[]}++property NonMono1 = Lfp P. {| x | -/ x ::: P |}++--property NonMono2 Q = Lfp P. {| x | -/ x ::: P /\ (Q P) |}++-- Pred a = a -> Prop ??+++------------------------++-- how to write "implies" and "iff" nicely?++-- foldr+assert All f . All a .                  {foldr f a} ::: Undef -> Undef+assert All f . All a .                  {foldr f a []} === a+assert All f . All a . All x . All xs . {foldr f a (x:xs)} === {f x (foldr f a xs)}++assert All f . All a . All xs . All ys . {foldr f a (xs ++ ys)} === {foldr f (foldr f a ys) xs}+assert All xs . All ys .                 {xs ++ ys} === {foldr (:) ys xs}++assert All f . All a .+    (Strict f /\ Monoid f a) ==>+      All xs . All ys . +                 {foldr f a (xs ++ ys)} === {f (foldr f a xs) (foldr f a ys)}++-- map+assert All f .                  {map f} ::: Undef -> Undef+assert All f .                  {map f []} ::: []+assert All f . All x . All xs . {map f (x:xs)} === {f x : map f xs}++assert All xs . All ys . All f . {map f (xs ++ ys)} === {map f xs ++ map f ys}+assert All xs .                  {map id xs} === xs+assert All f. All g .            {map (f . g)} === {map f . map g}+assert All xs . All f .          {reverse (map f xs)} === {map f (reverse xs)}+assert All xs . All f .          {map f xs} === {[f x | x<-xs]}+assert All f .                   {map f} === {foldr (\u us -> f u : us) []}+++-- id, (.)+assert All x . {id x} === x+assert All f . All g . All x . {f (g x)} === {(f . g) x}++assert LeftUnit (.) id+assert RightUnit (.) id+assert Assoc (.)+assert Monoid (.) id++assert Finite {[]}+++-- is there a nicer way to write iff?+-- +--assert All xs . All x . Finite {xs} iff Finite {x:xs}+--assert All xs . All f . Finite {xs} iff Finite {map f xs}+--assert All xs . Finite {xs} iff Finite {reverse xs}+--assert All xs . All ys . Finite {xs ++ ys} iff (Finite {xs} /\ Finite {ys})++assert All xs . All x .  (-/ Finite {xs} \/ Finite {x:xs}) /\ --+                         (-/ Finite {x:xs} \/ Finite {xs})++assert All xs . All x .  Finite {xs} <==> Finite {x:xs}++assert All xs . All f .  (-/ Finite {xs} \/ Finite {map f xs}) /\ +                         (-/ Finite {map f xs} \/ Finite {xs})++assert All xs . All f .  (Finite {xs} <==> Finite {map f xs})++assert All xs .          (-/ Finite {xs} \/ Finite {reverse xs}) /\ --+                         (-/ Finite {reverse xs} \/ Finite {xs})++assert All xs .          Finite {xs} <==> Finite {reverse xs}++assert All xs . All ys . (-/ Finite {xs ++ ys} \/ (Finite {xs} /\ Finite {ys})) /\ --+                         (-/ (Finite {xs} /\ Finite {ys}) \/ Finite {xs ++ ys})++assert All xs . All ys . Finite {xs ++ ys} <==> (Finite {xs} /\ Finite {ys})++++-- reverse+assert                  reverse ::: Undef -> Undef+assert                  {reverse []}     === {[]}+assert All x . All xs . {reverse (x:xs)} === {reverse xs ++ [x]}++assert All xs . {reverse xs} === {[]} ==> xs === {[]}++assert All xs . All ys . -/ (Finite xs) \/ {reverse (ys ++ xs)} === {reverse ys ++ reverse xs}+assert All xs . -/ Finite xs \/ {reverse (reverse xs)} === xs+assert All f . All xs . -/ Strict f \/ {head (map f xs)} === {f (head xs)}+assert All xs . {head (reverse xs)} === {last xs}+assert All xs . {last (reverse xs)} === {head xs}++assert All xs . All f . -/ Strict f                  \/ {last (map f xs)} === {f (last xs)}+assert All xs . All f . -/ (Finite xs /\ -/ xs:::[]) \/ {last (map f xs)} === {f (last xs)}++assert All xs . All f . Strict f ==> {last (map f xs)} === {f (last xs)}+assert All xs . All f . (Finite xs /\ -/ xs:::[]) ==> {last (map f xs)} === {f (last xs)}+++-- last+assert last ::: Undef -> Undef+assert last ::: [] -> Undef+assert All x . All xs . {last (x:xs)} === {case xs of { [] -> x; (u:us) -> last (u:us)}}+assert All x . {last [x]} === x+assert All x . All y . All ys . {last (x:y:ys)} === {last (y:ys)}+assert All xs . All ys . -/ Finite xs \/ (ys ::: [] /\ {last (xs ++ ys)} === {last ys})++assert All xs . All ys . Finite xs ==> (ys ::: $[] /\ {last (xs ++ ys)} === {last xs}) ++-}
+ tools/property/tests/Primes.hs view
@@ -0,0 +1,23 @@+module Primes where++primes = sieve [2..]++sieve [] = []+sieve (x:xs) = x:sieve [y|y<-xs, y `mod` x /= 0]++{-P:+assert PrimesProp = {-#cert:QcPrimesProp#-} {-#cert:ISayPrimesProp#-}+  All i . {i>=0}:::True ==> {primes!!i} ::: TwoOrOdd++property TwoOrOdd x = x===2 \/ True{odd x}++--two = 2++isTwoOrOdd x = x==2 || odd x++property SieveProp = {| n::Integer | {all isTwoOrOdd (sieve [2..n])} ::: True |}++assert PrimesProp100 = SieveProp 10 {-#cert:QcPrimesProp100#-} {-#cert:AlfaPrimesProp100#-}+assert PrimesPropAll = All n . SieveProp n++-}
+ tools/property/tests/RecPred.hs view
@@ -0,0 +1,5 @@+module RecPred where++property Univ = Gfp X . X++property P = [] \/ (Univ : P)
+ tools/property/tests/Simple1.hs view
@@ -0,0 +1,39 @@+module Simple1(C) where+++data List a   = Nil | Cons a (List a)++-- ?+data TestR a  = TestR { filed1 :: a, field2 :: [a] }++f x = let assert {x > 5} ::: True in 3++data C = Mk++++property Any  = Gfp X. X+property None = Lfp X. X++assert All x::Int. x ::: Any+assert Exist x::Int. x ::: None+assert All x::Int. x ::: !even+assert All x::Int. (x ::: !even) \/ x === 1++assert All x. {x::Int} ::: !even ==> -/ (x ::: !odd)+assert A = All x. Exist y. {x::Int} === y  {-#cert:certA#-} {-#cert:certA1#-}++assert B = All xs. {xs::[Int]} ::: !(\xs -> length xs < 3) ==> xs === {[1,2,3,4]}+assert C = All xs. {xs::[Int]} ::: !(\xs -> length xs < 100)++-- signatures in comprahensions don;t yet work in quick check+property AllEven = Gfp X. {| xs :: [Int] | ({xs::[Int]} ::: []) \/ (xs ::: (!even : X)) |}++-- assert D = {[2::Int,4,6,8,10,12]} ::: AllEven+assert E = All xs::[Int]. xs ::: AllEven+++assert F = All x::Int. All y. x ::: !(< y) ==> {x + 1} ::: !(<= y)+--assert G = ALl x::Int. x ::: !(const False) ==> undefined++-- assert F = All x::a. x === x
+ tools/property/tests/Test0Proofs.alfa view
@@ -0,0 +1,58 @@+--#include "alfa/Test0.alfa"++open Logic  use  cong++open Module_Prelude  use  List,  id,  map++open Module_Test0  use  Id1,  MapId1,  IF++proofId1 ::Id1+  =  \(t21::Star) ->  \(x::t21) -> Ref@_++proofMapId1 ::MapId1+  =  \(a::Star) ->+     \(xs::Module_Prelude.List a) ->+    case xs of {+      (Nil) -> Ref@_;+      (Cons x xs') ->+        cong+        (List a)+        (List a)+        (map a a (id a) xs')+        xs'+        ( \(h::PreludeFromAlfa.List a) -> Cons@_ x h)+        (proofMapId1 a xs');}++proofIF ::IF+  =  \(t83::Star) ->+    AndIntro ((f::t83 -> t83) ->+              (g::t83 -> t83) ->+              (===) (t83 -> t83) (Module_Prelude.id (t83 -> t83) (Module_Prelude.(..)+                                                                  t83+                                                                  t83+                                                                  t83+                                                                  f+                                                                  g)) (Module_Prelude.(..)+                                                                       t83+                                                                       t83+                                                                       t83+                                                                       (Module_Prelude.id (t83 ->+                                                                                           t83) f)+                                                                       (Module_Prelude.id (t83 ->+                                                                                           t83) g))) ((===) (t83 ->+                                                                                                             t83) (Module_Prelude.id (t83 ->+                                                                                                                                      t83) (Module_Prelude.id+                                                                                                                                            t83)) (Module_Prelude.id+                                                                                                                                                   t83)) ( \(f::t83 ->+                                                                                                                                                                t83) ->+                                                                                                                                                           \(g::t83 ->+                                                                                                                                                                t83) ->+                                                                                                                                                          Ref@_) Ref@_+{-# Alfa unfoldgoals off+brief on+hidetypeannots on+wide++nd+hiding on+ #-}
+ tools/property/tests/Test1Proofs.alfa view
@@ -0,0 +1,63 @@+--#include "alfa/Test1.alfa"++open Module_Prelude  use  List,  map,  id,  Bool,  (..),  not,  Int++open Module_Test1+ use  f,  IsId,  IdIsId,  g,  Id_g,  MapIdIsId,  NotNotIsId,+      Reflexive,  EqReflBool,  AllBools,  h,  tr,  fa,  T,  F,+      ExcludedMiddle++open Identity  use  Identical,  refl,  cong++proofIdIsId ::IdIsId+  =  \(t5::Star) ->+     \(x::t5) ->+    let ndgoal ::Identical t5 (id t5 x) x+          = refl t5 (id t5 x)+    in  ndgoal++proofMapIdIsId ::MapIdIsId+  =  \(t11::Star) ->+     \(x::Module_Prelude.List t11) ->+    let lemma (xs::List t11) ::+          Identical (Module_Prelude.List t11) (map t11 t11 (id t11) xs) xs+          = case xs of {+              (Nil) -> Ref@_;+              (Cons x' xs') ->+                cong+                (List t11)+                (Module_Prelude.List t11)+                (map t11 t11 (id t11) xs')+                xs'+                ( \(h::List t11) -> Cons@_ x' h)+                (lemma xs');}+    in  lemma x++proofId_g ::Id_g+  =  \(t16::Star) -> refl t16++proofNotNotIsId ::NotNotIsId+  =  \(x::Module_Prelude.Bool) ->+    case x of {+      (False) -> Ref@_;+      (True) -> Ref@_;}++proofEqReflBool ::EqReflBool+  =  \(x::Module_Prelude.Bool) ->+    case x of {+      (False) -> Ref@_;+      (True) -> Ref@_;}++proofExcludedMiddle ::ExcludedMiddle+  =  \(b::Module_Prelude.Bool) ->+    case b of {+      (False) -> orI1@_ Ref@_;+      (True) -> orI2@_ Ref@_;}+{-# Alfa unfoldgoals off+brief on+hidetypeannots on+wide++nd+hiding on+ #-}
+ tools/property/tests/test0.hs view
@@ -0,0 +1,174 @@+module Test0 where+import List(sort)+import Ix(inRange)+{-P:+import PreludeProps(Finite)+-}++{-P:++property ImpliesToo P Q = -/ P \/ Q++property IsIdentity' = IsIdentity++property IsIdentity f = All x . {f x} === x -- :: Pred(a->a)++property IsIdentityToo f = f === id -- :: Pred(a->a)++assert Id1 = id ::: IsIdentity  {-#cert:id1#-} {-#cert:id1b#-}+assert MapId1 = {map id} ::: IsIdentity  {-#cert:mapid1#-}+-}++idid = id . id++--f x = not (not x)+--f x = not x+f = not . not++testcase1 = print (f True,f False) {-#cert:testcase1#-}++{-P:+assert NotNotIsId = f ::: IsIdentity +{-#cert:notnot1#-} {-#cert:notnot2#-}++assert not ::: IsIdentity -- unprovable!!++--assert {case True of {True -> id}}:::IsIdentity++-- This style of definition is not supported in Dick's proposed syntax:+--property IsFunctor1 map = All f . All g . {map (f.g)} === {map f . map g}++property IsFunctor1 map = All f . All g . {map (f.g)}==={map f . map g}+property IsFunctor2 map = {map id} === id  -- :: Pred ((a->a)->(b->b))+property IsFunctor      = IsFunctor1 /\ IsFunctor2++assert MF = map ::: IsFunctor+assert IF = id ::: IsFunctor+assert CF = (.) ::: IsFunctor++property AndToo P Q = P /\ Q+property OrToo P Q = P \/ Q++property IsAssoc (*) = All x, y, z . {(x*y)*z} === {x*(y*z)}+property IsCommutative (*) = All x, y . {x*y} === {y*x}++assert PlusAssoc = {(+)::Int->Int->Int} ::: IsAssoc {-#cert:PlusAssoc#-}+assert PlusCommutes = {(+)::Int->Int->Int} ::: IsCommutative++assert PlusAssocFloat = {(+)::Float->Float->Float} ::: IsAssoc {-#cert:PlusAssocFloat#-}++property AC = IsAssoc /\ IsCommutative++assert PlusAC = {(+)::Int->Int->Int} ::: AC {-#cert:PlusAC#-}++--property WO Base pred = Lfp X . {| x | x ::: Base \/ {pred x}::: X |}++--property WO_Int = WO !(==0) {subtract (1::Int)}+-}+fac 0 = 1+fac n = n * fac(n-1)++property InRange r = !(inRange r)++testcase2 = putStr $ unlines [show (n,fac n)|n<-[0..10]] {-#cert:testcase2#-}++{-P:+property Pos x = x::: $ !(>=0)++assert FacPos = {fac::Int->Int} ::: Pos -> Pos {-#cert:FacPos#-}++property PosOp = Pos -> Pos -> Pos+assert PlusPos = {(+)::Int->Int->Int} ::: PosOp {-#cert:PlusPos#-}++--assert fac ::: WO_Int -> WO_Int+-}+x=True++{-P: {--}+property IsTrue = !(==True)+property IsTrueToo = True -- a lifted constructor+-- Are all these equivalent?+assert x==={True}+assert x:::True+assert x::: !(==True)+assert True x+assert x:::IsTrue+assert IsTrue x++--property Finite = Lfp Fin . {| xs | xs:::[] \/ xs::: Univ:Fin |}+--property Finite = Lfp Fin . [] \/ Univ:Fin+--property Infinite = Gfp Inf . {| xs | xs:::Univ:Inf |}+property Infinite = Gfp Inf . Univ:Inf++property Fix P = Lfp X . P X+--u = Univ++-- The predicate that is true for every value:+property Univ = Gfp U . U -- Ok?++assert {[1..10]::[Integer]}:::Finite+assert {[1..]::[Integer]}:::Infinite++assert {Just True} ::: Just True++property LeftUnit m = All x . {fst m x (snd m)} === x++property Eventually P =  Lfp X . ($P : Univ) \/ ($Univ : $X)++property Equal x y = x===y++--property Nub = Lfp Nub . {| x:xs::[a] | True {x `notElem` xs} /\ Nub xs |}++--property InList = Lfp R . {| (x,y:ys) | x === y \/ R {(x,ys)} |}++--property InList2 = Lfp R . {| y:ys,x | x === y \/ R ys x |}++--assert InList {(5, [1..10]::[Integer])}+--assert InList2 {[1..10]::[Integer]} 5+--assert Even1_10 = Exist x . x::: !even ==> x ::: InList2 {[1..10::Integer]}+--assert Even1_10 = Exist x . x::: !even ==> {(x,[1..10::Integer])} ::: InList++property Even = !even+assert ZeroIsEven = 0:::Even++property OldAllElems P = Lfp X . {| xs | xs:::[] \/ xs:::P:X |}+property AllElems P = Lfp X . [] \/ (P:X)+property Minimal ys y = AllElems (!(y<=)) ys+property Ordered = Lfp P . {| xs | xs:::[] \/ xs:::Minimal xs:P |}++xs = [1..60]++assert M = Minimal xs {1}++assert SortProp = All xs.{sort xs}:::Ordered {-#cert:SortProp#-}+assert SortProp2 = {sort::[Int]->[Int]}:::Univ->Ordered {-#cert:SortProp2#-}++assert Fst = All x::Maybe a . x==={Nothing} \/  Exist y . x==={Just y}+{-#cert:Fst#-}+assert Fst' = All x . x ::: (Nothing \/ Just Univ)++property SyntBug = Univ /\ Univ : Univ+property SyntaxBug = {| x | x:::Univ /\ x::: Univ:Univ |}++property Pair = (Univ , Univ)+--property Pair' = {| (x,y) | x:::Univ /\ y:::Univ |}+property Pair'' = (,) Univ Univ+property PosPair = (Pos,Pos)+property Unit = ()++property FiniteToo = $( Lfp P. [] \/ Univ : $P )++assert ExcludedMiddle = All b . b ::: (False \/ True) {-#cert:ExcludedMiddle#-}++property Returns x = {| m | m==={m>>return x} |}++assert RevLength = All xs . {length (reverse xs)} === {length xs}+assert RevSumInt = All xs::[Int] . {sum (reverse xs)} === {sum xs}+assert RevSum = All xs .+   IsCommutative {(+) `at` head xs} ==> {sum (reverse xs)} === {sum xs}++op `at` x = op `asTypeOf` optype x+  where optype :: a -> (a->a->a)+        optype = undefined++-}
+ tools/property/tests/test00.hs view
@@ -0,0 +1,14 @@+module Test00 where+++property IsIdentity = {| f::a->a | All x . {f x} === x |} -- :: Pred(a->a)++assert Id1 = f ::: IsIdentity  {-#cert:id1#-} {-#cert:id1b#-}++f x = x++assert Str = "ab" === "ab"  {-#cert:string1#-}+assert Int = 1 === 1  {-#cert:int1#-}+assert Plus = {1+1::Integer} === 2 {-#cert:plus1#-} +assert Plus2 = {1+1==(2::Integer)} ::: True {-#cert:plus2#-} +assert Sum = {sum [1..10]::Integer}===55 {-#cert:sum1#-} 
+ tools/property/tests/test1.hs view
@@ -0,0 +1,43 @@+module Test1 where++--id x = x++--f x = not (not x)+f = not . not++g,h :: a -> a+g x = x+h = g++property IsId = {| f::a->a | All x.  {f x}===x |}++--(x,y)=(id,id)++assert IdIsId = id ::: IsId  {-#cert:IdIsId#-}+assert Id_g = g ::: IsId  {-#cert:Id_g#-}+assert Id_g' = IsId g++assert MapIdIsId = {map id} ::: IsId  {-#cert:MapIdIsId#-}+--property P = P++assert NotNotIsId = f ::: IsId   {-#cert:NotNotIsId#-} {-#cert:NotNotIsId2#-}++property Reflexive = {| rel::a->a->a | All x . { x `rel` x } === {True} |}++assert EqReflBool = {(==)::Bool->Bool->Bool} ::: Reflexive+{-#cert:EqReflBool#-}++allElems :: (Bounded a,Enum a) => [a]+allElems = [minBound..maxBound]+--allElems = [fa,tr]+--all = [False,True]++tr = succ False+fa = pred True++assert AllBools = allElems==={[False,True]}  {-#cert:AllBools#-}+++property F = {|b|b==={False}|}+property T = {|b|b==={True}|}+assert ExcludedMiddle = All b . b ::: (F \/ T) {-#cert:ExcludedMiddle#-}
+ tools/property/tests/testPrelude.hs view
@@ -0,0 +1,116 @@+module Prelude where+import PreludeInt++type Int = HInt+data Integer+instance Eq Integer where (==) = primEqInteger++primEqInteger i1 i2 =+   primIntegerNeg i1==primIntegerNeg i2 &&+   primIntegerDigits i1==primIntegerDigits i2++foreign import primIntegerNeg :: Integer -> Bool+foreign import primIntegerDigits :: Integer -> [[Bool]]++foreign import primError :: String->a+error = primError+undefined = error "undefined"++--data Int+data Char+type String = [Char]++--instance Eq Int+--instance Num Int+instance Enum Int where+  succ x = x+1+  pred x = x-1+  fromEnum = id; toEnum = id+  enumFrom x = x:enumFrom (succ x)+  enumFromTo x y = enumFromThenTo x 1 y+  enumFromThen x y = x:enumFromThen (x+y) y+  enumFromThenTo x y z = if x<=y then enumUp x else enumDown x+    where enumUp x = if x<=z then x:enumUp (x+y) else []+          enumDown x = if x>=z then x:enumDown (x-y) else []++data Bool = False | True deriving (Eq,Enum,Bounded)+--data Maybe a = Nothing | Just a deriving (Eq)++data Prop+--type Pred a = a->Prop++class Eq a where+  (==),(/=) :: a -> a -> Bool+  x/=y = not (x==y)++data Ordering = LT | EQ | GT deriving (Eq)++class Ord a where+  compare :: a->a->Ordering+  (<=),(>=) :: a->a->Bool+  x>=y = compare x y/=LT+  x<=y = compare x y/=GT+  +class Bounded a where minBound,maxBound::a++instance Ord Int where+   compare x y = case signum (x-y) of+                   -1 -> LT+		   0 -> EQ+		   1 -> GT++data [] a = [] | a : [a] deriving (Eq,Ord)++map f = mapf+  where+   mapf [] = []+   mapf (x:xs) = f x:mapf xs++not False = True+not True = False++infixr 9 .+(f . g) x = f (g x)++infixr 0 $+f $ x = f x++class Eq a => Num a where+  (+),(-),(*) :: a -> a -> a+  fromInteger :: Integer -> a+  negate :: a->a+  abs,signum :: a->a+  a-b=a+negate b++subtract x y = y-x++id y = y+const x y = x+flip f x y = f y x -- Used by the type checker for sections, like (==0)++class Enum a where+  succ, pred :: a -> a+  toEnum :: Int -> a+  fromEnum :: a -> Int+  enumFrom :: a -> [a]+  enumFromThen,enumFromTo :: a -> a -> [a]+  enumFromThenTo :: a -> a -> a -> [a]++  succ             =  toEnum . (+1) . fromEnum+  pred             =  toEnum . (subtract 1) . fromEnum+  enumFrom x       =  map toEnum [fromEnum x ..]+  enumFromTo x y   =  map toEnum [fromEnum x .. fromEnum y]+  enumFromThen x y =  map toEnum [fromEnum x, fromEnum y ..]+  enumFromThenTo x y z = map toEnum [fromEnum x, fromEnum y .. fromEnum z]++data (,) a b = (,) a b deriving (Eq,Ord)+data (,,) a b c = (,,) a b c -- deriving (Eq)++fst (a,b) = a+snd (a,b) = b++infixr 3 &&+x&&y = if x then y else False++lexOrder EQ o = o+lexOrder o _ = o
+ tools/property/toy/Main.hs view
@@ -0,0 +1,18 @@+-- $Id: Main.hs,v 1.1 2001/03/19 17:55:45 moran Exp $++module Main where++import Syntax+import Translate+++nil = ExpId (Var "nil")+appendNil = ExpEval $+	    App (ExpEval $ App (ExpId (Var "append"))+		               (ExpId (Var "xs")))+                nil+	        ++appendNilUnit = Prop $ All (Var "xs") (Prop (appendNil `Equiv` nil))++main = print $ translateProp [] [] appendNilUnit
+ tools/property/toy/Syntax.hs view
@@ -0,0 +1,57 @@+-- $Id: Syntax.hs,v 1.1 2001/03/19 17:55:45 moran Exp $++module Syntax where+++type Name = String+++data Id+    = Var Name+    | Escape Name+      deriving (Eq, Show)++data E e v+    = App e e+    | Lambda [v] e+      deriving (Eq, Show)++data P id term prop+    = prop `And` prop+    | prop `Or` prop+    | prop `Implies` prop+    | prop `Iff` prop+    | term `Equiv` term+    | Exists id prop+    | All id prop+    | Truth+    | Falsehood+      deriving (Eq, Show)++-- Tie the knots++data Exp+    = ExpEval (E Exp Name)+    | ExpId Id+      deriving (Eq, Show)++data EscExp+    = EscExpEval (E EscExp Name)+    | EscExpId Id+      deriving (Eq, Show)++data Code e+    = Code e+      deriving (Eq, Show)++data Prop+    = Eval (E Prop Name)+    | Prop (P Id Exp Prop)+    | Term Exp+      deriving (Eq, Show)++data EscProp+    = EscEval (E EscProp Name)+    | EscProp (P Id (Code EscExp) EscProp)+    | EscTerm (Code EscExp)+      deriving (Eq, Show)
+ tools/property/toy/Translate.hs view
@@ -0,0 +1,60 @@+-- $Id: Translate.hs,v 1.1 2001/03/19 17:55:45 moran Exp $++module Translate where++import Syntax+import List((\\))++type Translator a b = [Name] -> [Name] -> a -> b+++translateProp :: Translator Prop EscProp+translateProp metas env (Eval p) =+    EscEval $ translateE translateProp metas env p+translateProp metas env (Prop p) =+    EscProp $ translateP (translateId Var) codeExp translateProp metas env p+	where codeExp metas env e = Code $ translateExp metas env e+translateProp metas env (Term e) =+    EscTerm $ Code $ translateExp metas env e++translateExp :: Translator Exp EscExp+translateExp metas env (ExpEval e) =+    EscExpEval $ translateE translateExp metas env e+translateExp metas env (ExpId v) =+    EscExpId $ translateId Escape metas env v+++translateId :: (Name -> Id) -> Translator Id Id+translateId meta metas env (Var v) =+    if v `elem` metas then meta v else Var v+translateId meta metas env v       = v+++translateE :: Translator ea eb -> Translator (E ea Name) (E eb Name)+translateE te metas env (App e f)     = App (te metas env e) (te metas env f)+translateE te metas env (Lambda vs e) = Lambda vs $+				        te (metas \\ vs) (env ++ vs) e+++translateP :: Translator Id Id -> Translator ta tb -> Translator pa pb ->+	      Translator (P Id ta pa) (P Id tb pb)+translateP ti tt tp metas env (p1 `And` p2)     =+    (tp metas env p1) `And` (tp metas env p2)+translateP ti tt tp metas env (p1 `Or` p2)      =+    (tp metas env p1) `Or` (tp metas env p2)+translateP ti tt tp metas env (p1 `Implies` p2) =+    (tp metas env p1) `Implies` (tp metas env p2)+translateP ti tt tp metas env (p1 `Iff` p2)     =+    (tp metas env p1) `Iff` (tp metas env p2)+translateP ti tt tp metas env (t1 `Equiv` t2)   =+    (tt metas env t1) `Equiv` (tt metas env t2)+translateP ti tt tp metas env (Exists i p)      =+    Exists (ti metas env i) (tp (nameOf i : metas) env p)+translateP ti tt tp metas env (All i p)         =+    All (ti metas env i) (tp (nameOf i : metas) env p)+translateP ti tt tp metas env Truth             = Truth+translateP ti tt tp metas env Falsehood         = Falsehood+++nameOf (Var n)    = n+nameOf (Escape n) = n
+ tools/property/transforms/Flags.ghc view
@@ -0,0 +1,2 @@+ToQC.hs: -fallow-undecidable-instances -fno-monomorphism-restriction+RemoveListCompProp.hs: -fallow-undecidable-instances
+ tools/property/transforms/MapDeclMProp.hs view
@@ -0,0 +1,11 @@+module MapDeclMProp where+import MapDeclM+import PropSyntax+import MapDeclMPropStruct() -- get the instances+import MapDeclMBaseStruct() -- get the instances++instance MapDeclM (HsDeclI i)    [HsDeclI i] where mapDeclM = std_mapDeclM+instance MapDeclM (HsExpI i)     [HsDeclI i] where mapDeclM = std_mapDeclM+instance MapDeclM (AssertionI i) [HsDeclI i] where mapDeclM = std_mapDeclM+instance MapDeclM (PredicateI i) [HsDeclI i] where mapDeclM = std_mapDeclM+
+ tools/property/transforms/MapDeclMPropStruct.hs view
@@ -0,0 +1,20 @@+module MapDeclMPropStruct where++import MapDeclM+import HsPropStruct+import HsPropMaps++-- we assume only "expressions" & "declarations" may contain declarations+instance (MapDeclM pa ds,MapDeclM pp ds) => MapDeclM (PD i pa pp) ds where+    mapDeclM f = seqPD . mapPD return m m+      where m x = mapDeclM f x++instance (MapDeclM e ds,MapDeclM pa ds,MapDeclM pp ds)+       => MapDeclM (PA i e t pa pp) ds where+    mapDeclM f = seqPA . mapPA return m return m m+      where m x = mapDeclM f x++instance (MapDeclM e ds,MapDeclM pa ds,MapDeclM pp ds)+       => MapDeclM (PP i e p t pa pp) ds where+    mapDeclM f = seqPP . mapPP return m return return m m+      where m x = mapDeclM f x
+ tools/property/transforms/RemoveListCompProp.hs view
@@ -0,0 +1,11 @@+module RemoveListCompProp(rmAllListComp) where+import RemoveListComp+import Substitute+import SubstituteProp+import Recursive+import PropSyntaxRec(HsExpI)+import TiNames(ValueId)+import TiPropInstances() -- HasDef [HsDeclI i] (HsDeclI i)++instance ValueId i => RmListComp i (HsExpI i) where+  rmListComp cm = rmListCompE cm . struct
+ tools/property/transforms/SimpPatMatchProp.hs view
@@ -0,0 +1,12 @@+module SimpPatMatchProp where+import SimpPatMatch+import Recursive(struct)+import PropSyntaxRec(HsExpI)+--import PropSyntaxStruct(prop)+import TiProp() -- HasDef [HsDeclI i] (HsDeclI i)+import PrettyPrint(PrintableOp)++instance (Eq i,PrintableOp i,+          HasSrcLoc i,ValueId i,HasIdTy n i,HasOrig i,HasOrig n)+      => SimpPatMatch i (HsExpI i) where+  simpPatMatch ids = simpPatMatchE ids . struct
+ tools/property/transforms/SubstituteProp.hs view
@@ -0,0 +1,13 @@+module SubstituteProp where+import Recursive+import Substitute+import SubstitutePropStruct+import SubstituteBaseStruct+import PropSyntaxRec(HsExpI,HsDeclI,PredicateI,AssertionI)++instance MapExp (HsExpI i) (HsDeclI i)    where mapExp = mapExpRec+instance MapExp (HsExpI i) (PredicateI i) where mapExp = mapExpRec+instance MapExp (HsExpI i) (AssertionI i) where mapExp = mapExpRec+instance MapExp (HsExpI i) (HsExpI i)     where mapExp = mapExpRec++instance Subst i (HsExpI i) where subst s = substE s . struct
+ tools/property/transforms/SubstitutePropStruct.hs view
@@ -0,0 +1,17 @@+module SubstitutePropStruct where+import Substitute+import HsPropStruct+import HsPropMaps+import PropSyntaxStruct(mapProp,Prop)++instance (MapExp e pa,MapExp e pp) => MapExp e (PD i pa pp) where+  mapExp f = mapPD id (mapExp f) (mapExp f)++instance (MapExp e pa,MapExp e pp) => MapExp e (PA i e t pa pp) where+  mapExp f = mapPA id f id (mapExp f) (mapExp f)++instance (MapExp e pa,MapExp e pp) => MapExp e (PP i e p t pa pp) where+  mapExp f = mapPP id f id id (mapExp f) (mapExp f)++instance (MapExp e b,MapExp e p) => MapExp e (Prop b p) where+  mapExp f = mapProp (mapExp f) (mapExp f)
+ tools/property/transforms/ToQC.hs view
@@ -0,0 +1,327 @@+module ToQC(moduleToQC) where++-- haskell syntax+import HsName+import HasBaseStruct+--import PrettyPrint(pp)+import HsExp(EI,mapEI,seqEI)+import HsPat(PI,isPVar)+import HsDecl(DI,HsMatchI(..),mapDI,seqDI)+import HsGuards(HsRhs(..))+import HsFields(HsFieldI(..))+import HsLiteral(HsLiteral(..))+import SrcLoc(loc0)++import WorkModule(inscpRel)+import Relations(applyRel)+--import Ents(Ent(..))+import TypedIds(IdTy(..),idTy)+import SourceNames(fakeSN)+import QualNames(getQualified)++-- property syntax+import PropSyntax as Prop hiding (quant)+import Syntax     as Hs+++-- utils+import List(nub)+import Maybe(isJust,fromJust)+import MUtils (( # ))+import StateM++++class Trans t e | t -> e where trans :: t -> e+++-- names of combinators+qc = Qual (PlainModule "QC") ++neg     = qc "not"+conj    = qc "/\\"+disj    = qc "\\/"+impl    = qc "==>"+equiv   = qc "<==>"+false   = qc "false"+true    = qc "true"+forAll  = qc "forAll"+exists  = qc "exists"+arrow   = qc "-=>"+nil     = Qual mod_Prelude "nil"+lft     = qc "!"+lfp     = qc "lfp"+gfp     = qc "gfp"+equal   = qc "==="+formula_type  = qc "F"++pneg     = qc "pNot"+pconj    = qc "^/\\"+pdisj    = qc "^\\/"+pimpl    = qc "^==>"+pequiv   = qc "^<==>"+++transOp Conj  = HsVar conj +transOp Disj  = HsVar disj+transOp Imp   = HsVar impl+transOp Equiv = HsVar equiv++transPredOp Conj  = HsVar pconj +transPredOp Disj  = HsVar pdisj+transPredOp Imp   = HsVar pimpl+transPredOp Equiv = HsVar pequiv+++predName y  +  | isConOp y = mapHsName ("%" ++) y+  | isTuple y = mapHsName (\s ->"pred_Tuple"++show (tupleArity s)) y+  | otherwise = mapHsName ("pred_" ++) y+  where+    isTuple y = case hsUnQual y of+		 '(':_ -> True+		 _ -> False++    tupleArity "()" = 0+    tupleArity s = 1+length (filter (==',') s)++assertName  = mapHsName ("assert_" ++)+++string (UnQual x) = hsLit loc0 (HsString x)+string _          = error "Qualified names not allowd in quantifiers."++f $$ x = hsApp f x++pInfixApp e1 op e2 = hsInfixApp (hsParen e1) op (hsParen e2)++class SplitType t' c t | t' -> t c where+  splitType :: t' -> (c,t)++instance SplitType (Q [c] t) [c] t where+  splitType (c :=> t) = (c,t)+++instance (Trans pa e, Trans pp e, Trans e' e, SplitType t' [c] t,+          HasBaseStruct e (EI HsName e p [d] t [c]), +          HasBaseStruct p (PI HsName p),+          HasBaseStruct t (TI HsName t))+  => Trans (PA HsName e' t' pa pp) e where+  trans (Quant All x t pa)      = quant forAll x t pa+  trans (Quant Exist x t pa)    = quant exists x t pa+--trans (PropId i)              = hsEVar (assertName i)+  trans (PropApp i ts es)       = foldl ($$) (hsEVar (predName i)) (map (either trans trans) es)+  trans (PropNeg pa)            = hsEVar neg $$ trans pa+  trans (PropOp op p1 p2)       = pInfixApp (trans p1) (transOp op) (trans p2)+  trans (PropEqual e1 e2)       = pInfixApp (trans e1) (HsVar equal) (trans e2)+  trans (PropHas e pp)          = hsParen (trans pp) $$ trans e+  trans (PropParen pa)          = hsParen (trans pa)+++quant name x t pa               = hsEVar name $$ string x $$ body+  where exp                     = hsLambda [hsPVar x] (trans pa)+        body                    = case t of +                                    Nothing -> exp+                                    Just t  -> hsExpTypeSig loc0 (hsParen exp) ctxt (hsTyFun ty (hsTyCon formula_type))+                                      where (ctxt,ty) = splitType t++++instance (Trans pa e, Trans pp e, Trans e' e,+          HasBaseStruct e (EI HsName e p [d] t [c]),  +          HasBaseStruct p (PI HsName p),+          GetBaseStruct p (PI HsName p),+          HasBaseStruct d (DI HsName e p [d] t [c] tp))+  => Trans (PP HsName e' p t1 pa pp) e where+--trans (PredId i)              = hsEVar (predName i)+  trans (PredApp i ts xs)       = foldl ($$) p (map (either trans trans) xs)+    where p                     = hsEVar (predName i)+  trans (PredArrow p1 p2)       = pInfixApp (trans p1) (HsVar arrow) (trans p2)+  trans (PredInfixApp p1 i p2)  = pInfixApp (trans p1) p (trans p2) +    where p                     = HsVar (predName i)+  trans (PredNeg oppt p)        = hsEVar pneg $$ trans p+  trans (PredOp op optt p1 p2)	= pInfixApp (trans p1) (transPredOp op) (trans p2)+  trans (PredLfp i _ pp)        = hsEVar lfp $$ hsLambda [hsPVar (predName i)] (trans pp)+  trans (PredGfp i _ pp)        = hsEVar gfp $$ hsLambda [hsPVar (predName i)] (trans pp)+  trans PredNil                 = hsEVar nil+  trans (PredLifted e)          = hsEVar lft $$ trans e+  trans (PredStrong pp)         = trans pp+  trans (PredComp ps pa) +    | allVars                   = hsLambda pats exp +    | otherwise                 = hsLet [hsFunBind loc0 ms] (hsEVar x)+    where allVars               = all isJust (map isPVar pats)+          (pats,tys)            = unzip ps+          exp                   = trans pa+          ms                    = [ HsMatch loc0 x pats (HsBody exp) []+                                  , HsMatch loc0 x (map und ps) (HsBody $ hsEVar false) []+                                  ]+          und _                 = hsPWildCard+          x                     = UnQual "it"+  trans (PredParen pp)          = hsParen (trans pp)  +++instance (HasBaseStruct e (EI HsName e p [d] t [c]), Trans d' d, Trans e' e) => Trans (EI HsName e' p [d'] t [c]) e where+  trans = base . mapEI id trans id (map trans) id id++instance (HasBaseStruct d (DI HsName e p [d] t [c] tp), Trans d' d, Trans e' e) => Trans (DI HsName e' p [d'] t [c] tp) d where+  trans = base . mapDI id trans id (map trans) id id id+++instance (Trans d' d, Trans e' e, Trans pa e, Trans pp e,+           HasBaseStruct d (DI HsName e p [d] t [c] tp),+           HasBaseStruct e (EI HsName e p [d] t [c]),+           GetBaseStruct e (EI HsName e p [d] t [c]),+           HasBaseStruct p (PI HsName p))+          => Trans (PropDI HsName e' p [d'] t [c] tp pa pp) d where+  trans = prop trans transPD+++-- PRE: all assertions are named++transPD :: (Trans pa e, Trans pp e, +            HasBaseStruct d (DI HsName e p [d] t [c] tp),+            HasBaseStruct e (EI HsName e p [d] t [c]),+            GetBaseStruct e (EI HsName e p [d] t [c]),+            HasBaseStruct p (PI HsName p))+        => PD HsName pa pp -> d+transPD (HsAssertion loc (Just i) pa) =+    hsPatBind loc (hsPVar (assertName i)) (HsBody (trans pa)) []+transPD (HsPropDecl loc i xs pp)      =+    case basestruct body of+      Just (HsLambda ps e) -> bind (map cvt xs ++ ps) e+      _    -> if null xs then bind [hsPVar x]+			           (hsParen body $$ hsEVar x)+                         else bind (map cvt xs) body++  where cvt (HsCon i)                 = hsPVar (predName i)+        cvt (HsVar i)                 = hsPVar i+        body                          = trans pp+        bind ps body                  = hsFunBind loc [HsMatch loc (predName i) ps (HsBody body) []]+        x                             = UnQual "x"++transPD (HsAssertion _ Nothing _)     = error "unnamed assertion?"++++++--- recursive -----------------------------------------------------------------+instance Trans (AssertionI HsName) (Hs.HsExpI HsName)     where trans = trans . struct+instance Trans (PredicateI HsName) (Hs.HsExpI HsName)     where trans = trans . struct+instance Trans (Prop.HsExpI HsName) (Hs.HsExpI HsName)    where trans = trans . struct+instance Trans (Prop.HsDeclI HsName) (Hs.HsDeclI HsName)  where trans = trans . struct+++++--------------------------------------------------------------------------------+-- generating predicates for lifted constructors+--------------------------------------------------------------------------------++gen' compNum pat loc name     = hsFunBind loc matches+  where matches               = [ HsMatch loc lftCon (predPats ++ [pat compNames]) (HsBody body) []+                                , HsMatch loc lftCon (predPats ++ [hsPWildCard])   (HsBody (hsEVar false)) []+                                ] +        lftCon                = predName name+        body                  = foldr app (hsEVar true) (zipWith ($$) (map hsEVar predNames) (map hsEVar compNames))+          where app e1 e2     = pInfixApp e1 (HsVar conj) e2+        names x               = take compNum [ UnQual (x ++ show n) | n <- [1..] ]+        predPats              = map hsPVar predNames+        predNames             = names "p"+        compNames             = names "x"+++gen                           :: (HasBaseStruct d (DI HsName e p [d] t c tp), +                                  HasBaseStruct e (EI HsName e p [d] t c), +                                  HasBaseStruct p (PI HsName p)) +                              => HsConDeclI HsName t c -> d+gen (HsConDecl loc _ _ name ts) = gen' (length ts) pat loc name+  where pat compNames         = hsPApp name (map hsPVar compNames)+gen (HsRecDecl loc _ _ name fs) = gen' (length fieldNames) pat loc name+  where fieldNames              = concatMap fst fs+        pat compNames           = hsPRec name $ zipWith HsField fieldNames (map hsPVar compNames)++++genLiftedCon                            :: (HasBaseStruct d (DI HsName e p [d] t c tp), HasBaseStruct e (EI HsName e p [d] t c), +                                            HasBaseStruct p (PI HsName p)) => DI HsName e p [d] t c tp -> [d]+genLiftedCon (HsDataDecl _ _ _ ds _)    = map gen ds +genLiftedCon (HsNewTypeDecl _ _ _ d _)  = [gen d]+genLiftedCon _                          = []+++genLiftedConRec               :: Hs.HsDeclI HsName -> [Hs.HsDeclI HsName]+genLiftedConRec d             = genLiftedCon (struct d)+++-- translation of imports and exports ------------------------------------------++transImps exs = map (transImp exs)+transImp exs (Prop.HsImportDecl s mn q as optspecs) =+    Hs.HsImportDecl s mn q as (fmap (transImpSpec ex) optspecs)+  where ex = applyRel (fromJust (lookup mn exs)) . getQualified . fakeSN++transImpSpec ex (hiding,ents) = (hiding,concatMap (transEnt hiding ex) ents)++transExps ex = fmap (concatMap (transExp (applyRel ex.fakeSN)))+transExp ex exp =+  case exp of+    EntE e-> map EntE (transEnt False ex e)+    _ -> [exp]++transEnt hiding rel ent =+  case ent of+    Abs i -> nub $ concatMap (absEnt hiding i) (rel i)+    ListSubs i is -> ent:[Var (predName c)|HsCon c<-is]+    _ -> [ent] -- no constrcutors/assertions/predicates on other cases++absEnt hiding i ent =+  case idTy ent of+    Assertion -> [Var (assertName i)]+    Property -> [Var (predName i)]+    ConstrOf{} | hiding -> [Abs i,Var (predName i)]+    _ -> [Abs i]++--- translation of modules -----------------------------------------------------++moduleToQC ((wm,ex),HsModule loc name exps imps decls) =+    HsModule loc name newExps newImps newDecls+  where+    newDecls = addLiftedCons . map trans . addNames $ decls+    newExps = transExps (inscpRel wm) exps+    newImps = imp "QC_combinators" True (as "QC") Nothing :+	      imp "QC_prelude" False (as "Prelude") Nothing :+	      transImps ex imps++    addNames = withSt names . mapM nameAssert+      where names = [UnQual ("unnamed_" ++ show n) | n <- [1..]]++    addLiftedCons ds  = concatMap genLiftedConRec ds ++ ds++    imp = HsImportDecl loc . PlainModule -- !!! no import from Main+    as = Just . PlainModule -- hmm+++-- name all assertions+class NameAssert t i | t -> i where+  nameAssert :: t -> StateM [i] t+  +instance NameAssert (PD i pa pp) i where+  nameAssert (HsAssertion loc Nothing pa) = do n <- newName+                                               return (HsAssertion loc (Just n) pa)+  nameAssert x                            = return x++instance NameAssert (PropDecl i) i where+  nameAssert = mapMProp nameAssert nameAssert++instance (NameAssert e i, NameAssert d i) => NameAssert (DI i e p [d] t c tp) i where+  nameAssert = seqDI . mapDI return nameAssert return (mapM nameAssert) return return return ++instance (NameAssert e i, NameAssert d i) => NameAssert (EI i e p [d] t c) i where+  nameAssert = seqEI . mapEI return nameAssert return (mapM nameAssert) return return++instance NameAssert (Prop.HsDeclI i) i where nameAssert x = rec # nameAssert (struct x)+instance NameAssert (Prop.HsExpI i) i where nameAssert x = rec # nameAssert (struct x)++newName :: StateM [i] i+newName = head # updSt tail
+ tools/property/tstTiProp.hs view
@@ -0,0 +1,26 @@++import PropParser(parse)+import HsName(HsName)+import HsModule(HsModuleI)+import PropSyntax(HsModuleR)+import ScopeNamesProp()+import NameMapsProp()+import TiHsName+import ReAssocProp()+import TiPropDecorate+import PrettyPrint+import UTF8Util+import System(getArgs)+import TiProgram+import MUtils+import DirUtils++main = (tstTi =<< expand =<< getArgs) `catch` utf8err+++tstTi files =+  putStrLn =<< (utf8.(++("\n"++happy)).pp.r.fst # tcProgramFiles parse files)++r = id :: I [[HsModuleI i1 (TiDecls i2)]]++type I a = a->a
+ tools/scripts/adjustscript view
@@ -0,0 +1,19 @@++#adjustscript inserts a suitable default definition of a configuration+#option into a script. Input is excepected on stdin, output is sent to stdout.+#+# 'adjuscript VAR good' will change a line looking like this:+#+#     defaultVAR="anything"+#+# (where anything is anything) into+#+#     defaultVAR="good"+#++[ $# = 2 ] || {+  echo >&2 "Usage: adjustscript <varible> <default>"+  exit 1+}++sed "s%default$1=\"[^\"]*\"%default$1=\"$2\"%"
+ tools/scripts/myghc--make view
@@ -0,0 +1,4 @@++. HuMakefile+flags="-fallow-undecidable-instances -fno-monomorphism-restriction"+${GHC-ghc} --make $flags $GHCFLAGS -i$SRC_DIRS "$@"
+ tools/scripts/myghcxmake view
@@ -0,0 +1,17 @@++. HuMakefile+flags="-fallow-undecidable-instances -fno-monomorphism-restriction"+srcdirs="`echo $SRC_DIRS | sed 's/:/ -i/g'`"+libdirs="`echo $LIB_DIRS | sed 's/:/ -P/g'`"+if [ -n "$libdirs" ] ; then+  libdirs="-P$libdirs"+fi++if [ "x$1" = "x-contrib" ] ; then+  flags="-contrib $flags"+  shift+fi++#[ -n "$HIDE" ] && mv "$HIDE" "$HIDE.hidefromhmake" #hmake-3.07 bug workaround+ghcxmake $flags $GHCFLAGS -i$srcdirs $libdirs "$@"+#[ -n "$HIDE" ] && mv "$HIDE.hidefromhmake" "$HIDE" #hmake-3.07 bug workaround
+ tools/scripts/myghumake view
@@ -0,0 +1,2 @@++FUD_batch=${FUD_batch-yes} ghumake "$@"
+ tools/scripts/myghuxmake view
@@ -0,0 +1,2 @@++FUD_batch=${FUD_batch-yes} ghuxmake "$@"
+ tools/scripts/setEnv.csh view
@@ -0,0 +1,3 @@+setenv PROGRAMATICA $cwd/lib/Programatica+set path= ($cwd/bin $path)+
+ tools/scripts/syncanoncvs view
@@ -0,0 +1,45 @@+#!/bin/sh++### The purpose of this script is to update the copy of the Programatica+### CVS repository on the anonymous CVS server on glass.cse.ogi.edu.++RSYNC_RSH=ssh; export RSYNC_RSH++## Where the anonymous CVS repository mirror is located:+#anoncvshost=glass.cse.ogi.edu+anoncvshost=cvs.haskell.org+#anoncvsdir=/home/cvs/anon/cvs/programatica+anoncvsdir=/home/cvs/root/programatica+todir=$anoncvshost:$anoncvsdir++## Where the source CVS repository is located:+cvsdir=/projects/pacsoft/cvs/programatica+subdirs="tools hOp" # only copy this subdirectories+fromdirs="$cvsdir/tools $cvsdir/hOp"+exclude="--exclude=hOp/kernel/L4"+tmpdir=/tmp/programatica-cvs-tmp-copy+[ -d $tmpdir ] || mkdir -m go-rwx $tmpdir || exit 1++before=$tmpdir/before+after=$tmpdir/after+locks=$tmpdir/locks++### First try to make a consistent copy of the CVS repository:+find $fromdirs -ls >$after || exit 1+until+  mv $after $before &&+  rsync -a --delete --delete-excluded $exclude $fromdirs $tmpdir &&+  find $fromdirs -ls >$after || exit 1+  find $tmpdir -name '#cvs.*' >$locks || exit 1+  ! [ -s $locks ] && cmp $before $after+do+  [ -s $locks ] && echo "Found some lock files."+  cmp -s $before $after || echo "Repository changed during copy."+  echo "Trying again."+  sleep 10+done++### Assume we now have a consistent copy of the repository.+### Go ahead and upload it.++(cd $tmpdir && rsync -av --delete $subdirs $todir)
+ tools/scripts/updateNow.sh view
@@ -0,0 +1,15 @@++now="${1-Now.hs}"+new="$now.new"+{+echo "module Now where"+echo "{-# NOINLINE compileDate #-}"+echo 'compileDate = "'`date +%Y-%m-%d`'"'+#echo 'compileTime = "'`date +%T`'"'+} > "$new"+if cmp "$now" "$new"; then+ : #  echo Same date+else+  cat "$new" >"$now"+fi+rm "$new"
+ tools/titles view
@@ -0,0 +1,36 @@+. Root of Programica Tools Source Directory+TFF Theorems for Free+base Base Language and Base Functionalty+evman Evidence Management+hs2alfa Haskell-to-Alfa translator+hs2html Haskell-to-HTML renderer+hs2stratego Haskell-to-Stratego (Plover) translator+pfe Programatica Front-end Framework and command-line interface+base/AST Abstract Syntax (non-recursive structure)+base/Modules Haskell Module System+base/TI Type Inference Infrastructure and Type Inference for the Base Language+base/defs Scoping (name resolution)+base/lib General utility library+base/lib/Monads Iavor's Monads and Monad Transformers+base/lib/Monads/docs+base/parse2 Haskell 98 Parser+base/parse2/Lexer The Haskell Lexer (generated and hand-written modules)+base/parse2/LexerGen Lexer Generator+base/parse2/LexerSpec Haskell Lexical Syntax Specification+base/parse2/Parser Haskell 98 Happy Parser+base/pretty Pretty Printing Library+base/syntax Base Language Abstract Syntax Knot-tying recursive definitions+base/transforms Program transformation+base/transforms/Deriving Derived instance code generation+pfe/Browser Programatica Haskell Browser+property/AST AST for the Plogic extention (non-recursive structure)+property The Plogic extension+property/TI Type inference for the Plogic extension+property/defs Scoping (name resolution) for the Plogic extension+property/parse2 Parser for Haskell + the Plogic extension+property/parse2/Parser+property/pfe Command-line interface additions for the Plogic extension+property/syntax Knot-tying recursive definitions for the Plogic extention AST+property/transforms Program transformation for the Plogic extension+scripts Shell scripts to support the build process+web Files for the web pages
+ tools/usage.html view
@@ -0,0 +1,357 @@+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">+<html>+<head>+<title>Programatica Tools - Usage</title>+<link rel=parent href="./" title="Programatica Tools">+<link rel=author href="/~hallgren/" title="Thomas Hallgren">+<link rel="alternate stylesheet" type="text/css" HREF="/~hallgren/src2.css" title="Midnight Hacker">+<link rel="stylesheet" type="text/css" HREF="/~hallgren/src.css" title="Normal">+<link rel=icon type="image/gif" href="web/icon1.png">+</head>+<body>+<h1><img align=right src="web/icon1.png" alt="">Programatica Tools</h1>++<p>The Programatica tools currently consist of the following programs,+which are described in more detail below:</p>++<table>+<tr><td><a href="#pfe"><strong><code>pfe</code></strong></a>+<td>The Preliminary Front-End tool.+    (Or perhaps the Programatica Front-End tool :-)+<tr><td><a href="#pfesetup"><strong><code>pfesetup</code></strong></a>+<td>A front-end to pfe, for simple creation of PFE projects, using a command+line interface similar to that of Hugs or GHC.+<tr><td><a href="#pfebrowser"><strong><code>pfebrowser</code></strong></a>+<td>A Haskell browser tool (runs under the X11 Window system). It also has+    some support for certificate management.+<tr><td><a href="#cert"><strong><code>cert</code></strong></a>+<td>Certificate manipulation tool.+</table>++<p>+Except for <code>pfebrowser</code>, these are all command-line tools.++<p>+We also provide a version of the Haskell 98 <code>Prelude</code> and standard+libraries for use with PFE. We also adapted a version of the+Haskell Hierarchical Libraries for use with PFE.++<h2>Where to get the tools</h2>+<div>+<p>+Binary snapshots and installation instructions are available in the+<a href="http://www.cse.ogi.edu/~hallgren/Programatica/download/">download directory</a>.++<p>+If you are a local PacSoft member and you just want to test the tools,+they are already installed in++<ul>+  <li><code>/home/projects/pacsoft/tools/bin</code>+</ul>++<p>+(along with various other Linux tools)+so just log in on one of the Linux computers (kokotni, watiya, turing ,...)+and add that directory to your path. ++</div>++<h2>Usage</h2>++<p>Common to all the tools is that they operate on a PFE <em>project</em>,+i.e., a collection of files containing Haskell modules. A PFE project is+created in a specific directory and the PFE tools operate on the project+in the current directory. Except for the source files, which can be located+anywhere in the file system, the PFE tools keep all information relating to a+project in a subdirectory called <code>hi</code>.++<h3 id=pfesetup>pfesetup</h3>+<code>pfesetup</code> creates a new PFE project.+Usage:+<blockquote><code>+  pfesetup [<var>options</var>]+  <var>path<sub>1</sub></var> <var>...</var> <var>path<sub>n</sub></var>+</code></blockquote> +<p>+where the <var>path</var>s are Haskell files to include in the project.+<p>+<code>pfesetup</code> is designed to ease the transition from other Haskell+implementations (hugs, ghc, hbc, nhc) by providing a similar command line+interface.+<p>+Options:+<table>+<tr><td>+  (-P|-I|-i)<var>path<sub>1</sub></var>:...:<var>path<sub>n</sub></var>+<td>Directories to search for imported modules.+<tr><td>[no]cpp+<td>Pass source files through the C preprocessor (or not).+    The default is nocpp.+<tr><td>[no]prelude+<td>All modules implicitly import the Prelude (or not).+<tr><td>[no]plogic+<td>Enable (or disable) support for the P-logic extension. When enabled,+    <code>assert</code> and <code>property</code> are reserved identifiers+    and text in <code>{-P: comments like this -}</code> is treated as ordinary+    code+<tr><td>+h|hierarchical+<td>Use the Haskell Hierarchical Libraries+<tr><td>-h|nohierarchical+<td>Use the plain Haskell 98 Libraries (this is the default)+</table>++<p>+<code>pfesetup</code> does its work by using the <code>pfe new</code>+and <code>pfe chase</code> commands. (<code>pfe chase</code> is the only+command that assumes a relationship between file names and module names.)++<h3 id=pfe>pfe</h3>+Usage:+<blockquote><code>+pfe [<var>options</var>] <var>command</var>+</code></blockquote>+<p>+where <var>options</var> include+<p>+<table>+<tr><td>[no]plogic<td>Enable (or disable) support for the P-logic extension.+        When enabled,+    <code>assert</code> and <code>property</code> are reserved identifiers.+<tr><td>[no]cpp<td>Pass source code through the C preprocessor (or not)+<tr><td>cpp=<var>command</var><td>Pass source code through a user supplied preprocessor+<tr><td>[no]prelude<td>All modules implicitly import the Prelude (or not)+<tr><td>(+|-)debug<td>Turn on (or off) verbose debugging info in pretty printed output+<tr><td>(+|-)tinfo<td>Include (or not) extra type information in pretty printed output+<tr><td>(+|-)utf8<td>Turn on (or off) the use of Unicode symbols and UTF-8 encoding of pretty printed output+<tr><td>layout=<var>layout</var><td>Change the pretty printer's layout style+    to one of PPOffsideRule, PPSemiColon, PPUtrecht, PPInLine, PPNoLayout.+    (Not all layout styles are implemented)++</table>++<p>+and where <var>command</var> is one of:+<p>++<table>+<tr><th colspan=2>Level 0: basic project management+<tr><td>new [-quiet] <var>files</var>+    <td>create a new project containing (zero or more) <var>files</var>+<tr><td>add [-quiet] <var>files</var>+    <td>add <var>files</var> to the project+<tr><td>remove [-quiet] <var>files</var>+    <td>remove <var>files</var> from the project+<tr><td>files<td>list files in the project+<tr><td>options<td>show options in effect+<tr><td>modules <var>modules</var><td>list modules in the project++<tr><th colspan=2>Module graph queries+<tr><td>graph [-rev] [-dot] [-dir] <var>modules</var>+    <td>show module dependecy (sub)graph+<tr><td>unused <var>modules</var><td>show unimported and unreachable modules+<tr><td>prune <var>modules</var><td>remove unreachable modules from the project+<tr><td>file <var>modules</var><td>which file is the module in+<tr><td>module <var>files</var><td>which module does the file contain++<tr><th colspan=2>Import chasing+<tr><td>chase <var>files</var><td>look for imported modules in given files/directories++<tr><th colspan=2>Level 1: simple, local module queries+<tr><td>defined <var>modules</var><td>list entities defined in the module+<tr><td>free <var>modules</var><td>list names referenced but not defined in the module+<tr><td>pragmas <var>modules</var><td>extract pragmas from modules+<tr><td>lex <var>files</var><td>show the result of lexical analysis+<tr><td>lexl <var>files</var>+    <td>show the result of lexical analysis + layout preprocessing+<tr><td>preparse <var>files</var>+    <td>preparse and show abstract syntax++<tr><th colspan=2>Level 2: module system queries (import/export, top level environment)+<tr><td>exports <var>modules</var><td>list entities exported by the modules+<tr><td>find <var>identifiers</var><td>find exported entities with the given names+<tr><td>inscope <var>modules</var><td>list entities in modules' top-level environment++<tr><th colspan=2>Level 3: proper parsing (and name resolution)+<tr><td>pp <var>modules</var><td>parse and pretty-print modules+<tr><td>parse <var>modules</var><td>parse and show abstract syntax++<tr><th colspan=2>HTML+<tr><td>htmlfiles <var>modules</var><td>generate HTML files for modules+         (to be used with pfe.cgi for dynamically generated web pages)+<tr><td>webpages <var>modules</var><td>generate static web pages for modules++<tr><th colspan=2>Program transformation+<tr><td>rmpatbind <var>modules</var><td>remove pattern bindings+<tr><td>patmatch <var>modules</var><td>simplify pattern matches+<tr><td>funbind <var>modules</var><td>simplify function bindings++<tr><th colspan=2>Level 4: type checking+<tr><td>tc [-pm] [-pb] [-lc] <var>modules</var>+    <td>type check and display decorated modules+<tr><td>types <var>modules</var><td>show types/kinds of top-level entities+<tr><td>typeof <var>M1.x1 ... Mn.xn</var>+    <td>show types of named top-level entities+<tr><td>kindof <var>M1.x1 ... Mn.xn</var>+    <td>show kinds of named top-level entities+<tr><td>instances <var>modules</var><td>list instances defined in a module+<tr><td>iface <var>modules</var><td>show the interfaces of modules+<tr><td>usedtypes <var>modules</var><td>show what types identifers are used at++<tr><th colspan=2>Level 5: function level dependencies+<tr><td>deps [-dot] [-untyped] <var>modules</var>+    <td>compute dependency graph for definitions+<tr><td>needed [-untyped] <var>M1.x1 ... Mn.xn</var><td>needed definitions+<tr><td>neededmodules [-untyped] <var>M1.x1 ... Mn.xn</var><td>names of modules containing needed values+<tr><td>dead [-untyped] <var>M1.x1 ... Mn.xn</var><td>dead code (default: Main.main)+<tr><td>uses [type|class|value|con] <var>M.x</var>+    <td>find all uses of an entity++<tr><th colspan=2>Metrics+<tr><td>loc <var>modules</var><td>number of lines of code+<tr><td>sizemetrics<td>number of lines per module metrics+<tr><td>locmetrics<td>number of lines of code per module metrics+<tr><td>importmetrics<td>number of imports per module metrics+<tr><td>exportmetrics<td>number of exports (importers) per module metrics+<tr><td>classmetrics<td>number of instances per class metrics++<tr><th colspan=2>Commands to support certificate servers+<tr><td>assertions <var>modules</var><td>list names of named assertion+<tr><td>asig <var>M.x</var><td>write an assertion signature to stdout+<tr><td>tasig <var>M.x</var><td>write an assertion signature to stdout+<tr><td>adiff <var>M.x</var><td>compare an assertion signature with stdin+<tr><td>tadiff <var>M.x</var><td>compare an assertion signature with stdin+<tr><td>qc <var>modules</var><td>translate to QuickCheck+<tr><td>slice <var>M.x</var><td>extract a slice (needed part) of the program+<tr><td>pqc <var>M.x</var><td>pruned translation to QuickCheck+<tr><td>qcslice <var>M.x</var><td>translate a slice to QuickCheck+<tr><td>stratego <var>modules</var><td>simple translation of one module to Stratego+<tr><td>strategoslice <var>modules</var><td>translate a slice to Stratego+<tr><td>alfa [-simplepats] <var>modules</var><td>translate modules to Alfa++<tr><th colspan=2>Cleaning+<tr><td>clean<td>remove cache files++<tr><th colspan=2>Interactive/server mode+<tr><td>interactive<td>read pfe commands from stdin+<tr><td>server<td>start a PFE server++<tr><th colspan=2>Documentation+<tr><td>help<td>list available commands+<tr><td>version<td>display version number+</table> ++<p>+(TODO: many commands need to be explained in more detailed. Some related+commands should be combined into one command with options.)++<h3 id=cert>cert</h3>++Usage:+<blockquote><code>+cert <var>command</var>+</code></blockquote> ++where the <var>command</var> is one of+<p>+<table>+<tr><td>types<td>list supported certificate types+<tr><td>ls<td>list certificates+<tr><td>dotgraph<td>output dot format certificate dependency graph+<tr><td>todo<td>list uncertified assertions+<tr><td>new <var>type</var> <var>M/c</var> <var>conc</var> ...+     <td>create a new certificate+<tr><td>info <var>M/c</var><td>show certificate details+<tr><td>validate <var>M/c</var><td>validate a certificate+<tr><td>validate -all<td>validate all certificates+<tr><td>sign <var>M/c</var><td>add a PGP signature to a certifiacte+<tr><td>verify <var>M/c</var><td>verify the PGP signature of a certificate+<tr><td>rm <var>M/c</var><td>remove a certificate+<tr><td>recreate<td>generate a list of <code>cert new</code> commands to recreate all certificates+</table>++<p>+(TODO: describe commands in more detail. Add more functionality.)++<h3 id=pfebrowser>pfebrowser</h3>++Usage:+<blockquote><code>+pfebrowser [<var>options</var>]+</code></blockquote> ++where the <var>options</var> are the same as for+<a href="#pfe"><code>pfe</code></a>.++<p>+Since <code>pfebrowser</code> currently doesn't provide any project+management functionality, before you start pfebrowser, you should+create a PFE project with the+<a href="#pfesetup"><code>pfesetup</code></a> or+<a href="#pfe"><code>pfe</code></a> command.+Also, if files are added or removed from the+project, you need to restart <code>pfebrowser</code>.++<h4>Browsing</h4>++<p>+In the source display area, clicking on identifiers have the following effect:+</p>++<table>+<tr><th>Button 1 (Left)+    <td>Jumps to the definition++<tr><th>Button 2 (Middle)+    <td>Displays information about the identifier,+        such as where it was originally defined and what type of entity+	it represents.+	<br>+	If type checking is turned on, pfebrowser also displays the type+	of the identifier, both it's general type scheme and the instance+	it is used at. For an identifier denoting a type or a class, its+	kind is shown.+<tr><th>Button 3 (Right)+    <td>Highlight all references to the same entity in the current module.+</table>++<h4>Type checking</h4>++Type checking is turned off by default. To turn it on, select+<strong>Type Info</strong> in the <strong>View</strong> menu.+Type checking is turned off when a type error is encountered.++<h4>Auxiliary windows</h4>++<p>+The <strong>Windows</strong> menu lists the following windows that display+additional views of the current module.+</p>++<table>+<tr><th>CertInfo+    <td>Details about the currently selected certificates.+        (Opens automatically when clicking on a certificate icons.)+<tr><th>CertTypes+    <td>Lists known certificate types.+<tr><th>Evidence+    <td>List assertions and certificates in the current module+<tr><th>Exports+    <td>Lists entities exported from the current module+<tr><th>Interface+    <td>Lists types/kinds of entities exported from the current module,+        provided type checking is turned on.+<tr><th>Pretty+    <td>Displays a pretty printed view of the current module.+</table>++<h4>Certificate management</h4>++<p>+(TODO: document how to manipulate certificates with pfebrowser...)+<p>+(TODO: there is probably more functionality in pfebrowser that needs to be+documented.)++</body>+</html>
+ tools/web/blue.gif view
binary file changed (absent → 1015 bytes)
+ tools/web/icon1.png view
binary file changed (absent → 5918 bytes)
+ tools/web/pfe.cgi view
@@ -0,0 +1,293 @@+#! /bin/bash++PATH=$PATH:/usr/local/bin; export PATH # For gunzip on church...+bin=/home/users/hallgren/cgi+AUTOHEADER=no+. $bin/cgistart.sh++datefmt=${datefmt-"+%b %d"}++### Locations ##################################################################+self_url=pfe.cgi+#modulesourcefiles=hi/modules # old+modulesourcefiles=hi/ModuleSourceFiles.txt # new+revgraph=hi/ModuleGraphRev.txt+htmldir=hi/html+ifacedir=hi/iface+### Functions ##################################################################++modulelink() {+  link "$self_url?$1" "${2-$1}"+}++plainsrclink() {+  echo "${2-Plain source file}:"+  link "$1" "$1"+  wrap small " (`filedate "$datefmt" "$1"`)"+}++cvsloglink() {+  if [ -x cvs.cgi ]; then+    link "cvs.cgi?$1" "cvs log"+  fi+}++optdoclink() {+  doc="${1%.hs}.doc"+  if [ -n "$manpage_url" ] && [ -r "$doc" ] ; then+    sep="<p>Related manual pages: "+    grep '^\$Doc ' <$doc | while read doc manentry rest ; do+     echo "$sep"+     link "${manpage_url}$manentry.html" "$manentry"+     sep=", "+    done+  fi+}++optifacelink() {+ if [ -r "$1" ] ; then+   echo_n "$2"+   link "$1" "Interface"+   echo_n "$3"+   if [ -n "$4" ] ; then+     wrap small " (`filedate "$datefmt" "$1"`)"+   fi+ fi+}++generated() {+  if [ "$1" = "$3" ] ; then+    plainsrclink "$1" "Plain source file for $2"+    p+  else +    wrap code "$1"+    echo "is actually generated by $2 from"+    wrap code `link "$3" "$3"`+    echo "which is shown below."+  fi+}++plainfile() {+  grep "^$1 " $modulesourcefiles | awk '{print $2}'+}++importedby() {+  m="$1"+  if [ -r $revgraph ] ; then+    grep "^$m " <$revgraph | { read this imports && {+      echo "$m is imported"+      sep="by:"+      for i in $imports ; do+	echo "$sep"+        modulelink "$i"+	sep=","+      done+      echo "."+      p+    }+    }+  else+    echo "Don't know who imports this module."+    p+  fi+}++uptodatecheck() {+  gen="$1" # existing generated file+  src="$2" # maybe missing source file+  if [ -r "$src" ] && [ "$src" -nt "$gen" ] ; then+    echo "Warning: the plain source file is newer than the generated HTML version shown below!"+  fi+}+showsourcefile() {+m="$1"+hm=`echo "$m" | sed 's%/%-%g'`+h="$htmldir/$hm.html"+hgz="$h.gz"+#pfe all2html "$m" >/dev/null+f=`plainfile "$m"`+d=""+if [ -r "$h" ] || [ -r "$hgz" ] ; then+  if [ -r "$f" ] ; then+    plainsrclink "$f"+    optifacelink "$ifacedir/$hm.hs" "<br>" " (experimental)" d+    optdoclink "$f"+    #br;cvsloglink "$f"+    p;importedby "$m"+  else+    echo "The plain source file for module $m is not available."+  fi+  if [ -r "$h" ] ; then+    uptodatecheck "$h" "$f"+    cat "$h"+    d="`filedate "$datefmt" "$h"`"+  elif [ -r "$hgz" ] ; then+    uptodatecheck "$hgz" "$f"+    gunzip <"$hgz"+    d="`filedate "$datefmt" "$hgz"`"+  fi+else+  echo "The source file for module $m is not available."+fi+hr+link "$self_url" Index+p+[ -n "$d" ] && {+  begin small+   echo "(HTML for this module was generated on $d."+   link "//www.cse.ogi.edu/~hallgren/h2h.html" "About the conversion tool"+   echo ".)"+}+}++showsubdirs() {+  h2 Subdirectories+  begin ol+  p="*/"+  [ -n "$1" ] && p="$1*/"+  for d in $p ; do+    li; link "$self_url?$d" $d; nl+  done+  end+}++adddir() {+  while read m d f ; do+    [ -n "$f" ] || { f="$d"; d="."; }+    echo "$m" "$d" "$f"+  done+}++buggymoduleroot() {+  if [ -n "$related" ] ; then+    echo "$1" | sed "s/\($related\)\$//"+  else+    echo "$1"+  fi+}++moduleroot() {+  case "$1" in+    *BaseStruct) echo "${1%BaseStruct}" ;;+    *RecPretty) echo "${1%RecPretty}" ;;+    *Base) echo "${1%Base}" ;;+    *Maps) echo "${1%Maps}" ;;+    *Pretty) echo "${1%Pretty}" ;;+    *Struct) echo "${1%Struct}" ;;+    *Util) echo "${1%Util}" ;;+    *Rec) echo "${1%Rec}" ;;+    *MT) echo "${1%T}" ;;+    *) echo "$1"+  esac+}++showstructureindex() {+  grep " $1" <$modulesourcefiles | sed 's%/\([^/]*\)$% \1%' |+    adddir | sort -f -k 2 | {+    files=""+    d0=""+    m0=""+    while read m d f; do+      h="$htmldir/$m.html"+      path="$d/$f"+      if [ -r "$path" ] ; then+	case "$path" in+	  hi/libs/*Libraries/*) ;; # exclude Prelude & standard libraries+	  *) if [ "$d" != "$d0" ] ; then+	       nl+	       [ -z "$d0" ] || end+	       nl+	       desc=""+               if [ -r titles ] ; then+		 escd=`echo "$d" | sed 's/\./\\\\./g'`+                 desc="`sed -n "s%^$escd \(.*\)\$%\1%p" <titles`"+                 #echo "($escd)" | cat -v+               fi+	       [ -z "$desc" ] || desc="- $desc"+	       if [ -r "$d/README.html" ] ; then+	         h="Directory `link $d $d` $desc"+	       else+	         h="Directory $d $desc"+               fi+	       begin h4 "id=\"$d\""; echo_n "$h"; end+	       nl+	       d0="$d"+               begin ol+             fi+             m1=`moduleroot "$m"`+	     if [ "$m1" = "$m0" ] ; then+               echo ","+             else+	       m0="$m1"+               nl; li+             fi+             modulelink "$m" # ; echo "($f)"+	     optifacelink "$ifacedir/$m.hs" " (" ")"+	     files="$files $path"+	esac+      fi+    done+    [ -z "$d0" ] || end+    nl+    filedate "$datefmt" $files+  }+}++showmoduleindex() {+  #pfe >/dev/null+  #h2 "Modules"+  grep " $1" <$modulesourcefiles | sort | {+    begin ol+    files=""+    while read m f; do+      h="$htmldir/$m.html"+      if [ -r "$f" ] ; then+	case "$f" in+	  hi/libs/*Libraries/*) ;; # exclude Prelude & standard libraries+	  *) li; modulelink "$m"+	     #echo "($f)"+	     nl+	     files="$files $f"+	esac+      fi+    done+    end+    filedate "$datefmt" $files+  }+}++showindex() {+  files="$modulesourcefiles"+  [ -r index_inc.html ] && files="$files index_inc.html"+  [ -r index_footer.html ] && files="$files index_footer.html"+  [ -r cgiconfig.sh ] && files="$files cgiconfig.sh"+  modtime="`TZ=GMT LANG=C filedate '+%a, %d %b %Y %T %Z' $files`"++  echo "Last-Modified: $modtime"+  pagestart "${maintitle-Haskell Files}"++  #showsubdirs "$@"+  [ -r index_inc.html ] && cat index_inc.html+  #showmoduleindex "$@"+  showstructureindex "$@"+  [ -r index_footer.html ] && cat index_footer.html+}++### Main #######################################################################++if [ -n "$QUERY_STRING" ]; then+  contents_url="$self_url";+  parent_url="$self_url";parent="Module List"+  eval f="$*"+  pagestart "$f"+  #if [ -d "$f" ] ; then+  #  showindex "$1"+  #  show+  #else+    showsourcefile "$f"+  #fi+else+  showindex+fi++pageend
+ tools/web/src.css view
@@ -0,0 +1,75 @@+BODY { color: black; background: #c9d6df }+.code {+  background-color: #efe6d9;+}++DIV.code {+  margin-left: 0; margin-right: 0;+  border-width: 0.1px; /* NS 4.x trick */+}++.sc { font-variant: small-caps; }++.code B { color: #662200; }+B.con { color: #007744; }+B.conop { color: #007744; }+B.tcon { color: #000099; }+.code VAR { font-style: normal; }+VAR.var { color: black; font-style: normal; }+VAR.varop { color: #dd0000; font-style: normal; }+VAR.tvar { color: #000099; font-style: italic; }+SPAN.lit { color: #880088; }++/*code { font-weight: bold; }*/++DIV { padding-left: 1em; }++DIV.page { border-width: 2px;+	   border-style: solid;+	   border-color: #191970;+           margin: 20px;+	   /* margin-bottom: 20px; */+	   padding: 5px;+	   page-break-before: always;+	   page-break-inside: avoid;+           /*align: center;*/ }++UL,OL { margin-right: 4em; }+/*LI { margin-top: 1ex; margin-bottom: 1ex; }*/++.cmnt { color: #191970;+	background-color: #c9d6df; +}++H1, H2, H3, H4, TH {+  font-family: sans-serif;+  color: #191970;+}++H1, H2, H3 {+      text-align: center;+      background-color: #b7c8e8;+      padding: 0.5ex;++      margin-top:0;+      margin-bottom: 1ex;+/**/+ }++TABLE.borderless { border-width: 0; }+TABLE.borderless TR TD { border-width: 0; }+TABLE.borderless TR TH { border-width: 0; }++TH,TD { text-align: left; vertical-align: top; }+TH,TD,TABLE { border: 1px solid #171770 }+TABLE { border-collapse: collapse; }+/*TH, TD { padding: 3px; }*/ /* Problem in NS 4.x */+TH { background-color: #efe6d9; }+TD { background-color: #d9e6ef; }++IMG.border0 { border-width: 0; }+DIV.right { text-align: right; }+IMG.right { float: right; margin: 0; padding: 0; }+.clear { clear: both; }++DT { margin-top: 1ex; }
+ tools/web/src2.css view
@@ -0,0 +1,53 @@+body {+	color:			#ffffff;+	background-color:	#444488;+}++.max50em { max-width: 50em; }++h1,h2,h3 {+	background-color:	#990000;+	/* background-color:	#ff6600; */+	text-align: center;+	padding-top: 5px;+	padding-bottom: 5px;+	font-family: sans-serif;+}++.code {+	background-color:	#333366;+}++DIV { padding-left: 1em; }++DIV.code {+  margin-left: 0; margin-right: 0;+  border-width: 0.1px; /* NS 4.x trick */+}++a {+	color:			#ccccff;+} ++a:hover {+	background-color:	purple;+	color:			#ffffff;+}++.code B { color: #00ff00; }++B.con { color: #ff9900 }+B.conop { color: #ff9900 }+B.tcon { color: #33ccff; }+.code VAR { font-style: normal; }+VAR.var { color: #ffffff; font-style: normal; }+VAR.varop { color: #ffff00; font-style: normal; }+VAR.tvar { font-style: italic; }+SPAN.lit { color: #ff66ff; }+++.cmnt { color: #ccccff;+	background-color: #444488; +}++DT { margin-top: 1.5ex; }
+ tools/web/tree.cgi view
@@ -0,0 +1,55 @@+#!/bin/bash++bin=/home/users/hallgren/cgi+. $bin/cgistart.sh++### Horizontal Tree+htree() {+  begin table+  begin caption; h4 "$1";end+  tr;+  ls -1 | while read dir ; do+    if [ -d "$dir" ] ; then+      case "$dir" in+	CVS|objs|junk|hi|tests) : ;;+	*) td; (cd "$dir"; htree "$dir")+      esac+    fi+  done+  end+}++### Vertical Tree+vtree() {+  begin table class=borderless+  tr; th "$2/"+  td+  begin table class=borderless+  tr;td;sed -n "s%^$1 \(.*\)\$%\1%p" <titles+  txt=README+  [ -r "$1/README.html" ] || txt="Files"+  link "$1/" "$txt" ; nl+  if [ $level -ge $maxlevel ] ; then+    link "tree.cgi?$1" more+  else+    ls -1 "$1" | while read node ; do+      dir="$1/$node"+      dir="${dir#./}" # remove ./ prefix+      if ! [ -h "$dir" ] && [ -d "$dir" ] && [ -d "$dir/CVS" ] ; then+	case "$node" in+	  CVS|tests|doc|spec|hsutils|toy|command) : ;;+	  *) tr;td;+	     level=$(($level+1)) vtree "$dir" "$node"+	esac+      fi+    done+  fi+  end+  end+}++maxlevel=6+level=1+pagestart "Directory Tree Overview"+vtree ${1-.} `basename "${1-$PWD}"`+endall