diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,27 @@
+Copyright (c) 1998-2004, Wolfgang Lux
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+2.  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.
+3. None of the names of the copyright holders and 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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/curry-frontend.cabal b/curry-frontend.cabal
new file mode 100644
--- /dev/null
+++ b/curry-frontend.cabal
@@ -0,0 +1,44 @@
+Name:          curry-frontend
+Version:       0.1
+Cabal-Version: >= 1.6
+Synopsis:      A compiler for the functional logic language Curry to several intermediate language formats.
+Description:   The Curry Frontend consists of the executable program "cymake".
+               It is used by various backends to compile Curry programs to 
+               an internal representation. 
+               The code is a stripped-down version of an early version of
+	       the Muenster Curry Compiler 
+               (<http://danae.uni-muenster.de/~lux/curry/>)
+Category:      Language
+License:       OtherLicense
+License-File:  LICENSE
+Author:        Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel
+Maintainer:    Michael Hanus
+Bug-Reports:   mailto:mh@informatik.uni-kiel.de
+Homepage:      http://curry-language.org
+Build-Type:    Simple
+Stability:     experimental
+
+Extra-Source-Files: src/currydoc.css
+		    
+
+Executable cymake
+  hs-source-dirs:   src
+  Main-is:          cymake.hs
+  Build-Depends:    base >= 3 && < 4, mtl, old-time, directory, filepath
+  Other-Modules:    AbstractCurry, CurryBuilder, Env, IL, Message
+                    CurryCompilerOpts, Error, Modules, Subst, Arity
+                    CurryDeps, Eval, ILPP, NestEnv, SyntaxCheck, Base
+                    Exports, ILScope, SyntaxColoring, CurryEnv
+                    ExtendedFlat, ILTrans, OldScopeEnv, CurryHtml
+                    ILxml, PatchPrelude, TopEnv, CaseCompletion
+                    CurryLexer, Imports, PathUtils, TypeCheck
+                    CurryParser, InterfaceCheck, Position
+                    Types, CurryPP, Frontend, PrecCheck
+                    TypeSubst, CurrySubdir, GenAbstractCurry
+                    Pretty, Typing, Combined, CurrySyntax
+                    GenFlatCurry, KindCheck, Qual, Unlit, CompilerResults
+                    LexComb, SCC, Utils, GetOpt
+                    Lift, ScopeEnv, WarnCheck
+                    LLParseComb, Set, Desugar, Ident, ShowCurrySyntax
+                    Map, Simplify
+
diff --git a/src/AbstractCurry.hs b/src/AbstractCurry.hs
new file mode 100644
--- /dev/null
+++ b/src/AbstractCurry.hs
@@ -0,0 +1,282 @@
+------------------------------------------------------------------------------
+--- Library to support meta-programming in Curry.
+---
+--- This library contains a definition for representing Curry programs
+--- in Curry (type "CurryProg") and an I/O action to read Curry programs and
+--- transform them into this abstract representation (function "readCurry").
+---
+--- Note this defines a slightly new format for AbstractCurry
+--- in comparison to the first proposal of 2003.
+---
+--- Assumption: an abstract Curry program is stored in file prog.acy
+---             and translated with the parser by "parsecurry -acy prog".
+---
+--- @author Michael Hanus
+--- @version April 2004
+---
+--- Version for Haskell (slightly modified):
+--- July 2005, Martin Engelke (men@informatik.uni-kiel.de)
+---
+------------------------------------------------------------------------------
+
+module AbstractCurry (CurryProg(..), QName, CLabel, CVisibility(..),
+		      CTVarIName, CTypeDecl(..), CConsDecl(..), CTypeExpr(..),
+                      COpDecl(..), CFixity(..), CVarIName,
+                      CFuncDecl(..), CRules(..), CEvalAnnot(..),
+                      CRule(..), CLocalDecl(..), CExpr(..), CStatement(..),
+                      CPattern(..), CBranchExpr(..), CLiteral(..),
+		      CField,
+                      readCurry, writeCurry) where
+
+import Data.List(intersperse)
+
+import PathUtils (writeModule,readModule)
+
+
+------------------------------------------------------------------------------
+-- Definition of data types for representing abstract Curry programs:
+-- ==================================================================
+
+--- Data type for representing a Curry module in the intermediate form.
+--- A value of this data type has the form
+--- <CODE>
+---  (CProg modname imports typedecls functions opdecls)
+--- </CODE>
+--- where modname: name of this module,
+---       imports: list of modules names that are imported,
+---       typedecls, opdecls, functions: see below
+
+data CurryProg = CurryProg String [String] [CTypeDecl] [CFuncDecl] [COpDecl]
+	         deriving (Read, Show)
+
+--- The data type for representing qualified names.
+--- In AbstractCurry all names are qualified to avoid name clashes.
+--- The first component is the module name and the second component the
+--- unqualified name as it occurs in the source program.
+type QName = (String,String)
+
+--- Type for representing label identifiers
+type CLabel = String
+
+-- Data type to specify the visibility of various entities.
+
+data CVisibility = Public    -- exported entity
+                 | Private   -- private entity
+		   deriving (Read, Show, Eq)
+
+
+--- The data type for representing type variables.
+--- They are represented by (i,n) where i is a type variable index
+--- which is unique inside a function and n is a name (if possible,
+--- the name written in the source program).
+type CTVarIName = (Int,String)
+
+--- Data type for representing definitions of algebraic data types
+--- and type synonyms.
+--- <PRE>
+--- A data type definition of the form
+---
+--- data t x1...xn = ...| c t1....tkc |...
+---
+--- is represented by the Curry term
+---
+--- (CType t v [i1,...,in] [...(CCons c kc v [t1,...,tkc])...])
+---
+--- where each ij is the index of the type variable xj
+---
+--- Note: the type variable indices are unique inside each type declaration
+---       and are usually numbered from 0
+---
+--- Thus, a data type declaration consists of the name of the data type,
+--- a list of type parameters and a list of constructor declarations.
+--- </PRE>
+
+data CTypeDecl = CType    QName CVisibility [CTVarIName] [CConsDecl]
+               | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr
+		 deriving (Read, Show)
+
+
+--- A constructor declaration consists of the name and arity of the
+--- constructor and a list of the argument types of the constructor.
+
+data CConsDecl = CCons QName Int CVisibility [CTypeExpr]
+		 deriving (Read, Show)
+
+
+--- Data type for type expressions.
+--- A type expression is either a type variable, a function type,
+--- or a type constructor application.
+---
+--- Note: the names of the predefined type constructors are
+---       "Int", "Float", "Bool", "Char", "IO", "Success",
+---       "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
+
+data CTypeExpr =
+    CTVar CTVarIName               -- type variable
+  | CFuncType CTypeExpr CTypeExpr  -- function type t1->t2
+  | CTCons QName [CTypeExpr]       -- type constructor application
+  | CRecordType [CField CTypeExpr] -- record type (extended Curry)
+                (Maybe CTVarIName)
+    deriving (Read, Show) 
+
+
+--- Data type for operator declarations.
+--- An operator declaration "fix p n" in Curry corresponds to the
+--- AbstractCurry term (COp n fix p).
+
+data COpDecl = COp QName CFixity Integer deriving (Read, Show)
+
+data CFixity = CInfixOp   -- non-associative infix operator
+             | CInfixlOp  -- left-associative infix operator
+             | CInfixrOp  -- right-associative infix operator
+	       deriving (Read, Show, Eq)
+
+
+--- Data types for representing object variables.
+--- Object variables occurring in expressions are represented by (Var i)
+--- where i is a variable index.
+
+type CVarIName = (Int,String)
+
+
+--- Data type for representing function declarations.
+--- <PRE>
+--- A function declaration in FlatCurry is a term of the form
+---
+---  (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))
+---
+--- and represents the function "name" with definition
+---
+---   name :: type
+---   rule1
+---   ...
+---   rulek
+---
+--- Note: the variable indices are unique inside each rule
+---
+--- External functions are represented as (CFunc name arity type (CExternal s))
+--- where s is the external name associated to this function.
+---
+--- Thus, a function declaration consists of the name, arity, type, and
+--- a list of rules.
+--- </PRE>
+
+data CFuncDecl = CFunc QName Int CVisibility CTypeExpr CRules
+	         deriving (Read, Show)
+
+
+--- A rule is either a list of formal parameters together with an expression
+--- (i.e., a rule in flat form), a list of general program rules with
+--- an evaluation annotation, or it is externally defined
+
+data CRules = CRules CEvalAnnot [CRule]
+            | CExternal String
+	      deriving (Read, Show)
+
+--- Data type for classifying evaluation annotations for functions.
+--- They can be either flexible (default), rigid, or choice.
+
+data CEvalAnnot = CFlex | CRigid | CChoice deriving (Read, Show, Eq)
+
+--- The most general form of a rule. It consists of a list of patterns
+--- (left-hand side), a list of guards ("success" if not present in the
+--- source text) with their corresponding right-hand sides, and
+--- a list of local declarations.
+data CRule = CRule [CPattern] [(CExpr,CExpr)] [CLocalDecl]
+	     deriving (Read, Show)
+
+--- Data type for representing local (let/where) declarations
+data CLocalDecl =
+     CLocalFunc CFuncDecl                   -- local function declaration
+   | CLocalPat  CPattern CExpr [CLocalDecl] -- local pattern declaration
+   | CLocalVar  CVarIName                   -- local free variable declaration
+     deriving (Read, Show)
+
+--- Data type for representing Curry expressions.
+
+data CExpr =
+   CVar       CVarIName             -- variable (unique index / name)
+ | CLit       CLiteral              -- literal (Integer/Float/Char constant)
+ | CSymbol    QName                 -- a defined symbol with module and name
+ | CApply     CExpr CExpr           -- application (e1 e2)
+ | CLambda    [CPattern] CExpr      -- lambda abstraction
+ | CLetDecl   [CLocalDecl] CExpr    -- local let declarations
+ | CDoExpr    [CStatement]          -- do expression
+ | CListComp  CExpr [CStatement]    -- list comprehension
+ | CCase      CExpr [CBranchExpr]   -- case expression
+ | CRecConstr [CField CExpr]        -- record construction (extended Curry)
+ | CRecSelect CExpr CLabel          -- field selection (extended Curry)
+ | CRecUpdate [CField CExpr] CExpr  -- record update (extended Curry)
+   deriving (Read, Show)
+
+--- Data type for representing statements in do expressions and
+--- list comprehensions.
+
+data CStatement = CSExpr CExpr         -- an expression (I/O action or boolean)
+                | CSPat CPattern CExpr -- a pattern definition
+                | CSLet [CLocalDecl]   -- a local let declaration
+		  deriving (Read, Show)
+
+--- Data type for representing pattern expressions.
+
+data CPattern =
+   CPVar CVarIName             -- pattern variable (unique index / name)
+ | CPLit CLiteral              -- literal (Integer/Float/Char constant)
+ | CPComb QName [CPattern]     -- application (m.c e1 ... en) of n-ary
+                               -- constructor m.c (CPComb (m,c) [e1,...,en])
+ | CPAs CVarIName CPattern     -- as-pattern (extended Curry)
+ | CPFuncComb QName [CPattern] -- function pattern (extended Curry)
+ | CPLazy CPattern             -- lazy pattern (extended Curry) 
+ | CPRecord [CField CPattern]  -- record pattern (extended curry)
+            (Maybe CPattern)
+   deriving (Read, Show)  
+
+--- Data type for representing branches in case expressions.
+
+data CBranchExpr = CBranch CPattern CExpr deriving (Read, Show)
+
+--- Data type for representing literals occurring in an expression.
+--- It is either an integer, a float, or a character constant.
+--- Note: the constructor definition of 'CIntc' differs from the original
+--- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'
+--- to provide an unlimited range of integer numbers. Furthermore
+--- float values are represented with Haskell type 'Double' instead of
+--- 'Float'.
+
+data CLiteral = CIntc   Integer
+              | CFloatc Double
+              | CCharc  Char
+		deriving (Read, Show, Eq)
+
+--- Type for representing labeled fields
+
+type CField a = (CLabel,a)
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+-- Reads an AbstractCurry file and returns the corresponding AbstractCurry
+-- program term (type 'CurryProg')
+readCurry :: String -> IO CurryProg
+readCurry filename
+   = do file <- readModule filename
+	let prog = (read file) :: CurryProg
+	return prog
+
+-- Writes an AbstractCurry program term into a file
+writeCurry :: String -> CurryProg -> IO ()
+writeCurry filename prog 
+   = catch (writeModule filename (showCurry prog)) (\e -> ioError e)
+
+-- Shows an AbstractCurry program in a more nicely way.
+showCurry :: CurryProg -> String
+showCurry (CurryProg mname imps types funcs ops) =
+  "CurryProg "++show mname++"\n "++
+  show imps ++"\n ["++
+  concat (intersperse ",\n  " (map (\t->show t) types)) ++"]\n ["++
+  concat (intersperse ",\n  " (map (\f->show f) funcs)) ++"]\n "++
+  show ops ++"\n"
+  
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
diff --git a/src/Arity.hs b/src/Arity.hs
new file mode 100644
--- /dev/null
+++ b/src/Arity.hs
@@ -0,0 +1,132 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- Arity - provides functions for expanding the arity environment 'ArityEnv'
+--         (see Module "Base")
+--
+-- September 2005,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+module Arity (bindArities) where
+
+import Base
+import CurrySyntax
+import Ident
+
+
+-------------------------------------------------------------------------------
+
+-- Expands the arity envorinment with (global / local) function arities and
+-- constructor arities
+bindArities :: ArityEnv -> Module -> ArityEnv
+bindArities aEnv (Module mid _ decls)
+   = foldl (visitDecl mid) aEnv decls
+
+
+-------------------------------------------------------------------------------
+
+visitDecl :: ModuleIdent -> ArityEnv -> Decl -> ArityEnv
+visitDecl mid aEnv (DataDecl _ _ _ cdecls)
+   = foldl (visitConstrDecl mid) aEnv cdecls
+visitDecl mid aEnv (ExternalDecl _ _ _ id texpr)
+   = bindArity mid id (typeArity texpr) aEnv
+visitDecl mid aEnv (FunctionDecl _ id equs)
+   = let (Equation _ lhs rhs) = head equs
+     in  visitRhs mid (visitLhs mid id aEnv lhs) rhs
+visitDecl _ aEnv _ = aEnv
+
+
+visitConstrDecl :: ModuleIdent -> ArityEnv -> ConstrDecl -> ArityEnv
+visitConstrDecl mid aEnv (ConstrDecl _ _ id texprs)
+   = bindArity mid id (length texprs) aEnv
+visitConstrDecl mid aEnv (ConOpDecl _ _ _ id _)
+   = bindArity mid id 2 aEnv
+
+
+visitLhs :: ModuleIdent -> Ident -> ArityEnv -> Lhs -> ArityEnv
+visitLhs mid _ aEnv (FunLhs id params)
+   = bindArity mid id (length params) aEnv
+visitLhs mid id aEnv (OpLhs _ _ _)
+   = bindArity mid id 2 aEnv
+visitLhs _ _ aEnv _ = aEnv
+
+
+visitRhs :: ModuleIdent -> ArityEnv -> Rhs -> ArityEnv
+visitRhs mid aEnv (SimpleRhs _ expr decls)
+   = foldl (visitDecl mid) (visitExpression mid aEnv expr) decls
+visitRhs mid aEnv (GuardedRhs cexprs decls)
+   = foldl (visitDecl mid) (foldl (visitCondExpr mid) aEnv cexprs) decls
+
+
+visitCondExpr :: ModuleIdent -> ArityEnv -> CondExpr -> ArityEnv
+visitCondExpr mid aEnv (CondExpr _ cond expr)
+   = visitExpression mid (visitExpression mid aEnv expr) cond
+
+
+visitExpression :: ModuleIdent -> ArityEnv -> Expression -> ArityEnv
+visitExpression mid aEnv (Paren expr)
+   = visitExpression mid aEnv expr
+visitExpression mid aEnv (Typed expr _)
+   = visitExpression mid aEnv expr
+visitExpression mid aEnv (Tuple _ exprs)
+   = foldl (visitExpression mid) aEnv exprs
+visitExpression mid aEnv (List _ exprs)
+   = foldl (visitExpression mid) aEnv exprs
+visitExpression mid aEnv (ListCompr _ expr stmts)
+   = foldl (visitStatement mid) (visitExpression mid aEnv expr) stmts
+visitExpression mid aEnv (EnumFrom expr)
+   = visitExpression mid aEnv expr
+visitExpression mid aEnv (EnumFromThen expr1 expr2)
+   = foldl (visitExpression mid) aEnv [expr1,expr2]
+visitExpression mid aEnv (EnumFromTo expr1 expr2)
+   = foldl (visitExpression mid) aEnv [expr1,expr2]
+visitExpression mid aEnv (EnumFromThenTo expr1 expr2 expr3)
+   = foldl (visitExpression mid) aEnv [expr1,expr2,expr3]
+visitExpression mid aEnv (UnaryMinus _ expr)
+   = visitExpression mid aEnv expr
+visitExpression mid aEnv (Apply expr1 expr2)
+   = foldl (visitExpression mid) aEnv [expr1,expr2]
+visitExpression mid aEnv (InfixApply expr1 _ expr2)
+   = foldl (visitExpression mid) aEnv [expr1,expr2]
+visitExpression mid aEnv (LeftSection expr _)
+   = visitExpression mid aEnv expr
+visitExpression mid aEnv (RightSection _ expr)
+   = visitExpression mid aEnv expr
+visitExpression mid aEnv (Lambda _ _ expr)
+   = visitExpression mid aEnv expr
+visitExpression mid aEnv (Let decls expr)
+   = foldl (visitDecl mid) (visitExpression mid aEnv expr) decls
+visitExpression mid aEnv (Do stmts expr)
+   = foldl (visitStatement mid) (visitExpression mid aEnv expr) stmts
+visitExpression mid aEnv (IfThenElse _ expr1 expr2 expr3)
+   = foldl (visitExpression mid) aEnv [expr1,expr2,expr3]
+visitExpression mid aEnv (Case _ expr alts)
+   = visitExpression mid (foldl (visitAlt mid) aEnv alts) expr
+visitExpression _ aEnv _ = aEnv
+
+
+visitStatement :: ModuleIdent -> ArityEnv -> Statement -> ArityEnv
+visitStatement mid aEnv (StmtExpr _ expr)
+   = visitExpression mid aEnv expr
+visitStatement mid aEnv (StmtDecl decls)
+   = foldl (visitDecl mid) aEnv decls
+visitStatement mid aEnv (StmtBind _ _ expr)
+   = visitExpression mid aEnv expr
+
+
+visitAlt :: ModuleIdent -> ArityEnv -> Alt -> ArityEnv
+visitAlt mid aEnv (Alt _ _ rhs)
+   = visitRhs mid aEnv rhs
+
+
+
+-------------------------------------------------------------------------------
+
+-- Computes the function arity using a type expression
+typeArity :: TypeExpr -> Int
+typeArity (ArrowType _ t2) = 1 + typeArity t2
+typeArity _                = 0
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/Base.lhs b/src/Base.lhs
new file mode 100644
--- /dev/null
+++ b/src/Base.lhs
@@ -0,0 +1,956 @@
+% $Id: Base.lhs,v 1.77 2004/02/15 22:10:25 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{Base.lhs}
+\section{Common Definitions for the Compiler}
+The module \texttt{Base} provides common definitions for the various 
+phases of the compiler.
+\begin{verbatim}
+
+> module Base(module Base,module Ident,module Position,module Types,
+>             module CurrySyntax) where
+
+> import Data.List
+> import Control.Monad
+> import Data.Maybe
+
+> import Ident 
+> import Position
+> import Types
+> import CurrySyntax
+> import CurryPP
+> import Pretty
+> import ExtendedFlat hiding (SrcRef, Fixity(..), TypeExpr, Expr(..))
+> import Env
+> import TopEnv
+> import Map
+> import Set
+> import Utils
+
+
+> import qualified ExtendedFlat as EF 
+
+\end{verbatim}
+\paragraph{Types}
+The functions \texttt{toType}, \texttt{toTypes}, and \texttt{fromType}
+convert Curry type expressions into types and vice versa. The
+functions \texttt{qualifyType} and \texttt{unqualifyType} add and
+remove module qualifiers in a type, respectively.
+
+When Curry type expression are converted with \texttt{toType} or
+\texttt{toTypes}, type variables are assigned ascending indices in the
+order of their occurrence. It is possible to pass a list of additional
+type variables to both functions which are assigned indices before
+those variables occurring in the type. This allows preserving the
+order of type variables in the left hand side of a type declaration.
+\begin{verbatim}
+
+> toQualType :: ModuleIdent -> [Ident] -> TypeExpr -> Type
+> toQualType m tvs ty = qualifyType m (toType tvs ty)
+
+> toQualTypes :: ModuleIdent -> [Ident] -> [TypeExpr] -> [Type]
+> toQualTypes m tvs tys = map (qualifyType m) (toTypes tvs tys)
+
+> toType :: [Ident] -> TypeExpr -> Type
+> toType tvs ty = toType' (fromListFM (zip (tvs ++ tvs') [0..])) ty
+>   where tvs' = [tv | tv <- nub (fv ty), tv `notElem` tvs]
+
+> toTypes :: [Ident] -> [TypeExpr] -> [Type]
+> toTypes tvs tys = map (toType' (fromListFM (zip (tvs ++ tvs') [0..]))) tys
+>   where tvs' = [tv | tv <- nub (concatMap fv tys), tv `notElem` tvs]
+
+> toType' :: FM Ident Int -> TypeExpr -> Type
+> toType' tvs (ConstructorType tc tys) =
+>   TypeConstructor tc (map (toType' tvs) tys)
+> toType' tvs (VariableType tv) =
+>   maybe (internalError ("toType " ++ show tv)) TypeVariable (lookupFM tv tvs)
+> toType' tvs (TupleType tys)
+>   | null tys = TypeConstructor (qualify unitId) []
+>   | otherwise = TypeConstructor (qualify (tupleId (length tys'))) tys'
+>   where tys' = map (toType' tvs) tys
+> toType' tvs (ListType ty) = TypeConstructor (qualify listId) [toType' tvs ty]
+> toType' tvs (ArrowType ty1 ty2) =
+>   TypeArrow (toType' tvs ty1) (toType' tvs ty2)
+> toType' tvs (RecordType fs rty) =
+>   TypeRecord (concatMap (\ (ls,ty) -> map (\l -> (l, toType' tvs ty)) ls) fs)
+>              (maybe Nothing 
+>	              (\ty -> case toType' tvs ty of
+>	                        TypeVariable tv -> Just tv 
+>	                        _ -> internalError ("toType " ++ show ty))
+>	              rty)
+
+> qualifyType :: ModuleIdent -> Type -> Type
+> qualifyType m (TypeConstructor tc tys)
+>   | isTupleId tc' = tupleType tys'
+>   | tc' == unitId && n == 0 = unitType
+>   | tc' == listId && n == 1 = listType (head tys')
+>   | otherwise = TypeConstructor (qualQualify m tc) tys'
+>   where n = length tys'
+>         tc' = unqualify tc
+>         tys' = map (qualifyType m) tys
+> qualifyType _ (TypeVariable tv) = TypeVariable tv
+> qualifyType m (TypeConstrained tys tv) =
+>   TypeConstrained (map (qualifyType m) tys) tv
+> qualifyType m (TypeArrow ty1 ty2) =
+>   TypeArrow (qualifyType m ty1) (qualifyType m ty2)
+> qualifyType _ (TypeSkolem k) = TypeSkolem k
+> qualifyType m (TypeRecord fs rty) =
+>   TypeRecord (map (\ (l,ty) -> (l, qualifyType m ty)) fs) rty
+
+> fromQualType :: ModuleIdent -> Type -> TypeExpr
+> fromQualType m ty = fromType (unqualifyType m ty)
+
+> fromType :: Type -> TypeExpr
+> fromType (TypeConstructor tc tys)
+>   | isTupleId c = TupleType tys'
+>   | c == listId && length tys == 1 = ListType (head tys')
+>   | c == unitId && null tys = TupleType []
+>   | otherwise = ConstructorType tc tys'
+>   where c = unqualify tc
+>         tys' = map (fromType) tys
+> fromType (TypeVariable tv) =
+>   VariableType (if tv >= 0 then nameSupply !! tv
+>                            else mkIdent ('_' : show (-tv)))
+> fromType (TypeConstrained tys _) = fromType (head tys)
+> fromType (TypeArrow ty1 ty2) = ArrowType (fromType ty1) (fromType ty2)
+> fromType (TypeSkolem k) = VariableType (mkIdent ("_?" ++ show k))
+> fromType (TypeRecord fs rty) = 
+>   RecordType (map (\ (l,ty) -> ([l], fromType ty)) fs)
+>              (maybe Nothing (Just . fromType . TypeVariable) rty)
+
+> unqualifyType :: ModuleIdent -> Type -> Type
+> unqualifyType m (TypeConstructor tc tys) =
+>   TypeConstructor (qualUnqualify m tc) (map (unqualifyType m) tys)
+> unqualifyType _ (TypeVariable tv) = TypeVariable tv
+> unqualifyType m (TypeConstrained tys tv) =
+>   TypeConstrained (map (unqualifyType m) tys) tv
+> unqualifyType m (TypeArrow ty1 ty2) =
+>   TypeArrow (unqualifyType m ty1) (unqualifyType m ty2)
+> unqualifyType m (TypeSkolem k) = TypeSkolem k
+> unqualifyType m (TypeRecord fs rty) =
+>   TypeRecord (map (\ (l,ty) -> (l, unqualifyType m ty)) fs) rty
+
+\end{verbatim}
+The following functions implement pretty-printing for types.
+\begin{verbatim}
+
+> ppType :: ModuleIdent -> Type -> Doc
+> ppType m = ppTypeExpr 0 . fromQualType m
+
+> ppTypeScheme :: ModuleIdent -> TypeScheme -> Doc
+> ppTypeScheme m (ForAll _ ty) = ppType m ty
+
+\end{verbatim}
+\paragraph{Interfaces}
+The compiler maintains a global environment holding all (directly or
+indirectly) imported interfaces.
+
+The function \texttt{bindFlatInterfac} transforms FlatInterface
+information (type \texttt{FlatCurry.Prog} to MCC interface declarations
+(type \texttt{CurrySyntax.IDecl}. This is necessary to process
+FlatInterfaces instead of ".icurry" files when using MCC as frontend
+for PAKCS.
+\begin{verbatim}
+
+> type ModuleEnv = Env ModuleIdent [IDecl]
+
+> bindModule :: Interface -> ModuleEnv -> ModuleEnv
+> bindModule (Interface m ds) = bindEnv m ds
+
+> bindFlatInterface :: Prog -> ModuleEnv -> ModuleEnv
+> bindFlatInterface (Prog m imps ts fs os)
+>    = bindModule (Interface (mkMIdent [m])
+>	                     ((map genIImportDecl imps)
+>		              ++ (map genITypeDecl ts')
+>		              ++ (map genIFuncDecl fs)
+>		              ++ (map genIOpDecl os)))
+>  where
+>  genIImportDecl :: String -> IDecl
+>  genIImportDecl imp = IImportDecl pos (mkMIdent [imp])
+>
+>  genITypeDecl :: TypeDecl -> IDecl
+>  genITypeDecl (Type qn _ is cs)
+>     | recordExt `isPrefixOf` localName qn
+>       = ITypeDecl pos
+>                   (genQualIdent qn)
+>	            (map (genVarIndexIdent "a") is)
+>	            (RecordType (map genLabeledType cs) Nothing)
+>     | otherwise
+>       = IDataDecl pos 
+>                   (genQualIdent qn) 
+>                   (map (genVarIndexIdent "a") is) 
+>                   (map (Just . genConstrDecl) cs)
+>  genITypeDecl (TypeSyn qn _ is t)
+>     = ITypeDecl pos
+>                 (genQualIdent qn)
+>                 (map (genVarIndexIdent "a") is)
+>                 (genTypeExpr t)
+>
+>  genIFuncDecl :: FuncDecl -> IDecl
+>  genIFuncDecl (Func qn a _ t _) 
+>     = IFunctionDecl pos (genQualIdent qn) a (genTypeExpr t)
+>
+>  genIOpDecl :: OpDecl -> IDecl
+>  genIOpDecl (Op qn f p) = IInfixDecl pos (genInfix f) p  (genQualIdent qn)
+>
+>  genConstrDecl :: ConsDecl -> ConstrDecl
+>  genConstrDecl (Cons qn _ _ ts)
+>     = ConstrDecl pos [] (mkIdent (localName qn)) (map genTypeExpr ts)
+>
+>  genLabeledType :: EF.ConsDecl -> ([Ident],CurrySyntax.TypeExpr)
+>  genLabeledType (Cons qn _ _ [t])
+>     = ([renameLabel (fromLabelExtId (mkIdent $ localName qn))], genTypeExpr t)
+>
+>  genTypeExpr :: EF.TypeExpr -> CurrySyntax.TypeExpr
+>  genTypeExpr (TVar i)
+>     = VariableType (genVarIndexIdent "a" i)
+>  genTypeExpr (FuncType t1 t2) 
+>     = ArrowType (genTypeExpr t1) (genTypeExpr t2)
+>  genTypeExpr (TCons qn ts) 
+>     = ConstructorType (genQualIdent qn) (map genTypeExpr ts)
+>
+>  genInfix :: EF.Fixity -> Infix
+>  genInfix EF.InfixOp  = Infix
+>  genInfix EF.InfixlOp = InfixL
+>  genInfix EF.InfixrOp = InfixR
+>
+>  genQualIdent :: QName -> QualIdent
+>  genQualIdent QName{modName=mod,localName=name} = 
+>    qualifyWith (mkMIdent [mod]) (mkIdent name)
+>
+>  genVarIndexIdent :: String -> Int -> Ident
+>  genVarIndexIdent v i = mkIdent (v ++ show i)
+>
+>  isSpecialPreludeType :: TypeDecl -> Bool
+>  isSpecialPreludeType (Type QName{modName=mod,localName=name} _ _ _) 
+>     = (name == "[]" || name == "()") && mod == "Prelude"
+>  isSpecialPreludeType _ = False
+>
+>  pos = first m
+>  ts' = filter (not . isSpecialPreludeType) ts
+
+> lookupModule :: ModuleIdent -> ModuleEnv -> Maybe [IDecl]
+> lookupModule = lookupEnv
+
+\end{verbatim}
+The label environment is used to store information of labels.
+Unlike unsual identifiers like in functions, types etc. identifiers
+of labels are always represented unqualified. Since the common type 
+environment (type \texttt{ValueEnv}) has some problems with handling 
+imported unqualified identifiers, it is necessary to process the type 
+information for labels seperately.
+\begin{verbatim}
+
+> data LabelInfo = LabelType Ident QualIdent Type deriving Show
+
+> type LabelEnv = Env Ident [LabelInfo]
+
+> bindLabelType :: Ident -> QualIdent -> Type -> LabelEnv -> LabelEnv
+> bindLabelType l r ty lEnv =
+>   maybe (bindEnv l [LabelType l r ty] lEnv)
+>         (\ls -> bindEnv l ((LabelType l r ty):ls) lEnv)
+>         (lookupEnv l lEnv)
+
+> lookupLabelType :: Ident -> LabelEnv -> [LabelInfo]
+> lookupLabelType l lEnv = fromMaybe [] (lookupEnv l lEnv)
+
+> initLabelEnv :: LabelEnv
+> initLabelEnv = emptyEnv
+
+
+\end{verbatim}
+\paragraph{Type constructors}
+For all defined types the compiler must maintain kind information. At
+present, Curry does not support type classes. Therefore its type
+language is first order and the only information that must be recorded
+is the arity of each type. For algebraic data types and renaming types
+the compiler also records all data constructors belonging to that
+type, for alias types the type expression to be expanded is saved. In
+order to manage the import and export of types, the names of the
+original definitions are also recorded. On import two types are
+considered equal if their original names match.
+
+The information for a data constructor comprises the number of
+existentially quantified type variables and the list of the argument
+types. Note that renaming type constructors have only one type
+argument.
+
+Importing and exporting algebraic data types and renaming types is
+complicated by the fact that the constructors of the type may be
+(partially) hidden in the interface. This facilitates the definition
+of abstract data types. An abstract type is always represented as a
+data type without constructors in the interface regardless of whether
+it is defined as a data type or as a renaming type. When only some
+constructors of a data type are hidden, those constructors are
+replaced by underscores in the interface. Furthermore, if the
+right-most constructors of a data type are hidden, they are not
+exported at all in order to make the interface more stable against
+changes which are private to the module.
+\begin{verbatim}
+
+> data TypeInfo = DataType QualIdent Int [Maybe (Data [Type])]
+>               | RenamingType QualIdent Int (Data Type)
+>               | AliasType QualIdent Int Type
+>               deriving Show
+
+> data Data a = Data Ident Int a deriving Show
+
+> instance Entity TypeInfo where
+>   origName (DataType tc _ _) = tc
+>   origName (RenamingType tc _ _) = tc
+>   origName (AliasType tc _ _) = tc
+>   merge (DataType tc n cs) (DataType tc' _ cs')
+>     | tc == tc' = Just (DataType tc n (mergeData cs cs'))
+>     where mergeData ds [] = ds
+>           mergeData [] ds = ds
+>           mergeData (d:ds) (d':ds') = d `mplus` d' : mergeData ds ds'
+>   merge (DataType tc n _) (RenamingType tc' _ nc)
+>     | tc == tc' = Just (RenamingType tc n nc)
+>   merge (RenamingType tc n nc) (DataType tc' _ _)
+>     | tc == tc' = Just (RenamingType tc n nc)
+>   merge (RenamingType tc n nc) (RenamingType tc' _ _)
+>     | tc == tc' = Just (RenamingType tc n nc)
+>   merge (AliasType tc n ty) (AliasType tc' _ _)
+>     | tc == tc' = Just (AliasType tc n ty)
+>   merge _ _ = Nothing
+
+> tcArity :: TypeInfo -> Int
+> tcArity (DataType _ n _) = n
+> tcArity (RenamingType _ n _) = n
+> tcArity (AliasType _ n _) = n
+
+\end{verbatim}
+Types can only be defined on the top-level; no nested environments are
+needed for them. Tuple types must be handled as a special case because
+there is an infinite number of potential tuple types making it
+impossible to insert them into the environment in advance.
+\begin{verbatim}
+
+> type TCEnv = TopEnv TypeInfo
+
+> bindTypeInfo :: (QualIdent -> Int -> a -> TypeInfo) -> ModuleIdent
+>              -> Ident -> [Ident] -> a -> TCEnv -> TCEnv
+> bindTypeInfo f m tc tvs x 
+>   = bindTopEnv "Base.bindTypeInfo" tc t 
+>     . qualBindTopEnv "Base.bindTypeInfo" tc' t
+>   where tc' = qualifyWith m tc
+>         t = f tc' (length tvs) x
+
+> lookupTC :: Ident -> TCEnv -> [TypeInfo]
+> lookupTC tc tcEnv = lookupTopEnv tc tcEnv ++! lookupTupleTC tc
+
+> qualLookupTC :: QualIdent -> TCEnv -> [TypeInfo]
+> qualLookupTC tc tcEnv =
+>   qualLookupTopEnv tc tcEnv ++! lookupTupleTC (unqualify tc)
+
+> lookupTupleTC :: Ident -> [TypeInfo]
+> lookupTupleTC tc
+>   | isTupleId tc = [tupleTCs !! (tupleArity tc - 2)]
+>   | otherwise = []
+
+> tupleTCs :: [TypeInfo]
+> tupleTCs = map typeInfo tupleData
+>   where typeInfo (Data c _ tys) =
+>           DataType (qualifyWith preludeMIdent c) (length tys)
+>                    [Just (Data c 0 tys)]
+
+> tupleData :: [Data [Type]]
+> tupleData = [Data (tupleId n) 0 (take n tvs) | n <- [2..]]
+>   where tvs = map typeVar [0..]
+
+\end{verbatim}
+\paragraph{Function and constructor types}
+In order to test the type correctness of a module, the compiler needs
+to determine the type of every data constructor, function,
+variable, record and label in the module. 
+For the purpose of type checking there is no
+need for distinguishing between variables and functions. For all objects
+their original names and their types are saved. Functions also
+contain arity information. Labels currently contain the name of their
+defining record. On import two values
+are considered equal if their original names match.
+\begin{verbatim}
+
+> data ValueInfo = DataConstructor QualIdent ExistTypeScheme
+>                | NewtypeConstructor QualIdent ExistTypeScheme
+>                | Value QualIdent TypeScheme
+>	         | Label QualIdent QualIdent TypeScheme
+>	           -- Label <label> <record name> <type>
+>                deriving Show
+
+> instance Entity ValueInfo where
+>   origName (DataConstructor origName _) = origName
+>   origName (NewtypeConstructor origName _) = origName
+>   origName (Value origName _) = origName
+>   origName (Label origName _ _) = origName
+>   
+>   merge (Label l r ty) (Label l' r' ty')
+>     | l == l' && r == r' = Just (Label l r ty)
+>     | otherwise = Nothing
+>   merge x y
+>     | origName x == origName y = Just x
+>     | otherwise = Nothing
+
+
+\end{verbatim}
+Even though value declarations may be nested, the compiler uses only
+flat environments for saving type information. This is possible
+because all identifiers are renamed by the compiler. Here we need
+special cases for handling tuple constructors.
+
+\em{Note:} the function \texttt{qualLookupValue} has been extended to
+allow the usage of the qualified list constructor \texttt{(Prelude.:)}.
+\begin{verbatim}
+
+> type ValueEnv = TopEnv ValueInfo
+
+> bindGlobalInfo :: (QualIdent -> a -> ValueInfo) -> ModuleIdent -> Ident -> a
+>                -> ValueEnv -> ValueEnv
+> bindGlobalInfo f m c ty 
+>   = bindTopEnv "Base.bindGlobalInfo" c v 
+>     . qualBindTopEnv "Base.bindGlobalInfo" c' v
+>   where c' = qualifyWith m c
+>         v = f c' ty
+
+> bindFun :: ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv
+> bindFun m f ty tyEnv
+>   | uniqueId f == 0 
+>     = bindTopEnv "Base.bindFun" f v (qualBindTopEnv "Base.bindFun" f' v tyEnv)
+>   | otherwise = bindTopEnv "Base.bindFun" f v tyEnv
+>   where f' = qualifyWith m f
+>         v = Value f' ty
+
+> rebindFun :: ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv
+> rebindFun m f ty
+>   | uniqueId f == 0 = rebindTopEnv f v . qualRebindTopEnv f' v
+>   | otherwise = rebindTopEnv f v
+>   where f' = qualifyWith m f
+>         v = Value f' ty
+
+> bindLabel :: Ident -> QualIdent -> TypeScheme -> ValueEnv -> ValueEnv
+> bindLabel l r ty tyEnv = bindTopEnv "Base.bindLabel" l v tyEnv
+>   where v  = Label (qualify l) r ty
+
+> lookupValue :: Ident -> ValueEnv -> [ValueInfo]
+> lookupValue x tyEnv = lookupTopEnv x tyEnv ++! lookupTuple x
+
+> qualLookupValue :: QualIdent -> ValueEnv -> [ValueInfo]
+> qualLookupValue x tyEnv =
+>   qualLookupTopEnv x tyEnv 
+>   ++! qualLookupCons x tyEnv
+>   ++! lookupTuple (unqualify x)
+
+> qualLookupCons :: QualIdent -> ValueEnv -> [ValueInfo]
+> qualLookupCons x tyEnv
+>    | (maybe False ((==) preludeMIdent) mmid) && (id == consId)
+>       = qualLookupTopEnv (qualify id) tyEnv
+>    | otherwise = []
+>  where (mmid, id) = splitQualIdent x
+
+> lookupTuple :: Ident -> [ValueInfo]
+> lookupTuple c
+>   | isTupleId c = [tupleDCs !! (tupleArity c - 2)]
+>   | otherwise = []
+
+> tupleDCs :: [ValueInfo]
+> tupleDCs = map dataInfo tupleTCs
+>   where dataInfo (DataType tc tvs [Just (Data c _ tys)]) =
+>           DataConstructor (qualUnqualify preludeMIdent tc)
+>                           (ForAllExist (length tys) 0
+>                                        (foldr TypeArrow (tupleType tys) tys))
+
+\end{verbatim}
+\paragraph{Arity}
+In order to generate correct FlatCurry application it is necessary
+to define the number of arguments as the arity value (instead of
+using the arity computed from the type). For this reason the compiler
+needs a table containing the information for all known functions
+and constructors. 
+\begin{verbatim}
+
+> type ArityEnv = TopEnv ArityInfo
+
+> data ArityInfo = ArityInfo QualIdent Int deriving Show
+
+> instance Entity ArityInfo where
+>   origName (ArityInfo origName _) = origName
+
+> bindArity :: ModuleIdent -> Ident -> Int -> ArityEnv -> ArityEnv
+> bindArity mid id arity aEnv
+>    | uniqueId id == 0 
+>      = bindTopEnv "Base.bindArity" id arityInfo 
+>                   (qualBindTopEnv "Base.bindArity" qid arityInfo aEnv)
+>    | otherwise        
+>      = bindTopEnv "Base.bindArity" id arityInfo aEnv
+>  where
+>  qid = qualifyWith mid id
+>  arityInfo = ArityInfo qid arity
+
+> lookupArity :: Ident -> ArityEnv -> [ArityInfo]
+> lookupArity id aEnv = lookupTopEnv id aEnv ++! lookupTupleArity id
+
+> qualLookupArity :: QualIdent -> ArityEnv -> [ArityInfo]
+> qualLookupArity qid aEnv = qualLookupTopEnv qid aEnv
+>		             ++! qualLookupConsArity qid aEnv
+>			     ++! lookupTupleArity (unqualify qid)
+
+> qualLookupConsArity :: QualIdent -> ArityEnv -> [ArityInfo]
+> qualLookupConsArity qid aEnv
+>    | (maybe False ((==) preludeMIdent) mmid) && (id == consId)
+>      = qualLookupTopEnv (qualify id) aEnv
+>    | otherwise
+>      = []
+>  where (mmid, id) = splitQualIdent qid
+
+> lookupTupleArity :: Ident -> [ArityInfo]
+> lookupTupleArity id 
+>    | isTupleId id 
+>      = [ArityInfo (qualifyWith preludeMIdent id) (tupleArity id)]
+>    | otherwise
+>      = []
+
+\end{verbatim}
+\paragraph{Module alias}
+\begin{verbatim}
+
+> type ImportEnv = Env ModuleIdent ModuleIdent
+
+> bindAlias :: Decl -> ImportEnv -> ImportEnv
+> bindAlias (ImportDecl _ mid _ mmid _) iEnv
+>    = bindEnv mid (fromMaybe mid mmid) iEnv
+
+> lookupAlias :: ModuleIdent -> ImportEnv -> Maybe ModuleIdent
+> lookupAlias = lookupEnv
+
+> sureLookupAlias :: ModuleIdent -> ImportEnv -> ModuleIdent
+> sureLookupAlias m iEnv = fromMaybe m (lookupAlias m iEnv)
+
+
+\end{verbatim}
+\paragraph{Operator precedences}
+In order to parse infix expressions correctly, the compiler must know
+the precedence and fixity of each operator. Operator precedences are
+associated with entities and will be checked after renaming was
+applied. Nevertheless, we need to save precedences for ambiguous names
+in order to handle them correctly while computing the exported
+interface of a module.
+
+If no fixity is assigned to an operator, it will be given the default
+precedence 9 and assumed to be a left-associative operator.
+
+\em{Note:} this modified version uses Haskell type \texttt{Integer}
+for representing the precedence. This change had to be done due to the
+introduction of unlimited integer constants in the parser / lexer.
+\begin{verbatim}
+
+> data OpPrec = OpPrec Infix Integer deriving Eq
+
+> instance Show OpPrec where
+>   showsPrec _ (OpPrec fix p) = showString (assoc fix) . shows p
+>     where assoc InfixL = "left "
+>           assoc InfixR = "right "
+>           assoc Infix  = "non-assoc "
+
+> defaultP :: OpPrec
+> defaultP = OpPrec InfixL 9
+
+\end{verbatim}
+The lookup functions for the environment which maintains the operator
+precedences are simpler than for the type and value environments
+because they do not need to handle tuple constructors.
+\begin{verbatim}
+
+> data PrecInfo = PrecInfo QualIdent OpPrec deriving (Eq,Show)
+
+> instance Entity PrecInfo where
+>   origName (PrecInfo op _) = op
+
+> type PEnv = TopEnv PrecInfo
+
+> bindP :: ModuleIdent -> Ident -> OpPrec -> PEnv -> PEnv
+> bindP m op p
+>   | uniqueId op == 0 
+>     = bindTopEnv "Base.bindP" op info . qualBindTopEnv "Base.bindP" op' info
+>   | otherwise = bindTopEnv "Base.bindP" op info
+>   where op' = qualifyWith m op
+>         info = PrecInfo op' p
+
+> lookupP :: Ident -> PEnv -> [PrecInfo]
+> lookupP = lookupTopEnv
+
+> qualLookupP :: QualIdent -> PEnv -> [PrecInfo]
+> qualLookupP = qualLookupTopEnv
+
+\end{verbatim}
+\paragraph{Evaluation modes}
+The compiler has to collect the evaluation annotations for a program
+in an environment. As these annotations affect only local declarations,
+a flat environment mapping unqualified names onto annotations is
+sufficient.
+\begin{verbatim}
+
+> type EvalEnv = Env Ident EvalAnnotation
+
+> bindEval :: Ident -> EvalAnnotation -> EvalEnv -> EvalEnv
+> bindEval = bindEnv
+
+> lookupEval :: Ident -> EvalEnv -> Maybe EvalAnnotation
+> lookupEval f evEnv = lookupEnv f evEnv
+
+\end{verbatim}
+\paragraph{Predefined types}
+The list and unit data types must be predefined because their
+definitions
+\begin{verbatim}
+data () = ()
+data [] a = [] | a : [a]
+\end{verbatim}
+are not allowed by Curry's syntax. The corresponding types
+are available in the environments \texttt{initTCEnv} and
+\texttt{initDCEnv}. In addition, the precedence of the (infix) list
+constructor is available in the environment \texttt{initPEnv}.
+
+Note that only the unqualified names are predefined. This is correct,
+because neither \texttt{Prelude.()} nor \texttt{Prelude.[]} are valid
+identifiers.
+\begin{verbatim}
+
+> initPEnv :: PEnv
+> initPEnv =
+>   predefTopEnv qConsId (PrecInfo qConsId (OpPrec InfixR 5)) emptyTopEnv
+
+> initTCEnv :: TCEnv
+> initTCEnv = foldr (uncurry predefTC) emptyTopEnv predefTypes
+>   where a = typeVar 0
+>         predefTC (TypeConstructor tc tys) cs =
+>           predefTopEnv (qualify (unqualify tc))
+>                        (DataType tc (length tys) (map Just cs))
+
+> initDCEnv :: ValueEnv
+> initDCEnv =
+>   foldr (uncurry predefDC) emptyTopEnv
+>         [(c,constrType (polyType ty) n' tys)
+>         | (ty,cs) <- predefTypes, Data c n' tys <- cs]
+>   where primTypes = map snd (moduleImports preludeMIdent initTCEnv)
+>         predefDC c ty = predefTopEnv c' (DataConstructor c' ty)
+>           where c' = qualify c
+>         constrType (ForAll n ty) n' = ForAllExist n n' . foldr TypeArrow ty
+
+> initAEnv :: ArityEnv
+> initAEnv
+>    = foldr bindPredefArity emptyTopEnv (concatMap snd predefTypes)
+>  where
+>  bindPredefArity (Data id _ ts) aEnv
+>     = bindArity preludeMIdent id (length ts) aEnv
+
+> initIEnv :: ImportEnv
+> initIEnv = emptyEnv
+
+> predefTypes :: [(Type,[Data [Type]])]
+> predefTypes =
+>   let a = typeVar 0 in [
+>     (unitType,   [Data unitId 0 []]),
+>     (listType a, [Data nilId 0 [],Data consId 0 [a,listType a]])
+>   ]
+
+
+\end{verbatim}
+\paragraph{Free and bound variables}
+The compiler needs to compute the sets of free and bound variables for
+various different entities. We will devote three type classes to that
+purpose. The \texttt{QualExpr} class is expected to take into account
+that it is possible to use a qualified name to refer to a function
+defined in the current module and therefore \emph{M.x} and $x$, where
+$M$ is the current module name, should be considered the same name.
+However note that this is correct only after renaming all local
+definitions as \emph{M.x} always denotes an entity defined at the
+top-level.
+
+The \texttt{Decl} instance of \texttt{QualExpr} returns all free
+variables on the right hand side, regardless of whether they are bound
+on the left hand side. This is more convenient as declarations are
+usually processed in a declaration group where the set of free
+variables cannot be computed independently for each declaration. Also
+note that the operator in a unary minus expression is not a free
+variable. This operator always refers to a global function from the
+prelude.
+\begin{verbatim}
+
+> class Expr e where
+>   fv :: e -> [Ident]
+> class QualExpr e where
+>   qfv :: ModuleIdent -> e -> [Ident]
+> class QuantExpr e where
+>   bv :: e -> [Ident]
+
+> instance Expr e => Expr [e] where
+>   fv = concat . map fv
+> instance QualExpr e => QualExpr [e] where
+>   qfv m = concat . map (qfv m)
+> instance QuantExpr e => QuantExpr [e] where
+>   bv = concat . map bv
+
+> instance QualExpr Decl where
+>   qfv m (FunctionDecl _ _ eqs) = qfv m eqs
+>   qfv m (PatternDecl _ _ rhs) = qfv m rhs
+>   qfv _ _ = []
+
+> instance QuantExpr Decl where
+>   bv (TypeSig _ vs _) = vs
+>   bv (EvalAnnot _ fs _) = fs
+>   bv (FunctionDecl _ f _) = [f]
+>   bv (ExternalDecl _ _ _ f _) = [f]
+>   bv (FlatExternalDecl _ fs) = fs
+>   bv (PatternDecl _ t _) = bv t
+>   bv (ExtraVariables _ vs) = vs
+>   bv _ = []
+
+> instance QualExpr Equation where
+>   qfv m (Equation _ lhs rhs) = filterBv lhs (qfv m lhs ++ qfv m rhs)
+
+> instance QuantExpr Lhs where
+>   bv = bv . snd . flatLhs
+
+> instance QualExpr Lhs where
+>   qfv m lhs = qfv m (snd (flatLhs lhs))
+
+> instance QualExpr Rhs where
+>   qfv m (SimpleRhs _ e ds) = filterBv ds (qfv m e ++ qfv m ds)
+>   qfv m (GuardedRhs es ds) = filterBv ds (qfv m es ++ qfv m ds)
+
+> instance QualExpr CondExpr where
+>   qfv m (CondExpr _ g e) = qfv m g ++ qfv m e
+
+> instance QualExpr Expression where
+>   qfv _ (Literal _) = []
+>   qfv m (Variable v) = maybe [] return (localIdent m v)
+>   qfv _ (Constructor _) = []
+>   qfv m (Paren e) = qfv m e
+>   qfv m (Typed e _) = qfv m e
+>   qfv m (Tuple _ es) = qfv m es
+>   qfv m (List _ es) = qfv m es
+>   qfv m (ListCompr _ e qs) = foldr (qfvStmt m) (qfv m e) qs
+>   qfv m (EnumFrom e) = qfv m e
+>   qfv m (EnumFromThen e1 e2) = qfv m e1 ++ qfv m e2
+>   qfv m (EnumFromTo e1 e2) = qfv m e1 ++ qfv m e2
+>   qfv m (EnumFromThenTo e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
+>   qfv m (UnaryMinus _ e) = qfv m e
+>   qfv m (Apply e1 e2) = qfv m e1 ++ qfv m e2
+>   qfv m (InfixApply e1 op e2) = qfv m op ++ qfv m e1 ++ qfv m e2
+>   qfv m (LeftSection e op) = qfv m op ++ qfv m e
+>   qfv m (RightSection op e) = qfv m op ++ qfv m e
+>   qfv m (Lambda _ ts e) = filterBv ts (qfv m e)
+>   qfv m (Let ds e) = filterBv ds (qfv m ds ++ qfv m e)
+>   qfv m (Do sts e) = foldr (qfvStmt m) (qfv m e) sts
+>   qfv m (IfThenElse _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
+>   qfv m (Case _ e alts) = qfv m e ++ qfv m alts
+>   qfv m (RecordConstr fs) = qfv m fs
+>   qfv m (RecordSelection e _) = qfv m e
+>   qfv m (RecordUpdate fs e) = qfv m e ++ qfv m fs
+
+> qfvStmt :: ModuleIdent -> Statement -> [Ident] -> [Ident]
+> qfvStmt m st fvs = qfv m st ++ filterBv st fvs
+
+> instance QualExpr Statement where
+>   qfv m (StmtExpr _ e) = qfv m e
+>   qfv m (StmtDecl ds) = filterBv ds (qfv m ds)
+>   qfv m (StmtBind _ t e) = qfv m e
+
+> instance QualExpr Alt where
+>   qfv m (Alt _ t rhs) = filterBv t (qfv m rhs)
+
+> instance QuantExpr a => QuantExpr (Field a) where
+>   bv (Field _ _ t) = bv t
+
+> instance QualExpr a => QualExpr (Field a) where
+>   qfv m (Field _ _ t) = qfv m t
+
+> instance QuantExpr Statement where
+>   bv (StmtExpr _ e) = []
+>   bv (StmtBind _ t e) = bv t
+>   bv (StmtDecl ds) = bv ds
+
+> instance QualExpr InfixOp where
+>   qfv m (InfixOp op) = qfv m (Variable op)
+>   qfv _ (InfixConstr _) = []
+
+> instance QuantExpr ConstrTerm where
+>   bv (LiteralPattern _) = []
+>   bv (NegativePattern _ _) = []
+>   bv (VariablePattern v) = [v]
+>   bv (ConstructorPattern c ts) = bv ts
+>   bv (InfixPattern t1 op t2) = bv t1 ++ bv t2
+>   bv (ParenPattern t) = bv t
+>   bv (TuplePattern _ ts) = bv ts
+>   bv (ListPattern _ ts) = bv ts
+>   bv (AsPattern v t) = v : bv t
+>   bv (LazyPattern _ t) = bv t
+>   bv (FunctionPattern f ts) = bvFuncPatt (FunctionPattern f ts)
+>   bv (InfixFuncPattern t1 op t2) = bvFuncPatt (InfixFuncPattern t1 op t2)
+>   bv (RecordPattern fs r) = (maybe [] bv r) ++ bv fs
+
+> instance QualExpr ConstrTerm where
+>   qfv _ (LiteralPattern _) = []
+>   qfv _ (NegativePattern _ _) = []
+>   qfv _ (VariablePattern _) = []
+>   qfv m (ConstructorPattern _ ts) = qfv m ts
+>   qfv m (InfixPattern t1 _ t2) = qfv m [t1,t2]
+>   qfv m (ParenPattern t) = qfv m t
+>   qfv m (TuplePattern _ ts) = qfv m ts
+>   qfv m (ListPattern _ ts) = qfv m ts
+>   qfv m (AsPattern _ ts) = qfv m ts
+>   qfv m (LazyPattern _ t) = qfv m t
+>   qfv m (FunctionPattern f ts) 
+>     = (maybe [] return (localIdent m f)) ++ qfv m ts
+>   qfv m (InfixFuncPattern t1 op t2) 
+>     = (maybe [] return (localIdent m op)) ++ qfv m [t1,t2]
+>   qfv m (RecordPattern fs r) = (maybe [] (qfv m) r) ++ qfv m fs
+
+> instance Expr TypeExpr where
+>   fv (ConstructorType _ tys) = fv tys
+>   fv (VariableType tv)
+>     | tv == anonId = []
+>     | otherwise = [tv]
+>   fv (TupleType tys) = fv tys
+>   fv (ListType ty) = fv ty
+>   fv (ArrowType ty1 ty2) = fv ty1 ++ fv ty2
+>   fv (RecordType fs rty) = (maybe [] fv rty) ++ fv (map snd fs)
+
+> filterBv :: QuantExpr e => e -> [Ident] -> [Ident]
+> filterBv e = filter (`notElemSet` fromListSet (bv e))
+
+\end{verbatim}
+Since multiple variable occurrences are allowed in function patterns,
+it is necessary to compute the list of bound variables in a different way:
+Each variable occuring in the function pattern will be unique in the result
+list.
+\begin{verbatim}
+
+> bvFuncPatt :: ConstrTerm -> [Ident]
+> bvFuncPatt = bvfp []
+>  where
+>  bvfp bvs (LiteralPattern _) = bvs
+>  bvfp bvs (NegativePattern _ _) = bvs
+>  bvfp bvs (VariablePattern v)
+>     | elem v bvs = bvs
+>     | otherwise  = v:bvs
+>  bvfp bvs (ConstructorPattern c ts) = foldl bvfp bvs ts
+>  bvfp bvs (InfixPattern t1 op t2) = foldl bvfp bvs [t1,t2]
+>  bvfp bvs (ParenPattern t) = bvfp bvs t
+>  bvfp bvs (TuplePattern _ ts) = foldl bvfp bvs ts
+>  bvfp bvs (ListPattern _ ts) = foldl bvfp bvs ts
+>  bvfp bvs (AsPattern v t)
+>     | elem v bvs = bvfp bvs t
+>     | otherwise  = bvfp (v:bvs) t
+>  bvfp bvs (LazyPattern _ t) = bvfp bvs t
+>  bvfp bvs (FunctionPattern f ts) = foldl bvfp bvs ts
+>  bvfp bvs (InfixFuncPattern t1 op t2) = foldl bvfp bvs [t1, t2]
+>  bvfp bvs (RecordPattern fs r)
+>     = foldl bvfp (maybe bvs (bvfp bvs) r) (map fieldTerm fs)
+
+\end{verbatim}
+\paragraph{Miscellany}
+Error handling
+\begin{verbatim}
+
+> errorAt :: Position -> String -> a
+> errorAt p msg = error ("\n" ++ show p ++ ": " ++ msg)
+
+> errorAt' :: (Position,String) -> a
+> errorAt' = uncurry errorAt
+
+> internalError :: String -> a
+> internalError what = error ("internal error: " ++ what)
+
+\end{verbatim}
+Name supply for the generation of (type) variable names.
+\begin{verbatim}
+
+> nameSupply :: [Ident]
+> nameSupply = map mkIdent [c:showNum i | i <- [0..], c <- ['a'..'z']]
+>   where showNum 0 = ""
+>         showNum n = show n
+
+\end{verbatim}
+\ToDo{The \texttt{nameSupply} should respect the current case mode, 
+i.e., use upper case for variables in Prolog mode.}
+
+Here is a list of predicates identifying various kinds of
+declarations.
+\begin{verbatim}
+
+> isImportDecl, isInfixDecl, isTypeDecl :: Decl -> Bool
+> isTypeSig, isEvalAnnot, isExtraVariables, isValueDecl :: Decl -> Bool
+> isImportDecl (ImportDecl _ _ _ _ _) = True
+> isImportDecl _ = False
+> isInfixDecl (InfixDecl _ _ _ _) = True
+> isInfixDecl _ = False
+> isTypeDecl (DataDecl _ _ _ _) = True
+> isTypeDecl (NewtypeDecl _ _ _ _) = True
+> isTypeDecl (TypeDecl _ _ _ _) = True
+> isTypeDecl _ = False
+> isTypeSig (TypeSig _ _ _) = True
+> isTypeSig (ExternalDecl _ _ _ _ _) = True
+> isTypeSig _ = False
+> isEvalAnnot (EvalAnnot _ _ _) = True
+> isEvalAnnot _ = False
+> isExtraVariables (ExtraVariables _ _) = True
+> isExtraVariables _ = False
+> isValueDecl (FunctionDecl _ _ _) = True
+> isValueDecl (ExternalDecl _ _ _ _ _) = True
+> isValueDecl (FlatExternalDecl _ _) = True
+> isValueDecl (PatternDecl _ _ _) = True
+> isValueDecl (ExtraVariables _ _) = True
+> isValueDecl _ = False
+> isRecordDecl (TypeDecl _ _ _ (RecordType _ _)) = True
+> isRecordDecl _ = False
+
+> isIImportDecl :: IDecl -> Bool
+> isIImportDecl (IImportDecl _ _) = True
+> isIImportDecl _ = False
+
+\end{verbatim}
+The function \texttt{infixOp} converts an infix operator into an
+expression.
+\begin{verbatim}
+
+> infixOp :: InfixOp -> Expression
+> infixOp (InfixOp op) = Variable op
+> infixOp (InfixConstr op) = Constructor op
+
+\end{verbatim}
+The function \texttt{linear} checks whether a list of entities is
+linear, i.e., if every entity in the list occurs only once. If it is
+non-linear, the first offending object is returned.
+\begin{verbatim}
+
+> data Linear a = Linear | NonLinear a
+
+> linear :: Eq a => [a] -> Linear a
+> linear (x:xs)
+>   | x `elem` xs = NonLinear x
+>   | otherwise = linear xs
+> linear [] = Linear
+
+\end{verbatim}
+In order to give precise error messages on duplicate definitions of
+identifiers, the compiler pairs identifiers with their position in the
+source file when passing them to the function above. However, the
+position must be ignored when comparing two such pairs.
+\begin{verbatim}
+
+> data PIdent = PIdent Position Ident
+
+> instance Eq PIdent where
+>   PIdent _ x == PIdent _ y = x == y
+
+\end{verbatim}
+
+
+
+
+
diff --git a/src/CaseCompletion.hs b/src/CaseCompletion.hs
new file mode 100644
--- /dev/null
+++ b/src/CaseCompletion.hs
@@ -0,0 +1,661 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- CaseCompletion - expands case branches with missing constructors
+--
+-- The MMC translates case expressions into the intermediate language
+-- representation (IL) without completing them (i.e. without generating
+-- case branches for missing contructors). Because they are necessary for
+-- the PAKCS back end this module expands all case expressions accordingly.
+--
+-- May 2005,
+-- Martin Engelke, (men@informatik.uni-kiel.de)
+-- 
+module CaseCompletion (completeCase) where
+
+import Data.Maybe
+
+import qualified CurrySyntax
+import Base (ModuleEnv, lookupModule)
+import IL
+import Ident
+import Position (SrcRef)
+import OldScopeEnv as ScopeEnv
+import ILScope
+
+
+
+-------------------------------------------------------------------------------
+
+-- Completes case expressions by adding branches for missing constructors.
+-- The module environment 'menv' is needed to compute these constructors.
+--
+-- Call:
+--      completeCase <module environment>
+--                   <IL module>
+--
+completeCase :: ModuleEnv -> Module -> Module
+completeCase menv mod = let (mod', _) = visitModule menv mod in mod'
+
+
+-------------------------------------------------------------------------------
+-- The following functions run through an IL term searching for
+-- case expressions
+
+--
+visitModule :: ModuleEnv -> Module -> (Module, [Message])
+visitModule menv (Module mident imports decls)
+   = ((Module mident (insertUnique preludeMIdent imports) decls'), msgs')
+ where
+   (decls', msgs') = visitList (visitDecl (Module mident imports decls) menv)
+		               insertDeclScope
+			       []
+			       (getModuleScope (Module mident imports decls))
+			       decls
+
+
+--
+visitDecl :: Module -> ModuleEnv -> [Message] -> ScopeEnv -> Decl
+	     -> (Decl, [Message])
+visitDecl mod menv msgs senv (DataDecl qident arity cdecls)
+   = ((DataDecl qident arity cdecls), msgs)
+
+visitDecl mod menv msgs senv (NewtypeDecl qident arity cdecl)
+   = ((NewtypeDecl qident arity cdecl), msgs)
+
+visitDecl mod menv msgs senv (FunctionDecl qident params typeexpr expr)
+   = ((FunctionDecl qident params typeexpr expr'), msgs)
+ where
+   (expr', msgs',_) = visitExpr mod menv msgs (insertExprScope senv expr) expr
+
+visitDecl mod menv msgs senv (ExternalDecl qident cconv name typeexpr)
+   = ((ExternalDecl qident cconv name typeexpr), msgs)
+
+
+--
+visitExpr :: Module -> ModuleEnv -> [Message] -> ScopeEnv -> Expression 
+	     -> (Expression, [Message],ScopeEnv)
+visitExpr mod menv msgs senv (Literal lit) 
+   = ((Literal lit), msgs, senv)
+
+visitExpr mod menv msgs senv (Variable ident) 
+   = ((Variable ident), msgs, senv)
+
+visitExpr mod menv msgs senv (Function qident arity) 
+   = ((Function qident arity), msgs, senv)
+
+visitExpr mod menv msgs senv (Constructor qident arity)
+   = ((Constructor qident arity), msgs, senv)
+
+visitExpr mod menv msgs senv (Apply expr1 expr2)
+   = ((Apply expr1' expr2'), msgs2, senv2)
+ where
+   (expr1', msgs1, senv1) = visitExpr mod menv msgs (insertExprScope senv expr1) expr1
+   (expr2', msgs2, senv2) = visitExpr mod menv msgs1 (insertExprScope senv1 expr2) expr2
+
+visitExpr mod menv msgs senv (Case r evalannot expr alts)
+   | null altsR
+     = intError "visitExpr" "empty alternative list"
+   | evalannot == Flex   -- pattern matching causes flexible case expressions
+     = (Case r evalannot expr' altsR, msgs, senv1)
+   | isConstrAlt altR
+     = (expr2, msgs3, senv3)
+   | isLitAlt altR
+     = (completeLitAlts r evalannot expr' altsR, msgs3, senv2)
+   | isVarAlt altR
+     = (completeVarAlts expr' altsR, msgs3, senv2)
+   | otherwise 
+     = intError "visitExpr" "illegal alternative list"
+ where
+   altR           = head altsR
+   (expr', msgs1, senv1) = visitExpr mod menv msgs (insertExprScope senv expr) expr
+   (alts', msgs2, senv2) = visitListWithEnv (visitAlt mod menv) insertAltScope msgs senv1 alts
+   (altsR, msgs3) = removeRedundantAlts msgs alts'
+   (expr2, senv3) = completeConsAlts r mod menv senv2 evalannot expr' altsR
+
+visitExpr mod menv msgs senv (Or expr1 expr2)
+   = ((Or expr1' expr2'), msgs2, senv3)
+ where
+   (expr1', msgs1, senv2) = visitExpr mod menv msgs (insertExprScope senv expr1) expr1
+   (expr2', msgs2, senv3) = visitExpr mod menv msgs1 (insertExprScope senv2 expr2) expr2
+
+visitExpr mod menv msgs senv (Exist ident expr)
+   = ((Exist ident expr'), msgs', senv2)
+ where
+   (expr', msgs', senv2) = visitExpr mod menv msgs (insertExprScope senv expr) expr
+
+visitExpr mod menv msgs senv (Let bind expr)
+   = ((Let bind' expr'), msgs2, senv3)
+ where
+   (expr', msgs1, senv2) = visitExpr mod menv msgs (insertExprScope senv expr) expr
+   (bind', msgs2, senv3) = visitBinding mod menv msgs (insertBindingScope senv2 bind) bind
+
+visitExpr mod menv msgs senv (Letrec binds expr)
+   = ((Letrec binds' expr'), msgs2, senv3)
+ where
+   (expr', msgs1, senv2)  = visitExpr mod menv msgs (insertExprScope senv expr) expr
+   (binds', msgs2, senv3) = visitListWithEnv (visitBinding mod menv)
+		               const
+			       msgs1
+			       (foldl insertBindingScope senv2 binds)
+			       binds
+
+
+--
+visitAlt :: Module -> ModuleEnv -> [Message] -> ScopeEnv -> Alt 
+	    -> (Alt, [Message], ScopeEnv)
+visitAlt mod menv msgs senv (Alt pattern expr)
+   = ((Alt pattern expr'), msgs', senv2)
+ where
+   (expr', msgs', senv2) = visitExpr mod menv msgs (insertExprScope senv expr) expr
+
+
+--
+visitBinding :: Module -> ModuleEnv -> [Message] -> ScopeEnv -> Binding 
+	        -> (Binding, [Message], ScopeEnv)
+visitBinding mod menv msgs senv (Binding ident expr)
+   = ((Binding ident expr'), msgs', senv2)
+ where
+   (expr', msgs', senv2) = visitExpr mod menv msgs (insertExprScope senv expr) expr
+
+
+--
+visitList :: ([Message] -> ScopeEnv -> a -> (a, [Message]))
+	     -> (ScopeEnv -> a -> ScopeEnv)
+	     -> [Message] -> ScopeEnv -> [a]
+	     -> ([a], [Message])
+visitList visitTerm insertScope msgs senv []
+   = ([], msgs)
+visitList visitTerm insertScope msgs senv (term:terms)
+   = ((term':terms'), msgs2)
+ where
+   (term', msgs1)  = visitTerm msgs (insertScope senv term) term
+   (terms', msgs2) = visitList visitTerm insertScope msgs1 senv terms
+
+visitListWithEnv :: ([Message] -> ScopeEnv -> a -> (a, [Message], ScopeEnv))
+	     -> (ScopeEnv -> a -> ScopeEnv)
+	     -> [Message] -> ScopeEnv -> [a]
+	     -> ([a], [Message], ScopeEnv)
+visitListWithEnv visitTerm insertScope msgs senv []
+   = ([], msgs, senv)
+visitListWithEnv visitTerm insertScope msgs senv (term:terms)
+   = ((term':terms'), msgs2, senv3)
+ where
+   (term', msgs1, senv2)  = visitTerm msgs (insertScope senv term) term
+   (terms', msgs2, senv3) = visitListWithEnv visitTerm insertScope msgs1 senv2 terms
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+-- Functions for completing case alternatives
+
+-- Completes a case alternative list which branches via constructor patterns
+-- by adding alternatives of the form
+--
+--      comp_pattern -> default_expr
+--
+-- where "comp_pattern" is a complementary constructor pattern and
+-- "default_expr" is the expression from the first alternative containing
+-- a variable pattern. If there is no such alternative the defualt expression
+-- is set to the prelude function 'failed'.
+--
+-- This funtions uses a scope environment ('ScopeEnv') to generate fresh
+-- variables for the arguments of the new constructors.
+--
+completeConsAlts :: SrcRef -> Module -> ModuleEnv -> ScopeEnv 
+		    -> Eval -> Expression -> [Alt]
+		    -> (Expression, ScopeEnv)
+completeConsAlts r mod menv senv evalannot expr alts
+   = (Case r evalannot expr (alts1 ++ alts2), senv2)
+ where
+   (Alt varpatt defaultexpr) = getDefaultAlt alts
+   (VariablePattern varid)   = varpatt
+   alts1       = filter isConstrAlt alts
+   constrs     = (map p_getConsAltIdent alts1)
+   cconsinfos  = getComplConstrs mod menv constrs
+   (cconstrs,senv2) = 
+                 foldr p_genConstrTerm
+                       ([],senv) 
+                       cconsinfos
+   alts2       = map (\cconstr -> 
+		      (Alt cconstr 
+		        (replaceVar varid (cterm2expr cconstr) defaultexpr))) 
+		     cconstrs
+
+   p_getConsAltIdent (Alt (ConstructorPattern qident _) _) = qident
+
+   p_genConstrTerm (qident, arity) (cconstrs,senv3) =
+       let args = ScopeEnv.genIdentList arity "x" senv3
+           senv4 = foldr ScopeEnv.insertIdent senv3 args
+       in (ConstructorPattern qident args : cconstrs, senv4)
+
+
+-- If the alternatives branches via literal pattern complementary
+-- constructor list cannot be generated because it would become infinite.
+-- So the function 'completeLitAlts' transforms case expressions like
+--      case <cexpr> of
+--        <lit_1> -> <expr_1>
+--        <lit_2> -> <expr_2>
+--                    :
+--        <lit_n> -> <expr_n>
+--       [<var>   -> <default_expr>]
+-- to 
+--      case (<cexpr> == <lit_1>) of
+--        True  -> <expr_1>
+--        False -> case (<cexpr> == <lit_2>) of
+--                   True  -> <expr_2>
+--                   False -> case ...
+--                                  :
+--                               -> case (<cexpr> == <lit_n>) of
+--                                    True  -> <expr_n>
+--                                    False -> <default_expr>
+--
+completeLitAlts :: SrcRef -> Eval -> Expression -> [Alt] -> Expression
+completeLitAlts r evalannot expr [] = failedExpr
+completeLitAlts r evalannot expr (alt:alts)
+   | isLitAlt alt 
+     = (Case r evalannot 
+	     (eqExpr expr (p_makeLitExpr alt))
+	     [(Alt truePatt  (getAltExpr alt)),
+	      (Alt falsePatt (completeLitAlts r evalannot expr alts))])
+   | otherwise
+     = case alt of
+         Alt (VariablePattern v) expr'
+	   -> replaceVar v expr expr'
+	 _ -> intError "completeLitAlts" "illegal alternative"
+ where
+   p_makeLitExpr alt
+      = case (getAltPatt alt) of
+	  LiteralPattern lit -> Literal lit
+	  _                  -> intError "completeLitAlts" 
+				         "literal pattern expected"
+
+
+-- For the unusual case of having only one alternative containing a variable
+-- pattern it is necessary to tranform it to a 'let' term because FlatCurry
+-- does not support variable patterns in case alternatives. So the
+-- case expression
+--      case <ce> of 
+--        x -> <expr>
+-- is transformed ot
+--      let x = <ce> in <expr>
+completeVarAlts :: Expression -> [Alt] -> Expression
+completeVarAlts expr [] = failedExpr
+completeVarAlts expr (alt:_)
+   = (Let (Binding (p_getVarIdent alt) expr) (getAltExpr alt))
+ where
+   p_getVarIdent alt
+      = case (getAltPatt alt) of
+	  VariablePattern ident -> ident
+	  _                     -> intError "completeVarAlts" 
+				            "variable pattern expected"
+
+
+-------------------------------------------------------------------------------
+-- The function 'removeRedundantAlts' removes case branches which are
+-- either idle (i.e. they will never be reached) or multiply declared.
+-- Note: unlike the PAKCS frontend MCC does not support warnings. So
+-- there will be no messages if alternatives have been removed.
+ 
+removeRedundantAlts :: [Message] -> [Alt] -> ([Alt], [Message])
+removeRedundantAlts msgs alts
+   = let
+         (alts1, msgs1) = removeIdleAlts msgs alts
+	 (alts2, msgs2) = removeMultipleAlts msgs1 alts1
+     in
+         (alts2, msgs2)
+
+
+-- An alternative is idle if it occurs anywehere behind another alternative 
+-- which contains a variable pattern. Example:
+--    case x of
+--      (y:ys) -> e1
+--      z      -> e2
+--      []     -> e3
+-- Here all alternatives behind (z  -> e2) are idle and will be removed.
+removeIdleAlts :: [Message] -> [Alt] -> ([Alt], [Message])
+removeIdleAlts msgs alts 
+   | null alts2 = (alts1, msgs)
+   | otherwise  = (alts1, msgs)
+ where
+   (alts1, alts2) = splitAfter isVarAlt alts
+
+
+-- An alternative occures multiply if at least two alternatives
+-- use the same pattern. Example:
+--    case x of
+--      []     -> e1
+--      (y:ys) -> e2
+--      []     -> e3
+-- Here the last alternative occures multiply because its pattern is already
+-- used in the first alternative. All multiple alternatives will be
+-- removed except for the first occurrence.
+removeMultipleAlts :: [Message] -> [Alt] -> ([Alt], [Message])
+removeMultipleAlts msgs alts
+   = p_remove msgs [] alts
+ where
+   p_remove msgs altsR []     = ((reverse altsR), msgs)
+   p_remove msgs altsR (alt:alts)
+      | p_containsAlt alt altsR = p_remove msgs altsR alts
+      | otherwise               = p_remove msgs (alt:altsR) alts
+
+   p_containsAlt alt alts = any (p_eqAlt alt) alts
+
+   p_eqAlt (Alt (LiteralPattern lit1) _) alt2
+      = case alt2 of
+	  (Alt (LiteralPattern lit2) _) -> lit1 == lit2
+	  _                             -> False
+   p_eqAlt (Alt (ConstructorPattern qident1 _) _) alt2
+      = case alt2 of
+	  (Alt (ConstructorPattern qident2 _) _) -> qident1 == qident2
+	  _                                      -> False
+   p_eqAlt (Alt (VariablePattern _) _) alt2
+      = case alt2 of
+	  (Alt (VariablePattern _) _) -> True
+	  _                           -> False
+
+
+-------------------------------------------------------------------------------
+-- Some functions for testing and extracting terms from case alternatives
+
+--
+isVarAlt :: Alt -> Bool
+isVarAlt alt = case (getAltPatt alt) of
+	         VariablePattern _ -> True
+		 _                 -> False
+
+--
+isConstrAlt :: Alt -> Bool
+isConstrAlt alt = case (getAltPatt alt) of
+		    ConstructorPattern _ _ -> True
+		    _                      -> False
+
+--
+isLitAlt :: Alt -> Bool
+isLitAlt alt = case (getAltPatt alt) of
+	         LiteralPattern _ -> True
+		 _                -> False
+
+
+--
+getAltExpr :: Alt -> Expression
+getAltExpr (Alt _ expr) = expr
+
+
+--
+getAltPatt :: Alt -> ConstrTerm
+getAltPatt (Alt cterm _) = cterm
+
+
+-- Note: the newly generated variable 'x!' is just a dummy and will never
+-- occur in the transformed program
+getDefaultAlt :: [Alt] -> Alt
+getDefaultAlt alts 
+   = fromMaybe (Alt (VariablePattern (mkIdent "x!")) failedExpr)
+               (find isVarAlt alts)
+
+
+-------------------------------------------------------------------------------
+-- This part of the module contains functions for replacing variables
+-- with expressions. This is necessary in the case of having a default 
+-- alternative like
+--      v -> <expr>
+-- where the variable v occurs in the default expression <expr>. When
+-- building additional alternatives for this default expression the variable
+-- must be replaced with the newly generated constructors.
+
+-- Call:
+--      replaceVar <variable id>
+--                 <replace-with expression>
+--                 <replace-in expression>
+--
+replaceVar :: Ident -> Expression -> Expression -> Expression
+replaceVar ident expr (Variable ident')
+   | ident == ident' = expr
+   | otherwise       = Variable ident'
+replaceVar ident expr (Apply expr1 expr2)
+   = Apply (replaceVar ident expr expr1) (replaceVar ident expr expr2)
+replaceVar ident expr (Case r eval expr' alts)
+   = Case r eval 
+          (replaceVar ident expr expr') 
+	  (map (replaceVarInAlt ident expr) alts)
+replaceVar ident expr (Or expr1 expr2)
+   = Or (replaceVar ident expr expr1) (replaceVar ident expr expr2)
+replaceVar ident expr (Exist ident' expr')
+   | ident == ident' = Exist ident' expr'
+   | otherwise       = Exist ident' (replaceVar ident expr expr')
+replaceVar ident expr (Let binding expr')
+   | varOccursInBinding ident binding
+     = Let binding expr'
+   | otherwise
+     = Let (replaceVarInBinding ident expr binding) 
+	   (replaceVar ident expr expr')
+replaceVar ident expr (Letrec bindings expr')
+   | any (varOccursInBinding ident) bindings
+     = Letrec bindings expr'
+   | otherwise
+     = Letrec (map (replaceVarInBinding ident expr) bindings)
+              (replaceVar ident expr expr')
+replaceVar _ _ expr'
+   = expr'
+
+
+--
+replaceVarInAlt :: Ident -> Expression -> Alt -> Alt
+replaceVarInAlt ident expr (Alt patt expr')
+   | varOccursInPattern ident patt 
+     = Alt patt expr'
+   | otherwise 
+     = Alt patt (replaceVar ident expr expr')
+
+
+--
+replaceVarInBinding :: Ident -> Expression -> Binding -> Binding
+replaceVarInBinding ident expr (Binding ident' expr')
+   | ident == ident' = Binding ident' expr'
+   | otherwise       = Binding ident' (replaceVar ident expr expr')
+
+
+--
+varOccursInPattern :: Ident -> ConstrTerm -> Bool
+varOccursInPattern ident (VariablePattern ident')
+   = ident == ident'
+varOccursInPattern ident (ConstructorPattern _ idents)
+   = elem ident idents
+varOccursInPattern _ _
+   = False
+
+
+--
+varOccursInBinding :: Ident -> Binding -> Bool
+varOccursInBinding ident (Binding ident' _)
+   = ident == ident'
+
+
+-------------------------------------------------------------------------------
+-- The following functions generate several IL expressions and patterns
+
+--
+failedExpr :: Expression
+failedExpr = Function (qualifyWith preludeMIdent (mkIdent "failed")) 0
+
+--
+eqExpr :: Expression -> Expression -> Expression
+eqExpr e1 e2 = Apply
+	         (Apply 
+		   (Function (qualifyWith preludeMIdent (mkIdent "==")) 2)
+		   e1)
+		 e2
+
+
+--
+truePatt :: ConstrTerm
+truePatt = ConstructorPattern qTrueId []
+
+--
+falsePatt :: ConstrTerm
+falsePatt = ConstructorPattern qFalseId []
+
+
+--
+cterm2expr :: ConstrTerm -> Expression
+cterm2expr (LiteralPattern lit) = Literal lit
+cterm2expr (ConstructorPattern qident args)
+   = p_genApplic (Constructor qident (length args)) args
+ where
+   p_genApplic expr []     = expr
+   p_genApplic expr (v:vs) = p_genApplic (Apply expr (Variable v)) vs
+cterm2expr (VariablePattern ident) = Variable ident
+
+
+
+-------------------------------------------------------------------------------
+-- The folowing functions compute the missing constructors for generating
+-- new case alternatives
+
+-- Computes the complementary constructors for a list of constructors. All
+-- specified constructors must have the same type.
+-- This functions uses the module environment 'menv' which contains all known
+-- constructors, except for those which are declared in the module and
+-- except for the list constructors.
+--
+-- Call:
+--      getComplConstr <IL module>
+--                     <module environment>
+--                     <list of (qualified) constructor ids>
+--
+getComplConstrs :: Module -> ModuleEnv -> [QualIdent] -> [(QualIdent, Int)]
+getComplConstrs (Module mid _ decls) menv constrs
+   | null constrs 
+     = intError "getComplConstrs" "empty constructor list"
+   | cons == qNilId || cons == qConsId
+     = getCC constrs [(qNilId, 0), (qConsId, 2)]
+   | mid' == mid
+     = getCCFromDecls mid constrs decls
+   | otherwise
+     = maybe [] -- error ...
+             (getCCFromIDecls mid' constrs) 
+	     (lookupModule mid' menv)
+ where
+   cons = head constrs
+   (mmid', _) = splitQualIdent cons
+   mid' = maybe mid id mmid'
+
+
+-- Find complementary constructors within the declarations of the
+-- current module
+getCCFromDecls :: ModuleIdent -> [QualIdent] -> [Decl] -> [(QualIdent, Int)]
+getCCFromDecls _ constrs decls
+   = let
+         cdecls = maybe [] -- error ...
+		        p_extractConstrDecls
+			(find (p_declaresConstr (head constrs)) decls)
+	 cinfos = map p_getConstrDeclInfo cdecls
+     in
+         getCC constrs cinfos
+ where
+   p_declaresConstr qident decl
+      = case decl of
+	  DataDecl _ _ cdecls   -> any (p_isConstrDecl qident) cdecls
+	  NewtypeDecl _ _ cdecl -> p_isConstrDecl qident cdecl
+	  _                     -> False
+
+   p_isConstrDecl qident (ConstrDecl qid _) = qident == qid
+
+   p_extractConstrDecls decl
+      = case decl of
+	  DataDecl _ _ cdecls   -> cdecls
+	  _                     -> []
+
+   p_getConstrDeclInfo (ConstrDecl qident types) = (qident, length types)
+
+
+-- Find complementary constructors within the module environment
+getCCFromIDecls :: ModuleIdent -> [QualIdent] -> [CurrySyntax.IDecl] 
+		   -> [(QualIdent, Int)]
+getCCFromIDecls mident constrs idecls
+   = let
+         cdecls = maybe [] -- error ...
+		        p_extractIConstrDecls
+		        (find (p_declaresIConstr (head constrs)) idecls)
+	 cinfos = map (p_getIConstrDeclInfo mident) cdecls
+     in
+         getCC constrs cinfos
+ where
+   p_declaresIConstr qident idecl
+      = case idecl of
+	  CurrySyntax.IDataDecl _ _ _ cdecls
+	      -> any (p_isIConstrDecl qident) 
+		     (map fromJust (filter isJust cdecls))
+	  CurrySyntax.INewtypeDecl _ _ _ ncdecl 
+	      -> p_isINewConstrDecl qident ncdecl
+	  _   -> False
+
+   p_isIConstrDecl qident (CurrySyntax.ConstrDecl _ _ ident _)
+      = (unqualify qident) == ident
+   p_isIConstrDecl qident (CurrySyntax.ConOpDecl _ _ _ ident _)
+      = (unqualify qident) == ident
+
+   p_isINewConstrDecl qident (CurrySyntax.NewConstrDecl _ _ ident _)
+      = (unqualify qident) == ident
+
+   p_extractIConstrDecls idecl
+      = case idecl of
+	  CurrySyntax.IDataDecl _ _ _ cdecls 
+	      -> map fromJust (filter isJust cdecls)
+	  _   -> []
+
+   p_getIConstrDeclInfo mid (CurrySyntax.ConstrDecl _ _ ident types)
+      = (qualifyWith mid ident, length types)
+   p_getIConstrDeclInfo mid (CurrySyntax.ConOpDecl _ _ _ ident _)
+      = (qualifyWith mid ident, 2)
+
+
+-- Compute complementary constructors
+getCC :: [QualIdent] -> [(QualIdent, Int)] -> [(QualIdent, Int)]
+getCC _ [] = []
+getCC constrs ((qident,arity):cis)
+   | any ((==) qident) constrs = getCC constrs cis
+   | otherwise                 = (qident,arity):(getCC constrs cis)
+
+
+-------------------------------------------------------------------------------
+-- Message handling
+-- Not in use in this version, but intended for further versions
+
+type Message = String
+
+
+-------------------------------------------------------------------------------
+-- Miscellaneous
+
+-- Splits a list behind the first element which satify 'cond'
+splitAfter :: (a -> Bool) -> [a] -> ([a], [a])
+splitAfter cond xs = p_splitAfter cond [] xs
+ where
+   p_splitAfter c fs []     = ((reverse fs),[])
+   p_splitAfter c fs (l:ls) | c l       = ((reverse (l:fs)), ls)
+			    | otherwise = p_splitAfter c (l:fs) ls
+
+
+-- Returns the first element which satisfy 'cond'. The returned element is
+-- embedded in a 'Maybe' term
+find :: (a -> Bool) -> [a] -> Maybe a
+find _    []     = Nothing
+find cond (x:xs) | cond x    = Just x
+		 | otherwise = find cond xs
+
+
+-- Prefixes an element to a list if it does not already exit within the
+-- list
+insertUnique :: Eq a => a -> [a] -> [a]
+insertUnique x xs | elem x xs = xs
+		  | otherwise = x:xs
+
+
+-- Raises an internal error
+intError :: String -> String -> a
+intError fun msg = error ("CaseCompletion." ++ fun ++ " - " ++ msg)
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/Combined.lhs b/src/Combined.lhs
new file mode 100644
--- /dev/null
+++ b/src/Combined.lhs
@@ -0,0 +1,299 @@
+% -*- LaTeX -*-
+% $Id: Combined.lhs,v 1.16 2003/05/07 22:38:37 wlux Exp $
+%
+% Copyright (c) 1998-2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Combined.lhs}
+\section{Combined monads}\label{sec:combined-monads}
+In this section we introduce combined monads which are parameterized
+by another monads. This technique has been explored
+in~\cite{KingWadler93:Combining} and very extensively
+in~\cite{LiangHudakJones95:ModInterp}. The monad transformers used in
+this report are mostly copied from the latter. Some restrictions were
+necessary because Haskell~98 does not support multi-parameter type
+classes. Especially, we cannot define generic lift operations because
+they have to be parameterized over two monad classes. In addition, we
+cannot define generic state and environment monad classes.
+\begin{verbatim}
+
+> module Combined where
+
+> import Control.Monad
+> import Data.IORef
+
+> import Error
+
+\end{verbatim}
+\subsection{Identity monad}
+The identity monad only serves as a base monad if no other monad --
+usually either \texttt{[]} or \texttt{IO} -- can be used. It allows to
+derive the usual -- i.e. unparameterized -- state and environment
+monads.
+
+Unfortunately, we cannot define \texttt{Id} as a \texttt{newtype}
+because of a bug in the nhc compiler.
+\begin{verbatim}
+
+> -- newtype Id a = Id a
+> data Id a = Id a
+
+> unId :: Id a -> a
+> unId (Id x) = x
+
+> instance Functor Id where
+>   fmap f (Id x) = Id (f x)
+
+> instance Monad Id where
+>   return x = Id x
+>   Id x >>= k = k x
+
+> callId :: Id a -> a
+> callId = unId
+
+\end{verbatim}
+\subsection{State transformers}
+The state transformer monad is defined as usual, except that the
+result of the state transformer function is itself a monad. The
+unparameterized version is defined by using the identity monad
+\texttt{Id} for the base monad.
+\begin{verbatim}
+
+> newtype StateT s m a = StateT (s -> m (a,s))
+> type St s a = StateT s Id a
+
+> unStateT :: StateT s m a -> (s -> m (a,s))
+> unStateT (StateT st) = st
+
+> instance Functor f => Functor (StateT s f) where
+>   fmap f (StateT st) = StateT (fmap (\(x,s') -> (f x,s')) . st)
+
+> instance Monad m => Monad (StateT s m) where
+>   return x = StateT (\s -> return (x,s))
+>   StateT st >>= f = StateT (\s -> st s >>= \(x,s') -> unStateT (f x) s')
+>   fail msg = StateT (const (fail msg))
+
+> instance MonadPlus m => MonadPlus (StateT s m) where
+>   mzero = StateT (const mzero)
+>   StateT st `mplus` StateT st' = StateT (\s -> st s `mplus` st' s)
+
+> liftSt :: Monad m => m a -> StateT s m a
+> liftSt m = StateT (\s -> m >>= \x -> return (x,s))
+
+> callSt :: Monad m => StateT s m a -> s -> m a
+> callSt (StateT st) s = st s >>= return . fst
+
+> runSt :: St s a -> s -> a
+> runSt st = callId . callSt st
+
+\end{verbatim}
+In addition to the standard monad functions, state monads should
+provide means to fetch and change the state. With multi-parameter type
+classes, one could use the following class:
+\begin{verbatim}
+
+class Monad m => StateMonad s m where
+  update :: (s -> s) -> m s
+  fetch :: m s
+  change :: s -> m s
+
+  fetch = update id
+  change = update . const
+
+instance Monad m => StateMonad s (StateT s m) where
+  update f = StateT (\s -> return (s,f s))
+
+\end{verbatim}
+Unfortunately multi-parameter type classes are not available in
+Haskell~98. Therefore we define the corresponding instance functions
+for each state monad class separately. Here are the functions for the
+state transformers.
+\begin{verbatim}
+
+> updateSt :: Monad m => (s -> s) -> StateT s m s
+> updateSt f = StateT (\s -> return (s,f s))
+
+> updateSt_ :: Monad m => (s -> s) -> StateT s m ()
+> updateSt_ f = StateT (\s -> return ((),f s))
+
+> fetchSt :: Monad m => StateT s m s
+> fetchSt = updateSt id
+
+> changeSt :: Monad m => s -> StateT s m s
+> changeSt = updateSt . const
+
+\end{verbatim}
+Currying and uncurrying for state monads has been implemented
+in~\cite{Fokker95:JPEG}. Here we extend this implementation to the
+parametric monad classes.
+\begin{verbatim}
+
+> stCurry :: Monad m => StateT (s,t) m a -> t -> StateT s m (t,a)
+> stCurry (StateT st) t =
+>   StateT (\s -> st (s,t) >>= \(x,(s',t')) -> return ((t',x),s'))
+
+> stUncurry :: Monad m => (t -> StateT s m (t,a)) -> StateT (s,t) m a
+> stUncurry f =
+>   StateT (\(s,t) -> let (StateT st) = f t
+>                     in st s >>= \((t',x),s') -> return (x,(s',t')))
+
+\end{verbatim}
+\subsection{Environment monad}
+A variant of the state transformer monad is the environment monad
+which is also known as (state) reader monad.
+\begin{verbatim}
+
+> data ReaderT r m a = ReaderT (r -> m a)
+> type Rt r a = ReaderT r Id a
+
+> unReaderT :: ReaderT r m a -> (r -> m a)
+> unReaderT (ReaderT rt) = rt
+
+> instance Functor f => Functor (ReaderT r f) where
+>   fmap f (ReaderT rt) = ReaderT (fmap f . rt)
+
+> instance Monad m => Monad (ReaderT r m) where
+>   return x = ReaderT (\_ -> return x)
+>   ReaderT rt >>= f = ReaderT (\r -> rt r >>= \x -> unReaderT (f x) r)
+>   fail msg = ReaderT (const (fail msg))
+
+> instance MonadPlus m => MonadPlus (ReaderT r m) where
+>   mzero = ReaderT (\_ -> mzero)
+>   ReaderT rt `mplus` ReaderT rt' = ReaderT (\r -> rt r `mplus` rt' r)
+
+> liftRt :: Monad m => m a -> ReaderT r m a
+> liftRt m = ReaderT (\_ -> m)
+
+> callRt :: ReaderT r m a -> r -> m a
+> callRt (ReaderT rt) r = rt r
+
+> runRt :: Rt r a -> r -> a
+> runRt rt = callId . callRt rt
+
+\end{verbatim}
+Similar to the state monad class, an environment monad class which
+provides functions to access the current state and to run an
+environment monad in a given state could be defined as follows:
+\begin{verbatim}
+
+class Monad m => EnvMonad r m where
+  env :: m r
+  putEnv :: r -> m a -> m a
+
+instance Monad m => EnvMonad r (ReaderT r m) where
+  env = ReaderT return
+  putEnv r (ReaderT rt) = ReaderT (\_ -> rt r)
+
+\end{verbatim}
+Again, this requires multi-parameter type classes; thus we define the
+appropriate instance functions for the type \texttt{ReaderT} instead.
+\begin{verbatim}
+
+> envRt :: Monad m => ReaderT r m r
+> envRt = ReaderT return 
+
+> putEnvRt :: Monad m => r -> ReaderT r m a -> ReaderT r m a
+> putEnvRt r (ReaderT rt) = ReaderT (\_ -> rt r)
+
+\end{verbatim}
+Currying can also be applied to state reader monads.
+\begin{verbatim}
+
+> rtCurry :: Monad m => ReaderT (r,t) m a -> t -> ReaderT r m a
+> rtCurry (ReaderT rt) t = ReaderT (\r -> rt (r,t))
+
+> rtUncurry :: Monad m => (t -> ReaderT r m a) -> ReaderT (r,t) m a
+> rtUncurry f = ReaderT (\(r,t) -> let (ReaderT rt) = f t in rt r)
+
+\end{verbatim}
+A state reader transformer can be transformed trivially into a state
+transformer monad. This is handled by the combinator \texttt{ro}.
+\begin{verbatim}
+
+> ro :: Monad m => ReaderT r m a -> StateT r m a
+> ro (ReaderT rt) = StateT (\s -> rt s >>= \x -> return (x,s))
+
+\end{verbatim}
+\subsection{Error monad}
+Another useful monad defined in~\cite{LiangHudakJones95:ModInterp} is
+the error monad.
+\begin{verbatim}
+
+> data ErrorT m a = ErrorT (m (Error a))
+
+> unErrorT :: ErrorT m a -> m (Error a)
+> unErrorT (ErrorT m) = m
+
+> instance Functor f => Functor (ErrorT f) where
+>   fmap f (ErrorT m) = ErrorT (fmap (fmap f) m)
+
+> instance Monad m => Monad (ErrorT m) where
+>   return = ErrorT . return . Ok
+>   fail = ErrorT . return . Error
+>   ErrorT m >>= f = ErrorT (m >>= k)
+>     where k (Ok x) = unErrorT (f x)
+>           k (Error msg) = return (Error msg)
+
+> instance MonadPlus m => MonadPlus (ErrorT m) where
+>   mzero = ErrorT mzero
+>   ErrorT m `mplus` ErrorT m' = ErrorT (m `mplus` m')
+
+> liftErr :: Monad m => m a -> ErrorT m a
+> liftErr = ErrorT . liftM Ok
+
+> callErr :: ErrorT m a -> m (Error a)
+> callErr = unErrorT
+
+\end{verbatim}
+\subsection{Mutable variables}
+All major Haskell implementations provide some kind of mutable state
+variables. In order to be able to lift these operations to the
+combined monads approach, we define a class for handling these
+references. Currently this is restricted to the use of mutable
+variables in the \texttt{IO} monad.\footnote{We use the interface
+provided by Hugs and ghc and provide compatibility implementations for
+hbc and nhc that adapt the respective implementations to the one used
+here. See appendix~\ref{sec:hbc-ioexts} and~\ref{sec:nhc-ioexts} for
+details.}
+\begin{verbatim}
+
+> type Ref a = IORef a
+
+> class Monad m => RefMonad m where
+>   newRef :: a -> m (Ref a)
+>   readRef :: Ref a -> m a
+>   writeRef :: Ref a -> a -> m ()
+
+> instance RefMonad IO where
+>   newRef = newIORef
+>   readRef = readIORef
+>   writeRef = writeIORef
+
+\end{verbatim}
+\subsection{Lifting operations}
+In order to use the operations of one the classes defined above in
+another monad, the appropriate \texttt{lift}\dots{} combinators have
+to be applied. The following instance declarations automatically
+provide these lifting operations. Unfortunately we cannot define such
+implicit lifting operations for neither the state monad functions nor
+the environment monad functions as we were unable to define those
+classes.
+\begin{verbatim}
+
+> -- Reference monad
+> instance RefMonad m => RefMonad (ErrorT m) where
+>   newRef = liftErr . newRef
+>   readRef = liftErr . readRef
+>   writeRef ref = liftErr . writeRef ref
+
+> instance RefMonad m => RefMonad (ReaderT s m) where
+>   newRef = liftRt . newRef
+>   readRef = liftRt . readRef
+>   writeRef ref = liftRt . writeRef ref
+
+> instance RefMonad m => RefMonad (StateT s m) where
+>   newRef = liftSt . newRef
+>   readRef = liftSt . readRef
+>   writeRef ref = liftSt . writeRef ref
+
+\end{verbatim}
diff --git a/src/CompilerResults.hs b/src/CompilerResults.hs
new file mode 100644
--- /dev/null
+++ b/src/CompilerResults.hs
@@ -0,0 +1,24 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- CompilerResult - Provides a record for dealing with compiler results.
+--                
+-- January 2006,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+module CompilerResults where
+
+
+-------------------------------------------------------------------------------
+
+--
+data CompilerResults
+   = CompilerResults{ unchangedIntf :: Maybe FilePath }
+
+--
+defaultResults :: CompilerResults
+defaultResults = CompilerResults{ unchangedIntf = Nothing }
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/CurryBuilder.hs b/src/CurryBuilder.hs
new file mode 100644
--- /dev/null
+++ b/src/CurryBuilder.hs
@@ -0,0 +1,204 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- CurryBuilder - Generates Curry representations for a Curry source file
+--                including all imported modules.
+--
+-- September 2005,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+-- March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)
+--
+module CurryBuilder (buildCurry, smake) where
+
+import System.Exit
+import System.Time
+import Control.Monad
+import Data.Maybe
+import Data.List 
+import System.IO
+
+import Modules (compileModule_)
+import CurryCompilerOpts 
+import CurryDeps
+import Ident
+import PathUtils
+import Env
+
+-------------------------------------------------------------------------------
+
+-- Compiles the Curry program 'file' including all imported modules, depending
+-- on the options 'options'. The compilation was successful, if the returned
+-- list is empty, otherwise it contains error messages.
+buildCurry :: Options -> FilePath -> IO ()
+buildCurry options file
+   = do let paths = importPaths options
+	file'          <- getSourcePath paths file
+	(cfile, errs1) <- return (maybe ("", [missingModule file])
+			                (\f -> (f,[]))
+				        file')
+	unless (null errs1) (abortWith errs1)
+	(deps, errs2) <- genDeps paths cfile
+	unless (null errs2) (abortWith errs2)
+	makeCurry options deps cfile
+
+
+-------------------------------------------------------------------------------
+
+makeCurry :: Options -> [(ModuleIdent,Source)] -> FilePath -> IO ()
+makeCurry options deps file
+   = mapM compile (map snd deps) >> return ()
+ where
+ compile (Source file' mods)
+    | rootname file == rootname file'
+      = do 
+           flatIntfExists <- doesModuleExist (flatIntName file')
+	   if flatIntfExists && not (force options) && null (dump options)
+	    then smake (targetNames file')
+                       (file':(catMaybes (map flatInterface mods)))
+		       (generateFile file')
+		       (skipFile file')
+	    else generateFile file'
+    | otherwise
+      = do 
+           flatIntfExists <- doesModuleExist (flatIntName file')
+	   if flatIntfExists
+            then  smake [flatName file'] --[flatName file', flatIntName file']
+	                (file':(catMaybes (map flatInterface mods)))
+			(compileFile file')
+			(skipFile file')
+	    else compileFile file'
+ compile _ = return ()
+
+ compileFile file
+    = do unless (noVerb options) (putStrLn ("compiling " ++ file ++ " ..."))
+	 compileCurry (compOpts True) file
+	 return ()
+
+ skipFile file
+    = do unless (noVerb options)
+		(putStrLn ("skipping " ++ file ++ " ..."))
+
+ generateFile file
+    = do unless (noVerb options) 
+		(putStrLn ("generating "  
+			   ++ (head (targetNames file))               
+			   ++ " ..."))
+	 compileCurry (compOpts False) file
+	 return ()
+
+ targetNames fn         
+        | flat options            = [flatName fn] -- , flatIntName fn]
+		| flatXml options         = [xmlName fn]
+		| abstract options        = [acyName fn]
+		| untypedAbstract options = [uacyName fn]
+		| parseOnly options       = [maybe (sourceRepName fn) id (output options)]
+		| otherwise               = [flatName fn] -- , flatIntName fn]
+
+ flatInterface mod 
+    = case (lookup mod deps) of
+        Just (Source file _)  -> Just (flatIntName (rootname file))
+	Just (Interface file) -> Just (flatIntName (rootname file))
+	_                     -> Nothing
+
+ compOpts isImport
+    | isImport 
+      = options 
+	   { flat = True,
+	     flatXml = False,
+	     abstract = False,
+	     untypedAbstract = False,
+	     parseOnly = False,
+	     dump = []
+	   }
+    | otherwise = options
+
+-------------------------------------------------------------------------------
+
+-- Searches in 'paths' for the corresponding Curry file of 'fn' and returns
+-- the complete path if it exist. The filename 'fn' doesn't need one of the 
+-- Curry file extensions ".curry" or ".lcurry"
+getSourcePath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
+getSourcePath paths file = getCurryPath paths [] file
+
+
+-- Computes a dependency list for the Curry file 'file' (such a list
+-- usualy starts with the prelude and ends with 'file'). The result 
+-- is a tuple containing an association list (type [(ModuleIdent,Source)]; 
+-- see module "CurryDeps") and a list of error messages.
+genDeps :: [FilePath] -> FilePath
+	   -> IO ([(ModuleIdent,Source)], [String])
+genDeps paths file
+   = fmap (flattenDeps . sortDeps) (deps paths [] emptyEnv file)
+
+
+-------------------------------------------------------------------------------
+-- A simple make function
+
+-- smake <destination files>
+--       <dependencies> 
+--       <io action, if dependencies are newer than destination files>
+--       <io action, if destination files are newer than dependencies>
+smake :: [FilePath] -> [FilePath] -> IO a -> IO a -> IO a
+smake dests deps cmd alt
+   = do destTimes <- getDestTimes dests
+	depTimes  <- getDepTimes deps
+	make destTimes depTimes
+ where
+ make destTimes depTimes
+    | (length destTimes) < (length dests) 
+      = catch cmd (\err -> abortWith [show err]) 
+    | null depTimes 
+      = abortWith ["unknown dependencies"]
+    | outOfDate destTimes depTimes
+      = catch cmd (\err -> abortWith [show err])
+    | otherwise
+      = alt
+
+--
+getDestTimes :: [FilePath] -> IO [ClockTime]
+getDestTimes [] = return []
+getDestTimes (file:files)
+   = catch (do time  <- getModuleModTime file
+	       times <- getDestTimes files
+	       return (time:times))
+           (const (getDestTimes files))
+
+--
+getDepTimes :: [String] -> IO [ClockTime]
+getDepTimes [] = return []
+getDepTimes (file:files)
+   = catch (do time  <- getModuleModTime file
+	       times <- getDepTimes files
+	       return (time:times))
+           (\err -> abortWith [show err])
+
+--
+outOfDate :: [ClockTime] -> [ClockTime] -> Bool
+outOfDate tgtimes dptimes = or (map (\t -> or (map ((<) t) dptimes)) tgtimes)
+
+
+compileCurry = compileModule_
+
+-------------------------------------------------------------------------------
+-- Error handling
+
+-- Prints an error message on 'stderr'
+putErrLn :: String -> IO ()
+putErrLn = hPutStrLn stderr
+
+-- Prints a list of error messages on 'stderr'
+putErrsLn :: [String] -> IO ()
+putErrsLn = mapM_ putErrLn
+
+-- Prints a list of error messages on 'stderr' and aborts the program
+abortWith :: [String] -> IO a
+abortWith errs = putErrsLn errs >> exitWith (ExitFailure 1)
+
+
+-- Error messages
+
+missingModule :: FilePath -> String
+missingModule file = "Error: missing module \"" ++ file ++ "\""
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/CurryCompilerOpts.hs b/src/CurryCompilerOpts.hs
new file mode 100644
--- /dev/null
+++ b/src/CurryCompilerOpts.hs
@@ -0,0 +1,167 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- CurryCompilerOpts - Defines data structures containing options for
+--                     compiling Curry programs (see module "CurryCompiler")
+--
+-- September 2005,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+-- March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)
+--
+module CurryCompilerOpts where
+
+import GetOpt
+--import Options (Dump(..))
+
+
+-------------------------------------------------------------------------------
+
+-- Data type for recording compiler options
+data Options
+   = Options{ force :: Bool,             -- force compilation
+              html :: Bool,              -- generate Html code  
+	      importPaths :: [FilePath], -- directories for searching imports
+	      output :: Maybe FilePath,  -- name of output file
+	      noInterface :: Bool,       -- do not create an interface file
+	      noVerb :: Bool,            -- verbosity on/off
+	      noWarn :: Bool,            -- warnings on/off
+	      noOverlapWarn :: Bool,     -- "overlap" warnings on/off
+	      flat :: Bool,              -- generate FlatCurry code
+              extendedFlat :: Bool,      -- generate FlatCurry code with extensions
+	      flatXml :: Bool,           -- generate flat XML code
+	      abstract :: Bool,          -- generate typed AbstracCurry code
+	      untypedAbstract :: Bool,   -- generate untyped AbstractCurry code
+	      parseOnly :: Bool,         -- generate source representation
+	      withExtensions :: Bool,    -- enable extended functionalities
+	      dump :: [Dump]             -- dumps
+	    }
+
+
+-- Default compiler options
+defaultOpts = Options{ force           = False,
+                       html            = False,
+		       importPaths     = [],
+		       output          = Nothing,
+		       noInterface     = False,
+		       noVerb          = False,
+		       noWarn          = False,
+		       noOverlapWarn   = False,
+                       extendedFlat    = False,
+		       flat            = False,
+		       flatXml         = False,
+		       abstract        = False,
+		       untypedAbstract = False,
+                       parseOnly       = False,
+		       withExtensions  = False,
+		       dump            = []
+		     }
+
+
+-- Data type for representing all available options (needed to read and parse
+-- the options from the command line; see module "GetOpt")
+data Option = Help | Force | Html
+	    | ImportPath FilePath | Output FilePath
+	    | NoInterface | NoVerb | NoWarn | NoOverlapWarn
+	    | FlatXML | Flat | ExtFlat
+            | Abstract | UntypedAbstract | ParseOnly
+	    | WithExtensions
+	    | Dump [Dump]
+   deriving Eq
+
+
+-- All available compiler options
+options = [Option "f" ["force"] (NoArg Force)
+	          "force compilation of dependent files",
+           Option "" ["html"] (NoArg Html)
+                  "generate html code",
+	   Option "i" ["import-dir"] (ReqArg ImportPath "DIR")
+                  "search for imports in DIR",
+	   Option "o" ["output"] (ReqArg Output "FILE")
+                  "write code to FILE",
+	   Option "" ["no-intf"] (NoArg NoInterface)
+                  "do not create an interface file",
+	   Option "" ["no-verb"] (NoArg NoVerb)
+	          "do not print compiler messages",
+	   Option "" ["no-warn"] (NoArg NoWarn)
+	          "do not print warnings",
+	   Option "" ["no-overlap-warn"] (NoArg NoOverlapWarn)
+	          "do not print warnings for overlapping rules",
+	   Option "" ["flat"] (NoArg Flat)
+                  "generate FlatCurry code",
+	   Option "" ["extended-flat"] (NoArg ExtFlat)
+                  "generate FlatCurry code with source references",
+	   Option "" ["xml"] (NoArg FlatXML)
+                  "generate flat xml code",
+	   Option "" ["acy"] (NoArg Abstract)
+                  "generate (type infered) AbstractCurry code",
+	   Option "" ["uacy"] (NoArg UntypedAbstract)
+                  "generate untyped AbstractCurry code",
+	   Option "" ["parse-only"] (NoArg ParseOnly)
+                  "generate source representation",
+	   Option "e"  ["extended"] (NoArg WithExtensions)
+	          "enable extended Curry functionalities",
+	   Option "" ["dump-all"] (NoArg (Dump [minBound..maxBound]))
+                  "dump everything",
+	   Option "" ["dump-renamed"] (NoArg (Dump [DumpRenamed]))
+                  "dump source code after renaming",
+	   Option "" ["dump-types"] (NoArg (Dump [DumpTypes]))
+                  "dump types after type-checking",
+	   Option "" ["dump-desugared"] (NoArg (Dump [DumpDesugared]))
+                  "dump source code after desugaring",
+	   Option "" ["dump-simplified"] (NoArg (Dump [DumpSimplified]))
+                  "dump source code after simplification",
+	   Option "" ["dump-lifted"] (NoArg (Dump [DumpLifted]))
+                  "dump source code after lambda-lifting",
+	   Option "" ["dump-il"] (NoArg (Dump [DumpIL]))
+                  "dump intermediate language before lifting",
+	   Option "" ["dump-case"] (NoArg (Dump [DumpCase]))
+	          "dump intermediate language after case simplification",
+	   Option "" ["dump-transformed"] (NoArg (Dump [DumpTransformed]))
+                  "dump IL code after debugging transformation",
+	   Option "" ["dump-normalized"] (NoArg (Dump [DumpNormalized]))
+                  "dump IL code after normalization",
+	   Option "?h" ["help"] (NoArg Help)
+                  "display this help and exit"
+	  ]
+
+
+-- Inserts an option (type 'Option') into the options record (type 'Options')
+selectOption :: Option -> Options -> Options
+selectOption Force opts           = opts{ force = True }
+selectOption (ImportPath dir) opts 
+   = opts{ importPaths = dir:(importPaths opts) }
+selectOption (Output file) opts   = opts{ output = Just file }
+selectOption NoInterface opts     = opts{ noInterface = True }
+selectOption NoVerb opts          = opts{ noVerb = True } 
+selectOption NoWarn opts          = opts{ noWarn = True }
+selectOption NoOverlapWarn opts   = opts{ noOverlapWarn = True }
+selectOption Flat opts            = opts{ flat = True }
+selectOption ExtFlat opts         = opts{ extendedFlat = True }
+selectOption Html opts            = opts{ html = True }
+selectOption FlatXML opts         = opts{ flatXml = True }
+selectOption Abstract opts        = opts{ abstract = True }
+selectOption UntypedAbstract opts = opts{ untypedAbstract = True }
+selectOption ParseOnly opts       = opts{ parseOnly = True }
+selectOption WithExtensions opts  = opts{ withExtensions = True }
+selectOption (Dump ds) opts       = opts{ dump = ds ++ dump opts }
+
+
+-------------------------------------------------------------------------------
+
+-- Data type for representing code dumps
+-- TODO: dump FlatCurry code, dump AbstractCurry code, dump after 'case'
+--       expansion
+data Dump = DumpRenamed      -- dump source after renaming
+	  | DumpTypes        -- dump types after typechecking
+	  | DumpDesugared    -- dump source after desugaring
+	  | DumpSimplified   -- dump source after simplification
+	  | DumpLifted       -- dump source after lambda-lifting
+	  | DumpIL           -- dump IL code after translation
+	  | DumpCase         -- dump IL code after case elimination
+	  | DumpTransformed  -- dump transformed code
+	  | DumpNormalized   -- dump IL code after normalization
+	    deriving (Eq,Bounded,Enum,Show)
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/CurryDeps.lhs b/src/CurryDeps.lhs
new file mode 100644
--- /dev/null
+++ b/src/CurryDeps.lhs
@@ -0,0 +1,417 @@
+
+% $Id: CurryDeps.lhs,v 1.14 2004/02/09 17:10:05 wlux Exp $
+%
+% Copyright (c) 2002-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+% Extended by Sebastian Fischer (sebf@informatik.uni-kiel.de)
+\nwfilename{CurryDeps.lhs}
+\section{Building Programs}
+This module implements the functions to compute the dependency
+information between Curry modules. This is used to create Makefile
+dependencies and to update programs composed of multiple modules.
+\begin{verbatim}
+
+> module CurryDeps where
+
+> import Data.List
+> import Data.Maybe
+> import Control.Monad
+
+> import Error
+> import Ident
+> import Unlit
+> import CurrySyntax hiding(Interface(..))
+> import CurryParser(parseHeader)
+> import SCC
+> import Env
+
+> import PathUtils
+
+> data Source = Source FilePath [ModuleIdent]
+>             | Interface FilePath
+>             | Unknown
+>             deriving (Eq,Ord,Show)
+> type SourceEnv = Env ModuleIdent Source
+
+\end{verbatim}
+The module has two entry points. The function \texttt{buildScript}
+computes either a build or clean script for a module while
+\texttt{makeDepend} computes dependency rules for inclusion into a
+Makefile.
+\begin{verbatim}
+
+> buildScript :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool
+>             -> [FilePath] -> [FilePath] -> Maybe FilePath -> FilePath 
+>             -> IO [String]
+> buildScript clean debug linkAlways flat xml acy uacy
+>             paths libraryPaths ofn fn =
+>   do
+>     mfn'      <- getCurryPath paths libraryPaths fn
+>     (fn',es1) <- return (maybe ("",["Error: missing module \"" ++ fn ++ "\""])
+>                                (\x -> (x,[]))
+>                                mfn')
+>     (ms,es2)  <- fmap 
+>                   (flattenDeps . sortDeps)
+>                   (deps paths (filter (`notElem` paths) libraryPaths) emptyEnv fn')
+>     es        <- return (es1 ++ es2)
+>     when (null es)
+>          (putStr 
+>            (makeScript clean debug flat xml acy uacy linkAlways 
+>                        (outputFile fn') fn ms))
+>     return es
+>   where outputFile fn
+>           | extension fn `elem` moduleExts ++ objectExts = Nothing
+>           | otherwise = ofn `mplus` Just fn
+>         makeScript clean = if clean then makeCleanScript else makeBuildScript
+
+> makeDepend :: [FilePath] -> [FilePath] -> Maybe FilePath -> [FilePath]
+>            -> IO ()
+> makeDepend paths libraryPaths ofn ms =
+>   do
+>     flatDeps <- liftM (makeDeps True) (allDeps flat)
+>     objectDeps <- liftM (makeDeps False) (allDeps nonFlat)
+>     maybe putStr writeFile ofn (flatDeps ++ objectDeps)
+>   where (flat,nonFlat) = partition (flatExt `isSuffixOf`) ms
+>         allDeps = foldM (deps paths libraryPaths') emptyEnv
+>         libraryPaths' = filter (`notElem` paths) libraryPaths
+
+> deps :: [FilePath] -> [FilePath] -> SourceEnv -> FilePath -> IO SourceEnv
+> deps paths libraryPaths mEnv fn
+>   | e `elem` sourceExts = sourceDeps paths libraryPaths (mkMIdent [r]) mEnv fn
+>   | e == icurryExt = return emptyEnv
+>   | e `elem` objectExts = targetDeps paths libraryPaths mEnv r
+>   | otherwise = targetDeps paths libraryPaths mEnv fn
+>   where r = rootname fn
+>         e = extension fn
+
+> targetDeps :: [FilePath] -> [FilePath] -> SourceEnv -> FilePath
+>            -> IO SourceEnv
+> targetDeps paths libraryPaths mEnv fn =
+>   lookupFile [fn ++ e | e <- sourceExts] >>=
+>   maybe (return (bindEnv m Unknown mEnv)) (sourceDeps paths libraryPaths m mEnv)
+>   where m = mkMIdent [fn]
+
+\end{verbatim}
+The following functions are used to lookup files related to a given
+module. Source files for targets are looked up in the current
+directory only. Two different search paths are used to look up
+imported modules, the first is used to find source modules, whereas
+the library path is used only for finding matching interface files. As
+the compiler does not distinguish these paths, we actually check for
+interface files in the source paths as well.
+
+Note that the functions \texttt{buildScript} and \texttt{makeDepend}
+already remove all directories that are included in the both search
+paths from the library paths in order to avoid scanning such
+directories more than twice.
+\begin{verbatim}
+
+
+> lookupModule :: [FilePath] -> [FilePath] -> ModuleIdent
+>              -> IO (Maybe FilePath)
+> lookupModule paths libraryPaths m =
+>   lookupFile [p `catPath` fn ++ e | p <- "" : paths, e <- moduleExts] >>=
+>   maybe (lookupFile [p `catPath` fn ++ e 
+>                      | p <- libraryPaths, e <- moduleExts])
+>         (return . Just)
+>   where fn = foldr1 catPath (moduleQualifiers m)
+>                      -- | p <- libraryPaths, e <- [icurryExt, curryExt, lcurryExt]])
+
+> --lookupModule :: [FilePath] -> [FilePath] -> ModuleIdent
+> --             -> IO (Maybe FilePath)
+> --lookupModule paths libraryPaths m =
+> --  lookupFile [p `catPath` fn ++ e | p <- "" : paths, e <- moduleExts] >>=
+> --  maybe (lookupFile [p `catPath` fn ++ icurryExt | p <- libraryPaths])
+> --        (return . Just)
+> --  where fn = foldr1 catPath (moduleQualifiers m)
+
+\end{verbatim}
+In order to compute the dependency graph, source files for each module
+need to be looked up. When a source module is found, its header is
+parsed in order to determine the modules that it imports, and
+dependencies for these modules are computed recursively. The prelude
+is added implicitly to the list of imported modules except for the
+prelude itself. Any errors reported by the parser are ignored.
+\begin{verbatim}
+
+> moduleDeps :: [FilePath] -> [FilePath] -> SourceEnv -> ModuleIdent
+>            -> IO SourceEnv
+> moduleDeps paths libraryPaths mEnv m =
+>   case lookupEnv m mEnv of
+>     Just _ -> return mEnv
+>     Nothing ->
+>       do
+>         mbFn <- lookupModule paths libraryPaths m
+>         case mbFn of
+>           Just fn
+>             | icurryExt `isSuffixOf` fn ->
+>                 return (bindEnv m (Interface fn) mEnv)
+>             | otherwise -> sourceDeps paths libraryPaths m mEnv fn
+>           Nothing -> return (bindEnv m Unknown mEnv)
+
+> sourceDeps :: [FilePath] -> [FilePath] -> ModuleIdent -> SourceEnv
+>            -> FilePath -> IO SourceEnv
+> sourceDeps paths libraryPaths m mEnv fn =
+>   do
+>     s <- readModule fn
+>     case parseHeader fn (unlitLiterate fn s) of
+>       Ok (Module m' _ ds) ->
+>         let ms = imports m' ds in
+>         foldM (moduleDeps paths libraryPaths) (bindEnv m (Source fn ms) mEnv) ms
+>       Error _ -> return (bindEnv m (Source fn []) mEnv)
+
+> imports :: ModuleIdent -> [Decl] -> [ModuleIdent]
+> imports m ds = nub $
+>   [preludeMIdent | m /= preludeMIdent] ++ [m | ImportDecl _ m _ _ _ <- ds]
+
+> unlitLiterate :: FilePath -> String -> String
+> unlitLiterate fn
+>   | lcurryExt `isSuffixOf` fn = snd . unlit fn
+>   | otherwise = id
+
+\end{verbatim}
+It is quite straight forward to generate Makefile dependencies from
+the dependency environment. In order for these dependencies to work,
+the Makefile must include a rule
+\begin{verbatim}
+.SUFFIXES: .lcurry .curry .icurry
+.o.icurry: @echo interface $@ not found, remove $< and recompile; exit 1
+\end{verbatim}
+This dependency rule introduces an indirect dependency between a
+module and its interface. In particular, the interface may be updated
+when the module is recompiled and a new object file is generated but
+it does not matter if the interface is out-of-date with respect to the
+object code.
+\begin{verbatim}
+
+> makeDeps :: Bool -> SourceEnv -> String
+> makeDeps flat mEnv =
+>   unlines (filter (not . null) (map (depsLine . snd) (envToList mEnv)))
+>   where depsLine (Source fn ms) =
+>           targetName fn ++ ": " ++ fn ++ " " ++
+>           unwords (filter (not . null) (map interf ms))
+>         depsLine (Interface _) = []
+>         depsLine Unknown = []
+>         interf m = maybe [] interfFile (lookupEnv m mEnv)
+>         interfFile (Source fn _) = interfName fn
+>         interfFile (Interface fn) = fn
+>         interfFile Unknown = ""
+>         targetName = if flat then flatName else objectName False
+
+\end{verbatim}
+If we want to compile the program instead of generating Makefile
+dependencies the environment has to be sorted topologically. Note
+that the dependency graph should not contain any cycles.
+\begin{verbatim}
+
+> sortDeps :: SourceEnv -> [[(ModuleIdent,Source)]]
+> sortDeps = scc (modules . fst) (imports . snd) . envToList
+>   where modules m = [m]
+>         imports (Source _ ms) = ms
+>         imports (Interface _) = []
+>         imports Unknown = []
+
+> flattenDeps :: [[(ModuleIdent,Source)]] -> ([(ModuleIdent,Source)],[String])
+> flattenDeps [] = ([],[])
+> flattenDeps (dep:deps) =
+>   case dep of
+>     [] -> (ms',es')
+>     [m] -> (m:ms',es')
+>     _ -> (ms',cyclicError (map fst dep) : es')
+>   where (ms',es') = flattenDeps deps
+
+> cyclicError :: [ModuleIdent] -> String
+> cyclicError (m:ms) =
+>   "Cylic import dependency between modules " ++ show m ++ rest ms
+>   where rest [m] = " and " ++ show m
+>         rest (m:ms) = ", " ++ show m ++ rest' ms
+>         rest' [m] = ", and " ++ show m
+>         rest' (m:ms) = ", " ++ show m ++ rest' ms
+
+\end{verbatim}
+The function \texttt{makeBuildScript} returns a shell script that
+rebuilds several program representations (e.g. interfaces, FlatCurry etc.)
+given a sorted list of module informations. The
+script uses the command \verb|compile| and \verb|link| to build
+programs and representations. They should be defined to reasonable values in the
+environment where the script is executed (e.g. compile=cyc
+The script deliberately uses
+the \verb|-e| shell option so that the script is terminated upon the
+first error. Unlike the original function \texttt{makeBuildScript} this
+modification uses the command "smake" to check the out-of-dateness
+of dependend program files.
+\begin{verbatim}
+
+> makeBuildScript :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool 
+>                 -> Maybe FilePath -> FilePath -> [(ModuleIdent,Source)] 
+>                 -> String
+> makeBuildScript debug flat xml acy uacy linkAlways ofn fn mEnv =
+>   unlines ("set -e" : (map (compCommands . snd) mEnv)
+>                       ++ (maybe [] linkCommands ofn))
+>   where 
+>         compCommands (Source fn' ms)
+>            | (acy || uacy) && rootname fn /= rootname fn'
+>              = (smake ([flatName fn', flatIntName fn'])
+>                       (fn' : catMaybes (map flatInt ms))
+>                       "")
+>                ++ " || (\\" --rm -f " ++ (interfName fn') ++ " && \\"
+>                ++ unwords ["compile", "--flat", fn', "-o",
+>                            flatName fn']
+>                ++ ")"
+>            | otherwise
+>              = (smake (targetNames fn')
+>                       (fn' : catMaybes (map flatInt ms))
+>                       "")
+>                ++ " || (\\" --rm -f " ++ (interfName fn')
+>                ++ (compile fn') ++ ")"
+>         compCommands (Interface _) = []
+>         compCommands Unknown = []
+>
+>         linkCommands fn'
+>           | linkAlways = [link fn' os]
+>           | otherwise  = [smake [fn'] os "", " || \\", (link fn' os)]
+>           where os = reverse (catMaybes (map (object . snd) mEnv))
+>
+>         smake ts ds rule
+>            = "$CURRY_PATH/smake " 
+>              ++ (unwords ts) ++ " : " 
+>              ++ (unwords ds)
+>              ++ (if null rule then "" else " : " ++ rule)
+>
+>         compile fn' = unwords ["compile", cFlag, fn', "-o", 
+>                                head (targetNames fn')] 
+>
+>         cFlag | flat      = "--flat"
+>               | xml       = "--xml"
+>               | acy       = "--acy"
+>               | uacy      = "--uacy"
+>               | otherwise = "-c"
+>
+>         oGen fn' | flat || xml || acy || uacy = []
+>                  | otherwise   = ["-o", head (targetNames fn')]
+>
+>         link fn' os = unwords ("link" : "-o" : fn' : os)
+>
+>         flatInt m =
+>           case lookup m mEnv of
+>             Just (Source fn' _) 
+>	        -> Just (flatIntName fn')
+>             Just (Interface fn') 
+>	        -> Just (flatIntName (basename (rootname fn')))
+>             Just Unknown 
+>	        -> Nothing
+>             _ -> Nothing
+>
+>         object (Source fn' _) = Just (head (targetNames fn'))
+>         object (Interface _) = Nothing
+>         object Unknown = Nothing
+>
+>         targetNames fn' | flat      = [flatName fn', flatIntName fn']
+>                         | xml       = [xmlName fn']
+>                         | acy       = [acyName fn']
+>                         | uacy      = [uacyName fn']
+>                         | otherwise = [objectName debug fn']
+
+
+\end{verbatim}
+The function \texttt{makeCleanScript} returns a shell script that
+removes all compiled files for a module. The script uses the command
+\verb|remove| to delete the files. It should be defined to a
+reasonable value in the environment where the script is executed.
+\begin{verbatim}
+
+> makeCleanScript :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool 
+>                 -> Maybe FilePath -> FilePath -> [(ModuleIdent,Source)] 
+>                 -> String
+> makeCleanScript debug flat xml acy uacy _ ofn _ mEnv =
+>   unwords ("remove" : foldr files (maybe [] return ofn) (map snd mEnv))
+>   where d = if debug then 2 else 0
+>         files = if flat then flatFiles else nonFlatFiles
+>         flatFiles (Source fn _) fs =
+>           drop d [interfName fn,flatName fn] ++ fs
+>         flatFiles (Interface _) fs = fs
+>         flatFiles Unknown fs = fs
+>         nonFlatFiles (Source fn _) fs =
+>           drop d [interfName fn,objectName False fn,objectName True fn] ++
+>           fs
+>         nonFlatFiles (Interface _) fs = fs
+>         nonFlatFiles Unknown fs = fs
+
+\end{verbatim}
+The function \verb|getCurryPath| searches in predefined paths
+for the corresponding \texttt{.curry} or \texttt{.lcurry} file, 
+if the given file name has no extension.
+\begin{verbatim}
+
+> getCurryPath :: [FilePath] -> [FilePath] -> FilePath -> IO (Maybe FilePath)
+> getCurryPath paths libraryPaths fn
+>   = lookupFile filepaths
+>  where
+>  filepaths = [p `catPath` fn' | p   <- "":(paths ++ libraryPaths),
+>                                 fn' <- fns']
+>  fns' | null (extension fn) = [fn ++ ext' | ext' <- sourceExts]
+>       | otherwise           = [fn]
+
+> --getSourceName :: FilePath -> IO FilePath
+> --getSourceName fn
+> --   | null (extension fn)
+> --      = do mfn <- lookupFile [fn ++ ext' | ext' <- sourceExts]
+> --           return (fromMaybe fn mfn)
+> --   | otherwise 
+> --     = return fn
+
+
+\end{verbatim}
+The following functions compute the name of the target file (e.g.
+interface file, flat curry file etc.)
+for a source module. Note that
+output files are always created in the same directory as the source
+file.
+\begin{verbatim}
+
+> interfName :: FilePath -> FilePath
+> interfName sfn = rootname sfn ++ icurryExt
+
+> flatName :: FilePath -> FilePath
+> flatName fn = rootname fn ++ flatExt
+
+> flatIntName :: FilePath -> FilePath
+> flatIntName fn = rootname fn ++ flatIntExt
+
+> xmlName :: FilePath -> FilePath
+> xmlName fn = rootname fn ++ xmlExt
+
+> acyName :: FilePath -> FilePath
+> acyName fn = rootname fn ++ acyExt
+
+> uacyName :: FilePath -> FilePath
+> uacyName fn = rootname fn ++ uacyExt
+
+> sourceRepName :: FilePath -> FilePath
+> sourceRepName fn = rootname fn ++ sourceRepExt
+
+> objectName :: Bool -> FilePath -> FilePath
+> objectName debug = name (if debug then debugExt else oExt)
+>   where name ext fn = rootname fn ++ ext
+
+> curryExt, lcurryExt, icurryExt, oExt :: String
+> curryExt = ".curry"
+> lcurryExt = ".lcurry"
+> icurryExt = ".icurry"
+> flatExt = ".fcy"
+> flatIntExt = ".fint"
+> xmlExt = "_flat.xml"
+> acyExt = ".acy"
+> uacyExt = ".uacy"
+> sourceRepExt = ".cy"
+> oExt = ".o"
+> debugExt = ".d.o"
+
+> sourceExts, moduleExts, objectExts :: [String]
+> sourceExts = [curryExt,lcurryExt]
+> moduleExts = sourceExts ++ [icurryExt]
+> objectExts = [oExt]
+
+\end{verbatim}
diff --git a/src/CurryEnv.hs b/src/CurryEnv.hs
new file mode 100644
--- /dev/null
+++ b/src/CurryEnv.hs
@@ -0,0 +1,182 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- CurryEnv - Generates a record containing extracted and prepared data
+--            from a CurrySyntax module
+--
+-- November 2005,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+module CurryEnv (CurryEnv, 
+		 moduleId, exports, imports, interface, infixDecls,
+		 typeSynonyms, curryEnv) where
+
+import Data.Maybe
+
+import Base
+
+
+------------------------------------------------------------------------------
+
+-- A record containing the following data for a module 'm':
+--
+--    moduleId    - the name of 'm'
+--    exports     - the export list extracted from 'm'
+--    interface   - all exported declarations in 'm' (including exported 
+--                  imports)
+--    infixDecls  - interfaces of all infix declarations in 'm'
+--    typeSynonym - interfaces of all type synonyms in 'm'
+--
+data CurryEnv = CurryEnv{ moduleId     :: ModuleIdent,
+			  exports      :: [Export],
+			  imports      :: [IDecl],
+			  interface    :: [IDecl],
+			  infixDecls   :: [IDecl],
+			  typeSynonyms :: [IDecl]
+			} deriving Show
+			  
+
+-------------------------------------------------------------------------------
+
+-- Returns a Curry environment for the module 'mod' and its corresponding
+-- environments 'mEnv' (imported modules), 'tcEnv' (table of type
+-- constructors) and 'intf' (the interface of 'mod')
+curryEnv :: ModuleEnv -> TCEnv -> Interface -> Module -> CurryEnv
+curryEnv mEnv tcEnv (Interface iid idecls) mod@(Module mid mExp decls)
+   | iid == mid
+     = CurryEnv{ moduleId     = mid,
+		 exports      = maybe [] (\ (Exporting _ exps) -> exps) mExp,
+		 imports      = genImportIntf decls,
+		 interface    = idecls,
+		 infixDecls   = genInfixDecls mod,
+		 typeSynonyms = genTypeSyns tcEnv mod
+	       }
+   | otherwise
+     = internalError ("CurryEnv: interface \"" ++ show iid 
+		      ++ "\" does not match module \"" ++ show mid ++ "\"")
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+-- Generate interfaces for import declarations
+genImportIntf :: [Decl] -> [IDecl]
+genImportIntf decls = reverse (map snd (foldl genImpIntf [] decls))
+
+--
+genImpIntf imps (ImportDecl pos mid _ _ _)
+   = maybe ((mid, IImportDecl pos mid):imps) (const imps) (lookup mid imps)
+genImpIntf imps _ = imps
+
+
+-------------------------------------------------------------------------------
+
+-- Generate interface declaration for all infix declarations in the module
+genInfixDecls :: Module -> [IDecl]
+genInfixDecls (Module mident _ decls) = collectIInfixDecls mident decls
+
+--
+collectIInfixDecls :: ModuleIdent -> [Decl] -> [IDecl]
+collectIInfixDecls mident [] = []
+collectIInfixDecls mident ((InfixDecl pos infixspec prec idents):decls)
+   = (map (\ident 
+	   -> IInfixDecl pos infixspec prec (qualifyWith mident ident)) 
+	   idents)
+     ++ (collectIInfixDecls mident decls)
+collectIInfixDecls mident (_:decls) = collectIInfixDecls mident decls
+
+
+-------------------------------------------------------------------------------
+
+-- Generate interface declarations for all type synonyms in the module.
+genTypeSyns :: TCEnv -> Module -> [IDecl]
+genTypeSyns tcEnv (Module mident _ decls)
+   = map (genTypeSynDecl mident tcEnv) (filter isTypeSyn decls)
+
+--
+genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> IDecl
+genTypeSynDecl mid tcEnv (TypeDecl pos ident params texpr)
+   = genTypeDecl pos mid ident params tcEnv texpr
+genTypeSynDecl _ _ _ 
+   = internalError "@CurryInfo.genTypeSynDecl: illegal declaration"
+
+--
+genTypeDecl :: Position -> ModuleIdent -> Ident -> [Ident] -> TCEnv
+	    -> TypeExpr -> IDecl
+genTypeDecl pos mid ident params tcEnv texpr
+   = ITypeDecl pos (qualifyWith mid ident) params
+               (modifyTypeExpr tcEnv texpr)
+
+
+--
+modifyTypeExpr :: TCEnv -> TypeExpr -> TypeExpr
+modifyTypeExpr tcEnv (ConstructorType qident typeexprs)
+   = case (qualLookupTC qident tcEnv) of
+       [AliasType _ arity rhstype]
+          -> modifyTypeExpr tcEnv 
+	                    (genTypeSynDeref (zip [0 .. (arity-1)] typeexprs)
+			                     rhstype)
+       _  -> ConstructorType (fromMaybe qident (lookupTCId qident tcEnv))
+                             (map (modifyTypeExpr tcEnv) typeexprs)
+modifyTypeExpr _ (VariableType ident)
+   = VariableType ident
+modifyTypeExpr tcEnv (ArrowType type1 type2)
+   = ArrowType (modifyTypeExpr tcEnv type1) (modifyTypeExpr tcEnv type2)
+modifyTypeExpr tcEnv (TupleType typeexprs)
+   | null typeexprs 
+     = ConstructorType qUnitId []
+   | otherwise
+     = ConstructorType (qTupleId (length typeexprs)) 
+                       (map (modifyTypeExpr tcEnv) typeexprs)
+modifyTypeExpr tcEnv (ListType typeexpr)
+   = ConstructorType (qualify listId) [(modifyTypeExpr tcEnv typeexpr)]
+modifyTypeExpr tcEnv (RecordType fields rtype)
+   = RecordType (map (\ (labs, texpr) -> (labs, (modifyTypeExpr tcEnv texpr)))
+		     fields)
+                (maybe Nothing (Just . modifyTypeExpr tcEnv) rtype)
+
+--
+genTypeSynDeref :: [(Int,TypeExpr)] -> Type -> TypeExpr
+genTypeSynDeref its (TypeConstructor qident typeexprs)
+   = ConstructorType qident (map (genTypeSynDeref its) typeexprs)
+genTypeSynDeref its (TypeVariable i)
+   = fromMaybe (internalError ("@CurryInfo.genTypeSynDeref: " ++
+			       "unkown type var index"))
+               (lookup i its)
+genTypeSynDeref its (TypeConstrained typeexprs i)
+   = internalError ("@CurryInfo.genTypeSynDeref: " ++
+		    "illegal constrained type occured")
+genTypeSynDeref its (TypeArrow type1 type2)
+   = ArrowType (genTypeSynDeref its type1) (genTypeSynDeref its type2)
+genTypeSynDeref its (TypeSkolem i)
+   = internalError ("@CurryInfo.genTypeSynDeref: " ++
+		    "illegal skolem type occured")
+genTypeSynDeref its (TypeRecord fields ri)
+   = RecordType (map (\ (lab, texpr) -> ([lab], genTypeSynDeref its texpr))
+		     fields)
+                (maybe Nothing 
+		       (\i -> Just (genTypeSynDeref its (TypeVariable i)))
+		       ri)
+
+--
+lookupTCId :: QualIdent -> TCEnv -> Maybe QualIdent
+lookupTCId qident tcEnv
+   = case (qualLookupTC qident tcEnv) of
+       [DataType qident' _ _]     -> Just qident'
+       [RenamingType qident' _ _] -> Just qident'
+       [AliasType qident' _ _]    -> Just qident'
+       _                          -> Nothing
+
+--
+isTypeSyn :: Decl -> Bool
+isTypeSyn (TypeDecl _ _ _ texpr)
+   = case texpr of
+       RecordType _ _ -> False
+       _              -> True
+isTypeSyn _ = False
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+
diff --git a/src/CurryHtml.hs b/src/CurryHtml.hs
new file mode 100644
--- /dev/null
+++ b/src/CurryHtml.hs
@@ -0,0 +1,158 @@
+module CurryHtml(program2html,source2html) where
+
+import SyntaxColoring
+import Ident
+import Data.Char hiding(Space)
+import CurryDeps(getCurryPath)
+import PathUtils (writeModule)
+       
+--- translate source file into HTML file with syntaxcoloring
+--- @param outputfilename
+--- @param sourcefilename
+source2html :: [String] -> String -> String -> IO ()
+source2html imports outputfilename sourcefilename = do
+        let sourceprogname = removeExtension sourcefilename
+            output = if null outputfilename 
+                     then sourceprogname ++ "_curry.html"
+                     else outputfilename 
+            modulname = fileName sourceprogname
+        fullfname <- getCurryPath imports [] sourcefilename
+        program <- filename2program imports (maybe sourcefilename id fullfname)
+        (if null outputfilename then writeModule output 
+                                else writeFile   output)
+           (program2html modulname program)
+   
+       
+--- generates htmlcode with syntax highlighting            
+--- @param modulname
+--- @param a program
+--- @return HTMLcode
+program2html :: String ->Program -> String
+program2html modulname codes =
+    "<html>\n<head>\n<title>Module "++ 
+    modulname++
+    "</title>\n" ++
+    "<link rel=\"stylesheet\" type=\"text/css\" href=\"currydoc.css\">"++
+    "</link>\n</head>\n<body style=\"font-family:'Courier New', Arial;\">\n<pre>\n" ++
+    concat (map (code2html True . (\(_,_,c) -> c)) codes) ++
+    "<pre>\n</body>\n</html>"            
+            
+            
+--- which code has which color 
+--- @param code
+--- @return color of the code  
+code2class :: Code -> String                          
+code2class (Keyword _) = "keyword"
+code2class (Space _)= ""
+code2class NewLine = ""
+code2class (ConstructorName ConstrPattern _) = "constructorname_constrpattern"
+code2class (ConstructorName ConstrCall _) = "constructorname_constrcall"
+code2class (ConstructorName ConstrDecla _) = "constructorname_constrdecla"
+code2class (ConstructorName OtherConstrKind _) = "constructorname_otherconstrkind"
+code2class (Function InfixFunction _) = "function_infixfunction"
+code2class (Function TypSig _) = "function_typsig"
+code2class (Function FunDecl _) = "function_fundecl"
+code2class (Function FunctionCall _) = "function_functioncall"
+code2class (Function OtherFunctionKind _) = "function_otherfunctionkind"
+code2class (ModuleName _) = "modulename"
+code2class (Commentary _) = "commentary"
+code2class (NumberCode _) = "numbercode"
+code2class (StringCode _) = "stringcode"
+code2class (CharCode _) = "charcode"
+code2class (Symbol _) = "symbol"
+code2class (Identifier IdDecl _) = "identifier_iddecl"
+code2class (Identifier IdOccur _) = "identifier_idoccur"
+code2class (Identifier UnknownId _) = "identifier_unknownid"
+code2class (TypeConstructor TypeDecla _) = "typeconstructor_typedecla"
+code2class (TypeConstructor TypeUse _) = "typeconstructor_typeuse"
+code2class (TypeConstructor TypeExport _) = "typeconstructor_typeexport"
+code2class (CodeError _ _) = "codeerror"
+code2class (CodeWarning _ _) = "codewarning"
+code2class (NotParsed _) = "notparsed"
+
+
+code2html :: Bool -> Code -> String    
+code2html _ code@(CodeError _ c) =
+      (spanTag (code2class code) 
+              (code2html False c))
+code2html ownClass code@(CodeWarning _ c) =
+     (if ownClass then spanTag (code2class code) else id)
+              (code2html False c)       
+code2html ownClass code@(Commentary _) =
+    (if ownClass then spanTag (code2class code) else id)
+      (replace '<' "<span>&lt</span>" (code2string code))                
+code2html ownClass c
+      | isCall c && ownClass = maybe tag (addHtmlLink tag) (getQualIdent c) 
+      | isDecl c && ownClass= maybe tag (addHtmlAnchor tag) (getQualIdent c)
+      | otherwise = tag
+    where tag = (if ownClass then spanTag (code2class c) else id)
+                      (htmlQuote (code2string c)) 
+                                        
+spanTag :: String -> String -> String
+spanTag cl str
+   |null cl = str
+   | otherwise = "<span class=\""++ cl ++ "\">" ++ str ++ "</span>"
+
+replace :: Char -> String -> String -> String
+replace old new = foldr (\ x -> if x == old then (new ++) else ([x]++)) ""
+
+addHtmlAnchor :: String -> QualIdent -> String
+addHtmlAnchor html qualIdent = "<a name=\""++ string2urlencoded (show (unqualify qualIdent)) ++"\"></a>" ++ html
+
+addHtmlLink :: String -> QualIdent -> String
+addHtmlLink html qualIdent =
+   let (maybeModuleIdent,ident) = splitQualIdent qualIdent in   
+   "<a href=\"" ++ 
+   (maybe "" (\x -> show x ++ "_curry.html") maybeModuleIdent) ++ 
+   "#"++ 
+   string2urlencoded (show ident) ++
+   "\">"++ 
+   html ++
+   "</a>"
+
+isCall :: Code -> Bool
+isCall (TypeConstructor TypeExport _) = True
+isCall (TypeConstructor _ _) = False
+isCall (Identifier _ _) = False
+isCall code = not (isDecl code) &&
+                maybe False (const True) (getQualIdent code)
+
+     
+isDecl :: Code -> Bool
+isDecl (ConstructorName ConstrDecla _) = True
+isDecl (Function FunDecl _) = True
+isDecl (TypeConstructor TypeDecla _) = True
+isDecl _ = False 
+
+
+fileName = reverse . takeWhile (/='/') . reverse 
+
+removeExtension = reverse . drop 1 . dropWhile (/='.') . reverse 
+
+
+--- Translates arbitrary strings into equivalent urlencoded string.
+string2urlencoded :: String -> String
+string2urlencoded = id
+{-
+string2urlencoded [] = []
+string2urlencoded (c:cs)
+  | isAlphaNum c = c : string2urlencoded cs
+  | c == ' '     = '+' : string2urlencoded cs
+  | otherwise = show (ord c) ++ (if null cs then "" else ".") ++ string2urlencoded cs
+-}
+
+htmlQuote :: String -> String
+htmlQuote [] = []
+htmlQuote (c:cs) | c=='<' = "&lt;"   ++ htmlQuote cs
+                 | c=='>' = "&gt;"   ++ htmlQuote cs
+                 | c=='&' = "&amp;"  ++ htmlQuote cs
+                 | c=='"' = "&quot;" ++ htmlQuote cs
+                 | c=='\228' = "&auml;" ++ htmlQuote cs
+                 | c=='\246' = "&ouml;" ++ htmlQuote cs
+                 | c=='\252' = "&uuml;" ++ htmlQuote cs
+                 | c=='\196' = "&Auml;" ++ htmlQuote cs
+                 | c=='\214' = "&Ouml;" ++ htmlQuote cs
+                 | c=='\220' = "&Uuml;" ++ htmlQuote cs
+                 | c=='\223' = "&szlig;"++ htmlQuote cs
+                 | otherwise = c : htmlQuote cs
+  
diff --git a/src/CurryLexer.lhs b/src/CurryLexer.lhs
new file mode 100644
--- /dev/null
+++ b/src/CurryLexer.lhs
@@ -0,0 +1,629 @@
+
+% $Id: CurryLexer.lhs,v 1.40 2004/03/04 22:39:12 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{CurryLexer.lhs}
+\section{A Lexer for Curry}
+In this section a lexer for Curry is implemented.
+\begin{verbatim}
+ 
+> module CurryLexer (lexFile,lexer, Token (..), Category(..), Attributes(..)) where
+
+> import Data.Char 
+> import Data.List
+
+> import LexComb
+> import Position
+> import Map
+
+
+\end{verbatim}
+\paragraph{Tokens} Note that the equality and ordering instances of
+\texttt{Token} disregard the attributes.
+\begin{verbatim}
+
+> data Token = Token Category Attributes
+
+> instance Eq Token where
+>   Token t1 _ == Token t2 _ = t1 == t2
+> instance Ord Token where
+>   Token t1 _ `compare` Token t2 _ = t1 `compare` t2
+
+> data Category =
+>   -- literals
+>     CharTok | IntTok | FloatTok | IntegerTok | StringTok
+>   -- identifiers
+>   | Id | QId | Sym | QSym
+>   -- punctuation symbols
+>   | LeftParen | RightParen | Semicolon | LeftBrace | RightBrace
+>   | LeftBracket | RightBracket | Comma | Underscore | Backquote
+>   -- turn off layout (inserted by bbr)
+>   | LeftBraceSemicolon
+>   -- virtual punctation (inserted by layout)
+>   | VSemicolon | VRightBrace
+>   -- reserved identifiers
+>   | KW_case | KW_choice | KW_data | KW_do | KW_else | KW_eval | KW_external
+>   | KW_free | KW_if | KW_import | KW_in | KW_infix | KW_infixl | KW_infixr
+>   | KW_let | KW_module | KW_newtype | KW_of | KW_rigid | KW_then | KW_type
+>   | KW_where
+>   -- reserved operators
+>   | At | Colon | DotDot | DoubleColon | Equals | Backslash | Bar
+>   | LeftArrow | RightArrow | Tilde | Binds
+>   -- special identifiers
+>   | Id_as | Id_ccall | Id_forall | Id_hiding | Id_interface | Id_primitive
+>   | Id_qualified
+>   -- special operators
+>   | Sym_Dot | Sym_Minus | Sym_MinusDot
+>   -- end-of-file token
+>   | EOF
+>   -- comments (only for full lexer) inserted by men & bbr
+>   | LineComment | NestedComment 
+>   deriving (Eq,Ord)
+
+\end{verbatim}
+There are different kinds of attributes associated with the tokens.
+Most attributes simply save the string corresponding to the token.
+However, for qualified identifiers, we also record the list of module
+qualifiers. The values corresponding to a literal token are properly
+converted already. To simplify the creation and extraction of
+attribute values we make use of records.
+\begin{verbatim}
+
+> data Attributes =
+>     NoAttributes
+>   | CharAttributes{ cval :: Char, original :: String}
+>   | IntAttributes{ ival :: Int , original :: String}
+>   | FloatAttributes{ fval :: Double, original :: String}
+>   | IntegerAttributes{ intval :: Integer, original :: String}
+>   | StringAttributes{ sval :: String, original :: String}
+>   | IdentAttributes{ modul :: [String], sval :: String}
+
+> instance Show Attributes where
+>   showsPrec _ NoAttributes = showChar '_'
+>   showsPrec _ (CharAttributes cval _) = shows cval
+>   showsPrec _ (IntAttributes ival _) = shows ival
+>   showsPrec _ (FloatAttributes fval _) = shows fval
+>   showsPrec _ (IntegerAttributes intval _) = shows intval
+>   showsPrec _ (StringAttributes sval _) = shows sval
+>   showsPrec _ (IdentAttributes mIdent ident) =
+>     showString ("`" ++ concat (intersperse "." (mIdent ++ [ident])) ++ "'")
+
+\end{verbatim}
+The following functions can be used to construct tokens with
+specific attributes.
+\begin{verbatim}
+
+> tok :: Category -> Token
+> tok t = Token t NoAttributes
+
+> idTok :: Category -> [String] -> String -> Token
+> idTok t mIdent ident = Token t IdentAttributes{ modul = mIdent, sval = ident }
+
+> charTok :: Char -> String -> Token
+> charTok c o = Token CharTok CharAttributes{ cval = c, original = o }
+
+> intTok :: Int -> String -> Token
+> intTok base digits =
+>   Token IntTok IntAttributes{ ival = convertIntegral base digits,
+>                               original = digits}
+
+> floatTok :: String -> String -> Int -> String -> Token
+> floatTok mant frac exp rest =
+>   Token FloatTok FloatAttributes{ fval = convertFloating mant frac exp, 
+>                                   original = mant++"."++frac++rest}
+ 
+> integerTok :: Integer -> String -> Token
+> integerTok base digits =
+>   Token IntegerTok
+>         IntegerAttributes{intval = (convertIntegral base digits) :: Integer,
+>                           original = digits}
+
+> stringTok :: String -> String -> Token
+> stringTok cs o = Token StringTok StringAttributes{ sval = cs, original = o }
+
+> lineCommentTok :: String -> Token
+> lineCommentTok s = Token LineComment StringAttributes{ sval = s, original = s}
+
+> nestedCommentTok :: String -> Token
+> nestedCommentTok s = Token NestedComment StringAttributes{ sval = s, original = s }
+
+\end{verbatim}
+The \texttt{Show} instance of \texttt{Token} is designed to display
+all tokens in their source representation.
+\begin{verbatim}
+
+> instance Show Token where
+>   showsPrec _ (Token Id a) = showString "identifier " . shows a
+>   showsPrec _ (Token QId a) = showString "qualified identifier " . shows a
+>   showsPrec _ (Token Sym a) = showString "operator " . shows a
+>   showsPrec _ (Token QSym a) = showString "qualified operator " . shows a
+>   showsPrec _ (Token IntTok a) = showString "integer " . shows a
+>   showsPrec _ (Token FloatTok a) = showString "float " . shows a
+>   showsPrec _ (Token CharTok a) = showString "character " . shows a
+>   showsPrec _ (Token IntegerTok a) = showString "integer " . shows a
+>   showsPrec _ (Token StringTok a) = showString "string " . shows a
+>   showsPrec _ (Token LeftParen _) = showString "`('"
+>   showsPrec _ (Token RightParen _) = showString "`)'"
+>   showsPrec _ (Token Semicolon _) = showString "`;'"
+>   showsPrec _ (Token LeftBrace _) = showString "`{'"
+>   showsPrec _ (Token RightBrace _) = showString "`}'"
+>   showsPrec _ (Token LeftBracket _) = showString "`['"
+>   showsPrec _ (Token RightBracket _) = showString "`]'"
+>   showsPrec _ (Token Comma _) = showString "`,'"
+>   showsPrec _ (Token Underscore _) = showString "`_'"
+>   showsPrec _ (Token Backquote _) = showString "``'"
+>   showsPrec _ (Token VSemicolon _) =
+>     showString "`;' (inserted due to layout)"
+>   showsPrec _ (Token VRightBrace _) =
+>     showString "`}' (inserted due to layout)"
+>   showsPrec _ (Token At _) = showString "`@'"
+>   showsPrec _ (Token Colon _) = showString "`:'"
+>   showsPrec _ (Token DotDot _) = showString "`..'"
+>   showsPrec _ (Token DoubleColon _) = showString "`::'"
+>   showsPrec _ (Token Equals _) = showString "`='"
+>   showsPrec _ (Token Backslash _) = showString "`\\'"
+>   showsPrec _ (Token Bar _) = showString "`|'"
+>   showsPrec _ (Token LeftArrow _) = showString "`<-'"
+>   showsPrec _ (Token RightArrow _) = showString "`->'"
+>   showsPrec _ (Token Tilde _) = showString "`~'"
+>   showsPrec _ (Token Binds _) = showString "`:='"
+>   showsPrec _ (Token Sym_Dot _) = showString "operator `.'"
+>   showsPrec _ (Token Sym_Minus _) = showString "operator `-'"
+>   showsPrec _ (Token Sym_MinusDot _) = showString "operator `-.'"
+>   showsPrec _ (Token KW_case _) = showString "`case'"
+>   showsPrec _ (Token KW_choice _) = showString "`choice'"
+>   showsPrec _ (Token KW_data _) = showString "`data'"
+>   showsPrec _ (Token KW_do _) = showString "`do'"
+>   showsPrec _ (Token KW_else _) = showString "`else'"
+>   showsPrec _ (Token KW_eval _) = showString "`eval'"
+>   showsPrec _ (Token KW_external _) = showString "`external'"
+>   showsPrec _ (Token KW_free _) = showString "`free'"
+>   showsPrec _ (Token KW_if _) = showString "`if'"
+>   showsPrec _ (Token KW_import _) = showString "`import'"
+>   showsPrec _ (Token KW_in _) = showString "`in'"
+>   showsPrec _ (Token KW_infix _) = showString "`infix'"
+>   showsPrec _ (Token KW_infixl _) = showString "`infixl'"
+>   showsPrec _ (Token KW_infixr _) = showString "`infixr'"
+>   showsPrec _ (Token KW_let _) = showString "`let'"
+>   showsPrec _ (Token KW_module _) = showString "`module'"
+>   showsPrec _ (Token KW_newtype _) = showString "`newtype'"
+>   showsPrec _ (Token KW_of _) = showString "`of'"
+>   showsPrec _ (Token KW_rigid _) = showString "`rigid'"
+>   showsPrec _ (Token KW_then _) = showString "`then'"
+>   showsPrec _ (Token KW_type _) = showString "`type'"
+>   showsPrec _ (Token KW_where _) = showString "`where'"
+>   showsPrec _ (Token Id_as _) = showString "identifier `as'"
+>   showsPrec _ (Token Id_ccall _) = showString "identifier `ccall'"
+>   showsPrec _ (Token Id_forall _) = showString "identifier `forall'"
+>   showsPrec _ (Token Id_hiding _) = showString "identifier `hiding'"
+>   showsPrec _ (Token Id_interface _) = showString "identifier `interface'"
+>   showsPrec _ (Token Id_primitive _) = showString "identifier `primitive'"
+>   showsPrec _ (Token Id_qualified _) = showString "identifier `qualified'"
+>   showsPrec _ (Token EOF _) = showString "<end-of-file>"
+>   showsPrec _ (Token LineComment a) = shows a
+>   showsPrec _ (Token NestedComment a) = shows a
+
+\end{verbatim}
+Tables for reserved operators and identifiers
+\begin{verbatim}
+
+> reserved_ops, reserved_and_special_ops :: FM String Category
+> reserved_ops = fromListFM [
+>     ("@",  At),
+>     ("::", DoubleColon),
+>     ("..", DotDot),
+>     ("=",  Equals),
+>     ("\\", Backslash),
+>     ("|",  Bar),
+>     ("<-", LeftArrow),
+>     ("->", RightArrow),
+>     ("~",  Tilde),
+>     (":=", Binds)
+>   ]
+> reserved_and_special_ops = foldr (uncurry addToFM) reserved_ops [
+>     (":",  Colon),
+>     (".",  Sym_Dot),
+>     ("-",  Sym_Minus),
+>     ("-.", Sym_MinusDot)
+>   ]
+
+> reserved_ids, reserved_and_special_ids :: FM String Category
+> reserved_ids = fromListFM [
+>     ("case",     KW_case),
+>     ("choice",   KW_choice),
+>     ("data",     KW_data),
+>     ("do",       KW_do),
+>     ("else",     KW_else),
+>     ("eval",     KW_eval),
+>     ("external", KW_external),
+>     ("free",     KW_free),
+>     ("if",       KW_if),
+>     ("import",   KW_import),
+>     ("in",       KW_in),
+>     ("infix",    KW_infix),
+>     ("infixl",   KW_infixl),
+>     ("infixr",   KW_infixr),
+>     ("let",      KW_let),
+>     ("module",   KW_module),
+>     ("newtype",  KW_newtype),
+>     ("of",       KW_of),
+>     ("rigid",    KW_rigid),
+>     ("then",     KW_then),
+>     ("type",     KW_type),
+>     ("where",    KW_where)
+>   ]
+> reserved_and_special_ids = foldr (uncurry addToFM) reserved_ids [
+>     ("as",        Id_as),
+>     ("ccall",     Id_ccall),
+>     ("forall",    Id_forall),
+>     ("hiding",    Id_hiding),
+>     ("interface", Id_interface),
+>     ("primitive", Id_primitive),
+>     ("qualified", Id_qualified)
+>   ]
+
+\end{verbatim}
+Character classes
+\begin{verbatim}
+
+> isIdent, isSym, isOctit, isHexit :: Char -> Bool
+> isIdent c = isAlphaNum c || c `elem` "'_"
+> isSym c = c `elem` "~!@#$%^&*+-=<>:?./|\\" {-$-}
+> isOctit c = c >= '0' && c <= '7'
+> isHexit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
+
+inserted for full lexing (men&bbr)
+
+> isLineComment, isNestedComment :: String -> Bool
+> isLineComment ('-':'-':_) = True
+> isLineComment _ = False
+> isNestedComment ('{':'-':s) = True
+> isNestedComment _ = False
+
+
+\end{verbatim}
+Lexing functions
+\begin{verbatim}
+
+> type SuccessP a = Position -> Token -> P a
+> type FailP a = Position -> String -> P a
+
+> lexFile :: P [(Position,Token)]
+> lexFile = fullLexer tokens failP
+>   where tokens p t@(Token c _)
+>           | c == EOF = returnP [(p,t)]
+>           | otherwise = lexFile `thenP` returnP . ((p,t):)
+
+> lexer :: SuccessP a -> FailP a -> P a
+> lexer success fail = skipBlanks
+>   where -- skipBlanks moves past whitespace and comments
+>         skipBlanks p [] bol = success p (tok EOF) p [] bol
+>         skipBlanks p ('\t':s) bol = skipBlanks (tab p) s bol
+>         skipBlanks p ('\n':s) bol = skipBlanks (nl p) s True
+>         skipBlanks p ('-':'-':s) bol =
+>           skipBlanks (nl p) (tail' (dropWhile (/= '\n') s)) True
+>         skipBlanks p ('{':'-':s) bol =
+>           nestedComment p skipBlanks fail (incr p 2) s bol
+>         skipBlanks p (c:s) bol
+>           | isSpace c = skipBlanks (next p) s bol
+>           | otherwise =
+>               (if bol then lexBOL else lexToken) success fail p (c:s) bol
+>         tail' [] = []
+>         tail' (_:tl) = tl
+
+> fullLexer :: SuccessP a -> FailP a -> P a
+> fullLexer success fail = skipBlanks
+>   where -- skipBlanks moves past whitespace 
+>         skipBlanks p [] bol = success p (tok EOF) p [] bol
+>         skipBlanks p ('\t':s) bol = skipBlanks (tab p) s bol
+>         skipBlanks p ('\n':s) bol = skipBlanks (nl p) s True
+>         skipBlanks p s@('-':'-':_) bol = lexLineComment success p s bol
+>         skipBlanks p s@('{':'-':_) bol =
+>           lexNestedComment 0 id p success fail p s bol
+>         skipBlanks p (c:s) bol
+>           | isSpace c = skipBlanks (next p) s bol
+>           | otherwise =
+>               (if bol then lexBOL else lexToken) success fail p (c:s) bol
+>         tail' [] = []
+>         tail' (_:tl) = tl
+
+> lexLineComment :: SuccessP a -> P a
+> lexLineComment success p s = case break (=='\n') s of
+>   (comment,rest) -> success p (lineCommentTok comment) (incr p (length comment)) rest
+ 
+> lexNestedComment :: Int -> (String -> String) -> 
+>                     Position -> SuccessP a -> FailP a -> P a
+> lexNestedComment 1 comment p0 success fail p ('-':'}':s) = 
+>   success p0 (nestedCommentTok (comment "-}") ) (incr p 2) s 
+> lexNestedComment n comment p0 success fail p ('{':'-':s) = 
+>   lexNestedComment (n+1) (comment . ("{-"++)) p0 success fail (incr p 2) s
+> lexNestedComment n comment p0 success fail p ('-':'}':s) = 
+>   lexNestedComment (n-1) (comment . ("-}"++)) p0 success fail (incr p 2) s
+> lexNestedComment n comment p0 success fail p (c@'\t':s) = 
+>   lexNestedComment n (comment . (c:)) p0 success fail (tab p) s
+> lexNestedComment n comment p0 success fail p (c@'\n':s) = 
+>   lexNestedComment n (comment . (c:)) p0 success fail (nl p) s
+> lexNestedComment n comment p0 success fail p (c:s) = 
+>   lexNestedComment n (comment . (c:)) p0 success fail (next p) s
+> lexNestedComment n comment p0 success fail p "" = 
+>   fail p0 "Unterminated nested comment" p []
+
+> nestedComment :: Position -> P a -> FailP a -> P a
+> nestedComment p0 success fail p ('-':'}':s) = success (incr p 2) s
+> nestedComment p0 success fail p ('{':'-':s) =
+>   nestedComment p (nestedComment p0 success fail) fail (incr p 2) s
+> nestedComment p0 success fail p ('\t':s) =
+>   nestedComment p0 success fail (tab p) s
+> nestedComment p0 success fail p ('\n':s) =
+>   nestedComment p0 success fail (nl p) s
+> nestedComment p0 success fail p (_:s) =
+>   nestedComment p0 success fail (next p) s
+> nestedComment p0 success fail p [] =
+>   fail p0 "Unterminated nested comment at end-of-file" p []
+
+
+> lexBOL :: SuccessP a -> FailP a -> P a
+> lexBOL success fail p s _ [] = lexToken success fail p s False []
+> lexBOL success fail p s _ ctxt@(n:rest)
+>   | col < n = success p (tok VRightBrace) p s True rest
+>   | col == n = success p (tok VSemicolon) p s False ctxt
+>   | otherwise = lexToken success fail p s False ctxt
+>   where col = column p
+
+> lexToken :: SuccessP a -> FailP a -> P a
+> lexToken success fail p [] = success p (tok EOF) p []
+> lexToken success fail p (c:s)
+>   | c == '(' = token LeftParen
+>   | c == ')' = token RightParen
+>   | c == ',' = token Comma
+>   | c == ';' = token Semicolon
+>   | c == '[' = token LeftBracket
+>   | c == ']' = token RightBracket
+>   | c == '_' = token Underscore
+>   | c == '`' = token Backquote
+>   | c == '{' = lexLeftBrace (token LeftBrace) (next p) (success p) s 
+>   | c == '}' = \bol -> token RightBrace bol . drop 1
+>   | c == '\'' = lexChar p success fail (next p) s
+>   | c == '\"' = lexString p success fail (next p) s
+>   | isAlpha c = lexIdent (success p) p (c:s)
+>   | isSym c = lexSym (success p) p (c:s)
+>   | isDigit c = lexNumber (success p) p (c:s)
+>   | otherwise = fail p ("Illegal character " ++ show c) p s
+>   where token t = success p (tok t) (next p) s
+
+> lexIdent :: (Token -> P a) -> P a
+> lexIdent cont p s =
+>   maybe (lexOptQual cont (token Id) [ident]) (cont . token)
+>         (lookupFM ident reserved_and_special_ids)
+>         (incr p (length ident)) rest
+>   where (ident,rest) = span isIdent s
+>         token t = idTok t [] ident
+
+> lexSym :: (Token -> P a) -> P a
+> lexSym cont p s =
+>   cont (idTok (maybe Sym id (lookupFM sym reserved_and_special_ops)) [] sym)
+>        (incr p (length sym)) rest
+>   where (sym,rest) = span isSym s
+
+> lexLeftBrace leftBrace _ _       []    = leftBrace
+> lexLeftBrace leftBrace p cont (c:s) 
+>   | c==';'    = cont (tok LeftBraceSemicolon) (next p) s
+>   | otherwise = leftBrace
+
+\end{verbatim}
+{\em Note:} the function \texttt{lexOptQual} has been extended to provide
+the qualified use of the Prelude list operators and tuples.
+\begin{verbatim}
+
+> lexOptQual :: (Token -> P a) -> Token -> [String] -> P a
+> lexOptQual cont token mIdent p ('.':c:s)
+>   | isAlpha c = lexQualIdent cont identCont mIdent (next p) (c:s)
+>   | isSym c = lexQualSym cont identCont mIdent (next p) (c:s)
+>   | c=='(' || c=='[' 
+>     = lexQualPreludeSym cont token identCont mIdent (next p) (c:s)
+>  where identCont _ _ = cont token p ('.':c:s)
+> lexOptQual cont token mIdent p s = cont token p s
+
+> lexQualIdent :: (Token -> P a) -> P a -> [String] -> P a
+> lexQualIdent cont identCont mIdent p s =
+>   maybe (lexOptQual cont (idTok QId mIdent ident) (mIdent ++ [ident]))
+>         (const identCont)
+>         (lookupFM ident reserved_ids)
+>         (incr p (length ident)) rest
+>   where (ident,rest) = span isIdent s
+
+> lexQualSym :: (Token -> P a) -> P a -> [String] -> P a
+> lexQualSym cont identCont mIdent p s =
+>   maybe (cont (idTok QSym mIdent sym)) (const identCont)
+>         (lookupFM sym reserved_ops)
+>         (incr p (length sym)) rest
+>   where (sym,rest) = span isSym s
+
+
+> lexQualPreludeSym :: (Token -> P a) -> Token -> P a -> [String] -> P a
+> lexQualPreludeSym cont _ identCont mIdent p ('[':']':rest) =
+>   cont (idTok QId mIdent "[]") (incr p 2) rest
+> lexQualPreludeSym cont _ identCont mIdent p ('(':rest)
+>   | not (null rest') && head rest'==')' 
+>   = cont (idTok QId mIdent ('(':tup++")")) (incr p (length tup+2)) (tail rest')
+>   where (tup,rest') = span (==',') rest
+> lexQualPreludeSym cont token _ _ p s =  cont token p s
+
+
+\end{verbatim}
+{\em Note:} since Curry allows an unlimited range of integer numbers,
+read numbers must be converted to Haskell type \texttt{Integer}.
+\begin{verbatim}
+
+> lexNumber :: (Token -> P a) -> P a
+> lexNumber cont p ('0':c:s)
+>   | c `elem` "oO" = lexOctal cont nullCont (incr p 2) s
+>   | c `elem` "xX" = lexHexadecimal cont nullCont (incr p 2) s
+>   where nullCont _ _ = cont (intTok 10 "0") (next p) (c:s)
+> lexNumber cont p s
+>     = lexOptFraction cont (integerTok 10 digits) digits
+>                      (incr p (length digits)) rest
+>   where (digits,rest) = span isDigit s
+>         num           = (read digits) :: Integer
+
+> lexOctal :: (Token -> P a) -> P a -> P a
+> lexOctal cont nullCont p s
+>   | null digits = nullCont undefined undefined
+>   | otherwise = cont (integerTok 8 digits) (incr p (length digits)) rest
+>   where (digits,rest) = span isOctit s
+
+> lexHexadecimal :: (Token -> P a) -> P a -> P a
+> lexHexadecimal cont nullCont p s
+>   | null digits = nullCont undefined undefined
+>   | otherwise = cont (integerTok 16 digits) (incr p (length digits)) rest
+>   where (digits,rest) = span isHexit s
+
+> lexOptFraction :: (Token -> P a) -> Token -> String -> P a
+> lexOptFraction cont _ mant p ('.':c:s)
+>   | isDigit c = lexOptExponent cont (floatTok mant frac 0 "") mant frac
+>                                (incr p (length frac+1)) rest
+>   where (frac,rest) = span isDigit (c:s)
+> lexOptFraction cont token mant p (c:s)
+>   | c `elem` "eE" = lexSignedExponent cont intCont mant "" [c] (next p) s
+>   where intCont _ _ = cont token p (c:s)
+> lexOptFraction cont token _ p s = cont token p s
+
+> lexOptExponent :: (Token -> P a) -> Token -> String -> String -> P a
+> lexOptExponent cont token mant frac p (c:s)
+>   | c `elem` "eE" = lexSignedExponent cont floatCont mant frac [c] (next p) s
+>   where floatCont _ _ = cont token p (c:s)
+> lexOptExponent cont token mant frac p s = cont token p s
+
+> lexSignedExponent :: (Token -> P a) -> P a -> String -> String -> String -> P a
+> lexSignedExponent cont floatCont mant frac e p ('+':c:s)
+>   | isDigit c = lexExponent cont mant frac (e++"+") id (next p) (c:s)
+> lexSignedExponent cont floatCont mant frac e p ('-':c:s)
+>   | isDigit c = lexExponent cont mant frac (e++"-") negate (next p) (c:s)
+> lexSignedExponent cont floatCont mant frac e p (c:s)
+>   | isDigit c = lexExponent cont mant frac e id p (c:s)
+> lexSignedExponent cont floatCont mant frac e p s = floatCont p s
+
+> lexExponent :: (Token -> P a) -> String -> String -> String -> (Int -> Int) -> P a
+> lexExponent cont mant frac e expSign p s =
+>   cont (floatTok mant frac exp (e++digits)) (incr p (length digits)) rest
+>   where (digits,rest) = span isDigit s
+>         exp = expSign (convertIntegral 10 digits)
+
+> lexChar :: Position -> SuccessP a -> FailP a -> P a
+> lexChar p0 success fail p [] = fail p0 "Illegal character constant" p []
+> lexChar p0 success fail p (c:s)
+>   | c == '\\' = lexEscape p (lexCharEnd p0 success fail) fail (next p) s
+>   | c == '\n' = fail p0 "Illegal character constant" p (c:s)
+>   | c == '\t' = lexCharEnd p0 success fail c "\t" (tab p) s
+>   | otherwise = lexCharEnd p0 success fail c [c] (next p) s
+
+> lexCharEnd :: Position -> SuccessP a -> FailP a -> Char -> String -> P a
+> lexCharEnd p0 success fail c o p ('\'':s) = success p0 (charTok c o) (next p) s
+> lexCharEnd p0 success fail c o p s =
+>   fail p0 "Improperly terminated character constant" p s
+
+> lexString :: Position -> SuccessP a -> FailP a -> P a
+> lexString p0 success fail = lexStringRest p0 success fail "" id
+
+> lexStringRest :: Position -> SuccessP a -> FailP a -> String -> (String -> String) -> P a
+> lexStringRest p0 success fail s0 so p [] = 
+>   fail p0 "Improperly terminated string constant" p []
+> lexStringRest p0 success fail s0 so p (c:s)
+>   | c == '\\' =
+>       lexStringEscape p (lexStringRest p0 success fail) fail s0 so (next p) s
+>   | c == '\"' = success p0 (stringTok (reverse s0) (so "")) (next p) s
+>   | c == '\n' = fail p0 "Improperly terminated string constant" p []
+>   | c == '\t' = lexStringRest p0 success fail (c:s0) (so . (c:)) (tab p) s
+>   | otherwise = lexStringRest p0 success fail (c:s0) (so . (c:)) (next p) s
+
+> lexStringEscape ::  Position -> (String -> (String -> String) -> P a) -> FailP a -> 
+>                                  String -> (String -> String) -> P a
+> lexStringEscape p0 success fail s0 so p [] = lexEscape p0 undefined fail p []
+> lexStringEscape p0 success fail s0 so p (c:s)
+>   | c == '&' = success s0 (so . ("\\&"++)) (next p) s
+>   | isSpace c = lexStringGap (success s0) fail so p (c:s)
+>   | otherwise = lexEscape p0 (\ c' s' -> success (c':s0) (so . (s'++))) fail p (c:s)
+
+> lexStringGap :: ((String -> String) -> P a) -> FailP a -> (String -> String) -> P a
+> lexStringGap success fail so p [] = fail p "End of file in string gap" p []
+> lexStringGap success fail so p (c:s)
+>   | c == '\\' = success (so . (c:)) (next p) s
+>   | c == '\t' = lexStringGap success fail (so . (c:)) (tab p) s
+>   | c == '\n' = lexStringGap success fail (so . (c:)) (nl p) s
+>   | isSpace c = lexStringGap success fail (so . (c:)) (next p) s
+>   | otherwise = fail p ("Illegal character in string gap " ++ show c) p s
+
+> lexEscape :: Position -> (Char -> String -> P a) -> FailP a -> P a
+> lexEscape p0 success fail p ('a':s) = success '\a' "\\a" (next p) s
+> lexEscape p0 success fail p ('b':s) = success '\b' "\\b" (next p) s
+> lexEscape p0 success fail p ('f':s) = success '\f' "\\f" (next p) s
+> lexEscape p0 success fail p ('n':s) = success '\n' "\\n" (next p) s
+> lexEscape p0 success fail p ('r':s) = success '\r' "\\r" (next p) s
+> lexEscape p0 success fail p ('t':s) = success '\t' "\\t" (next p) s
+> lexEscape p0 success fail p ('v':s) = success '\v' "\\v" (next p) s
+> lexEscape p0 success fail p ('\\':s) = success '\\' "\\\\" (next p) s
+> lexEscape p0 success fail p ('"':s) = success '\"' "\\\"" (next p) s
+> lexEscape p0 success fail p ('\'':s) = success '\'' "\\\'" (next p) s
+> lexEscape p0 success fail p ('^':c:s)
+>   | isUpper c || c `elem` "@[\\]^_" =
+>       success (chr (ord c `mod` 32)) ("\\^"++[c]) (incr p 2) s
+> lexEscape p0 success fail p ('o':c:s)
+>   | isOctit c = numEscape p0 success fail 8 isOctit ("\\o"++) (next p) (c:s)
+> lexEscape p0 success fail p ('x':c:s)
+>   | isHexit c = numEscape p0 success fail 16 isHexit ("\\x"++) (next p) (c:s)
+> lexEscape p0 success fail p (c:s)
+>   | isDigit c = numEscape p0 success fail 10 isDigit ("\\"++) p (c:s)
+> lexEscape p0 success fail p s = asciiEscape p0 success fail p s
+
+> asciiEscape :: Position -> (Char -> String -> P a) -> FailP a -> P a
+> asciiEscape p0 success fail p ('N':'U':'L':s) = success '\NUL' "\\NUL" (incr p 3) s
+> asciiEscape p0 success fail p ('S':'O':'H':s) = success '\SOH' "\\SOH" (incr p 3) s
+> asciiEscape p0 success fail p ('S':'T':'X':s) = success '\STX' "\\STX" (incr p 3) s
+> asciiEscape p0 success fail p ('E':'T':'X':s) = success '\ETX' "\\ETX" (incr p 3) s
+> asciiEscape p0 success fail p ('E':'O':'T':s) = success '\EOT' "\\EOT" (incr p 3) s
+> asciiEscape p0 success fail p ('E':'N':'Q':s) = success '\ENQ' "\\ENQ" (incr p 3) s
+> asciiEscape p0 success fail p ('A':'C':'K':s) = success '\ACK' "\\ACK" (incr p 3) s 
+> asciiEscape p0 success fail p ('B':'E':'L':s) = success '\BEL' "\\BEL" (incr p 3) s
+> asciiEscape p0 success fail p ('B':'S':s) = success '\BS' "\\BS" (incr p 2) s
+> asciiEscape p0 success fail p ('H':'T':s) = success '\HT' "\\HT" (incr p 2) s
+> asciiEscape p0 success fail p ('L':'F':s) = success '\LF' "\\LF" (incr p 2) s
+> asciiEscape p0 success fail p ('V':'T':s) = success '\VT' "\\VT" (incr p 2) s
+> asciiEscape p0 success fail p ('F':'F':s) = success '\FF' "\\FF" (incr p 2) s
+> asciiEscape p0 success fail p ('C':'R':s) = success '\CR' "\\CR" (incr p 2) s
+> asciiEscape p0 success fail p ('S':'O':s) = success '\SO' "\\SO" (incr p 2) s
+> asciiEscape p0 success fail p ('S':'I':s) = success '\SI' "\\SI" (incr p 2) s
+> asciiEscape p0 success fail p ('D':'L':'E':s) = success '\DLE' "\\DLE" (incr p 3) s 
+> asciiEscape p0 success fail p ('D':'C':'1':s) = success '\DC1' "\\DC1" (incr p 3) s
+> asciiEscape p0 success fail p ('D':'C':'2':s) = success '\DC2' "\\DC2" (incr p 3) s
+> asciiEscape p0 success fail p ('D':'C':'3':s) = success '\DC3' "\\DC3" (incr p 3) s
+> asciiEscape p0 success fail p ('D':'C':'4':s) = success '\DC4' "\\DC4" (incr p 3) s
+> asciiEscape p0 success fail p ('N':'A':'K':s) = success '\NAK' "\\NAK" (incr p 3) s
+> asciiEscape p0 success fail p ('S':'Y':'N':s) = success '\SYN' "\\SYN" (incr p 3) s
+> asciiEscape p0 success fail p ('E':'T':'B':s) = success '\ETB' "\\ETB" (incr p 3) s
+> asciiEscape p0 success fail p ('C':'A':'N':s) = success '\CAN' "\\CAN" (incr p 3) s 
+> asciiEscape p0 success fail p ('E':'M':s) = success '\EM' "\\EM" (incr p 2) s
+> asciiEscape p0 success fail p ('S':'U':'B':s) = success '\SUB' "\\SUB" (incr p 3) s
+> asciiEscape p0 success fail p ('E':'S':'C':s) = success '\ESC' "\\ESC" (incr p 3) s
+> asciiEscape p0 success fail p ('F':'S':s) = success '\FS' "\\FS" (incr p 2) s
+> asciiEscape p0 success fail p ('G':'S':s) = success '\GS' "\\GS" (incr p 2) s
+> asciiEscape p0 success fail p ('R':'S':s) = success '\RS' "\\RS" (incr p 2) s
+> asciiEscape p0 success fail p ('U':'S':s) = success '\US' "\\US" (incr p 2) s
+> asciiEscape p0 success fail p ('S':'P':s) = success '\SP' "\\SP" (incr p 2) s
+> asciiEscape p0 success fail p ('D':'E':'L':s) = success '\DEL' "\\DEL" (incr p 3) s
+> asciiEscape p0 success fail p s = fail p0 "Illegal escape sequence" p s
+
+> numEscape :: Position -> (Char -> String -> P a) -> FailP a -> Int
+>           -> (Char -> Bool) -> (String -> String) -> P a
+> numEscape p0 success fail b isDigit so p s
+>   | n >= min && n <= max = success (chr n) (so digits) (incr p (length digits)) rest
+>   | otherwise = fail p0 "Numeric escape out-of-range" p s
+>   where (digits,rest) = span isDigit s
+>         n = convertIntegral b digits
+>         min = ord minBound
+>         max = ord maxBound
+
+\end{verbatim}
diff --git a/src/CurryPP.lhs b/src/CurryPP.lhs
new file mode 100644
--- /dev/null
+++ b/src/CurryPP.lhs
@@ -0,0 +1,369 @@
+
+% $Id: CurryPP.lhs,v 1.50 2004/02/15 22:10:27 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{CurryPP.lhs}
+\section{A Pretty Printer for Curry}\label{sec:CurryPP}
+This module implements a pretty printer for Curry expressions. It was
+derived from the Haskell pretty printer provided in Simon Marlow's
+Haskell parser.
+\begin{verbatim}
+
+> module CurryPP(module CurryPP, Doc) where
+> import Ident
+> import CurrySyntax
+> import Pretty
+
+\end{verbatim}
+Pretty print a module
+\begin{verbatim}
+
+> ppModule :: Module -> Doc
+> ppModule (Module m es ds) = ppModuleHeader m es $$ ppBlock ds
+
+\end{verbatim}
+Module header
+\begin{verbatim}
+
+> ppModuleHeader :: ModuleIdent -> Maybe ExportSpec -> Doc
+> ppModuleHeader m es =
+>   text "module" <+> ppMIdent m <+> maybePP ppExportSpec es <+> text "where"
+
+> ppExportSpec :: ExportSpec -> Doc
+> ppExportSpec (Exporting _ es) = parenList (map ppExport es)
+
+> ppExport :: Export -> Doc
+> ppExport (Export x) = ppQIdent x
+> ppExport (ExportTypeWith tc cs) = ppQIdent tc <> parenList (map ppIdent cs)
+> ppExport (ExportTypeAll tc) = ppQIdent tc <> text "(..)"
+> ppExport (ExportModule m) = text "module" <+> ppMIdent m
+
+\end{verbatim}
+Declarations
+\begin{verbatim}
+
+> ppBlock :: [Decl] -> Doc
+> ppBlock = vcat . map ppDecl
+
+> ppDecl :: Decl -> Doc
+> ppDecl (ImportDecl _ m q asM is) =
+>   text "import" <+> ppQualified q <+> ppMIdent m <+> maybePP ppAs asM
+>                 <+> maybePP ppImportSpec is
+>   where ppQualified q = if q then text "qualified" else empty
+>         ppAs m = text "as" <+> ppMIdent m
+> ppDecl (InfixDecl _ fix p ops) = ppPrec fix p <+> list (map ppInfixOp ops)
+> ppDecl (DataDecl _ tc tvs cs) =
+>   sep (ppTypeDeclLhs "data" tc tvs :
+>        map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs)))
+> ppDecl (NewtypeDecl _ tc tvs nc) =
+>   sep [ppTypeDeclLhs "newtype" tc tvs <+> equals,indent (ppNewConstr nc)]
+> ppDecl (TypeDecl _ tc tvs ty) =
+>   sep [ppTypeDeclLhs "type" tc tvs <+> equals,indent (ppTypeExpr 0 ty)]
+> ppDecl (TypeSig _ fs ty) =
+>   list (map ppIdent fs) <+> text "::" <+> ppTypeExpr 0 ty
+> ppDecl (EvalAnnot _ fs ev) =
+>   list (map ppIdent fs) <+> text "eval" <+> ppEval ev
+>   where ppEval EvalRigid = text "rigid"
+>         ppEval EvalChoice = text "choice"
+> ppDecl (FunctionDecl _ _ eqs) = vcat (map ppEquation eqs)
+> ppDecl (ExternalDecl p cc impent f ty) =
+>   sep [text "external" <+> ppCallConv cc <+> maybePP (text . show) impent,
+>        indent (ppDecl (TypeSig p [f] ty))]
+>   where ppCallConv CallConvPrimitive = text "primitive"
+>         ppCallConv CallConvCCall = text "ccall"
+> ppDecl (FlatExternalDecl _ fs) = list (map ppIdent fs) <+> text "external"
+> ppDecl (PatternDecl _ t rhs) = ppRule (ppConstrTerm 0 t) equals rhs
+> ppDecl (ExtraVariables _ vs) = list (map ppIdent vs) <+> text "free"
+
+> ppImportSpec :: ImportSpec -> Doc
+> ppImportSpec (Importing _ is) = parenList (map ppImport is)
+> ppImportSpec (Hiding _ is) = text "hiding" <+> parenList (map ppImport is)
+
+> ppImport :: Import -> Doc
+> ppImport (Import x) = ppIdent x
+> ppImport (ImportTypeWith tc cs) = ppIdent tc <> parenList (map ppIdent cs)
+> ppImport (ImportTypeAll tc) = ppIdent tc <> text "(..)"
+
+> ppPrec :: Infix -> Integer -> Doc
+> ppPrec fix p = ppAssoc fix <+> ppPrio p
+>   where ppAssoc InfixL = text "infixl"
+>         ppAssoc InfixR = text "infixr"
+>         ppAssoc Infix = text "infix"
+>         ppPrio p = if p < 0 then empty else integer p
+
+> ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc
+> ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs)
+
+> ppConstr :: ConstrDecl -> Doc
+> ppConstr (ConstrDecl _ tvs c tys) =
+>   sep [ppExistVars tvs,ppIdent c <+> fsep (map (ppTypeExpr 2) tys)]
+> ppConstr (ConOpDecl _ tvs ty1 op ty2) =
+>   sep [ppExistVars tvs,ppTypeExpr 1 ty1,ppInfixOp op <+> ppTypeExpr 1 ty2]
+
+> ppNewConstr :: NewConstrDecl -> Doc
+> ppNewConstr (NewConstrDecl _ tvs c ty) =
+>   sep [ppExistVars tvs,ppIdent c <+> ppTypeExpr 2 ty]
+
+> ppExistVars :: [Ident] -> Doc
+> ppExistVars tvs
+>   | null tvs = empty
+>   | otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.'
+
+> ppEquation :: Equation -> Doc
+> ppEquation (Equation _ lhs rhs) = ppRule (ppLhs lhs) equals rhs
+
+> ppLhs :: Lhs -> Doc
+> ppLhs (FunLhs f ts) = ppIdent f <+> fsep (map (ppConstrTerm 2) ts)
+> ppLhs (OpLhs t1 f t2) =
+>   ppConstrTerm 1 t1 <+> ppInfixOp f <+> ppConstrTerm 1 t2
+> ppLhs (ApLhs lhs ts) = parens (ppLhs lhs) <+> fsep (map (ppConstrTerm 2) ts)
+
+> ppRule :: Doc -> Doc -> Rhs -> Doc
+> ppRule lhs eq (SimpleRhs _ e ds) =
+>   sep [lhs <+> eq,indent (ppExpr 0 e)] $$ ppLocalDefs ds
+> ppRule lhs eq (GuardedRhs es ds) =
+>   sep [lhs,indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds
+
+> ppLocalDefs :: [Decl] -> Doc
+> ppLocalDefs ds
+>   | null ds = empty
+>   | otherwise = indent (text "where" <+> ppBlock ds)
+
+\end{verbatim}
+Interfaces
+\begin{verbatim}
+
+> ppInterface :: Interface -> Doc
+> ppInterface (Interface m ds) =
+>   text "interface" <+> ppMIdent m <+> text "where" <+> lbrace
+>     $$ vcat (punctuate semi (map ppIDecl ds)) $$ rbrace
+
+> ppIDecl :: IDecl -> Doc
+> ppIDecl (IImportDecl _ m) = text "import" <+> ppMIdent m
+> ppIDecl (IInfixDecl _ fix p op) = ppPrec fix p <+> ppQInfixOp op
+> ppIDecl (HidingDataDecl _ tc tvs) =
+>   text "hiding" <+> ppITypeDeclLhs "data" (qualify tc) tvs
+> ppIDecl (IDataDecl _ tc tvs cs) =
+>   sep (ppITypeDeclLhs "data" tc tvs :
+>        map indent (zipWith (<+>) (equals : repeat vbar) (map ppIConstr cs)))
+>   where ppIConstr = maybe (char '_') ppConstr
+> ppIDecl (INewtypeDecl _ tc tvs nc) =
+>   sep [ppITypeDeclLhs "newtype" tc tvs <+> equals,indent (ppNewConstr nc)]
+> ppIDecl (ITypeDecl _ tc tvs ty) =
+>   sep [ppITypeDeclLhs "type" tc tvs <+> equals,indent (ppTypeExpr 0 ty)]
+> ppIDecl (IFunctionDecl _ f _ ty) = ppQIdent f <+> text "::" <+> ppTypeExpr 0 ty
+
+> ppITypeDeclLhs :: String -> QualIdent -> [Ident] -> Doc
+> ppITypeDeclLhs kw tc tvs = text kw <+> ppQIdent tc <+> hsep (map ppIdent tvs)
+
+\end{verbatim}
+Types
+\begin{verbatim}
+
+> ppTypeExpr :: Int -> TypeExpr -> Doc
+> ppTypeExpr p (ConstructorType tc tys) =
+>   parenExp (p > 1 && not (null tys))
+>            (ppQIdent tc <+> fsep (map (ppTypeExpr 2) tys))
+> ppTypeExpr _ (VariableType tv) = ppIdent tv
+> ppTypeExpr _ (TupleType tys) = parenList (map (ppTypeExpr 0) tys)
+> ppTypeExpr _ (ListType ty) = brackets (ppTypeExpr 0 ty)
+> ppTypeExpr p (ArrowType ty1 ty2) =
+>   parenExp (p > 0) (fsep (ppArrowType (ArrowType ty1 ty2)))
+>   where ppArrowType (ArrowType ty1 ty2) =
+>           ppTypeExpr 1 ty1 <+> rarrow : ppArrowType ty2
+>         ppArrowType ty = [ppTypeExpr 0 ty]
+> ppTypeExpr p (RecordType fs rty) = 
+>   braces (list (map ppTypedField fs) 
+>           <> maybe empty (\ty -> space <> char '|' <+> ppTypeExpr 0 ty) rty)
+>   where
+>   ppTypedField (ls,ty) = 
+>     list (map ppIdent ls) <> text "::" <> ppTypeExpr 0 ty
+
+\end{verbatim}
+Literals
+\begin{verbatim}
+
+> ppLiteral :: Literal -> Doc
+> ppLiteral (Char _ c)   = text (show c)
+> ppLiteral (Int _ i)    = integer i
+> ppLiteral (Float _ f)  = double f
+> ppLiteral (String _ s) = text (show s)
+
+\end{verbatim}
+Patterns
+\begin{verbatim}
+
+> ppConstrTerm :: Int -> ConstrTerm -> Doc
+> ppConstrTerm p (LiteralPattern l) =
+>   parenExp (p > 1 && isNegative l) (ppLiteral l)
+>   where isNegative (Char _ _)   = False
+>         isNegative (Int _ i)    = i < 0
+>         isNegative (Float _ f)  = f < 0.0
+>         isNegative (String _ _) = False
+> ppConstrTerm p (NegativePattern op l) =
+>   parenExp (p > 1) (ppInfixOp op <> ppLiteral l)
+> ppConstrTerm _ (VariablePattern v) = ppIdent v
+> ppConstrTerm p (ConstructorPattern c ts) =
+>   parenExp (p > 1 && not (null ts))
+>            (ppQIdent c <+> fsep (map (ppConstrTerm 2) ts))
+> ppConstrTerm p (InfixPattern t1 c t2) =
+>   parenExp (p > 0)
+>            (sep [ppConstrTerm 1 t1 <+> ppQInfixOp c,
+>                  indent (ppConstrTerm 0 t2)])
+> ppConstrTerm _ (ParenPattern t) = parens (ppConstrTerm 0 t)
+> ppConstrTerm _ (TuplePattern _ ts) = parenList (map (ppConstrTerm 0) ts)
+> ppConstrTerm _ (ListPattern _ ts) = bracketList (map (ppConstrTerm 0) ts)
+> ppConstrTerm _ (AsPattern v t) = ppIdent v <> char '@' <> ppConstrTerm 2 t
+> ppConstrTerm _ (LazyPattern _ t) = char '~' <> ppConstrTerm 2 t
+> ppConstrTerm p (FunctionPattern f ts) =
+>   parenExp (p > 1 && not (null ts))
+>            (ppQIdent f <+> fsep (map (ppConstrTerm 2) ts))
+> ppConstrTerm p (InfixFuncPattern t1 f t2) =
+>   parenExp (p > 0)
+>            (sep [ppConstrTerm 1 t1 <+> ppQInfixOp f,
+>                  indent (ppConstrTerm 0 t2)])
+> ppConstrTerm p (RecordPattern fs rt) =
+>   braces (list (map ppFieldPatt fs)
+>          <> (maybe empty (\t -> space <> char '|' <+> ppConstrTerm 0 t) rt))
+
+> ppFieldPatt :: Field ConstrTerm -> Doc
+> ppFieldPatt (Field _ l t) = ppIdent l <> equals <> ppConstrTerm 0 t
+
+\end{verbatim}
+Expressions
+\begin{verbatim}
+
+> ppCondExpr :: Doc -> CondExpr -> Doc
+> ppCondExpr eq (CondExpr _ g e) =
+>   vbar <+> sep [ppExpr 0 g <+> eq,indent (ppExpr 0 e)]
+
+> ppExpr :: Int -> Expression -> Doc
+> ppExpr _ (Literal l) = ppLiteral l
+> ppExpr _ (Variable v) = ppQIdent v
+> ppExpr _ (Constructor c) = ppQIdent c
+> ppExpr _ (Paren e) = parens (ppExpr 0 e)
+> ppExpr p (Typed e ty) =
+>   parenExp (p > 0) (ppExpr 0 e <+> text "::" <+> ppTypeExpr 0 ty)
+> ppExpr _ (Tuple _ es) = parenList (map (ppExpr 0) es)
+> ppExpr _ (List _ es) = bracketList (map (ppExpr 0) es)
+> ppExpr _ (ListCompr _ e qs) =
+>   brackets (ppExpr 0 e <+> vbar <+> list (map ppStmt qs))
+> ppExpr _ (EnumFrom e) = brackets (ppExpr 0 e <+> text "..")
+> ppExpr _ (EnumFromThen e1 e2) =
+>   brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2 <+> text "..")
+> ppExpr _ (EnumFromTo e1 e2) =
+>   brackets (ppExpr 0 e1 <+> text ".." <+> ppExpr 0 e2)
+> ppExpr _ (EnumFromThenTo e1 e2 e3) =
+>   brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2
+>               <+> text ".." <+> ppExpr 0 e3)
+> ppExpr p (UnaryMinus op e) = parenExp (p > 1) (ppInfixOp op <> ppExpr 1 e)
+> ppExpr p (Apply e1 e2) =
+>   parenExp (p > 1) (sep [ppExpr 1 e1,indent (ppExpr 2 e2)])
+> ppExpr p (InfixApply e1 op e2) =
+>   parenExp (p > 0) (sep [ppExpr 1 e1 <+> ppQInfixOp (opName op),
+>                          indent (ppExpr 1 e2)])
+> ppExpr _ (LeftSection e op) = parens (ppExpr 1 e <+> ppQInfixOp (opName op))
+> ppExpr _ (RightSection op e) = parens (ppQInfixOp (opName op) <+> ppExpr 1 e)
+> ppExpr p (Lambda _ t e) =
+>   parenExp (p > 0)
+>            (sep [backsl <> fsep (map (ppConstrTerm 2) t) <+> rarrow,
+>                  indent (ppExpr 0 e)])
+> ppExpr p (Let ds e) =
+>   parenExp (p > 0)
+>            (sep [text "let" <+> ppBlock ds <+> text "in",ppExpr 0 e])
+> ppExpr p (Do sts e) =
+>   parenExp (p > 0) (text "do" <+> (vcat (map ppStmt sts) $$ ppExpr 0 e))
+> ppExpr p (IfThenElse _ e1 e2 e3) =
+>   parenExp (p > 0)
+>            (text "if" <+>
+>             sep [ppExpr 0 e1,
+>                  text "then" <+> ppExpr 0 e2,
+>                  text "else" <+> ppExpr 0 e3])
+> ppExpr p (Case _ e alts) =
+>   parenExp (p > 0)
+>            (text "case" <+> ppExpr 0 e <+> text "of" $$
+>             indent (vcat (map ppAlt alts)))
+> ppExpr p (RecordConstr fs) =
+>   braces (list (map (ppFieldExpr equals) fs))
+> ppExpr p (RecordSelection e l) =
+>   parenExp (p > 0)
+>            (ppExpr 1 e <+> text "->" <+> ppIdent l)
+> ppExpr p (RecordUpdate fs e) =
+>   braces (list (map (ppFieldExpr (text ":=")) fs)
+>          <+> char '|' <+> ppExpr 0 e)
+
+> ppStmt :: Statement -> Doc
+> ppStmt (StmtExpr _ e) = ppExpr 0 e
+> ppStmt (StmtBind _ t e) = sep [ppConstrTerm 0 t <+> larrow,indent (ppExpr 0 e)]
+> ppStmt (StmtDecl ds) = text "let" <+> ppBlock ds
+
+> ppAlt :: Alt -> Doc
+> ppAlt (Alt _ t rhs) = ppRule (ppConstrTerm 0 t) rarrow rhs
+
+> ppFieldExpr :: Doc -> Field Expression -> Doc
+> ppFieldExpr comb (Field _ l e) = ppIdent l <> comb <> ppExpr 0 e
+
+> ppOp :: InfixOp -> Doc
+> ppOp (InfixOp op) = ppQInfixOp op
+> ppOp (InfixConstr op) = ppQInfixOp op
+
+\end{verbatim}
+Goals
+\begin{verbatim}
+
+> ppGoal :: Goal -> Doc
+> ppGoal (Goal _ e ds) = sep [ppExpr 0 e,indent (ppLocalDefs ds)]
+
+\end{verbatim}
+Names
+\begin{verbatim}
+
+> ppIdent :: Ident -> Doc
+> ppIdent x = parenExp (isInfixOp x) (text (name x))
+
+> ppQIdent :: QualIdent -> Doc
+> ppQIdent x = parenExp (isQInfixOp x) (text (qualName x))
+
+> ppInfixOp :: Ident -> Doc
+> ppInfixOp x = backQuoteExp (not (isInfixOp x)) (text (name x))
+
+> ppQInfixOp :: QualIdent -> Doc
+> ppQInfixOp x = backQuoteExp (not (isQInfixOp x)) (text (qualName x))
+
+> ppMIdent :: ModuleIdent -> Doc
+> ppMIdent m = text (moduleName m)
+
+\end{verbatim}
+Print printing utilities
+\begin{verbatim}
+
+> indent :: Doc -> Doc
+> indent = nest 2
+
+> maybePP :: (a -> Doc) -> Maybe a -> Doc
+> maybePP pp = maybe empty pp
+
+> parenExp :: Bool -> Doc -> Doc
+> parenExp b doc = if b then parens doc else doc
+
+> backQuoteExp :: Bool -> Doc -> Doc
+> backQuoteExp b doc = if b then backQuote <> doc <> backQuote else doc
+
+> list, parenList, bracketList, braceList :: [Doc] -> Doc
+> list = fsep . punctuate comma
+> parenList = parens . list
+> bracketList = brackets . list
+> braceList = braces . list
+
+> backQuote,backsl,vbar,rarrow,larrow :: Doc
+> backQuote = char '`'
+> backsl = char '\\'
+> vbar = char '|'
+> rarrow = text "->"
+> larrow = text "<-"
+
+\end{verbatim}
diff --git a/src/CurryParser.lhs b/src/CurryParser.lhs
new file mode 100644
--- /dev/null
+++ b/src/CurryParser.lhs
@@ -0,0 +1,818 @@
+
+% $Id: CurryParser.lhs,v 1.75 2004/02/15 23:11:28 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{CurryParser.lhs}
+\section{A Parser for Curry}
+The Curry parser is implemented using the (mostly) LL(1) parsing
+combinators described in appendix~\ref{sec:ll-parsecomb}.
+\begin{verbatim}
+
+> module CurryParser where
+> import Ident
+> import Position
+> import Error
+> import LLParseComb
+> import CurrySyntax
+> import CurryLexer
+
+> instance Symbol Token where
+>   isEOF (Token c _) = c == EOF
+
+\end{verbatim}
+\paragraph{Modules}
+\begin{verbatim}
+
+> parseSource :: Bool -> FilePath -> String -> Error Module
+> parseSource flat path mod = 
+>    fmap addSrcRefs (applyParser (parseModule flat) lexer path mod)
+
+> parseHeader :: FilePath -> String -> Error Module
+> parseHeader = prefixParser (moduleHeader <*->
+>                             (leftBrace `opt` undefined) <*>
+>                             many (importDecl <*-> many semicolon))
+>                            lexer
+
+> parseModule :: Bool -> Parser Token Module a
+> parseModule flat = moduleHeader <*> decls flat
+
+> moduleHeader :: Parser Token ([Decl] -> Module) a
+> moduleHeader = Module <$-> token KW_module
+>                       <*> (mIdent <?> "module name expected")
+>                       <*> ((Just <$> exportSpec) `opt` Nothing)
+>                       <*-> (token KW_where <?> "where expected")
+>          `opt` Module mainMIdent Nothing
+
+> exportSpec :: Parser Token ExportSpec a
+> exportSpec = Exporting <$> position <*> parens (export `sepBy` comma)
+
+> export :: Parser Token Export a
+> export = qtycon <**> (parens spec `opt` Export)
+>      <|> Export <$> qfun <\> qtycon
+>      <|> ExportModule <$-> token KW_module <*> mIdent
+>   where spec = ExportTypeAll <$-> token DotDot
+>            <|> flip ExportTypeWith <$> con `sepBy` comma
+
+\end{verbatim}
+\paragraph{Interfaces}
+Since this modified version of MCC uses FlatCurry interfaces instead of
+".icurry" files, a separate parser is not required any longer.
+\begin{verbatim}
+
+> --parseInterface :: FilePath -> String -> Error Interface
+> --parseInterface fn s = applyParser parseIface lexer fn s
+
+> --parseIface :: Parser Token Interface a
+> --parseIface = Interface <$-> token Id_interface
+> --                       <*> (mIdent <?> "module name expected")
+> --                       <*-> (token KW_where <?> "where expected")
+> --                       <*> braces intfDecls
+
+\end{verbatim}
+\paragraph{Goals}
+\begin{verbatim}
+
+> parseGoal :: String -> Error Goal
+> parseGoal s = applyParser goal lexer "" s
+
+> goal :: Parser Token Goal a
+> goal = Goal <$> position <*> expr False <*> localDefs False
+
+\end{verbatim}
+\paragraph{Declarations}
+\begin{verbatim}
+
+> decls :: Bool -> Parser Token [Decl] a
+> decls flat = layout (globalDecls flat)
+
+> globalDecls :: Bool -> Parser Token [Decl] a
+> globalDecls flat =
+>       (:) <$> importDecl <*> (semicolon <-*> globalDecls flat `opt` [])
+>   <|> topDecl flat `sepBy` semicolon
+
+> topDecl :: Bool -> Parser Token Decl a
+> topDecl flat
+>   | flat = infixDecl <|> dataDecl flat <|> typeDecl <|> functionDecl flat
+>   | otherwise = infixDecl
+>             <|> dataDecl flat <|> newtypeDecl <|> typeDecl
+>             <|> functionDecl flat <|> externalDecl
+
+> localDefs :: Bool -> Parser Token [Decl] a
+> localDefs flat = token KW_where <-*> layout (valueDecls flat)
+>            `opt` []
+
+> valueDecls :: Bool -> Parser Token [Decl] a
+> valueDecls flat = localDecl flat `sepBy` semicolon
+>   where localDecl flat
+>           | flat = infixDecl <|> valueDecl flat
+>           | otherwise = infixDecl <|> valueDecl flat <|> externalDecl
+
+> importDecl :: Parser Token Decl a
+> importDecl =
+>   flip . ImportDecl <$> position <*-> token KW_import 
+>                     <*> (True <$-> token Id_qualified `opt` False)
+>                     <*> mIdent
+>                     <*> (Just <$-> token Id_as <*> mIdent `opt` Nothing)
+>                     <*> (Just <$> importSpec `opt` Nothing)
+
+> importSpec :: Parser Token ImportSpec a
+> importSpec = position <**> (Hiding <$-> token Id_hiding `opt` Importing)
+>                       <*> parens (spec `sepBy` comma)
+>   where spec = tycon <**> (parens constrs `opt` Import)
+>            <|> Import <$> fun <\> tycon
+>         constrs = ImportTypeAll <$-> token DotDot
+>               <|> flip ImportTypeWith <$> con `sepBy` comma
+
+> infixDecl :: Parser Token Decl a
+> infixDecl = infixDeclLhs InfixDecl <*> funop `sepBy1` comma
+
+> infixDeclLhs :: (Position -> Infix -> Integer -> a) -> Parser Token a b
+> infixDeclLhs f = f <$> position <*> tokenOps infixKW <*> integer
+>   where infixKW = [(KW_infix,Infix),(KW_infixl,InfixL),(KW_infixr,InfixR)]
+
+> dataDecl :: Bool -> Parser Token Decl a
+> dataDecl flat = typeDeclLhs DataDecl KW_data <*> constrs
+>   where constrs = equals <-*> constrDecl flat `sepBy1` bar
+>             `opt` []
+
+> newtypeDecl :: Parser Token Decl a
+> newtypeDecl =
+>   typeDeclLhs NewtypeDecl KW_newtype <*-> equals <*> newConstrDecl
+
+> typeDecl :: Parser Token Decl a
+> typeDecl = typeDeclLhs TypeDecl KW_type <*-> equals <*> typeDeclRhs --type0
+
+> typeDeclLhs :: (Position -> Ident -> [Ident] -> a) -> Category
+>             -> Parser Token a b
+> typeDeclLhs f kw = f <$> position <*-> token kw <*> tycon <*> many typeVar
+>   where typeVar = tyvar <|> anonId <$-> token Underscore
+
+> typeDeclRhs :: Parser Token TypeExpr a
+> typeDeclRhs = type0
+>	        <|> (flip RecordType) Nothing
+>		   <$> (layoutOff <-*> braces (labelDecls `sepBy` comma))
+
+> labelDecls = (,) <$> labId `sepBy1` comma <*-> token DoubleColon <*> type0
+
+> constrDecl :: Bool -> Parser Token ConstrDecl a
+> constrDecl flat = position <**> (existVars <**> constr)
+>   where constr = conId <**> identDecl
+>              <|> leftParen <-*> parenDecl
+>              <|> type1 <\> conId <\> leftParen <**> opDecl
+>         identDecl = many type2 <**> (conType <$> opDecl `opt` conDecl)
+>         parenDecl = conOpDeclPrefix 
+>	              <$> conSym <*-> rightParen <*> type2 <*> type2
+>                 <|> tupleType <*-> rightParen <**> opDecl
+>         opDecl = conOpDecl <$> conop <*> type1
+>         conType f tys c = f (ConstructorType (qualify c) tys)
+>         conDecl tys c tvs p = ConstrDecl p tvs c tys
+>         conOpDecl op ty2 ty1 tvs p = ConOpDecl p tvs ty1 op ty2
+>         conOpDeclPrefix op ty1 ty2 tvs p = ConOpDecl p tvs ty1 op ty2
+
+> newConstrDecl :: Parser Token NewConstrDecl a
+> newConstrDecl =
+>   NewConstrDecl <$> position <*> existVars <*> con <*> type2
+
+> existVars :: Parser Token [Ident] a
+> {-
+> existVars flat
+>   | flat = succeed []
+>   | otherwise = token Id_forall <-*> many1 tyvar <*-> dot `opt` []
+> -}
+> existVars = succeed []
+
+> functionDecl :: Bool -> Parser Token Decl a
+> functionDecl flat = position <**> decl
+>   where decl = fun `sepBy1` comma <**> funListDecl flat
+>           <|?> funDecl <$> lhs <*> declRhs flat
+>         lhs = (\f -> (f,FunLhs f [])) <$> fun
+>          <|?> funLhs
+
+> valueDecl :: Bool -> Parser Token Decl a
+> valueDecl flat = position <**> decl
+>   where decl = var `sepBy1` comma <**> valListDecl flat
+>           <|?> valDecl <$> constrTerm0 <*> declRhs flat
+>           <|?> funDecl <$> curriedLhs <*> declRhs flat
+>         valDecl t@(ConstructorPattern c ts)
+>           | not (isConstrId c) = funDecl (f,FunLhs f ts)
+>           where f = unqualify c
+>         valDecl t = opDecl id t
+>         opDecl f (InfixPattern t1 op t2)
+>           | isConstrId op = opDecl (f . InfixPattern t1 op) t2
+>           | otherwise = funDecl (op',OpLhs (f t1) op' t2)
+>           where op' = unqualify op
+>         opDecl f t = patDecl (f t)
+>         isConstrId c = c == qConsId || isQualified c || isQTupleId c
+
+> funDecl :: (Ident,Lhs) -> Rhs -> Position -> Decl
+> funDecl (f,lhs) rhs p = FunctionDecl p f [Equation p lhs rhs]
+
+> patDecl :: ConstrTerm -> Rhs -> Position -> Decl
+> patDecl t rhs p = PatternDecl p t rhs
+
+> funListDecl :: Bool -> Parser Token ([Ident] -> Position -> Decl) a
+> funListDecl flat
+>   | flat = typeSig <$-> token DoubleColon <*> type0
+>        <|> evalAnnot <$-> token KW_eval <*> tokenOps evalKW
+>        <|> externalDecl <$-> token KW_external
+>   | otherwise = typeSig <$-> token DoubleColon <*> type0
+>             <|> evalAnnot <$-> token KW_eval <*> tokenOps evalKW
+>   where typeSig ty vs p = TypeSig p vs ty
+>         evalAnnot ev vs p = EvalAnnot p vs ev
+>         evalKW = [(KW_rigid,EvalRigid),(KW_choice,EvalChoice)]
+>         externalDecl vs p = FlatExternalDecl p vs
+
+> valListDecl :: Bool -> Parser Token ([Ident] -> Position -> Decl) a
+> valListDecl flat = funListDecl flat <|> extraVars <$-> token KW_free
+>   where extraVars vs p = ExtraVariables p vs
+
+> funLhs :: Parser Token (Ident,Lhs) a
+> funLhs = funLhs <$> fun <*> many1 constrTerm2
+>     <|?> flip ($ id) <$> constrTerm1 <*> opLhs'
+>     <|?> curriedLhs
+>   where opLhs' = opLhs <$> funSym <*> constrTerm0
+>              <|> infixPat <$> gConSym <\> funSym <*> constrTerm1 <*> opLhs'
+>              <|> backquote <-*> opIdLhs
+>         opIdLhs = opLhs <$> funId <*-> checkBackquote <*> constrTerm0
+>               <|> infixPat <$> qConId <\> funId <*-> backquote <*> constrTerm1
+>                            <*> opLhs'
+>         funLhs f ts = (f,FunLhs f ts)
+>         opLhs op t2 f t1 = (op,OpLhs (f t1) op t2)
+>         infixPat op t2 f g t1 = f (g . InfixPattern t1 op) t2
+
+> curriedLhs :: Parser Token (Ident,Lhs) a
+> curriedLhs = apLhs <$> parens funLhs <*> many1 constrTerm2
+>   where apLhs (f,lhs) ts = (f,ApLhs lhs ts)
+
+> declRhs :: Bool -> Parser Token Rhs a
+> declRhs flat = rhs flat equals
+
+> rhs :: Bool -> Parser Token a b -> Parser Token Rhs b
+> rhs flat eq = rhsExpr <*> localDefs flat
+>   where rhsExpr = SimpleRhs <$-> eq <*> position <*> expr flat
+>               <|> GuardedRhs <$> many1 (condExpr flat eq)
+
+> externalDecl :: Parser Token Decl a
+> externalDecl =
+>   ExternalDecl <$> position <*-> token KW_external
+>                <*> callConv <*> (Just <$> string `opt` Nothing)
+>                <*> fun <*-> token DoubleColon <*> type0
+>   where callConv = CallConvPrimitive <$-> token Id_primitive
+>                <|> CallConvCCall <$-> token Id_ccall
+>                <?> "Unsupported calling convention"
+
+\end{verbatim}
+\paragraph{Interface declarations}
+\begin{verbatim}
+
+> --intfDecls :: Parser Token [IDecl] a
+> --intfDecls = (:) <$> iImportDecl <*> (semicolon <-*> intfDecls `opt` [])
+> --        <|> intfDecl `sepBy` semicolon
+
+> --intfDecl :: Parser Token IDecl a
+> --intfDecl = iInfixDecl
+> --       <|> iHidingDecl <|> iDataDecl <|> iNewtypeDecl <|> iTypeDecl
+> --       <|> iFunctionDecl <\> token Id_hiding
+
+> --iImportDecl :: Parser Token IDecl a
+> --iImportDecl = IImportDecl <$> position <*-> token KW_import <*> mIdent
+
+> --iInfixDecl :: Parser Token IDecl a
+> --iInfixDecl = infixDeclLhs IInfixDecl <*> qfunop
+
+> --iHidingDecl :: Parser Token IDecl a
+> --iHidingDecl = position <*-> token Id_hiding <**> (dataDecl <|> funcDecl)
+> --  where dataDecl = hiddenData <$-> token KW_data <*> tycon <*> many tyvar
+> --        funcDecl = hidingFunc <$-> token DoubleColon <*> type0
+> --        hiddenData tc tvs p = HidingDataDecl p tc tvs
+> --        hidingFunc ty p = IFunctionDecl p hidingId ty
+> --        hidingId = qualify (mkIdent "hiding")
+
+> --iDataDecl :: Parser Token IDecl a
+> --iDataDecl = iTypeDeclLhs IDataDecl KW_data <*> constrs
+> --  where constrs = equals <-*> iConstrDecl `sepBy1` bar
+> --            `opt` []
+> --        iConstrDecl = Just <$> constrDecl False <\> token Underscore
+> --                  <|> Nothing <$-> token Underscore
+
+> --iNewtypeDecl :: Parser Token IDecl a
+> --iNewtypeDecl =
+> --  iTypeDeclLhs INewtypeDecl KW_newtype <*-> equals <*> newConstrDecl
+
+> --iTypeDecl :: Parser Token IDecl a
+> --iTypeDecl = iTypeDeclLhs ITypeDecl KW_type <*-> equals <*> type0
+
+> --iTypeDeclLhs :: (Position -> QualIdent -> [Ident] -> a) -> Category
+> --             -> Parser Token a b
+> --iTypeDeclLhs f kw = f <$> position <*-> token kw <*> qtycon <*> many tyvar
+
+> --iFunctionDecl :: Parser Token IDecl a
+> --iFunctionDecl = IFunctionDecl <$> position <*> qfun <*-> token DoubleColon
+> --                              <*> type0
+
+\end{verbatim}
+\paragraph{Types}
+\begin{verbatim}
+
+> type0 :: Parser Token TypeExpr a
+> type0 = type1 `chainr1` (ArrowType <$-> token RightArrow)
+
+> type1 :: Parser Token TypeExpr a
+> type1 = ConstructorType <$> qtycon <*> many type2
+>     <|> type2 <\> qtycon
+
+> type2 :: Parser Token TypeExpr a
+> type2 = anonType <|> identType <|> parenType <|> listType
+
+> anonType :: Parser Token TypeExpr a
+> anonType = VariableType anonId <$-> token Underscore
+
+> identType :: Parser Token TypeExpr a
+> identType = VariableType <$> tyvar
+>         <|> flip ConstructorType [] <$> qtycon <\> tyvar
+
+> parenType :: Parser Token TypeExpr a
+> parenType = parens tupleType
+
+> tupleType :: Parser Token TypeExpr a
+> tupleType = type0 <??> (tuple <$> many1 (comma <-*> type0))
+>       `opt` TupleType []
+>   where tuple tys ty = TupleType (ty:tys)
+
+> listType :: Parser Token TypeExpr a
+> listType = ListType <$> brackets type0
+
+\end{verbatim}
+\paragraph{Literals}
+\begin{verbatim}
+
+> literal :: Parser Token Literal a
+> literal = mk Char   <$> char
+>       <|> mkInt     <$> integer
+>       <|> mk Float  <$> float
+>       <|> mk String <$> string
+
+\end{verbatim}
+\paragraph{Patterns}
+\begin{verbatim}
+
+> constrTerm0 :: Parser Token ConstrTerm a
+> constrTerm0 = constrTerm1 `chainr1` (flip InfixPattern <$> gconop)
+
+> constrTerm1 :: Parser Token ConstrTerm a
+> constrTerm1 = varId <**> identPattern
+>	    <|> ConstructorPattern <$> qConId <\> varId <*> many constrTerm2
+>           <|> minus <**> negNum
+>           <|> fminus <**> negFloat
+>           <|> leftParen <-*> parenPattern
+>           <|> constrTerm2 <\> qConId <\> leftParen
+>   where identPattern = optAsPattern
+>                    <|> conPattern <$> many1 constrTerm2
+>         parenPattern = minus <**> minusPattern negNum
+>                    <|> fminus <**> minusPattern negFloat
+>                    <|> gconPattern
+>                    <|> funSym <\> minus <\> fminus <*-> rightParen
+>                                                    <**> identPattern
+>                    <|> parenTuplePattern <\> minus <\> fminus <*-> rightParen
+>         minusPattern p = rightParen <-*> identPattern
+>                      <|> parenMinusPattern p <*-> rightParen
+>         gconPattern = ConstructorPattern <$> gconId <*-> rightParen
+>                                          <*> many constrTerm2
+>         conPattern ts = flip ConstructorPattern ts . qualify
+
+> constrTerm2 :: Parser Token ConstrTerm a
+> constrTerm2 = literalPattern <|> anonPattern <|> identPattern
+>           <|> parenPattern <|> listPattern <|> lazyPattern
+>	    <|> recordPattern
+
+> literalPattern :: Parser Token ConstrTerm a
+> literalPattern = LiteralPattern <$> literal
+
+> anonPattern :: Parser Token ConstrTerm a
+> anonPattern = VariablePattern anonId <$-> token Underscore
+
+> identPattern :: Parser Token ConstrTerm a
+> identPattern = varId <**> optAsPattern
+>            <|> flip ConstructorPattern [] <$> qConId <\> varId
+
+> parenPattern :: Parser Token ConstrTerm a
+> parenPattern = leftParen <-*> parenPattern
+>   where parenPattern = minus <**> minusPattern negNum
+>                    <|> fminus <**> minusPattern negFloat
+>                    <|> flip ConstructorPattern [] <$> gconId <*-> rightParen
+>                    <|> funSym <\> minus <\> fminus <*-> rightParen
+>                                                    <**> optAsPattern
+>                    <|> parenTuplePattern <\> minus <\> fminus <*-> rightParen
+>         minusPattern p = rightParen <-*> optAsPattern
+>                      <|> parenMinusPattern p <*-> rightParen
+
+> listPattern :: Parser Token ConstrTerm a
+> listPattern = mk' ListPattern <$> brackets (constrTerm0 `sepBy` comma)
+
+> lazyPattern :: Parser Token ConstrTerm a
+> lazyPattern = mk LazyPattern <$-> token Tilde <*> constrTerm2
+
+> recordPattern :: Parser Token ConstrTerm a
+> recordPattern = layoutOff <-*> braces content
+>   where
+>   content = RecordPattern <$> fields <*> record
+>   fields = fieldPatt `sepBy` comma
+>   fieldPatt = Field <$> position <*> labId <*-> checkEquals <*> constrTerm0
+>   record = Just <$-> checkBar <*> constrTerm2 `opt` Nothing
+
+\end{verbatim}
+Partial patterns used in the combinators above, but also for parsing
+the left-hand side of a declaration.
+\begin{verbatim}
+
+> gconId :: Parser Token QualIdent a
+> gconId = colon <|> tupleCommas
+
+> negNum,negFloat :: Parser Token (Ident -> ConstrTerm) a
+> negNum = flip NegativePattern 
+>          <$> (mkInt <$> integer <|> mk Float <$> float)
+> negFloat = flip NegativePattern . mk Float 
+>            <$> (fromIntegral <$> integer <|> float)
+
+> optAsPattern :: Parser Token (Ident -> ConstrTerm) a
+> optAsPattern = flip AsPattern <$-> token At <*> constrTerm2
+>          `opt` VariablePattern
+
+> optInfixPattern :: Parser Token (ConstrTerm -> ConstrTerm) a
+> optInfixPattern = infixPat <$> gconop <*> constrTerm0
+>             `opt` id
+>   where infixPat op t2 t1 = InfixPattern t1 op t2
+
+> optTuplePattern :: Parser Token (ConstrTerm -> ConstrTerm) a
+> optTuplePattern = tuple <$> many1 (comma <-*> constrTerm0)
+>             `opt` ParenPattern
+>   where tuple ts t = mk TuplePattern (t:ts)
+
+> parenMinusPattern :: Parser Token (Ident -> ConstrTerm) a
+>                   -> Parser Token (Ident -> ConstrTerm) a
+> parenMinusPattern p = p <.> optInfixPattern <.> optTuplePattern
+
+> parenTuplePattern :: Parser Token ConstrTerm a
+> parenTuplePattern = constrTerm0 <**> optTuplePattern
+>               `opt` mk TuplePattern []
+
+\end{verbatim}
+\paragraph{Expressions}
+\begin{verbatim}
+
+> condExpr :: Bool -> Parser Token a b -> Parser Token CondExpr b
+> condExpr flat eq =
+>   CondExpr <$> position <*-> bar <*> expr0 flat <*-> eq <*> expr flat
+
+> expr :: Bool -> Parser Token Expression a
+> expr flat = expr0 flat <??> (flip Typed <$-> token DoubleColon <*> type0)
+
+> expr0 :: Bool -> Parser Token Expression a
+> expr0 flat = expr1 flat `chainr1` (flip InfixApply <$> infixOp)
+
+> expr1 :: Bool -> Parser Token Expression a
+> expr1 flat = UnaryMinus <$> (minus <|> fminus) <*> expr2 flat
+>          <|> expr2 flat
+
+> expr2 :: Bool -> Parser Token Expression a
+> expr2 flat = lambdaExpr flat <|> letExpr flat <|> doExpr flat
+>          <|> ifExpr flat <|> caseExpr flat
+>          <|> expr3 flat <**> applicOrSelect
+>   where
+>   applicOrSelect = flip RecordSelection 
+>	                  <$-> (token RightArrow <?> "-> expected")
+>			  <*> labId
+>		 <|?> (\es e -> foldl1 Apply (e:es))
+>		          <$> many (expr3 flat) 
+
+> expr3 :: Bool -> Parser Token Expression a
+> expr3 flat = expr3' 
+>   where
+>   expr3' = constant <|> variable <|> parenExpr flat
+>        <|> listExpr flat <|> recordExpr flat
+
+> constant :: Parser Token Expression a
+> constant = Literal <$> literal
+
+> variable :: Parser Token Expression a
+> variable = Variable <$> qFunId
+
+> parenExpr :: Bool -> Parser Token Expression a
+> parenExpr flat = parens pExpr
+>   where pExpr = (minus <|> fminus) <**> minusOrTuple
+>             <|> Constructor <$> tupleCommas
+>             <|> leftSectionOrTuple <\> minus <\> fminus
+>             <|> opOrRightSection <\> minus <\> fminus
+>           `opt` mk Tuple []
+>         minusOrTuple = flip UnaryMinus <$> expr1 flat <.> infixOrTuple
+>                  `opt` Variable . qualify
+>         leftSectionOrTuple = expr1 flat <**> infixOrTuple
+>         infixOrTuple = ($ id) <$> infixOrTuple'
+>         infixOrTuple' = infixOp <**> leftSectionOrExp
+>                     <|> (.) <$> (optType <.> tupleExpr)
+>         leftSectionOrExp = expr1 flat <**> (infixApp <$> infixOrTuple')
+>                      `opt` leftSection
+>         optType = flip Typed <$-> token DoubleColon <*> type0
+>             `opt` id
+>         tupleExpr = tuple <$> many1 (comma <-*> expr flat)
+>               `opt` Paren
+>         opOrRightSection = qFunSym <**> optRightSection
+>                        <|> colon <**> optCRightSection
+>                        <|> infixOp <\> colon <\> qFunSym <**> rightSection
+>         optRightSection = (. InfixOp) <$> rightSection `opt` Variable
+>         optCRightSection = (. InfixConstr) <$> rightSection `opt` Constructor
+>         rightSection = flip RightSection <$> expr0 flat
+>         infixApp f e2 op g e1 = f (g . InfixApply e1 op) e2
+>         leftSection op f e = LeftSection (f e) op
+>         tuple es e = mk Tuple (e:es)
+
+> infixOp :: Parser Token InfixOp a
+> infixOp = InfixOp <$> qfunop
+>       <|> InfixConstr <$> colon
+
+> listExpr :: Bool -> Parser Token Expression a
+> listExpr flat = brackets (elements `opt` mk' List [])
+>   where elements = expr flat <**> rest
+>         rest = comprehension
+>            <|> enumeration (flip EnumFromTo) EnumFrom
+>            <|> comma <-*> expr flat <**>
+>                (enumeration (flip3 EnumFromThenTo) (flip EnumFromThen)
+>                <|> list <$> many (comma <-*> expr flat))
+>          `opt` (\e -> mk' List [e])
+>         comprehension = flip (mk ListCompr) <$-> bar <*> quals flat
+>         enumeration enumTo enum =
+>           token DotDot <-*> (enumTo <$> expr flat `opt` enum)
+>         list es e2 e1 = mk' List (e1:e2:es)
+>         flip3 f x y z = f z y x
+
+> recordExpr :: Bool -> Parser Token Expression a
+> recordExpr flat = layoutOff <-*> braces content
+>   where content = RecordConstr <$> fieldConstr `sepBy` comma
+>	            <|?> RecordUpdate <$> fieldUpdate `sepBy` comma
+>		                      <*-> checkBar <*> expr flat
+>	  fieldConstr = Field <$> position <*> labId 
+>		              <*-> checkEquals <*> expr flat
+>	  fieldUpdate = Field <$> position <*> labId 
+>		              <*-> checkBinds <*> expr flat
+
+> lambdaExpr :: Bool -> Parser Token Expression a
+> lambdaExpr flat =
+>   mk Lambda <$-> token Backslash <*> many1 constrTerm2
+>          <*-> (token RightArrow <?> "-> expected") <*> expr flat
+
+> letExpr :: Bool -> Parser Token Expression a
+> letExpr flat = Let <$-> token KW_let <*> layout (valueDecls flat)
+>                    <*-> (token KW_in <?> "in expected") <*> expr flat
+
+> doExpr :: Bool -> Parser Token Expression a
+> doExpr flat = uncurry Do <$-> token KW_do <*> layout (stmts flat)
+
+> ifExpr :: Bool -> Parser Token Expression a
+> ifExpr flat =
+>   mk IfThenElse <$-> token KW_if <*> expr flat
+>              <*-> (token KW_then <?> "then expected") <*> expr flat
+>              <*-> (token KW_else <?> "else expected") <*> expr flat
+
+> caseExpr :: Bool -> Parser Token Expression a
+> caseExpr flat = mk Case <$-> token KW_case <*> expr flat
+>                 <*-> (token KW_of <?> "of expected") <*> layout (alts flat)
+
+> alts :: Bool -> Parser Token [Alt] a
+> alts flat = alt flat `sepBy1` semicolon
+
+> alt :: Bool -> Parser Token Alt a
+> alt flat = Alt <$> position <*> constrTerm0
+>                <*> rhs flat (token RightArrow <?> "-> expected")
+
+\end{verbatim}
+\paragraph{Statements in list comprehensions and \texttt{do} expressions}
+Parsing statements is a bit difficult because the syntax of patterns
+and expressions largely overlaps. The parser will first try to
+recognize the prefix \emph{Pattern}~\texttt{<-} of a binding statement
+and if this fails fall back into parsing an expression statement. In
+addition, we have to be prepared that the sequence
+\texttt{let}~\emph{LocalDefs} can be either a let-statement or the
+prefix of a let expression.
+\begin{verbatim}
+
+> stmts :: Bool -> Parser Token ([Statement],Expression) a
+> stmts flat = stmt flat (reqStmts flat) (optStmts flat)
+
+> reqStmts :: Bool -> Parser Token (Statement -> ([Statement],Expression)) a
+> reqStmts flat = (\(sts,e) st -> (st : sts,e)) <$-> semicolon <*> stmts flat
+
+> optStmts :: Bool -> Parser Token (Expression -> ([Statement],Expression)) a
+> optStmts flat = succeed (mk StmtExpr) <.> reqStmts flat
+>           `opt` (,) []
+
+> quals :: Bool -> Parser Token [Statement] a
+> quals flat = stmt flat (succeed id) (succeed $ mk StmtExpr) `sepBy1` comma
+
+> stmt :: Bool -> Parser Token (Statement -> a) b
+>      -> Parser Token (Expression -> a) b -> Parser Token a b
+> stmt flat stmtCont exprCont = letStmt flat stmtCont exprCont
+>                           <|> exprOrBindStmt flat stmtCont exprCont
+
+> letStmt :: Bool -> Parser Token (Statement -> a) b
+>         -> Parser Token (Expression -> a) b -> Parser Token a b
+> letStmt flat stmtCont exprCont =
+>   token KW_let <-*> layout (valueDecls flat) <**> optExpr
+>   where optExpr = flip Let <$-> token KW_in <*> expr flat <.> exprCont
+>               <|> succeed StmtDecl <.> stmtCont
+
+> exprOrBindStmt :: Bool -> Parser Token (Statement -> a) b
+>                -> Parser Token (Expression -> a) b
+>                -> Parser Token a b
+> exprOrBindStmt flat stmtCont exprCont =
+>        mk StmtBind <$> constrTerm0 <*-> leftArrow <*> expr flat <**> stmtCont
+>   <|?> expr flat <\> token KW_let <**> exprCont
+
+\end{verbatim}
+\paragraph{Literals, identifiers, and (infix) operators}
+\begin{verbatim}
+
+> char :: Parser Token Char a
+> char = cval <$> token CharTok
+
+> int, checkInt :: Parser Token Int a
+> int = ival <$> token IntTok
+> checkInt = int <?> "integer number expected"
+
+> float, checkFloat :: Parser Token Double a
+> float = fval <$> token FloatTok
+> checkFloat = float <?> "floating point number expected"
+
+> integer, checkInteger :: Parser Token Integer a
+> integer = intval <$> token IntegerTok
+> checkInteger = integer <?> "integer number expected"
+
+> string :: Parser Token String a
+> string = sval <$> token StringTok
+
+> tycon, tyvar :: Parser Token Ident a
+> tycon = conId
+> tyvar = varId
+
+> qtycon :: Parser Token QualIdent a
+> qtycon = qConId
+
+> varId, funId, conId, labId :: Parser Token Ident a
+> varId = ident
+> funId = ident
+> conId = ident
+> labId = renameLabel <$> ident
+
+> funSym, conSym :: Parser Token Ident a
+> funSym = sym
+> conSym = sym
+
+> var, fun, con :: Parser Token Ident a
+> var = varId <|> parens (funSym <?> "operator symbol expected")
+> fun = funId <|> parens (funSym <?> "operator symbol expected")
+> con = conId <|> parens (conSym <?> "operator symbol expected")
+
+> funop, conop :: Parser Token Ident a
+> funop = funSym <|> backquotes (funId <?> "operator name expected")
+> conop = conSym <|> backquotes (conId <?> "operator name expected")
+
+> qFunId, qConId, qLabId :: Parser Token QualIdent a
+> qFunId = qIdent
+> qConId = qIdent
+> qLabId = qIdent
+
+> qFunSym, qConSym :: Parser Token QualIdent a
+> qFunSym = qSym
+> qConSym = qSym
+> gConSym = qConSym <|> colon
+
+> qfun, qcon :: Parser Token QualIdent a
+> qfun = qFunId <|> parens (qFunSym <?> "operator symbol expected")
+> qcon = qConId <|> parens (qConSym <?> "operator symbol expected")
+
+> qfunop, qconop, gconop :: Parser Token QualIdent a
+> qfunop = qFunSym <|> backquotes (qFunId <?> "operator name expected")
+> qconop = qConSym <|> backquotes (qConId <?> "operator name expected")
+> gconop = gConSym <|> backquotes (qConId <?> "operator name expected")
+
+> ident :: Parser Token Ident a
+> ident = (\ pos t -> mkIdentPosition pos $ sval t) <$> position <*> 
+>        tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,
+>                Id_interface,Id_primitive,Id_qualified]
+
+> qIdent :: Parser Token QualIdent a
+> qIdent = qualify <$> ident <|> mkQIdent <$> position <*> token QId
+>   where mkQIdent p a = qualifyWith (mkMIdent (modul a)) 
+>                                    (mkIdentPosition p (sval a))
+
+> mIdent :: Parser Token ModuleIdent a
+> mIdent = mIdent <$> position <*> 
+>      tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding,
+>              Id_interface,Id_primitive,Id_qualified]
+>   where mIdent p a = addPositionModuleIdent p $ 
+>                      mkMIdent (modul a ++ [sval a])
+
+> sym :: Parser Token Ident a
+> sym = (\ pos t -> mkIdentPosition pos $ sval t) <$> position <*> 
+>       tokens [Sym,Sym_Dot,Sym_Minus,Sym_MinusDot]
+
+> qSym :: Parser Token QualIdent a
+> qSym = qualify <$> sym <|> mkQIdent <$> position <*> token QSym
+>   where mkQIdent p a = qualifyWith (mkMIdent (modul a)) 
+>                                    (mkIdentPosition p (sval a))
+
+> colon :: Parser Token QualIdent a
+> colon = (\ p _ -> qualify $ addPositionIdent p consId) <$> 
+>         position <*> token Colon
+
+> minus :: Parser Token Ident a
+> minus = (\ p _ -> addPositionIdent p minusId) <$> 
+>         position <*> token Sym_Minus
+
+> fminus :: Parser Token Ident a
+> fminus = (\ p _ -> addPositionIdent p fminusId) <$> 
+>         position <*> token Sym_MinusDot
+
+> tupleCommas :: Parser Token QualIdent a
+> tupleCommas = (\ p str -> qualify $
+>                           addPositionIdent p (tupleId $ 
+>                                               (1 + ) $ 
+>                                               length str))
+>               <$> position <*> many1 comma
+
+\end{verbatim}
+\paragraph{Layout}
+\begin{verbatim}
+
+> layout :: Parser Token a b -> Parser Token a b
+> layout p = layoutOff <-*> bracket leftBraceSemicolon p rightBrace
+>        <|> layoutOn <-*> p <*-> (token VRightBrace <|> layoutEnd)
+
+\end{verbatim}
+\paragraph{More combinators}
+\begin{verbatim}
+
+> braces, brackets, parens, backquotes :: Parser Token a b -> Parser Token a b
+> braces p = bracket leftBrace p rightBrace
+> brackets p = bracket leftBracket p rightBracket
+> parens p = bracket leftParen p rightParen
+> backquotes p = bracket backquote p checkBackquote
+
+\end{verbatim}
+\paragraph{Simple token parsers}
+\begin{verbatim}
+
+> token :: Category -> Parser Token Attributes a
+> token c = attr <$> symbol (Token c NoAttributes)
+>   where attr (Token _ a) = a
+
+> tokens :: [Category] -> Parser Token Attributes a
+> tokens cs = foldr1 (<|>) (map token cs)
+
+> tokenOps :: [(Category,a)] -> Parser Token a b
+> tokenOps cs = ops [(Token c NoAttributes,x) | (c,x) <- cs]
+
+> dot, comma, semicolon, bar, equals, binds :: Parser Token Attributes a
+> dot = token Sym_Dot
+> comma = token Comma
+> semicolon = token Semicolon <|> token VSemicolon
+> bar = token Bar
+> equals = token Equals
+> binds = token Binds
+
+> checkBar, checkEquals, checkBinds :: Parser Token Attributes a
+> checkBar = bar <?> "| expected"
+> checkEquals = equals <?> "= expected"
+> checkBinds = binds <?> ":= expected"
+
+> backquote, checkBackquote :: Parser Token Attributes a
+> backquote = token Backquote
+> checkBackquote = backquote <?> "backquote (`) expected"
+
+> leftParen, rightParen :: Parser Token Attributes a
+> leftParen = token LeftParen
+> rightParen = token RightParen
+
+> leftBracket, rightBracket :: Parser Token Attributes a
+> leftBracket = token LeftBracket
+> rightBracket = token RightBracket
+
+> leftBrace, leftBraceSemicolon, rightBrace :: Parser Token Attributes a
+> leftBrace = token LeftBrace
+> leftBraceSemicolon = token LeftBraceSemicolon
+> rightBrace = token RightBrace
+
+> leftArrow :: Parser Token Attributes a
+> leftArrow = token LeftArrow
+
+\end{verbatim}
+\paragraph{Ident}
+\begin{verbatim}
+
+> mkIdentPosition :: Position -> String -> Ident
+> mkIdentPosition pos str = addPositionIdent pos $ mkIdent str
+
+\end{verbatim}
diff --git a/src/CurrySubdir.hs b/src/CurrySubdir.hs
new file mode 100644
--- /dev/null
+++ b/src/CurrySubdir.hs
@@ -0,0 +1,90 @@
+module CurrySubdir where
+
+import System.FilePath
+import System.Directory
+import System.Time (ClockTime)
+import Control.Monad (when)
+import Data.List(intersperse)
+
+-- some definitions from PathUtils
+
+curDirPath :: FilePath
+curDirPath = "."
+
+-- divide given puth names in directories
+
+path :: String -> [String]
+path = canonPath . separateBy (==pathSeparator) 
+  where
+    canonPath (c:cs) = c:filter (not . null) cs
+
+-- separate a list by separator predicate
+
+separateBy :: (a -> Bool) -> [a] -> [[a]]
+separateBy p = sep id 
+  where
+    sep xs [] = [xs []]
+    sep xs (c:cs) = if p c then xs [] : sep id cs
+                           else sep (xs . (c:)) cs
+
+-- make canonical path from list of directories
+
+unpath :: [String] -> String
+unpath = concat . intersperse [pathSeparator]
+
+--When we split a path into its basename and directory we will make
+--sure that the basename does not contain any path separators.
+ 
+dirname, basename :: FilePath -> FilePath
+dirname  = unpath . init . path
+basename = last . path
+
+-- add a subdirectory to a given filename 
+-- if it is not already present
+
+inSubdir :: String -> String -> String
+inSubdir sub fn = unpath $ add (path fn) 
+  where
+    add ps@[n] = sub:ps
+    add ps@[p,n] | p==sub = ps
+    add (p:ps) = p:add ps
+
+--The sub directory to hide files in:
+
+currySubdir :: String 
+currySubdir = ".curry"
+
+inCurrySubdir :: String -> String
+inCurrySubdir = inSubdir currySubdir
+
+--write a file to curry subdirectory
+
+writeModule :: String -> String -> IO ()
+writeModule filename contents = do
+  --writeFile filename contents
+  let filename' = inCurrySubdir filename
+      subdir = dirname filename'
+  ex <- doesDirectoryExist subdir
+  when (not ex) (createDirectory subdir)
+  writeFile filename' contents
+
+-- do things with file in subdir
+
+onExistingFileDo :: (String -> IO a) -> String -> IO a
+onExistingFileDo act filename = do
+  ex <- doesFileExist filename
+  if ex then act filename 
+        else act $ inCurrySubdir filename
+
+readModule :: String -> IO String
+readModule = onExistingFileDo readFile
+
+maybeReadModule :: String -> IO (Maybe String)
+maybeReadModule filename = 
+  catch (readModule filename >>= return . Just) (\_ -> return Nothing)
+
+doesModuleExist :: String -> IO Bool
+doesModuleExist = onExistingFileDo doesFileExist
+
+getModuleModTime :: String -> IO ClockTime
+getModuleModTime = onExistingFileDo getModificationTime
diff --git a/src/CurrySyntax.lhs b/src/CurrySyntax.lhs
new file mode 100644
--- /dev/null
+++ b/src/CurrySyntax.lhs
@@ -0,0 +1,323 @@
+> {-# LANGUAGE DeriveDataTypeable #-}
+
+% $Id: CurrySyntax.lhs,v 1.43 2004/02/15 22:10:31 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{CurrySyntax.lhs}
+\section{The Parse Tree}
+This module provides the necessary data structures to maintain the
+parsed representation of a Curry program.
+
+\em{Note:} this modified version uses haskell type \texttt{Integer}
+instead of \texttt{Int} for representing integer values. This allows
+an unlimited range of integer constants in Curry programs.
+\begin{verbatim}
+
+> module CurrySyntax where
+> import Ident
+> import Position
+> import Data.Generics
+> import Control.Monad.State
+
+\end{verbatim}
+\paragraph{Modules}
+\begin{verbatim}
+
+> data Module = Module ModuleIdent (Maybe ExportSpec) [Decl] 
+>  deriving (Eq,Show,Read,Typeable,Data)
+
+> data ExportSpec = Exporting Position [Export] deriving (Eq,Show,Read,Typeable,Data)
+> data Export =
+>     Export         QualIdent                  -- f/T
+>   | ExportTypeWith QualIdent [Ident]          -- T(C1,...,Cn)
+>   | ExportTypeAll  QualIdent                  -- T(..)
+>   | ExportModule   ModuleIdent
+>   deriving (Eq,Show,Read,Typeable,Data)
+
+\end{verbatim}
+\paragraph{Module declarations}
+\begin{verbatim}
+
+> data ImportSpec =
+>     Importing Position [Import]
+>   | Hiding Position [Import]
+>   deriving (Eq,Show,Read,Typeable,Data)
+> data Import =
+>     Import         Ident            -- f/T
+>   | ImportTypeWith Ident [Ident]    -- T(C1,...,Cn)
+>   | ImportTypeAll  Ident            -- T(..)
+>   deriving (Eq,Show,Read,Typeable,Data)
+
+> data Decl =
+>     ImportDecl Position ModuleIdent Qualified (Maybe ModuleIdent)
+>                (Maybe ImportSpec)
+>   | InfixDecl Position Infix Integer [Ident]
+>   | DataDecl Position Ident [Ident] [ConstrDecl]
+>   | NewtypeDecl Position Ident [Ident] NewConstrDecl
+>   | TypeDecl Position Ident [Ident] TypeExpr
+>   | TypeSig Position [Ident] TypeExpr
+>   | EvalAnnot Position [Ident] EvalAnnotation
+>   | FunctionDecl Position Ident [Equation]
+>   | ExternalDecl Position CallConv (Maybe String) Ident TypeExpr
+>   | FlatExternalDecl Position [Ident]
+>   | PatternDecl Position ConstrTerm Rhs
+>   | ExtraVariables Position [Ident]
+>   deriving (Eq,Show,Read,Typeable,Data)
+
+> data ConstrDecl =
+>     ConstrDecl Position [Ident] Ident [TypeExpr]
+>   | ConOpDecl Position [Ident] TypeExpr Ident TypeExpr
+>   deriving (Eq,Show,Read,Typeable,Data)
+> data NewConstrDecl =
+>   NewConstrDecl Position [Ident] Ident TypeExpr
+>   deriving (Eq,Show,Read,Typeable,Data)
+
+> type Qualified = Bool
+> data Infix = InfixL | InfixR | Infix deriving (Eq,Show,Read,Typeable,Data)
+> data EvalAnnotation = EvalRigid | EvalChoice deriving (Eq,Show,Read,Typeable,Data)
+> data CallConv = CallConvPrimitive | CallConvCCall deriving (Eq,Show,Read,Typeable,Data)
+
+\end{verbatim}
+\paragraph{Module interfaces}
+Interface declarations are restricted to type declarations and signatures. 
+Note that an interface function declaration additionaly contains the 
+function arity (= number of parameters) in order to generate
+correct FlatCurry function applications.
+\begin{verbatim}
+
+> data Interface = Interface ModuleIdent [IDecl] deriving (Eq,Show,Read,Typeable,Data)
+
+> data IDecl =
+>     IImportDecl Position ModuleIdent
+>   | IInfixDecl Position Infix Integer QualIdent
+>   | HidingDataDecl Position Ident [Ident] 
+>   | IDataDecl Position QualIdent [Ident] [Maybe ConstrDecl]
+>   | INewtypeDecl Position QualIdent [Ident] NewConstrDecl
+>   | ITypeDecl Position QualIdent [Ident] TypeExpr
+>   | IFunctionDecl Position QualIdent Int TypeExpr
+>   deriving (Eq,Show,Read,Typeable,Data)
+
+\end{verbatim}
+\paragraph{Types}
+\begin{verbatim}
+
+> data TypeExpr =
+>     ConstructorType QualIdent [TypeExpr]
+>   | VariableType Ident
+>   | TupleType [TypeExpr]
+>   | ListType TypeExpr
+>   | ArrowType TypeExpr TypeExpr
+>   | RecordType [([Ident],TypeExpr)] (Maybe TypeExpr) 
+>     -- {l1 :: t1,...,ln :: tn | r}
+>   deriving (Eq,Show,Read,Typeable,Data)
+
+\end{verbatim}
+\paragraph{Functions}
+\begin{verbatim}
+
+> data Equation = Equation Position Lhs Rhs deriving (Eq,Show,Read,Typeable,Data)
+> data Lhs =
+>     FunLhs Ident [ConstrTerm]
+>   | OpLhs ConstrTerm Ident ConstrTerm
+>   | ApLhs Lhs [ConstrTerm]
+>   deriving (Eq,Show,Read,Typeable,Data)
+> data Rhs =
+>     SimpleRhs Position Expression [Decl]
+>   | GuardedRhs [CondExpr] [Decl]
+>   deriving (Eq,Show,Read,Typeable,Data)
+> data CondExpr = CondExpr Position Expression Expression deriving (Eq,Show,Read,Typeable,Data)
+
+> flatLhs :: Lhs -> (Ident,[ConstrTerm])
+> flatLhs lhs = flat lhs []
+>   where flat (FunLhs f ts) ts' = (f,ts ++ ts')
+>         flat (OpLhs t1 op t2) ts = (op,t1:t2:ts)
+>         flat (ApLhs lhs ts) ts' = flat lhs (ts ++ ts')
+
+\end{verbatim}
+\paragraph{Literals} The \texttt{Ident} argument of an \texttt{Int}
+literal is used for supporting ad-hoc polymorphism on integer
+numbers. An integer literal can be used either as an integer number or
+as a floating-point number depending on its context. The compiler uses
+the identifier of the \texttt{Int} literal for maintaining its type.
+\begin{verbatim}
+
+> data Literal =
+>     Char SrcRef Char                         -- should be Int to handle Unicode
+>   | Int Ident Integer
+>   | Float SrcRef Double
+>   | String SrcRef String                     -- should be [Int] to handle Unicode
+>   deriving (Eq,Show,Read,Typeable,Data)
+
+> mk' :: ([SrcRef] -> a) -> a
+> mk' = ($[])
+
+> mk :: (SrcRef -> a) -> a
+> mk = ($noRef)
+
+> mkInt :: Integer -> Literal
+> mkInt i = mk (\r -> Int (addPositionIdent (AST  r) anonId) i) 
+
+\end{verbatim}
+\paragraph{Patterns}
+\begin{verbatim}
+
+> data ConstrTerm =
+>     LiteralPattern Literal
+>   | NegativePattern Ident Literal
+>   | VariablePattern Ident
+>   | ConstructorPattern QualIdent [ConstrTerm]
+>   | InfixPattern ConstrTerm QualIdent ConstrTerm
+>   | ParenPattern ConstrTerm
+>   | TuplePattern SrcRef [ConstrTerm]
+>   | ListPattern [SrcRef] [ConstrTerm]
+>   | AsPattern Ident ConstrTerm
+>   | LazyPattern SrcRef ConstrTerm
+>   | FunctionPattern QualIdent [ConstrTerm]
+>   | InfixFuncPattern ConstrTerm QualIdent ConstrTerm
+>   | RecordPattern [Field ConstrTerm] (Maybe ConstrTerm)  
+>         -- {l1 = p1, ..., ln = pn}  oder {l1 = p1, ..., ln = pn | p}
+>   deriving (Eq,Show,Read,Typeable,Data)
+
+\end{verbatim}
+\paragraph{Expressions}
+\begin{verbatim}
+
+> data Expression =
+>     Literal Literal
+>   | Variable QualIdent
+>   | Constructor QualIdent
+>   | Paren Expression
+>   | Typed Expression TypeExpr
+>   | Tuple SrcRef [Expression]
+>   | List [SrcRef] [Expression]
+>   | ListCompr SrcRef Expression [Statement] -- the ref corresponds to the main list  
+>   | EnumFrom Expression
+>   | EnumFromThen Expression Expression
+>   | EnumFromTo Expression Expression
+>   | EnumFromThenTo Expression Expression Expression
+>   | UnaryMinus Ident Expression
+>   | Apply Expression Expression
+>   | InfixApply Expression InfixOp Expression
+>   | LeftSection Expression InfixOp
+>   | RightSection InfixOp Expression
+>   | Lambda SrcRef [ConstrTerm] Expression
+>   | Let [Decl] Expression
+>   | Do [Statement] Expression
+>   | IfThenElse SrcRef Expression Expression Expression
+>   | Case SrcRef Expression [Alt]
+>   | RecordConstr [Field Expression]            -- {l1 = e1,...,ln = en}
+>   | RecordSelection Expression Ident           -- e -> l
+>   | RecordUpdate [Field Expression] Expression -- {l1 := e1,...,ln := en | e}
+>   deriving (Eq,Show,Read,Typeable,Data)
+
+> data InfixOp = InfixOp QualIdent | InfixConstr QualIdent deriving (Eq,Show,Read,Typeable,Data)
+
+> data Statement =
+>     StmtExpr SrcRef Expression
+>   | StmtDecl [Decl]
+>   | StmtBind SrcRef ConstrTerm Expression
+>   deriving (Eq,Show,Read,Typeable,Data)
+
+> data Alt = Alt Position ConstrTerm Rhs deriving (Eq,Show,Read,Typeable,Data)
+
+> data Field a = Field Position Ident a deriving (Eq, Show,Read,Typeable,Data)
+
+> fieldLabel :: Field a -> Ident
+> fieldLabel (Field _ l _) = l
+
+> fieldTerm :: Field a -> a
+> fieldTerm (Field _ _ t) = t
+
+> field2Tuple :: Field a -> (Ident,a)
+> field2Tuple (Field _ l t) = (l,t)
+
+> opName :: InfixOp -> QualIdent
+> opName (InfixOp op) = op
+> opName (InfixConstr c) = c
+
+\end{verbatim}
+\paragraph{Goals}
+A goal is equivalent to an unconditional right hand side of an equation.
+\begin{verbatim}
+
+> data Goal = Goal Position Expression [Decl] deriving (Eq,Show,Read,Typeable,Data)
+
+\end{verbatim}
+
+> instance SrcRefOf ConstrTerm where
+>   srcRefOf (LiteralPattern l) = srcRefOf l
+>   srcRefOf (NegativePattern i _) = srcRefOf i
+>   srcRefOf (VariablePattern i) = srcRefOf i
+>   srcRefOf (ConstructorPattern i _) = srcRefOf i
+>   srcRefOf (InfixPattern _ i _) = srcRefOf i
+>   srcRefOf (ParenPattern c) = srcRefOf c
+>   srcRefOf (TuplePattern s _) = s
+>   srcRefOf (ListPattern s _) = error "list pattern has several source refs"
+>   srcRefOf (AsPattern i _) = srcRefOf i
+>   srcRefOf (LazyPattern s _) = s
+>   srcRefOf (FunctionPattern i _) = srcRefOf i
+>   srcRefOf (InfixFuncPattern _ i _) = srcRefOf i
+
+> instance SrcRefOf CurrySyntax.Literal where
+>   srcRefOf (Char s _)   = s
+>   srcRefOf (Int i _)    = srcRefOf i
+>   srcRefOf (Float s _)  = s
+>   srcRefOf (String s _) = s
+
+---------------------------
+-- add source references
+---------------------------
+
+> type M a = a -> State Int a
+> 
+> addSrcRefs :: Module -> Module
+> addSrcRefs x = evalState (addRef x) 0
+>   where 
+>     addRef :: Data a' => M a' 
+>     addRef = down `extM` addRefPos   
+>                   `extM` addRefSrc   
+>                   `extM` addRefIdent
+>                   `extM` addRefListPat
+>                   `extM` addRefListExp
+>       where
+>         down :: Data a' => M a'
+>         down = gmapM addRef
+> 
+>         addRefPos :: M [SrcRef]
+>         addRefPos _ = liftM (:[]) next
+> 
+>         addRefSrc :: M SrcRef
+>         addRefSrc _ = next
+> 
+>         addRefIdent :: M Ident
+>         addRefIdent ident = liftM (flip addRefId ident) next
+>
+>         addRefListPat :: M ConstrTerm
+>         addRefListPat (ListPattern _ ts) = do
+>           liftM (uncurry ListPattern) (addRefList ts)
+>         addRefListPat ct = gmapM addRef ct
+>   
+>         addRefListExp :: M Expression
+>         addRefListExp (List _ ts) = do
+>           liftM (uncurry List) (addRefList ts)
+>         addRefListExp ct = gmapM addRef ct
+>   
+>         addRefList :: Data a' => [a'] -> State Int ([SrcRef],[a'])
+>         addRefList ts = do
+>           i <- next
+>           let add t = do t' <- addRef t;j <- next; return (j,t')
+>           ists <- sequence (map add ts)
+>           let (is,ts') = unzip ists
+>           return (i:is,ts')
+>          
+>         current,next :: State Int SrcRef
+>         current = liftM (SrcRef . (:[])) get
+>
+>         next = do
+>           i <- get
+>           put $! i+1
+>           return (SrcRef [i])
diff --git a/src/Desugar.lhs b/src/Desugar.lhs
new file mode 100644
--- /dev/null
+++ b/src/Desugar.lhs
@@ -0,0 +1,917 @@
+
+% $Id: Desugar.lhs,v 1.42 2004/02/15 22:10:32 wlux Exp $
+%
+% Copyright (c) 2001-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{Desugar.lhs}
+\section{Desugaring Curry Expressions}
+The desugaring pass removes all syntactic sugar from the module. In
+particular, the output of the desugarer will have the following
+properties.
+\begin{itemize}
+\item All function definitions are $\eta$-expanded.\\
+  {\em Note:} Since this version is used as a frontend for PAKCS, the 
+  $\eta$-expansion had been disabled.
+\item No guarded right hand sides occur in equations, pattern
+  declarations, and case alternatives. In addition, the declaration
+  lists of the right hand sides are empty; local declarations are
+  transformed into let expressions.
+\item Patterns in equations and case alternatives are composed only of
+  \begin{itemize}
+  \item literals,
+  \item variables,
+  \item constructor applications, and
+  \item as patterns.
+  \end{itemize}
+\item Expressions are composed only of
+  \begin{itemize}
+  \item literals,
+  \item variables,
+  \item constructors,
+  \item (binary) applications,
+  \item let expressions, and
+  \item case expressions.
+  \end{itemize}
+\item Applications $N\:x$ in patterns and expressions, where $N$ is a
+  newtype constructor, are replaced by a $x$. Note that neither the
+  newtype declaration itself nor partial applications of newtype
+  constructors are changed.\footnote{It were possible to replace
+  partial applications of newtype constructor by \texttt{prelude.id}.
+  However, our solution yields a more accurate output when the result
+  of a computation includes partial applications.}
+\item Function patterns are replaced by variables and are integrated
+  in a guarded right hand side using the \texttt{=:<=} operator
+\item Records, which currently must be declared using the keyword
+  \texttt{type}, are transformed into data types with one constructor.
+  Record construction and pattern matching are represented using the
+  record constructor. Selection and update are represented using selector
+  and update functions which are generated for each record declaration.
+  The record constructor must be entered into the type environment as well
+  as the selector functions and the update functions. 
+\end{itemize}
+
+\ToDo{Use a different representation for the restricted code instead
+of using the syntax tree from \texttt{CurrySyntax}.}
+
+\textbf{As we are going to insert references to real prelude entities,
+all names must be properly qualified before calling this module.}
+\begin{verbatim}
+
+> module Desugar(desugar,desugarGoal) where
+
+> import Data.Maybe
+> import Control.Monad
+> import Data.List
+
+> import Base
+> import Combined
+> import Typing
+> import Utils
+> import Ident
+
+
+posE = undefined
+
+\end{verbatim}
+New identifiers may be introduced while desugaring pattern
+declarations, case and $\lambda$-expressions, and list comprehensions.
+As usual, we use a state monad transformer for generating unique
+names. In addition, the state is also used for passing through the
+type environment, which must be augmented with the types of these new
+variables.
+\begin{verbatim}
+
+> type DesugarState a = StateT ValueEnv (StateT Int Id) a
+
+> run :: DesugarState a -> ValueEnv -> a
+> run m tyEnv = runSt (callSt m tyEnv) 1
+
+\end{verbatim}
+The desugaring phase keeps only the type, function, and value
+declarations of the module. In the current version record declarations
+are transformed into data types. The remaining type declarations are
+not desugared and cannot occur in local declaration groups.
+They are filtered out separately.
+
+In order to use records within other modules, the export specification
+of the module has to be extended with the selector and update functions of
+all exported labels.
+
+Actually, the transformation is slightly more general than necessary
+as it allows value declarations at the top-level of a module.
+\begin{verbatim}
+
+> desugar :: ValueEnv -> TCEnv -> Module -> (Module,ValueEnv)
+> desugar tyEnv tcEnv (Module m es ds) = (Module m es ds',tyEnv')
+>   where (ds',tyEnv') = run (desugarModule m tcEnv ds) tyEnv
+
+> desugarModule :: ModuleIdent -> TCEnv -> [Decl] 
+>	        -> DesugarState ([Decl],ValueEnv)
+> desugarModule m tcEnv ds = 
+>   do
+>     dss <- mapM (desugarRecordDecl m tcEnv) ds
+>     let ds' = concat dss
+>     ds'' <- desugarDeclGroup m tcEnv ds'
+>     tyEnv' <- fetchSt
+>     return (filter isTypeDecl ds' ++ ds'', tyEnv')
+
+\end{verbatim}
+While a goal of type \texttt{IO \_} is executed directly by the
+runtime system, all other goals are evaluated under an interactive
+top-level which displays the solutions of the goal and in particular
+the bindings of the free variables. For this reason, the free
+variables declared in the \texttt{where} clause of a goal are
+translated into free variables of the goal. In addition, the goal
+is transformed into a first order expression by performing a
+unification with another variable. Thus, a goal
+\begin{quote}
+ \emph{expr}
+ \texttt{where} $v_1$,\dots,$v_n$ \texttt{free}; \emph{decls}
+\end{quote}
+where no free variable declarations occur in \emph{decls} is
+translated into the function
+\begin{quote}
+  \emph{f} $v_0$ $v_1$ \dots{} $v_n$ \texttt{=}
+    $v_0$ \texttt{=:=} \emph{expr}
+    \texttt{where} \emph{decls}
+\end{quote}
+where $v_0$ is a fresh variable.
+
+\textbf{Note:} The debugger assumes that the goal is always a nullary
+function. This means that we must not $\eta$-expand functional goal
+expressions. In order to avoid the $\eta$-expansion we cheat a little
+bit here and change the type of the goal into $\forall\alpha.\alpha$
+if it really has a functional type.
+
+\ToDo{Fix the debugger to handle functional goals so that this
+hack is no longer needed.}
+\begin{verbatim}
+
+> desugarGoal :: Bool -> ValueEnv -> TCEnv -> ModuleIdent -> Ident -> Goal
+>             -> (Maybe [Ident],Module,ValueEnv)
+> desugarGoal debug tyEnv tcEnv m g (Goal p e ds)
+>   | debug || isIO ty =
+>       desugarGoalIO tyEnv tcEnv p m g (Let ds e)
+>         (if debug && arrowArity ty > 0 then typeVar 0 else ty)
+>   | otherwise = desugarGoal' tyEnv tcEnv p m g vs e' ty
+>   where ty = typeOf tyEnv e
+>         (vs,e') = liftGoalVars (if null ds then e else Let ds e)
+>         isIO (TypeConstructor tc [_]) = tc == qIOId
+>         isIO _ = False
+
+> desugarGoalIO :: ValueEnv -> TCEnv -> Position -> ModuleIdent -> Ident
+>               -> Expression -> Type -> (Maybe [Ident],Module,ValueEnv)
+> desugarGoalIO tyEnv tcEnv p m g e ty =
+>   (Nothing,
+>    Module m Nothing [goalDecl p g [] e'],
+>    bindFun m g (polyType ty) tyEnv')
+>   where (e',tyEnv') = run (desugarGoalExpr m tcEnv e) tyEnv
+
+> desugarGoal' :: ValueEnv -> TCEnv -> Position -> ModuleIdent -> Ident -> [Ident]
+>              -> Expression -> Type -> (Maybe [Ident],Module,ValueEnv)
+> desugarGoal' tyEnv tcEnv p m g vs e ty =
+>   (Just vs',
+>    Module m Nothing [goalDecl p g (v0:vs') (apply prelUnif [mkVar v0,e'])],
+>    bindFun m v0 (monoType ty) (bindFun m g (polyType ty') tyEnv'))
+>   where (e',tyEnv') = run (desugarGoalExpr m tcEnv e) tyEnv
+>         v0 = anonId
+>         vs' = filter (`elem` qfv m e') vs
+>         ty' = TypeArrow ty (foldr (TypeArrow . typeOf tyEnv) successType vs')
+
+> goalDecl :: Position -> Ident -> [Ident] -> Expression -> Decl
+> goalDecl p g vs e = funDecl p g (map VariablePattern vs) e
+
+> desugarGoalExpr :: ModuleIdent -> TCEnv -> Expression
+>                 -> DesugarState (Expression,ValueEnv)
+> desugarGoalExpr m tcEnv e =
+>   do
+>     e' <- desugarExpr m tcEnv (first "") e
+>     tyEnv' <- fetchSt
+>     return (e',tyEnv')
+
+> liftGoalVars :: Expression -> ([Ident],Expression)
+> liftGoalVars (Let ds e) =
+>   (concat [vs | ExtraVariables _ vs <- vds],Let ds' e)
+>   where (vds,ds') = partition isExtraVariables ds
+> liftGoalVars e = ([],e)
+
+\end{verbatim}
+Within a declaration group, all type signatures and evaluation
+annotations are discarded. First, the patterns occurring in the left
+hand sides are desugared. Due to lazy patterns this may add further
+declarations to the group that must be desugared as well.
+\begin{verbatim}
+
+> desugarDeclGroup :: ModuleIdent -> TCEnv -> [Decl] -> DesugarState [Decl]
+> desugarDeclGroup m tcEnv ds =
+>   do
+>     dss' <- mapM (desugarDeclLhs m tcEnv) (filter isValueDecl ds)
+>     mapM (desugarDeclRhs m tcEnv) (concat dss')
+
+> desugarDeclLhs :: ModuleIdent -> TCEnv -> Decl -> DesugarState [Decl]
+> desugarDeclLhs m tcEnv (PatternDecl p t rhs) =
+>   do
+>     (ds',t') <- desugarTerm m tcEnv p [] t
+>     dss' <- mapM (desugarDeclLhs m tcEnv) ds'
+>     return (PatternDecl p t' rhs : concat dss')
+> desugarDeclLhs m tcEnv (FlatExternalDecl p fs) =
+>   do
+>     tyEnv <- fetchSt
+>     return (map (externalDecl tyEnv p) fs)
+>   where externalDecl tyEnv p f =
+>           ExternalDecl p CallConvPrimitive (Just (name f)) f
+>                        (fromType (typeOf tyEnv (Variable (qual f))))
+>         qual f
+>           | unRenameIdent f == f = qualifyWith m f
+>           | otherwise = qualify f
+> desugarDeclLhs _ _ d = return [d]
+
+\end{verbatim}
+After desugaring its right hand side, each equation is $\eta$-expanded
+by adding as many variables as necessary to the argument list and
+applying the right hand side to those variables ({\em Note:} $\eta$-expansion
+is disabled in the version for PAKCS).
+Furthermore every occurrence of a record type within the type of a function
+is simplified to the corresponding type constructor from the record
+declaration. This is possible because currently records must not be empty
+and a record label belongs to only one record declaration.
+\begin{verbatim}
+
+> desugarDeclRhs :: ModuleIdent -> TCEnv -> Decl -> DesugarState Decl
+> desugarDeclRhs m tcEnv (FunctionDecl p f eqs) =
+>   do
+>     tyEnv <- fetchSt
+>     let ty =  (flip typeOf (Variable (qual f))) tyEnv
+>     liftM (FunctionDecl p f) 
+>	    (mapM (desugarEquation m tcEnv (arrowArgs ty)) eqs)
+>   where qual f
+>           | unRenameIdent f == f = qualifyWith m f
+>           | otherwise = qualify f
+> desugarDeclRhs _ tcEnv (ExternalDecl p cc ie f ty) =
+>   return (ExternalDecl p cc (ie `mplus` Just (name f)) f ty)
+> desugarDeclRhs m tcEnv (PatternDecl p t rhs) =
+>   liftM (PatternDecl p t) (desugarRhs m tcEnv p rhs)
+> desugarDeclRhs _ tcEnv (ExtraVariables p vs) = return (ExtraVariables p vs)
+
+> desugarEquation :: ModuleIdent -> TCEnv -> [Type] -> Equation 
+>	          -> DesugarState Equation
+> desugarEquation m tcEnv tys (Equation p lhs rhs) =
+>   do
+>     (ds',ts') <- mapAccumM (desugarTerm m tcEnv p) [] ts
+>     rhs' <- desugarRhs m tcEnv p (addDecls ds' rhs)
+>     (ts'', rhs'') <- desugarFunctionPatterns m p ts' rhs'
+>     return (Equation p (FunLhs f ts'') rhs'')
+>   where (f,ts) = flatLhs lhs
+
+
+\end{verbatim}
+The transformation of patterns is straight forward except for lazy
+patterns. A lazy pattern \texttt{\~}$t$ is replaced by a fresh
+variable $v$ and a new local declaration $t$~\texttt{=}~$v$ in the
+scope of the pattern. In addition, as-patterns $v$\texttt{@}$t$ where
+$t$ is a variable or an as-pattern are replaced by $t$ in combination
+with a local declaration for $v$.
+\begin{verbatim}
+
+> desugarLiteral :: Literal -> DesugarState (Either Literal ([SrcRef],[Literal]))
+> desugarLiteral (Char p c) = return (Left (Char p c))
+> desugarLiteral (Int v i)  = liftM (Left . fixType) fetchSt
+>   where 
+>    fixType tyEnv
+>      | typeOf tyEnv v == floatType 
+>          = Float (ast $ positionOfIdent v) (fromIntegral i)
+>      | otherwise = Int v i
+> desugarLiteral (Float p f) = return (Left (Float p f))
+> desugarLiteral (String (SrcRef [i]) cs) 
+>   = return (Right (consRefs i cs,zipWith (Char . SrcRef . (:[])) [i,i+2..] cs))
+>   where consRefs r []     = [SrcRef [r]]
+>         consRefs r (_:xs) = let r'=r+2 in r' `seq` (SrcRef [r']:consRefs r' xs)
+> desugarLiteral (String is _) = error $ "internal error desugarLiteral; "++
+>                                        "wrong source ref for string: "  ++ show is
+
+> desugarList :: [SrcRef] -> (SrcRef -> b -> b -> b) -> (SrcRef -> b) -> [b] -> b
+> desugarList pos cons nil xs = snd (foldr cons' nil' xs)
+>   where rNil:rCs = reverse pos 
+>         nil'                = (rCs,nil rNil)
+>         cons' t (rC:rCs,ts) = (rCs,cons rC t ts)
+
+> desugarTerm :: ModuleIdent -> TCEnv -> Position -> [Decl] -> ConstrTerm
+>             -> DesugarState ([Decl],ConstrTerm)
+> desugarTerm m tcEnv p ds (LiteralPattern l) =
+>   desugarLiteral l >>=
+>   either (return . (,) ds . LiteralPattern)
+>          (\ (pos,ls) -> desugarTerm m tcEnv p ds $ ListPattern pos $ map LiteralPattern ls)
+> desugarTerm m tcEnv p ds (NegativePattern _ l) =
+>   desugarTerm m tcEnv p ds (LiteralPattern (negateLiteral l))
+>   where negateLiteral (Int v i) = Int v (-i)
+>         negateLiteral (Float p f) = Float p (-f)
+>         negateLiteral _ = internalError "negateLiteral"
+> desugarTerm _ _ _ ds (VariablePattern v) = return (ds,VariablePattern v)
+> desugarTerm m tcEnv p ds (ConstructorPattern c [t]) =
+>   do
+>     tyEnv <- fetchSt
+>     liftM (if isNewtypeConstr tyEnv c then id else apSnd (constrPat c))
+>           (desugarTerm m tcEnv p ds t)
+>   where constrPat c t = ConstructorPattern c [t]
+> desugarTerm m tcEnv p ds (ConstructorPattern c ts) =
+>   liftM (apSnd (ConstructorPattern c)) (mapAccumM (desugarTerm m tcEnv p) ds ts)
+> desugarTerm m tcEnv p ds (InfixPattern t1 op t2) =
+>   desugarTerm m tcEnv p ds (ConstructorPattern op [t1,t2])
+> desugarTerm m tcEnv p ds (ParenPattern t) = desugarTerm m tcEnv p ds t
+> desugarTerm m tcEnv p ds (TuplePattern pos ts) =
+>   desugarTerm m tcEnv p ds (ConstructorPattern (tupleConstr ts) ts)
+>   where tupleConstr ts = addRef pos $ 
+>                          if null ts then qUnitId else qTupleId (length ts)
+> desugarTerm m tcEnv p ds (ListPattern pos ts) =
+>   liftM (apSnd (desugarList pos cons nil)) (mapAccumM (desugarTerm m tcEnv p) ds ts)
+>   where nil  p' = ConstructorPattern (addRef p' qNilId) []
+>         cons p' t ts = ConstructorPattern (addRef p' qConsId) [t,ts]
+
+> desugarTerm m tcEnv p ds (AsPattern v t) =
+>   liftM (desugarAs p v) (desugarTerm m tcEnv p ds t)
+> desugarTerm m tcEnv p ds (LazyPattern pos t) = desugarLazy pos m p ds t
+> desugarTerm m tcEnv p ds (FunctionPattern f ts) =
+>   liftM (apSnd (FunctionPattern f)) (mapAccumM (desugarTerm m tcEnv p) ds ts)
+> desugarTerm m tcEnv p ds (InfixFuncPattern t1 f t2) =
+>   desugarTerm m tcEnv p ds (FunctionPattern f [t1,t2])
+> desugarTerm m tcEnv p ds (RecordPattern fs _)
+>   | null fs = internalError "desugarTerm: empty record"
+>   | otherwise =
+>     do tyEnv <- fetchSt 
+>	 case (lookupValue (fieldLabel (head fs)) tyEnv) of
+>          [Label _ r _] -> 
+>            desugarRecordPattern m tcEnv p ds (map field2Tuple fs) r
+>          _ -> internalError "desugarTerm: no label"
+
+> desugarAs :: Position -> Ident -> ([Decl],ConstrTerm) -> ([Decl],ConstrTerm)
+> desugarAs p v (ds,t) =
+>  case t of
+>    VariablePattern v' -> (varDecl p v (mkVar v') : ds,t)
+>    AsPattern v' _ -> (varDecl p v (mkVar v') : ds,t)
+>    _ -> (ds,AsPattern v t)
+
+> desugarLazy :: SrcRef -> ModuleIdent -> Position -> [Decl] -> ConstrTerm
+>             -> DesugarState ([Decl],ConstrTerm)
+> desugarLazy pos m p ds t =
+>   case t of
+>     VariablePattern _ -> return (ds,t)
+>     ParenPattern t' -> desugarLazy pos m p ds t'
+>     AsPattern v t' -> liftM (desugarAs p v) (desugarLazy pos m p ds t')
+>     LazyPattern pos t' -> desugarLazy pos m p ds t'
+>     _ ->
+>       do
+>         v0 <- fetchSt >>= freshIdent m "_#lazy" . monoType . flip typeOf t
+>         let v' = addPositionIdent (AST pos) v0
+>         return (patDecl p{ast=pos} t (mkVar v') : ds,VariablePattern v')
+
+
+\end{verbatim}
+A list of boolean guards is expanded into a nested if-then-else
+expression, whereas a constraint guard is replaced by a case
+expression. Note that if the guard type is \texttt{Success} only a
+single guard is allowed for each equation.\footnote{This change was
+introduced in version 0.8 of the Curry report.} We check for the
+type \texttt{Bool} of the guard because the guard's type defaults to
+\texttt{Success} if it is not restricted by the guard expression.
+\begin{verbatim}
+
+> desugarRhs :: ModuleIdent -> TCEnv -> Position -> Rhs -> DesugarState Rhs
+> desugarRhs m tcEnv p rhs =
+>   do
+>     tyEnv <- fetchSt
+>     e' <- desugarExpr m tcEnv p (expandRhs tyEnv prelFailed rhs)
+>     return (SimpleRhs p e' [])
+
+> expandRhs :: ValueEnv -> Expression -> Rhs -> Expression
+> expandRhs tyEnv _ (SimpleRhs _ e ds) = Let ds e
+> expandRhs tyEnv e0 (GuardedRhs es ds) = Let ds (expandGuards tyEnv e0 es)
+
+> expandGuards :: ValueEnv -> Expression -> [CondExpr] -> Expression
+> expandGuards tyEnv e0 es
+>   | booleanGuards tyEnv es = foldr mkIfThenElse e0 es
+>   | otherwise = mkCond es
+>   where mkIfThenElse (CondExpr p g e) = IfThenElse (srcRefOf p) g e
+>         mkCond [CondExpr p g e] = Apply (Apply prelCond g) e
+
+> booleanGuards :: ValueEnv -> [CondExpr] -> Bool
+> booleanGuards _ [] = False
+> booleanGuards tyEnv (CondExpr _ g _ : es) =
+>   not (null es) || typeOf tyEnv g == boolType
+
+> desugarExpr :: ModuleIdent -> TCEnv -> Position -> Expression
+>             -> DesugarState Expression
+> desugarExpr m tcEnv p (Literal l) =
+>   desugarLiteral l >>=
+>   either (return . Literal) (\ (pos,ls) -> desugarExpr m tcEnv p $ List pos $ map Literal ls)
+> desugarExpr _ _ _ (Variable v) = return (Variable v)
+> desugarExpr _ _ _ (Constructor c) = return (Constructor c)
+> desugarExpr m tcEnv p (Paren e) = desugarExpr m tcEnv p e
+> desugarExpr m tcEnv p (Typed e _) = desugarExpr m tcEnv p e
+> desugarExpr m tcEnv p (Tuple pos es) =
+>   liftM (apply (Constructor (tupleConstr es))) 
+>         (mapM (desugarExpr m tcEnv p) es)
+>   where tupleConstr es = addRef pos $ if null es then qUnitId else qTupleId (length es)
+> desugarExpr m tcEnv p (List pos es) =
+>   liftM (desugarList pos cons nil) (mapM (desugarExpr m tcEnv p) es)
+>   where nil p'  = Constructor (addRef p' qNilId)
+>         cons p' = Apply . Apply (Constructor $ addRef p' qConsId)
+> desugarExpr m tcEnv p (ListCompr pos e []) = desugarExpr m tcEnv p (List [pos,pos] [e])
+> desugarExpr m tcEnv p (ListCompr r e (q:qs)) = 
+>   desugarQual m tcEnv p q (ListCompr r e qs)
+> desugarExpr m tcEnv p (EnumFrom e) = 
+>   liftM (Apply prelEnumFrom) (desugarExpr m tcEnv p e)
+> desugarExpr m tcEnv p (EnumFromThen e1 e2) =
+>   liftM (apply prelEnumFromThen) (mapM (desugarExpr m tcEnv p) [e1,e2])
+> desugarExpr m tcEnv p (EnumFromTo e1 e2) =
+>   liftM (apply prelEnumFromTo) (mapM (desugarExpr m tcEnv p) [e1,e2])
+> desugarExpr m tcEnv p (EnumFromThenTo e1 e2 e3) =
+>   liftM (apply prelEnumFromThenTo) (mapM (desugarExpr m tcEnv p) [e1,e2,e3])
+> desugarExpr m tcEnv p (UnaryMinus op e) =
+>   do
+>     tyEnv <- fetchSt
+>     liftM (Apply (unaryMinus op (typeOf tyEnv e))) (desugarExpr m tcEnv p e)
+>   where unaryMinus op ty
+>           | op == minusId =
+>               if ty == floatType then prelNegateFloat else prelNegate
+>           | op == fminusId = prelNegateFloat
+>           | otherwise = internalError "unaryMinus"
+> desugarExpr m tcEnv p (Apply (Constructor c) e) =
+>   do
+>     tyEnv <- fetchSt
+>     liftM (if isNewtypeConstr tyEnv c then id else (Apply (Constructor c)))
+>           (desugarExpr m tcEnv p e)
+> desugarExpr m tcEnv p (Apply e1 e2) =
+>   do
+>     e1' <- desugarExpr m tcEnv p e1
+>     e2' <- desugarExpr m tcEnv p e2
+>     return (Apply e1' e2')
+> desugarExpr m tcEnv p (InfixApply e1 op e2) =
+>   do
+>     op' <- desugarExpr m tcEnv p (infixOp op)
+>     e1' <- desugarExpr m tcEnv p e1
+>     e2' <- desugarExpr m tcEnv p e2
+>     return (Apply (Apply op' e1') e2')
+> desugarExpr m tcEnv p (LeftSection e op) =
+>   do
+>     op' <- desugarExpr m tcEnv p (infixOp op)
+>     e' <- desugarExpr m tcEnv p e
+>     return (Apply op' e')
+> desugarExpr m tcEnv p (RightSection op e) =
+>   do
+>     op' <- desugarExpr m tcEnv p (infixOp op)
+>     e' <- desugarExpr m tcEnv p e
+>     return (Apply (Apply prelFlip op') e')
+> desugarExpr m tcEnv p exp@(Lambda r ts e) =
+>   do
+>     f <- fetchSt >>=
+>          freshIdent m "_#lambda" . polyType . flip typeOf exp
+>     desugarExpr m tcEnv p (Let [funDecl (AST r) f ts e] (mkVar f))
+> desugarExpr m tcEnv p (Let ds e) =
+>   do
+>     ds' <- desugarDeclGroup m tcEnv ds
+>     e' <- desugarExpr m tcEnv p e
+>     return (if null ds' then e' else Let ds' e')
+> desugarExpr m tcEnv p (Do sts e) = 
+>   desugarExpr m tcEnv p (foldr desugarStmt e sts)
+>   where desugarStmt (StmtExpr r e) e' = apply (prelBind_ r) [e,e']
+>         desugarStmt (StmtBind r t e) e' = apply (prelBind r) [e,Lambda r [t] e']
+>         desugarStmt (StmtDecl ds) e' = Let ds e'
+> desugarExpr m tcEnv p (IfThenElse r e1 e2 e3) =
+>   do
+>     e1' <- desugarExpr m tcEnv p e1
+>     e2' <- desugarExpr m tcEnv p e2
+>     e3' <- desugarExpr m tcEnv p e3
+>     return (Case r e1' [caseAlt p truePattern e2',caseAlt p falsePattern e3'])
+> desugarExpr m tcEnv p (Case r e alts)
+>   | null alts = return prelFailed
+>   | otherwise =
+>       do
+>         e' <- desugarExpr m tcEnv p e
+>         v <- fetchSt >>= freshIdent m "_#case" . monoType . flip typeOf e
+>         alts' <- mapM (desugarAltLhs m tcEnv) alts
+>         tyEnv <- fetchSt
+>         alts'' <- mapM (desugarAltRhs m tcEnv)
+>                        (map (expandAlt tyEnv v) (init (tails alts')))
+>         return (mkCase m v e' alts'')
+>   where mkCase m v e alts
+>           | v `elem` qfv m alts = Let [varDecl p v e] (Case r (mkVar v) alts)
+>           | otherwise = Case r e alts
+> desugarExpr m tcEnv p (RecordConstr fs)
+>   | null fs = internalError "desugarExpr: empty record construction"
+>   | otherwise =
+>       do let l = fieldLabel (head fs)
+>	       fs' = map field2Tuple fs
+>          tyEnv <- fetchSt
+>	   case (lookupValue l tyEnv) of
+>            [Label l' r _] -> desugarRecordConstr m tcEnv p r fs'
+>            _  -> internalError "desugarExpr: illegal record construction"
+> desugarExpr m tcEnv p (RecordSelection e l) =
+>   do tyEnv <- fetchSt
+>      case (lookupValue l tyEnv) of
+>        [Label _ r _] -> desugarRecordSelection m tcEnv p r l e
+>        _ -> internalError "desugarExpr: illegal record selection"
+> desugarExpr m tcEnv p (RecordUpdate fs rexpr)
+>   | null fs = internalError "desugarExpr: empty record update"
+>   | otherwise =
+>       do let l = fieldLabel (head fs)
+>	       fs' = map field2Tuple fs
+>          tyEnv <- fetchSt
+>	   case (lookupValue l tyEnv) of
+>            [Label _ r _] -> desugarRecordUpdate m tcEnv p r rexpr fs'
+>            _  -> internalError "desugarExpr: illegal record update"
+
+desugarExpr _ _ _ x = internalError $ "desugarExpr: unexpected expression " ++ show x
+
+\end{verbatim}
+If an alternative in a case expression has boolean guards and all of
+these guards return \texttt{False}, the enclosing case expression does
+not fail but continues to match the remaining alternatives against the
+selector expression. In order to implement this semantics, which is
+compatible with Haskell, we expand an alternative with boolean guards
+such that it evaluates a case expression with the remaining cases that
+are compatible with the matched pattern when the guards fail.
+\begin{verbatim}
+
+> desugarAltLhs :: ModuleIdent -> TCEnv -> Alt -> DesugarState Alt
+> desugarAltLhs m tcEnv (Alt p t rhs) =
+>   do
+>     (ds',t') <- desugarTerm m tcEnv p [] t
+>     return (Alt p t' (addDecls ds' rhs))
+
+> desugarAltRhs :: ModuleIdent -> TCEnv -> Alt -> DesugarState Alt
+> desugarAltRhs m tcEnv (Alt p t rhs) = 
+>   liftM (Alt p t) (desugarRhs m tcEnv p rhs)
+
+> expandAlt :: ValueEnv -> Ident -> [Alt] -> Alt
+> expandAlt tyEnv v (Alt p t rhs : alts) = caseAlt p t (expandRhs tyEnv e0 rhs)
+>   where e0 = Case (srcRefOf p) (mkVar v) 
+>                   (filter (isCompatible t . altPattern) alts)
+>         altPattern (Alt _ t _) = t
+
+> isCompatible :: ConstrTerm -> ConstrTerm -> Bool
+> isCompatible (VariablePattern _) _ = True
+> isCompatible _ (VariablePattern _) = True
+> isCompatible (AsPattern _ t1) t2 = isCompatible t1 t2
+> isCompatible t1 (AsPattern _ t2) = isCompatible t1 t2
+> isCompatible (ConstructorPattern c1 ts1) (ConstructorPattern c2 ts2) =
+>   and ((c1 == c2) : zipWith isCompatible ts1 ts2)
+> isCompatible (LiteralPattern l1) (LiteralPattern l2) = canon l1 == canon l2
+>   where canon (Int _ i) = Int anonId i
+>         canon l = l
+
+\end{verbatim}
+The frontend provides several extensions of the Curry functionality, which
+have to be desugared as well. This part transforms the following extensions:
+\begin{itemize}
+\item runction patterns
+\item records
+\end{itemize}
+\begin{verbatim}
+
+> desugarFunctionPatterns :: ModuleIdent -> Position -> [ConstrTerm] -> Rhs
+>	                     -> DesugarState ([ConstrTerm], Rhs)
+> desugarFunctionPatterns m p ts rhs = 
+>   do (ts', its) <- elimFunctionPattern m p ts
+>      rhs' <- genFunctionPatternExpr m p its rhs
+>      return (ts', rhs')
+
+> desugarRecordDecl :: ModuleIdent -> TCEnv -> Decl -> DesugarState [Decl]
+> desugarRecordDecl m tcEnv (TypeDecl p r vs (RecordType fss _)) =
+>   case (qualLookupTC r' tcEnv) of
+>     [AliasType _ n (TypeRecord fs' _)] ->
+>       do tyEnv <- fetchSt
+>	   let tys = concatMap (\ (ls,ty) -> replicate (length ls) ty) fss
+>	       --tys' = map (elimRecordTypes tyEnv) tys
+>	       rdecl = DataDecl p r vs [ConstrDecl p [] r tys]
+>	       rty' = TypeConstructor r' (map TypeVariable [0 .. n-1])
+>              rcts' = ForAllExist 0 n (foldr TypeArrow rty' (map snd fs'))
+>	   rfuncs <- mapM (genRecordFuncs m tcEnv p r' rty' (map fst fs')) fs'
+>	   updateSt_ (bindGlobalInfo DataConstructor m r rcts')
+>          return (rdecl:(concat rfuncs))
+>     _ -> internalError "desugarRecordDecl: no record"
+>   where r' = qualifyWith m r
+> desugarRecordDecl _ _ decl = return [decl]
+
+> desugarRecordPattern :: ModuleIdent -> TCEnv -> Position -> [Decl]
+>		       -> [(Ident,ConstrTerm)] -> QualIdent
+>		       -> DesugarState ([Decl],ConstrTerm)
+> desugarRecordPattern m tcEnv p ds fs r =
+>   case (qualLookupTC r tcEnv) of
+>     [AliasType _ _ (TypeRecord fs' _)] ->
+>       do let ts = map (\ (l,_) 
+>		         -> fromMaybe (VariablePattern anonId)
+>		                      (lookup l fs))
+>		        fs'
+>	   desugarTerm m tcEnv p ds (ConstructorPattern r ts)
+
+> desugarRecordConstr :: ModuleIdent -> TCEnv -> Position -> QualIdent 
+>	              -> [(Ident,Expression)] -> DesugarState Expression
+> desugarRecordConstr m tcEnv p r fs =
+>   case (qualLookupTC r tcEnv) of
+>     [AliasType _ _ (TypeRecord fs' _)] ->
+>       do let cts = map (\ (l,_) -> 
+>	                  fromMaybe (internalError "desugarRecordConstr")
+>		                    (lookup l fs)) fs'
+>	   desugarExpr m tcEnv p (foldl Apply (Constructor r) cts)
+>     _ -> internalError "desugarRecordConstr: wrong type"
+
+> desugarRecordSelection :: ModuleIdent -> TCEnv -> Position -> QualIdent 
+>		         -> Ident -> Expression -> DesugarState Expression
+> desugarRecordSelection m tcEnv p r l e =
+>   desugarExpr m tcEnv p (Apply (Variable (qualRecSelectorId m r l)) e)
+
+> desugarRecordUpdate :: ModuleIdent -> TCEnv -> Position -> QualIdent
+>	              -> Expression -> [(Ident,Expression)] 
+>	              -> DesugarState Expression
+> desugarRecordUpdate m tcEnv p r rexpr fs =
+>   desugarExpr m tcEnv p (foldl (genRecordUpdate m r) rexpr fs)
+>   where
+>   genRecordUpdate m r rexpr (l,e) =
+>     Apply (Apply (Variable (qualRecUpdateId m r l)) rexpr) e
+
+> elimFunctionPattern :: ModuleIdent -> Position -> [ConstrTerm]
+>		         -> DesugarState ([ConstrTerm], [(Ident,ConstrTerm)])
+> elimFunctionPattern m p [] = return ([],[])
+> elimFunctionPattern m p (t:ts)
+>    | containsFunctionPattern t
+>      = do tyEnv <- fetchSt
+>	    ident <- freshIdent m "_#funpatt" (monoType (typeOf tyEnv t))
+>	    (ts',its') <- elimFunctionPattern m p ts
+>           return ((VariablePattern ident):ts', (ident,t):its')
+>    | otherwise
+>      = do (ts', its') <- elimFunctionPattern m p ts
+>	    return (t:ts', its')
+
+> containsFunctionPattern :: ConstrTerm -> Bool
+> containsFunctionPattern (ConstructorPattern _ ts)
+>    = any containsFunctionPattern ts
+> containsFunctionPattern (InfixPattern t1 _ t2)
+>    = any containsFunctionPattern [t1,t2]
+> containsFunctionPattern (ParenPattern t)
+>    = containsFunctionPattern t
+> containsFunctionPattern (TuplePattern _ ts)
+>    = any containsFunctionPattern ts
+> containsFunctionPattern (ListPattern _ ts)
+>    = any containsFunctionPattern ts
+> containsFunctionPattern (AsPattern _ t)
+>    = containsFunctionPattern t
+> containsFunctionPattern (LazyPattern _ t)
+>    = containsFunctionPattern t
+> containsFunctionPattern (FunctionPattern _ _) = True
+> containsFunctionPattern (InfixFuncPattern _ _ _) = True
+> containsFunctionPattern _ = False
+
+> genFunctionPatternExpr :: ModuleIdent -> Position -> [(Ident, ConstrTerm)]
+>		            -> Rhs -> DesugarState Rhs
+> genFunctionPatternExpr m _ its rhs@(SimpleRhs p expr decls)
+>    | null its = return rhs
+>    | otherwise
+>      = let ies = map (\ (i,t) -> (i, constrTerm2Expr t)) its
+>	     fpexprs = map (\ (ident, expr) 
+>		            -> Apply (Apply prelFuncPattEqu expr) 
+>		                     (Variable (qualify ident)))
+>	                   ies
+>	     fpexpr =  foldl (\e1 e2 -> Apply (Apply prelConstrConj e1) e2)
+>	                     (head fpexprs) 
+>		             (tail fpexprs)
+>	     freevars = foldl getConstrTermVars [] (map snd its)
+>            rhsexpr = Let [ExtraVariables p freevars]
+>		           (Apply (Apply prelCond fpexpr) expr)
+>        in  return (SimpleRhs p rhsexpr decls)  
+> genFunctionPatternExpr _ _ _ rhs
+>    = internalError "genFunctionPatternExpr: unexpected right-hand-side"
+
+> constrTerm2Expr :: ConstrTerm -> Expression
+> constrTerm2Expr (LiteralPattern lit)
+>    = Literal lit
+> constrTerm2Expr (VariablePattern ident)
+>    = Variable (qualify ident)
+> constrTerm2Expr (ConstructorPattern qident cts)
+>    = foldl (\e1 e2 -> Apply e1 e2) 
+>            (Constructor qident) 
+>            (map constrTerm2Expr cts)
+> constrTerm2Expr (FunctionPattern qident cts)
+>    = foldl (\e1 e2 -> Apply e1 e2) 
+>            (Variable qident) 
+>            (map constrTerm2Expr cts)
+> constrTerm2Expr _
+>    = internalError "constrTerm2Expr: unexpected constructor term"
+
+> getConstrTermVars :: [Ident] -> ConstrTerm -> [Ident]
+> getConstrTermVars ids (VariablePattern ident)
+>    | elem ident ids = ids
+>    | otherwise      = ident:ids
+> getConstrTermVars ids (ConstructorPattern _ cts)
+>    = foldl getConstrTermVars ids cts
+> getConstrTermVars ids (InfixPattern c1 qid c2)
+>    = getConstrTermVars ids (ConstructorPattern qid [c1,c2])
+> getConstrTermVars ids (ParenPattern c)
+>    = getConstrTermVars ids c
+> getConstrTermVars ids (TuplePattern _ cts)
+>    = foldl getConstrTermVars ids cts
+> getConstrTermVars ids (ListPattern _ cts)
+>    = foldl getConstrTermVars ids cts
+> getConstrTermVars ids (AsPattern _ c)
+>    = getConstrTermVars ids c
+> getConstrTermVars ids (LazyPattern _ c)
+>    = getConstrTermVars ids c
+> getConstrTermVars ids (FunctionPattern _ cts)
+>    = foldl getConstrTermVars ids cts
+> getConstrTermVars ids (InfixFuncPattern c1 qid c2)
+>    = getConstrTermVars ids (FunctionPattern qid [c1,c2])
+> getConstrTermVars ids _
+>    = ids
+
+> genRecordFuncs :: ModuleIdent -> TCEnv -> Position -> QualIdent -> Type 
+>	         -> [Ident] -> (Ident, Type) -> DesugarState [Decl]
+> genRecordFuncs m tcEnv p r rty ls (l,ty) =
+>   case (qualLookupTC r tcEnv) of
+>     [AliasType _ n (TypeRecord fs _)] ->
+>       do let (selId, selFunc) = genSelectorFunc m p r ls l
+>              (updId, updFunc) = genUpdateFunc m p r ls l
+>	       selType = polyType (TypeArrow rty ty)
+>	       updType = polyType (TypeArrow rty (TypeArrow ty rty))
+>	   updateSt_ (bindFun m selId selType . bindFun m updId updType)
+>	   return [selFunc,updFunc]
+>     _ -> internalError "genRecordFuncs: wrong type"
+
+> genSelectorFunc :: ModuleIdent -> Position -> QualIdent -> [Ident] -> Ident
+>	          -> (Ident, Decl)
+> genSelectorFunc m p r ls l =
+>   let selId = recSelectorId r l
+>       cpatt = ConstructorPattern r (map VariablePattern ls)
+>	selLhs = FunLhs selId [cpatt]
+>	selRhs = SimpleRhs p (Variable (qualify l)) []
+>   in  (selId, FunctionDecl p selId [Equation p selLhs selRhs])
+
+> genUpdateFunc :: ModuleIdent -> Position -> QualIdent -> [Ident] -> Ident
+>	        -> (Ident, Decl)
+> genUpdateFunc m p r ls l =
+>   let updId = recUpdateId r l
+>	ls' = replaceIdent l anonId ls
+>	cpatt1 = ConstructorPattern r (map VariablePattern ls')
+>       cpatt2 = VariablePattern l
+>	cexpr = foldl Apply 
+>	              (Constructor r)
+>	              (map (Variable . qualify) ls) 
+>	updLhs = FunLhs updId [cpatt1, cpatt2]
+>	updRhs = SimpleRhs p cexpr []
+>   in  (updId, FunctionDecl p updId [Equation p updLhs updRhs])
+
+> replaceIdent :: Ident -> Ident -> [Ident] -> [Ident]
+> replaceIdent _ _ [] = []
+> replaceIdent what with (id:ids)
+>   | what == id = with:ids
+>   | otherwise  = id:(replaceIdent what with ids)
+
+\end{verbatim}
+In general, a list comprehension of the form
+\texttt{[}$e$~\texttt{|}~$t$~\texttt{<-}~$l$\texttt{,}~\emph{qs}\texttt{]}
+is transformed into an expression \texttt{foldr}~$f$~\texttt{[]}~$l$ where $f$
+is a new function defined as
+\begin{quote}
+  \begin{tabbing}
+    $f$ $x$ \emph{xs} \texttt{=} \\
+    \quad \= \texttt{case} $x$ \texttt{of} \\
+          \> \quad \= $t$ \texttt{->} \texttt{[}$e$ \texttt{|} \emph{qs}\texttt{]} \texttt{++} \emph{xs} \\
+          \>       \> \texttt{\_} \texttt{->} \emph{xs}
+  \end{tabbing}
+\end{quote}
+Note that this translation evaluates the elements of $l$ rigidly,
+whereas the translation given in the Curry report is flexible.
+However, it does not seem very useful to have the comprehension
+generate instances of $t$ which do not contribute to the list.
+
+Actually, we generate slightly better code in a few special cases.
+When $t$ is a plain variable, the \texttt{case} expression degenerates
+into a let-binding and the auxiliary function thus becomes an alias
+for \texttt{(++)}. Instead of \texttt{foldr~(++)} we use the
+equivalent prelude function \texttt{concatMap}. In addition, if the
+remaining list comprehension in the body of the auxiliary function has
+no qualifiers -- i.e., if it is equivalent to \texttt{[$e$]} -- we
+avoid the construction of the singleton list by calling \texttt{(:)}
+instead of \texttt{(++)} and \texttt{map} in place of
+\texttt{concatMap}, respectively. -}
+\begin{verbatim}
+
+> desugarQual :: ModuleIdent -> TCEnv -> Position -> Statement -> Expression
+>      -> DesugarState Expression
+> desugarQual m tcEnv p (StmtExpr pos b) e = 
+>   desugarExpr m tcEnv p (IfThenElse pos b e (List [pos] []))
+> desugarQual m tcEnv p (StmtBind refBind t l) e
+>   | isVarPattern t = desugarExpr m tcEnv p (qualExpr t e l)
+>   | otherwise =
+>       do
+>         tyEnv <- fetchSt
+>         v0 <- freshIdent m "_#var" (monoType (typeOf tyEnv t))
+>         l0 <- freshIdent m "_#var" (monoType (typeOf tyEnv e))
+>         let v  = addRefId refBind v0
+>             l' = addRefId refBind l0
+>         desugarExpr m tcEnv p (apply (prelFoldr refBind) 
+>                                      [foldFunct v l' e,List [refBind] [],l])
+>   where 
+>     qualExpr v (ListCompr _ e []) l 
+>       = apply (prelMap refBind) [Lambda refBind [v] e,l]
+>     qualExpr v e l = apply (prelConcatMap refBind) [Lambda refBind [v] e,l]
+
+>     foldFunct v l e =
+>           Lambda refBind (map VariablePattern [v,l])
+>             (Case refBind (mkVar v)
+>                   [caseAlt {-refBind-} p t (append e (mkVar l)),
+>                    caseAlt {-refBind-} p (VariablePattern v) (mkVar l)])
+>
+>     append (ListCompr _ e []) l = apply (Constructor $ addRef refBind $ qConsId) [e,l]
+>     append e l = apply (prelAppend refBind) [e,l]
+>
+> desugarQual m tcEnv p (StmtDecl ds) e = desugarExpr m tcEnv p (Let ds e)
+
+\end{verbatim}
+Generation of fresh names
+\begin{verbatim}
+
+> freshIdent :: ModuleIdent -> String -> TypeScheme -> DesugarState Ident
+> freshIdent m prefix ty =
+>   do
+>     x <- liftM (mkName prefix) (liftSt (updateSt (1 +)))
+>     updateSt_ (bindFun m x ty)
+>     return x
+>   where mkName pre n = mkIdent (pre ++ show n)
+
+\end{verbatim}
+Prelude entities
+\begin{verbatim}
+
+> prelUnif = Variable $ preludeIdent "=:="
+> prelBind = prel ">>="
+> prelBind_ = prel ">>"
+> prelFlip = Variable $ preludeIdent "flip"
+> prelEnumFrom = Variable $ preludeIdent "enumFrom"
+> prelEnumFromTo = Variable $ preludeIdent "enumFromTo"
+> prelEnumFromThen = Variable $ preludeIdent "enumFromThen"
+> prelEnumFromThenTo = Variable $ preludeIdent "enumFromThenTo"
+> prelFailed = Variable $ preludeIdent "failed"
+> prelMap r = Variable $ addRef r $ preludeIdent "map"
+> prelFoldr = prel "foldr"
+> prelAppend = prel "++"
+> prelConcatMap = prel "concatMap"
+> prelNegate = Variable $ preludeIdent "negate"
+> prelNegateFloat = Variable $ preludeIdent "negateFloat"
+> prelCond = Variable $ preludeIdent "cond"
+> prelFuncPattEqu = Variable $ preludeIdent "=:<="
+> prelConstrConj = Variable $ preludeIdent "&"
+
+> prel s r = Variable (addRef r (preludeIdent s))
+
+> truePattern = ConstructorPattern qTrueId []
+> falsePattern = ConstructorPattern qFalseId []
+> successPattern = ConstructorPattern (qualify successId) []
+
+> preludeIdent :: String -> QualIdent
+> preludeIdent = qualifyWith preludeMIdent . mkIdent
+
+\end{verbatim}
+Auxiliary definitions
+\begin{verbatim}
+
+> isNewtypeConstr :: ValueEnv -> QualIdent -> Bool
+> isNewtypeConstr tyEnv c =
+>   case qualLookupValue c tyEnv of
+>     [DataConstructor _ _] -> False
+>     [NewtypeConstructor _ _] -> True
+>     _ -> internalError ("isNewtypeConstr " ++ show c) --internalError "isNewtypeConstr"
+
+> isVarPattern :: ConstrTerm -> Bool
+> isVarPattern (VariablePattern _) = True
+> isVarPattern (ParenPattern t) = isVarPattern t
+> isVarPattern (AsPattern _ t) = isVarPattern t
+> isVarPattern (LazyPattern _ _) = True
+> isVarPattern _ = False
+
+> funDecl :: Position -> Ident -> [ConstrTerm] -> Expression -> Decl
+> funDecl p f ts e =
+>   FunctionDecl p f [Equation p (FunLhs f ts) (SimpleRhs p e [])]
+
+> patDecl :: Position -> ConstrTerm -> Expression -> Decl
+> patDecl p t e = PatternDecl p t (SimpleRhs p e [])
+
+> varDecl :: Position -> Ident -> Expression -> Decl
+> varDecl p = patDecl p . VariablePattern
+
+> addDecls :: [Decl] -> Rhs -> Rhs
+> addDecls ds (SimpleRhs p e ds') = SimpleRhs p e (ds ++ ds')
+> addDecls ds (GuardedRhs es ds') = GuardedRhs es (ds ++ ds')
+
+> caseAlt :: Position -> ConstrTerm -> Expression -> Alt
+> caseAlt p t e = Alt p t (SimpleRhs p e [])
+
+> apply :: Expression -> [Expression] -> Expression
+> apply = foldl Apply
+
+> mkVar :: Ident -> Expression
+> mkVar = Variable . qualify
+
+
+\end{verbatim}
diff --git a/src/Env.lhs b/src/Env.lhs
new file mode 100644
--- /dev/null
+++ b/src/Env.lhs
@@ -0,0 +1,57 @@
+% -*- LaTeX -*-
+% $Id: Env.lhs,v 1.9 2002/12/20 15:07:56 lux Exp $
+%
+% Copyright (c) 2002, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Env.lhs}
+\section{Environments}
+The module \texttt{Env} implements environments. An environment
+$\rho = \left\{x_1\mapsto t_1,\dots,x_n\mapsto t_n\right\}$ is a
+finite mapping from (finitely many) variables $x_1,\dots,x_n$ to
+some kind of expression or term. For any environment we have the
+following definitions:
+\begin{displaymath}
+  \begin{array}{l}
+    \rho(x) = \left\{\begin{array}{ll}
+        t_i&\mbox{if $x=x_i$}\\
+        \bot&\mbox{otherwise}\end{array}\right. \\
+    \mathop{{\mathcal D}om}(\rho) = \left\{x_1,\dots,x_n\right\} \\
+    \mathop{{\mathcal C}odom}(\rho) = \left\{t_1,\dots,t_n\right\}
+  \end{array}
+\end{displaymath}
+
+Unfortunately we cannot define \texttt{Env} as a \texttt{newtype}
+because of a bug in the nhc compiler.
+\begin{verbatim}
+
+> module Env where
+> import Map
+
+> newtype Env a b = Env (FM a b) deriving Show
+
+> emptyEnv :: Ord a => Env a b
+> emptyEnv = Env zeroFM
+
+> environment :: Ord a => [(a,b)] -> Env a b
+> environment = foldr (uncurry bindEnv) emptyEnv
+
+> envToList :: Ord v => Env v e -> [(v,e)]
+> envToList (Env rho) = toListFM rho
+
+> bindEnv :: Ord v => v -> e -> Env v e -> Env v e
+> bindEnv v e (Env rho) = Env (addToFM v e rho)
+
+> unbindEnv :: Ord v => v -> Env v e -> Env v e
+> unbindEnv v (Env rho) = Env (deleteFromFM v rho)
+
+> lookupEnv :: Ord v => v -> Env v e -> Maybe e
+> lookupEnv v (Env rho) = lookupFM v rho
+
+> envSize :: Ord v => Env v e -> Int
+> envSize (Env rho) = length (toListFM rho)
+
+> instance Ord a => Functor (Env a) where
+>   fmap f (Env rho) = Env (fmap f rho)
+
+\end{verbatim}
diff --git a/src/Error.lhs b/src/Error.lhs
new file mode 100644
--- /dev/null
+++ b/src/Error.lhs
@@ -0,0 +1,42 @@
+% -*- LaTeX -*-
+% $Id: Error.lhs,v 1.1 2003/05/07 22:38:42 wlux Exp $
+%
+% Copyright (c) 2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Error.lhs}
+\section{Errors}\label{sec:error}
+The \texttt{Error} type is used for describing the result of a
+computation that can fail. In contrast to the standard \texttt{Maybe}
+type, its \texttt{Error} case provides for an error message that
+describes the failure.
+\begin{verbatim}
+
+> module Error where
+> import Control.Monad
+
+> data Error a = Ok a | Error String deriving (Eq,Ord,Show)
+
+> instance Functor Error where
+>   fmap f (Ok x) = Ok (f x)
+>   fmap f (Error e) = Error e
+
+> instance Monad Error where
+>   return x = Ok x
+>   fail s = Error s
+>   Ok x >>= f = f x
+>   Error e >>= _ = Error e
+
+> ok :: Error a -> a
+> ok (Ok x) = x
+> ok (Error e) = error e
+
+> okM :: Monad m => Error a -> m a
+> okM (Ok x) = return x
+> okM (Error e) = fail e
+
+> emap :: (String -> String) -> Error a -> Error a
+> emap _ (Ok x) = Ok x
+> emap f (Error e) = Error (f e)
+
+\end{verbatim}
diff --git a/src/Eval.lhs b/src/Eval.lhs
new file mode 100644
--- /dev/null
+++ b/src/Eval.lhs
@@ -0,0 +1,96 @@
+
+% $Id: Eval.lhs,v 1.12 2004/02/08 15:35:12 wlux Exp $
+%
+% Copyright (c) 2001-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Eval.lhs}
+\section{Collecting Evaluation Annotations}
+The module \texttt{Eval} computes the evaluation annotation
+environment. There is no need to check the annotations because this
+happens already while checking the definitions of the module.
+\begin{verbatim}
+
+> module Eval(evalEnv,evalEnvGoal) where
+> import Base
+> import Env
+
+\end{verbatim}
+The function \texttt{evalEnv} collects all evaluation annotations of
+the module by traversing the syntax tree.
+\begin{verbatim}
+
+> evalEnv :: [Decl] -> EvalEnv
+> evalEnv = foldr collectAnnotsDecl emptyEnv
+
+> evalEnvGoal :: Goal -> EvalEnv
+> evalEnvGoal (Goal _ e ds) =
+>   collectAnnotsExpr e (foldr collectAnnotsDecl emptyEnv ds)
+
+> collectAnnotsDecl :: Decl -> EvalEnv -> EvalEnv
+> collectAnnotsDecl (EvalAnnot _ fs ev) env = foldr (flip bindEval ev) env fs
+> collectAnnotsDecl (FunctionDecl _ _ eqs) env = foldr collectAnnotsEqn env eqs
+> collectAnnotsDecl (PatternDecl _ _ rhs) env = collectAnnotsRhs rhs env
+> collectAnnotsDecl _ env = env
+
+> collectAnnotsEqn :: Equation -> EvalEnv -> EvalEnv
+> collectAnnotsEqn (Equation _ _ rhs) env = collectAnnotsRhs rhs env
+
+> collectAnnotsRhs :: Rhs -> EvalEnv -> EvalEnv
+> collectAnnotsRhs (SimpleRhs _ e ds) env =
+>   collectAnnotsExpr e (foldr collectAnnotsDecl env ds)
+> collectAnnotsRhs (GuardedRhs es ds) env =
+>   foldr collectAnnotsCondExpr (foldr collectAnnotsDecl env ds) es
+
+> collectAnnotsCondExpr :: CondExpr -> EvalEnv -> EvalEnv
+> collectAnnotsCondExpr (CondExpr _ g e) env =
+>   collectAnnotsExpr g (collectAnnotsExpr e env)
+
+> collectAnnotsExpr :: Expression -> EvalEnv -> EvalEnv
+> collectAnnotsExpr (Literal _) env = env
+> collectAnnotsExpr (Variable _) env = env
+> collectAnnotsExpr (Constructor _) env = env
+> collectAnnotsExpr (Paren e) env = collectAnnotsExpr e env
+> collectAnnotsExpr (Typed e _) env = collectAnnotsExpr e env
+> collectAnnotsExpr (Tuple _ es) env = foldr collectAnnotsExpr env es
+> collectAnnotsExpr (List _ es) env = foldr collectAnnotsExpr env es
+> collectAnnotsExpr (ListCompr _ e qs) env =
+>   collectAnnotsExpr e (foldr collectAnnotsStmt env qs)
+> collectAnnotsExpr (EnumFrom e) env = collectAnnotsExpr e env
+> collectAnnotsExpr (EnumFromThen e1 e2) env =
+>   collectAnnotsExpr e1 (collectAnnotsExpr e2 env)
+> collectAnnotsExpr (EnumFromTo e1 e2) env =
+>   collectAnnotsExpr e1 (collectAnnotsExpr e2 env)
+> collectAnnotsExpr (EnumFromThenTo e1 e2 e3) env =
+>   collectAnnotsExpr e1 (collectAnnotsExpr e2 (collectAnnotsExpr e3 env))
+> collectAnnotsExpr (UnaryMinus _ e) env = collectAnnotsExpr e env
+> collectAnnotsExpr (Apply e1 e2) env =
+>   collectAnnotsExpr e1 (collectAnnotsExpr e2 env)
+> collectAnnotsExpr (InfixApply e1 _ e2) env =
+>   collectAnnotsExpr e1 (collectAnnotsExpr e2 env)
+> collectAnnotsExpr (LeftSection e _) env = collectAnnotsExpr e env
+> collectAnnotsExpr (RightSection _ e) env = collectAnnotsExpr e env
+> collectAnnotsExpr (Lambda _ _ e) env = collectAnnotsExpr e env
+> collectAnnotsExpr (Let ds e) env =
+>   foldr collectAnnotsDecl (collectAnnotsExpr e env) ds
+> collectAnnotsExpr (Do sts e) env =
+>   foldr collectAnnotsStmt (collectAnnotsExpr e env) sts
+> collectAnnotsExpr (IfThenElse _ e1 e2 e3) env =
+>   collectAnnotsExpr e1 (collectAnnotsExpr e2 (collectAnnotsExpr e3 env))
+> collectAnnotsExpr (Case _ e alts) env =
+>   collectAnnotsExpr e (foldr collectAnnotsAlt env alts)
+> collectAnnotsExpr (RecordConstr fs) env =
+>   foldr collectAnnotsExpr env (map fieldTerm fs)
+> collectAnnotsExpr (RecordSelection e _) env = collectAnnotsExpr e env
+> collectAnnotsExpr (RecordUpdate fs e) env =
+>   foldr collectAnnotsExpr (collectAnnotsExpr e env) (map fieldTerm fs)
+
+> collectAnnotsStmt :: Statement -> EvalEnv -> EvalEnv
+> collectAnnotsStmt (StmtExpr _ e) env = collectAnnotsExpr e env
+> collectAnnotsStmt (StmtDecl ds) env = foldr collectAnnotsDecl env ds
+> collectAnnotsStmt (StmtBind _ _ e) env = collectAnnotsExpr e env
+
+> collectAnnotsAlt :: Alt -> EvalEnv -> EvalEnv
+> collectAnnotsAlt (Alt _ _ rhs) env = collectAnnotsRhs rhs env
+
+\end{verbatim}
diff --git a/src/Exports.lhs b/src/Exports.lhs
new file mode 100644
--- /dev/null
+++ b/src/Exports.lhs
@@ -0,0 +1,460 @@
+
+% $Id: Exports.lhs,v 1.32 2004/02/13 19:23:57 wlux Exp $
+%
+% Copyright (c) 2000-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{Exports.lhs}
+\section{Creating Interfaces}
+This section describes how the exported interface of a compiled module
+is computed.
+\begin{verbatim}
+
+> module Exports(expandInterface,exportInterface) where
+
+> import Data.List
+> import Data.Maybe
+
+> import Base
+> import Map
+> import Set
+> import TopEnv
+
+\end{verbatim}
+The interface of a module is computed in two steps. The function
+\texttt{expandInterface} checks the export specifications of the
+module and expands them into a list containing all exported types and
+functions, combining multiple exports for the same entity. The
+expanded export specifications refer to the original names of all
+entities. The function \texttt{exportInterface} uses the expanded
+specifications and the corresponding environments in order to compute
+to the interface of the module.
+\begin{verbatim}
+
+> expandInterface :: Module -> TCEnv -> ValueEnv -> Module
+> expandInterface (Module m es ds) tcEnv tyEnv =
+>     --error (show es')
+>   case linear [unqualify tc | ExportTypeWith tc _ <- es'] of
+>     Linear ->
+>       case linear ([c | ExportTypeWith _ cs <- es', c <- cs] ++
+>                    [unqualify f | Export f <- es']) of
+>         Linear -> Module m (Just (Exporting noPos es')) ds
+>         NonLinear v -> errorAt' (ambiguousExportValue v)
+>     NonLinear tc -> errorAt' (ambiguousExportType tc) 
+>   where ms = fromListSet [fromMaybe m asM | ImportDecl _ m _ asM _ <- ds]
+>         es' = joinExports $                                              -- $
+>               maybe (expandLocalModule tcEnv tyEnv)
+>                     (expandSpecs ms m tcEnv tyEnv)
+>                     es
+
+\end{verbatim}
+While checking all export specifications, the compiler expands
+specifications of the form \verb|T(..)| into
+\texttt{T($C_1,\dots,C_n$)}, where $C_1,\dots,C_n$ are the data
+constructors or the record labels of type \texttt{T}, and replaces 
+an export specification
+\verb|module M| by specifications for all entities which are defined
+in module \texttt{M} and imported into the current module with their
+unqualified name. In order to distinguish exported type constructors
+from exported functions, the former are translated into the equivalent
+form \verb|T()|. Note that the export specification \texttt{x} may
+export a type constructor \texttt{x} \emph{and} a global function
+\texttt{x} at the same time.
+
+\em{Note:} This frontend allows redeclaration and export of imported
+identifiers.
+\begin{verbatim}
+
+> expandSpecs :: Set ModuleIdent -> ModuleIdent -> TCEnv -> ValueEnv
+>             -> ExportSpec -> [Export]
+> expandSpecs ms m tcEnv tyEnv (Exporting _ es) =
+>   concat (map (expandExport ms m tcEnv tyEnv) es)
+
+> expandExport :: Set ModuleIdent -> ModuleIdent -> TCEnv
+>              -> ValueEnv -> Export -> [Export]
+> expandExport _ m tcEnv tyEnv (Export x) = expandThing m tcEnv tyEnv x
+> expandExport _ m tcEnv _ (ExportTypeWith tc cs) =
+>   expandTypeWith m tcEnv tc cs
+> expandExport _ m tcEnv tyEnv (ExportTypeAll tc) = 
+>   expandTypeAll m tyEnv tcEnv tc
+> expandExport ms m tcEnv tyEnv (ExportModule m')
+>   | m == m' = (if m `elemSet` ms then expandModule tcEnv tyEnv m else [])
+>               ++ expandLocalModule tcEnv tyEnv
+>   | m' `elemSet` ms = expandModule tcEnv tyEnv m'
+>   | otherwise = errorAt' (moduleNotImported m')
+
+> expandThing :: ModuleIdent -> TCEnv -> ValueEnv -> QualIdent
+>                -> [Export]
+> expandThing m tcEnv tyEnv tc =
+>   case qualLookupTC tc tcEnv of
+>     [] -> expandThing' m tyEnv tc Nothing
+>     [t] -> expandThing' m tyEnv tc (Just [ExportTypeWith (origName t) []])
+>     _ -> errorAt' (ambiguousType tc)
+
+> expandThing' :: ModuleIdent -> ValueEnv -> QualIdent
+>              -> Maybe [Export] -> [Export]
+> expandThing' m tyEnv f tcExport =
+>   case (qualLookupValue f tyEnv) of
+>     [] -> fromMaybe (errorAt' (undefinedEntity f)) tcExport
+>     [Value f' _] -> Export f' : fromMaybe [] tcExport
+>     [_] -> fromMaybe (errorAt' (exportDataConstr f)) tcExport
+>     vs -> case (qualLookupValue (qualQualify m f) tyEnv) of
+>             [] -> fromMaybe (errorAt' (undefinedEntity f)) tcExport
+>             [Value f'' _] -> Export f'' : fromMaybe [] tcExport
+>             [_] -> fromMaybe (errorAt' (exportDataConstr f)) tcExport
+>             _   -> errorAt' (ambiguousName f)
+
+> expandTypeWith :: ModuleIdent -> TCEnv -> QualIdent -> [Ident] 
+>	 -> [Export]
+> expandTypeWith m tcEnv tc cs =
+>   case qualLookupTC tc tcEnv of
+>     [] -> errorAt' (undefinedType tc)
+>     [t]
+>       | isDataType t -> [ExportTypeWith (origName t)
+>                            (map (checkConstr (constrs t)) (nub cs))]
+>       | isRecordType t -> [ExportTypeWith (origName t)
+>                            (map (checkLabel (labels t)) (nub cs))]
+>       | otherwise -> errorAt' (nonDataType tc)
+>     _ -> errorAt' (ambiguousType tc)
+>   where checkConstr cs c
+>           | c `elem` cs = c
+>           | otherwise = errorAt' (undefinedDataConstr tc c)
+>         checkLabel ls l
+>	    | l' `elem` ls = l'
+>           | otherwise = errorAt' (undefinedLabel tc l)
+>	   where l' = renameLabel l
+
+> expandTypeAll :: ModuleIdent -> ValueEnv -> TCEnv -> QualIdent 
+>	-> [Export]
+> expandTypeAll m tyEnv tcEnv tc =
+>   case qualLookupTC tc tcEnv of
+>     [] -> errorAt' (undefinedType tc)
+>     [t]
+>       | isDataType t -> [exportType tyEnv t]
+>       | isRecordType t -> exportRecord m t
+>       | otherwise -> errorAt' (nonDataType tc)
+>     _ -> errorAt' (ambiguousType tc)
+
+> expandLocalModule :: TCEnv -> ValueEnv -> [Export]
+> expandLocalModule tcEnv tyEnv =
+>   [exportType tyEnv t | (_,t) <- localBindings tcEnv] ++
+>   [Export f' | (f,Value f' _) <- localBindings tyEnv, f == unRenameIdent f]
+
+> expandModule :: TCEnv -> ValueEnv -> ModuleIdent -> [Export]
+> expandModule tcEnv tyEnv m =
+>   [exportType tyEnv t | (_,t) <- moduleImports m tcEnv] ++
+>   [Export f | (_,Value f _) <- moduleImports m tyEnv]
+
+> exportType :: ValueEnv -> TypeInfo -> Export
+> exportType tyEnv t 
+>   | isRecordType t -- = ExportTypeWith (origName t) (labels t)
+>     = let ls = labels t
+>           r  = origName t
+>       in  case (lookupValue (head ls) tyEnv) of
+>             [Label _ r' _] -> if r == r' then ExportTypeWith r ls
+>		                   else ExportTypeWith r []
+>             _ -> internalError "exportType"
+>   | otherwise = ExportTypeWith (origName t) (constrs t)
+
+> exportRecord :: ModuleIdent -> TypeInfo -> [Export]
+> exportRecord m t = [ExportTypeWith (origName t) (labels t)]
+
+\end{verbatim}
+The expanded list of exported entities may contain duplicates. These
+are removed by the function \texttt{joinExports}.
+\begin{verbatim}
+
+> joinExports :: [Export] -> [Export]
+> joinExports es =
+>   [ExportTypeWith tc cs | (tc,cs) <- toListFM (foldr joinType zeroFM es)] ++
+>   [Export f | f <- toListSet (foldr joinFun zeroSet es)]
+
+> joinType :: Export -> FM QualIdent [Ident] -> FM QualIdent [Ident]
+> joinType (Export _) tcs = tcs
+> joinType (ExportTypeWith tc cs) tcs =
+>   addToFM tc (cs `union` fromMaybe [] (lookupFM tc tcs)) tcs
+
+> joinFun :: Export -> Set QualIdent -> Set QualIdent
+> joinFun (Export f) fs = f `addToSet` fs
+> joinFun (ExportTypeWith _ _) fs = fs
+
+\end{verbatim}
+After checking that the interface is not ambiguous, the compiler
+generates the interface's declarations from the list of exported
+functions and values. In order to make the interface more stable
+against private changes in the module, we remove the hidden data
+constructors of a data type in the interface when they occur
+right-most in the declaration. In addition, newtypes whose constructor
+is not exported are transformed into (abstract) data types.
+
+If a type is imported from another module, its name is qualified with
+the name of the module where it is defined. The same applies to an
+exported function.
+\begin{verbatim}
+
+> exportInterface :: Module -> PEnv -> TCEnv -> ValueEnv -> Interface
+> exportInterface (Module m (Just (Exporting _ es)) _) pEnv tcEnv tyEnv =
+>   Interface m (imports ++ precs ++ hidden ++ ds)
+>   where imports = map (IImportDecl noPos) (usedModules ds)
+>         precs = foldr (infixDecl m pEnv) [] es
+>         hidden = map (hiddenTypeDecl m tcEnv) (hiddenTypes ds)
+>         ds = foldr (typeDecl m tcEnv) (foldr (funDecl m tyEnv) [] es) es
+> exportInterface (Module _ Nothing _) _ _ _ = internalError "exportInterface"
+
+> infixDecl :: ModuleIdent -> PEnv -> Export -> [IDecl] -> [IDecl]
+> infixDecl m pEnv (Export f) ds = iInfixDecl m pEnv f ds
+> infixDecl m pEnv (ExportTypeWith tc cs) ds =
+>   foldr (iInfixDecl m pEnv . qualifyLike (fst (splitQualIdent tc))) ds cs
+>   where qualifyLike = maybe qualify qualifyWith
+
+> iInfixDecl :: ModuleIdent -> PEnv -> QualIdent -> [IDecl] -> [IDecl]
+> iInfixDecl m pEnv op ds =
+>   case qualLookupP op pEnv of
+>     [] -> ds
+>     [PrecInfo _ (OpPrec fix pr)] ->
+>       IInfixDecl noPos fix pr (qualUnqualify m op) : ds
+>     _ -> internalError "infixDecl"
+
+> typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]
+> typeDecl _ _ (Export _) ds = ds
+> typeDecl m tcEnv (ExportTypeWith tc cs) ds =
+>   case qualLookupTC tc tcEnv of
+>     [DataType tc n cs'] ->
+>       iTypeDecl IDataDecl m tc n
+>          (constrDecls m (drop n nameSupply) cs cs') : ds
+>     [RenamingType tc n (Data c n' ty)]
+>       | c `elem` cs ->
+>           iTypeDecl INewtypeDecl m tc n (NewConstrDecl noPos tvs c ty') : ds
+>       | otherwise -> iTypeDecl IDataDecl m tc n [] : ds
+>       where tvs = take n' (drop n nameSupply)
+>             ty' = fromQualType m ty
+>     [AliasType tc n ty] ->
+>       case ty of 
+>	  TypeRecord fs _ ->
+>           let ty' = TypeRecord (filter (\ (l,_) -> elem l cs) fs) Nothing
+>           in  iTypeDecl ITypeDecl m tc n (fromQualType m ty') : ds
+>         _ -> iTypeDecl ITypeDecl m tc n (fromQualType m ty) : ds
+>     _ -> internalError "typeDecl"
+
+> iTypeDecl :: (Position -> QualIdent -> [Ident] -> a -> IDecl)
+>            -> ModuleIdent -> QualIdent -> Int -> a -> IDecl
+> iTypeDecl f m tc n = f noPos (qualUnqualify m tc) (take n nameSupply)
+
+> constrDecls :: ModuleIdent -> [Ident] -> [Ident] -> [Maybe (Data [Type])]
+>             -> [Maybe ConstrDecl]
+> constrDecls m tvs cs = clean . map (>>= constrDecl m tvs)
+>   where clean = reverse . dropWhile isNothing . reverse
+>         constrDecl m tvs (Data c n tys)
+>           | c `elem` cs =
+>               Just (iConstrDecl (take n tvs) c (map (fromQualType m) tys))
+>           | otherwise = Nothing
+
+> iConstrDecl :: [Ident] -> Ident -> [TypeExpr] -> ConstrDecl
+> iConstrDecl tvs op [ty1,ty2]
+>   | isInfixOp op = ConOpDecl noPos tvs ty1 op ty2
+> iConstrDecl tvs c tys = ConstrDecl noPos tvs c tys
+
+> funDecl :: ModuleIdent -> ValueEnv -> Export -> [IDecl] -> [IDecl]
+> funDecl m tyEnv (Export f) ds =
+>   case qualLookupValue f tyEnv of
+>     [Value _ (ForAll _ ty)] ->
+>       IFunctionDecl noPos (qualUnqualify m f) (arrowArity ty) 
+>		  (fromQualType m ty) : ds
+>     _ -> internalError ("funDecl: " ++ show f)
+> funDecl _ _ (ExportTypeWith _ _) ds = ds
+
+
+\end{verbatim}
+The compiler determines the list of imported modules from the set of
+module qualifiers that are used in the interface. Careful readers
+probably will have noticed that the functions above carefully strip
+the module prefix from all entities that are defined in the current
+module. Note that the list of modules returned from
+\texttt{usedModules} is not necessarily a subset of the modules that
+were imported into the current module. This will happen when an
+imported module re-exports entities from another module. E.g., given
+the three modules
+\begin{verbatim}
+module A where { data A = A; }
+module B(A(..)) where { import A; }
+module C where { import B; x = A; }
+\end{verbatim}
+the interface for module \texttt{C} will import module \texttt{A} but
+not module \texttt{B}.
+\begin{verbatim}
+
+> usedModules :: [IDecl] -> [ModuleIdent]
+> usedModules ds = nub (catMaybes (map modul (foldr identsDecl [] ds)))
+>   where nub = toListSet . fromListSet
+>         modul = fst . splitQualIdent
+
+> identsDecl :: IDecl -> [QualIdent] -> [QualIdent]
+> identsDecl (IDataDecl _ tc _ cs) xs =
+>   tc : foldr identsConstrDecl xs (catMaybes cs)
+> identsDecl (INewtypeDecl _ tc _ nc) xs = tc : identsNewConstrDecl nc xs
+> identsDecl (ITypeDecl _ tc _ ty) xs = tc : identsType ty xs
+> identsDecl (IFunctionDecl _ f _ ty) xs = f : identsType ty xs
+
+> identsConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
+> identsConstrDecl (ConstrDecl _ _ _ tys) xs = foldr identsType xs tys
+> identsConstrDecl (ConOpDecl _ _ ty1 _ ty2) xs =
+>   identsType ty1 (identsType ty2 xs)
+
+> identsNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
+> identsNewConstrDecl (NewConstrDecl _ _ _ ty) xs = identsType ty xs
+
+> identsType :: TypeExpr -> [QualIdent] -> [QualIdent]
+> identsType (ConstructorType tc tys) xs = tc : foldr identsType xs tys
+> identsType (VariableType _) xs = xs
+> identsType (TupleType tys) xs = foldr identsType xs tys
+> identsType (ListType ty) xs = identsType ty xs
+> identsType (ArrowType ty1 ty2) xs = identsType ty1 (identsType ty2 xs)
+> identsType (RecordType fs rty) xs =
+>   foldr identsType (maybe xs (\ty -> identsType ty xs) rty) (map snd fs)
+
+\end{verbatim}
+After the interface declarations have been computed, the compiler
+eventually must add hidden (data) type declarations to the interface
+for all those types which were used in the interface but not exported
+from the current module, so that these type constructors can always be
+distinguished from type variables.
+\begin{verbatim}
+
+> hiddenTypeDecl :: ModuleIdent -> TCEnv -> QualIdent -> IDecl
+> hiddenTypeDecl m tcEnv tc =
+>   case qualLookupTC (qualQualify m tc) tcEnv of
+>     [DataType _ n _] -> hidingDataDecl tc n
+>     [RenamingType _ n _] -> hidingDataDecl tc n
+>     _ ->  internalError "hiddenTypeDecl"
+>   where hidingDataDecl tc n =
+>           HidingDataDecl noPos (unqualify tc) (take n nameSupply)
+
+> hiddenTypes :: [IDecl] -> [QualIdent]
+> hiddenTypes ds = [tc | tc <- toListSet tcs, not (isQualified tc)]
+>   where tcs = foldr deleteFromSet (fromListSet (usedTypes ds))
+>                     (definedTypes ds)
+
+> usedTypes :: [IDecl] -> [QualIdent]
+> usedTypes ds = foldr usedTypesDecl [] ds
+
+> usedTypesDecl :: IDecl -> [QualIdent] -> [QualIdent]
+> usedTypesDecl (IDataDecl _ _ _ cs) tcs =
+>   foldr usedTypesConstrDecl tcs (catMaybes cs)
+> usedTypesDecl (INewtypeDecl _ _ _ nc) tcs = usedTypesNewConstrDecl nc tcs
+> usedTypesDecl (ITypeDecl _ _ _ ty) tcs = usedTypesType ty tcs
+> usedTypesDecl (IFunctionDecl _ _ _ ty) tcs = usedTypesType ty tcs
+
+> usedTypesConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
+> usedTypesConstrDecl (ConstrDecl _ _ _ tys) tcs = foldr usedTypesType tcs tys
+> usedTypesConstrDecl (ConOpDecl _ _ ty1 _ ty2) tcs =
+>   usedTypesType ty1 (usedTypesType ty2 tcs)
+
+> usedTypesNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
+> usedTypesNewConstrDecl (NewConstrDecl _ _ _ ty) tcs = usedTypesType ty tcs
+
+> usedTypesType :: TypeExpr -> [QualIdent] -> [QualIdent]
+> usedTypesType (ConstructorType tc tys) tcs = tc : foldr usedTypesType tcs tys
+> usedTypesType (VariableType _) tcs = tcs
+> usedTypesType (TupleType tys) tcs = foldr usedTypesType tcs tys
+> usedTypesType (ListType ty) tcs = usedTypesType ty tcs
+> usedTypesType (ArrowType ty1 ty2) tcs =
+>   usedTypesType ty1 (usedTypesType ty2 tcs)
+> usedTypesType (RecordType fs rty) tcs =
+>   foldr usedTypesType 
+>         (maybe tcs (\ty -> usedTypesType ty tcs) rty) 
+>         (map snd fs)
+
+> definedTypes :: [IDecl] -> [QualIdent]
+> definedTypes ds = foldr definedType [] ds
+
+> definedType :: IDecl -> [QualIdent] -> [QualIdent]
+> definedType (IDataDecl _ tc _ _) tcs = tc : tcs
+> definedType (INewtypeDecl _ tc _ _) tcs = tc : tcs
+> definedType (ITypeDecl _ tc _ _) tcs = tc : tcs
+> definedType (IFunctionDecl _ _ _ _)  tcs = tcs
+
+\end{verbatim}
+Auxiliary definitions
+\begin{verbatim}
+
+
+> isDataType :: TypeInfo -> Bool
+> isDataType (DataType _ _ _) = True
+> isDataType (RenamingType _ _ _) = True
+> isDataType (AliasType _ _ _) = False
+
+> isRecordType :: TypeInfo -> Bool
+> isRecordType (AliasType _ _ (TypeRecord _ _)) = True
+> isRecordType _ = False
+
+> constrs :: TypeInfo -> [Ident]
+> constrs (DataType _ _ cs) = [c | Just (Data c _ _) <- cs]
+> constrs (RenamingType _ _ (Data c _ _)) = [c]
+> constrs (AliasType _ _ _) = []
+
+> labels :: TypeInfo -> [Ident]
+> labels (AliasType _ _ (TypeRecord fs _)) = map fst fs
+> labels _ = []
+
+\end{verbatim}
+Error messages
+\begin{verbatim}
+
+> undefinedEntity :: QualIdent -> (Position,String)
+> undefinedEntity x =
+>   (positionOfQualIdent x,
+>    "Entity " ++ qualName x ++ " in export list is not defined")
+
+> undefinedType :: QualIdent -> (Position,String)
+> undefinedType tc = 
+>   (positionOfQualIdent tc,
+>    "Type " ++ qualName tc ++ " in export list is not defined")
+
+> moduleNotImported :: ModuleIdent -> (Position,String)
+> moduleNotImported m = 
+>   (positionOfModuleIdent m,
+>    "Module " ++ moduleName m ++ " not imported")
+
+> ambiguousExportType :: Ident -> (Position,String)
+> ambiguousExportType x = 
+>   (positionOfIdent x,
+>    "Ambiguous export of type " ++ name x)
+
+> ambiguousExportValue :: Ident -> (Position,String)
+> ambiguousExportValue x = 
+>   (positionOfIdent x,
+>    "Ambiguous export of " ++ name x)
+
+> ambiguousType :: QualIdent -> (Position,String)
+> ambiguousType tc = 
+>   (positionOfQualIdent tc,
+>    "Ambiguous type " ++ qualName tc)
+
+> ambiguousName :: QualIdent -> (Position,String)
+> ambiguousName x = 
+>   (positionOfQualIdent x,
+>    "Ambiguous name " ++ qualName x)
+
+> exportDataConstr :: QualIdent -> (Position,String)
+> exportDataConstr c = 
+>   (positionOfQualIdent c,
+>    "Data constructor " ++ qualName c ++ " in export list")
+
+> nonDataType :: QualIdent -> (Position,String)
+> nonDataType tc = 
+>   (positionOfQualIdent tc,
+>    qualName tc ++ " is not a data type")
+
+> undefinedDataConstr :: QualIdent -> Ident -> (Position,String)
+> undefinedDataConstr tc c =
+>   (positionOfIdent c,    
+>    name c ++ " is not a data constructor of type " ++ qualName tc)
+
+> undefinedLabel :: QualIdent -> Ident -> (Position,String)
+> undefinedLabel r l =
+>   (positionOfIdent l,    
+>    name l ++ " is not a label of the record " ++ qualName r)
+
+\end{verbatim}
diff --git a/src/ExtendedFlat.hs b/src/ExtendedFlat.hs
new file mode 100644
--- /dev/null
+++ b/src/ExtendedFlat.hs
@@ -0,0 +1,513 @@
+------------------------------------------------------------------------------
+--- Library to support meta-programming in Curry.
+---
+--- This library contains a definition for representing FlatCurry programs
+--- in Haskell (type "Prog").
+---
+--- @author Michael Hanus
+--- @version September 2003
+---
+--- Version for Haskell (slightly modified):
+---  December 2004, Martin Engelke (men@informatik.uni-kiel.de)
+---
+--- Added part calls for constructors, Bernd Brassel, August 2005
+--- Added source references, Bernd Brassel, May 2009
+------------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}
+
+module ExtendedFlat (SrcRef,Prog(..), QName(..), Visibility(..),
+                  TVarIndex, TypeDecl(..), ConsDecl(..), TypeExpr(..),
+                  OpDecl(..), Fixity(..),
+                  VarIndex(..), 
+                  FuncDecl(..), Rule(..), 
+                  CaseType(..), CombType(..), Expr(..), BranchExpr(..),
+                  Pattern(..), Literal(..), 
+		  readFlatCurry, readFlatInterface, readFlat, 
+		  writeFlatCurry,gshowsPrec,
+                  qnOf,mkQName,
+                  mkIdx,idxOf) where
+
+import PathUtils (writeModule,maybeReadModule)
+import Data.List(intersperse)
+import Control.Monad (liftM)
+import Data.Generics hiding (Fixity)
+import Position (SrcRef)
+
+
+------------------------------------------------------------------------------
+-- Definition of data types for representing FlatCurry programs:
+-- =============================================================
+
+--- Data type for representing a Curry module in the intermediate form.
+--- A value of this data type has the form
+--- <CODE>
+---  (Prog modname imports typedecls functions opdecls translation_table)
+--- </CODE>
+--- where modname: name of this module,
+---       imports: list of modules names that are imported,
+---       typedecls, opdecls, functions, translation of type names
+---       and constructor/function names: see below
+
+data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl] 
+	    deriving (Read, Show, Eq,Data,Typeable)
+
+
+-------------------------------------------------------------------------
+--- The data type for representing qualified names.
+--- In FlatCurry all names are qualified to avoid name clashes.
+--- The first component is the module name and the second component the
+--- unqualified name as it occurs in the source program.
+--- The additional information about source references and types should
+--- be invisible for the normal usage of QName.
+-------------------------------------------------------------------------
+
+data QName = QName {srcRef      :: Maybe SrcRef,
+                    typeofQName :: Maybe TypeExpr,
+                    modName     :: String,
+                    localName   :: String} deriving (Data,Typeable)
+
+
+app_prec = 10
+hi_prec  = app_prec+1
+
+instance Read QName where
+  readsPrec d r = 
+       [ (mkQName nm,s) | (nm,s) <- readsPrec d r ]
+    ++ readParen (d > app_prec) 
+                 (\r' -> [ (QName ref typ n m,res) 
+                               | ("QName",s0) <- lex r',
+                                 (ref,s1) <- readsPrec hi_prec s0,
+                                 (typ,s2) <- readsPrec hi_prec s1,
+                                 (n,s3)   <- readsPrec hi_prec s2,
+                                 (m,res)  <- readsPrec hi_prec s3 ]) r
+    
+
+instance Show QName where
+  showsPrec d (QName r t m n)= 
+    showParen (d > app_prec) $ showString "QName " .
+                     showsPrec hi_prec r . showChar ' ' .
+                     showsPrec hi_prec t . showChar ' ' .
+                     showsPrec hi_prec m . showChar ' ' .
+                     showsPrec hi_prec n
+
+instance Eq QName where (==) = onName (==)
+instance Ord QName where compare = onName compare
+
+mkQName :: (String,String) -> QName
+mkQName = uncurry (QName Nothing Nothing)
+
+qnOf :: QName -> (String,String) 
+qnOf QName{modName=m,localName=n} = (m,n)
+
+onName :: ((String,String) -> (String,String) -> a) -> QName -> QName -> a
+onName f QName{modName=m,localName=l} QName{modName=m',localName=l'} =
+  f (m,l) (m',l')
+
+
+-------------------------------------------------------------------------
+--- The data type for representing variable names.
+--- The additional information should
+--- be invisible for the normal usage of VarIndex.
+-------------------------------------------------------------------------
+
+data VarIndex = VarIndex {
+                    typeofVar :: Maybe TypeExpr,
+                    index     :: Int
+                } deriving (Data,Typeable)
+
+onIndex :: (Int -> a) -> VarIndex -> a
+onIndex f VarIndex{index=i} = f i
+
+(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
+f .: g = \x -> f . g x
+
+onIndexes :: (Int -> Int -> a) -> VarIndex -> VarIndex -> a
+onIndexes = onIndex .: onIndex
+
+mkIdx :: Int -> VarIndex
+mkIdx = VarIndex Nothing
+
+idxOf :: VarIndex -> Int
+idxOf VarIndex{index=i}= i
+
+instance Read VarIndex where
+  readsPrec d r = 
+       [ (mkIdx i,s) | (i,s) <- readsPrec d r ]
+    ++ readParen (d > app_prec) 
+                 (\r' -> [ (VarIndex typ i,res) 
+                         | ("VarIndex",s0) <- lex r',
+                           (typ,s1) <- readsPrec hi_prec s0,
+                           (i,res)  <- readsPrec hi_prec s1]) r
+    
+
+instance Show VarIndex where
+  showsPrec d (VarIndex t i)= 
+    showParen (d > app_prec) $ showString "VarIndex " .
+                     showsPrec hi_prec t . showChar ' ' .
+                     showsPrec hi_prec i
+
+
+instance Eq VarIndex where (==) = onIndexes (==)
+instance Ord VarIndex where compare = onIndexes compare
+
+instance Num VarIndex where
+  (+) = mkIdx .: onIndexes (+)
+  (*) = mkIdx .: onIndexes (*)
+  (-) = mkIdx .: onIndexes (-)
+  abs = mkIdx .  onIndex abs
+  signum = mkIdx .  onIndex signum
+  fromInteger = mkIdx . fromInteger
+
+------------------------------------------------------------
+--- Data type to specify the visibility of various entities.
+------------------------------------------------------------
+
+data Visibility = Public    -- public (exported) entity
+                | Private   -- private entity
+		deriving (Read, Show, Eq,Data,Typeable)
+
+--- The data type for representing type variables.
+--- They are represented by (TVar i) where i is a type variable index.
+
+type TVarIndex = Int
+
+--- Data type for representing definitions of algebraic data types.
+--- <PRE>
+--- A data type definition of the form
+---
+--- data t x1...xn = ...| c t1....tkc |...
+---
+--- is represented by the FlatCurry term
+---
+--- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])
+---
+--- where each ij is the index of the type variable xj
+---
+--- Note: the type variable indices are unique inside each type declaration
+---       and are usually numbered from 0
+---
+--- Thus, a data type declaration consists of the name of the data type,
+--- a list of type parameters and a list of constructor declarations.
+--- </PRE>
+
+data TypeDecl = Type    QName Visibility [TVarIndex] [ConsDecl]
+              | TypeSyn QName Visibility [TVarIndex] TypeExpr
+	      deriving (Read, Show, Eq,Data,Typeable)
+
+--- A constructor declaration consists of the name and arity of the
+--- constructor and a list of the argument types of the constructor.
+
+data ConsDecl = Cons QName Int Visibility [TypeExpr]
+	      deriving (Read, Show, Eq,Data,Typeable)
+
+
+--- Data type for type expressions.
+--- A type expression is either a type variable, a function type,
+--- or a type constructor application.
+---
+--- Note: the names of the predefined type constructors are
+---       "Int", "Float", "Bool", "Char", "IO", "Success",
+---       "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
+
+data TypeExpr =
+     TVar TVarIndex                 -- type variable
+   | FuncType TypeExpr TypeExpr     -- function type t1->t2
+   | TCons QName [TypeExpr]         -- type constructor application
+   deriving (Read, Show, Eq,Data,Typeable)            --    TCons module name typeargs
+
+
+--- Data type for operator declarations.
+--- An operator declaration "fix p n" in Curry corresponds to the
+--- FlatCurry term (Op n fix p).
+--- Note: the constructor definition of 'Op' differs from the original
+--- PAKCS definition using Haskell type 'Integer' instead of 'Int'
+--- for representing the precedence. 
+
+data OpDecl = Op QName Fixity Integer deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data types for the different choices for the fixity of an operator.
+
+data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Read, Show, Eq,Data,Typeable)
+
+
+--- Data type for representing object variables.
+--- Object variables occurring in expressions are represented by (Var i)
+--- where i is a variable index.
+
+--- Data type for representing function declarations.
+--- <PRE>
+--- A function declaration in FlatCurry is a term of the form
+---
+---  (Func name arity type (Rule [i_1,...,i_arity] e))
+---
+--- and represents the function "name" with definition
+---
+---   name :: type
+---   name x_1...x_arity = e
+---
+--- where each i_j is the index of the variable x_j
+---
+--- Note: the variable indices are unique inside each function declaration
+---       and are usually numbered from 0
+---
+--- External functions are represented as (Func name arity type (External s))
+--- where s is the external name associated to this function.
+---
+--- Thus, a function declaration consists of the name, arity, type, and rule.
+--- </PRE>
+
+data FuncDecl = Func QName Int Visibility TypeExpr Rule
+	      deriving (Read, Show, Eq,Data,Typeable)
+
+
+--- A rule is either a list of formal parameters together with an expression
+--- or an "External" tag.
+
+data Rule = Rule [VarIndex] Expr
+          | External String
+	  deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data type for classifying case expressions.
+--- Case expressions can be either flexible or rigid in Curry.
+
+data CaseType = Rigid | Flex deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data type for classifying combinations
+--- (i.e., a function/constructor applied to some arguments).
+--- @cons FuncCall     - a call to a function all arguments are provided
+--- @cons ConsCall     - a call with a constructor at the top,
+---                      all arguments are provided
+--- @cons FuncPartCall - a partial call to a function
+---                      (i.e., not all arguments are provided) 
+---                      where the parameter is the number of
+---                      missing arguments
+--- @cons ConsPartCall - a partial call to a constructor along with 
+---                      number of missing arguments
+
+data CombType = FuncCall 
+              | ConsCall 
+              | FuncPartCall Int 
+              | ConsPartCall Int deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data type for representing expressions.
+---
+--- Remarks:
+--- <PRE>
+--- 1. if-then-else expressions are represented as function calls:
+---      (if e1 then e2 else e3)
+---    is represented as
+---      (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])
+--- 
+--- 2. Higher order applications are represented as calls to the (external)
+---    function "apply". For instance, the rule
+---      app f x = f x
+---    is represented as
+---      (Rule  [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))
+--- 
+--- 3. A conditional rule is represented as a call to an external function
+---    "cond" where the first argument is the condition (a constraint).
+---    For instance, the rule
+---      equal2 x | x=:=2 = success
+---    is represented as
+---      (Rule [0]
+---            (Comb FuncCall ("Prelude","cond")
+---                  [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],
+---                   Comb FuncCall ("Prelude","success") []]))
+--- 
+--- 4. Functions with evaluation annotation "choice" are represented
+---    by a rule whose right-hand side is enclosed in a call to the
+---    external function "Prelude.commit".
+---    Furthermore, all rules of the original definition must be
+---    represented by conditional expressions (i.e., (cond [c,e]))
+---    after pattern matching.
+---    Example:
+--- 
+---       m eval choice
+---       m [] y = y
+---       m x [] = x
+--- 
+---    is translated into (note that the conditional branches can be also
+---    wrapped with Free declarations in general):
+--- 
+---       Rule [0,1]
+---            (Comb FuncCall ("Prelude","commit")
+---              [Or (Case Rigid (Var 0)
+---                     [(Pattern ("Prelude","[]") []
+---                         (Comb FuncCall ("Prelude","cond")
+---                               [Comb FuncCall ("Prelude","success") [],
+---                                Var 1]))] )
+---                  (Case Rigid (Var 1)
+---                     [(Pattern ("Prelude","[]") []
+---                         (Comb FuncCall ("Prelude","cond")
+---                               [Comb FuncCall ("Prelude","success") [],
+---                                Var 0]))] )])
+--- 
+---    Operational meaning of (Prelude.commit e):
+---    evaluate e with local search spaces and commit to the first
+---    (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c
+---    is satisfied
+--- </PRE>
+--- @cons Var - variable (represented by unique index)
+--- @cons Lit - literal (Integer/Float/Char constant)
+--- @cons Comb - application (f e1 ... en) of function/constructor f
+---              with n<=arity(f)
+--- @cons Free - introduction of free local variables
+--- @cons Or - disjunction of two expressions (used to translate rules
+---            with overlapping left-hand sides)
+--- @cons Case - case distinction (rigid or flex)
+
+data Expr = Var VarIndex 
+          | Lit Literal
+          | Comb CombType QName [Expr]
+          | Free [VarIndex] Expr
+          | Let [(VarIndex,Expr)] Expr
+          | Or Expr Expr
+          | Case SrcRef CaseType Expr [BranchExpr]
+	  deriving (Read, Show, Eq,Data,Typeable)
+
+
+--- Data type for representing branches in a case expression.
+--- <PRE>
+--- Branches "(m.c x1...xn) -> e" in case expressions are represented as
+---
+---   (Branch (Pattern (m,c) [i1,...,in]) e)
+---
+--- where each ij is the index of the pattern variable xj, or as
+---
+---   (Branch (LPattern (Intc i)) e)
+---
+--- for integers as branch patterns (similarly for other literals
+--- like float or character constants).
+--- </PRE>
+
+data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data type for representing patterns in case expressions.
+
+data Pattern = Pattern QName [VarIndex]
+             | LPattern Literal
+	     deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data type for representing literals occurring in an expression
+--- or case branch. It is either an integer, a float, or a character constant.
+--- Note: the constructor definition of 'Intc' differs from the original
+--- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'
+--- to provide an unlimited range of integer numbers. Furthermore
+--- float values are represented with Haskell type 'Double' instead of
+--- 'Float'.
+
+data Literal = Intc   SrcRef Integer
+             | Floatc SrcRef Double
+             | Charc  SrcRef Char
+	     deriving (Read, Show, Eq,Data,Typeable)
+
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+-- Reads a FlatCurry file (extension ".fcy") and returns the corresponding
+-- FlatCurry program term (type 'Prog') as a value of type 'Maybe'.
+readFlatCurry :: FilePath -> IO (Maybe Prog)
+readFlatCurry fn 
+   = do let filename = genFlatFilename ".fcy" fn
+        readFlat filename
+
+-- Reads a FlatInterface file (extension ".fint") and returns the
+-- corresponding term (type 'Prog') as a value of type 'Maybe'.
+readFlatInterface :: String -> IO (Maybe Prog)
+readFlatInterface fn
+   = do let filename = genFlatFilename ".fint" fn
+        readFlat filename
+
+-- Reads a Flat file and returns the corresponding term (type 'Prog') as
+-- a value of type 'Maybe'.
+readFlat :: FilePath -> IO (Maybe Prog)
+readFlat = liftM (fmap read) . maybeReadModule
+  
+-- Writes a FlatCurry program term into a file.
+writeFlatCurry :: String -> Prog -> IO ()
+writeFlatCurry filename prog
+   = writeModule filename (showFlatCurry' prog)
+
+-- Writes a FlatCurry program term with source references into a file.
+writeFlatWithSrcRefs :: String -> Prog -> IO ()
+writeFlatWithSrcRefs filename prog
+   = writeModule filename (showFlatCurry prog)
+
+-- Shows FlatCurry program in a more nicely way.
+showFlatCurry :: Prog -> String
+showFlatCurry (Prog mname imps types funcs ops) =
+  "Prog "++show mname++"\n "++
+  show imps ++"\n ["++
+  concat (intersperse ",\n  " (map (\t->show t) types)) ++"]\n ["++
+  concat (intersperse ",\n  " (map (\f->show f) funcs)) ++"]\n "++
+  show ops ++"\n"
+  
+
+-- Add the extension 'ext' to the filename 'fn' if it doesn't
+-- already exist.
+genFlatFilename :: String -> FilePath -> FilePath
+genFlatFilename ext fn
+   | drop (length fn - length ext) fn == ext
+     = fn
+   | otherwise
+     = fn ++ ext
+
+showFlatCurry' :: Prog -> String
+showFlatCurry' x = gshowsPrec False x ""
+
+
+gshowsPrec :: Data a => Bool -> a -> ShowS
+gshowsPrec d = 
+  genericShowsPrec d `ext1Q` showsList
+                     `ext2Q` showsTuple
+                     `extQ`  (const id :: SrcRef -> ShowS)
+                     `extQ`  (const id :: [SrcRef] -> ShowS)
+                     `extQ`  (shows :: String -> ShowS)
+                     `extQ`  (shows :: Char -> ShowS)
+                     `extQ`  showsQName
+                     `extQ`  showsVarIndex
+                                      
+      where
+        showsQName :: QName -> ShowS
+        showsQName QName{modName=m,localName=n} = shows (m,n)
+
+        showsVarIndex :: VarIndex -> ShowS
+        showsVarIndex VarIndex{index=i} = shows i
+
+        genericShowsPrec :: Data a => Bool -> a -> ShowS
+        genericShowsPrec d t = let args = intersperse (showChar ' ') $
+                                          gmapQ (gshowsPrec True) t in
+                               showParen (d && not (null args)) $
+                               showString (showConstr (toConstr t)) .
+                               (if null args then id else showChar ' ') .
+                               foldr (.) id args
+
+        showsList :: Data a => [a] -> ShowS
+        showsList xs = showChar '[' . 
+                       foldr (.) (showChar ']') 
+                             (intersperse (showChar ',') $ 
+                              map (gshowsPrec False) xs)
+                       
+
+        showsTuple :: (Data a,Data b) => (a,b) -> ShowS
+        showsTuple (x,y) = showChar '(' . 
+                           gshowsPrec False x . 
+                           showChar ',' .
+                           gshowsPrec False y .
+                           showChar ')' 
+
+
+newtype Q r a = Q (a -> r)
+ 
+ext2Q :: (Data d, Typeable2 t) => (d -> q) -> 
+   (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
+ext2Q def ext arg =
+   case dataCast2 (Q ext) of
+     Just (Q ext') -> ext' arg
+     Nothing       -> def arg
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
diff --git a/src/Frontend.hs b/src/Frontend.hs
new file mode 100644
--- /dev/null
+++ b/src/Frontend.hs
@@ -0,0 +1,262 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- Frontend - Provides an API for dealing with several kinds of Curry
+--            program representations
+--
+-- December 2005,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+module Frontend (lex, parse, fullParse, typingParse, abstractIO, flatIO,
+		 Result(..), Message(..)
+		)where
+
+import Data.List
+import Data.Maybe
+import Control.Monad
+import Prelude hiding (lex)
+
+import Modules
+import CurryBuilder
+import CurryCompilerOpts
+import CurryParser
+import CurryLexer
+import GenAbstractCurry
+import GenFlatCurry
+import CaseCompletion
+import CurryDeps hiding (unlitLiterate)
+import qualified CurrySyntax as CS
+import qualified AbstractCurry as ACY
+import qualified ExtendedFlat as FCY
+import qualified Error as Err
+import CompilerResults
+import Message
+import CurryEnv
+import Unlit
+import Ident
+import Position
+import PathUtils
+import Env
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+-- Returns the result of a lexical analysis of the source program 'src'.
+-- The result is a list of tuples consisting of a position and a token
+-- (see Modules "Position" and "CurryLexer")
+lex :: FilePath -> String -> Result [(Position,Token)]
+lex fn src = genToks (lexFile (first fn) src False [])
+
+
+-- Returns the result of a syntactical analysis of the source program 'src'.
+-- The result is the syntax tree of the program (type 'Module'; see Module
+-- "CurrySyntax").
+parse :: FilePath -> String -> Result CS.Module
+parse fn src = let (err, src') = unlitLiterate fn src
+	       in  if null err
+		   then genCurrySyntax fn (parseSource True fn src')
+		   else Failure [message_ Error err]
+
+
+-- Returns the syntax tree of the source program 'src' (type 'Module'; see
+-- Module "CurrySyntax") after resolving the category (i.e. function,
+-- constructor or variable) of an identifier. 'fullParse' always
+-- searches for standard Curry libraries in the path defined in the
+-- environment variable "PAKCSLIBPATH". Additional search paths can
+-- be defined using the argument 'paths'.
+fullParse :: [FilePath] -> FilePath -> String -> IO (Result CS.Module)
+fullParse paths fn src =
+  genFullCurrySyntax simpleCheckModule paths	fn (parse fn src)
+
+-- Behaves like 'fullParse', but Returns the syntax tree of the source 
+-- program 'src' (type 'Module'; see Module "CurrySyntax") after inferring 
+-- the types of identifiers.
+typingParse :: [FilePath] -> FilePath -> String -> IO (Result CS.Module)
+typingParse paths fn src = 
+  genFullCurrySyntax checkModule paths fn (parse fn src)
+
+-- Compiles the source programm 'src' to an AbstractCurry program.
+-- 'fullParse' always searches for standard Curry libraries in the path 
+-- defined in the environment variable "PAKCSLIBPATH". Additional search 
+-- paths can be defined using the argument 'paths'.
+-- Notes: Due to the lack of error handling in the current version of the
+-- front end, this function may fail when an error occurs
+abstractIO :: [FilePath] -> FilePath -> String -> IO (Result ACY.CurryProg)
+abstractIO paths fn src = 
+  genAbstractIO paths fn (parse fn src)
+
+-- Compiles the source program 'src' to a FlatCurry program.
+-- 'fullParse' always searches for standard Curry libraries in the path 
+-- defined in the environment variable "PAKCSLIBPATH". Additional search 
+-- paths can be defined using the argument 'paths'.
+-- Note: Due to the lack of error handling in the current version of the
+-- front end, this function may fail when an error occurs
+flatIO :: [FilePath] -> FilePath -> String -> IO (Result FCY.Prog)
+flatIO paths fn src = 
+  genFlatIO paths fn (parse fn src)
+
+
+-------------------------------------------------------------------------------
+-- Result handling
+
+data Result a = Result [Message] a | Failure [Message] deriving Show
+
+-- See module "Message":
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+-- Privates...
+
+
+opts paths = defaultOpts{ 
+                     importPaths = paths,
+		     noVerb      = True,
+		     noWarn      = True,
+		     abstract    = True
+		   }
+
+
+--
+genToks :: Err.Error [(Position,Token)] -> Result [(Position,Token)]
+genToks (Err.Ok toks)   = Result [] toks
+genToks (Err.Error err) = Failure [message_ Error err]
+
+
+--
+genCurrySyntax :: FilePath -> Err.Error CS.Module -> Result (CS.Module)
+genCurrySyntax fn (Err.Ok mod)
+   = let mod'@(CS.Module mid _ _) = patchModuleId fn (importPrelude fn mod)
+     in  if isValidModuleId fn mid
+	 then Result [] mod'
+	 else Failure [message_ Error (err_invalidModuleName mid)]
+genCurrySyntax _ (Err.Error err)
+   = Failure [message_ Error err]
+
+
+--
+genFullCurrySyntax check paths fn (Result msgs mod)
+   = do errs <- makeInterfaces paths mod
+	if null errs
+	   then do mEnv <- loadInterfaces paths mod
+		   (_, _, _, mod', _, msgs') <- check (opts paths) mEnv mod
+		   return (Result (msgs ++ msgs') mod')
+	   else return (Failure (msgs ++ map (message_ Error) errs))
+genFullCurrySyntax _ _ _ (Failure msgs) = return (Failure msgs)
+
+
+--
+genAbstractIO :: [FilePath] -> FilePath -> Result CS.Module
+	      -> IO (Result ACY.CurryProg)
+genAbstractIO paths fn (Result msgs mod)
+   = do errs <- makeInterfaces paths mod
+	if null errs
+	   then do mEnv <- loadInterfaces paths mod
+		   (tyEnv, tcEnv, _, mod', _, msgs')
+		       <- simpleCheckModule (opts paths) mEnv mod
+		   return (Result (msgs ++ msgs') 
+			          (genTypedAbstract tyEnv tcEnv mod'))
+	   else return (Failure (msgs ++ map (message_ Error) errs))
+genAbstractIO _ _ (Failure msgs) = return (Failure msgs)
+
+
+--
+genFlatIO :: [FilePath] -> FilePath -> Result CS.Module -> IO (Result FCY.Prog)
+genFlatIO paths fn (Result msgs mod)
+   = do errs <- makeInterfaces paths mod
+	if null errs then
+	   (do mEnv <- loadInterfaces paths mod
+	       (tyEnv, tcEnv, aEnv, mod', intf, msgs') <- 
+	           checkModule (opts paths) mEnv mod
+	       let (il, aEnv', _) 
+	              = transModule True True False mEnv tyEnv tcEnv aEnv mod'
+	           il' = completeCase mEnv il
+	           cEnv = curryEnv mEnv tcEnv intf mod'
+	           (prog,msgs'') = genFlatCurry (opts paths) cEnv mEnv 
+	                                        tyEnv tcEnv aEnv' il'
+               return (Result (msgs'' ++ msgs ++ msgs') prog)
+	   )
+	   else return (Failure (msgs ++ map (message_ Error) errs))
+genFlatIO _ _ (Failure msgs) = return (Failure msgs)
+
+
+-------------------------------------------------------------------------------
+
+-- Generates interface files for importes modules, if they don't exist or
+-- if they are not up-to-date.
+makeInterfaces ::  [FilePath] -> CS.Module -> IO [String]
+makeInterfaces paths (CS.Module mid _ decls)
+  = do let imports = [preludeMIdent | mid /= preludeMIdent] 
+		      ++ [imp | CS.ImportDecl _ imp _ _ _ <- decls]
+       (deps, errs) <- fmap (flattenDeps . sortDeps)
+		            (foldM (moduleDeps paths []) emptyEnv imports)
+       when (null errs) (mapM_ (compile deps . snd) deps)
+       return errs
+ where
+ compile deps (Source file' mods)
+    = do smake [flatName file', flatIntName file']
+	       (file':catMaybes (map (flatInterface deps) mods))
+	       (compileCurry (opts paths) file')
+	       (return defaultResults)
+	 return ()
+ compile _ _ = return ()
+
+ flatInterface deps mod 
+    = case (lookup mod deps) of
+        Just (Source file _)  -> Just (flatIntName (rootname file))
+	Just (Interface file) -> Just (flatIntName (rootname file))
+	_                     -> Nothing
+
+-- Declares the filename as module name, if the module name is not
+-- explicitly declared in the module.
+patchModuleId :: FilePath -> CS.Module -> CS.Module
+patchModuleId fn (CS.Module mid mexports decls)
+   | (moduleName mid) == "main"
+     = CS.Module (mkMIdent [basename (rootname fn)]) mexports decls
+   | otherwise
+     = CS.Module mid mexports decls
+
+
+-- Adds an import declaration for the prelude to the module, if
+-- it is not the prelude itself. If the module already has an explicit
+-- import for the prelude, then a qualified import is added.
+importPrelude :: FilePath -> CS.Module -> CS.Module
+importPrelude fn (CS.Module m es ds)
+   = CS.Module m es (if m == preludeMIdent then ds else ds')
+ where ids = [decl | decl@(CS.ImportDecl _ _ _ _ _) <- ds]
+       ds' = CS.ImportDecl (first fn) preludeMIdent
+                        (preludeMIdent `elem` map importedModule ids)
+                        Nothing Nothing : ds
+       importedModule (CS.ImportDecl _ m q asM is) = fromMaybe m asM
+
+
+-- Returns 'True', if file name and module name are equal.
+isValidModuleId :: FilePath -> ModuleIdent -> Bool
+isValidModuleId fn mid
+   = last (moduleQualifiers mid) == basename (rootname fn)
+
+
+-- Converts a literate source program to a non-literate source program
+unlitLiterate :: FilePath -> String -> (String,String)
+unlitLiterate fn src
+  | isLiterateSource fn = unlit fn src
+  | otherwise           = ("",src)
+
+isLiterateSource :: FilePath -> Bool
+isLiterateSource fn = litExt `isSuffixOf` fn
+
+litExt = ".lcurry"
+
+compileCurry = compileModule_
+
+-------------------------------------------------------------------------------
+-- Messages
+
+err_invalidModuleName :: ModuleIdent -> String
+err_invalidModuleName mid 
+   = "module \"" ++ moduleName mid 
+     ++ "\" must be in a file \"" ++ moduleName mid ++ ".curry\""
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/GenAbstractCurry.hs b/src/GenAbstractCurry.hs
new file mode 100644
--- /dev/null
+++ b/src/GenAbstractCurry.hs
@@ -0,0 +1,1108 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- GenAbstractCurry - Generates an AbstractCurry program term
+--                    (type 'CurryProg')
+--
+-- July 2005,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+module GenAbstractCurry (genTypedAbstract, 
+			 genUntypedAbstract) where
+
+import Data.Maybe
+import Data.List
+import Data.Char
+
+import AbstractCurry
+import Base
+import Types
+import Ident
+import Position
+import TopEnv
+import Env
+
+
+-------------------------------------------------------------------------------
+
+-- Generates standard (type infered) AbstractCurry code from a CurrySyntax
+-- module. The function needs the type environment 'tyEnv' to determin the
+-- infered function types.
+genTypedAbstract :: ValueEnv -> TCEnv -> Module -> CurryProg
+genTypedAbstract tyEnv tcEnv mod
+   = genAbstract (genAbstractEnv TypedAcy tyEnv tcEnv mod) mod
+
+
+-- Generates untyped AbstractCurry code from a CurrySyntax module. The type
+-- signature takes place in every function type annotation, if it exists, 
+-- otherwise the dummy type "Prelude.untyped" is used.
+genUntypedAbstract :: ValueEnv -> TCEnv -> Module -> CurryProg
+genUntypedAbstract tyEnv tcEnv mod
+   = genAbstract (genAbstractEnv UntypedAcy tyEnv tcEnv mod) mod
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+-- Private...
+
+-- Generates an AbstractCurry program term from the syntax tree
+genAbstract :: AbstractEnv -> Module -> CurryProg
+genAbstract env (Module mid exp decls)
+   = let partitions = foldl partitionDecl emptyPartitions decls
+         modname    = moduleName mid 
+	 (imps, _)  
+	     = mapfoldl genImportDecl env (reverse (importDecls partitions))
+	 (types, _) 
+	     = mapfoldl genTypeDecl env (reverse (typeDecls partitions))
+	 (funcs, _) 
+	     = mapfoldl (genFuncDecl False) 
+	                env 
+			(funcDecls partitions)
+	 (ops, _)   
+	     = mapfoldl genOpDecl env (reverse (opDecls partitions))
+     in  CurryProg modname imps types funcs ops
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+-- The following types and functions can be used to spread a list of
+-- CurrySyntax declarations into four parts: a list of imports, a list of
+-- type declarations (data types and type synonyms), a table of function
+-- declarations and a list of fixity declarations.
+
+
+-- Inserts a CurrySyntax top level declaration into a partition.
+-- Note: declarations are collected in reverse order.
+partitionDecl :: Partitions -> Decl -> Partitions
+partitionDecl partitions (TypeSig pos ids typeexpr)
+   = partitionFuncDecls (\id -> TypeSig pos [id] typeexpr) partitions ids
+partitionDecl partitions (EvalAnnot pos ids annot)
+   = partitionFuncDecls (\id -> EvalAnnot pos [id] annot) partitions ids
+partitionDecl partitions (FunctionDecl pos id equs)
+   = partitionFuncDecls (const (FunctionDecl pos id equs)) partitions [id]
+partitionDecl partitions (ExternalDecl pos conv name id typeexpr)
+   = partitionFuncDecls (const (ExternalDecl pos conv name id typeexpr))
+                     partitions
+		     [id]
+partitionDecl partitions (FlatExternalDecl pos ids)
+   = partitionFuncDecls (\id -> FlatExternalDecl pos [id]) partitions ids
+partitionDecl partitions (InfixDecl pos fix prec idents)
+   = partitions {opDecls = (map (\id -> (InfixDecl pos fix prec [id])) idents)
+		          ++ (opDecls partitions)}
+partitionDecl partitions decl
+   = case decl of
+       ImportDecl _ _ _ _ _ 
+         -> partitions {importDecls = decl:(importDecls partitions)}
+       DataDecl _ _ _ _     
+         -> partitions {typeDecls = decl:(typeDecls partitions)}
+       TypeDecl _ _ _ _     
+         -> partitions {typeDecls = decl:(typeDecls partitions)}
+       _ -> partitions
+
+
+--
+partitionFuncDecls :: (Ident -> Decl) -> Partitions -> [Ident] -> Partitions
+partitionFuncDecls genDecl partitions ids
+   = partitions {funcDecls = foldl partitionFuncDecl (funcDecls partitions) ids}
+ where
+   partitionFuncDecl funcs' id
+      = insertEntry id ((genDecl id):(fromMaybe [] (lookup id funcs'))) funcs'
+
+
+-- Data type for representing partitions of CurrySyntax declarations
+-- (according to the definition of the AbstractCurry program
+-- representation; type 'CurryProg').
+-- Since a complete function declaration usually consist of more than one
+-- declaration (e.g. rules, type signature etc.), it is necessary 
+-- to collect them within an association list
+data Partitions = Partitions {importDecls :: [Decl],
+			      typeDecls   :: [Decl],
+			      funcDecls   :: [(Ident,[Decl])],
+			      opDecls     :: [Decl]
+			     } deriving Show
+
+-- Generates initial partitions.
+emptyPartitions = Partitions {importDecls = [],
+			      typeDecls   = [],
+			      funcDecls   = [],
+			      opDecls     = []
+			     } 
+
+
+-------------------------------------------------------------------------------
+-- The following functions convert CurrySyntax terms to AbstractCurry
+-- terms.
+
+--
+genImportDecl :: AbstractEnv -> Decl -> (String, AbstractEnv)
+genImportDecl env (ImportDecl _ mid _ _ _) = (moduleName mid, env)
+
+
+--
+genTypeDecl :: AbstractEnv -> Decl -> (CTypeDecl, AbstractEnv)
+genTypeDecl env (DataDecl _ ident params cdecls)
+   = let (idxs, env1)    = mapfoldl genTVarIndex env params
+	 (cdecls', env2) = mapfoldl genConsDecl env1 cdecls
+     in  (CType (genQName True env2 (qualifyWith (moduleId env) ident))
+	        (genVisibility env2 ident)
+	        (zip idxs (map name params))
+	        cdecls',
+	  resetScope env2)
+genTypeDecl env (TypeDecl _ ident params typeexpr)
+   = let (idxs, env1)      = mapfoldl genTVarIndex env params
+	 (typeexpr', env2) = genTypeExpr env1 typeexpr
+     in  (CTypeSyn (genQName True env2 (qualifyWith (moduleId env) ident))
+	           (genVisibility env2 ident)
+	           (zip idxs (map name params))
+	           typeexpr',
+	  resetScope env2)
+genTypeDecl env (NewtypeDecl pos ident _ _)
+   = errorAt pos "'newtype' declarations are not supported in AbstractCurry"
+genTypeDecl env _
+   = internalError "unexpected declaration"
+
+
+--
+genConsDecl :: AbstractEnv -> ConstrDecl -> (CConsDecl, AbstractEnv)
+genConsDecl env (ConstrDecl _ _ ident params)
+   = let (params', env') = mapfoldl genTypeExpr env params
+     in  (CCons (genQName False env' (qualifyWith (moduleId env) ident))
+	        (length params)
+	        (genVisibility env' ident)
+	        params',
+	  env')
+genConsDecl env (ConOpDecl pos ids ltype ident rtype)
+   = genConsDecl env (ConstrDecl pos ids ident [ltype, rtype])
+
+
+--
+genTypeExpr :: AbstractEnv -> TypeExpr -> (CTypeExpr, AbstractEnv)
+genTypeExpr env (ConstructorType qident targs)
+   = let (targs', env') = mapfoldl genTypeExpr env targs
+     in  (CTCons (genQName True env' qident) targs', env')
+genTypeExpr env (VariableType ident)
+   | isJust midx = (CTVar (fromJust midx, name ident), env)
+   | otherwise   = (CTVar (idx, name ident), env')
+ where
+   midx        = getTVarIndex env ident
+   (idx, env') = genTVarIndex env ident
+genTypeExpr env (TupleType targs)
+   | len > 1   = genTypeExpr env (ConstructorType (qTupleId len) targs)
+   | len == 0  = genTypeExpr env (ConstructorType qUnitId targs)
+   | len == 1  = genTypeExpr env (head targs)
+ where len = length targs
+genTypeExpr env (ListType typeexpr)
+   = genTypeExpr env (ConstructorType qListId [typeexpr])
+genTypeExpr env (ArrowType texpr1 texpr2)
+   = let (texpr1', env1) = genTypeExpr env texpr1
+	 (texpr2', env2) = genTypeExpr env1 texpr2
+     in  (CFuncType texpr1' texpr2', env2)
+genTypeExpr env (RecordType fss mr)
+   = let fs = concatMap (\ (ls,typeexpr) -> map (\l -> (l,typeexpr)) ls) fss
+         (ls,ts) = unzip fs
+         (ts',env1) = mapfoldl genTypeExpr env ts
+         ls' = map name ls
+     in  case mr of
+           Nothing
+             -> (CRecordType (zip ls' ts') Nothing, env1)
+           Just tvar@(VariableType _)
+             -> let (CTVar iname, env2) = genTypeExpr env1 tvar
+                in  (CRecordType (zip ls' ts') (Just iname), env2)
+           Just rec@(RecordType _ _)
+             -> let (CRecordType fields rbase, env2) = genTypeExpr env1 rec
+		    fields' = foldr (\ (l,t) -> insertEntry l t) 
+				    fields
+			            (zip ls' ts')
+		in  (CRecordType fields' rbase, env2)
+           _ -> internalError "illegal record base"
+
+
+-- NOTE: every infix declaration must declare exactly one operator.
+genOpDecl :: AbstractEnv -> Decl -> (COpDecl, AbstractEnv)
+genOpDecl env (InfixDecl _ fix prec [ident])
+   = (COp (genQName False env (qualifyWith (moduleId env) ident))
+          (genFixity fix)
+          prec,
+      env)
+
+
+--
+genFixity :: Infix -> CFixity
+genFixity InfixL = CInfixlOp
+genFixity InfixR = CInfixrOp
+genFixity Infix  = CInfixOp
+
+
+-- Generate an AbstractCurry function declaration from a list of CurrySyntax
+-- function declarations.
+-- NOTES: 
+--   - every declaration in 'decls' must declare exactly one function.
+--   - since infered types are internally represented in flat style,
+--     all type variables are renamed with generated symbols when
+--     generating typed AbstractCurry.
+genFuncDecl :: Bool -> AbstractEnv -> (Ident, [Decl]) -> (CFuncDecl, AbstractEnv)
+genFuncDecl isLocal env (ident, decls)
+   | not (null decls)
+     = let name          = genQName False env (qualify ident)
+	   visibility    = genVisibility env ident
+           evalannot     = maybe CFlex 
+	                         (\ (EvalAnnot _ _ ea) -> genEvalAnnot ea)
+				 (find isEvalAnnot decls)
+           (mtype, env1) = maybe (Nothing, env) 
+                                 (\ (t, env') -> (Just t, env'))
+				 (genFuncType env decls)
+	   (rules, env2) = maybe ([], env1)
+			         (\ (FunctionDecl _ _ equs)
+				  -> mapfoldl genRule env1 equs)
+				 (find isFunctionDecl decls)
+           mexternal     = applyMaybe genExternal (find isExternal decls)
+	   arity         = compArity mtype rules
+           typeexpr      = fromMaybe (CTCons ("Prelude","untyped") []) mtype
+           rule          = compRule evalannot rules mexternal
+           env3          = if isLocal then env1 else resetScope env2
+       in  (CFunc name arity visibility typeexpr rule, env3)
+   | otherwise
+     = internalError ("missing declaration for function \""
+		      ++ show ident ++ "\"")
+ where
+   genFuncType env decls
+      | acytype == UntypedAcy
+	= applyMaybe (genTypeSig env) (find isTypeSig decls)
+      | acytype == TypedAcy
+	= applyMaybe (genTypeExpr env) mftype
+      | otherwise 
+	= Nothing
+    where 
+    acytype = acyType env
+    mftype  | isLocal   
+	      = lookupType ident (typeEnv env)
+	    | otherwise 
+	      = qualLookupType (qualifyWith (moduleId env) ident)
+	                       (typeEnv env)
+
+   genTypeSig env (TypeSig _ _ ts)          = genTypeExpr env ts
+   genTypeSig env (ExternalDecl _ _ _ _ ts) = genTypeExpr env ts
+
+   genExternal (ExternalDecl _ _ mname ident _)
+      = CExternal (fromMaybe (name ident) mname)
+   genExternal (FlatExternalDecl _ [ident])
+      = CExternal (name ident)
+   genExternal _
+      = internalError "illegal external declaration occured"
+
+   compArity mtypeexpr rules
+      | not (null rules)
+        = let (CRule patts _ _) = head rules in length patts
+      | otherwise
+        = maybe (internalError ("unable to compute arity for function \""
+				++ show ident ++ "\""))
+	        compArityFromType
+		mtypeexpr
+
+   compArityFromType (CTVar _)        = 0
+   compArityFromType (CFuncType _ t2) = 1 + (compArityFromType t2)
+   compArityFromType (CTCons _ _)     = 0
+
+   compRule evalannot rules mexternal
+      | not (null rules) = CRules evalannot rules
+      | otherwise
+	= fromMaybe (internalError ("missing rule for function \""
+				    ++ show ident ++ "\""))
+	            mexternal
+
+
+--
+genRule :: AbstractEnv -> Equation -> (CRule, AbstractEnv)
+genRule env (Equation pos lhs rhs)
+   = let (patts, env1)  = mapfoldl (genPattern pos)
+			           (beginScope env) 
+				   (simplifyLhs lhs)
+	 (locals, env2) = genLocalDecls env1 (simplifyRhsLocals rhs)
+	 (crhss, env3)  = mapfoldl (genCrhs pos) env2 (simplifyRhsExpr rhs)
+     in  (CRule patts crhss locals, endScope env3)
+
+
+--
+genCrhs :: Position -> AbstractEnv -> (Expression, Expression) 
+           -> ((CExpr, CExpr), AbstractEnv)
+genCrhs pos env (cond, expr)
+   = let (cond', env1) = genExpr pos env cond
+	 (expr', env2) = genExpr pos env1 expr
+     in  ((cond', expr'), env2)
+
+
+-- NOTE: guarded expressions and 'where' declarations in local pattern
+-- declarations are not supported in PAKCS
+genLocalDecls :: AbstractEnv -> [Decl] -> ([CLocalDecl], AbstractEnv)
+genLocalDecls env decls
+   = genLocals (foldl genLocalIndex env decls)
+               (funcDecls (foldl partitionDecl emptyPartitions decls))
+	       decls
+ where
+   genLocalIndex env (PatternDecl _ constr _)
+      = genLocalPatternIndex env constr
+   genLocalIndex env (ExtraVariables _ idents)
+      = let (_, env') = mapfoldl genVarIndex env idents
+	in  env'
+   genLocalIndex env _
+       = env
+
+   genLocalPatternIndex env (VariablePattern ident)
+      = snd (genVarIndex env ident)
+   genLocalPatternIndex env (ConstructorPattern _ args)
+      = foldl genLocalPatternIndex env args
+   genLocalPatternIndex env (InfixPattern c1 _ c2)
+      = foldl genLocalPatternIndex env [c1,c2]
+   genLocalPatternIndex env (ParenPattern c)
+      = genLocalPatternIndex env c
+   genLocalPatternIndex env (TuplePattern _ args)
+      = foldl genLocalPatternIndex env args
+   genLocalPatternIndex env (ListPattern _ args)
+      = foldl genLocalPatternIndex env args
+   genLocalPatternIndex env (AsPattern ident c)
+      = genLocalPatternIndex (snd (genVarIndex env ident)) c
+   genLocalPatternIndex env (LazyPattern _ c)
+      = genLocalPatternIndex env c
+   genLocalPatternIndex env (RecordPattern fields mc)
+      = let env' = foldl genLocalPatternIndex env (map fieldTerm fields)
+        in  maybe env' (genLocalPatternIndex env') mc
+   genLocalPatternIndex env _
+      = env
+
+   -- The association list 'fdecls' is necessary because function
+   -- rules may not be together in the declaration list
+   genLocals :: AbstractEnv -> [(Ident,[Decl])] -> [Decl] 
+	        -> ([CLocalDecl], AbstractEnv)
+   genLocals env _ [] = ([], env)
+   genLocals env fdecls ((FunctionDecl _ ident _):decls)
+      = let (funcdecl, env1) = genLocalFuncDecl (beginScope env) fdecls ident
+	    (locals, env2)   = genLocals (endScope env1) fdecls decls
+        in  (funcdecl:locals, env2)
+   genLocals env fdecls ((ExternalDecl _ _ _ ident _):decls)
+      = let (funcdecl, env1) = genLocalFuncDecl (beginScope env) fdecls ident
+	    (locals, env2)   = genLocals (endScope env1) fdecls decls
+        in  (funcdecl:locals, env2)
+   genLocals env fdecls ((FlatExternalDecl pos idents):decls)
+      | null idents = genLocals env fdecls decls
+      | otherwise 
+        = let (funcdecl, env1) 
+		= genLocalFuncDecl (beginScope env) fdecls (head idents)
+	      (locals, env2) 
+		= genLocals (endScope env1)
+		            fdecls 
+			    ((FlatExternalDecl pos (tail idents)):decls)
+          in  (funcdecl:locals, env2)
+   genLocals env fdecls ((PatternDecl pos constr rhs):decls)
+      = let (patt, env1)    = genLocalPattern pos env constr
+	    (plocals, env2) = genLocalDecls (beginScope env1) 
+			                    (simplifyRhsLocals rhs)
+	    (expr, env3)    = genLocalPattRhs pos env2 (simplifyRhsExpr rhs)
+	    (locals, env4)  = genLocals (endScope env3) fdecls decls
+	in  ((CLocalPat patt expr plocals):locals, env4)
+   genLocals env fdecls ((ExtraVariables pos idents):decls)
+      | null idents  = genLocals env fdecls decls
+      | otherwise
+        = let ident  = head idents
+	      idx    = fromMaybe 
+		         (internalError ("cannot find index"
+					 ++ " for free variable \""
+					 ++ show ident ++ "\""))
+		         (getVarIndex env ident)
+	      decls' = (ExtraVariables pos (tail idents)):decls
+	      (locals, env') = genLocals env fdecls decls'
+          in  ((CLocalVar (idx, name ident)):locals, env')
+   genLocals env fdecls ((TypeSig _ _ _):decls)
+      = genLocals env fdecls decls
+   genLocals _ _ decl = internalError ("unexpected local declaration: \n"
+				       ++ show (head decl))
+
+   genLocalFuncDecl :: AbstractEnv -> [(Ident,[Decl])] -> Ident 
+		       -> (CLocalDecl, AbstractEnv)
+   genLocalFuncDecl env fdecls ident
+      = let fdecl = fromMaybe 
+		      (internalError ("missing declaration" 
+				      ++ " for local function \""
+				      ++ show ident ++ "\""))
+		      (lookup ident fdecls)
+	    (funcdecl, _) = genFuncDecl True env (ident,fdecl)
+        in  (CLocalFunc funcdecl, env)
+
+   genLocalPattern pos env (LiteralPattern lit)
+      = case lit of
+       String _ cs 
+         -> genLocalPattern pos env 
+                 (ListPattern [] (map (LiteralPattern . Char noRef) cs))
+       _ -> (CPLit (genLiteral lit), env)
+   genLocalPattern pos env (VariablePattern ident)
+      = let idx = fromMaybe 
+		     (internalError ("cannot find index"
+				    ++ " for pattern variable \""
+				    ++ show ident ++ "\""))
+		     (getVarIndex env ident)   
+        in  (CPVar (idx, name ident), env)
+   genLocalPattern pos env (ConstructorPattern qident args)
+      = let (args', env') = mapfoldl (genLocalPattern pos) env args
+	in (CPComb (genQName False env qident) args', env')
+   genLocalPattern pos env (InfixPattern larg qident rarg)
+      = genLocalPattern pos env (ConstructorPattern qident [larg, rarg])
+   genLocalPattern pos env (ParenPattern patt)
+      = genLocalPattern pos env patt
+   genLocalPattern pos env (TuplePattern _ args)
+      | len > 1  
+        = genLocalPattern pos env (ConstructorPattern (qTupleId len) args)
+      | len == 1
+	= genLocalPattern pos env (head args)
+      | len == 0
+	= genLocalPattern pos env (ConstructorPattern qUnitId [])
+    where len = length args
+   genLocalPattern pos env (ListPattern _ args)
+      = genLocalPattern pos env 
+	  (foldr (\p1 p2 -> ConstructorPattern qConsId [p1,p2])
+	   (ConstructorPattern qNilId [])
+	   args)
+   genLocalPattern pos _ (NegativePattern _ _)
+      = errorAt pos "negative patterns are not supported in AbstractCurry"
+   genLocalPattern pos env (AsPattern ident cterm)
+      = let (patt, env1) = genLocalPattern pos env cterm
+	    idx          = fromMaybe 
+			      (internalError ("cannot find index"
+					      ++ " for alias variable \""
+					      ++ show ident ++ "\""))
+			      (getVarIndex env1 ident)
+        in  (CPAs (idx, name ident) patt, env1)
+   genLocalPattern pos env (LazyPattern _ cterm)
+      = let (patt, env') = genLocalPattern pos env cterm
+        in  (CPLazy patt, env')
+   genLocalPattern pos env (RecordPattern fields mr)
+      = let (fields', env1) = mapfoldl (genField genLocalPattern) env fields
+	    (mr', env2)
+		= maybe (Nothing, env1)
+		        ((applyFst Just) . (genLocalPattern pos env1))
+			mr
+	in  (CPRecord fields' mr', env2)
+
+   genLocalPattRhs pos env [(Variable qSuccessFunId, expr)]
+      = genExpr pos env expr
+   genLocalPattRhs pos _ _
+      = errorAt pos ("guarded expressions in pattern declarations"
+		     ++ " are not supported in AbstractCurry")
+
+
+--
+genExpr :: Position -> AbstractEnv -> Expression -> (CExpr, AbstractEnv)
+genExpr pos env (Literal lit)
+   = case lit of
+       String _ cs -> genExpr pos env (List [] (map (Literal . Char noRef) cs))
+       _           -> (CLit (genLiteral lit), env)
+genExpr _ env (Variable qident)
+   | isJust midx          = (CVar (fromJust midx, name ident), env)
+   | qident == qSuccessId = (CSymbol (genQName False env qSuccessFunId), env)
+   | otherwise            = (CSymbol (genQName False env qident), env)
+ where
+   ident = unqualify qident
+   midx  = getVarIndex env ident
+genExpr _ env (Constructor qident)
+   = (CSymbol (genQName False env qident), env)
+genExpr pos env (Paren expr)
+   = genExpr pos env expr
+genExpr pos env (Typed expr _)
+   = genExpr pos env expr
+genExpr pos env (Tuple _ args)
+   | len > 1
+     = genExpr pos env (foldl Apply (Variable (qTupleId (length args))) args)
+   | len == 1
+     = genExpr pos env (head args)
+   | len == 0
+     = genExpr pos env (Variable qUnitId)
+ where len = length args
+genExpr pos env (List _ args)
+   = let cons = Constructor qConsId
+	 nil  = Constructor qNilId
+     in  genExpr pos env (foldr (\e1 e2 -> Apply (Apply cons e1) e2) nil args)
+genExpr pos env (ListCompr _ expr stmts)
+   = let (stmts', env1) = mapfoldl (genStatement pos) (beginScope env) stmts
+	 (expr', env2)  = genExpr pos env1 expr
+     in  (CListComp expr' stmts', endScope env2)
+genExpr pos env (EnumFrom expr)
+   = genExpr pos env (Apply (Variable qEnumFromId) expr)
+genExpr pos env (EnumFromThen expr1 expr2)
+   = genExpr pos env (Apply (Apply (Variable qEnumFromThenId) expr1) expr2)
+genExpr pos env (EnumFromTo expr1 expr2)
+   = genExpr pos env (Apply (Apply (Variable qEnumFromToId) expr1) expr2)
+genExpr pos env (EnumFromThenTo expr1 expr2 expr3)
+   = genExpr pos env (Apply (Apply (Apply (Variable qEnumFromThenToId) 
+				    expr1) expr2) expr3)
+genExpr pos env (UnaryMinus _ expr)
+   = genExpr pos env (Apply (Variable qNegateId) expr)
+genExpr pos env (Apply expr1 expr2)
+   = let (expr1', env1) = genExpr pos env expr1
+	 (expr2', env2) = genExpr pos env1 expr2
+     in  (CApply expr1' expr2', env2)
+genExpr pos env (InfixApply expr1 op expr2)
+   = genExpr pos env (Apply (Apply (opToExpr op) expr1) expr2)
+genExpr pos env (LeftSection expr op)
+   = let ident  = freshVar env "x"
+	 patt   = VariablePattern ident
+	 var    = Variable (qualify ident)
+	 applic = Apply (Apply (opToExpr op) expr) var 
+     in  genExpr pos env (Lambda noRef [patt] applic)
+genExpr pos env (RightSection op expr)
+   = let ident  = freshVar env "x"
+	 patt   = VariablePattern ident
+	 var    = Variable (qualify ident)
+	 applic = Apply (Apply (opToExpr op) var) expr 
+     in  genExpr pos env (Lambda noRef [patt] applic)
+genExpr pos env (Lambda _ params expr)
+   = let (params', env1) = mapfoldl (genPattern pos) (beginScope env) params
+	 (expr', env2)   = genExpr pos env1 expr
+     in  (CLambda params' expr', endScope env2)
+genExpr pos env (Let decls expr)
+   = let (decls', env1) = genLocalDecls (beginScope env) decls
+	 (expr', env2)  = genExpr pos env1 expr
+     in  (CLetDecl decls' expr', endScope env2)
+genExpr pos env (Do stmts expr)
+   = let (stmts', env1) = mapfoldl (genStatement pos) (beginScope env) stmts
+	 (expr', env2)  = genExpr pos env1 expr
+     in  (CDoExpr (stmts' ++ [CSExpr expr']), endScope env2)
+genExpr pos env (IfThenElse _ expr1 expr2 expr3)
+   = genExpr pos env (Apply (Apply (Apply (Variable qIfThenElseId)
+				    expr1) expr2) expr3)
+genExpr pos env (Case _ expr alts)
+   = let (expr', env1) = genExpr pos env expr
+	 (alts', env2) = mapfoldl genBranchExpr env1 alts
+     in  (CCase expr' alts', env2)
+genExpr pos env (RecordConstr fields)
+   = let (fields', env1) = mapfoldl (genField genExpr) env fields
+     in  (CRecConstr fields', env1)
+genExpr pos env (RecordSelection expr label)
+   = let (expr', env1) = genExpr pos env expr
+     in  (CRecSelect expr' (name label), env1)
+genExpr pos env (RecordUpdate fields expr)
+   = let (fields', env1) = mapfoldl (genField genExpr) env fields
+         (expr', env2)   = genExpr pos env1 expr
+     in  (CRecUpdate fields' expr', env2)
+
+
+--
+genStatement :: Position -> AbstractEnv -> Statement 
+	        -> (CStatement, AbstractEnv)
+genStatement pos env (StmtExpr _ expr)
+   = let (expr', env') = genExpr pos env expr
+     in  (CSExpr expr', env')
+genStatement _ env (StmtDecl decls)
+   = let (decls', env') = genLocalDecls env decls
+     in  (CSLet decls', env')
+genStatement pos env (StmtBind _ patt expr)
+   = let (expr', env1) = genExpr pos env expr
+	 (patt', env2) = genPattern pos env1 patt
+     in  (CSPat patt' expr', env2)
+
+
+-- NOTE: guarded expressions and local declarations in case branches
+-- are not supported in PAKCS
+genBranchExpr :: AbstractEnv -> Alt -> (CBranchExpr, AbstractEnv)
+genBranchExpr env (Alt pos patt rhs)
+   = let (patt', env1) = genPattern pos (beginScope env) patt
+	 (expr', env2) = genBranchRhs pos env1 (simplifyRhsExpr rhs)
+     in  (CBranch patt' expr', endScope env2)
+ where
+   genBranchRhs pos env [(Variable qSuccessFunId, expr)]
+      = genExpr pos env expr
+   genBranchRhs pos _ _
+      = errorAt pos ("guarded expressions in case alternatives"
+		     ++ " are not supported in AbstractCurry")
+
+
+--
+genPattern :: Position -> AbstractEnv -> ConstrTerm -> (CPattern, AbstractEnv)
+genPattern pos env (LiteralPattern lit)
+   = case lit of
+       String _ cs 
+         -> genPattern pos env (ListPattern [] (map (LiteralPattern . Char noRef) cs))
+       _ -> (CPLit (genLiteral lit), env)
+genPattern _ env (VariablePattern ident)
+   = let (idx, env') = genVarIndex env ident
+     in  (CPVar (idx, name ident), env')
+genPattern pos env (ConstructorPattern qident args)
+   = let (args', env') = mapfoldl (genPattern pos) env args
+     in  (CPComb (genQName False env qident) args', env')
+genPattern pos env (InfixPattern larg qident rarg)
+   = genPattern pos env (ConstructorPattern qident [larg, rarg])
+genPattern pos env (ParenPattern patt)
+   = genPattern pos env patt
+genPattern pos env (TuplePattern _ args)
+   | len > 1
+     = genPattern pos env (ConstructorPattern (qTupleId len) args)
+   | len == 1
+     = genPattern pos env (head args)
+   | len == 0
+     = genPattern pos env (ConstructorPattern qUnitId [])
+ where len = length args
+genPattern pos env (ListPattern _ args)
+   = genPattern pos env (foldr (\x1 x2 -> ConstructorPattern qConsId [x1, x2]) 
+		         (ConstructorPattern qNilId []) 
+		         args)
+genPattern pos _ (NegativePattern _ _)
+   = errorAt pos "negative patterns are not supported in AbstractCurry"
+genPattern pos env (AsPattern ident cterm)
+   = let (patt, env1) = genPattern pos env cterm
+	 (idx, env2) = genVarIndex env1 ident
+     in  (CPAs (idx, name ident) patt, env2)
+genPattern pos env (LazyPattern _ cterm)
+   = let (patt, env') = genPattern pos env cterm
+     in  (CPLazy patt, env')
+genPattern pos env (FunctionPattern qident cterms)
+   = let (patts, env') = mapfoldl (genPattern pos) env cterms
+     in  (CPFuncComb (genQName False env qident) patts, env')
+genPattern pos env (InfixFuncPattern cterm1 qident cterm2)
+   = genPattern pos env (FunctionPattern qident [cterm1, cterm2])
+genPattern pos env (RecordPattern fields mr)
+   = let (fields', env1) = mapfoldl (genField genPattern) env fields
+         (mr', env2)     = maybe (Nothing, env1)
+                                 ((applyFst Just) . (genPattern pos env1))
+				 mr
+     in  (CPRecord fields' mr', env2)
+
+
+--
+genField :: (Position -> AbstractEnv -> a -> (b, AbstractEnv))
+	 -> AbstractEnv -> Field a -> (CField b, AbstractEnv)
+genField genTerm env (Field pos label term)
+   = let (term',env1) = genTerm pos env term
+     in  ((name label, term'), env1)
+
+--
+genLiteral :: Literal -> CLiteral
+genLiteral (Char _ c)  = CCharc c
+genLiteral (Int _ i)   = CIntc i
+genLiteral (Float _ f) = CFloatc f
+genLiteral _           = internalError "unsupported literal"
+
+
+-- Notes: 
+-- - Some prelude identifiers are not quialified. The first check ensures
+--   that they get a correct qualifier.
+-- - The test for unqualified identifiers is necessary to qualify
+--   them correctly in the untyped AbstractCurry representation.
+genQName :: Bool -> AbstractEnv -> QualIdent -> QName
+genQName isTypeCons env qident
+   | isPreludeSymbol qident
+     = genQualName (qualQualify preludeMIdent qident)
+   | not (isQualified qident)
+     = genQualName (getQualIdent (unqualify qident))
+   | otherwise
+     = genQualName qident
+ where
+  ident = unqualify qident
+
+  genQualName qid
+     = let (mmid, id) = splitQualIdent qid
+	   mid = maybe (moduleId env)
+		       (\mid' -> fromMaybe mid' (lookupEnv mid' (imports env)))
+		       mmid
+       in  (moduleName mid, name id)
+
+  getQualIdent id
+     | isTypeCons = case (lookupTC id (tconsEnv env)) of
+		      --[DataType qid _ _] -> qid
+		      --[RenamingType qid _ _] -> qid
+		      --[AliasType qid _ _] -> qid
+		      [info] -> origName info
+		      _ ->  qualifyWith (moduleId env) id
+     | otherwise  = case (lookupValue id (typeEnv env)) of
+		      --[DataConstructor qid _] -> qid
+		      --[NewtypeConstructor qid _] -> qid
+		      --[Value qid _] -> qid
+		      [info] -> origName info
+		      _ -> qualifyWith (moduleId env) id
+		      
+
+
+--
+genVisibility :: AbstractEnv -> Ident -> CVisibility
+genVisibility env ident
+   | isExported env ident = Public
+   | otherwise            = Private
+
+
+--
+genEvalAnnot :: EvalAnnotation -> CEvalAnnot
+genEvalAnnot EvalRigid  = CRigid
+genEvalAnnot EvalChoice = CChoice
+
+
+-------------------------------------------------------------------------------
+-- This part defines an environment containing all necessary information
+-- for generating the AbstractCurry representation of a CurrySyntax term.
+
+-- Data type for representing an AbstractCurry generator environment.
+--
+--    moduleName  - name of the module
+--    typeEnv     - table of all known types
+--    exports     - table of all exported symbols from the module
+--    imports     - table of import aliases
+--    varIndex    - index counter for generating variable indices
+--    tvarIndex   - index counter for generating type variable indices
+--    varScope    - stack of variable tables
+--    tvarScope   - stack of type variable tables
+--    acyType     - type of AbstractCurry code to be generated
+data AbstractEnv = AbstractEnv {moduleId   :: ModuleIdent,
+				typeEnv    :: ValueEnv,
+				tconsEnv   :: TCEnv,
+				exports    :: Env Ident (),
+				imports    :: Env ModuleIdent ModuleIdent,
+				varIndex   :: Int,
+				tvarIndex  :: Int,
+				varScope   :: [Env Ident Int],
+				tvarScope  :: [Env Ident Int],
+                                acyType    :: AbstractType
+			       } deriving Show
+
+-- Data type representing the type of AbstractCurry code to be generated
+-- (typed infered or untyped (i.e. type signated))
+data AbstractType = TypedAcy | UntypedAcy deriving (Eq, Show)
+
+
+-- Initializes the AbstractCurry generator environment.
+genAbstractEnv :: AbstractType -> ValueEnv -> TCEnv -> Module -> AbstractEnv
+genAbstractEnv absType tyEnv tcEnv (Module mid exps decls)
+   = AbstractEnv 
+       {moduleId     = mid,
+	typeEnv      = tyEnv,
+	tconsEnv     = tcEnv,
+	exports      = foldl (buildExportTable mid decls) emptyEnv exps',
+	imports      = foldl buildImportTable emptyEnv decls,
+	varIndex     = 0,
+	tvarIndex    = 0,
+	varScope     = [emptyEnv],
+	tvarScope    = [emptyEnv],
+        acyType      = absType
+       }
+ where
+   exps' = maybe (buildExports mid decls) (\ (Exporting _ es) -> es) exps
+
+
+-- Generates a list of exports for all specified top level declarations
+buildExports :: ModuleIdent -> [Decl] -> [Export]
+buildExports _ [] = []
+buildExports mid ((DataDecl _ ident _ _):ds) 
+   = (ExportTypeAll (qualifyWith mid ident)):(buildExports mid ds)
+buildExports mid ((NewtypeDecl _ ident _ _):ds)
+   = (ExportTypeAll (qualifyWith mid ident)):(buildExports mid ds)
+buildExports mid ((TypeDecl _ ident _ _):ds)
+   = (Export (qualifyWith mid ident)):(buildExports mid ds)
+buildExports mid ((FunctionDecl _ ident _):ds)
+   = (Export (qualifyWith mid ident)):(buildExports mid ds)
+buildExports mid ((ExternalDecl _ _ _ ident _):ds)
+   = (Export (qualifyWith mid ident)):(buildExports mid ds)
+buildExports mid ((FlatExternalDecl _ idents):ds)
+   = (map (Export . (qualifyWith mid)) idents) ++ (buildExports mid ds)
+buildExports mid (_:ds) = buildExports mid ds
+
+
+-- Builds a table containing all exported (i.e. public) identifiers
+-- from a module.
+buildExportTable :: ModuleIdent -> [Decl] -> Env Ident () -> Export 
+                    -> Env Ident ()
+buildExportTable mid _ exptab (Export qident)
+   | isJust (localIdent mid qident)
+     = insertExportedIdent exptab (unqualify qident)
+   | otherwise = exptab
+buildExportTable mid _ exptab (ExportTypeWith qident ids)
+   | isJust (localIdent mid qident)
+     = foldl insertExportedIdent 
+             (insertExportedIdent exptab (unqualify qident))
+             ids
+   | otherwise  = exptab
+buildExportTable mid decls exptab (ExportTypeAll qident)
+   | isJust ident'
+     = foldl insertExportedIdent
+             (insertExportedIdent exptab ident)
+             (maybe [] getConstrIdents (find (isDataDeclOf ident) decls))
+   | otherwise = exptab
+ where 
+   ident' = localIdent mid qident
+   ident  = fromJust ident'
+buildExportTable _ _ exptab (ExportModule _) = exptab
+
+--
+insertExportedIdent :: Env Ident () -> Ident -> Env Ident ()
+insertExportedIdent env ident = bindEnv ident () env
+
+--
+getConstrIdents :: Decl -> [Ident]
+getConstrIdents (DataDecl _ _ _ constrs)
+   = map getConstrIdent constrs
+ where
+   getConstrIdent (ConstrDecl _ _ ident _)  = ident
+   getConstrIdent (ConOpDecl _ _ _ ident _) = ident
+
+
+-- Builds a table for dereferencing import aliases
+buildImportTable :: Env ModuleIdent ModuleIdent -> Decl
+		    -> Env ModuleIdent ModuleIdent
+buildImportTable env (ImportDecl _ mid _ malias _)
+   = bindEnv (fromMaybe mid malias) mid env
+buildImportTable env _ = env
+
+
+-- Checks whether an identifier is exported or not.
+isExported :: AbstractEnv -> Ident -> Bool
+isExported env ident = isJust (lookupEnv ident (exports env))
+
+
+-- Generates an unique index for the  variable 'ident' and inserts it
+-- into the  variable table of the current scope.
+genVarIndex :: AbstractEnv -> Ident -> (Int, AbstractEnv)
+genVarIndex env ident 
+   = let idx   = varIndex env
+         vtabs = varScope env
+	 vtab  = head vtabs --if null vtabs then emptyEnv else head vtabs
+     in  (idx, env {varIndex = idx + 1,
+		    varScope = (bindEnv ident idx vtab):(sureTail vtabs)})
+
+-- Generates an unique index for the type variable 'ident' and inserts it
+-- into the type variable table of the current scope.
+genTVarIndex :: AbstractEnv -> Ident -> (Int, AbstractEnv)
+genTVarIndex env ident
+   = let idx   = tvarIndex env
+         vtabs = tvarScope env
+	 vtab  = head vtabs --if null vtabs then emptyEnv else head vtabs
+     in  (idx, env {tvarIndex = idx + 1,
+		    tvarScope = (bindEnv ident idx vtab):(sureTail vtabs)})
+
+
+-- Looks up the unique index for the variable 'ident' in the
+-- variable table of the current scope.
+getVarIndex :: AbstractEnv -> Ident -> Maybe Int
+getVarIndex env ident = lookupEnv ident (head (varScope env))
+
+-- Looks up the unique index for the type variable 'ident' in the type
+-- variable table of the current scope.
+getTVarIndex :: AbstractEnv -> Ident -> Maybe Int
+getTVarIndex env ident = lookupEnv ident (head (tvarScope env))
+
+
+-- Generates an indentifier which doesn't occur in the variable table
+-- of the current scope.
+freshVar :: AbstractEnv -> String -> Ident
+freshVar env name = genFreshVar env name 0
+ where
+   genFreshVar env name idx
+      | isJust (getVarIndex env ident)
+         = genFreshVar env name (idx + 1)
+      | otherwise 
+         = ident
+    where ident = mkIdent (name ++ show idx)
+
+-- Generates an indentifier which doesn't occur in the type variable table
+-- of the current scope.
+freshTVar :: AbstractEnv -> String -> Ident
+freshTVar env name = genFreshTVar env name 0
+ where
+   genFreshTVar env name idx
+      | isJust (getTVarIndex env ident)
+         = genFreshTVar env name (idx + 1)
+      | otherwise 
+         = ident
+    where ident = mkIdent (name ++ show idx)
+
+
+-- Sets the index counter back to zero and deletes all stack entries.
+resetScope :: AbstractEnv -> AbstractEnv
+resetScope env = env {varIndex  = 0,
+		      tvarIndex = 0,
+		      varScope  = [emptyEnv],
+		      tvarScope = [emptyEnv]}
+
+-- Starts a new scope, i.e. copies and pushes the variable table of the current 
+-- scope onto the top of the stack
+beginScope :: AbstractEnv -> AbstractEnv
+beginScope env = env {varScope  = (head vs):vs,
+		      tvarScope = (head tvs):tvs}
+ where
+ vs  = varScope env
+ tvs = tvarScope env
+
+-- End the current scope, i.e. pops and deletes the variable table of the
+-- current scope from the top of the stack.
+endScope :: AbstractEnv -> AbstractEnv
+endScope env = env {varScope  = if oneElement vs then vs else tail vs,
+		    tvarScope = if oneElement tvs then tvs else tail tvs}
+ where
+ vs  = varScope env
+ tvs = tvarScope env
+
+
+-------------------------------------------------------------------------------
+-- Miscellaneous...
+
+-- Some identifiers...
+qEnumFromId       = qualifyWith preludeMIdent (mkIdent "enumFrom")
+qEnumFromThenId   = qualifyWith preludeMIdent (mkIdent "enumFromThen")
+qEnumFromToId     = qualifyWith preludeMIdent (mkIdent "enumFromTo")
+qEnumFromThenToId = qualifyWith preludeMIdent (mkIdent "enumFromThenTo")
+qNegateId         = qualifyWith preludeMIdent (mkIdent "negate")
+qIfThenElseId     = qualifyWith preludeMIdent (mkIdent "if_then_else")
+qSuccessFunId     = qualifyWith preludeMIdent (mkIdent "success")
+
+
+-- The following functions check whether a declaration is of a certain kind
+isFunctionDecl :: Decl -> Bool
+isFunctionDecl (FunctionDecl _ _ _) = True
+isFunctionDecl _                    = False
+
+isExternal :: Decl -> Bool
+isExternal (ExternalDecl _ _ _ _ _) = True
+isExternal (FlatExternalDecl _ _)   = True
+isExternal _                        = False
+
+
+-- Checks, whether a declaration is the data declaration of 'ident'.
+isDataDeclOf :: Ident -> Decl -> Bool
+isDataDeclOf ident (DataDecl _ ident' _ _) 
+   = ident == ident'
+isDataDeclOf _ _  
+   = False
+
+
+-- Checks, whether a symbol is defined in the Prelude.
+isPreludeSymbol :: QualIdent -> Bool
+isPreludeSymbol qident
+   = let (mmid, ident) = splitQualIdent qident
+     in  (isJust mmid && preludeMIdent == fromJust mmid)
+         || elem ident [unitId, listId, nilId, consId]
+	 || isTupleId ident
+
+
+-- Converts an infix operator to an expression
+opToExpr :: InfixOp -> Expression
+opToExpr (InfixOp qident)     = Variable qident
+opToExpr (InfixConstr qident) = Constructor qident
+
+
+-- Looks up the type of a qualified symbol in the type environment and
+-- converts it to a CurrySyntax type term.
+qualLookupType :: QualIdent -> ValueEnv -> Maybe TypeExpr
+qualLookupType qident tyEnv
+   = case (qualLookupValue qident tyEnv) of
+       [Value _ ts] -> (\ (ForAll _ ty) -> Just (toCSType ty)) ts
+       _            -> Nothing
+
+-- Looks up the type of a symbol in the type environment and
+-- converts it to a CurrySyntax type term.
+lookupType :: Ident -> ValueEnv -> Maybe TypeExpr
+lookupType ident tyEnv
+   = case (lookupValue ident tyEnv) of
+       [Value _ ts] -> (\ (ForAll _ ty) -> Just (toCSType ty)) ts
+       _            -> Nothing
+
+
+-- Converts the internal representation of the types from the type
+-- envorinment to CurrySyntax representation
+toCSType :: Type -> TypeExpr
+toCSType = fromType 
+{-
+toCSType (TypeConstructor qident types)
+   = ConstructorType qident (map toCSType types)
+toCSType (TypeVariable idx)
+   = VariableType (mkVarIdent idx)
+toCSType (TypeConstrained types _)
+   = toCSType (head types)
+toCSType (TypeArrow type1 type2)
+   = ArrowType (toCSType type1) (toCSType type2)
+toCSType (TypeSkolem idx)
+   = VariableType (mkVarIdent idx)
+-}
+
+{-
+--
+solveTypeSyn :: TCEnv -> QualIdent -> [TypeExpr] -> Maybe TypeExpr
+solveTypeSyn tcEnv qident args
+   = case (qualLookupTC qident tcEnv) of
+       [AliasType _ _ t] -> Just (adaptType args t)
+       _ -> case (lookupTC (unqualify qident) tcEnv) of
+	       [AliasType _ _ t] -> Just (adaptType args t)
+	       _ -> Nothing
+
+--
+adaptType :: [TypeExpr] -> Type -> TypeExpr
+adaptType args texpr = adapt (zip [0 .. ((length args) - 1)] args) texpr
+ where
+ adapt its (TypeConstructor qident types)
+    = ConstructorType qident (map (adapt its) types)
+ adapt its (TypeVariable idx)
+    = fromMaybe (internalError "cannot adapt type variable")
+	        (lookup idx its)
+ adapt its (TypeConstrained types _)
+    = adapt its (head types)
+ adapt its (TypeArrow type1 type2)
+    = ArrowType (adapt its type1) (adapt its type2)
+ adapt its (TypeSkolem idx)
+    = adapt its (TypeVariable idx)
+-}
+
+-- Generates a variable name from an index.
+mkVarIdent :: Int -> Ident
+mkVarIdent i | i < 0     = mkIdent ('b':(show (i * (-1)))) 
+             | i < 26    = mkIdent [chr (i + ord 'a')]
+	     | otherwise = mkIdent ('a':(show i))
+       
+
+
+-- The following functions transform left-hand-side and right-hand-side terms
+-- for a better handling
+simplifyLhs :: Lhs -> [ConstrTerm]
+simplifyLhs lhs = snd (flatLhs lhs)
+
+simplifyRhsExpr :: Rhs -> [(Expression, Expression)]
+simplifyRhsExpr (SimpleRhs _ expr _) 
+   = [(Variable qSuccessId, expr)]
+simplifyRhsExpr (GuardedRhs crhs _)  
+   = map (\ (CondExpr _ cond expr) -> (cond, expr)) crhs
+
+simplifyRhsLocals :: Rhs -> [Decl]
+simplifyRhsLocals (SimpleRhs _ _ locals) = locals
+simplifyRhsLocals (GuardedRhs _ locals)  = locals
+
+
+-- Applies the function 'f' on the value which is wrapped in 'Just'.
+applyMaybe :: (a -> b) -> Maybe a -> Maybe b
+applyMaybe f (Just x) = Just (f x)
+applyMaybe _ Nothing  = Nothing
+
+-- A combination of 'map' and 'foldl'. It maps a function to a list
+-- from left to right while updating the argument 'e' continously.
+mapfoldl :: (a -> b -> (c,a)) -> a -> [b] -> ([c], a)
+mapfoldl _ e []     = ([], e)
+mapfoldl f e (x:xs) = let (x', e')   = f e x
+                          (xs', e'') = mapfoldl f e' xs
+                      in  (x':xs', e'')
+
+-- Inserts an element under a key into an association list
+insertEntry :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
+insertEntry k e [] = [(k,e)]
+insertEntry k e ((x,y):xys)
+   | k == x    = (k,e):xys
+   | otherwise = (x,y):(insertEntry k e xys)
+
+
+-- Returns the list without the first element. If the list is empty, an
+-- empty list will be returned.
+sureTail :: [a] -> [a]
+sureTail []     = []
+sureTail (_:xs) = xs
+
+
+-- Returns 'True', if a list contains exactly one element
+oneElement :: [a] -> Bool
+oneElement [_] = True
+oneElement _   = False
+
+
+-- Applies 'f' on the first value in a tuple
+applyFst :: (a -> c) -> (a,b) -> (c,b)
+applyFst f (x,y) = (f x, y)
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/GenFlatCurry.hs b/src/GenFlatCurry.hs
new file mode 100644
--- /dev/null
+++ b/src/GenFlatCurry.hs
@@ -0,0 +1,1140 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- GenFlatCurry - Generates FlatCurry program terms and FlatCurry interfaces
+--                (type 'FlatCurry.Prog')
+--
+-- November 2005,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+module GenFlatCurry (genFlatCurry,
+		     genFlatInterface) where
+
+import Debug.Trace
+
+import Control.Monad.State
+import Control.Monad
+import Data.Maybe
+import Data.List
+
+import Base (ArityEnv, ArityInfo(..), ModuleEnv, PEnv, PrecInfo(..), 
+	     OpPrec(..), TCEnv, TypeInfo(..), ValueEnv, ValueInfo(..),
+	     lookupValue, qualLookupTC,
+	     qualLookupArity, lookupArity,  internalError)
+
+--import FlatWithSrcRefs
+import ExtendedFlat
+
+import qualified IL
+import qualified CurrySyntax as CS
+
+import CurryEnv (CurryEnv)
+import qualified CurryEnv
+
+import ScopeEnv (ScopeEnv)
+import qualified ScopeEnv
+
+
+import Types
+import CurryCompilerOpts
+import Message
+import PatchPrelude
+import Ident as Id
+import Env
+import Map
+
+
+-------------------------------------------------------------------------------
+
+-- transforms intermediate language code (IL) to FlatCurry code
+genFlatCurry :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv 
+		-> ArityEnv -> IL.Module -> (Prog, [Message])
+genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv mod
+   = (patchPreludeFCY prog, messages)
+ where (prog, messages) 
+	   = run opts cEnv mEnv tyEnv tcEnv aEnv False (visitModule mod)
+
+
+-- transforms intermediate language code (IL) to FlatCurry interfaces
+genFlatInterface :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv
+		 -> ArityEnv -> IL.Module -> (Prog, [Message])
+genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv mod
+   = (patchPreludeFCY intf, messages)
+ where (intf, messages) 
+	   = run opts cEnv mEnv tyEnv tcEnv aEnv True (visitModule mod)
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+--
+visitModule :: IL.Module -> FlatState Prog
+visitModule (IL.Module mid imps decls)
+   = whenFlatCurry
+       (do ops     <- genOpDecls
+           datas   <- mapM visitDataDecl (filter isDataDecl decls)
+	   types   <- genTypeSynonyms
+	   records <- genRecordTypes
+	   funcs   <- mapM visitFuncDecl (filter isFuncDecl decls)
+	   mod     <- visitModuleIdent mid
+	   imps'   <- imports
+	   is      <- mapM visitModuleIdent 
+	                   (nub (imps ++ (map (\ (CS.IImportDecl _ mid) 
+					       -> mid) imps')))
+           return (Prog mod is (records ++ types ++ datas) funcs ops))
+       (do ops     <- genOpDecls
+	   ds      <- filterM isPublicDataDecl decls
+	   datas   <- mapM visitDataDecl ds
+	   types   <- genTypeSynonyms
+	   records <- genRecordTypes
+	   fs      <- filterM isPublicFuncDecl decls
+	   funcs   <- mapM visitFuncDecl fs
+	   expimps <- getExportedImports
+	   itypes  <- mapM visitTypeIDecl (filter isTypeIDecl expimps)
+	   ifuncs  <- mapM visitFuncIDecl (filter isFuncIDecl expimps)
+	   iops    <- mapM visitOpIDecl (filter isOpIDecl expimps)
+	   mod     <- visitModuleIdent mid
+	   imps'   <- imports
+	   is      <- mapM visitModuleIdent 
+	                   (nub (imps ++ (map (\ (CS.IImportDecl _ mid) 
+					       -> mid) imps')))
+	   return (Prog mod 
+		        is 
+		        (itypes ++ records ++ types ++ datas)
+		        (ifuncs ++ funcs)
+		        (iops ++ ops)))
+
+--
+visitDataDecl :: IL.Decl -> FlatState TypeDecl
+visitDataDecl (IL.DataDecl qident arity constrs)
+   = do cdecls <- mapM visitConstrDecl constrs
+	qname  <- visitQualIdent qident
+	vis    <- getVisibility False qident
+	return (Type qname vis [0 .. (arity - 1)] (concat cdecls))
+visitDataDecl _ = internalError "GenFlatCurry: no data declaration"
+
+--
+visitConstrDecl :: IL.ConstrDecl [IL.Type] -> FlatState [ConsDecl]
+visitConstrDecl (IL.ConstrDecl qident types)
+   = do texprs <- mapM visitType types
+	qname  <- visitQualIdent qident
+	vis    <- getVisibility True qident
+        genFint <- genInterface
+        if genFint && vis == Private 
+          then return []
+          else return [Cons qname (length types) vis texprs]
+
+--
+visitType :: IL.Type -> FlatState TypeExpr
+visitType (IL.TypeConstructor qident types)
+   = do texprs <- mapM visitType types
+	qname  <- visitQualIdent qident
+	if (qualName qident) == "Identity"
+	   then return (head texprs)
+	   else return (TCons qname texprs)
+visitType (IL.TypeVariable index)
+   = return (TVar (int2num index))
+visitType (IL.TypeArrow type1 type2)
+   = do texpr1 <- visitType type1
+	texpr2 <- visitType type2
+	return (FuncType texpr1 texpr2)
+
+--
+visitFuncDecl :: IL.Decl -> FlatState FuncDecl
+visitFuncDecl (IL.FunctionDecl qident params typeexpr expression)
+   = whenFlatCurry
+       (do setFunctionId qident
+	   is    <- mapM newVarIndex params
+	   texpr <- visitType typeexpr
+	   expr  <- visitExpression expression
+	   qname <- visitQualIdent qident
+	   vis   <- getVisibility False qident
+	   clearVarIndices
+	   return (Func qname (length params) vis texpr (Rule is expr)))
+       (do setFunctionId qident
+	   texpr <- visitType typeexpr
+	   qname <- visitQualIdent qident
+	   clearVarIndices
+	   return (Func qname (length params) Public texpr (Rule [] (Var $ mkIdx 0))))
+visitFuncDecl (IL.ExternalDecl qident _ name typeexpr)
+   = do setFunctionId qident
+	texpr <- visitType typeexpr
+	qname <- visitQualIdent qident
+	vis   <- getVisibility False qident
+	xname <- visitExternalName name
+	return (Func qname (typeArity typeexpr) vis texpr (External xname))
+visitFuncDecl (IL.NewtypeDecl _ _ _)
+   = do mid <- moduleId 
+	error ("\"" ++ Id.moduleName mid 
+	       ++ "\": newtype declarations are not supported")
+visitFuncDecl _ = internalError "GenFlatCurry: no function declaration"
+
+--
+visitExpression :: IL.Expression -> FlatState Expr
+visitExpression (IL.Literal literal)
+   = liftM Lit (visitLiteral literal)
+visitExpression (IL.Variable ident)
+   = liftM Var (lookupVarIndex ident)
+visitExpression (IL.Function qident _)
+   = do arity_ <- lookupIdArity qident
+	maybe (internalError (funcArity qident))
+	      (\arity -> genFuncCall qident arity [])
+	      arity_
+visitExpression (IL.Constructor qident arity)
+   = do arity_ <- lookupIdArity qident
+	maybe (internalError (consArity qident))
+	      (\arity -> genConsCall qident arity [])
+	      arity_
+visitExpression (IL.Apply expression1 expression2)
+   = genFlatApplication (IL.Apply expression1 expression2)
+visitExpression (IL.Case r evalannot expression alts)
+   = do ea       <- visitEval evalannot
+	expr     <- visitExpression expression
+	branches <- mapM visitAlt alts
+	return (Case r ea expr branches)
+visitExpression (IL.Or expression1 expression2)
+   = do expr1 <- visitExpression expression1
+	expr2 <- visitExpression expression2
+	checkOverlapping expr1 expr2
+	return (Or expr1 expr2)
+visitExpression (IL.Exist ident expression)
+   = do index <- newVarIndex ident
+	expr  <- visitExpression expression
+	case expr of
+	  Free is expr' -> return (Free (index:is) expr')
+	  _             -> return (Free [index] expr)
+visitExpression (IL.Let binding expression)
+   = do beginScope
+	newVarIndex (bindingIdent binding)
+        bind <- visitBinding binding
+	expr <- visitExpression expression
+	case expr of
+	  Let binds expr' -> return (Let (bind:binds) expr')
+	  _               -> return (Let [bind] expr)
+visitExpression (IL.Letrec bindings expression)
+   = do beginScope
+	mapM_ newVarIndex (map bindingIdent bindings)
+	binds <- mapM visitBinding bindings
+	expr  <- visitExpression expression
+	endScope
+	return (Let binds expr)
+
+
+getTypeOf :: Ident -> FlatState (Maybe TypeExpr)
+getTypeOf ident = do
+    (valEnv, _) <- environments
+    case lookupValue ident valEnv of 
+      Value _ (ForAll _ t) : _ 
+          -> do t <- visitType (ttrans t)
+                trace ("getTypeOf(" ++ show ident ++ ") = " ++ show t)$
+                      return (Just t)
+      v   -> trace ("lookupValue did not return a value for index " ++ show ident ++ ", instead " ++ show v)
+             (return Nothing)
+    where ttrans :: Type -> IL.Type 
+          ttrans (TypeConstructor i ts)
+              = IL.TypeConstructor i (map ttrans ts)
+          ttrans (TypeVariable v)
+              = IL.TypeVariable v
+          ttrans (TypeConstrained [] v)
+              = trace (msg1 v) $ IL.TypeVariable v
+          ttrans (TypeConstrained (v:_) i)
+              = trace (msg2 i ilt) ilt
+              where ilt = ttrans v
+          ttrans (TypeArrow f x) = IL.TypeArrow (ttrans f) (ttrans x)
+          ttrans s@(TypeSkolem _) = error $ "in ttrans: " ++ show s
+          ttrans s@(TypeRecord _ _) = error $ "in ttrans: " ++ show s
+          msg1 i = "in ttrans: empty TypeConstrained, coerced to type var #" ++ show i
+          msg2 i t = "in ttrans: TypeConstrained with index " ++ show i ++ ", coerced to " ++ show t
+
+--
+visitLiteral :: IL.Literal -> FlatState Literal
+visitLiteral (IL.Char rs c)  = return (Charc rs c)
+visitLiteral (IL.Int rs i)   = return (Intc rs i)
+visitLiteral (IL.Float rs f) = return (Floatc rs f)
+
+--
+visitAlt :: IL.Alt -> FlatState BranchExpr
+visitAlt (IL.Alt cterm expression)
+   = do patt <- visitConstrTerm cterm
+	expr <- visitExpression expression
+	return (Branch patt expr)
+
+--
+visitConstrTerm :: IL.ConstrTerm -> FlatState Pattern
+visitConstrTerm (IL.LiteralPattern literal)
+   = do lit <- visitLiteral literal
+	return (LPattern lit)
+visitConstrTerm (IL.ConstructorPattern qident args)
+   = do is    <- mapM newVarIndex args
+	qname <- visitQualIdent qident
+	return (Pattern qname is)
+visitConstrTerm (IL.VariablePattern ident)
+   = do mid <- moduleId
+	error ("\"" ++ Id.moduleName mid 
+	       ++ "\": variable patterns are not supported")
+
+--
+visitEval :: IL.Eval -> FlatState CaseType
+visitEval IL.Rigid = return (Rigid)
+visitEval IL.Flex  = return (Flex)
+
+--
+visitBinding :: IL.Binding -> FlatState (VarIndex, Expr)
+visitBinding (IL.Binding ident expression)
+   = do index <- lookupVarIndex ident
+	expr  <- visitExpression expression
+	return (index, expr)
+
+
+-------------------------------------------------------------------------------
+
+--
+visitFuncIDecl :: CS.IDecl -> FlatState FuncDecl
+visitFuncIDecl (CS.IFunctionDecl _ qident arity typeexpr)
+   = do texpr <- visitType (fst (cs2ilType [] typeexpr))
+	qname <- visitQualIdent qident
+	return (Func qname arity Public texpr (Rule [] (Var $ mkIdx 0)))
+visitFuncIDecl _ = internalError "GenFlatCurry: no function interface"
+
+--
+visitTypeIDecl :: CS.IDecl -> FlatState TypeDecl
+visitTypeIDecl (CS.IDataDecl _ qident params constrs_)
+   = do let mid = fromMaybe (internalError "GenFlatCurry: no module name")
+		            (fst (splitQualIdent qident))
+	    is  = [0 .. (length params) - 1]
+	cdecls <- mapM (visitConstrIDecl mid (zip params is)) 
+		       (catMaybes constrs_)
+	qname  <- visitQualIdent qident
+	return (Type qname Public is cdecls)
+visitTypeIDecl (CS.ITypeDecl _ qident params typeexpr)
+   = do let is = [0 .. (length params) - 1]
+	texpr <- visitType (fst (cs2ilType (zip params is) typeexpr))
+	qname <- visitQualIdent qident
+	return (TypeSyn qname Public is texpr)
+visitTypeIDecl _ = internalError "GenFlatCurry: no type interface"
+
+--
+visitConstrIDecl :: ModuleIdent -> [(Ident, Int)] -> CS.ConstrDecl 
+		    -> FlatState ConsDecl
+visitConstrIDecl mid tis (CS.ConstrDecl _ _ ident typeexprs)
+   = do texprs <- mapM visitType (map (fst . cs2ilType tis) typeexprs)
+	qname  <- visitQualIdent (qualifyWith mid ident)
+	return (Cons qname (length typeexprs) Public texprs)
+visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)
+   = visitConstrIDecl mid tis (CS.ConstrDecl pos ids ident [type1,type2])
+
+--
+visitOpIDecl :: CS.IDecl -> FlatState OpDecl
+visitOpIDecl (CS.IInfixDecl _ fixity prec qident)
+   = do let fix = case fixity of
+	            CS.InfixL -> InfixlOp
+		    CS.InfixR -> InfixrOp
+		    _         -> InfixOp
+        qname <- visitQualIdent qident
+	return (Op qname fix prec)
+
+
+-------------------------------------------------------------------------------
+
+--
+visitModuleIdent :: ModuleIdent -> FlatState String
+visitModuleIdent mident = return (Id.moduleName mident)
+
+--
+visitQualIdent :: QualIdent -> FlatState QName
+visitQualIdent qident
+   = do mid <- moduleId
+	let (mmod, ident) = splitQualIdent qident
+	    mod | elem ident [listId, consId, nilId, unitId] || isTupleId ident
+		  = Id.moduleName preludeMIdent
+		| otherwise
+		  = maybe (Id.moduleName mid) Id.moduleName mmod
+	return (curry mkQName mod $ name ident)
+
+--
+visitExternalName :: String -> FlatState String
+visitExternalName name 
+   = moduleId >>= (\mid -> return ((Id.moduleName mid) ++ "." ++ name))
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+--
+getVisibility :: Bool -> QualIdent -> FlatState Visibility
+getVisibility isConstr qident
+   = do public <- isPublic isConstr qident
+	if public then return Public else return Private
+
+
+--
+getExportedImports :: FlatState [CS.IDecl]
+getExportedImports
+   = do mid  <- moduleId
+	exps <- exports
+	genExportedIDecls (envToList (getExpImports mid emptyEnv exps))
+
+--
+getExpImports :: ModuleIdent -> Env ModuleIdent [CS.Export] -> [CS.Export]
+		 -> Env ModuleIdent [CS.Export]
+getExpImports mident expenv [] = expenv
+getExpImports mident expenv ((CS.Export qident):exps)
+   = getExpImports mident 
+	           (bindExpImport mident qident (CS.Export qident) expenv) 
+		   exps
+getExpImports mident expenv ((CS.ExportTypeWith qident idents):exps)
+   = getExpImports mident 
+		   (bindExpImport mident 
+		                  qident 
+		                  (CS.ExportTypeWith qident idents) 
+		                  expenv)
+		   exps
+getExpImports mident expenv ((CS.ExportTypeAll qident):exps)
+   = getExpImports mident 
+	 	   (bindExpImport mident qident (CS.ExportTypeAll qident) expenv) 
+		   exps
+getExpImports mident expenv ((CS.ExportModule mident'):exps)
+   = getExpImports mident (bindEnv mident' [] expenv) exps
+
+--
+bindExpImport :: ModuleIdent -> QualIdent -> CS.Export 
+	         -> Env ModuleIdent [CS.Export] -> Env ModuleIdent [CS.Export]
+bindExpImport mident qident export expenv
+   | isJust (localIdent mident qident)
+     = expenv
+   | otherwise
+     = let (mmod, _) = splitQualIdent qident
+	   mod       = fromJust mmod
+       in  maybe (bindEnv mod [export] expenv)
+	         (\es -> bindEnv mod (export:es) expenv) 
+		 (lookupEnv mod expenv)
+
+--
+genExportedIDecls :: [(ModuleIdent,[CS.Export])] -> FlatState [CS.IDecl]
+genExportedIDecls mes = genExpIDecls [] mes
+
+--
+genExpIDecls :: [CS.IDecl] -> [(ModuleIdent,[CS.Export])] -> FlatState [CS.IDecl]
+genExpIDecls idecls [] = return idecls
+genExpIDecls idecls ((mid,exps):mes)
+   = do intf_ <- lookupModuleIntf mid
+	let idecls' = maybe idecls (p_genExpIDecls mid idecls exps) intf_
+	genExpIDecls idecls' mes
+ where
+   p_genExpIDecls mid idecls exps intf
+      | null exps = (map (qualifyIDecl mid) intf) ++ idecls
+      | otherwise = (filter (isExportedIDecl exps) 
+		            (map (qualifyIDecl mid) intf))
+		    ++ idecls
+
+-- 
+isExportedIDecl :: [CS.Export] -> CS.IDecl -> Bool
+isExportedIDecl exports (CS.IInfixDecl _ _ _ qident)
+   = isExportedQualIdent qident exports
+isExportedIDecl exports (CS.IDataDecl _ qident _ _)
+   = isExportedQualIdent qident exports
+isExportedIDecl exports (CS.ITypeDecl _ qident _ _)
+   = isExportedQualIdent qident exports
+isExportedIDecl exports (CS.IFunctionDecl _ qident _ _)
+   = isExportedQualIdent qident exports
+isExportedIDecl exports _
+   = False
+
+--
+isExportedQualIdent :: QualIdent -> [CS.Export] -> Bool
+isExportedQualIdent qident [] = False
+isExportedQualIdent qident ((CS.Export qident'):exps)
+   = qident == qident' || isExportedQualIdent qident exps
+isExportedQualIdent qident ((CS.ExportTypeWith qident' idents):exps)
+   = qident == qident' || isExportedQualIdent qident exps
+isExportedQualIdent qident ((CS.ExportTypeAll qident'):exps)
+   = qident == qident' || isExportedQualIdent qident exps
+isExportedQualIdent qident ((CS.ExportModule _):exps)
+   = isExportedQualIdent qident exps
+
+--
+qualifyIDecl :: ModuleIdent -> CS.IDecl -> CS.IDecl
+qualifyIDecl mident (CS.IInfixDecl pos fix prec qident)
+   = (CS.IInfixDecl pos fix prec (qualQualify mident qident))
+qualifyIDecl mident (CS.IDataDecl pos qident idents cdecls)
+   = (CS.IDataDecl pos (qualQualify mident qident) idents cdecls)
+qualifyIDecl mident (CS.INewtypeDecl pos qident idents ncdecl)
+   = (CS.INewtypeDecl pos (qualQualify mident qident) idents ncdecl)
+qualifyIDecl mident (CS.ITypeDecl pos qident idents texpr)
+   = (CS.ITypeDecl pos (qualQualify mident qident) idents texpr)
+qualifyIDecl mident (CS.IFunctionDecl pos qident arity texpr)
+   = (CS.IFunctionDecl pos (qualQualify mident qident) arity texpr)
+qualifyIDecl _ idecl = idecl
+
+
+--
+typeArity :: IL.Type -> Int
+typeArity (IL.TypeArrow _ t)       = 1 + (typeArity t)
+typeArity (IL.TypeConstructor _ _) = 0
+typeArity (IL.TypeVariable _)      = 0
+
+
+-------------------------------------------------------------------------------
+
+--
+genFlatApplication :: IL.Expression -> FlatState Expr
+genFlatApplication applicexpr
+   = genFlatApplic [] applicexpr
+ where
+   genFlatApplic args expression 
+      = case expression of
+	  (IL.Apply expr1 expr2)    
+	      -> genFlatApplic (expr2:args) expr1
+	  (IL.Function qident _)
+	      -> do arity_ <- lookupIdArity qident
+		    maybe (internalError (funcArity qident))
+			  (\arity -> genFuncCall qident arity args)
+			  arity_
+	  (IL.Constructor qident _)
+	      -> do arity_ <- lookupIdArity qident
+		    maybe (internalError (consArity qident))
+			  (\arity -> genConsCall qident arity args)
+			  arity_
+	  _   -> do expr <- visitExpression expression
+		    genApplicComb expr args
+
+--
+genFuncCall :: QualIdent -> Int -> [IL.Expression] -> FlatState Expr
+genFuncCall qident arity args
+   | arity > cnt 
+     = genComb qident args (FuncPartCall (arity - cnt))
+   | arity < cnt 
+     = do let (funcargs, applicargs) = splitAt arity args
+	  funccall <- genComb qident funcargs FuncCall
+	  genApplicComb funccall applicargs
+   | otherwise   
+     = genComb qident args FuncCall
+ where cnt = length args
+
+--
+genConsCall :: QualIdent -> Int -> [IL.Expression] -> FlatState Expr
+genConsCall qident arity args
+   | arity > cnt 
+     = genComb qident args (ConsPartCall (arity - cnt))
+   | arity < cnt
+     = do let (funcargs, applicargs) = splitAt arity args
+	  conscall <- genComb qident funcargs ConsCall
+	  genApplicComb conscall applicargs
+   | otherwise 
+     = genComb qident args ConsCall 
+ where cnt = length args
+
+--
+genComb :: QualIdent -> [IL.Expression] -> CombType -> FlatState Expr
+genComb qident args combtype
+   = do exprs <- mapM visitExpression args
+	qname <- visitQualIdent qident
+	return (Comb combtype qname exprs)
+	 
+--
+genApplicComb :: Expr -> [IL.Expression] -> FlatState Expr
+genApplicComb expr [] = return expr
+genApplicComb expr (e1:es)
+   = do expr1 <- visitExpression e1
+	qname <- visitQualIdent qidApply
+	genApplicComb (Comb FuncCall qname [expr, expr1]) es
+ where
+ qidApply = qualifyWith preludeMIdent (mkIdent "apply")
+
+
+--
+genOpDecls :: FlatState [OpDecl]
+genOpDecls = fixities >>= (\fix -> mapM genOpDecl fix)
+
+--
+genOpDecl :: CS.IDecl -> FlatState OpDecl
+genOpDecl (CS.IInfixDecl _ fixity prec qident)
+   = do qname <- visitQualIdent qident
+	return (Op qname (p_genOpFixity fixity) prec)
+ where
+   p_genOpFixity CS.InfixL = InfixlOp
+   p_genOpFixity CS.InfixR = InfixrOp
+   p_genOpFixity CS.Infix  = InfixOp
+genOpDecl _ = internalError "GenFlatCurry: no infix interface"
+
+
+-- The intermediate language (IL) does not represent type synonyms
+-- (and also no record declarations). For this reason an interface
+-- representation of all type synonyms is generated (see "CurryEnv")
+-- from the abstract syntax representation of the Curry program.
+-- The function 'typeSynonyms' returns this list of type synonyms.
+genTypeSynonyms ::  FlatState [TypeDecl]
+genTypeSynonyms = typeSynonyms >>= mapM genTypeSynonym
+
+--
+genTypeSynonym :: CS.IDecl -> FlatState TypeDecl
+genTypeSynonym (CS.ITypeDecl _ qident params typeexpr)
+   = do let is = [0 .. (length params) - 1]
+        (tyEnv,tcEnv) <- environments
+	let typeexpr' = elimRecordTypes tyEnv tcEnv typeexpr
+	texpr <- visitType (fst (cs2ilType (zip params is) typeexpr'))
+	qname <- visitQualIdent qident
+	vis   <- getVisibility False qident
+	return (TypeSyn qname vis is texpr)
+genTypeSynonym _ = internalError "GenFlatCurry: no type synonym interface"
+
+
+-- In order to provide an interface for record declarations, 'genRecordTypes'
+-- generates dummy data declarations representing records together
+-- with their typed labels. For the record declaration
+--
+--      type Rec = {l_1 :: t_1,..., l_n :: t_n}
+--
+-- the following data declaration will be generated:
+--
+--      data Rec' = l_1' t_1 | ... | l_n' :: t_n
+--
+-- Rec' and l_i' are unique idenfifiers which encode the original names
+-- Rec and l_i.
+-- When reading an interface file containing such declarations, it is
+-- now possible to reconstruct the original record declaration. Since
+-- usual FlatCurry code is used, these declaration should not have any
+-- effects on the behaviour of the Curry program. But to ensure correctness,
+-- these dummies should be generated for the interface file as well as for
+-- the corresponding FlatCurry file.
+genRecordTypes :: FlatState [TypeDecl]
+genRecordTypes = records >>= mapM genRecordType
+
+--
+genRecordType :: CS.IDecl -> FlatState TypeDecl
+genRecordType (CS.ITypeDecl _ qident params (CS.RecordType fields _))
+   = do let is = [0 .. (length params) - 1]
+	    (mod,ident) = splitQualIdent qident
+	qname <- visitQualIdent ((maybe qualify qualifyWith mod) 
+				 (recordExtId ident))
+	labels <- mapM (genRecordLabel mod (zip params is)) fields
+	return (Type qname Public is labels)
+
+--
+genRecordLabel :: Maybe ModuleIdent -> [(Ident,Int)] -> ([Ident],CS.TypeExpr) 
+	       -> FlatState ConsDecl
+genRecordLabel mod vis ([ident],typeexpr)
+   = do (tyEnv,tcEnv) <- environments
+	let typeexpr' = elimRecordTypes tyEnv tcEnv typeexpr
+        texpr <- visitType (fst (cs2ilType vis typeexpr'))
+	qname <- visitQualIdent ((maybe qualify qualifyWith mod) 
+				 (labelExtId ident))
+	return (Cons qname 1 Public [texpr])
+
+
+-------------------------------------------------------------------------------
+
+-- FlatCurry provides no possibility of representing record types like
+-- {l_1::t_1, l_2::t_2, ..., l_n::t_n}. So they have to be transformed to
+-- to the corresponding type constructors which are defined in the record 
+-- declarations. 
+-- Unlike data declarations or function type annotations, type synonyms and
+-- record declarations are not generated from the intermediate language.
+-- So the transformation has only to be performed in these cases.
+elimRecordTypes :: ValueEnv -> TCEnv -> CS.TypeExpr -> CS.TypeExpr
+elimRecordTypes tyEnv tcEnv (CS.ConstructorType qid typeexprs)
+   = CS.ConstructorType qid (map (elimRecordTypes tyEnv tcEnv) typeexprs)
+elimRecordTypes tyEnv tcEnv (CS.VariableType id)
+   = CS.VariableType id
+elimRecordTypes tyEnv tcEnv (CS.TupleType typeexprs)
+   = CS.TupleType (map (elimRecordTypes tyEnv tcEnv) typeexprs)
+elimRecordTypes tyEnv tcEnv (CS.ListType typeexpr)
+   = CS.ListType (elimRecordTypes tyEnv tcEnv typeexpr)
+elimRecordTypes tyEnv tcEnv (CS.ArrowType typeexpr1 typeexpr2)
+   = CS.ArrowType (elimRecordTypes tyEnv tcEnv typeexpr1)
+                  (elimRecordTypes tyEnv tcEnv typeexpr2)
+elimRecordTypes tyEnv tcEnv (CS.RecordType fss _)
+   = let fs = flattenRecordTypeFields fss
+     in  case (lookupValue (fst (head fs)) tyEnv) of
+  	   [Label _ record _] ->
+	     case (qualLookupTC record tcEnv) of
+	       [AliasType _ n (TypeRecord fs' _)] ->
+	         let ms = foldl (matchTypeVars fs) zeroFM fs'
+		     types = map (\i -> maybe 
+			 	          (CS.VariableType 
+					     (mkIdent ("#tvar" ++ show i)))
+				          (elimRecordTypes tyEnv tcEnv)
+				          (lookupFM i ms))
+			         [0 .. n-1]
+	         in  CS.ConstructorType record types
+	       _ -> internalError ("GenFlatCurry.elimRecordTypes: "
+		 		   ++ "no record type")
+	   _ -> internalError ("GenFlatCurry.elimRecordTypes: "
+			       ++ "no label")
+
+matchTypeVars :: [(Ident,CS.TypeExpr)] -> FM Int CS.TypeExpr
+	      -> (Ident, Type) -> FM Int CS.TypeExpr
+matchTypeVars fs ms (l,ty)
+   = maybe ms (match ms ty) (lookup l fs)
+  where
+  match ms (TypeVariable i) typeexpr = addToFM i typeexpr ms
+  match ms (TypeConstructor _ tys) (CS.ConstructorType _ typeexprs)
+     = matchList ms tys typeexprs
+  match ms (TypeConstructor _ tys) (CS.ListType typeexpr)
+     = matchList ms tys [typeexpr]
+  match ms (TypeConstructor _ tys) (CS.TupleType typeexprs)
+     = matchList ms tys typeexprs
+  match ms (TypeArrow ty1 ty2) (CS.ArrowType typeexpr1 typeexpr2)
+     = matchList ms [ty1,ty2] [typeexpr1,typeexpr2]
+  match ms (TypeRecord fs' _) (CS.RecordType fss _)
+     = foldl (matchTypeVars (flattenRecordTypeFields fss)) ms fs'
+  match ms ty typeexpr
+     = internalError ("GenFlatCurry.matchTypeVars: "
+		      ++ show ty ++ "\n" ++ show typeexpr)
+
+  matchList ms tys typeexprs
+     = foldl (\ms' (ty,typeexpr) -> match ms' ty typeexpr)
+             ms
+	     (zip tys typeexprs)
+
+
+flattenRecordTypeFields :: [([Ident],CS.TypeExpr)] -> [(Ident,CS.TypeExpr)]
+flattenRecordTypeFields fss
+   = concatMap (\ (labels, typeexpr)
+		-> map (\label -> (label,typeexpr)) labels)
+               fss
+
+-------------------------------------------------------------------------------
+
+--
+checkOverlapping :: Expr -> Expr -> FlatState ()
+checkOverlapping expr1 expr2
+   = do opts <- compilerOpts
+	unless (noOverlapWarn opts)
+	       (checkOverlap expr1 expr2)
+ where
+ checkOverlap (Case _ _ _ _) _ 
+    = do qid <- functionId
+	 genWarning (overlappingRules qid)
+ checkOverlap _ (Case _ _ _ _)
+    = do qid <- functionId
+	 genWarning (overlappingRules qid)
+ checkOverlap _ _ = return ()
+
+
+-------------------------------------------------------------------------------
+
+-- 
+cs2ilType :: [(Ident,Int)] -> CS.TypeExpr -> (IL.Type, [(Ident,Int)])
+cs2ilType ids (CS.ConstructorType qident typeexprs)
+   = let (ilTypeexprs, ids') = emap cs2ilType ids typeexprs
+     in  (IL.TypeConstructor qident ilTypeexprs, ids')
+cs2ilType ids (CS.VariableType ident)
+   = let mid        = lookup ident ids
+	 nid        | null ids  = 0
+		    | otherwise = 1 + snd (head ids)
+	 (id, ids') | isJust mid = (fromJust mid, ids)
+		    | otherwise  = (nid, (ident, nid):ids)
+     in  (IL.TypeVariable id, ids')
+cs2ilType ids (CS.ArrowType type1 type2)
+   = let (ilType1, ids')  = cs2ilType ids type1
+	 (ilType2, ids'') = cs2ilType ids' type2
+     in  (IL.TypeArrow ilType1 ilType2, ids'')
+cs2ilType ids (CS.ListType typeexpr)
+   = let (ilTypeexpr, ids') = cs2ilType ids typeexpr
+     in  (IL.TypeConstructor (qualify listId) [ilTypeexpr], ids')
+cs2ilType ids (CS.TupleType typeexprs)
+   = case typeexprs of
+       []  -> (IL.TypeConstructor qUnitId [], ids)
+       [t] -> cs2ilType ids t
+       _   -> let (ilTypeexprs, ids') = emap cs2ilType ids typeexprs
+		  tuplen = length ilTypeexprs
+	      in  (IL.TypeConstructor (qTupleId tuplen) ilTypeexprs,
+		   ids')
+cs2ilType _ typeexpr = internalError ("cs2ilType: " ++ show typeexpr)
+
+
+-------------------------------------------------------------------------------
+-- Messages for internal errors and warnings
+
+funcArity qid = "GenFlatCurry: missing arity for function \"" 
+		++ show qid ++ "\""
+
+consArity qid = "GenFlatCurry: missing arity for constructor \""
+		++ show qid ++ "\""
+
+missingVarIndex id = "GenFlatCurry: missing index for \"" ++ show id ++ "\""
+
+
+overlappingRules qid = (OverlapRules,
+                           "function \""
+		        ++ show qid 
+		        ++ "\" is non-deterministic due to non-trivial "
+		        ++ "overlapping rules")
+
+
+-------------------------------------------------------------------------------
+prelude_types :: [TypeDecl]
+prelude_types = [(Type (preludeName "()") Public [] 
+		  [(Cons (preludeName "()") 0 Public [])]),
+		 (Type (preludeName "[]") Public [0] 
+		  [(Cons (preludeName "[]") 0 Public []),
+		   (Cons (preludeName ":") 2 Public 
+		    [(TVar 0),(TCons (preludeName "[]") [(TVar 0)])])])]
+                ++ map mkTupleType [2..15]
+    where
+      preludeName = curry mkQName "Prelude"
+      mkTupleType n = let last  = n-1
+                          name = preludeName("(" ++ replicate last ',' ++ ")")
+                          idxs  = [0..last]
+                          vars  = map TVar idxs
+                      in Type name Public idxs [Cons name n Public vars]
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+--
+isDataDecl :: IL.Decl -> Bool
+isDataDecl (IL.DataDecl _ _ _) = True
+isDataDecl _                = False
+
+--
+isFuncDecl :: IL.Decl -> Bool
+isFuncDecl (IL.FunctionDecl _ _ _ _) = True
+isFuncDecl (IL.ExternalDecl _ _ _ _) = True
+isFuncDecl _                         = False
+
+--
+isPublicDataDecl :: IL.Decl -> FlatState Bool
+isPublicDataDecl (IL.DataDecl qident _ _ ) = isPublic False qident
+isPublicDataDecl _                         = return False
+
+--
+isPublicFuncDecl :: IL.Decl -> FlatState Bool
+isPublicFuncDecl (IL.FunctionDecl qident _ _ _) = isPublic False qident
+isPublicFuncDecl (IL.ExternalDecl qident _ _ _) = isPublic False qident
+isPublicFuncDecl _                              = return False
+
+--
+isTypeIDecl :: CS.IDecl -> Bool
+isTypeIDecl (CS.IDataDecl _ _ _ _) = True
+isTypeIDecl (CS.ITypeDecl _ _ _ _) = True
+isTypeIDecl _                      = False
+
+--
+isRecordIDecl :: CS.IDecl -> Bool
+isRecordIDecl (CS.ITypeDecl _ _ _ (CS.RecordType (_:_) _)) = True
+isRecordIDecl _                                            = False
+
+--
+isFuncIDecl :: CS.IDecl -> Bool
+isFuncIDecl (CS.IFunctionDecl _ _ _ _) = True
+isFuncIDecl _                          = False
+
+--
+isOpIDecl :: CS.IDecl -> Bool
+isOpIDecl (CS.IInfixDecl _ _ _ _) = True
+isOpIDecl _                       = False 
+
+
+--
+bindingIdent :: IL.Binding -> Ident
+bindingIdent (IL.Binding ident _) = ident
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+int2num :: Int -> Int
+int2num = abs
+
+
+emap :: (e -> a -> (b,e)) -> e -> [a] -> ([b], e)
+emap _ env []     = ([], env)
+emap f env (x:xs) = let (x',env')    = f env x
+			(xs', env'') = emap f env' xs
+		    in  ((x':xs'), env'')
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+-- Data type for representing an environment which contains information needed
+-- for generating FlatCurry code.
+data FlatEnv = FlatEnv{ moduleIdE     :: ModuleIdent,
+			  functionIdE   :: QualIdent,
+			  compilerOptsE :: Options,
+			  moduleEnvE    :: ModuleEnv,
+			  arityEnvE     :: ArityEnv,
+			  typeEnvE      :: ValueEnv,
+			  tConsEnvE     :: TCEnv,
+			  publicEnvE    :: Env Ident IdentExport,
+			  fixitiesE     :: [CS.IDecl],
+			  typeSynonymsE :: [CS.IDecl],
+			  importsE      :: [CS.IDecl],
+			  exportsE      :: [CS.Export],
+			  interfaceE    :: [CS.IDecl],
+			  varIndexE     :: Int,
+			  varIdsE       :: ScopeEnv Ident VarIndex,
+			  tvarIndexE    :: Int,
+			  tvarIdsE      :: ScopeEnv Ident TVarIndex,
+			  messagesE     :: [Message],
+			  genInterfaceE :: Bool
+			}
+
+data IdentExport = NotConstr       -- function, type-constructor
+                 | OnlyConstr      -- constructor
+                 | NotOnlyConstr   -- constructor, function, type-constructor
+
+
+
+-- The environment 'FlatEnv' is embedded in the monadic representation
+-- 'FlatState' which allows the usage of 'do' expressions.
+type FlatState a = State FlatEnv a
+
+
+-- Runs a 'FlatState' action and returns the result
+run :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv 
+    -> Bool -> FlatState a -> (a, [Message])
+run opts cEnv mEnv tyEnv tcEnv aEnv genIntf f
+   = (result, messagesE env)
+ where
+ (result, env) = runState f env0
+ env0 = FlatEnv{ moduleIdE     = CurryEnv.moduleId cEnv,
+		 functionIdE   = qualify (mkIdent ""),
+		 compilerOptsE = opts,
+		 moduleEnvE    = mEnv,
+		 arityEnvE     = aEnv,
+		 typeEnvE      = tyEnv,
+		 tConsEnvE     = tcEnv,
+		 publicEnvE    = genPubEnv (CurryEnv.moduleId cEnv)
+		                 (CurryEnv.interface cEnv),
+		 fixitiesE     = CurryEnv.infixDecls cEnv,
+		 typeSynonymsE = CurryEnv.typeSynonyms cEnv,
+		 importsE      = CurryEnv.imports cEnv,
+		 exportsE      = CurryEnv.exports cEnv,
+		 interfaceE    = CurryEnv.interface cEnv,
+		 varIndexE     = 0,
+		 varIdsE       = ScopeEnv.new,
+		 tvarIndexE    = 0,
+		 tvarIdsE      = ScopeEnv.new,
+		 messagesE      = [],
+		 genInterfaceE = genIntf
+	       }
+
+
+--
+moduleId :: FlatState ModuleIdent
+moduleId = gets moduleIdE
+
+--
+functionId :: FlatState QualIdent
+functionId = gets functionIdE
+
+--
+setFunctionId :: QualIdent -> FlatState ()
+setFunctionId qid = modify (\env -> env{ functionIdE = qid })
+
+--
+compilerOpts :: FlatState Options
+compilerOpts = gets compilerOptsE
+
+--
+exports :: FlatState [CS.Export]
+exports = gets exportsE
+
+--
+imports :: FlatState [CS.IDecl]
+imports = gets importsE
+
+--
+records :: FlatState [CS.IDecl]
+records = gets (filter isRecordIDecl . interfaceE)
+
+--
+fixities :: FlatState [CS.IDecl]
+fixities = gets fixitiesE
+
+--
+typeSynonyms :: FlatState [CS.IDecl]
+typeSynonyms = gets typeSynonymsE
+
+--
+environments :: FlatState (ValueEnv,TCEnv)
+environments = gets (\env -> (typeEnvE env, tConsEnvE env))
+
+--
+isPublic :: Bool -> QualIdent -> FlatState Bool
+isPublic isConstr qid = gets (\env -> maybe False isP
+                                      (lookupEnv (unqualify qid) 
+                                       (publicEnvE env)))
+  where
+    isP NotConstr = not isConstr
+    isP OnlyConstr = isConstr
+    isP NotOnlyConstr = True
+
+--
+lookupModuleIntf :: ModuleIdent -> FlatState (Maybe [CS.IDecl])
+lookupModuleIntf mid
+   = gets (lookupEnv mid . moduleEnvE)
+
+--
+lookupIdArity :: QualIdent -> FlatState (Maybe Int)
+lookupIdArity qid
+   = gets (lookupA qid . arityEnvE)
+ where
+ lookupA qid aEnv = case (qualLookupArity qid aEnv) of
+		      [ArityInfo _ a]
+		         -> Just a
+		      [] -> case (lookupArity (unqualify qid) aEnv) of
+			      [ArityInfo _ a] -> Just a
+			      _               -> Nothing
+		      _  -> Nothing
+
+-- Generates a new index for a variable
+newVarIndex :: Ident -> FlatState VarIndex
+newVarIndex id
+   = do idx0 <- gets varIndexE
+        ty <- getTypeOf id
+        let idx = idx0 + 1
+            vid = VarIndex ty idx
+        vids <- gets varIdsE
+        modify (\env -> env{ varIndexE = idx,
+			     varIdsE   = ScopeEnv.insert id vid vids
+			   })
+        return vid
+
+--
+lookupVarIndex :: Ident -> FlatState VarIndex
+lookupVarIndex id
+   = do index_ <- gets (ScopeEnv.lookup id . varIdsE)
+        maybe (internalError (missingVarIndex id)) return index_
+
+--
+clearVarIndices :: FlatState ()
+clearVarIndices = modify (\env -> env { varIndexE = 0,
+				        varIdsE = ScopeEnv.new 
+				      })
+
+-- Generates a new index for a type variable
+newTVarIndex :: Ident -> FlatState Int
+newTVarIndex id
+   = do idx0 <- gets tvarIndexE
+        let idx = 1 + idx0
+        vids <- gets tvarIdsE
+        modify (\env -> env{ tvarIndexE = idx,
+			     tvarIdsE   = ScopeEnv.insert id idx vids
+			   })
+        return idx
+
+-- Looks up the index of an existing type variable or generates a new index,
+-- if the type variable doesn't exist
+getTVarIndex :: Ident -> FlatState Int
+getTVarIndex id
+   = do idx0 <- gets tvarIndexE
+        let idx = idx0 + 1
+        vids <- gets tvarIdsE    
+        maybe (do modify (\env -> env{ tvarIndexE = idx,
+		                       tvarIdsE   = ScopeEnv.insert id idx vids })
+                  return idx)
+              return
+              (ScopeEnv.lookup id vids)
+
+--
+lookupTVarIndex :: Ident -> FlatState (Maybe Int)
+lookupTVarIndex id
+   = gets (ScopeEnv.lookup id . tvarIdsE)
+
+--
+clearTVarIndices :: FlatState ()
+clearTVarIndices = modify (\env -> env { tvarIndexE = 0,
+					 tvarIdsE = ScopeEnv.new 
+				       })
+
+--
+genWarning :: (WarningType,String) -> FlatState ()
+genWarning (warnType,msg)
+   = modify (\env -> env{ messagesE = warnMsg:(messagesE env) })
+    where warnMsg = message_ (Warning warnType) msg
+
+--
+genInterface :: FlatState Bool
+genInterface = gets genInterfaceE
+
+--
+beginScope :: FlatState ()
+beginScope = modify
+	       (\env -> env { varIdsE  = ScopeEnv.beginScope (varIdsE env),
+			      tvarIdsE = ScopeEnv.beginScope (tvarIdsE env)
+			    })
+
+--
+endScope :: FlatState ()
+endScope = modify
+	     (\env -> env { varIdsE  = ScopeEnv.endScope (varIdsE env),
+			    tvarIdsE = ScopeEnv.endScope (tvarIdsE env)
+			  })
+
+--
+whenFlatCurry :: FlatState a -> FlatState a -> FlatState a
+whenFlatCurry genFlat genIntf 
+   = genInterface >>= (\intf -> if intf then genIntf else genFlat)
+
+
+-------------------------------------------------------------------------------
+
+-- Generates an evironment containing all public identifiers from the module
+-- Note: Currently the record functions (selection and update) for all public 
+-- record labels are inserted into the environment, though they are not
+-- explicitly declared in the export specifications.
+genPubEnv :: ModuleIdent -> [CS.IDecl] -> Env Ident IdentExport
+genPubEnv mid idecls = foldl (bindEnvIDecl mid) emptyEnv idecls
+
+bindIdentExport :: Ident -> Bool -> Env Ident IdentExport -> Env Ident IdentExport
+bindIdentExport id isConstr env =
+    maybe (bindEnv id (if isConstr then OnlyConstr else NotConstr) env)
+          (\ ie -> bindEnv id (updateIdentExport ie isConstr) env)
+          (lookupEnv id env)
+  where
+    updateIdentExport OnlyConstr True  = OnlyConstr
+    updateIdentExport OnlyConstr False = NotOnlyConstr
+    updateIdentExport NotConstr True   = NotOnlyConstr
+    updateIdentExport NotConstr False  = NotConstr
+    updateIdentExport NotOnlyConstr _  = NotOnlyConstr
+
+
+--
+bindEnvIDecl :: ModuleIdent -> Env Ident IdentExport -> CS.IDecl -> Env Ident IdentExport
+bindEnvIDecl mid env (CS.IDataDecl _ qid _ mcdecls)
+   = maybe env 
+           (\id -> foldl bindEnvConstrDecl
+	                 (bindIdentExport id False env)
+	                 (catMaybes mcdecls))
+	   (localIdent mid qid)
+bindEnvIDecl mid env (CS.INewtypeDecl _ qid _ ncdecl)
+   = maybe env 
+           (\id -> bindEnvNewConstrDecl (bindIdentExport id False env) ncdecl)
+	   (localIdent mid qid)
+bindEnvIDecl mid env (CS.ITypeDecl _ qid _ texpr)
+   = maybe env (\id -> bindEnvITypeDecl env id texpr) (localIdent mid qid)
+bindEnvIDecl mid env (CS.IFunctionDecl _ qid _ _)
+   = maybe env (\id -> bindIdentExport id False env) (localIdent mid qid)
+bindEnvIDecl _ env _ = env
+
+--
+bindEnvITypeDecl :: Env Ident IdentExport -> Ident -> CS.TypeExpr
+		    -> Env Ident IdentExport
+bindEnvITypeDecl env id (CS.RecordType fs _)
+   = bindIdentExport id False (foldl (bindEnvRecordLabel id) env fs)
+bindEnvITypeDecl env id texpr
+   = bindIdentExport id False env
+
+--
+bindEnvConstrDecl :: Env Ident IdentExport -> CS.ConstrDecl -> Env Ident IdentExport
+bindEnvConstrDecl env (CS.ConstrDecl _ _ id _)  = bindIdentExport id True env
+bindEnvConstrDecl env (CS.ConOpDecl _ _ _ id _) = bindIdentExport id True env
+
+--
+bindEnvNewConstrDecl :: Env Ident IdentExport -> CS.NewConstrDecl -> Env Ident IdentExport
+bindEnvNewConstrDecl env (CS.NewConstrDecl _ _ id _) = bindIdentExport id False env
+
+--
+bindEnvRecordLabel :: Ident -> Env Ident IdentExport -> ([Ident],CS.TypeExpr) 
+		   -> Env Ident IdentExport
+bindEnvRecordLabel rec env ([lab],_)
+   = bindIdentExport (recSelectorId (qualify rec) lab)
+             False
+	     (bindIdentExport (recUpdateId (qualify rec) lab) False env)
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/GetOpt.hs b/src/GetOpt.hs
new file mode 100644
--- /dev/null
+++ b/src/GetOpt.hs
@@ -0,0 +1,194 @@
+-----------------------------------------------------------------------------------------
+-- A Haskell port of GNU's 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 (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) where
+
+import Data.List(isPrefixOf)
+
+data ArgOrder a                        -- what to do with options following 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 (without "--")
+          (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 sep []     = ""
+         sepBy sep [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 (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 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 (_:_:_)      _        rest     = (errAmbig options optStr,rest)
+         long [NoArg  a  ] []       rest     = (Opt a,rest)
+         long [NoArg  a  ] ('=':xs) rest     = (errNoArg optStr,rest)
+         long [ReqArg f 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 f 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
+-----------------------------------------------------------------------------------------
+-}
diff --git a/src/IL.lhs b/src/IL.lhs
new file mode 100644
--- /dev/null
+++ b/src/IL.lhs
@@ -0,0 +1,108 @@
+% $Id: IL.lhs,v 1.18 2003/10/28 05:43:38 wlux Exp $
+%
+% Copyright (c) 1999-2003 Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{IL.lhs}
+\section{The intermediate language}
+The module \texttt{IL} defines the intermediate language which will be
+compiled into abstract machine code. The intermediate language removes
+a lot of syntactic sugar from the Curry source language.  Top-level
+declarations are restricted to data type and function definitions. A
+newtype definition serves mainly as a hint to the backend that it must
+provide an auxiliary function for partial applications of the
+constructor. \textbf{Newtype constructors must not occur in patterns
+and may be used in expressions only as partial applications.}
+
+Type declarations use a de-Bruijn indexing scheme (starting at 0) for
+type variables. In the type of a function, all type variables are
+numbered in the order of their occurence from left to right, i.e., a
+type \texttt{(Int -> b) -> (a,b) -> c -> (a,c)} is translated into the
+type (using integer numbers to denote the type variables)
+\texttt{(Int -> 0) -> (1,0) -> 2 -> (1,2)}.
+
+Pattern matching in an equation is handled via flexible and rigid
+\texttt{Case} expressions. Overlapping rules are translated with the
+help of \texttt{Or} expressions. The intermediate language has three
+kinds of binding expressions, \texttt{Exist} expressions introduce a
+new logical variable, \texttt{Let} expression support a single
+non-recursive variable binding, and \texttt{Letrec} expressions
+introduce multiple variables with recursive initializer expressions.
+The intermediate language explicitly distinguishes (local) variables
+and (global) functions in expressions.
+
+\em{Note:} this modified version uses haskell type \texttt{Integer}
+instead of \texttt{Int} for representing integer values. This provides
+an unlimited range of integer constants in Curry programs.
+\begin{verbatim}
+
+> module IL where
+> import Ident
+> import Position (SrcRef(..))
+
+> data Module = Module ModuleIdent [ModuleIdent] [Decl] deriving (Eq,Show)
+
+> data Decl = 
+>     DataDecl QualIdent Int [ConstrDecl [Type]]
+>   | NewtypeDecl QualIdent Int (ConstrDecl Type)
+>   | FunctionDecl QualIdent [Ident] Type Expression
+>   | ExternalDecl QualIdent CallConv String Type
+>   deriving (Eq,Show)
+
+> data ConstrDecl a = ConstrDecl QualIdent a deriving (Eq,Show)
+> data CallConv = Primitive | CCall deriving (Eq,Show)
+
+> data Type =
+>     TypeConstructor QualIdent [Type]
+>   | TypeVariable Int
+>   | TypeArrow Type Type
+>   deriving (Eq,Show)
+
+> data Literal = Char SrcRef Char | Int SrcRef Integer | Float SrcRef Double deriving (Eq,Show)
+
+> data ConstrTerm =
+>   -- literal patterns
+>     LiteralPattern Literal
+>   -- constructors
+>   | ConstructorPattern QualIdent [Ident]
+>   -- default
+>   | VariablePattern Ident
+>   deriving (Eq,Show)
+
+> data Expression =
+>   -- literal constants
+>     Literal Literal
+>   -- variables, functions, constructors
+>   | Variable Ident | Function QualIdent Int | Constructor QualIdent Int
+>   -- applications
+>   | Apply Expression Expression
+>   -- case expressions
+>   | Case SrcRef Eval Expression [Alt]
+>   -- non-determinisismic or
+>   | Or Expression Expression
+>   -- binding forms
+>   | Exist Ident Expression
+>   | Let Binding Expression
+>   | Letrec [Binding] Expression
+>   deriving (Eq,Show)
+
+> data Eval = Rigid | Flex deriving (Eq,Show)
+> data Alt = Alt ConstrTerm Expression deriving (Eq,Show)
+> data Binding = Binding Ident Expression deriving (Eq,Show)
+
+\end{verbatim}
+
+> instance SrcRefOf ConstrTerm where
+>   srcRefOf (LiteralPattern l) = srcRefOf l
+>   srcRefOf (ConstructorPattern i _) = srcRefOf i
+>   srcRefOf (VariablePattern i) = srcRefOf i
+
+
+> instance SrcRefOf Literal where
+>   srcRefOf (Char s _)   = s
+>   srcRefOf (Int s _)    = s
+>   srcRefOf (Float s _)  = s  
+
+
diff --git a/src/ILPP.lhs b/src/ILPP.lhs
new file mode 100644
--- /dev/null
+++ b/src/ILPP.lhs
@@ -0,0 +1,166 @@
+% -*- LaTeX -*-
+% $Id: ILPP.lhs,v 1.22 2003/10/28 05:43:43 wlux Exp $
+%
+% Copyright (c) 1999-2003 Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{ILPP.lhs}
+\section{A pretty printer for the intermediate language}
+This module implements just another pretty printer, this time for the
+intermediate language. It was mainly adapted from the Curry pretty
+printer (see sect.~\ref{sec:CurryPP}) which, in turn, is based on Simon
+Marlow's pretty printer for Haskell.
+\begin{verbatim}
+
+> module ILPP(module ILPP, Doc) where
+> import Ident
+> import IL
+> import Pretty
+
+> default(Int,Double)
+
+> dataIndent = 2
+> bodyIndent = 2
+> exprIndent = 2
+> caseIndent = 2
+> altIndent = 2
+
+> ppModule :: Module -> Doc
+> ppModule (Module m is ds) =
+>   vcat (text "module" <+> text (show m) <+> text "where" :
+>         map ppImport is ++ map ppDecl ds)
+
+> ppImport :: ModuleIdent -> Doc
+> ppImport m = text "import" <+> text (show m)
+
+> ppDecl :: Decl -> Doc
+> ppDecl (DataDecl tc n cs) =
+>   sep (text "data" <+> ppTypeLhs tc n :
+>        map (nest dataIndent)
+>            (zipWith (<+>) (equals : repeat (char '|')) (map ppConstr cs)))
+> ppDecl (NewtypeDecl tc n (ConstrDecl c ty)) =
+>   sep [text "newtype" <+> ppTypeLhs tc n <+> equals,
+>        nest dataIndent (ppConstr (ConstrDecl c [ty]))]
+> ppDecl (FunctionDecl f vs ty exp) =
+>   ppTypeSig f ty $$
+>   sep [ppQIdent f <+> hsep (map ppIdent vs) <+> equals,
+>        nest bodyIndent (ppExpr 0 exp)]
+> ppDecl (ExternalDecl f cc ie ty) =
+>   sep [text "external" <+> ppCallConv cc <+> text (show ie),
+>        nest bodyIndent (ppTypeSig f ty)]
+>   where ppCallConv Primitive = text "primitive"
+>         ppCallConv CCall = text "ccall"
+
+> ppTypeLhs :: QualIdent -> Int -> Doc
+> ppTypeLhs tc n = ppQIdent tc <+> hsep (map text (take n typeVars))
+
+> ppConstr :: ConstrDecl [Type] -> Doc
+> ppConstr (ConstrDecl c tys) = ppQIdent c <+> fsep (map (ppType 2) tys)
+
+> ppTypeSig :: QualIdent -> Type -> Doc
+> ppTypeSig f ty = ppQIdent f <+> text "::" <+> ppType 0 ty
+
+> ppType :: Int -> Type -> Doc
+> ppType p (TypeConstructor tc tys)
+>   | isQTupleId tc = parens (fsep (punctuate comma (map (ppType 0) tys)))
+>   | unqualify tc == nilId = brackets (ppType 0 (head tys))
+>   | otherwise =
+>       ppParen (p > 1 && not (null tys))
+>               (ppQIdent tc <+> fsep (map (ppType 2) tys))
+> ppType _ (TypeVariable n)
+>   | n >= 0 = text (typeVars !! n)
+>   | otherwise = text ('_':show (-n))
+> ppType p (TypeArrow ty1 ty2) =
+>   ppParen (p > 0) (fsep (ppArrow (TypeArrow ty1 ty2)))
+>   where ppArrow (TypeArrow ty1 ty2) =
+>           ppType 1 ty1 <+> text "->" : ppArrow ty2
+>         ppArrow ty = [ppType 0 ty]
+
+> ppBinding :: Binding -> Doc
+> ppBinding (Binding v exp) =
+>   sep [ppIdent v <+> equals,nest bodyIndent (ppExpr 0 exp)]
+
+> ppAlt :: Alt -> Doc
+> ppAlt (Alt pat exp) =
+>   sep [ppConstrTerm pat <+> text "->",nest altIndent (ppExpr 0 exp)]
+
+> ppLiteral :: Literal -> Doc
+> ppLiteral (Char _ c) = text (show c)
+> ppLiteral (Int _ i) = integer i
+> ppLiteral (Float _ f) = double f
+
+> ppConstrTerm :: ConstrTerm -> Doc
+> ppConstrTerm (LiteralPattern l) = ppLiteral l
+> ppConstrTerm (ConstructorPattern c [v1,v2])
+>   | isQInfixOp c = ppIdent v1 <+> ppQInfixOp c <+> ppIdent v2
+> ppConstrTerm (ConstructorPattern c vs)
+>   | isQTupleId c = parens (fsep (punctuate comma (map ppIdent vs)))
+>   | otherwise = ppQIdent c <+> fsep (map ppIdent vs)
+> ppConstrTerm (VariablePattern v) = ppIdent v
+
+> ppExpr :: Int -> Expression -> Doc
+> ppExpr p (Literal l) = ppLiteral l
+> ppExpr p (Variable v) = ppIdent v
+> ppExpr p (Function f _) = ppQIdent f
+> ppExpr p (Constructor c _) = ppQIdent c
+> ppExpr p (Apply (Apply (Function f _) e1) e2)
+>   | isQInfixOp f = ppInfixApp p e1 f e2
+> ppExpr p (Apply (Apply (Constructor c _) e1) e2)
+>   | isQInfixOp c = ppInfixApp p e1 c e2
+> ppExpr p (Apply e1 e2) =
+>   ppParen (p > 2) (sep [ppExpr 2 e1,nest exprIndent (ppExpr 3 e2)])
+> ppExpr p (Case _ ev e alts) =
+>   ppParen (p > 0)
+>           (text "case" <+> ppEval ev <+> ppExpr 0 e <+> text "of" $$
+>            nest caseIndent (vcat (map ppAlt alts)))
+>   where ppEval Rigid = text "rigid"
+>         ppEval Flex = text "flex"
+> ppExpr p (Or e1 e2) =
+>   ppParen (p > 0) (sep [ppExpr 0 e1,char '|' <+> ppExpr 0 e2])
+> ppExpr p (Exist v e) =
+>   ppParen (p > 0)
+>           (sep [text "let" <+> ppIdent v <+> text "free" <+> text "in",
+>                 ppExpr 0 e])
+> ppExpr p (Let b e) =
+>   ppParen (p > 0) (sep [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e])
+> ppExpr p (Letrec bs e) =
+>   ppParen (p > 0)
+>           (sep [text "letrec" <+> vcat (map ppBinding bs) <+> text "in",
+>                 ppExpr 0 e])
+
+> ppInfixApp :: Int -> Expression -> QualIdent -> Expression -> Doc
+> ppInfixApp p e1 op e2 =
+>   ppParen (p > 1)
+>           (sep [ppExpr 2 e1 <+> ppQInfixOp op,nest exprIndent (ppExpr 2 e2)])
+
+> ppIdent :: Ident -> Doc
+> ppIdent ident
+>   | isInfixOp ident = parens (ppName ident)
+>   | otherwise = ppName ident
+
+> ppQIdent :: QualIdent -> Doc
+> ppQIdent ident
+>   | isQInfixOp ident = parens (ppQual ident)
+>   | otherwise = ppQual ident
+
+> ppQInfixOp :: QualIdent -> Doc
+> ppQInfixOp op
+>   | isQInfixOp op = ppQual op
+>   | otherwise = char '`' <> ppQual op <> char '`'
+
+> ppName :: Ident -> Doc
+> ppName x = text (name x)
+
+> ppQual :: QualIdent -> Doc
+> ppQual x = text (qualName x)
+
+> typeVars :: [String]
+> typeVars = [mkTypeVar c i | i <- [0..], c <- ['a' .. 'z']]
+>   where mkTypeVar c i = c : if i == 0 then [] else show i
+
+> ppParen :: Bool -> Doc -> Doc
+> ppParen p = if p then parens else id
+
+\end{verbatim}
diff --git a/src/ILScope.hs b/src/ILScope.hs
new file mode 100644
--- /dev/null
+++ b/src/ILScope.hs
@@ -0,0 +1,124 @@
+module ILScope (getModuleScope,
+		insertDeclScope, insertConstrDeclScope,
+		insertCallConvScope, insertTypeScope,
+		insertLiteralScope, insertConstrTermScope,
+		insertExprScope, insertAltScope,
+		insertBindingScope) where
+
+
+import IL
+import Ident
+import OldScopeEnv as ScopeEnv
+
+
+-------------------------------------------------------------------------------
+
+--
+getModuleScope :: Module -> ScopeEnv
+getModuleScope (Module _ _ decls) = foldl insertDecl newScopeEnv decls
+
+
+--
+insertDeclScope :: ScopeEnv -> Decl -> ScopeEnv
+insertDeclScope env (DataDecl _ _ _) = env
+insertDeclScope env (NewtypeDecl _ _ _) = env
+insertDeclScope env (FunctionDecl _ params _ _)
+   = foldr ScopeEnv.insertIdent (ScopeEnv.beginScope env) params
+insertDeclScope env (ExternalDecl _ _ _ _) = env
+
+
+--
+insertConstrDeclScope :: ScopeEnv -> ConstrDecl [Type] -> ScopeEnv
+insertConstrDeclScope env _ = env
+
+
+--
+insertCallConvScope :: ScopeEnv -> CallConv -> ScopeEnv
+insertCallConvScope env _ = env
+
+
+--
+insertTypeScope :: ScopeEnv -> Type -> ScopeEnv
+insertTypeScope env _ = env
+
+
+--
+insertLiteralScope :: ScopeEnv -> Literal -> ScopeEnv
+insertLiteralScope env _ = env
+
+
+--
+insertConstrTermScope :: ScopeEnv -> ConstrTerm -> ScopeEnv
+insertConstrTermScope env _ = env
+
+
+--
+insertExprScope :: ScopeEnv -> Expression -> ScopeEnv
+insertExprScope env (Literal _) = env
+insertExprScope env (Variable _) = env
+insertExprScope env (Function _ _) = env
+insertExprScope env (Constructor _ _) = env
+insertExprScope env (Apply _ _) = env
+insertExprScope env (Case _ _ _ _) = env
+insertExprScope env (Or _ _) = env
+insertExprScope env (Exist ident _)
+   = ScopeEnv.insertIdent ident (ScopeEnv.beginScope env)
+insertExprScope env (Let bind _)
+   = insertBinding (beginScope env) bind
+insertExprScope env (Letrec binds _)
+   = foldl insertBinding (beginScope env) binds
+
+
+--
+insertAltScope :: ScopeEnv -> Alt -> ScopeEnv
+insertAltScope env (Alt cterm _)
+   = insertConstrTerm (ScopeEnv.beginScope env) cterm
+
+
+--
+insertBindingScope :: ScopeEnv -> Binding -> ScopeEnv
+insertBindingScope env _ = env
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+--
+insertDecl :: ScopeEnv -> Decl -> ScopeEnv
+insertDecl env (DataDecl qident _ cdecls)
+   = foldl insertConstrDecl
+	 (ScopeEnv.insertIdent (unqualify qident) env)
+	 cdecls
+
+insertDecl env (NewtypeDecl qident _ cdecl)
+   = insertConstrDecl (ScopeEnv.insertIdent (unqualify qident) env) cdecl
+
+insertDecl env (FunctionDecl qident _ _ _)
+   = ScopeEnv.insertIdent (unqualify qident) env
+
+insertDecl env (ExternalDecl qident _ _ _)
+   = ScopeEnv.insertIdent (unqualify qident) env
+
+
+--
+insertConstrDecl :: ScopeEnv -> ConstrDecl a -> ScopeEnv
+insertConstrDecl env (ConstrDecl qident _)
+   = ScopeEnv.insertIdent (unqualify qident) env
+
+
+--
+insertConstrTerm :: ScopeEnv -> ConstrTerm -> ScopeEnv
+insertConstrTerm env (LiteralPattern _) = env
+insertConstrTerm env (ConstructorPattern _ params)
+   = foldr ScopeEnv.insertIdent env params
+insertConstrTerm env (VariablePattern ident)
+   = ScopeEnv.insertIdent ident env
+
+
+--
+insertBinding :: ScopeEnv -> Binding -> ScopeEnv
+insertBinding env (Binding ident _) = ScopeEnv.insertIdent ident env
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/ILTrans.lhs b/src/ILTrans.lhs
new file mode 100644
--- /dev/null
+++ b/src/ILTrans.lhs
@@ -0,0 +1,594 @@
+
+% $Id: ILTrans.lhs,v 1.86 2004/02/13 19:23:58 wlux Exp $
+%
+% Copyright (c) 1999-2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{ILTrans.lhs}
+\section{Translating Curry into the Intermediate Language}
+After desugaring and lifting have been performed, the source code is
+translated into the intermediate language. Besides translating from
+source terms and expressions into intermediate language terms and
+expressions this phase in particular has to implement the pattern
+matching algorithm for equations and case expressions.
+
+Because of name conflicts between the source and intermediate language
+data structures, we can use only a qualified import for the
+\texttt{IL} module.
+\begin{verbatim}
+
+> module ILTrans(ilTrans,ilTransIntf) where
+
+> import Data.Maybe
+> import Data.List
+
+> import Base
+> import qualified IL
+> import Utils
+> import Env
+> import Set
+> import Map
+
+
+
+\end{verbatim}
+\paragraph{Modules}
+At the top-level, the compiler has to translate data type, newtype,
+function, and external declarations. When translating a data type or
+newtype declaration, we ignore the types in the declaration and lookup
+the types of the constructors in the type environment instead because
+these types are already fully expanded, i.e., they do not include any
+alias types.
+\begin{verbatim}
+
+> ilTrans :: Bool -> ValueEnv -> TCEnv -> EvalEnv -> Module -> IL.Module
+> ilTrans flat tyEnv tcEnv evEnv (Module m _ ds) = 
+>   IL.Module m (imports m ds') ds'
+>   where ds' = concatMap (translGlobalDecl flat m tyEnv tcEnv evEnv) ds
+
+> translGlobalDecl :: Bool -> ModuleIdent -> ValueEnv -> TCEnv -> EvalEnv
+>                  -> Decl -> [IL.Decl]
+> translGlobalDecl _ m tyEnv tcEnv _ (DataDecl _ tc tvs cs) =
+>   [translData m tyEnv tcEnv tc tvs cs]
+> translGlobalDecl _ m tyEnv tcEnv _ (NewtypeDecl _ tc tvs nc) =
+>   [translNewtype m tyEnv tcEnv tc tvs nc]
+> translGlobalDecl flat m tyEnv tcEnv evEnv (FunctionDecl pos f eqs) =
+>   [translFunction pos flat m tyEnv tcEnv evEnv f eqs]
+> translGlobalDecl _ m tyEnv tcEnv _ (ExternalDecl _ cc ie f _) =
+>   [translExternal m tyEnv tcEnv f cc (fromJust ie)]
+> translGlobalDecl _ _ _ _ _ _ = []
+
+> translData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident] -> [ConstrDecl]
+>            -> IL.Decl
+> translData m tyEnv tcEnv tc tvs cs =
+>   IL.DataDecl (qualifyWith m tc) (length tvs)
+>               (map (translConstrDecl m tyEnv tcEnv) cs)
+
+> translNewtype :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident] 
+>	        -> NewConstrDecl -> IL.Decl
+> translNewtype m tyEnv tcEnv tc tvs (NewConstrDecl _ _ c _) =
+>   IL.NewtypeDecl (qualifyWith m tc) (length tvs)
+>                  (IL.ConstrDecl c' (translType' m tyEnv tcEnv ty))
+>                  -- (IL.ConstrDecl c' (translType ty))
+>   where c' = qualifyWith m c
+>         TypeArrow ty _ = constrType tyEnv c'
+
+> translConstrDecl :: ModuleIdent -> ValueEnv -> TCEnv -> ConstrDecl
+>                  -> IL.ConstrDecl [IL.Type]
+> translConstrDecl m tyEnv tcEnv d =
+>   IL.ConstrDecl c' (map (translType' m tyEnv tcEnv)
+>	                  (arrowArgs (constrType tyEnv c')))
+>   -- IL.ConstrDecl c' (map translType (arrowArgs (constrType tyEnv c')))
+>   where c' = qualifyWith m (constr d)
+>         constr (ConstrDecl _ _ c _) = c
+>         constr (ConOpDecl _ _ _ op _) = op
+
+> translExternal :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> CallConv
+>                -> String -> IL.Decl
+> translExternal m tyEnv tcEnv f cc ie =
+>   IL.ExternalDecl f' (callConv cc) ie 
+>                   (translType' m tyEnv tcEnv (varType tyEnv f'))
+>   -- IL.ExternalDecl f' (callConv cc) ie (translType (varType tyEnv f'))
+>   where f' = qualifyWith m f
+>         callConv CallConvPrimitive = IL.Primitive
+>         callConv CallConvCCall = IL.CCall
+
+\end{verbatim}
+\paragraph{Interfaces}
+In order to generate code, the compiler also needs to know the tags
+and arities of all imported data constructors. For that reason we
+compile the data type declarations of all interfaces into the
+intermediate language, too. In this case we do not lookup the
+types in the environment because the types in the interfaces are
+already fully expanded. Note that we do not translate data types
+which are imported into the interface from some other module.
+\begin{verbatim}
+
+> ilTransIntf :: ValueEnv -> TCEnv -> Interface -> [IL.Decl]
+> ilTransIntf tyEnv tcEnv (Interface m ds) = 
+>   foldr (translIntfDecl m tyEnv tcEnv) [] ds
+
+> translIntfDecl :: ModuleIdent -> ValueEnv -> TCEnv -> IDecl -> [IL.Decl] 
+>	         -> [IL.Decl]
+> translIntfDecl m tyEnv tcEnv (IDataDecl _ tc tvs cs) ds
+>   | not (isQualified tc) = 
+>     translIntfData m tyEnv tcEnv (unqualify tc) tvs cs : ds
+> translIntfDecl _ _ _ _ ds = ds
+
+> translIntfData :: ModuleIdent -> ValueEnv -> TCEnv -> Ident -> [Ident] 
+>	         -> [Maybe ConstrDecl] -> IL.Decl
+> translIntfData m tyEnv tcEnv tc tvs cs =
+>   IL.DataDecl (qualifyWith m tc) (length tvs)
+>               (map (maybe hiddenConstr 
+>	                    (translIntfConstrDecl m tyEnv tcEnv tvs)) cs)
+>   where hiddenConstr = IL.ConstrDecl qAnonId []
+>         qAnonId = qualify anonId
+
+> translIntfConstrDecl :: ModuleIdent -> ValueEnv -> TCEnv -> [Ident] 
+>                      -> ConstrDecl -> IL.ConstrDecl [IL.Type]
+> translIntfConstrDecl m tyEnv tcEnv tvs (ConstrDecl _ _ c tys) =
+>   IL.ConstrDecl (qualifyWith m c) (map (translType' m tyEnv tcEnv)
+>			                 (toQualTypes m tvs tys))
+>   -- IL.ConstrDecl (qualifyWith m c) (map translType (toQualTypes m tvs tys))
+> translIntfConstrDecl m tyEnv tcEnv tvs (ConOpDecl _ _ ty1 op ty2) =
+>   IL.ConstrDecl (qualifyWith m op)
+>                 (map (translType' m tyEnv tcEnv)
+>	               (toQualTypes m tvs [ty1,ty2]))
+>   -- IL.ConstrDecl (qualifyWith m op)
+>   --              (map translType (toQualTypes m tvs [ty1,ty2]))
+
+\end{verbatim}
+\paragraph{Types}
+The type representation in the intermediate language is the same as
+the internal representation except that it does not support
+constrained type variables and skolem types. The former are fixed and
+the later are replaced by fresh type constructors.
+
+Due to possible occurrence of record types, it is necessary to transform
+them back into their corresponding type constructors.
+\begin{verbatim}
+
+> translType' :: ModuleIdent -> ValueEnv -> TCEnv -> Type -> IL.Type
+> translType' m tyEnv tcEnv ty =
+>   translType (elimRecordTypes m tyEnv tcEnv (maximum (0:(typeVars ty))) ty)
+
+> translType :: Type -> IL.Type
+> translType (TypeConstructor tc tys) =
+>   IL.TypeConstructor tc (map translType tys)
+> translType (TypeVariable tv) = IL.TypeVariable tv
+> translType (TypeConstrained tys _) = translType (head tys)
+> translType (TypeArrow ty1 ty2) =
+>   IL.TypeArrow (translType ty1) (translType ty2)
+> translType (TypeSkolem k) =
+>   IL.TypeConstructor (qualify (mkIdent ("_" ++ show k))) []
+
+> elimRecordTypes :: ModuleIdent -> ValueEnv -> TCEnv -> Int -> Type -> Type
+> elimRecordTypes m tyEnv tcEnv n (TypeConstructor t tys) =
+>   TypeConstructor t (map (elimRecordTypes m tyEnv tcEnv n) tys)
+> elimRecordTypes m tyEnv tcEnv n (TypeVariable v) =
+>   TypeVariable v
+> elimRecordTypes m tyEnv tcEnv n (TypeConstrained tys v) =
+>   TypeConstrained (map (elimRecordTypes m tyEnv tcEnv n) tys) v
+> elimRecordTypes m tyEnv tcEnv n (TypeArrow t1 t2) =
+>   TypeArrow (elimRecordTypes m tyEnv tcEnv n t1)
+>             (elimRecordTypes m tyEnv tcEnv n t2)
+> elimRecordTypes m tyEnv tcEnv n (TypeSkolem v) =
+>   TypeSkolem v
+> elimRecordTypes m tyEnv tcEnv n (TypeRecord fs _)
+>   | null fs = internalError "elimRecordTypes: empty record type"
+>   | otherwise =
+>     case (lookupValue (fst (head fs)) tyEnv) of
+>       [Label _ r _] ->
+>         case (qualLookupTC r tcEnv) of
+>           [AliasType _ n' (TypeRecord fs' _)] ->
+>	      let is = [0 .. n'-1]
+>                 vs = foldl (matchTypeVars fs)
+>			     zeroFM
+>			     fs'
+>		  tys = map (\i -> maybe (TypeVariable (i+n))
+>			                 (elimRecordTypes m tyEnv tcEnv n)
+>		                         (lookupFM i vs))
+>		            is 
+>	      in  TypeConstructor r tys
+>	    _ -> internalError "elimRecordTypes: no record type"
+>       _ -> internalError "elimRecordTypes: no label"
+
+> matchTypeVars :: [(Ident,Type)] -> FM Int Type -> (Ident,Type) 
+>	           -> FM Int Type
+> matchTypeVars fs vs (l,ty) =
+>   maybe vs (match vs ty) (lookup l fs)
+>   where
+>   match vs (TypeVariable i) ty' = addToFM i ty' vs
+>   match vs (TypeConstructor _ tys) (TypeConstructor _ tys') =
+>     matchList vs tys tys'
+>   match vs (TypeConstrained tys _) (TypeConstrained tys' _) =
+>     matchList vs tys tys'
+>   match vs (TypeArrow ty1 ty2) (TypeArrow ty1' ty2') =
+>     matchList vs [ty1,ty2] [ty1',ty2']
+>   match vs (TypeSkolem _) (TypeSkolem _) = vs
+>   match vs (TypeRecord fs _) (TypeRecord fs' _) =
+>     foldl (matchTypeVars fs') vs fs
+>   match vs ty ty' = 
+>     internalError ("matchTypeVars: " ++ show ty ++ "\n" ++ show ty')
+>
+>   matchList vs tys tys' = 
+>     foldl (\vs' (ty,ty') -> match vs' ty ty') vs (zip tys tys')
+
+\end{verbatim}
+\paragraph{Functions}
+Each function in the program is translated into a function of the
+intermediate language. The arguments of the function are renamed such
+that all variables occurring in the same position (in different
+equations) have the same name. This is necessary in order to
+facilitate the translation of pattern matching into a \texttt{case}
+expression. We use the following simple convention here: The top-level
+arguments of the function are named from left to right \texttt{\_1},
+\texttt{\_2}, and so on. The names of nested arguments are constructed
+by appending \texttt{\_1}, \texttt{\_2}, etc. from left to right to
+the name that were assigned to a variable occurring at the position of
+the constructor term.
+
+Some special care is needed for the selector functions introduced by
+the compiler in place of pattern bindings. In order to generate the
+code for updating all pattern variables, the equality of names between
+the pattern variables in the first argument of the selector function
+and their repeated occurrences in the remaining arguments must be
+preserved. This means that the second and following arguments of a
+selector function have to be renamed according to the name mapping
+computed for its first argument.
+
+If an evaluation annotation is available for a function, it determines
+the evaluation mode of the case expression. Otherwise, the function
+uses flexible matching.
+\begin{verbatim}
+
+> type RenameEnv = Env Ident Ident
+
+> translFunction :: Position -> Bool -> ModuleIdent -> ValueEnv -> TCEnv
+>       -> EvalEnv -> Ident -> [Equation] -> IL.Decl
+> translFunction pos flat m tyEnv tcEnv evEnv f eqs =
+>   -- | f == mkIdent "fun" = error (show (translType' m tyEnv tcEnv ty))
+>   -- | otherwise = 
+>     IL.FunctionDecl f' vs (translType' m tyEnv tcEnv ty) expr
+>    -- = IL.FunctionDecl f' vs (translType ty)
+>    --                  (match ev vs (map (translEquation tyEnv vs vs'') eqs))
+>   where f'  = qualifyWith m f
+>         ty  = varType tyEnv f'
+>         -- ty' = elimRecordType m tyEnv tcEnv (maximum (0:(typeVars ty))) ty
+>         ev' = lookupEval f evEnv
+>         ev  = maybe (defaultMode ty) evalMode ev'
+>         vs  = if not flat && isFpSelectorId f then translArgs eqs vs' else vs'
+>         (vs',vs'') = splitAt (equationArity (head eqs)) 
+>                              (argNames (mkIdent ""))
+>         expr | ev' == Just EvalChoice
+>                = IL.Apply 
+>                    (IL.Function 
+>                       (qualifyWith preludeMIdent (mkIdent "commit"))
+>                       1)
+>                    (match (ast pos) IL.Rigid vs 
+>                       (map (translEquation tyEnv vs vs'') eqs))
+>              | otherwise
+>                =  match (ast pos) ev vs (map (translEquation tyEnv vs vs'') eqs)
+>         ---
+>         -- (vs',vs'') = splitAt (arrowArity ty) (argNames (mkIdent ""))
+
+> evalMode :: EvalAnnotation -> IL.Eval
+> evalMode EvalRigid = IL.Rigid
+> evalMode EvalChoice = error "eval choice is not yet supported"
+
+> defaultMode :: Type -> IL.Eval
+> defaultMode _ = IL.Flex
+>
+> --defaultMode ty = if isIO (arrowBase ty) then IL.Rigid else IL.Flex
+> --  where TypeConstructor qIOId _ = ioType undefined
+> --        isIO (TypeConstructor tc [_]) = tc == qIOId
+> --        isIO _ = False
+
+> translArgs :: [Equation] -> [Ident] -> [Ident]
+> translArgs [Equation _ (FunLhs _ (t:ts)) _] (v:_) =
+>   v : map (translArg (bindRenameEnv v t emptyEnv)) ts
+>   where translArg env (VariablePattern v) = fromJust (lookupEnv v env)
+
+> translEquation :: ValueEnv -> [Ident] -> [Ident] -> Equation
+>                -> ([NestedTerm],IL.Expression)
+> translEquation tyEnv vs vs' (Equation _ (FunLhs _ ts) rhs) =
+>   (zipWith translTerm vs ts,
+>    translRhs tyEnv vs' (foldr2 bindRenameEnv emptyEnv vs ts) rhs)
+
+> translRhs :: ValueEnv -> [Ident] -> RenameEnv -> Rhs -> IL.Expression
+> translRhs tyEnv vs env (SimpleRhs _ e _) = translExpr tyEnv vs env e
+
+
+> equationArity :: Equation -> Int
+> equationArity (Equation _ lhs _) = p_equArity lhs
+>  where
+>    p_equArity (FunLhs _ ts) = length ts
+>    p_equArity (OpLhs _ _ _) = 2
+>    p_equArity _             = error "ILTrans - illegal equation"
+
+
+\end{verbatim}
+\paragraph{Pattern Matching}
+The pattern matching code searches for the left-most inductive
+argument position in the left hand sides of all rules defining an
+equation. An inductive position is a position where all rules have a
+constructor rooted term. If such a position is found, a \texttt{case}
+expression is generated for the argument at that position. The
+matching code is then computed recursively for all of the alternatives
+independently. If no inductive position is found, the algorithm looks
+for the left-most demanded argument position, i.e., a position where
+at least one of the rules has a constructor rooted term. If such a
+position is found, an \texttt{or} expression is generated with those
+cases that have a variable at the argument position in one branch and
+all other rules in the other branch. If there is no demanded position,
+the pattern matching is finished and the compiler translates the right
+hand sides of the remaining rules, eventually combining them using
+\texttt{or} expressions.
+
+Actually, the algorithm below combines the search for inductive and
+demanded positions. The function \texttt{match} scans the argument
+lists for the left-most demanded position. If this turns out to be
+also an inductive position, the function \texttt{matchInductive} is
+called in order to generate a \texttt{case} expression. Otherwise, the
+function \texttt{optMatch} is called that tries to find an inductive
+position in the remaining arguments. If one is found,
+\texttt{matchInductive} is called, otherwise the function
+\texttt{optMatch} uses the demanded argument position found by
+\texttt{match}.
+\begin{verbatim}
+
+> data NestedTerm = NestedTerm IL.ConstrTerm [NestedTerm] deriving Show
+
+> pattern (NestedTerm t _) = t
+> arguments (NestedTerm _ ts) = ts
+
+> translLiteral :: Literal -> IL.Literal
+> translLiteral (Char p c) = IL.Char p c
+> translLiteral (Int id i) = IL.Int (ast (positionOfIdent id)) i
+> translLiteral (Float p f) = IL.Float p f
+> translLiteral _ = internalError "translLiteral"
+
+> translTerm :: Ident -> ConstrTerm -> NestedTerm
+> translTerm _ (LiteralPattern l) =
+>   NestedTerm (IL.LiteralPattern (translLiteral l)) []
+> translTerm v (VariablePattern _) = NestedTerm (IL.VariablePattern v) []
+> translTerm v (ConstructorPattern c ts) =
+>   NestedTerm (IL.ConstructorPattern c (take (length ts) vs))
+>              (zipWith translTerm vs ts)
+>   where vs = argNames v
+> translTerm v (AsPattern _ t) = translTerm v t
+> translTerm _ _ = internalError "translTerm"
+
+> bindRenameEnv :: Ident -> ConstrTerm -> RenameEnv -> RenameEnv
+> bindRenameEnv _ (LiteralPattern _) env = env
+> bindRenameEnv v (VariablePattern v') env = bindEnv v' v env
+> bindRenameEnv v (ConstructorPattern _ ts) env =
+>   foldr2 bindRenameEnv env (argNames v) ts
+> bindRenameEnv v (AsPattern v' t) env = bindEnv v' v (bindRenameEnv v t env)
+> bindRenameEnv _ _ env = internalError "bindRenameEnv"
+
+> argNames :: Ident -> [Ident]
+> argNames v = [mkIdent (prefix ++ show i) | i <- [1..]]
+>   where prefix = name v ++ "_"
+
+> type Match = ([NestedTerm],IL.Expression)
+> type Match' = ([NestedTerm] -> [NestedTerm],[NestedTerm],IL.Expression)
+
+> isDefaultPattern :: IL.ConstrTerm -> Bool
+> isDefaultPattern (IL.VariablePattern _) = True
+> isDefaultPattern _ = False
+
+> isDefaultMatch :: (IL.ConstrTerm,a) -> Bool
+> isDefaultMatch = isDefaultPattern . fst
+
+> match :: SrcRef -> IL.Eval -> [Ident] -> [Match] -> IL.Expression
+> match _   ev [] alts = foldl1 IL.Or (map snd alts)
+> match pos ev (v:vs) alts
+>   | null vars = e1
+>   | null nonVars = e2
+>   | otherwise = optMatch pos ev (IL.Or e1 e2) (v:) vs (map skipArg alts)
+>   where (vars,nonVars) = partition isDefaultMatch (map tagAlt alts)
+>         (nonArgs,args) = partition (null.fst) alts
+>         e1 = matchInductive pos ev id v vs nonVars
+>         e2 = match pos ev vs (map snd vars)
+>         tagAlt (t:ts,e) = (pattern t,(arguments t ++ ts,e))
+>         skipArg (t:ts,e) = ((t:),ts,e)
+
+> optMatch :: SrcRef -> IL.Eval -> IL.Expression -> ([Ident] -> [Ident]) 
+>    -> [Ident] ->[Match'] -> IL.Expression
+> optMatch _ ev e prefix [] alts = e
+> optMatch pos ev e prefix (v:vs) alts
+>   | null vars = matchInductive pos ev prefix v vs nonVars
+>   | otherwise = optMatch pos ev e (prefix . (v:)) vs (map skipArg alts)
+>   where (vars,nonVars) = partition isDefaultMatch (map tagAlt alts)
+>         tagAlt (prefix,t:ts,e) = (pattern t,(prefix (arguments t ++ ts),e))
+>         skipArg (prefix,t:ts,e) = (prefix . (t:),ts,e)
+
+> matchInductive :: SrcRef -> IL.Eval -> ([Ident] -> [Ident]) -> Ident 
+>    -> [Ident] ->[(IL.ConstrTerm,Match)] -> IL.Expression
+> matchInductive pos ev prefix v vs alts =
+>   IL.Case pos ev (IL.Variable v) (matchAlts ev prefix vs alts)
+
+> matchAlts :: IL.Eval -> ([Ident] -> [Ident]) -> [Ident] ->
+>     [(IL.ConstrTerm,Match)] -> [IL.Alt]
+> matchAlts ev prefix vs [] = []
+> matchAlts ev prefix vs ((t,alt):alts) =
+>   IL.Alt t (match (srcRefOf t) 
+>                   ev (prefix (vars t ++ vs)) (alt : map snd same)) :
+>   matchAlts ev prefix vs others
+>   where (same,others) = partition ((t ==) . fst) alts 
+>         vars (IL.ConstructorPattern _ vs) = vs
+>         vars _ = []
+
+\end{verbatim}
+Matching in a \texttt{case}-expression works a little bit differently.
+In this case, the alternatives are matched from the first to the last
+alternative and the first matching alternative is chosen. All
+remaining alternatives are discarded.
+
+\ToDo{The case matching algorithm should use type information in order
+to detect total matches and immediately discard all alternatives which
+cannot be reached.}
+\begin{verbatim}
+
+> caseMatch :: SrcRef -> ([Ident] -> [Ident]) -> [Ident] -> [Match'] 
+>    -> IL.Expression
+> caseMatch _ prefix [] alts = thd3 (head alts)
+> caseMatch r prefix (v:vs) alts
+>   | isDefaultMatch (head alts') =
+>       caseMatch r (prefix . (v:)) vs (map skipArg alts)
+>   | otherwise =
+>       IL.Case r IL.Rigid (IL.Variable v) (caseMatchAlts prefix vs alts')
+>   where alts' = map tagAlt alts
+>         tagAlt (prefix,t:ts,e) = (pattern t,(prefix,arguments t ++ ts,e))
+>         skipArg (prefix,t:ts,e) = (prefix . (t:),ts,e)
+
+> caseMatchAlts ::
+>     ([Ident] -> [Ident]) -> [Ident] -> [(IL.ConstrTerm,Match')] -> [IL.Alt]
+> caseMatchAlts prefix vs alts = map caseAlt (ts ++ ts')
+>   where (ts',ts) = partition isDefaultPattern (nub (map fst alts))
+>         caseAlt t =
+>           IL.Alt t (caseMatch (srcRefOf t) id (prefix (vars t ++ vs))
+>                               (matchingCases t alts))
+>         matchingCases t =
+>           map (joinArgs (vars t)) . filter (matches t . fst)
+>         matches t t' = t == t' || isDefaultPattern t'
+>         joinArgs vs (IL.VariablePattern _,(prefix,ts,e)) =
+>            (id,prefix (map varPattern vs ++ ts),e)
+>         joinArgs _ (_,(prefix,ts,e)) = (id,prefix ts,e)
+>         varPattern v = NestedTerm (IL.VariablePattern v) []
+>         vars (IL.ConstructorPattern _ vs) = vs
+>         vars _ = []
+
+\end{verbatim}
+\paragraph{Expressions}
+Note that the case matching algorithm assumes that the matched
+expression is accessible through a variable. The translation of case
+expressions therefore introduces a let binding for the scrutinized
+expression and immediately throws it away after the matching -- except
+if the matching algorithm has decided to use that variable in the
+right hand sides of the case expression. This may happen, for
+instance, if one of the alternatives contains an \texttt{@}-pattern.
+\begin{verbatim}
+
+> translExpr :: ValueEnv -> [Ident] -> RenameEnv -> Expression -> IL.Expression
+> translExpr _ _ _ (Literal l) = IL.Literal (translLiteral l)
+> translExpr tyEnv _ env (Variable v) =
+>   case lookupVar v env of
+>     Just v' -> IL.Variable v'
+>     Nothing -> IL.Function v (arrowArity (varType tyEnv v))
+>   where lookupVar v env
+>           | isQualified v = Nothing
+>           | otherwise = lookupEnv (unqualify v) env
+> translExpr tyEnv _ _ (Constructor c) =
+>   IL.Constructor c (arrowArity (constrType tyEnv c))
+> translExpr tyEnv vs env (Apply e1 e2) =
+>   IL.Apply (translExpr tyEnv vs env e1) (translExpr tyEnv vs env e2)
+> translExpr tyEnv vs env (Let ds e) =
+>   case ds of
+>     [ExtraVariables _ vs] -> foldr IL.Exist e' vs
+>     [d] | all (`notElem` bv d) (qfv emptyMIdent d) ->
+>       IL.Let (translBinding env' d) e'
+>     _ -> IL.Letrec (map (translBinding env') ds) e'
+>   where e' = translExpr tyEnv vs env' e
+>         env' = foldr2 bindEnv env bvs bvs
+>         bvs = bv ds
+>         translBinding env (PatternDecl _ (VariablePattern v) rhs) =
+>           IL.Binding v (translRhs tyEnv vs env rhs)
+>         translBinding env p = error $ "unexpected binding: "++show p
+> translExpr tyEnv ~(v:vs) env (Case r e alts) =
+>   case caseMatch r id [v] (map (translAlt v) alts) of
+>     IL.Case r mode (IL.Variable v') alts'
+>       | v == v' && v `notElem` fv alts' -> IL.Case r mode e' alts'
+>     e''
+>       | v `elem` fv e'' -> IL.Let (IL.Binding v e') e''
+>       | otherwise -> e''
+>   where e' = translExpr tyEnv vs env e
+>         translAlt v (Alt _ t rhs) =
+>           (id,
+>            [translTerm v t],
+>            translRhs tyEnv vs (bindRenameEnv v t env) rhs)
+> translExpr _ _ _ _ = internalError "translExpr"
+
+> instance Expr IL.Expression where
+>   fv (IL.Variable v) = [v]
+>   fv (IL.Apply e1 e2) = fv e1 ++ fv e2
+>   fv (IL.Case _ _ e alts) = fv e ++ fv alts
+>   fv (IL.Or e1 e2) = fv e1 ++ fv e2
+>   fv (IL.Exist v e) = filter (/= v) (fv e)
+>   fv (IL.Let (IL.Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)
+>   fv (IL.Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e)
+>     where (vs,es) = unzip [(v,e) | IL.Binding v e <- bds]
+>   fv _ = []
+
+> instance Expr IL.Alt where
+>   fv (IL.Alt (IL.ConstructorPattern _ vs) e) = filter (`notElem` vs) (fv e)
+>   fv (IL.Alt (IL.VariablePattern v) e) = filter (v /=) (fv e)
+>   fv (IL.Alt _ e) = fv e
+
+\end{verbatim}
+\paragraph{Auxiliary Definitions}
+The functions \texttt{varType} and \texttt{constrType} return the type
+of variables and constructors, respectively. The quantifiers are
+stripped from the types.
+\begin{verbatim}
+
+> varType :: ValueEnv -> QualIdent -> Type
+> varType tyEnv f =
+>   case qualLookupValue f tyEnv of
+>     [Value _ (ForAll _ ty)] -> ty
+>     _ -> internalError ("varType: " ++ show f)
+
+> constrType :: ValueEnv -> QualIdent -> Type
+> constrType tyEnv c =
+>   case qualLookupValue c tyEnv of
+>     [DataConstructor _ (ForAllExist _ _ ty)] -> ty
+>     [NewtypeConstructor _ (ForAllExist _ _ ty)] -> ty
+>     _ -> internalError ("constrType: " ++ show c)
+
+\end{verbatim}
+The list of import declarations in the intermediate language code is
+determined by collecting all module qualifiers used in the current
+module.
+\begin{verbatim}
+
+> imports :: ModuleIdent -> [IL.Decl] -> [ModuleIdent]
+> imports m = toListSet . deleteFromSet m . fromListSet . foldr modulesDecl []
+
+> modulesDecl :: IL.Decl -> [ModuleIdent] -> [ModuleIdent]
+> modulesDecl (IL.DataDecl _ _ cs) ms = foldr modulesConstrDecl ms cs
+>   where modulesConstrDecl (IL.ConstrDecl _ tys) ms = foldr modulesType ms tys
+> modulesDecl (IL.NewtypeDecl _ _ (IL.ConstrDecl _ ty)) ms = modulesType ty ms
+> modulesDecl (IL.FunctionDecl _ _ ty e) ms = modulesType ty (modulesExpr e ms)
+> modulesDecl (IL.ExternalDecl _ _ _ ty) ms = modulesType ty ms
+
+> modulesType :: IL.Type -> [ModuleIdent] -> [ModuleIdent]
+> modulesType (IL.TypeConstructor tc tys) ms =
+>   modules tc (foldr modulesType ms tys)
+> modulesType (IL.TypeVariable _) ms = ms
+> modulesType (IL.TypeArrow ty1 ty2) ms = modulesType ty1 (modulesType ty2 ms)
+
+> modulesExpr :: IL.Expression -> [ModuleIdent] -> [ModuleIdent]
+> modulesExpr (IL.Function f _) ms = modules f ms
+> modulesExpr (IL.Constructor c _) ms = modules c ms
+> modulesExpr (IL.Apply e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
+> modulesExpr (IL.Case _ _ e as) ms = modulesExpr e (foldr modulesAlt ms as)
+>   where modulesAlt (IL.Alt t e) ms = modulesConstrTerm t (modulesExpr e ms)
+>         modulesConstrTerm (IL.ConstructorPattern c _) ms = modules c ms
+>         modulesConstrTerm _ ms = ms
+> modulesExpr (IL.Or e1 e2) ms = modulesExpr e1 (modulesExpr e2 ms)
+> modulesExpr (IL.Exist _ e) ms = modulesExpr e ms
+> modulesExpr (IL.Let b e) ms = modulesBinding b (modulesExpr e ms)
+> modulesExpr (IL.Letrec bs e) ms = foldr modulesBinding (modulesExpr e ms) bs
+> modulesExpr _ ms = ms
+
+> modulesBinding :: IL.Binding -> [ModuleIdent] -> [ModuleIdent]
+> modulesBinding (IL.Binding _ e) = modulesExpr e
+
+> modules :: QualIdent -> [ModuleIdent] -> [ModuleIdent]
+> modules x ms = maybe ms (: ms) (fst (splitQualIdent x))
+
+\end{verbatim}
+
diff --git a/src/ILxml.lhs b/src/ILxml.lhs
new file mode 100644
--- /dev/null
+++ b/src/ILxml.lhs
@@ -0,0 +1,518 @@
+
+% $Id: ILxml.lhs,v 1.0 2001/06/19 12:19:18 rafa Exp $
+%
+% $Log: ILxml.lhs,v $
+%
+% Revision 1.1  2001/06/19 12:19:18  rafa
+% Pretty printer in XML for the intermediate language added.
+%
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{ILxml.lhs}
+\section{A pretty printer in XML for the intermediate language}
+This module implements just another pretty printer, this time in XML and for
+the intermediate language. It was mainly adapted from the Curry pretty
+printer (see sect.~\ref{sec:CurryPP}), which in turn is based on Simon
+Marlow's pretty printer for Haskell. The format of the output intends to be
+similar to that of Flat-Curry XML representation.
+\begin{verbatim}
+
+> module ILxml(module ILxml, Doc) where
+
+> import Data.Maybe
+> import Data.Char(chr,ord,isAlphaNum)
+
+> import Ident
+> import IL
+> import qualified CurrySyntax as CS
+> import CurryEnv
+> import Pretty
+
+
+
+> -- identation level
+> level::Int
+> level = 3
+
+> xmlModule :: CurryEnv -> Module -> Doc
+> xmlModule cEnv m = text "<prog>" $$ nest level (xmlBody cEnv m) 
+>	                           $$ text "</prog>"
+
+> xmlBody :: CurryEnv -> Module -> Doc
+> xmlBody cEnv (Module name imports decls) =
+>                   xmlElement "module"      xmlModuleDecl      moduleDecl   $$
+>                   xmlElement "import"      xmlImportDecl      importDecl   $$
+>                   xmlElement "types"       xmlTypeDecl        typeDecl     $$
+>                   xmlElement "functions"   xmlFunctionDecl    functionDecl $$
+>                   xmlElement "operators"   xmlOperatorDecl    operatorDecl $$
+>                   xmlElement "translation" xmlTranslationDecl translationDecl
+>               where
+>                 moduleDecl      = [name]
+>                 importDecl      = imports
+>                 operatorDecl    = infixDecls cEnv
+>                 translationDecl = foldl (qualIDeclId (moduleId cEnv))
+>			                  [] 
+>				          (interface cEnv)
+>                 (functionDecl,typeDecl) = splitDecls decls
+
+> -- =========================================================================
+
+> xmlModuleDecl :: ModuleIdent -> Doc
+> xmlModuleDecl name = xmlModuleIdent name
+
+> -- =========================================================================
+
+> xmlImportDecl :: ModuleIdent -> Doc
+> xmlImportDecl name = xmlElement "module" xmlModuleDecl  [name]
+
+
+> -- =========================================================================
+> --            T Y P E S
+> -- =========================================================================
+
+> xmlTypeDecl :: Decl -> Doc
+> xmlTypeDecl (DataDecl tc arity cs) =
+>   beginType                                  $$
+>   nest level (xmlTypeParams arity)           $$
+>   xmlLines xmlConstructor cs                 $$
+>   endType
+>  where
+>   beginType = text "<type name=\"" <> (xmlQualIdent tc) <> text "\">"
+>   endType   = text "</type>"
+
+> xmlTypeParams :: Int -> Doc
+> xmlTypeParams n = xmlElement "params" xmlTypeVar [0..(n-1)]
+
+> xmlConstructor :: ConstrDecl [Type] -> Doc
+> xmlConstructor (ConstrDecl ident []) = xmlConstructorBegin ident 0
+> xmlConstructor (ConstrDecl ident l)  =
+>   xmlConstructorBegin ident (length l) $$
+>   xmlLines xmlType l $$
+>   xmlConstructorEnd
+>  where
+>   xmlConstructorEnd = text "</cons>"
+
+> xmlConstructorBegin :: QualIdent -> Int -> Doc
+> xmlConstructorBegin ident n = xmlHeadingWithArity "cons" ident n (n==0)
+
+> xmlHeadingWithArity :: String -> QualIdent -> Int -> Bool -> Doc
+> xmlHeadingWithArity tagName ident n single =
+>   if single
+>   then prefix<>text "/>"
+>   else prefix<> text ">"
+>   where
+>     prefix = text ("<"++tagName++" name=\"") <> name <> text "\" " <> arity
+>     arity  = text "arity=\"" <> xmlInt n <> text "\""
+>     name   = xmlQualIdent ident
+
+
+> xmlType :: Type -> Doc
+> xmlType (TypeConstructor ident []) = xmlTypeConsBegin ident True
+> xmlType (TypeConstructor ident l)  = xmlTypeConsBegin ident False $$
+>                                      xmlLines xmlType l           $$
+>                                      xmlTypeConsEnd
+>                                      where
+>                                        xmlTypeConsEnd = text "</tcons>"
+
+> xmlType (TypeVariable n) = xmlTypeVar n
+> xmlType (TypeArrow  a b) = xmlTypeFun a b
+
+> xmlTypeConsBegin :: QualIdent -> Bool -> Doc
+> xmlTypeConsBegin ident single =
+>   if single
+>   then prefix <> text "/>"
+>   else prefix <> text ">"
+>   where
+>     name   = xmlQualIdent ident
+>     prefix = text "<tcons name=\"" <> name <> text "\""
+
+> xmlTypeVar :: Int -> Doc
+> xmlTypeVar n = text "<tvar>"<> xmlInt n <> text "</tvar>"
+
+> xmlTypeFun :: Type -> Type -> Doc
+> xmlTypeFun a b =  xmlElement "functype" xmlType  [a,b]
+
+
+> -- =========================================================================
+> --            F U N C T I O N S
+> -- =========================================================================
+
+> xmlFunctionDecl :: Decl -> Doc
+> xmlFunctionDecl (NewtypeDecl tc arity (ConstrDecl ident ty)) =
+>   xmlFunctionDecl (FunctionDecl ident [arg] ftype (Variable arg))
+>   where
+>    arg = mkIdent "_1"
+>    ftype = TypeArrow ty (TypeConstructor tc (map TypeVariable [0..arity-1]))
+
+> xmlFunctionDecl (FunctionDecl ident largs fType expr) =
+>    heading $$ nest level (xmlRule largs expr) $$ end
+>  where
+>    heading = xmlBeginFunction ident (length largs) fType
+>    end     = text "</func>"
+
+> xmlFunctionDecl (ExternalDecl ident callConv internalName fType) =
+>    heading $$ external $$ end
+>  where
+>    heading  = xmlBeginFunction ident (xmlFunctionArity fType) fType
+>    external = text ("<external>"
+>                     ++ xmlFormat internalName
+>                     ++ "</external>")
+>    end      = text "</func>"
+
+> xmlBeginFunction :: QualIdent -> Int -> Type -> Doc
+> xmlBeginFunction ident n fType =
+>    heading $$ typeDecls
+>    where
+>      heading   = xmlHeadingWithArity "func" ident n False
+>      typeDecls = nest level (xmlType fType)
+
+> xmlEndFunction ::  Doc
+> xmlEndFunction  = text "</func>"
+
+> xmlFunctionArity :: Type -> Int
+> xmlFunctionArity (TypeConstructor ident l) = 0
+> xmlFunctionArity (TypeVariable n)          = 0
+> xmlFunctionArity (TypeArrow  a b)          = 1 + (xmlFunctionArity b)
+
+> xmlRule :: [Ident] -> Expression -> Doc
+> xmlRule lArgs e = text "<rule>"               $$
+>                   nest level (xmlLhs lArgs)   $$
+>                   nest level (xmlRhs lArgs e) $$
+>                   text "</rule>"
+
+> xmlLhs :: [Ident] -> Doc
+> xmlLhs l  = xmlElement "lhs" xmlVar [0..((length l)-1)]
+
+> xmlRhs :: [Ident] -> Expression -> Doc
+> xmlRhs l e = text "<rhs>"  $$ nest level rhs $$ text "</rhs>"
+>              where
+>                varDicc    = xmlBuildDicc l
+>                (rhs,dicc) = xmlExpr varDicc e
+
+> -- =========================================================================
+
+> -- =========================================================================
+> --            E X P R E S S I O N S
+> -- =========================================================================
+
+> xmlExpr :: [(Int,Ident)] -> Expression -> (Doc,[(Int,Ident)])
+> xmlExpr d (Literal lit)  = (xmlLiteral (xmlLit lit),d)
+> xmlExpr d (Variable ident)  = xmlExprVar d ident
+> xmlExpr d (Function ident arity)    = (xmlSingleApp ident arity True,d)
+> xmlExpr d (Constructor ident arity) = (xmlSingleApp ident arity False,d)
+> xmlExpr d exp@(Apply e1 e2)         = xmlApply  d exp (xmlAppArgs exp)
+> xmlExpr d (Case _ eval expr alt)      = xmlCase   d eval expr alt
+> xmlExpr d (Or expr1 expr2)          = xmlOr     d expr1 expr2
+> xmlExpr d (Exist ident expr)        = xmlFree   d ident expr
+> xmlExpr d (Let binding expr)        = xmlLet    d binding expr
+> xmlExpr d (Letrec lBinding expr)    = xmlLetrec d lBinding expr
+>   --error "Recursive let bindings not supported in FlatCurry"
+
+> -- =========================================================================
+
+> xmlSingleApp :: QualIdent -> Int -> Bool -> Doc
+> xmlSingleApp ident arity isFunction =
+>    if arity>0
+>    then xmlCombHeading identDoc (text "PartCall") True
+>    else xmlCombHeading identDoc (text totalApp) True
+>    where
+>       identDoc = xmlQualIdent ident
+>       totalApp = if isFunction then "FuncCall" else "ConsCall"
+
+
+> xmlCombHeading :: Doc -> Doc -> Bool -> Doc
+> xmlCombHeading name cType single =
+>     if single
+>     then prefix <> text " />"
+>     else prefix <> text ">"
+>     where
+>       prefix = text "<comb type=\""<>cType<>text "\" name=\""<>name<>text "\""
+
+> -- =========================================================================
+
+> xmlExprVar :: [(Int,Ident)] -> Ident -> (Doc,[(Int,Ident)])
+> xmlExprVar d ident =
+>    if isNew
+>    then (xmlVar newVar, (newVar,ident):d)
+>    else (xmlVar var, d)
+>    where
+>       var    = xmlLookUp ident d
+>       isNew  = var == -1
+>       newVar = xmlNewVar d
+
+> -- =========================================================================
+
+
+> xmlApply :: [(Int,Ident)] -> Expression -> (Expression,[Expression]) ->
+>              (Doc,[(Int,Ident)])
+
+> xmlApply d exp ((Function ident arity),lExp) =
+>   xmlApplyFunctor d ident arity lExp True
+
+> xmlApply d exp ((Constructor ident arity),lExp) =
+>   xmlApplyFunctor d ident arity lExp False
+
+> xmlApply d (Apply expr1 expr2) e' =
+>   (text "<apply>" $$ nest level e1 $$ nest level e2 $$ text "</apply>", d2)
+>     where
+>        (e1,d1) = xmlExpr d  expr1
+>        (e2,d2) = xmlExpr d1 expr2
+
+> xmlApplyFunctor ::[(Int,Ident)] -> QualIdent -> Int -> [Expression] ->
+>                     Bool -> (Doc,[(Int,Ident)])
+> xmlApplyFunctor d ident arity lArgs isFunction =
+>    xmlCombApply d (xmlQualIdent ident)  (text cTypeS) n lArgs
+>    where
+>       n     = length (lArgs)
+>       cTypeS = if n==arity
+>               then if isFunction
+>                    then "FuncCall"
+>                    else "ConsCall"
+>               else "PartCall"
+
+
+> xmlCombApply :: [(Int,Ident)] -> Doc -> Doc -> Int ->
+>                                 [Expression] -> (Doc,[(Int,Ident)])
+> xmlCombApply d name cType 0 lArgs =
+>    (xmlCombHeading name cType True,d)
+> xmlCombApply d name cType n lArgs =
+>    (xmlCombHeading name cType False $$ xmlLines id lDocs$$ text "</comb>", d1)
+>    where
+>      (lDocs,d1) = xmlMapDicc d xmlExpr lArgs
+
+
+> xmlAppArgs :: Expression -> (Expression,[Expression])
+> xmlAppArgs (Apply e1 e2) = (e,lArgs++[e2])
+>                            where
+>                                (e,lArgs) = (xmlAppArgs e1)
+> xmlAppArgs e             = (e,[])
+> -- =========================================================================
+
+
+> -- =========================================================================
+
+> xmlCase :: [(Int,Ident)] -> Eval -> Expression -> [Alt] -> (Doc,[(Int,Ident)])
+> xmlCase d eval expr lAlt =
+>   (heading $$ nest level e1 $$ xmlLines id lDocs$$ end,d2)
+>   where
+>     sEval      = if eval==Rigid then "\"Rigid\"" else "\"Flex\""
+>     heading    = text "<case type=" <> text sEval <> text ">"
+>     end        = text "</case>"
+>     (e1,d1)    = xmlExpr d expr
+>     (lDocs,d2) = xmlMapDicc d xmlBranch  lAlt
+
+> xmlOr :: [(Int,Ident)] -> Expression -> Expression -> (Doc,[(Int,Ident)])
+> xmlOr d  expr1 expr2 =
+>    (text "<or>" $$ nest level e1 $$ nest level e2 $$  text "</or>",d2)
+>    where
+>      (e1,d1) = xmlExpr d expr1
+>      (e2,d2) = xmlExpr d1 expr2
+
+
+> xmlBranch :: [(Int,Ident)] -> Alt -> (Doc,[(Int,Ident)])
+> xmlBranch d (Alt pattern expr) =
+>    (text "<branch>" $$ nest level e1 $$ nest level e2 $$ text "</branch>",d2)
+>    where
+>      (e1,d1) = xmlPattern d pattern
+>      (e2,d2) = xmlExpr d1 expr
+
+
+> xmlPattern :: [(Int,Ident)] -> ConstrTerm -> (Doc,[(Int,Ident)])
+> xmlPattern d (LiteralPattern lit) = (xmlLitPattern (xmlLit lit),d)
+> xmlPattern d (ConstructorPattern ident lArgs) = xmlConsPattern d ident  lArgs
+> xmlPattern d (VariablePattern _) = error "Variable patterns not allowed in Flat Curry"
+
+> xmlConsPattern :: [(Int,Ident)] -> QualIdent -> [Ident] -> (Doc,[(Int,Ident)])
+> xmlConsPattern d ident lArgs =
+>    (heading $$ xmlLines id lDocs $$ end,d2)
+>    where
+>      heading    = text "<pattern name=\""<> (xmlQualIdent ident) <>
+>                   text "\"" <> endh
+>      endh       = if (length lArgs)>0 then text ">" else text "/>"
+>      end        = if (length lArgs)>0 then text "</pattern>" else empty
+>      (lDocs,d2) = xmlMapDicc d xmlExprVar lArgs
+
+> -- =========================================================================
+
+
+> xmlFree :: [(Int,Ident)] -> Ident -> Expression -> (Doc,[(Int,Ident)])
+> xmlFree d ident exp =
+>  (text "<freevars>" $$ nest level v $$ nest level e $$ text "</freevars>",d2)
+>                    where
+>                       (v,d1) = xmlExprVar d  ident
+>                       (e,d2) = xmlExpr d1 exp
+
+
+> -- =========================================================================
+
+> xmlLet :: [(Int,Ident)] -> Binding -> Expression -> (Doc,[(Int,Ident)])
+> xmlLet d binding exp =
+>   (text "<let>" $$ nest level b $$ nest level e $$ text "</let>", d2)
+>   where
+>    (b,d1) = xmlBinding d binding
+>    (e,d2) = xmlExpr d1 exp
+
+> xmlBinding :: [(Int,Ident)] -> Binding -> (Doc,[(Int,Ident)])
+> xmlBinding d  (Binding ident exp) =
+>    (text "<binding>" $$ nest level v $$ nest level e $$ text "</binding>",d2)
+>    where
+>       (v,d1) = xmlExprVar d ident
+>       (e,d2) = xmlExpr d exp
+
+> -- =========================================================================
+
+> xmlLetrec :: [(Int,Ident)] -> [Binding] -> Expression -> (Doc,[(Int,Ident)])
+> xmlLetrec d lB exp =
+>   (text "<letrec>" $$ xmlLines id b $$ nest level e $$ text "</letrec>",d2)
+>   where
+>     (b,d1) = xmlMapDicc d xmlBinding lB
+>     (e,d2) = xmlExpr d1 exp
+
+> -- =========================================================================
+
+
+> -- =========================================================================
+> --            A U X I L I A R Y  F U N C T I O N S
+> -- =========================================================================
+
+> splitDecls :: [Decl] -> ([Decl],[Decl])
+> splitDecls []     = ([],[])
+> splitDecls (x:xs) = case x of
+>                      DataDecl     _ _ _   -> (functionDecl,x:typeDecl)
+>                      NewtypeDecl  _ _ _   -> (x:functionDecl,typeDecl)
+>                      FunctionDecl _ _ _ _ -> (x:functionDecl,typeDecl)
+>                      ExternalDecl _ _ _ _   -> (x:functionDecl,typeDecl)
+>                   where
+>                       (functionDecl,typeDecl) = splitDecls xs
+
+
+
+
+> xmlElement :: Eq a => String -> (a -> Doc) -> [a] -> Doc
+> xmlElement name f []     = text ("<"++name++" />")
+> xmlElement name f lDecls = beginElement $$ xmlLines f lDecls $$ endElement
+>                            where
+>                                beginElement = text ("<"++name++">")
+>                                endElement   = text ("</"++name++">")
+>
+
+> xmlLines :: (a -> Doc) -> [a] -> Doc
+> xmlLines f = (nest level).vcat.(map f)
+
+
+> xmlMapDicc::[(Int,Ident)] -> ([(Int,Ident)] -> a -> (Doc,[(Int,Ident)])) ->
+>              [a] -> ([Doc],[(Int,Ident)])
+> xmlMapDicc d f lArgs = foldl newArg ([],d) lArgs
+>                             where
+>                               newArg (l,d)  e = (l++[v'],d')
+>                                                 where (v',d') = f d e
+>
+
+
+> -- The dictionary identifies var names with integers
+> -- it will be ordered starting at the greatest integer
+> xmlBuildDicc :: [Ident] -> [(Int,Ident)]
+> xmlBuildDicc l = reverse (zip [0..((length l)-1)] l)
+
+> -- looks for a ident in the dictorionary. If it appears returns its
+> -- associated value. Otherwise, -1 is returned
+> xmlLookUp :: Ident -> [(Int,Ident)] -> Int
+> xmlLookUp ident []          = -1
+> xmlLookUp ident ((n,name):xs) = if ident==name
+>                                 then n
+>                                 else xmlLookUp ident xs
+
+> -- generates a integer corresponding to a new var
+> xmlNewVar :: [(Int,Ident)] -> Int
+> xmlNewVar []             = 0
+> xmlNewVar ((n,ident):xs) = n+1
+
+> xmlVar :: Int -> Doc
+> xmlVar n = text "<var>" <> xmlInt n <> text "</var>"
+
+> xmlLiteral :: Doc -> Doc
+> xmlLiteral d =   text "<lit>" $$ nest level d $$ text "</lit>"
+
+> xmlLitPattern :: Doc -> Doc
+> xmlLitPattern d =   text "<lpattern>" $$ nest level d $$ text "</lpattern>"
+
+
+> xmlLit :: Literal -> Doc
+> xmlLit (Char _ c) = text "<charc>" <>  xmlInt (ord c) <> text "</charc>"
+> xmlLit (Int _ n) = text "<intc>" <>  xmlInteger n <> text "</intc>"
+> xmlLit (Float _ n) = text "<floatc>" <>  xmlFloat n <> text "</floatc>"
+
+> xmlOperatorDecl :: CS.IDecl -> Doc
+> xmlOperatorDecl (CS.IInfixDecl _ fixity prec qident) =
+>     text "<op fixity=\"" <> xmlFixity fixity 
+>     <> text "\" prec=\"" <> xmlInteger prec <> text "\">"
+>     <> xmlIdent (unqualify qident)
+>     <> text "</op>"
+
+> xmlFixity :: CS.Infix -> Doc
+> xmlFixity CS.InfixL = text "InfixlOp"
+> xmlFixity CS.InfixR = text "InfixrOp"
+> xmlFixity CS.Infix  = text "InfixOp"
+
+
+> xmlTranslationDecl :: QualIdent -> Doc
+> xmlTranslationDecl expId =
+>       text "<trans>" 
+>    $$ nest level (   text "<name>"    <> xmlIdent (unqualify expId) <> text "</name>"
+>                   $$ text "<intname>" <> xmlQualIdent expId         <> text "</intname>")
+>    $$ text "</trans>"
+
+
+> xmlIdent :: Ident -> Doc
+> xmlIdent ident = text (xmlFormat (name ident))
+
+> xmlInt :: Int -> Doc
+> xmlInt n = text (show n)
+
+> xmlInteger :: Integer -> Doc
+> xmlInteger n = text (show n)
+
+> xmlFloat :: Double -> Doc
+> xmlFloat n = text (show n)
+
+> xmlQualIdent :: QualIdent -> Doc
+> xmlQualIdent ident = text (xmlFormat (qualName ident))
+
+> xmlModuleIdent:: ModuleIdent -> Doc
+> xmlModuleIdent name = text (xmlFormat (moduleName name))
+
+> xmlFormat :: String -> String
+> xmlFormat []       = []
+> xmlFormat ('>':xs) = "&gt;"++xmlFormat xs
+> xmlFormat ('<':xs) = "&lt;"++xmlFormat xs
+> xmlFormat ('&':xs) = "&amp;"++xmlFormat xs
+> xmlFormat (x:xs)   = x:(xmlFormat xs)
+
+> -- =========================================================================
+
+> qualIDeclId :: ModuleIdent -> [QualIdent] -> CS.IDecl -> [QualIdent]
+> qualIDeclId mid qids (CS.IDataDecl _ qid _ mcdecls)
+>    = foldl (qualConstrDeclId mid) (qid:qids) (catMaybes mcdecls)
+> qualIDeclId mid qids (CS.INewtypeDecl _ qid _ ncdecl)
+>    = qualNewConstrDeclId mid (qid:qids) ncdecl
+> qualIDeclId mid qids (CS.ITypeDecl _ qid _ _)
+>    = qid:qids
+> qualIDeclId mid qids (CS.IFunctionDecl _ qid _ _)
+>    = qid:qids
+> qualIDeclId mid qids _ = qids
+
+> qualConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.ConstrDecl 
+>	              -> [QualIdent]
+> qualConstrDeclId mid qids (CS.ConstrDecl _ _ id _)
+>    = (qualifyWith mid id):qids
+> qualConstrDeclId mid qids (CS.ConOpDecl _ _ _ id _)
+>    = (qualifyWith mid id):qids
+
+> qualNewConstrDeclId :: ModuleIdent -> [QualIdent] -> CS.NewConstrDecl 
+>	                 -> [QualIdent]
+> qualNewConstrDeclId mid qids (CS.NewConstrDecl _ _ id _)
+>    = (qualifyWith mid id):qids
+
+
+\end{verbatim}
diff --git a/src/Ident.lhs b/src/Ident.lhs
new file mode 100644
--- /dev/null
+++ b/src/Ident.lhs
@@ -0,0 +1,415 @@
+> {-# LANGUAGE DeriveDataTypeable #-}
+
+% $Id: Ident.lhs,v 1.21 2004/10/29 13:08:09 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Ident.lhs}
+\section{Identifiers}
+This module provides the implementation of identifiers and some
+utility functions for identifiers, which are used at various places in
+the compiler.
+
+Identifiers comprise the name of the denoted entity and an \emph{id},
+which can be used for renaming identifiers, e.g., in order to resolve
+name conflicts between identifiers from different scopes. An
+identifier with an \emph{id} $0$ is considered as not being renamed
+and, hence, its \emph{id} will not be shown.
+
+\ToDo{Probably we should use \texttt{Integer} for the \emph{id}s.}
+
+Qualified identifiers may optionally be prefixed by a module
+name. \textbf{The order of the cases \texttt{UnqualIdent} and
+\texttt{QualIdent} is important. Some parts of the compiler rely on
+the fact that all qualified identifiers are greater than any
+unqualified identifier.}
+\begin{verbatim}
+
+> module Ident(Ident,QualIdent,ModuleIdent,SrcRefOf(..),
+>              mkIdent,name,qualName,uniqueId,renameIdent,unRenameIdent,
+>              mkMIdent,moduleName,moduleQualifiers,isInfixOp,isQInfixOp,
+>              qualify,qualifyWith,qualQualify,isQualified,
+>              unqualify,qualUnqualify,localIdent,splitQualIdent,
+>              emptyMIdent,mainMIdent,preludeMIdent,
+>              anonId,unitId,boolId,charId,intId,floatId,listId,ioId,
+>              successId,trueId,falseId,nilId,consId,mainId,
+>              tupleId,isTupleId,tupleArity,
+>              minusId,fminusId,updIdentName,
+>              qUnitId,qBoolId,qCharId,qIntId,qFloatId,qListId,qIOId,
+>              qSuccessId,qTrueId,qFalseId,qNilId,qConsId,
+>              qTupleId,isQTupleId,qTupleArity,
+>              fpSelectorId,isFpSelectorId,isQualFpSelectorId,
+>              recSelectorId,qualRecSelectorId,
+>              recUpdateId, qualRecUpdateId, recordExtId, labelExtId,
+>              isRecordExtId, isLabelExtId, fromRecordExtId, fromLabelExtId,
+>              renameLabel, isLabel, fpSelExt, recSelExt, recUpdExt,
+>              recordExt, labelExt, mkLabelIdent,hasPositionIdent,
+>              showsIdent,showsQualIdent,showsModuleIdent,
+>              addPositionIdent, removePositionIdent, positionOfIdent,
+>              addPositionModuleIdent, removePositionModuleIdent,addRef,addRefId,
+>              positionOfModuleIdent,positionOfQualIdent,updQualIdent ) where
+
+> import Data.Char
+> import Data.List
+> import Data.Maybe
+> import Data.Generics
+
+> import Position
+
+
+> data Ident = Ident String Int 
+>            | IdentPosition Position String Int deriving (Read,Data,Typeable)
+> data QualIdent = UnqualIdent Ident | QualIdent ModuleIdent Ident
+>                  deriving (Eq,Ord,Read,Data,Typeable)
+> data ModuleIdent = ModuleIdent [String] 
+>                   |ModuleIdentPosition Position [String] deriving (Data,Typeable)
+
+> instance Eq Ident where
+>    ident1 == ident2 = name ident1 == name     ident2 && 
+>                   uniqueId ident1 == uniqueId ident2
+
+> instance Ord ModuleIdent where
+>    mident1 `compare` mident2 =
+>        moduleQualifiers mident1 `compare` moduleQualifiers mident2
+
+> instance Eq ModuleIdent where
+>    mident1 == mident2 = moduleQualifiers mident1 == moduleQualifiers mident2 
+
+> instance Read ModuleIdent where
+>   readsPrec p s = [ (mkMIdent [m],s') | (m,s') <- readsPrec p s ]
+
+> instance Ord Ident where
+>    ident1 `compare` ident2 =
+>        (name ident1,uniqueId ident1) `compare` (name ident2,uniqueId ident2)
+
+> instance Show Ident where
+>   showsPrec _ (Ident x n)
+>     | n == 0 = showString x
+>     | otherwise = showString x . showChar '.' . shows n
+>   showsPrec _ (IdentPosition _ x n)
+>     | n == 0 = showString x
+>     | otherwise = showString x . showChar '.' . shows n
+> instance Show QualIdent where
+>   showsPrec _ (UnqualIdent x) = shows x
+>   showsPrec _ (QualIdent m x) = shows m . showChar '.' . shows x
+> instance Show ModuleIdent where
+>   showsPrec _ m = showString (moduleName m)
+
+> hasPositionIdent :: Ident -> Bool
+> hasPositionIdent (Ident _ _ ) = False
+> hasPositionIdent (IdentPosition _ _ _) = True
+
+> addPositionIdent :: Position -> Ident -> Ident
+> addPositionIdent pos (Ident x n) = IdentPosition pos x n
+> addPositionIdent AST{ast=sr} (IdentPosition pos x n) = 
+>   IdentPosition pos{ast=sr} x n
+> addPositionIdent pos (IdentPosition _ x n) = 
+>   IdentPosition pos x n
+
+> removePositionIdent :: Ident -> Ident
+> removePositionIdent (Ident x n) = (Ident x n)
+> removePositionIdent (IdentPosition _ x n) = (Ident x n)
+
+> positionOfIdent :: Ident -> Position
+> positionOfIdent (Ident _ _) = noPos
+> positionOfIdent (IdentPosition pos _ _) = pos
+
+> addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent
+> addPositionModuleIdent pos (ModuleIdent x) = ModuleIdentPosition pos x 
+> addPositionModuleIdent pos (ModuleIdentPosition _ x) = ModuleIdentPosition pos x 
+
+> removePositionModuleIdent :: ModuleIdent -> ModuleIdent
+> removePositionModuleIdent (ModuleIdent x) = (ModuleIdent x)
+> removePositionModuleIdent (ModuleIdentPosition _ x) = (ModuleIdent x)
+
+> positionOfModuleIdent :: ModuleIdent -> Position
+> positionOfModuleIdent (ModuleIdent _) = noPos
+> positionOfModuleIdent (ModuleIdentPosition pos _) = pos
+
+> positionOfQualIdent :: QualIdent -> Position
+> positionOfQualIdent = positionOfIdent . snd . splitQualIdent
+
+> mkIdent :: String -> Ident
+> mkIdent x = Ident x 0
+
+> name :: Ident -> String
+> name (Ident x _) = x
+> name (IdentPosition _ x _) = x
+
+> qualName :: QualIdent -> String
+> qualName (UnqualIdent x) = name x
+> qualName (QualIdent m x) = moduleName m ++ "." ++ name x
+
+> uniqueId :: Ident -> Int
+> uniqueId (Ident _ n) = n
+> uniqueId (IdentPosition _ _ n) = n
+
+> renameIdent :: Ident -> Int -> Ident
+> renameIdent (Ident x _) n = Ident x n
+> renameIdent (IdentPosition p x _) n = IdentPosition p x n
+
+> unRenameIdent :: Ident -> Ident
+> unRenameIdent (Ident x _) = Ident x 0
+> unRenameIdent (IdentPosition p x _) = IdentPosition p x 0
+
+> mkMIdent :: [String] -> ModuleIdent
+> mkMIdent = ModuleIdent
+
+> moduleName :: ModuleIdent -> String
+> moduleName (ModuleIdent xs) = concat (intersperse "." xs)
+> moduleName (ModuleIdentPosition _ xs) = concat (intersperse "." xs)
+
+> moduleQualifiers :: ModuleIdent -> [String]
+> moduleQualifiers (ModuleIdent xs) = xs
+> moduleQualifiers (ModuleIdentPosition _ xs) = xs
+
+> isInfixOp :: Ident -> Bool
+> isInfixOp (Ident ('<':c:cs) _)=
+>   last (c:cs) /= '>' || not (isAlphaNum c) && c `notElem` "_(["
+> isInfixOp (Ident (c:_) _) = not (isAlphaNum c) && c `notElem` "_(["
+> isInfixOp (Ident _ _) = False -- error "Zero-length identifier"
+> isInfixOp x@(IdentPosition _ _ _) = isInfixOp $ removePositionIdent x
+
+> isQInfixOp :: QualIdent -> Bool
+> isQInfixOp (UnqualIdent x) = isInfixOp x
+> isQInfixOp (QualIdent _ x) = isInfixOp x
+
+\end{verbatim}
+The functions \texttt{qualify} and \texttt{qualifyWith} convert an
+unqualified identifier into a qualified identifier (without and with a
+given module prefix, respectively).
+\begin{verbatim}
+
+> qualify :: Ident -> QualIdent
+> qualify = UnqualIdent
+
+> qualifyWith :: ModuleIdent -> Ident -> QualIdent
+> qualifyWith = QualIdent
+
+> qualQualify :: ModuleIdent -> QualIdent -> QualIdent
+> qualQualify m (UnqualIdent x) = QualIdent m x
+> qualQualify _ x = x
+
+> isQualified :: QualIdent -> Bool
+> isQualified (UnqualIdent _) = False
+> isQualified (QualIdent _ _) = True
+
+> unqualify :: QualIdent -> Ident
+> unqualify (UnqualIdent x) = x
+> unqualify (QualIdent _ x) = x
+
+> qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent
+> qualUnqualify m (UnqualIdent x) = UnqualIdent x
+> qualUnqualify m (QualIdent m' x)
+>   | m == m' = UnqualIdent x
+>   | otherwise = QualIdent m' x
+
+> localIdent :: ModuleIdent -> QualIdent -> Maybe Ident
+> localIdent _ (UnqualIdent x) = Just x
+> localIdent m (QualIdent m' x)
+>   | m == m' = Just x
+>   | otherwise = Nothing
+
+> splitQualIdent :: QualIdent -> (Maybe ModuleIdent,Ident)
+> splitQualIdent (UnqualIdent x) = (Nothing,x)
+> splitQualIdent (QualIdent m x) = (Just m,x)
+
+> updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident) -> QualIdent -> QualIdent
+> updQualIdent _ g (UnqualIdent x) = UnqualIdent (g x)
+> updQualIdent f g (QualIdent m x) = QualIdent (f m) (g x)
+
+> addRef :: SrcRef -> QualIdent -> QualIdent
+> addRef r = updQualIdent id (addRefId r)
+
+> addRefId :: SrcRef -> Ident -> Ident
+> addRefId r = addPositionIdent (AST r)
+
+\end{verbatim}
+A few identifiers a predefined here.
+\begin{verbatim}
+
+> emptyMIdent, mainMIdent, preludeMIdent :: ModuleIdent
+> emptyMIdent   = ModuleIdent []
+> mainMIdent    = ModuleIdent ["main"]
+> preludeMIdent = ModuleIdent ["Prelude"]
+
+> anonId :: Ident
+> anonId = Ident "_" 0
+
+> unitPId :: Position -> Ident
+> unitPId p = IdentPosition p "()" 0
+
+> unitId, boolId, charId, intId, floatId, listId, ioId, successId :: Ident
+> unitId    = Ident "()" 0
+> boolId    = Ident "Bool" 0
+> charId    = Ident "Char" 0
+> intId     = Ident "Int" 0
+> floatId   = Ident "Float" 0
+> listId    = Ident "[]" 0
+> ioId      = Ident "IO" 0
+> successId = Ident "Success" 0
+
+> trueId, falseId, nilId, consId :: Ident
+> trueId  = Ident "True" 0
+> falseId = Ident "False" 0
+> nilId   = Ident "[]" 0
+> consId  = Ident ":" 0
+
+> tupleId :: Int -> Ident
+> tupleId n
+>   | n >= 2 = Ident ("(" ++ replicate (n - 1) ',' ++ ")") 0
+>   | otherwise = error "internal error: tupleId"
+
+> isTupleId :: Ident -> Bool
+> isTupleId x = n > 1 && x == tupleId n
+>   where n = length (name x) - 1
+
+> tupleArity :: Ident -> Int
+> tupleArity x
+>   | n > 1 && x == tupleId n = n
+>   | otherwise = error "internal error: tupleArity"
+>   where n = length (name x) - 1
+
+> mainId, minusId, fminusId :: Ident
+> mainId = Ident "main" 0
+> minusId = Ident "-" 0
+> fminusId = Ident "-." 0
+
+> qUnitId, qNilId, qConsId, qListId :: QualIdent
+> qUnitId = UnqualIdent unitId
+> qListId = UnqualIdent listId
+> qNilId  = UnqualIdent nilId
+> qConsId = UnqualIdent consId
+
+> qBoolId, qCharId, qIntId, qFloatId, qSuccessId, qIOId :: QualIdent
+> qBoolId = QualIdent preludeMIdent boolId
+> qCharId = QualIdent preludeMIdent charId
+> qIntId = QualIdent preludeMIdent intId
+> qFloatId = QualIdent preludeMIdent floatId
+> qSuccessId = QualIdent preludeMIdent successId
+> qIOId = QualIdent preludeMIdent ioId
+
+> qTrueId, qFalseId :: QualIdent
+> qTrueId = QualIdent preludeMIdent trueId
+> qFalseId = QualIdent preludeMIdent falseId
+
+> qTupleId :: Int -> QualIdent
+> qTupleId = UnqualIdent . tupleId
+
+> isQTupleId :: QualIdent -> Bool
+> isQTupleId = isTupleId . unqualify
+
+> qTupleArity :: QualIdent -> Int
+> qTupleArity = tupleArity . unqualify
+
+\end{verbatim}
+Micellaneous function for generating and testing extended identifiers.
+\begin{verbatim}
+
+> fpSelectorId :: Int -> Ident
+> fpSelectorId n = Ident (fpSelExt ++ show n) 0
+
+> isFpSelectorId :: Ident -> Bool
+> isFpSelectorId f = any (fpSelExt `isPrefixOf`) (tails (name f))
+
+> isQualFpSelectorId :: QualIdent -> Bool
+> isQualFpSelectorId = isFpSelectorId . unqualify
+
+> recSelectorId :: QualIdent -> Ident -> Ident
+> recSelectorId r l =
+>   mkIdent (recSelExt ++ name (unqualify r) ++ "." ++ name l)
+
+> qualRecSelectorId :: ModuleIdent -> QualIdent -> Ident -> QualIdent
+> qualRecSelectorId m r l = qualifyWith m' (recSelectorId r l)
+>   where m' = (fromMaybe m (fst (splitQualIdent r)))
+
+> recUpdateId :: QualIdent -> Ident -> Ident
+> recUpdateId r l = 
+>   mkIdent (recUpdExt ++ name (unqualify r) ++ "." ++ name l)
+
+> qualRecUpdateId :: ModuleIdent -> QualIdent -> Ident -> QualIdent
+> qualRecUpdateId m r l = qualifyWith m' (recUpdateId r l)
+>   where m' = (fromMaybe m (fst (splitQualIdent r)))
+
+> recordExtId :: Ident -> Ident
+> recordExtId r = mkIdent (recordExt ++ name r)
+
+> labelExtId :: Ident -> Ident
+> labelExtId l = mkIdent (labelExt ++ name l)
+
+> fromRecordExtId :: Ident -> Ident
+> fromRecordExtId r 
+>   | p == recordExt = mkIdent r'
+>   | otherwise = r
+>  where (p,r') = splitAt (length recordExt) (name r)
+
+> fromLabelExtId :: Ident -> Ident
+> fromLabelExtId l 
+>   | p == labelExt = mkIdent l'
+>   | otherwise = l
+>  where (p,l') = splitAt (length labelExt) (name l)
+
+> isRecordExtId :: Ident -> Bool
+> isRecordExtId r = recordExt `isPrefixOf` name r
+
+> isLabelExtId :: Ident -> Bool
+> isLabelExtId l = labelExt `isPrefixOf` name l
+
+> mkLabelIdent :: String -> Ident
+> mkLabelIdent c = renameIdent (mkIdent c) (-1)
+
+> renameLabel :: Ident -> Ident
+> renameLabel l = renameIdent l (-1)
+
+> isLabel :: Ident -> Bool
+> isLabel l = uniqueId l == (-1)
+
+
+> fpSelExt = "_#selFP"
+> recSelExt = "_#selR@"
+> recUpdExt = "_#updR@"
+> recordExt = "_#Rec:"
+> labelExt = "_#Lab:"
+
+> showsString :: String -> ShowS
+> showsString = (++)
+
+> space :: ShowS
+> space = showsString " "
+
+> showsIdent :: Ident -> ShowS
+> showsIdent x@(IdentPosition _ _ _) = showsIdent $ removePositionIdent x
+> showsIdent (Ident name n)
+>   = showsString "(Ident " . shows name . space . shows n . showsString ")"
+
+> showsQualIdent :: QualIdent -> ShowS
+> showsQualIdent (UnqualIdent ident)
+>   = showsString "(UnqualIdent " . showsIdent ident . showsString ")"
+> showsQualIdent (QualIdent mident ident)
+>   = showsString "(QualIdent "
+>   . showsModuleIdent mident . space
+>   . showsIdent ident
+>   . showsString ")"
+
+> showsModuleIdent :: ModuleIdent -> ShowS
+> showsModuleIdent = shows . moduleName
+
+showsModuleIdent x@(ModuleIdentPosition _ _) = 
+    showsModuleIdent $ removePositionModuleIdent x
+showsModuleIdent (ModuleIdent []) = showsString "(ModuleIdent [])"
+showsModuleIdent (ModuleIdent (s:strs))
+  = showsString "(ModuleIdent ["
+  . foldl (\sys y -> sys . showsString "," . shows y) (shows s) strs
+  . showsString "])"
+
+\end{verbatim}
+
+> instance SrcRefOf Ident where srcRefOf = srcRefOf . positionOfIdent
+> instance SrcRefOf QualIdent where srcRefOf = srcRefOf . unqualify
+
+> updIdentName :: (String -> String) -> Ident -> Ident
+> updIdentName f ident = let p=positionOfIdent ident
+>                            i=uniqueId ident
+>                            n=name ident in
+>   addPositionIdent p $ flip renameIdent i $ mkIdent (f n)
diff --git a/src/Imports.lhs b/src/Imports.lhs
new file mode 100644
--- /dev/null
+++ b/src/Imports.lhs
@@ -0,0 +1,380 @@
+
+% $Id: Imports.lhs,v 1.25 2004/02/13 19:24:00 wlux Exp $
+%
+% Copyright (c) 2000-2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Imports.lhs}
+\section{Importing interfaces}
+This module provides a few functions which can be used to import
+interfaces into the current module.
+\begin{verbatim}
+
+> module Imports(importInterface,importInterfaceIntf,importUnifyData) where
+
+> import Data.Maybe
+
+> import Base
+> import Env
+> import TopEnv
+> import Map
+> import Set
+
+\end{verbatim}
+Four kinds of environments are computed from the interface, one
+containing the operator precedences, another for the type
+constructors, the third containing the types of the data
+constructors and functions, and the last contains the arity for each
+function and constructor. Note that the original names of all
+entities defined in the imported module are qualified appropriately.
+The same is true for type expressions.
+\begin{verbatim}
+
+> type ExpPEnv = Env Ident PrecInfo
+> type ExpTCEnv = Env Ident TypeInfo
+> type ExpValueEnv = Env Ident ValueInfo
+> type ExpArityEnv = Env Ident ArityInfo
+
+\end{verbatim}
+When an interface is imported, the compiler first transforms the
+interface into these environments. If an import specification is
+present, the environments are restricted to only those entities which
+are included in the specification or not hidden by it, respectively.
+The resulting environments are then imported into the current module
+using either a qualified import or both a qualified and an unqualified
+import.
+\begin{verbatim}
+
+> importInterface :: Position -> ModuleIdent -> Bool -> Maybe ImportSpec
+>                 -> Interface -> PEnv -> TCEnv -> ValueEnv -> ArityEnv
+>                 -> (PEnv,TCEnv,ValueEnv,ArityEnv)
+> importInterface p m q is i pEnv tcEnv tyEnv aEnv =
+>   (importEntities m q vs id mPEnv pEnv,
+>    importEntities m q ts (importData vs) mTCEnv tcEnv,
+>    importEntities m q vs id mTyEnv tyEnv,
+>    importEntities m q as id mAEnv aEnv)
+>   where mPEnv  = intfEnv bindPrec i
+>         mTCEnv = intfEnv bindTC i
+>         mTyEnv = intfEnv bindTy i
+>         mAEnv  = intfEnv bindA i
+>         is' = maybe [] (expandSpecs m mTCEnv mTyEnv) is
+>         ts  = isVisible is (fromListSet (foldr addType [] is'))
+>         vs  = isVisible is (fromListSet (foldr addValue [] is'))
+>         as  = isVisible is (fromListSet (foldr addArity [] is'))
+
+> isVisible :: Maybe ImportSpec -> Set Ident -> Ident -> Bool
+> isVisible (Just (Importing _ _)) xs = (`elemSet` xs)
+> isVisible (Just (Hiding _ _)) xs = (`notElemSet` xs)
+> isVisible _ _ = const True
+
+> importEntities :: Entity a => ModuleIdent -> Bool -> (Ident -> Bool)
+>                -> (a -> a) -> Env Ident a -> TopEnv a -> TopEnv a
+> importEntities m q isVisible f mEnv env =
+>   foldr (uncurry (if q then qualImportTopEnv m else importUnqual m)) env
+>         [(x,f y) | (x,y) <- envToList mEnv, isVisible x]
+>   where importUnqual m x y = importTopEnv m x y . qualImportTopEnv m x y
+
+> importData :: (Ident -> Bool) -> TypeInfo -> TypeInfo
+> importData isVisible (DataType tc n cs) =
+>   DataType tc n (map (>>= importConstr isVisible) cs)
+> importData isVisible (RenamingType tc n nc) =
+>   maybe (DataType tc n []) (RenamingType tc n) (importConstr isVisible nc)
+> importData isVisible (AliasType tc  n ty) = AliasType tc n ty
+
+> importConstr :: (Ident -> Bool) -> Data a -> Maybe (Data a)
+> importConstr isVisible (Data c n tys)
+>   | isVisible c = Just (Data c n tys)
+>   | otherwise = Nothing
+
+\end{verbatim}
+Importing an interface into another interface is somewhat simpler
+because all entities are imported into the environment. In addition,
+only a qualified import is necessary. Note that the hidden data types
+are imported as well because they may be used in type expressions in
+an interface.
+\begin{verbatim}
+
+> importInterfaceIntf :: Interface -> PEnv -> TCEnv -> ValueEnv -> ArityEnv
+>                     -> (PEnv,TCEnv,ValueEnv,ArityEnv)
+> importInterfaceIntf i pEnv tcEnv tyEnv aEnv =
+>   (importEntities m True (const True) id (intfEnv bindPrec i) pEnv,
+>    importEntities m True (const True) id (intfEnv bindTCHidden i) tcEnv,
+>    importEntities m True (const True) id (intfEnv bindTy i) tyEnv,
+>    importEntities m True (const True) id (intfEnv bindA i) aEnv)
+>   where Interface m _ = i
+
+\end{verbatim}
+In a first step, the three export environments are initialized from
+the interface's declarations. This step also qualifies the names of
+all entities defined in (but not imported into) the interface with its
+module name.  
+\begin{verbatim}
+
+> intfEnv :: (ModuleIdent -> IDecl -> Env Ident a -> Env Ident a)
+>         -> Interface -> Env Ident a
+> intfEnv bind (Interface m ds) = foldr (bind m) emptyEnv ds
+
+> bindPrec :: ModuleIdent -> IDecl -> ExpPEnv -> ExpPEnv
+> bindPrec m (IInfixDecl _ fix p op) =
+>   bindEnv (unqualify op) (PrecInfo (qualQualify m op) (OpPrec fix p))
+> bindPrec _ _ = id
+
+> bindTC :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv
+> bindTC m (IDataDecl _ tc tvs cs) mTCEnv 
+>   | isJust (lookupEnv (unqualify tc) mTCEnv) =
+>     mTCEnv
+>   | otherwise =
+>     bindType DataType m tc tvs (map (fmap mkData) cs) mTCEnv
+>   where mkData (ConstrDecl _ evs c tys) =
+>           Data c (length evs) (toQualTypes m tvs tys)
+>         mkData (ConOpDecl _ evs ty1 c ty2) =
+>           Data c (length evs) (toQualTypes m tvs [ty1,ty2])
+> bindTC m (INewtypeDecl _ tc tvs (NewConstrDecl _ evs c ty)) mTCEnv =
+>   bindType RenamingType m tc tvs 
+>	 (Data c (length evs) (toQualType m tvs ty)) mTCEnv
+> bindTC m (ITypeDecl _ tc tvs ty) mTCEnv
+>   | isRecordExtId tc' = 
+>     bindType AliasType m (qualify (fromRecordExtId tc')) tvs 
+>	   (toQualType m tvs ty) mTCEnv
+>   | otherwise =
+>     bindType AliasType m tc tvs (toQualType m tvs ty) mTCEnv
+>   where tc' = unqualify tc
+> bindTC m _ mTCEnv = mTCEnv
+
+> bindTCHidden :: ModuleIdent -> IDecl -> ExpTCEnv -> ExpTCEnv
+> bindTCHidden m (HidingDataDecl _ tc tvs) =
+>   bindType DataType m (qualify tc) tvs []
+> bindTCHidden m d = bindTC m d
+
+> bindType :: (QualIdent -> Int -> a -> TypeInfo) -> ModuleIdent -> QualIdent
+>          -> [Ident] -> a -> ExpTCEnv -> ExpTCEnv
+> bindType f m tc tvs =
+>   bindEnv (unqualify tc) . f (qualQualify m tc) (length tvs) 
+
+> bindTy :: ModuleIdent -> IDecl -> ExpValueEnv -> ExpValueEnv
+> bindTy m (IDataDecl _ tc tvs cs) =
+>   flip (foldr (bindConstr m tc' tvs (constrType tc' tvs))) (catMaybes cs)
+>   where tc' = qualQualify m tc
+> bindTy m (INewtypeDecl _ tc tvs nc) =
+>   bindNewConstr m tc' tvs (constrType tc' tvs) nc
+>   where tc' = qualQualify m tc
+> --bindTy m (ITypeDecl _ r tvs (RecordType fs _)) =
+> --  flip (foldr (bindRecLabel m r')) fs
+> --  where r' = qualifyWith m (fromRecordExtId (unqualify r))
+> bindTy m (IFunctionDecl _ f _ ty) =
+>   bindEnv (unqualify f)
+>           (Value (qualQualify m f) (polyType (toQualType m [] ty)))
+> bindTy m _ = id
+
+> bindConstr :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr -> ConstrDecl
+>            -> ExpValueEnv -> ExpValueEnv
+> bindConstr m tc tvs ty0 (ConstrDecl _ evs c tys) =
+>   bindValue DataConstructor m tc tvs c evs (foldr ArrowType ty0 tys)
+> bindConstr m tc tvs ty0 (ConOpDecl _ evs ty1 op ty2) =
+>   bindValue DataConstructor m tc tvs op evs
+>             (ArrowType ty1 (ArrowType ty2 ty0))
+
+> bindNewConstr :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr
+>               -> NewConstrDecl -> ExpValueEnv -> ExpValueEnv
+> bindNewConstr m tc tvs ty0 (NewConstrDecl _ evs c ty1) =
+>   bindValue NewtypeConstructor m tc tvs c evs (ArrowType ty1 ty0)
+
+> --bindRecLabel :: ModuleIdent -> QualIdent -> ([Ident],TypeExpr)
+> --      -> ExpValueEnv -> ExpValueEnv
+> --bindRecLabel m r ([l],ty) =
+> --  bindEnv l (Label (qualify l) r (polyType (toQualType m [] ty)))
+
+> bindValue :: (QualIdent -> ExistTypeScheme -> ValueInfo) -> ModuleIdent
+>           -> QualIdent -> [Ident] -> Ident -> [Ident] -> TypeExpr
+>           -> ExpValueEnv -> ExpValueEnv
+> bindValue f m tc tvs c evs ty = bindEnv c (f (qualifyLike tc c) sigma)
+>   where sigma = ForAllExist (length tvs) (length evs) (toQualType m tvs ty)
+>         qualifyLike x = maybe qualify qualifyWith (fst (splitQualIdent x))
+
+> bindA :: ModuleIdent -> IDecl -> ExpArityEnv -> ExpArityEnv
+> bindA m (IDataDecl _ _ _ cs) expAEnv
+>    = foldr (bindConstrA m) expAEnv (catMaybes cs)
+> bindA m (IFunctionDecl _ f a _) expAEnv
+>    = bindEnv (unqualify f) (ArityInfo (qualQualify m f) a) expAEnv
+> bindA _ _ expAEnv = expAEnv
+
+> bindConstrA :: ModuleIdent -> ConstrDecl -> ExpArityEnv -> ExpArityEnv
+> bindConstrA m (ConstrDecl _ _ c tys) expAEnv
+>    = bindEnv c (ArityInfo (qualifyWith m c) (length tys)) expAEnv
+> bindConstrA m (ConOpDecl _ _ _ c _) expAEnv
+>    = bindEnv c (ArityInfo (qualifyWith m c) 2) expAEnv
+
+\end{verbatim}
+After the environments have been initialized, the optional import
+specifications can be checked. There are two kinds of import
+specifications, a ``normal'' one, which names the entities that shall
+be imported, and a hiding specification, which lists those entities
+that shall not be imported.
+
+There is a subtle difference between both kinds of
+specifications. While it is not allowed to list a data constructor
+outside of its type in a ``normal'' specification, it is allowed to
+hide a data constructor explicitly. E.g., if module \texttt{A} exports
+the data type \texttt{T} with constructor \texttt{C}, the data
+constructor can be imported with one of the two specifications
+\begin{verbatim}
+import A(T(C))
+import A(T(..))
+\end{verbatim}
+but can be hidden in three different ways:
+\begin{verbatim}
+import A hiding(C)
+import A hiding(T(C))
+import A hiding(T(..))
+\end{verbatim}
+
+The functions \texttt{expandImport} and \texttt{expandHiding} check
+that all entities in an import specification are actually exported
+from the module. In addition, all imports of type constructors are
+changed into a \texttt{T()} specification and explicit imports for the
+data constructors are added.
+\begin{verbatim}
+
+> expandSpecs :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> ImportSpec
+>             -> [Import]
+> expandSpecs m tcEnv tyEnv (Importing _ is) =
+>   concat (map (expandImport m tcEnv tyEnv) is)
+> expandSpecs m tcEnv tyEnv (Hiding _ is) =
+>   concat (map (expandHiding m tcEnv tyEnv) is)
+
+> expandImport :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Import
+>              -> [Import]
+> expandImport m tcEnv tyEnv (Import x) = expandThing m tcEnv tyEnv x
+> expandImport m tcEnv tyEnv (ImportTypeWith tc cs) =
+>   [expandTypeWith m tcEnv tc cs]
+> expandImport m tcEnv tyEnv (ImportTypeAll tc) =
+>   [expandTypeAll m tcEnv tc]
+
+> expandHiding :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Import
+>              -> [Import]
+> expandHiding m tcEnv tyEnv (Import x) = expandHide m tcEnv tyEnv x
+> expandHiding m tcEnv tyEnv (ImportTypeWith tc cs) =
+>   [expandTypeWith m tcEnv tc cs]
+> expandHiding m tcEnv tyEnv (ImportTypeAll tc) =
+>   [expandTypeAll m tcEnv tc]
+
+> expandThing :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident
+>             -> [Import]
+> expandThing m tcEnv tyEnv tc =
+>   case lookupEnv tc tcEnv of
+>     Just _ -> expandThing' m tyEnv tc (Just [ImportTypeWith tc []])
+>     Nothing -> expandThing' m tyEnv tc Nothing
+
+> expandThing' :: ModuleIdent -> ExpValueEnv -> Ident
+>              -> Maybe [Import] -> [Import]
+> expandThing' m tyEnv f tcImport =
+>   case lookupEnv f tyEnv of
+>     Just v
+>       | isConstr v -> maybe (errorAt' (importDataConstr m f)) id tcImport
+>       | otherwise -> Import f : maybe [] id tcImport
+>     Nothing -> maybe (errorAt' (undefinedEntity m f)) id tcImport
+>   where isConstr (DataConstructor _ _) = True
+>         isConstr (NewtypeConstructor _ _) = True
+>         isConstr (Value _ _) = False
+
+> expandHide :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident
+>            -> [Import]
+> expandHide m tcEnv tyEnv tc =
+>   case lookupEnv tc tcEnv of
+>     Just _ -> expandHide' m tyEnv tc (Just [ImportTypeWith tc []])
+>     Nothing -> expandHide' m tyEnv tc Nothing
+
+> expandHide' :: ModuleIdent -> ExpValueEnv -> Ident
+>             -> Maybe [Import] -> [Import]
+> expandHide' m tyEnv f tcImport =
+>   case lookupEnv f tyEnv of
+>     Just _ -> Import f : maybe [] id tcImport
+>     Nothing -> maybe (errorAt' (undefinedEntity m f)) id tcImport
+
+> expandTypeWith ::  ModuleIdent -> ExpTCEnv -> Ident -> [Ident]
+>                -> Import
+> expandTypeWith m tcEnv tc cs =
+>   case lookupEnv tc tcEnv of
+>     Just (DataType _ _ cs') ->
+>       ImportTypeWith tc (map (checkConstr [c | Just (Data c _ _) <- cs']) cs)
+>     Just (RenamingType _ _ (Data c _ _)) ->
+>       ImportTypeWith tc (map (checkConstr [c]) cs)
+>     Just _ -> errorAt' (nonDataType m tc)
+>     Nothing -> errorAt' (undefinedEntity m tc)
+>   where checkConstr cs c
+>           | c `elem` cs = c
+>           | otherwise = errorAt' (undefinedDataConstr m tc c)
+
+> expandTypeAll :: ModuleIdent -> ExpTCEnv -> Ident -> Import
+> expandTypeAll m tcEnv tc =
+>   case lookupEnv tc tcEnv of
+>     Just (DataType _ _ cs) -> ImportTypeWith tc [c | Just (Data c _ _) <- cs]
+>     Just (RenamingType _ _ (Data c _ _)) -> ImportTypeWith tc [c]
+>     Just _ -> errorAt' (nonDataType m tc)
+>     Nothing -> errorAt' (undefinedEntity m tc)
+
+\end{verbatim}
+After all modules have been imported, the compiler has to ensure that
+all references to a data type use the same list of constructors.
+\begin{verbatim}
+
+> importUnifyData :: TCEnv -> TCEnv
+> importUnifyData tcEnv =
+>   fmap (setInfo (foldr (mergeData . snd) zeroFM (allImports tcEnv))) tcEnv
+>   where setInfo tcs t = fromJust (lookupFM (origName t) tcs)
+>         mergeData t tcs =
+>           addToFM tc (maybe t (fromJust . merge t) (lookupFM tc tcs)) tcs
+>           where tc = origName t
+
+\end{verbatim}
+Auxiliary functions:
+\begin{verbatim}
+
+> addType :: Import -> [Ident] -> [Ident]
+> addType (Import _) tcs = tcs
+> addType (ImportTypeWith tc _) tcs = tc : tcs
+> addType (ImportTypeAll _) _ = internalError "types"
+
+> addValue :: Import -> [Ident] -> [Ident]
+> addValue (Import f) fs = f : fs
+> addValue (ImportTypeWith _ cs) fs = cs ++ fs
+> addValue (ImportTypeAll _) _ = internalError "values"
+
+> addArity :: Import -> [Ident] -> [Ident]
+> addArity (Import f) ids = f:ids
+> addArity (ImportTypeWith _ cs) ids = cs ++ ids
+> addArity (ImportTypeAll _) _ = internalError "arities"
+
+> constrType :: QualIdent -> [Ident] -> TypeExpr
+> constrType tc tvs = ConstructorType tc (map VariableType tvs)
+
+\end{verbatim}
+Error messages:
+\begin{verbatim}
+
+> undefinedEntity :: ModuleIdent -> Ident -> (Position,String)
+> undefinedEntity m x =
+>  (positionOfIdent x,
+>   "Module " ++ moduleName m ++ " does not export " ++ name x)
+
+> undefinedType :: ModuleIdent -> Ident -> (Position,String)
+> undefinedType m tc =
+>  (positionOfIdent tc,   
+>   "Module " ++ moduleName m ++ " does not export a type " ++ name tc)
+
+> undefinedDataConstr :: ModuleIdent -> Ident -> Ident -> (Position,String)
+> undefinedDataConstr m tc c =
+>  (positionOfIdent c,   
+>   name c ++ " is not a data constructor of type " ++ name tc)
+
+> nonDataType :: ModuleIdent -> Ident -> (Position,String)
+> nonDataType m tc = 
+>  (positionOfIdent tc,
+>   name tc ++ " is not a data type")
+
+> importDataConstr :: ModuleIdent -> Ident -> (Position,String)
+> importDataConstr m c = 
+>  (positionOfIdent c,
+>   "Explicit import for data constructor " ++ name c)
+
+\end{verbatim}
diff --git a/src/InterfaceCheck.hs b/src/InterfaceCheck.hs
new file mode 100644
--- /dev/null
+++ b/src/InterfaceCheck.hs
@@ -0,0 +1,142 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- InterfaceCheck - Checks the equality of the interfaces of two FlatCurry 
+--                  programs 
+--
+-- January 2006,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+module InterfaceCheck where
+
+import Data.List
+
+import ExtendedFlat
+
+
+
+-------------------------------------------------------------------------------
+
+-- Checks whether the interfaces of two FlatCurry programs are equal 
+interfaceCheck :: Prog -> Prog -> Bool
+interfaceCheck (Prog m1 is1 ts1 fs1 os1) (Prog m2 is2 ts2 fs2 os2)
+   = m1 == m2 
+     && sort is1 == sort is2
+     && checkTypeDecls ts1 ts2
+     && checkFuncDecls fs1 fs2
+     && checkOpDecls os1 os2
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+--
+checkTypeDecls :: [TypeDecl] -> [TypeDecl] -> Bool
+checkTypeDecls ts1 [] = null ts1
+checkTypeDecls ts1 ((Type qname vis2 is2 cs2):ts2')
+   = let (mt,ts1') = extract (isDataType qname) ts1
+     in  maybe False 
+               (\ (Type _ vis1 is1 cs1) 
+		-> vis1 == vis2 
+		   && is1 == is2 
+		   && checkConsDecls cs1 cs2
+		   && checkTypeDecls ts1' ts2')
+	       mt
+checkTypeDecls ts1 ((TypeSyn qname vis2 is2 texpr2):ts2')
+   = let (mt,ts1') = extract (isTypeSyn qname) ts1
+     in  maybe False
+	       (\ (TypeSyn _ vis1 is1 texpr1)
+		-> vis1 == vis2
+		   && is1 == is2
+		   && texpr1 == texpr2
+		   && checkTypeDecls ts1' ts2')
+	       mt
+
+--
+checkConsDecls :: [ConsDecl] -> [ConsDecl] -> Bool
+checkConsDecls cs1 [] = null cs1
+checkConsDecls cs1 ((Cons qname arity2 vis2 texprs2):cs2')
+   = let (mc,cs1') = extract (isCons qname) cs1
+     in  maybe False
+	       (\ (Cons _ arity1 vis1 texprs1)
+		-> arity1 == arity2
+		   && vis1 == vis2
+		   && texprs1 == texprs2
+		   && checkConsDecls cs1' cs2')
+	       mc
+
+--
+checkFuncDecls :: [FuncDecl] -> [FuncDecl] -> Bool
+checkFuncDecls fs1 [] = null fs1
+checkFuncDecls fs1 ((Func qname arity2 vis2 texpr2 rule2):fs2')
+   = let (mf,fs1') = extract (isFunc qname) fs1
+     in  maybe False
+	       (\ (Func _ arity1 vis1 texpr1 rule1)
+		-> arity1 == arity2
+		   && vis1 == vis2
+		   && texpr1 == texpr2
+		   && checkRule rule1 rule2
+		   && checkFuncDecls fs1' fs2')
+	       mf
+
+--
+checkRule :: Rule -> Rule -> Bool
+checkRule (Rule _ _)   (Rule _ _)   = True
+checkRule (External _) (External _) = True
+checkRule _            _            = False
+
+--
+checkOpDecls :: [OpDecl] -> [OpDecl] -> Bool
+checkOpDecls os1 [] = null os1
+checkOpDecls os1 ((Op qname fix2 prec2):os2')
+   = let (mo,os1') = extract (isOp qname) os1
+     in  maybe False
+	       (\ (Op _ fix1 prec1)
+		-> prec1 == prec2
+		   && fix1 == fix2
+		   && checkOpDecls os1' os2')
+	       mo
+
+
+-------------------------------------------------------------------------------
+
+--
+isDataType :: QName -> TypeDecl -> Bool
+isDataType qname (Type qname' _ _ _) = qname == qname'
+isDataType _     _                   = False
+
+--
+isTypeSyn :: QName -> TypeDecl -> Bool
+isTypeSyn qname (TypeSyn qname' _ _ _) = qname == qname'
+isTypeSyn _     _                      = False
+
+--
+isCons :: QName -> ConsDecl -> Bool
+isCons qname (Cons qname' _ _ _) = qname == qname'
+
+--
+isFunc :: QName -> FuncDecl -> Bool
+isFunc qname (Func qname' _ _ _ _) = qname == qname'
+
+--
+isOp :: QName -> OpDecl -> Bool
+isOp qname (Op qname' _ _) = qname == qname'
+
+
+-------------------------------------------------------------------------------
+
+--
+extract :: (a -> Bool) -> [a] -> (Maybe a, [a])
+extract _ [] = (Nothing, [])
+extract c (x:xs) | c x       = (Just x, xs)
+		 | otherwise = let (res, xs') = extract c xs in (res, x:xs')
+
+{-
+-- Alternativ:
+extract :: (a -> Bool) -> [a] -> (Maybe a, [a])
+extract c xs = maybe (Nothing, xs) (\x -> (Just x, delete x xs)) (find c xs)
+-}
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/KindCheck.lhs b/src/KindCheck.lhs
new file mode 100644
--- /dev/null
+++ b/src/KindCheck.lhs
@@ -0,0 +1,322 @@
+
+% $Id: KindCheck.lhs,v 1.33 2004/02/13 19:24:04 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{KindCheck.lhs}
+\section{Checking Type Definitions}
+After the source file has been parsed and all modules have been
+imported, the compiler first performs kind checking on all type
+definitions and signatures. Because Curry currently does not support
+type classes, kind checking is rather trivial. All types must be of
+first order kind ($\star$), i.e., all type constructor applications
+must be saturated.
+
+During kind checking, this module will also disambiguate nullary
+constructors and type variables which -- in contrast to Haskell -- is
+not possible on purely syntactic criteria. In addition it is checked
+that all type constructors and type variables occurring on the right
+hand side of a type declaration are actually defined and no identifier
+is defined more than once.
+\begin{verbatim}
+
+> module KindCheck(kindCheck,kindCheckGoal) where
+
+> import Data.Maybe
+
+> import Base hiding (bindArity)
+> import TopEnv
+
+\end{verbatim}
+In order to check type constructor applications, the compiler
+maintains an environment containing the kind information for all type
+constructors. The function \texttt{kindCheck} first initializes this
+environment by filtering out the arity of each type constructor from
+the imported type environment. Next, the arities of all locally
+defined type constructors are inserted into the environment, and,
+finally, the declarations are checked within this environment.
+\begin{verbatim}
+
+> kindCheck :: ModuleIdent -> TCEnv -> [Decl] -> [Decl]
+> kindCheck m tcEnv ds =
+>   case linear (map tconstr ds') of
+>     Linear -> map (checkDecl m kEnv) ds
+>     NonLinear (PIdent p tc) -> errorAt' (duplicateType tc)
+>   where ds' = filter isTypeDecl ds
+>         kEnv = foldr (bindArity m) (fmap tcArity tcEnv) ds'
+
+> kindCheckGoal :: TCEnv -> Goal -> Goal
+> kindCheckGoal tcEnv (Goal p e ds) =
+>   Goal p (checkExpr m kEnv e) (map (checkDecl m kEnv) ds)
+>   where kEnv = fmap tcArity tcEnv
+>	  m = mkMIdent []
+
+\end{verbatim}
+The kind environment only needs to record the arity of each type constructor.
+\begin{verbatim}
+
+> type KindEnv = TopEnv Int
+
+> bindArity :: ModuleIdent -> Decl -> KindEnv -> KindEnv
+> bindArity m (DataDecl _ tc tvs _) = bindArity' m  tc tvs
+> bindArity m (NewtypeDecl _ tc tvs _) = bindArity' m  tc tvs
+> bindArity m (TypeDecl _ tc tvs _) = bindArity' m  tc tvs
+> bindArity _ _ = id
+
+> bindArity' :: ModuleIdent -> Ident -> [Ident]
+>            -> KindEnv -> KindEnv
+> bindArity' m tc tvs 
+>   = bindTopEnv "KindCheck.bindArity'" tc n 
+>                . qualBindTopEnv "KindCheck.bindArity'" (qualifyWith m tc) n
+>   where n = length tvs
+
+> lookupKind :: Ident -> KindEnv -> [Int]
+> lookupKind = lookupTopEnv
+
+> qualLookupKind :: QualIdent -> KindEnv -> [Int]
+> qualLookupKind = qualLookupTopEnv
+
+\end{verbatim}
+When type declarations are checked, the compiler will allow anonymous
+type variables on the left hand side of the declaration, but not on
+the right hand side. Function and pattern declarations must be
+traversed because they can contain local type signatures.
+\begin{verbatim}
+
+> checkDecl :: ModuleIdent -> KindEnv -> Decl -> Decl
+> checkDecl m kEnv (DataDecl p tc tvs cs) =
+>   DataDecl p tc tvs' (map (checkConstrDecl m kEnv tvs') cs)
+>   where tvs' = checkTypeLhs kEnv tvs
+> checkDecl m kEnv (NewtypeDecl p tc tvs nc) =
+>   NewtypeDecl p tc tvs' (checkNewConstrDecl m kEnv tvs' nc)
+>   where tvs' = checkTypeLhs kEnv tvs
+> checkDecl m kEnv (TypeDecl p tc tvs ty) =
+>   TypeDecl p tc tvs' (checkClosedType m kEnv tvs' ty)
+>   where tvs' = checkTypeLhs kEnv tvs
+> checkDecl m kEnv (TypeSig p vs ty) =
+>   TypeSig p vs (checkType m kEnv ty)
+> checkDecl m kEnv (FunctionDecl p f eqs) =
+>   FunctionDecl p f (map (checkEquation m kEnv) eqs)
+> checkDecl m kEnv (PatternDecl p t rhs) =
+>   PatternDecl p t (checkRhs m kEnv rhs)
+> checkDecl m kEnv (ExternalDecl p cc ie f ty) =
+>   ExternalDecl p cc ie f (checkType m kEnv ty)
+> checkDecl _ _ d = d
+
+> checkTypeLhs :: KindEnv -> [Ident] -> [Ident]
+> checkTypeLhs kEnv (tv:tvs)
+>   | tv == anonId = tv : checkTypeLhs kEnv tvs
+>   | isTypeConstr tv = errorAt' (noVariable tv)
+>   | tv `elem` tvs = errorAt' (nonLinear tv)
+>   | otherwise = tv : checkTypeLhs kEnv tvs
+>   where isTypeConstr tv = not (null (lookupKind tv kEnv))
+> checkTypeLhs kEnv [] = []
+
+> checkConstrDecl :: ModuleIdent -> KindEnv -> [Ident] -> ConstrDecl -> ConstrDecl
+> checkConstrDecl m kEnv tvs (ConstrDecl p evs c tys) =
+>   ConstrDecl p evs' c (map (checkClosedType m kEnv tvs') tys)
+>   where evs' = checkTypeLhs kEnv evs
+>         tvs' = evs' ++ tvs
+> checkConstrDecl m kEnv tvs (ConOpDecl p evs ty1 op ty2) =
+>   ConOpDecl p evs' (checkClosedType m kEnv tvs' ty1) op
+>             (checkClosedType m kEnv tvs' ty2)
+>   where evs' = checkTypeLhs kEnv evs
+>         tvs' = evs' ++ tvs
+
+> checkNewConstrDecl :: ModuleIdent -> KindEnv -> [Ident] -> NewConstrDecl 
+>	     -> NewConstrDecl
+> checkNewConstrDecl m kEnv tvs (NewConstrDecl p evs c ty) =
+>   NewConstrDecl p evs' c (checkClosedType m kEnv tvs' ty)
+>   where evs' = checkTypeLhs kEnv evs
+>         tvs' = evs' ++ tvs
+
+\end{verbatim}
+Checking expressions is rather straight forward. The compiler must
+only traverse the structure of expressions in order to find local
+declaration groups.
+\begin{verbatim}
+
+> checkEquation :: ModuleIdent -> KindEnv -> Equation -> Equation
+> checkEquation m kEnv (Equation p lhs rhs) = 
+>     Equation p lhs (checkRhs m kEnv rhs)
+
+> checkRhs :: ModuleIdent -> KindEnv -> Rhs -> Rhs
+> checkRhs m kEnv (SimpleRhs p e ds) =
+>   SimpleRhs p (checkExpr m kEnv e) (map (checkDecl m kEnv) ds)
+> checkRhs m kEnv (GuardedRhs es ds) =
+>   GuardedRhs (map (checkCondExpr m kEnv) es) (map (checkDecl m kEnv) ds)
+
+> checkCondExpr :: ModuleIdent -> KindEnv -> CondExpr -> CondExpr
+> checkCondExpr m kEnv (CondExpr p g e) =
+>   CondExpr p (checkExpr m kEnv g) (checkExpr m kEnv e)
+
+> checkExpr :: ModuleIdent -> KindEnv -> Expression -> Expression
+> checkExpr _ _ (Literal l) = Literal l
+> checkExpr _ _ (Variable v) = Variable v
+> checkExpr _ _ (Constructor c) = Constructor c
+> checkExpr m kEnv (Paren e) = Paren (checkExpr m kEnv e)
+> checkExpr m kEnv (Typed e ty) =
+>   Typed (checkExpr m kEnv e) (checkType m kEnv ty)
+> checkExpr m kEnv (Tuple p es) = Tuple p (map (checkExpr m kEnv ) es)
+> checkExpr m kEnv (List p es) = List p (map (checkExpr m kEnv ) es)
+> checkExpr m kEnv (ListCompr p e qs) =
+>   ListCompr p (checkExpr m kEnv e) (map (checkStmt m kEnv ) qs)
+> checkExpr m kEnv  (EnumFrom e) = EnumFrom (checkExpr m kEnv  e)
+> checkExpr m kEnv  (EnumFromThen e1 e2) =
+>   EnumFromThen (checkExpr m kEnv  e1) (checkExpr m kEnv  e2)
+> checkExpr m kEnv  (EnumFromTo e1 e2) =
+>   EnumFromTo (checkExpr m kEnv  e1) (checkExpr m kEnv  e2)
+> checkExpr m kEnv  (EnumFromThenTo e1 e2 e3) =
+>   EnumFromThenTo (checkExpr m kEnv  e1) (checkExpr m kEnv  e2)
+>                  (checkExpr m kEnv  e3)
+> checkExpr m kEnv  (UnaryMinus op e) = UnaryMinus op (checkExpr m kEnv  e)
+> checkExpr m kEnv  (Apply e1 e2) =
+>   Apply (checkExpr m kEnv  e1) (checkExpr m kEnv  e2)
+> checkExpr m kEnv  (InfixApply e1 op e2) =
+>   InfixApply (checkExpr m kEnv  e1) op (checkExpr m kEnv  e2)
+> checkExpr m kEnv  (LeftSection e op) = LeftSection (checkExpr m kEnv  e) op
+> checkExpr m kEnv  (RightSection op e) = RightSection op (checkExpr m kEnv  e)
+> checkExpr m kEnv  (Lambda r ts e) = Lambda r ts (checkExpr m kEnv  e)
+> checkExpr m kEnv  (Let ds e) =
+>   Let (map (checkDecl m kEnv) ds) (checkExpr m kEnv  e)
+> checkExpr m kEnv  (Do sts e) =
+>   Do (map (checkStmt m kEnv ) sts) (checkExpr m kEnv  e)
+> checkExpr m kEnv  (IfThenElse r e1 e2 e3) =
+>   IfThenElse r (checkExpr m kEnv  e1) (checkExpr m kEnv  e2)
+>              (checkExpr m kEnv  e3)
+> checkExpr m kEnv  (Case r e alts) =
+>   Case r (checkExpr m kEnv  e) (map (checkAlt m kEnv) alts)
+> checkExpr m kEnv  (RecordConstr fs) =
+>   RecordConstr (map (checkFieldExpr m kEnv) fs)
+> checkExpr m kEnv  (RecordSelection e l) =
+>   RecordSelection (checkExpr m kEnv  e) l
+> checkExpr m kEnv  (RecordUpdate fs e) =
+>   RecordUpdate (map (checkFieldExpr m kEnv) fs) (checkExpr m kEnv  e)
+
+> checkStmt :: ModuleIdent -> KindEnv -> Statement -> Statement
+> checkStmt m kEnv  (StmtExpr p e) = StmtExpr p (checkExpr m kEnv  e)
+> checkStmt m kEnv  (StmtBind p t e) = StmtBind p t (checkExpr m kEnv  e)
+> checkStmt m kEnv  (StmtDecl ds) = StmtDecl (map (checkDecl m kEnv) ds)
+
+> checkAlt :: ModuleIdent -> KindEnv -> Alt -> Alt
+> checkAlt m kEnv (Alt p t rhs) = Alt p t (checkRhs m kEnv rhs)
+
+> checkFieldExpr :: ModuleIdent -> KindEnv -> Field Expression
+>	            -> Field Expression
+> checkFieldExpr m kEnv (Field p l e) = Field p l (checkExpr m kEnv e)
+
+\end{verbatim}
+The parser cannot distinguish unqualified nullary type constructors
+and type variables. Therefore, if the compiler finds an unbound
+identifier in a position where a type variable is admissible, it will
+interpret the identifier as such.
+\begin{verbatim}
+
+> checkClosedType :: ModuleIdent -> KindEnv -> [Ident] -> TypeExpr 
+>	  -> TypeExpr
+> checkClosedType m kEnv tvs ty = checkClosed tvs (checkType m kEnv  ty)
+
+> checkType :: ModuleIdent -> KindEnv -> TypeExpr -> TypeExpr
+> checkType m kEnv (ConstructorType tc tys) =
+>   case qualLookupKind tc kEnv of
+>     []
+>       | not (isQualified tc) && null tys -> VariableType (unqualify tc)
+>       | otherwise -> errorAt' (undefinedType tc)
+>     [n]
+>       | n == n' -> ConstructorType tc (map (checkType m kEnv ) tys)
+>       | otherwise -> errorAt' (wrongArity tc n n')
+>     _ -> case (qualLookupKind (qualQualify m tc) kEnv) of
+>            [n] 
+>               | n == n' -> ConstructorType tc (map (checkType m kEnv ) tys)
+>               | otherwise -> errorAt' (wrongArity tc n n')
+>            _ -> errorAt' (ambiguousType tc)
+>  where n' = length tys 
+> checkType m kEnv  (VariableType tv)
+>   | tv == anonId = VariableType tv
+>   | otherwise = checkType m kEnv  (ConstructorType (qualify tv) [])
+> checkType m kEnv  (TupleType tys) =
+>   TupleType (map (checkType m kEnv ) tys)
+> checkType m kEnv  (ListType ty) =
+>   ListType (checkType m kEnv  ty)
+> checkType m kEnv  (ArrowType ty1 ty2) =
+>   ArrowType (checkType m kEnv  ty1) (checkType m kEnv  ty2)
+> checkType m kEnv  (RecordType fs r) =
+>   RecordType (map (\ (ls,ty) -> (ls, checkType m kEnv  ty)) fs)
+>	       (maybe Nothing (Just . checkType m kEnv ) r)
+
+> checkClosed :: [Ident] -> TypeExpr -> TypeExpr
+> checkClosed tvs (ConstructorType tc tys) =
+>   ConstructorType tc (map (checkClosed tvs) tys)
+> checkClosed tvs (VariableType tv)
+>   | tv == anonId || tv `notElem` tvs = errorAt' (unboundVariable tv)
+>   | otherwise = VariableType tv
+> checkClosed tvs (TupleType tys) =
+>   TupleType (map (checkClosed tvs) tys)
+> checkClosed tvs (ListType ty) =
+>   ListType (checkClosed tvs ty)
+> checkClosed tvs (ArrowType ty1 ty2) =
+>   ArrowType (checkClosed tvs ty1) (checkClosed tvs ty2)
+> checkClosed tvs (RecordType fs r) =
+>   RecordType (map (\ (ls,ty) -> (ls, checkClosed tvs ty)) fs)
+>	       (maybe Nothing (Just . checkClosed tvs) r)
+>       
+
+\end{verbatim}
+Auxiliary definitions
+\begin{verbatim}
+
+> tconstr :: Decl -> PIdent
+> tconstr (DataDecl p tc _ _) = PIdent p tc
+> tconstr (NewtypeDecl p tc _ _) = PIdent p tc
+> tconstr (TypeDecl p tc _ _) = PIdent p tc
+> tconstr _ = internalError "tconstr"
+
+\end{verbatim}
+Error messages:
+\begin{verbatim}
+
+> undefinedType :: QualIdent -> (Position,String)
+> undefinedType tc = 
+>     (positionOfQualIdent tc,
+>      "Undefined type " ++ qualName tc)
+
+> ambiguousType :: QualIdent -> (Position,String)
+> ambiguousType tc = 
+>     (positionOfQualIdent tc,
+>      "Ambiguous type " ++ qualName tc)
+
+> duplicateType :: Ident -> (Position,String)
+> duplicateType tc = 
+>     (positionOfIdent tc,
+>      "More than one definition for type " ++ name tc)
+
+> nonLinear :: Ident -> (Position,String)
+> nonLinear tv =
+>  (positionOfIdent tv,      
+>   "Type variable " ++ name tv ++
+>   " occurs more than once on left hand side of type declaration")
+
+> noVariable :: Ident -> (Position,String)
+> noVariable tv =
+>  (positionOfIdent tv,      
+>   "Type constructor " ++ name tv ++
+>   " used in left hand side of type declaration")
+
+> wrongArity :: QualIdent -> Int -> Int -> (Position,String)
+> wrongArity tc arity argc =
+>  (positionOfQualIdent tc,      
+>   "Type constructor " ++ qualName tc ++ " expects " ++ arguments arity ++
+>   " but is applied to " ++ show argc)
+>   where arguments 0 = "no arguments"
+>         arguments 1 = "1 argument"
+>         arguments n = show n ++ " arguments"
+
+> unboundVariable :: Ident -> (Position,String)
+> unboundVariable tv = 
+>     (positionOfIdent tv,
+>      "Unbound type variable " ++ name tv)
+
+\end{verbatim}
diff --git a/src/LLParseComb.lhs b/src/LLParseComb.lhs
new file mode 100644
--- /dev/null
+++ b/src/LLParseComb.lhs
@@ -0,0 +1,292 @@
+% -*- LaTeX -*-
+% $Id: LLParseComb.lhs,v 1.26 2004/02/15 23:11:30 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{LLParseComb.lhs}
+\section{Parsing Combinators}\label{sec:ll-parsecomb}
+The parsing combinators implemented in the module \texttt{LLParseComb}
+are based on the LL(1) parsing combinators developed by Swierstra and
+Duponcheel~\cite{SwierstraDuponcheel96:Parsers}. They have been
+adapted to using continuation passing style in order to work with the
+lexing combinators described in the previous section. In addition, the
+facilities for error correction are omitted in this implementation.
+
+The two functions \texttt{applyParser} and \texttt{prefixParser} use
+the specified parser for parsing a string. When \texttt{applyParser}
+is used, an error is reported if the parser does not consume the whole
+string, whereas \texttt{prefixParser} discards the rest of the input
+string in this case.
+\begin{verbatim}
+
+> module LLParseComb(Symbol(..),Parser,
+>                    applyParser,prefixParser, position,succeed,symbol,
+>                    (<?>),(<|>),(<|?>),(<*>),(<\>),(<\\>),
+>                    opt,(<$>),(<$->),(<*->),(<-*>),(<**>),(<??>),(<.>),
+>                    many,many1, sepBy,sepBy1, chainr,chainr1,chainl,chainl1,
+>                    bracket,ops, layoutOn,layoutOff,layoutEnd) where
+
+> import Data.Maybe
+> import Control.Monad
+
+> import Position
+> import Set
+> import Map
+> import Error
+> import LexComb
+
+> infixl 5 <\>, <\\>
+> infixl 4 <*>, <$>, <$->, <*->, <-*>, <**>, <??>, <.>
+> infixl 3 <|>, <|?>
+> infixl 2 <?>, `opt`
+
+\end{verbatim}
+\paragraph{Parser types}
+\begin{verbatim}
+
+> class (Ord s,Show s) => Symbol s where
+>   isEOF :: s -> Bool
+
+> type Empty = Bool
+> type SuccessCont s a = Position -> s -> P a
+> type FailureCont a = Position -> String -> P a
+> type Lexer s a = SuccessCont s a -> FailureCont a -> P a
+> type ParseFun s a b = (a -> SuccessCont s b) -> FailureCont b
+>                     -> SuccessCont s b
+
+> data Parser s a b = Parser (Maybe (ParseFun s a b))
+>                            (FM s (Lexer s b -> ParseFun s a b))
+
+> instance Symbol s => Show (Parser s a b) where
+>   showsPrec p (Parser e ps) = showParen (p >= 10) $                      -- $
+>     showString "Parser " . shows (isJust e) .
+>     showChar ' ' . shows (domainFM ps)
+
+> applyParser :: Symbol s => Parser s a a -> Lexer s a -> FilePath -> String
+>             -> Error a
+> applyParser p lexer = parse (lexer (choose p lexer done failP) failP)
+>   where done x pos s
+>           | isEOF s = returnP x
+>           | otherwise = failP pos (unexpected s)
+
+> prefixParser :: Symbol s => Parser s a a -> Lexer s a -> FilePath -> String
+>              -> Error a
+> prefixParser p lexer = parse (lexer (choose p lexer discard failP) failP)
+>   where discard x _ _ = returnP x
+
+> choose :: Symbol s => Parser s a b -> Lexer s b -> ParseFun s a b
+> choose (Parser e ps) lexer success fail pos s =
+>   case lookupFM s ps of
+>     Just p -> p lexer success fail pos s
+>     Nothing ->
+>       case e of
+>         Just p -> p success fail pos s
+>         Nothing -> fail pos (unexpected s)
+
+> unexpected :: Symbol s => s -> String
+> unexpected s
+>   | isEOF s = "Unexpected end-of-file"
+>   | otherwise = "Unexpected token " ++ show s
+
+\end{verbatim}
+\paragraph{Basic combinators}
+\begin{verbatim}
+
+> position :: Symbol s => Parser s Position b
+> position = Parser (Just p) zeroFM
+>   where p success _ pos = success pos pos
+
+> succeed :: Symbol s => a -> Parser s a b
+> succeed x = Parser (Just p) zeroFM
+>   where p success _ = success x
+
+> symbol :: Symbol s => s -> Parser s s a
+> symbol s = Parser Nothing (addToFM s p zeroFM)
+>   where p lexer success fail pos s = lexer (success s) fail
+
+> (<?>) :: Symbol s => Parser s a b -> String -> Parser s a b
+> p <?> msg = p <|> Parser (Just pfail) zeroFM
+>   where pfail _ fail pos _ = fail pos msg
+
+> (<|>) :: Symbol s => Parser s a b -> Parser s a b -> Parser s a b
+> Parser e1 ps1 <|> Parser e2 ps2
+>   | isJust e1 && isJust e2 = error "Ambiguous parser for empty word"
+>   | not (nullSet common) = error ("Ambiguous parser for " ++ show common)
+>   | otherwise = Parser (e1 `mplus` e2) (insertIntoFM ps1 ps2)
+>   where common = domainFM ps1 `intersectionSet` domainFM ps2
+
+\end{verbatim}
+The parsing combinators presented so far require that the grammar
+being parsed is LL(1). In some cases it may be difficult or even
+impossible to transform a grammar into LL(1) form. As a remedy, we
+include a non-deterministic version of the choice combinator in
+addition to the deterministic combinator adapted from the paper. For
+every symbol from the intersection of the parser's first sets, the
+combinator \texttt{(<|?>)} applies both parsing functions to the input
+stream and uses that one which processes the longer prefix of the
+input stream irrespective of whether it succeeds or fails. If both
+functions recognize the same prefix, we choose the one that succeeds
+and report an ambiguous parse error if both succeed.
+\begin{verbatim}
+
+> (<|?>) :: Symbol s => Parser s a b -> Parser s a b -> Parser s a b
+> Parser e1 ps1 <|?> Parser e2 ps2
+>   | isJust e1 && isJust e2 = error "Ambiguous parser for empty word"
+>   | otherwise = Parser (e1 `mplus` e2) (insertIntoFM ps1' ps2)
+>   where ps1' = fromListFM [(s,maybe p (try p) (lookupFM s ps2))
+>                           | (s,p) <- toListFM ps1]
+>         try p1 p2 lexer success fail pos s =
+>           closeP1 p2s `thenP` \p2s' ->
+>           closeP1 p2f `thenP` \p2f' ->
+>           parse p1 (retry p2s') (retry p2f')
+>           where p2s r1 = parse p2 (select True r1) (select False r1)
+>                 p2f r1 = parse p2 (flip (select False) r1) (select False r1)
+>                 parse p psucc pfail =
+>                   p lexer (successK psucc) (failK pfail) pos s
+>                 successK k x pos s = k (pos,success x pos s)
+>                 failK k pos msg = k (pos,fail pos msg)
+>                 retry k (pos,p) = closeP0 p `thenP` curry k pos
+>         select suc (pos1,p1) (pos2,p2) =
+>           case pos1 `compare` pos2 of
+>             GT -> p1
+>             EQ
+>               | suc -> error ("Ambiguous parse before " ++ show pos1)
+>               | otherwise -> p1
+>             LT -> p2
+
+> (<*>) :: Symbol s => Parser s (a -> b) c -> Parser s a c -> Parser s b c
+> Parser (Just p1) ps1 <*> ~p2@(Parser e2 ps2) =
+>   Parser (fmap (seqEE p1) e2)
+>          (insertIntoFM (fmap (flip seqPP p2) ps1) (fmap (seqEP p1) ps2))
+> Parser Nothing ps1 <*> p2 = Parser Nothing (fmap (flip seqPP p2) ps1)
+
+> seqEE :: Symbol s => ParseFun s (a -> b) c -> ParseFun s a c
+>       -> ParseFun s b c
+> seqEE p1 p2 success fail = p1 (\f -> p2 (success . f) fail) fail
+
+> seqEP :: Symbol s => ParseFun s (a -> b) c -> (Lexer s c -> ParseFun s a c)
+>       -> Lexer s c -> ParseFun s b c
+> seqEP p1 p2 lexer success fail = p1 (\f -> p2 lexer (success . f) fail) fail
+
+> seqPP :: Symbol s => (Lexer s c -> ParseFun s (a -> b) c) -> Parser s a c
+>       -> Lexer s c -> ParseFun s b c
+> seqPP p1 p2 lexer success fail =
+>   p1 lexer (\f -> choose p2 lexer (success . f) fail) fail
+
+> insertIntoFM :: Ord a => FM a b -> FM a b -> FM a b
+> insertIntoFM map1 map2 = foldr (uncurry addToFM) map2 (toListFM map1)
+
+\end{verbatim}
+The combinators \verb|<\\>| and \verb|<\>| can be used to restrict
+the first set of a parser. This is useful for combining two parsers
+with an overlapping first set with the deterministic combinator <|>.
+\begin{verbatim}
+
+> (<\>) :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c
+> p <\> Parser _ ps = p <\\> map fst (toListFM ps)
+
+> (<\\>) :: Symbol s => Parser s a b -> [s] -> Parser s a b
+> Parser e ps <\\> xs = Parser e (foldr deleteFromFM ps xs)
+
+\end{verbatim}
+\paragraph{Other combinators.}
+Note that some of these combinators have not been published in the
+paper, but were taken from the implementation found on the web.
+\begin{verbatim}
+
+> opt :: Symbol s => Parser s a b -> a -> Parser s a b
+> p `opt` x = p <|> succeed x
+
+> (<$>) :: Symbol s => (a -> b) -> Parser s a c -> Parser s b c
+> f <$> p = succeed f <*> p
+
+> (<$->) :: Symbol s => a -> Parser s b c -> Parser s a c
+> f <$-> p = const f <$> p {-$-}
+
+> (<*->) :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c
+> p <*-> q = const <$> p <*> q {-$-}
+
+> (<-*>) :: Symbol s => Parser s a c -> Parser s b c -> Parser s b c
+> p <-*> q = const id <$> p <*> q {-$-}
+
+> (<**>) :: Symbol s => Parser s a c -> Parser s (a -> b) c -> Parser s b c
+> p <**> q = flip ($) <$> p <*> q
+
+> (<??>) :: Symbol s => Parser s a b -> Parser s (a -> a) b -> Parser s a b
+> p <??> q = p <**> (q `opt` id)
+
+> (<.>) :: Symbol s => Parser s (a -> b) d -> Parser s (b -> c) d
+>       -> Parser s (a -> c) d
+> p1 <.> p2 = p1 <**> ((.) <$> p2)
+
+> many :: Symbol s => Parser s a b -> Parser s [a] b
+> many p = many1 p `opt` []
+
+> many1 :: Symbol s => Parser s a b -> Parser s [a] b
+> -- many1 p = (:) <$> p <*> many p
+> many1 p = (:) <$> p <*> (many1 p `opt` [])
+
+\end{verbatim}
+The first definition of \texttt{many1} is commented out because it
+does not compile under nhc. This is due to a -- known -- bug in the
+type checker of nhc which expects a default declaration when compiling
+mutually recursive functions with class constraints. However, no such
+default can be given in the above case because neither of the types
+involved is a numeric type.
+\begin{verbatim}
+
+> sepBy :: Symbol s => Parser s a c -> Parser s b c -> Parser s [a] c
+> p `sepBy` q = p `sepBy1` q `opt` []
+
+> sepBy1 :: Symbol s => Parser s a c -> Parser s b c -> Parser s [a] c
+> p `sepBy1` q = (:) <$> p <*> many (q <-*> p) {-$-}
+
+> chainr :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b -> a
+>        -> Parser s a b
+> chainr p op x = chainr1 p op `opt` x
+
+> chainr1 :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b
+>         -> Parser s a b
+> chainr1 p op = r
+>   where r = p <**> (flip <$> op <*> r `opt` id) {-$-}
+
+> chainl :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b -> a
+>        -> Parser s a b
+> chainl p op x = chainl1 p op `opt` x
+
+> chainl1 :: Symbol s => Parser s a b -> Parser s (a -> a -> a) b
+>         -> Parser s a b
+> chainl1 p op = foldF <$> p <*> many (flip <$> op <*> p)
+>   where foldF x [] = x
+>         foldF x (f:fs) = foldF (f x) fs
+
+> bracket :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c
+>         -> Parser s b c
+> bracket open p close = open <-*> p <*-> close
+
+> ops :: Symbol s => [(s,a)] -> Parser s a b
+> ops [] = error "internal error: ops"
+> ops [(s,x)] = x <$-> symbol s
+> ops ((s,x):rest) = x <$-> symbol s <|> ops rest
+
+\end{verbatim}
+\paragraph{Layout combinators}
+Note that the layout functions grab the next token (and its position).
+After modifying the layout context, the continuation is called with
+the same token and an undefined result.
+\begin{verbatim}
+
+> layoutOn :: Symbol s => Parser s a b
+> layoutOn = Parser (Just on) zeroFM
+>   where on success _ pos = pushContext (column pos) . success undefined pos
+
+> layoutOff :: Symbol s => Parser s a b
+> layoutOff = Parser (Just off) zeroFM
+>   where off success _ pos = pushContext (-1) . success undefined pos
+
+> layoutEnd :: Symbol s => Parser s a b
+> layoutEnd = Parser (Just end) zeroFM
+>   where end success _ pos = popContext . success undefined pos
+
+\end{verbatim}
diff --git a/src/LexComb.lhs b/src/LexComb.lhs
new file mode 100644
--- /dev/null
+++ b/src/LexComb.lhs
@@ -0,0 +1,102 @@
+% -*- LaTeX -*-
+% $Id: LexComb.lhs,v 1.16 2004/01/20 16:44:14 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{LexComb.lhs}
+\section{Lexing combinators}
+The module \texttt{LexComb} provides the basic types and combinators
+to implement the lexers. The combinators use continuation passing code
+in a monadic style. The first argument of the continuation function is
+the string to be parsed, the second is the current position, and the
+third is a flag which signals the lexer that it is lexing the
+beginning of a line and therefore has to check for layout tokens. The
+fourth argument is a stack of indentations that is used to handle
+nested layout groups.
+\begin{verbatim}
+
+> module LexComb where
+> import Position
+> import Error
+> import Data.Char
+
+> infixl 1 `thenP`, `thenP_`
+
+> type Indent = Int
+> type Context = [Indent]
+> type P a = Position -> String -> Bool -> Context -> Error a
+
+> parse :: P a -> FilePath -> String -> Error a
+> parse p fn s = p (first fn) s False []
+
+\end{verbatim}
+Monad functions for the lexer.
+\begin{verbatim}
+
+> returnP :: a -> P a
+> returnP x _ _ _ _ = Ok x
+
+> thenP :: P a -> (a -> P b) -> P b
+> thenP lex k pos s bol ctxt = lex pos s bol ctxt >>= \x -> k x pos s bol ctxt
+
+> thenP_ :: P a -> P b -> P b
+> p1 `thenP_` p2 = p1 `thenP` \_ -> p2
+
+> failP :: Position -> String -> P a
+> failP pos msg _ _ _ _ = Error (parseError pos msg)
+
+> closeP0 :: P a -> P (P a)
+> closeP0 lex pos s bol ctxt = Ok (\_ _ _ _ -> lex pos s bol ctxt)
+
+> closeP1 :: (a -> P b) -> P (a -> P b)
+> closeP1 f pos s bol ctxt = Ok (\x _ _ _ _ -> f x pos s bol ctxt)
+
+> parseError :: Position -> String -> String
+> parseError p what = "\n" ++ show p ++ ": " ++ what
+
+\end{verbatim}
+Combinators that handle layout.
+\begin{verbatim}
+
+> pushContext :: Int -> P a -> P a
+> pushContext col cont pos s bol ctxt = cont pos s bol (col:ctxt)
+
+> popContext :: P a -> P a
+> popContext cont pos s bol (_:ctxt) = cont pos s bol ctxt
+> popContext cont pos s bol [] = 
+>    error "parse error: popping layout from empty context stack. \
+>          \Perhaps you have inserted too many '}'?"
+
+\end{verbatim}
+Conversions from strings into numbers.
+\begin{verbatim}
+
+> convertSignedIntegral :: Num a => a -> String -> a
+> convertSignedIntegral b ('+':s) = convertIntegral b s
+> convertSignedIntegral b ('-':s) = - convertIntegral b s
+> convertSignedIntegral b s = convertIntegral b s
+
+> convertIntegral :: Num a => a -> String -> a
+> convertIntegral b = foldl op 0
+>   where m `op` n | isDigit n = b * m + fromIntegral (ord n - ord0)
+>                  | isUpper n = b * m + fromIntegral (ord n - ordA)
+>                  | otherwise = b * m + fromIntegral (ord n - orda)
+>         ord0 = ord '0'
+>         ordA = ord 'A' - 10
+>         orda = ord 'a' - 10
+
+> convertSignedFloating :: Fractional a => String -> String -> Int -> a
+> convertSignedFloating ('+':m) f e = convertFloating m f e
+> convertSignedFloating ('-':m) f e = - convertFloating m f e
+> convertSignedFloating m f e = convertFloating m f e
+
+> convertFloating :: Fractional a => String -> String -> Int -> a
+> convertFloating m f e
+>   | e' == 0 = m'
+>   | e' > 0  = m' * 10^e'
+>   | otherwise = m' / 10^(-e')
+>   where m' = convertIntegral 10 (m ++ f)
+>         e' = e - length f
+
+\end{verbatim}
diff --git a/src/Lift.lhs b/src/Lift.lhs
new file mode 100644
--- /dev/null
+++ b/src/Lift.lhs
@@ -0,0 +1,317 @@
+
+% $Id: Lift.lhs,v 1.23 2004/02/13 14:02:54 wlux Exp $
+%
+% Copyright (c) 2001-2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Lift.lhs}
+\section{Lifting Declarations}
+After desugaring and simplifying the code, the compiler lifts all
+local function declarations to the top-level keeping only local
+variable declarations. The algorithm used here is similar to
+Johnsson's~\cite{Johnsson87:Thesis} (see also chapter 6
+of~\cite{PeytonJonesLester92:Book}). It consists of two phases, first
+we abstract each local function declaration, adding its free variables
+as initial parameters and update all calls to take these variables
+into account. Then all local function declarations are collected and
+lifted to the top-level.
+\begin{verbatim}
+
+> module Lift(lift) where
+
+> import Control.Monad
+> import Data.List
+
+> import Base
+> import Env
+> import TopEnv
+> import Set
+
+
+> import Combined
+> import SCC
+
+> lift :: ValueEnv -> EvalEnv -> Module -> (Module,ValueEnv,EvalEnv)
+> lift tyEnv evEnv (Module m es ds) =
+>   (Module m es (concatMap liftFunDecl ds'),tyEnv',evEnv')
+>   where (ds',tyEnv',evEnv') =
+>           runSt (callSt (abstractModule m ds) tyEnv) evEnv
+
+\end{verbatim}
+\paragraph{Abstraction}
+Besides adding the free variables to every (local) function, the
+abstraction pass also has to update the type environment in order to
+reflect the new types of the expanded functions. As usual we use a
+state monad transformer in order to pass the type environment
+through. The environment constructed in the abstraction phase maps
+each local function declaration onto its replacement expression,
+i.e. the function applied to its free variables.
+\begin{verbatim}
+
+> type AbstractState a = StateT ValueEnv (StateT EvalEnv Id) a
+> type AbstractEnv = Env Ident Expression
+
+> abstractModule :: ModuleIdent -> [Decl]
+>                -> AbstractState ([Decl],ValueEnv,EvalEnv)
+> abstractModule m ds =
+>   do
+>     ds' <- mapM (abstractDecl m "" [] emptyEnv) ds
+>     tyEnv' <- fetchSt
+>     evEnv' <- liftSt fetchSt
+>     return (ds',tyEnv',evEnv')
+
+> abstractDecl :: ModuleIdent -> String -> [Ident] -> AbstractEnv -> Decl
+>              -> AbstractState Decl
+> abstractDecl m _ lvs env (FunctionDecl p f eqs) =
+>   liftM (FunctionDecl p f) (mapM (abstractEquation m lvs env) eqs)
+> abstractDecl m pre lvs env (PatternDecl p t rhs) =
+>   liftM (PatternDecl p t) (abstractRhs m pre lvs env rhs)
+> abstractDecl _ _ _ _ d = return d
+
+> abstractEquation :: ModuleIdent -> [Ident] -> AbstractEnv -> Equation
+>                  -> AbstractState Equation
+> abstractEquation m lvs env (Equation p lhs@(FunLhs f ts) rhs) =
+>   liftM (Equation p lhs)
+>         (abstractRhs m (name f ++ ".") (lvs ++ bv ts) env rhs)
+
+> abstractRhs :: ModuleIdent -> String -> [Ident] -> AbstractEnv -> Rhs
+>             -> AbstractState Rhs
+> abstractRhs m pre lvs env (SimpleRhs p e _) =
+>   liftM (flip (SimpleRhs p) []) (abstractExpr m pre lvs env e)
+
+\end{verbatim}
+Within a declaration group we have to split the list of declarations
+into the function and value declarations. Only the function
+declarations are affected by the abstraction algorithm; the value
+declarations are left unchanged except for abstracting their right
+hand sides.
+
+The abstraction of a recursive declaration group is complicated by the
+fact that not all functions need to call each in a recursive
+declaration group. E.g., in the following example neither g nor h
+call each other.
+\begin{verbatim}
+  f = g True
+    where x = f 1
+          f z = y + z
+          y = g False
+          g z = if z then x else 0
+\end{verbatim}
+Because of this fact, f and g can be abstracted separately by adding
+only \texttt{y} to \texttt{f} and \texttt{x} to \texttt{g}. On the
+other hand, in the following example
+\begin{verbatim}
+  f x y = g 4
+    where g p = h p + x
+          h q = k + y + q
+          k = g x
+\end{verbatim}
+the local function \texttt{g} uses \texttt{h}, so the free variables
+of \texttt{h} have to be added to \texttt{g} as well. However, because
+\texttt{h} does not call \texttt{g} it is sufficient to add only
+\texttt{k} and \texttt{y} (and not \texttt{x}) to its definition. We
+handle this by computing the dependency graph between the functions
+and splitting this graph into its strongly connected components. Each
+component is then processed separately, adding the free variables in
+the group to its functions.
+
+We have to be careful with local declarations within desugared case
+expressions. If some of the cases have guards, e.g.,
+\begin{verbatim}
+  case e of
+    x | x < 1 -> 1
+    x -> let double y = y * y in double x
+\end{verbatim}
+the desugarer at present may duplicate code. While there is no problem
+with local variable declaration being duplicated, we must avoid to
+lift local function declarations more than once. Therefore
+\texttt{abstractFunDecls} transforms only those function declarations
+that have not been lifted and discards the other declarations. Note
+that it is easy to check whether a function has been lifted by
+checking whether an entry for its untransformed name is still present
+in the type environment.
+\begin{verbatim}
+
+> abstractDeclGroup :: ModuleIdent -> String -> [Ident] -> AbstractEnv
+>                   -> [Decl] -> Expression -> AbstractState Expression
+> abstractDeclGroup m pre lvs env ds e =
+>   abstractFunDecls m pre (lvs ++ bv vds) env (scc bv (qfv m) fds) vds e
+>   where (fds,vds) = partition isFunDecl ds
+
+> abstractFunDecls :: ModuleIdent -> String -> [Ident] -> AbstractEnv
+>                  -> [[Decl]] -> [Decl] -> Expression
+>                  -> AbstractState Expression
+> abstractFunDecls m pre lvs env [] vds e =
+>   do
+>     vds' <- mapM (abstractDecl m pre lvs env) vds
+>     e' <- abstractExpr m pre lvs env e
+>     return (Let vds' e')
+> abstractFunDecls m pre lvs env (fds:fdss) vds e =
+>   do
+>     fs' <- liftM (\tyEnv -> filter (not . isLifted tyEnv) fs) fetchSt
+>     updateSt_ (abstractFunTypes m pre fvs fs')
+>     liftSt (updateSt_ (abstractFunAnnots m pre fs'))
+>     fds' <- mapM (abstractFunDecl m pre fvs lvs env')
+>                  [d | d <- fds, any (`elem` fs') (bv d)]
+>     e' <- abstractFunDecls m pre lvs env' fdss vds e
+>     return (Let fds' e')
+>   where fs = bv fds
+>         fvs = filter (`elem` lvs) (toListSet fvsRhs)
+>         env' = foldr (bindF (map mkVar fvs)) env fs
+>         fvsRhs = unionSets
+>           [fromListSet (maybe [v] (qfv m) (lookupEnv v env)) | v <- qfv m fds]
+>         bindF fvs f = bindEnv f (apply (mkFun m pre f) fvs)
+>         isLifted tyEnv f = null (lookupValue f tyEnv)
+
+> abstractFunTypes :: ModuleIdent -> String -> [Ident] -> [Ident]
+>                  -> ValueEnv -> ValueEnv
+> abstractFunTypes m pre fvs fs tyEnv = foldr abstractFunType tyEnv fs
+>   where tys = map (varType tyEnv) fvs
+>         abstractFunType f tyEnv =
+>           qualBindFun m (liftIdent pre f)
+>                         (foldr TypeArrow (varType tyEnv f) tys)
+>                         (unbindFun f tyEnv)
+
+> abstractFunAnnots :: ModuleIdent -> String -> [Ident] -> EvalEnv -> EvalEnv
+> abstractFunAnnots m pre fs evEnv = foldr abstractFunAnnot evEnv fs
+>   where abstractFunAnnot f evEnv =
+>           case lookupEnv f evEnv of
+>             Just ev -> bindEnv (liftIdent pre f) ev (unbindEnv f evEnv)
+>             Nothing -> evEnv
+
+> abstractFunDecl :: ModuleIdent -> String -> [Ident] -> [Ident]
+>                 -> AbstractEnv -> Decl -> AbstractState Decl
+> abstractFunDecl m pre fvs lvs env (FunctionDecl p f eqs) =
+>   abstractDecl m pre lvs env (FunctionDecl p f' (map (addVars f') eqs))
+>   where f' = liftIdent pre f
+>         addVars f (Equation p (FunLhs _ ts) rhs) =
+>           Equation p (FunLhs f (map VariablePattern fvs ++ ts)) rhs
+> abstractFunDecl m pre _ lvs env (ExternalDecl p cc ie f ty) =
+>   return (ExternalDecl p cc ie (liftIdent pre f) ty)
+
+> abstractExpr :: ModuleIdent -> String -> [Ident] -> AbstractEnv
+>              -> Expression -> AbstractState Expression
+> abstractExpr _ _ _ _ (Literal l) = return (Literal l)
+> abstractExpr m pre lvs env (Variable v)
+>   | isQualified v = return (Variable v)
+>   | otherwise = maybe (return (Variable v)) (abstractExpr m pre lvs env)
+>                       (lookupEnv (unqualify v) env)
+> abstractExpr _ _ _ _ (Constructor c) = return (Constructor c)
+> abstractExpr m pre lvs env (Apply e1 e2) =
+>   do
+>     e1' <- abstractExpr m pre lvs env e1
+>     e2' <- abstractExpr m pre lvs env e2
+>     return (Apply e1' e2')
+> abstractExpr m pre lvs env (Let ds e) = abstractDeclGroup m pre lvs env ds e
+> abstractExpr m pre lvs env (Case r e alts) =
+>   do
+>     e' <- abstractExpr m pre lvs env e
+>     alts' <- mapM (abstractAlt m pre lvs env) alts
+>     return (Case r e' alts')
+> abstractExpr m _ _ _ _ = internalError "abstractExpr"
+
+> abstractAlt :: ModuleIdent -> String -> [Ident] -> AbstractEnv -> Alt
+>             -> AbstractState Alt
+> abstractAlt m pre lvs env (Alt p t rhs) =
+>   liftM (Alt p t) (abstractRhs m pre (lvs ++ bv t) env rhs)
+
+> abstractCondExpr :: ModuleIdent -> String -> [Ident] -> AbstractEnv
+>                  -> CondExpr -> AbstractState CondExpr
+> abstractCondExpr m pre lvs env (CondExpr p g e) =
+>   do
+>     g' <- abstractExpr m pre lvs env g
+>     e' <- abstractExpr m pre lvs env e
+>     return (CondExpr p g' e')
+
+\end{verbatim}
+\paragraph{Lifting}
+After the abstraction pass, all local function declarations are lifted
+to the top-level.
+\begin{verbatim}
+
+> liftFunDecl :: Decl -> [Decl]
+> liftFunDecl (FunctionDecl p f eqs) = (FunctionDecl p f eqs' : concat dss')
+>   where (eqs',dss') = unzip (map liftEquation eqs)
+> liftFunDecl d = [d]
+
+> liftVarDecl :: Decl -> (Decl,[Decl])
+> liftVarDecl (PatternDecl p t rhs) = (PatternDecl p t rhs',ds')
+>   where (rhs',ds') = liftRhs rhs
+> liftVarDecl (ExtraVariables p vs) = (ExtraVariables p vs,[])
+
+> liftEquation :: Equation -> (Equation,[Decl])
+> liftEquation (Equation p lhs rhs) = (Equation p lhs rhs',ds')
+>   where (rhs',ds') = liftRhs rhs
+
+> liftRhs :: Rhs -> (Rhs,[Decl])
+> liftRhs (SimpleRhs p e _) = (SimpleRhs p e' [],ds')
+>   where (e',ds') = liftExpr e
+
+> liftDeclGroup :: [Decl] -> ([Decl],[Decl])
+> liftDeclGroup ds = (vds',concat (map liftFunDecl fds ++ dss'))
+>   where (fds,vds) = partition isFunDecl ds
+>         (vds',dss') = unzip (map liftVarDecl vds)
+
+> liftExpr :: Expression -> (Expression,[Decl])
+> liftExpr (Literal l) = (Literal l,[])
+> liftExpr (Variable v) = (Variable v,[])
+> liftExpr (Constructor c) = (Constructor c,[])
+> liftExpr (Apply e1 e2) = (Apply e1' e2',ds' ++ ds'')
+>   where (e1',ds') = liftExpr e1
+>         (e2',ds'') = liftExpr e2
+> liftExpr (Let ds e) = (mkLet ds' e',ds'' ++ ds''')
+>   where (ds',ds'') = liftDeclGroup ds
+>         (e',ds''') = liftExpr e
+>         mkLet ds e = if null ds then e else Let ds e
+> liftExpr (Case r e alts) = (Case r e' alts',concat (ds':dss'))
+>   where (e',ds') = liftExpr e
+>         (alts',dss') = unzip (map liftAlt alts)
+> liftExpr _ = internalError "liftExpr"
+
+> liftAlt :: Alt -> (Alt,[Decl])
+> liftAlt (Alt p t rhs) = (Alt p t rhs',ds')
+>   where (rhs',ds') = liftRhs rhs
+
+> liftCondExpr :: CondExpr -> (CondExpr,[Decl])
+> liftCondExpr (CondExpr p g e) = (CondExpr p g' e',ds' ++ ds'')
+>   where (g',ds') = liftExpr g
+>         (e',ds'') = liftExpr e
+
+\end{verbatim}
+\paragraph{Auxiliary definitions}
+\begin{verbatim}
+
+> isFunDecl :: Decl -> Bool
+> isFunDecl (FunctionDecl _ _ _) = True
+> isFunDecl (ExternalDecl _ _ _ _ _) = True
+> isFunDecl _ = False
+
+> mkFun :: ModuleIdent -> String -> Ident -> Expression
+> mkFun m pre f = Variable (qualifyWith m (liftIdent pre f))
+
+> mkVar :: Ident -> Expression
+> mkVar v = Variable (qualify v)
+
+> apply :: Expression -> [Expression] -> Expression
+> apply = foldl Apply
+
+> qualBindFun :: ModuleIdent -> Ident -> Type -> ValueEnv -> ValueEnv
+> qualBindFun m f ty 
+>   = qualBindTopEnv "Lift.qualBindFun" f' (Value f' (polyType ty))
+>   where f' = qualifyWith m f
+
+> unbindFun :: Ident -> ValueEnv -> ValueEnv
+> unbindFun = unbindTopEnv
+
+> varType :: ValueEnv -> Ident -> Type
+> varType tyEnv v =
+>   case lookupValue v tyEnv of
+>     [Value _ (ForAll _ ty)] -> ty
+>     _ -> internalError ("varType " ++ show v)
+
+> liftIdent :: String -> Ident -> Ident
+> liftIdent prefix x =
+>     renameIdent (mkIdent (prefix ++ (show x))) (uniqueId x)
+>    --renameIdent (mkIdent (prefix ++ name x ++ show (uniqueId x))) (uniqueId x)
+
+\end{verbatim}
diff --git a/src/Map.lhs b/src/Map.lhs
new file mode 100644
--- /dev/null
+++ b/src/Map.lhs
@@ -0,0 +1,225 @@
+% -*- LaTeX -*-
+% $Id: Map.lhs,v 1.6 2003/04/24 08:02:39 wlux Exp $
+%
+% Copyright (c) 1999-2002, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Map.lhs}
+\section{Maps}
+The module \texttt{Map} implements finite maps using 2-3 trees.
+\begin{verbatim}
+
+> module Map(FM, nullFM, zeroFM, unitFM, addToFM, deleteFromFM,
+>            lookupFM, fromListFM, toListFM) where
+> import Data.List
+
+\end{verbatim}
+A 2-3 tree is either empty or a node with either two or three children
+that are themselves 2-3 trees of the same height. Thus, a 2-3 is
+always balanced.
+\begin{verbatim}
+
+> data FM a b =
+>     Empty
+>   | Node2 (FM a b) (a,b) (FM a b)
+>   | Node3 (FM a b) (a,b) (FM a b) (a,b) (FM a b)
+
+> nullFM :: Ord a => FM a b -> Bool
+> nullFM Empty = True
+> nullFM _ = False
+
+> zeroFM :: Ord a => FM a b
+> zeroFM = Empty
+
+> unitFM :: Ord a => a -> b -> FM a b
+> unitFM x y = Node2 Empty (x,y) Empty
+
+\end{verbatim}
+Insertion into the map is performed with the help of an auxiliary
+function. This function returns either the updated node or a triple of
+a left and right subtree together with the element between them
+if the height of the tree must be changed.
+\begin{verbatim}
+
+> addToFM :: Ord a => a -> b -> FM a b -> FM a b
+> addToFM x y xys =
+>   case insertNode x y xys of
+>     Left xys' -> xys'
+>     Right (l,x,r) -> Node2 l x r
+
+> fromListFM :: Ord a => [(a,b)] -> FM a b
+> fromListFM = foldr (uncurry addToFM) zeroFM
+
+> insertNode :: Ord a => a -> b -> FM a b
+>            -> Either (FM a b) ((FM a b),(a,b),(FM a b))
+> insertNode k x Empty = Right (Empty,(k,x),Empty)
+> insertNode k x (Node2 a y b) =
+>   Left (case compareKey k y of
+>           LT -> balanceL (insertNode k x a) y b
+>           EQ -> Node2 a (k,x) b
+>           GT -> balanceR a y (insertNode k x b))
+>   where balanceL (Left a) x b = Node2 a x b
+>         balanceL (Right (a,x,b)) y c = Node3 a x b y c
+>         balanceR a x (Left b) = Node2 a x b
+>         balanceR a x (Right (b,y,c)) = Node3 a x b y c
+> insertNode k x (Node3 a y b z c) =
+>   case compareKey k y of
+>     LT -> balanceL (insertNode k x a) y b z c
+>     EQ -> Left (Node3 a (k,x) b z c)
+>     GT ->
+>       case compareKey k z of
+>         LT -> balanceM a y (insertNode k x b) z c
+>         EQ -> Left (Node3 a y b (k,x) c)
+>         GT -> balanceR a y b z (insertNode k x c)
+>   where balanceL (Left a) x b y c = Left (Node3 a x b y c)
+>         balanceL (Right (a,x,b)) y c z d = Right (Node2 a x b,y,Node2 c z d)
+>         balanceM a x (Left b) y c = Left (Node3 a x b y c)
+>         balanceM a x (Right (b,y,c)) z d = Right (Node2 a x b,y,Node2 c z d)
+>         balanceR a x b y (Left c) = Left (Node3 a x b y c)
+>         balanceR a x b y (Right (c,z,d)) = Right (Node2 a x b,y,Node2 c z d)
+
+> compareKey :: Ord a => a -> (a,b) -> Ordering
+> compareKey k1 (k2,_) = compare k1 k2
+
+\end{verbatim}
+Deletion also uses an auxiliary function. This function returns the
+new node after the element has been deleted together with a boolean
+flag that indicates whether the height was decremented.
+\begin{verbatim}
+
+> deleteFromFM :: Ord a => a -> FM a b -> FM a b
+> deleteFromFM x xys = snd (deleteNode x xys)
+
+> deleteNode :: Ord a => a -> FM a b -> (Bool,FM a b)
+> deleteNode _ Empty = (False,Empty)
+> deleteNode x (Node2 a y b) =
+>   case compareKey x y of
+>     LT -> balanceL (deleteNode x a) y b
+>     EQ
+>       | nullFM a -> (True,b)
+>       | otherwise -> balanceR a u (deleteNode (fst u) b)
+>       where u = findMin b
+>     GT -> balanceR a y (deleteNode x b)
+>   where balanceL (False,a) x b = (False,Node2 a x b)
+>         balanceL (True,a) x (Node2 b y c) = (True,Node3 a x b y c)
+>         balanceL (True,a) x (Node3 b y c z d) =
+>           (False,Node2 (Node2 a x b) y (Node2 c z d))
+>         balanceR a x (False,b) = (False,Node2 a x b)
+>         balanceR (Node2 a x b) y (True,c) = (True,Node3 a x b y c)
+>         balanceR (Node3 a x b y c) z (True,d) =
+>           (False,Node2 (Node2 a x b) y (Node2 c z d))
+> deleteNode x (Node3 a y b z c) =
+>   (False,
+>    case compareKey x y of
+>      LT -> balanceL (deleteNode x a) y b z c
+>      EQ
+>        | nullFM a -> Node2 b z c
+>        | otherwise -> balanceM a u (deleteNode (fst u) b) z c
+>        where u = findMin b
+>      GT ->
+>        case compareKey x z of
+>          LT -> balanceM a y (deleteNode x b) z c
+>          EQ
+>            | nullFM c -> Node2 a y b
+>            | otherwise -> balanceR a y b u (deleteNode (fst u) c)
+>            where u = findMin c
+>          GT -> balanceR a y b z (deleteNode x c))
+>   where balanceL (False,a) x b y c = Node3 a x b y c
+>         balanceL (True,a) x (Node2 b y c) z d = Node2 (Node3 a x b y c) z d
+>         balanceL (True,a) w (Node3 b x c y d) z e =
+>           Node3 (Node2 a w b) x (Node2 c y d) z e
+>         balanceM a x (False,b) y c = Node3 a x b y c
+>         balanceM a x (True,b) y (Node2 c z d) = Node2 a x (Node3 b y c z d)
+>         balanceM a w (True,b) x (Node3 c y d z e) =
+>           Node3 a w (Node2 b x c) y (Node2 d z e)
+>         balanceR a x b y (False,c) = Node3 a x b y c
+>         balanceR a x (Node2 b y c) z (True,d) = Node2 a x (Node3 b y c z d)
+>         balanceR a w (Node3 b x c y d) z (True,e) =
+>           Node3 a w (Node2 b x c) y (Node2 d z e)
+
+> findMin :: Ord a => FM a b -> (a,b)
+> findMin (Node2 a x _)
+>   | nullFM a = x
+>   | otherwise = findMin a
+> findMin (Node3 a x _ _ _)
+>   | nullFM a = x
+>   | otherwise = findMin a
+
+\end{verbatim}
+Looking up an element is trivial.
+\begin{verbatim}
+
+> lookupFM :: Ord a => a -> FM a b -> Maybe b
+> lookupFM _ Empty = Nothing
+> lookupFM x (Node2 a y b) =
+>   case compareKey x y of
+>     LT -> lookupFM x a
+>     EQ -> Just (snd y)
+>     GT -> lookupFM x b
+> lookupFM x (Node3 a y b z c) =
+>   case compareKey x y of
+>     LT -> lookupFM x a
+>     EQ -> Just (snd y)
+>     GT -> lookupFM x (Node2 b z c)
+
+\end{verbatim}
+The function \texttt{toListFM} returns an association list of all
+elements in the map. We use a functional difference list approach
+similar to \texttt{show} in order to achieve an efficiency which is
+linear in the number of elements in the finite map.
+\begin{verbatim}
+
+> toListFM :: Ord a => FM a b -> [(a,b)]
+> toListFM = flip elems []
+>   where elems Empty xs = xs
+>         elems (Node2 a x b) xs = elems a (x : elems b xs)
+>         elems (Node3 a x b y c) xs = elems a (x : elems b (y : elems c xs))
+
+\end{verbatim}
+Two finite maps are considered equal if they contain the same
+elements. Note that the representation trees of the two maps may be
+different. Therefore we must use the list of elements in order to
+compare the maps.
+\begin{verbatim}
+
+> instance (Ord a,Eq b) => Eq (FM a b) where
+>   xys1 == xys2 = toListFM xys1 == toListFM xys2
+
+\end{verbatim}
+When we display a finite map we will show only its semantic
+information not the underlying tree representation.
+\begin{verbatim}
+
+> instance (Ord a,Show a,Show b) => Show (FM a b) where
+>   showsPrec p xys =
+>     showChar '{' . showList (map showAssoc (toListFM xys)) . showChar '}'
+>     where showList = flip (foldr ($)) . intersperse (showChar ',')       -- $
+>           showAssoc (x,y) = showsPrec 0 x . showString "|->" . showsPrec 0 y
+
+\end{verbatim}
+A finite map is a functor with respect to its data argument.
+\begin{verbatim}
+
+> instance Ord a => Functor (FM a) where
+>   fmap f Empty = Empty
+>   fmap f (Node2 a (k,x) b) = Node2 (fmap f a) (k,f x) (fmap f b)
+>   fmap f (Node3 a (k,x) b (l,y) c) =
+>     Node3 (fmap f a) (k,f x) (fmap f b) (l,f y) (fmap f c)
+
+\end{verbatim}
+The function \texttt{checkTree} verifies that a 2-3 tree is actually
+balanced. The function returns the height of the tree.
+\begin{verbatim}
+
+> checkTree :: Ord a => FM a b -> Int
+> checkTree Empty = 0
+> checkTree (Node2 a _ b)
+>   | h == checkTree b = h + 1
+>   | otherwise = error "checkTree: unbalanced 2-3 tree"
+>   where h = checkTree a
+> checkTree (Node3 a _ b _ c)
+>   | h == checkTree b && h == checkTree c = h + 1
+>   | otherwise = error "checkTree: unbalanced 2-3 tree"
+>   where h = checkTree a
+
+\end{verbatim}
diff --git a/src/Message.hs b/src/Message.hs
new file mode 100644
--- /dev/null
+++ b/src/Message.hs
@@ -0,0 +1,74 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- Message - A library for dealing with compiler messages
+--
+-- Note: This module overwrites the functions declared in "Message"
+--                
+-- January 2006,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+module Message where
+
+import Position
+
+
+-------------------------------------------------------------------------------
+
+-- Type for representing compiler messages (currently errors and warnings)
+data Message = Message MessageType (Maybe Position) String
+
+-- Data type for representing available compiler message types
+data MessageType = Warning WarningType | Error deriving Eq
+
+-- the different warnings are categorized by WarningType
+data WarningType = UnrefTypeVar
+                 | UnrefVar
+                 | ShadowingVar
+                 | IdleCaseAlt
+                 | OverlapCase
+                 | OverlapRules
+                 | RulesNotTogether
+                 | MultipleImportModule
+                 | MultipleImportSymbol
+                 | MultipleHiding 
+                 deriving Eq
+
+-- An instance of Show for converting messages to readable strings
+instance Show Message where
+ show (Message (Warning _) mpos msg) = showMessage "Warning" mpos msg
+ show (Message Error   mpos msg) = showMessage "ERROR" mpos msg
+
+
+-------------------------------------------------------------------------------
+
+--
+message :: MessageType -> Position -> String -> Message
+message mtype pos msg = Message mtype (Just pos) msg
+
+--
+message_ :: MessageType -> String -> Message
+message_ mtype msg = Message mtype Nothing msg
+
+--
+countMessages :: MessageType -> [Message] -> Int
+countMessages mtype msgs = length (filter (((==) mtype) . messageType) msgs)
+
+--
+messageType :: Message -> MessageType
+messageType (Message mtype _ _) = mtype
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+--
+showMessage :: String -> (Maybe Position) -> String -> String
+showMessage what mpos msg
+   = what ++ ": " ++ pos ++ msg
+ where
+ pos = maybe "" (\p -> show p ++ ": ") mpos
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/Modules.lhs b/src/Modules.lhs
new file mode 100644
--- /dev/null
+++ b/src/Modules.lhs
@@ -0,0 +1,799 @@
+
+% $Id: Modules.lhs,v 1.84 2004/02/10 17:46:07 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+% March 2007, extensions by Sebastian Fischer (sebf@informatik.uni-kiel.de)
+%
+\nwfilename{Modules.lhs}
+\section{Modules}
+This module controls the compilation of modules.
+
+Since this version is only used as a frontend for PAKCS, some of the following 
+import declarations are commented out
+\begin{verbatim}
+
+> module Modules(compileModule, compileModule_,
+>	         loadInterfaces, transModule,
+>	         simpleCheckModule, checkModule
+>	        ) where
+
+> import Data.List
+> import System.IO
+> import Data.Maybe
+> import Control.Monad
+
+> import Base
+> import Unlit(unlit)
+> import CurryParser(parseSource,parseGoal) -- xxxGoal entfernen
+> import ShowCurrySyntax(showModule)
+> import KindCheck(kindCheck,kindCheckGoal)
+> import SyntaxCheck(syntaxCheck)
+> import PrecCheck(precCheck,precCheckGoal)
+> import TypeCheck(typeCheck,typeCheckGoal)
+> import WarnCheck
+> import Message
+> import Arity
+> import Imports(importInterface,importInterfaceIntf,importUnifyData)
+> import Exports(expandInterface,exportInterface)
+> import Eval(evalEnv,evalEnvGoal)
+> import Qual(qual,qualGoal)
+> import Desugar(desugar,desugarGoal)
+> import Simplify(simplify)
+> import Lift(lift)
+> import qualified IL
+> import ILTrans(ilTrans,ilTransIntf)
+> import ILxml(xmlModule) -- check
+> import ExtendedFlat
+> import GenFlatCurry (genFlatCurry,genFlatInterface)
+> import AbstractCurry
+> import GenAbstractCurry
+> import InterfaceCheck
+> import CurryEnv
+> import CurryPP(ppModule,ppInterface,ppIDecl,ppGoal)
+> import qualified ILPP(ppModule)
+> import CurryCompilerOpts(Options(..),Dump(..))
+> import CompilerResults
+> import CaseCompletion
+> import PathUtils
+> import TypeSubst
+> import Pretty
+> import Error
+> import Env
+> import TopEnv
+
+\end{verbatim}
+The function \texttt{compileModule} is the main entry-point of this
+module for compiling a Curry source module. Depending on the command
+line options it will emit either C code or FlatCurry code (standard 
+or in XML
+representation) or AbtractCurry code (typed, untyped or with type
+signatures) for the module. Usually the first step is to
+check the module. Then the code is translated into the intermediate
+language. If necessary, this phase will also update the module's
+interface file. The resulting code then is either written out (in
+FlatCurry or XML format) or translated further into C code.
+The untyped  AbstractCurry representation is written
+out directly after parsing and simple checking the source file. 
+The typed AbstractCurry code is written out after checking the module.
+
+The compiler automatically loads the prelude when compiling any
+module, except for the prelude itself, by adding an appropriate import
+declaration to the module. 
+
+Since this modified version of the Muenster Curry Compiler is used
+as a frontend for PAKCS, all functions for evaluating goals and generating C 
+code are obsolete and commented out.
+\begin{verbatim}
+
+> compileModule :: Options -> FilePath -> IO ()
+> compileModule opts fn = compileModule_ opts fn >> return ()
+
+> compileModule_ :: Options -> FilePath -> IO CompilerResults
+> compileModule_ opts fn =
+>   do
+>     mod <- liftM (parseModule likeFlat fn) (readModule fn)
+>     let m = patchModuleId fn mod
+>     checkModuleId fn m
+>     mEnv <- loadInterfaces (importPaths opts) m
+>     if uacy || src
+>        then 
+>          do (tyEnv, tcEnv, aEnv, m', intf, _) <- simpleCheckModule opts mEnv m
+>             if uacy then genAbstract opts fn tyEnv tcEnv m'
+>                     else do
+>                       let outputFile = maybe (rootname fn ++ sourceRepExt) 
+>                                              id 
+>                                              (output opts)
+>                           outputMod = showModule m'
+>                       writeModule outputFile outputMod
+>                       return defaultResults
+>        else
+>          do (tyEnv, tcEnv, aEnv, m', intf, _) <- checkModule opts mEnv m
+>             let (il,aEnv',dumps) = transModule fcy False False 
+>			                         mEnv tyEnv tcEnv aEnv m'
+>             mapM_ (doDump opts) dumps
+>	      genCode opts fn mEnv tyEnv tcEnv aEnv' intf m' il
+>   where acy      = abstract opts
+>         uacy     = untypedAbstract opts
+>         fcy      = flat opts
+>         xml      = flatXml opts
+>         src      = parseOnly opts
+>         likeFlat = fcy || xml || acy || uacy || src
+>	  
+>         genCode opts fn mEnv tyEnv tcEnv aEnv intf m il
+>            | fcy || xml = genFlat opts fn mEnv tyEnv tcEnv aEnv intf m il
+>            | acy        = genAbstract opts fn tyEnv tcEnv m
+>            | otherwise  = return defaultResults
+
+> parseModule :: Bool -> FilePath -> String -> Module
+> parseModule likeFlat fn =
+>   importPrelude fn . ok . parseSource likeFlat fn . unlitLiterate fn
+
+> loadInterfaces :: [FilePath] -> Module -> IO ModuleEnv
+> loadInterfaces paths (Module m _ ds) =
+>   foldM (loadInterface paths [m]) emptyEnv
+>         [(p,m) | ImportDecl p m _ _ _ <- ds]
+
+> checkModuleId :: Monad m => FilePath -> Module -> m ()
+> checkModuleId fn (Module mid _ _)
+>    | last (moduleQualifiers mid) == basename (rootname fn)
+>      = return ()
+>    | otherwise
+>      = error ("module \"" ++ moduleName mid 
+>	        ++ "\" must be in a file \"" ++ moduleName mid
+>	        ++ ".curry\"")
+
+> simpleCheckModule :: Options -> ModuleEnv -> Module 
+>	    -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[Message])
+> simpleCheckModule opts mEnv (Module m es ds) =
+>   do unless (noWarn opts) (printMessages msgs)
+>      return (tyEnv'', tcEnv, aEnv'', modul, intf, msgs)
+>   where (impDs,topDs) = partition isImportDecl ds
+>         iEnv = foldr bindAlias initIEnv impDs
+>         (pEnv,tcEnv,tyEnv,aEnv) = importModules mEnv impDs
+>         msgs = warnCheck m tyEnv impDs topDs
+>	  withExt = withExtensions opts
+>         (pEnv',topDs') = precCheck m pEnv 
+>		           $ syntaxCheck withExt m iEnv aEnv tyEnv tcEnv
+>			   $ kindCheck m tcEnv topDs
+>         ds' = impDs ++ qual m tyEnv topDs'
+>         modul = (Module m es ds') --expandInterface (Module m es ds') tcEnv tyEnv
+>         (pEnv'',tcEnv'',tyEnv'',aEnv'') 
+>            = qualifyEnv mEnv pEnv' tcEnv tyEnv aEnv
+>         intf = exportInterface modul pEnv' tcEnv'' tyEnv''
+
+> checkModule :: Options -> ModuleEnv -> Module 
+>      -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[Message])
+> checkModule opts mEnv (Module m es ds) =
+>   do unless (noWarn opts) (printMessages msgs)
+>      when (m == mkMIdent ["field114..."])
+>           (error (show es))
+>      return (tyEnv''', tcEnv', aEnv'', modul, intf, msgs)
+>   where (impDs,topDs) = partition isImportDecl ds
+>         iEnv = foldr bindAlias initIEnv impDs
+>         (pEnv,tcEnvI,tyEnvI,aEnv) = importModules mEnv impDs
+>         tcEnv = if withExtensions opts
+>	             then fmap (expandRecordTC tcEnvI) tcEnvI
+>		     else tcEnvI
+>         lEnv = importLabels mEnv impDs
+>	  tyEnvL = addImportedLabels m lEnv tyEnvI
+>	  tyEnv = if withExtensions opts
+>	             then fmap (expandRecordTypes tcEnv) tyEnvL
+>		     else tyEnvI
+>         msgs = warnCheck m tyEnv impDs topDs
+>	  withExt = withExtensions opts
+>         (pEnv',topDs') = precCheck m pEnv 
+>		           $ syntaxCheck withExt m iEnv aEnv tyEnv tcEnv
+>			   $ kindCheck m tcEnv topDs
+>         (tcEnv',tyEnv') = typeCheck m tcEnv tyEnv topDs'
+>         ds' = impDs ++ qual m tyEnv' topDs'
+>         modul = expandInterface (Module m es ds') tcEnv' tyEnv'
+>         (pEnv'',tcEnv'',tyEnv'',aEnv'') 
+>            = qualifyEnv mEnv pEnv' tcEnv' tyEnv' aEnv
+>         tyEnvL' = addImportedLabels m lEnv tyEnv''
+>	  tyEnv''' = if withExtensions opts
+>	                then fmap (expandRecordTypes tcEnv'') tyEnvL'
+>		        else tyEnv''
+>         --tyEnv''' = addImportedLabels m lEnv tyEnv''
+>         intf = exportInterface modul pEnv'' tcEnv'' tyEnv'''
+
+> transModule :: Bool -> Bool -> Bool -> ModuleEnv -> ValueEnv -> TCEnv
+>      -> ArityEnv -> Module -> (IL.Module,ArityEnv,[(Dump,Doc)])
+> transModule flat debug trusted mEnv tyEnv tcEnv aEnv (Module m es ds) =
+>     (il',aEnv',dumps)
+>   where topDs = filter (not . isImportDecl) ds
+>         evEnv = evalEnv topDs
+>         (desugared,tyEnv') = desugar tyEnv tcEnv (Module m es topDs)
+>         (simplified,tyEnv'') = simplify flat tyEnv' evEnv desugared
+>         (lifted,tyEnv''',evEnv') = lift tyEnv'' evEnv simplified
+>         aEnv' = bindArities aEnv lifted
+>         il = ilTrans flat tyEnv''' tcEnv evEnv' lifted
+>         il' = completeCase mEnv il
+>         dumps = [(DumpRenamed,ppModule (Module m es ds)),
+>	           (DumpTypes,ppTypes m (localBindings tyEnv)),
+>	           (DumpDesugared,ppModule desugared),
+>                  (DumpSimplified,ppModule simplified),
+>                  (DumpLifted,ppModule lifted),
+>                  (DumpIL,ILPP.ppModule il),
+>	           (DumpCase,ILPP.ppModule il')
+>	          ]
+
+> qualifyEnv :: ModuleEnv -> PEnv -> TCEnv -> ValueEnv -> ArityEnv
+>     -> (PEnv,TCEnv,ValueEnv,ArityEnv)
+> qualifyEnv mEnv pEnv tcEnv tyEnv aEnv =
+>   (foldr bindQual pEnv' (localBindings pEnv),
+>    foldr bindQual tcEnv' (localBindings tcEnv),
+>    foldr bindGlobal tyEnv' (localBindings tyEnv),
+>    foldr bindQual aEnv' (localBindings aEnv))
+>   where (pEnv',tcEnv',tyEnv',aEnv') =
+>           foldl importInterface initEnvs (envToList mEnv)
+>         importInterface (pEnv,tcEnv,tyEnv,aEnv) (m,ds) =
+>           importInterfaceIntf (Interface m ds) pEnv tcEnv tyEnv aEnv
+>         bindQual (_,y) = qualBindTopEnv "Modules.qualifyEnv" (origName y) y
+>         bindGlobal (x,y)
+>           | uniqueId x == 0 = bindQual (x,y)
+>           | otherwise = bindTopEnv "Modules.qualifyEnv" x y
+
+> --ilImports :: ValueEnv -> TCEnv -> ModuleEnv -> IL.Module -> [IL.Decl]
+> --ilImports tyEnv tcEnv mEnv (IL.Module _ is _) =
+> --  concat [ilTransIntf tyEnv tcEnv (Interface m ds) 
+> --           | (m,ds) <- envToList mEnv, m `elem` is]
+
+> writeXML :: Maybe FilePath -> FilePath -> CurryEnv -> IL.Module -> IO ()
+> writeXML tfn sfn cEnv il = writeModule ofn (showln code)
+>   where ofn  = fromMaybe (rootname sfn ++ xmlExt) tfn
+>         code = (xmlModule cEnv il)
+
+> writeFlat :: Options -> Maybe FilePath -> FilePath -> CurryEnv -> ModuleEnv 
+>              -> ValueEnv -> TCEnv -> ArityEnv -> IL.Module -> IO Prog
+> writeFlat opts tfn sfn cEnv mEnv tyEnv tcEnv aEnv il
+>   = writeFlatFile opts (genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv il)
+>                        (fromMaybe (rootname sfn ++ flatExt) tfn)
+
+> writeFInt :: Options -> Maybe FilePath -> FilePath -> CurryEnv -> ModuleEnv
+>              -> ValueEnv -> TCEnv -> ArityEnv -> IL.Module -> IO Prog
+> writeFInt opts tfn sfn cEnv mEnv tyEnv tcEnv aEnv il 
+>   = writeFlatFile opts (genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il)
+>                        (fromMaybe (rootname sfn ++ fintExt) tfn)
+
+> writeFlatFile :: (Show a) => Options -> (Prog, [a]) -> String -> IO Prog
+> writeFlatFile opts (res,msgs) fname = do
+>         unless (noWarn opts) (printMessages msgs)
+>	  writeFlatCurry fname res
+>         return res
+
+
+> writeTypedAbs :: Maybe FilePath -> FilePath -> ValueEnv -> TCEnv -> Module
+>	           -> IO ()
+> writeTypedAbs tfn sfn tyEnv tcEnv mod
+>    = writeCurry fname (genTypedAbstract tyEnv tcEnv mod)
+>  where fname = fromMaybe (rootname sfn ++ acyExt) tfn
+
+> writeUntypedAbs :: Maybe FilePath -> FilePath -> ValueEnv -> TCEnv  
+>	             -> Module -> IO ()
+> writeUntypedAbs tfn sfn tyEnv tcEnv mod
+>    = writeCurry fname (genUntypedAbstract tyEnv tcEnv mod)
+>  where fname = fromMaybe (rootname sfn ++ uacyExt) tfn
+
+> --writeCode :: Maybe FilePath -> FilePath -> Either CFile [CFile] -> IO ()
+> --writeCode tfn sfn (Left cfile) = writeCCode ofn cfile
+> --  where ofn = fromMaybe (rootname sfn ++ cExt) tfn
+> --writeCode tfn sfn (Right cfiles) = zipWithM_ (writeCCode . mkFn) [1..] cfiles
+> --  where prefix = fromMaybe (rootname sfn) tfn
+> --        mkFn i = prefix ++ show i ++ cExt
+
+> --writeCCode :: FilePath -> CFile -> IO ()
+> --writeCCode fn = writeFile fn . showln . ppCFile
+
+> showln :: Show a => a -> String
+> showln x = shows x "\n"
+
+\end{verbatim}
+A goal is compiled with respect to a given module. If no module is
+specified the Curry prelude is used. The source module has to be
+parsed and type checked before the goal can be compiled.  Otherwise
+compilation of a goal is similar to that of a module.
+
+\em{Note:} These functions are obsolete when using the MCC as frontend
+for PAKCS.
+\begin{verbatim}
+
+> --compileGoal :: Options -> Maybe String -> Maybe FilePath -> IO ()
+> --compileGoal opts g fn =
+> --  do
+> --    (ccode,dumps) <- maybe (return startupCode) goalCode g
+> --    mapM_ (doDump opts) dumps
+> --    writeCCode ofn ccode
+> --  where ofn = fromMaybe (internalError "No filename for startup code")
+> --                        (output opts)
+> --        startupCode = (genMain "curry_run",[])
+> --        goalCode = doCompileGoal (debug opts) (importPath opts) fn
+
+> --doCompileGoal :: Bool -> [FilePath] -> Maybe FilePath -> String
+> --              -> IO (CFile,[(Dump,Doc)])
+> --doCompileGoal debug paths fn g =
+> --  do
+> --    (mEnv,_,ds) <- loadGoalModule paths fn
+> --    let (tyEnv,g') = checkGoal mEnv ds (ok (parseGoal g))
+> --        (ccode,dumps) =
+> --          transGoal debug runGoal mEnv tyEnv (mkIdent "goal") g'
+> --        ccode' = genMain runGoal
+> --    return (mergeCFile ccode ccode',dumps)
+> --  where runGoal = "curry_runGoal"
+
+> --typeGoal :: Options -> String -> Maybe FilePath -> IO ()
+> --typeGoal opts g fn =
+> --  do
+> --    (mEnv,m,ds) <- loadGoalModule (importPath opts) fn
+> --    let (tyEnv,Goal _ e _) = checkGoal mEnv ds (ok (parseGoal g))
+> --    print (ppType m (typeOf tyEnv e))
+
+> --loadGoalModule :: [FilePath] -> Maybe FilePath
+> --               -> IO (ModuleEnv,ModuleIdent,[Decl])
+> --loadGoalModule paths fn =
+> --  do
+> --    Module m _ ds <- maybe (return emptyModule) parseGoalModule fn
+> --    mEnv <- loadInterfaces paths (Module m Nothing ds)
+> --    let (_,_,_,_,intf) = checkModule mEnv (Module m Nothing ds)
+> --    return (bindModule intf mEnv,m,filter isImportDecl ds ++ [importMain m])
+> --  where emptyModule = importPrelude "" (Module emptyMIdent Nothing [])
+> --        parseGoalModule fn = liftM (parseModule False fn) (readFile fn)
+> --        importMain m = ImportDecl (first "") m False Nothing Nothing
+
+> --checkGoal :: ModuleEnv -> [Decl] -> Goal -> (ValueEnv,Goal)
+> --checkGoal mEnv impDs g = (tyEnv'',qualGoal tyEnv' g')
+> --  where (pEnv,tcEnv,tyEnv,aEnv) = importModules mEnv impDs
+> --        g' = precCheckGoal pEnv $ syntaxCheckGoal tyEnv
+> --                                $ kindCheckGoal tcEnv g
+> --        tyEnv' = typeCheckGoal tcEnv tyEnv g'
+> --        (_,_,tyEnv'',_) = qualifyEnv mEnv pEnv tcEnv tyEnv' emptyTopEnv
+
+> --transGoal :: Bool -> String -> ModuleEnv -> ValueEnv -> Ident -> Goal
+> --          -> (CFile,[(Dump,Doc)])
+> --transGoal debug run mEnv tyEnv goalId g = (ccode,dumps)
+> --  where qGoalId = qualifyWith emptyMIdent goalId
+> --        evEnv = evalEnvGoal g
+> --        (vs,desugared,tyEnv') = desugarGoal debug tyEnv emptyMIdent goalId g
+> --        (simplified,tyEnv'') = simplify False tyEnv' evEnv desugared
+> --        (lifted,tyEnv''',evEnv') = lift tyEnv'' evEnv simplified
+> --        il = ilTrans False tyEnv''' evEnv' lifted
+> --        ilDbg = if debug then dAddMain goalId (dTransform False il) else il
+> --        ilNormal = liftProg ilDbg
+> --        cam = camCompile ilNormal
+> --        imports = camCompileData (ilImports mEnv ilDbg)
+> --        ccode =
+> --          genModule imports cam ++
+> --          genEntry run (fun qGoalId) (fmap (map name) vs)
+> --        dumps = [
+> --            (DumpRenamed,ppGoal g),
+> --            (DumpTypes,ppTypes emptyMIdent (localBindings tyEnv)),
+> --            (DumpDesugared,ppModule desugared),
+> --            (DumpSimplified,ppModule simplified),
+> --            (DumpLifted,ppModule lifted),
+> --            (DumpIL,ILPP.ppModule il),
+> --            (DumpTransformed,ILPP.ppModule ilDbg),
+> --            (DumpNormalized,ILPP.ppModule ilNormal),
+> --            (DumpCam,CamPP.ppModule cam)
+> --          ]
+
+\end{verbatim}
+The compiler adds a startup function for the default goal
+\texttt{main.main} to the \texttt{main} module. Thus, there is no need
+to determine the type of the goal when linking the program.
+\begin{verbatim}
+
+> --compileDefaultGoal :: Bool -> ModuleEnv -> Interface -> Maybe CFile
+> --compileDefaultGoal debug mEnv (Interface m ds)
+> --  | m == mainMIdent && any (qMainId ==) [f | IFunctionDecl _ f _ _ <- ds] =
+> --      Just ccode
+> --  | otherwise = Nothing
+> --  where qMainId = qualify mainId
+> --        mEnv' = bindModule (Interface m ds) mEnv
+> --        (tyEnv,g) =
+> --          checkGoal mEnv' [ImportDecl (first "") m False Nothing Nothing]
+> --                    (Goal (first "") (Variable qMainId) [])
+> --        (ccode,_) = transGoal debug "curry_run" mEnv' tyEnv mainId g
+
+\end{verbatim}
+The function \texttt{importModules} brings the declarations of all
+imported modules into scope for the current module.
+\begin{verbatim}
+
+> importModules :: ModuleEnv -> [Decl] -> (PEnv,TCEnv,ValueEnv,ArityEnv)
+> importModules mEnv ds = (pEnv,importUnifyData tcEnv,tyEnv,aEnv)
+>   where (pEnv,tcEnv,tyEnv,aEnv) = foldl importModule initEnvs ds
+>         importModule (pEnv,tcEnv,tyEnv,aEnv) (ImportDecl p m q asM is) =
+>           case lookupModule m mEnv of
+>             Just ds -> importInterface p (fromMaybe m asM) q is
+>                                        (Interface m ds) pEnv tcEnv tyEnv aEnv
+>             Nothing -> internalError "importModule"
+>         importModule (pEnv,tcEnv,tyEnv,aEnv) _ = (pEnv,tcEnv,tyEnv,aEnv)
+
+> initEnvs :: (PEnv,TCEnv,ValueEnv,ArityEnv)
+> initEnvs = (initPEnv,initTCEnv,initDCEnv,initAEnv)
+
+\end{verbatim}
+Unlike unsual identifiers like in functions, types etc. identifiers
+of labels are always represented unqualified within the whole context
+of compilation. Since the common type environment (type \texttt{ValueEnv})
+has some problems with handling imported unqualified identifiers, it is 
+necessary to add the type information for labels seperately. For this reason
+the function \texttt{importLabels} generates an environment containing
+all imported labels and the function \texttt{addImportedLabels} adds this
+content to a type environment.
+\begin{verbatim}
+
+> importLabels :: ModuleEnv -> [Decl] -> LabelEnv
+> importLabels mEnv ds = foldl importLabelTypes initLabelEnv ds
+>   where
+>   importLabelTypes lEnv (ImportDecl p m _ asM is) =
+>     case (lookupModule m mEnv) of
+>       Just ds' -> foldl (importLabelType p (fromMaybe m asM) is) lEnv ds'
+>       Nothing -> internalError "importLabels"
+>   importLabelTypes lEnv _ = lEnv
+>		      
+>   importLabelType p m is lEnv (ITypeDecl _ r _ (RecordType fs _)) =
+>     foldl (insertLabelType p m r' (getImportSpec r' is)) lEnv fs
+>     where r' = qualifyWith m (fromRecordExtId (unqualify r))
+>   importLabelType _ _ _ lEnv _ = lEnv
+>			   
+>   insertLabelType p m r (Just (ImportTypeAll _)) lEnv ([l],ty) =
+>     bindLabelType l r (toType [] ty) lEnv
+>   insertLabelType p m r (Just (ImportTypeWith _ ls)) lEnv ([l],ty)
+>     | l `elem` ls = bindLabelType l r (toType [] ty) lEnv
+>     | otherwise   = lEnv
+>   insertLabelType _ _ _ _ lEnv _ = lEnv
+>			     
+>   getImportSpec r (Just (Importing _ is')) =
+>     find (isImported (unqualify r)) is'
+>   getImportSpec r Nothing = Just (ImportTypeAll (unqualify r))
+>   getImportSpec r _ = Nothing
+>		
+>   isImported r (Import r') = r == r'
+>   isImported r (ImportTypeWith r' _) = r == r'
+>   isImported r (ImportTypeAll r') = r == r'
+
+> addImportedLabels :: ModuleIdent -> LabelEnv -> ValueEnv -> ValueEnv
+> addImportedLabels m lEnv tyEnv = 
+>   foldr addLabelType tyEnv (concatMap snd (envToList lEnv))
+>   where
+>   addLabelType (LabelType l r ty) tyEnv = 
+>     let m' = fromMaybe m (fst (splitQualIdent r))
+>     in  importTopEnv m' l 
+>                      (Label (qualify l) (qualQualify m' r) (polyType ty)) 
+>	               tyEnv
+
+\end{verbatim}
+Fully expand all (imported) record types within the type constructor 
+environment and the type environment.
+Note: the record types for the current module are expanded within the
+type check.
+\begin{verbatim}
+
+> expandRecordTC :: TCEnv -> TypeInfo -> TypeInfo
+> expandRecordTC tcEnv (DataType qid n args) =
+>   DataType qid n (map (maybe Nothing (Just . (expandData tcEnv))) args)
+> expandRecordTC tcEnv (RenamingType qid n (Data id m ty)) =
+>   RenamingType qid n (Data id m (expandRecords tcEnv ty))
+> expandRecordTC tcEnv (AliasType qid n ty) =
+>   AliasType qid n (expandRecords tcEnv ty)
+
+> expandData :: TCEnv -> Data [Type] -> Data [Type]
+> expandData tcEnv (Data id n tys) =
+>   Data id n (map (expandRecords tcEnv) tys)
+
+> expandRecordTypes :: TCEnv -> ValueInfo -> ValueInfo
+> expandRecordTypes tcEnv (DataConstructor qid (ForAllExist n m ty)) =
+>   DataConstructor qid (ForAllExist n m (expandRecords tcEnv ty))
+> expandRecordTypes tcEnv (NewtypeConstructor qid (ForAllExist n m ty)) =
+>   NewtypeConstructor qid (ForAllExist n m (expandRecords tcEnv ty))
+> expandRecordTypes tcEnv (Value qid (ForAll n ty)) =
+>   Value qid (ForAll n (expandRecords tcEnv ty))
+> expandRecordTypes tcEnv (Label qid r (ForAll n ty)) =
+>   Label qid r (ForAll n (expandRecords tcEnv ty))
+
+> expandRecords :: TCEnv -> Type -> Type
+> expandRecords tcEnv (TypeConstructor qid tys) =
+>   case (qualLookupTC qid tcEnv) of
+>     [AliasType _ _ rty@(TypeRecord _ _)]
+>       -> expandRecords tcEnv 
+>            (expandAliasType (map (expandRecords tcEnv) tys) rty)
+>     _ -> TypeConstructor qid (map (expandRecords tcEnv) tys)
+> expandRecords tcEnv (TypeConstrained tys v) =
+>   TypeConstrained (map (expandRecords tcEnv) tys) v
+> expandRecords tcEnv (TypeArrow ty1 ty2) =
+>   TypeArrow (expandRecords tcEnv ty1) (expandRecords tcEnv ty2)
+> expandRecords tcEnv (TypeRecord fs rv) =
+>   TypeRecord (map (\ (l,ty) -> (l,expandRecords tcEnv ty)) fs) rv
+> expandRecords _ ty = ty
+
+\end{verbatim}
+An implicit import of the prelude is added to the declarations of
+every module, except for the prelude itself. If no explicit import for
+the prelude is present, the prelude is imported unqualified, otherwise
+only a qualified import is added.
+\begin{verbatim}
+
+> importPrelude :: FilePath -> Module -> Module
+> importPrelude fn (Module m es ds) =
+>   Module m es (if m == preludeMIdent then ds else ds')
+>   where ids = filter isImportDecl ds
+>         ds' = ImportDecl (first fn) preludeMIdent
+>                          (preludeMIdent `elem` map importedModule ids)
+>                          Nothing Nothing : ds
+>         importedModule (ImportDecl _ m q asM is) = fromMaybe m asM
+
+\end{verbatim}
+If an import declaration for a module is found, the compiler first
+checks whether an import for the module is already pending. In this
+case the module imports are cyclic which is not allowed in Curry. The
+compilation will therefore be aborted. Next, the compiler checks
+whether the module has been imported already. If so, nothing needs to
+be done, otherwise the interface will be searched in the import paths
+and compiled.
+\begin{verbatim}
+
+> loadInterface :: [FilePath] -> [ModuleIdent] -> ModuleEnv ->
+>     (Position,ModuleIdent) -> IO ModuleEnv
+> loadInterface paths ctxt mEnv (p,m)
+>   | m `elem` ctxt = errorAt p (cyclicImport m (takeWhile (/= m) ctxt))
+>   | isLoaded m mEnv = return mEnv
+>   | otherwise =
+>       lookupInterface paths m >>=
+>       maybe (errorAt p (interfaceNotFound m))
+>             (compileInterface paths ctxt mEnv m)
+>   where isLoaded m mEnv = maybe False (const True) (lookupModule m mEnv)
+
+\end{verbatim}
+After reading an interface, all imported interfaces are recursively
+loaded and entered into the interface's environment. There is no need
+to check FlatCurry-Interfaces, since these files contain automaticaly
+generated FlatCurry terms (type \texttt{Prog}).
+\begin{verbatim}
+
+> compileInterface :: [FilePath] -> [ModuleIdent] -> ModuleEnv -> ModuleIdent
+>                  -> FilePath -> IO ModuleEnv
+> compileInterface paths ctxt mEnv m fn =
+>   do
+>     mintf <- readFlatInterface fn
+>     let intf = fromMaybe (errorAt (first fn) (interfaceNotFound m)) mintf
+>         (Prog mod _ _ _ _) = intf
+>         m' = mkMIdent [mod]
+>     unless (m' == m) (errorAt (first fn) (wrongInterface m m'))
+>     mEnv' <- loadFlatInterfaces paths ctxt mEnv intf
+>     return (bindFlatInterface intf mEnv')
+
+> --loadIntfInterfaces :: [FilePath] -> [ModuleIdent] -> ModuleEnv -> Interface
+> --                   -> IO ModuleEnv
+> --loadIntfInterfaces paths ctxt mEnv (Interface m ds) =
+> --  foldM (loadInterface paths (m:ctxt)) mEnv [(p,m) | IImportDecl p m <- ds]
+
+
+> loadFlatInterfaces :: [FilePath] -> [ModuleIdent] -> ModuleEnv -> Prog
+>                    -> IO ModuleEnv
+> loadFlatInterfaces paths ctxt mEnv (Prog m is _ _ _) =
+>   foldM (loadInterface paths ((mkMIdent [m]):ctxt)) 
+>         mEnv 
+>         (map (\i -> (p, mkMIdent [i])) is)
+>  where p = first m
+
+> --checkInterface :: ModuleEnv -> Interface -> Interface
+> --checkInterface mEnv (Interface m ds) =
+> --  intfCheck pEnv tcEnv tyEnv (Interface m ds)
+> --  where (pEnv,tcEnv,tyEnv) = foldl importInterface initEnvs ds
+> --        importInterface (pEnv,tcEnv,tyEnv) (IImportDecl p m) =
+> --          case lookupModule m mEnv of
+> --            Just ds -> importInterfaceIntf (Interface m ds) pEnv tcEnv tyEnv
+> --            Nothing -> internalError "importInterface"
+> --        importInterface (pEnv,tcEnv,tyEnv) _ = (pEnv,tcEnv,tyEnv)
+
+
+\end{verbatim}
+Interface files are updated by the Curry builder when necessary.
+(see module \texttt{CurryBuilder}).
+
+Description of the following obsolete functions:
+After checking the module successfully, the compiler may need to
+update the module's interface file. The file will be updated only if
+the interface has been changed or the file did not exist before.
+
+The code is a little bit tricky because we must make sure that the
+interface file is closed before rewriting the interface, even if it
+has not been read completely. On the other hand, we must not apply
+\texttt{hClose} too early. Note that there is no need to close the
+interface explicitly if the interface check succeeds because the whole
+file must have been read in this case. In addition, we do not update
+the interface file in this case and therefore it doesn't matter when
+the file is closed.
+\begin{verbatim}
+
+> --updateInterface :: FilePath -> Interface -> IO ()
+> --updateInterface sfn i =
+> --  do
+> --    eq <- catch (matchInterface ifn i) (const (return False))
+> --    unless eq (writeInterface ifn i)
+> --  where ifn = rootname sfn ++ intfExt
+
+> --matchInterface :: FilePath -> Interface -> IO Bool
+> --matchInterface ifn i =
+> --  do
+> --    h <- openFile ifn ReadMode
+> --    s <- hGetContents h
+> --    case parseInterface ifn s of
+> --      Ok i' | i `intfEquiv` fixInterface i' -> return True
+> --      _ -> hClose h >> return False
+
+> --writeInterface :: FilePath -> Interface -> IO ()
+> --writeInterface ifn = writeFile ifn . showln . ppInterface
+
+\end{verbatim}
+The compiler searches for interface files in the import search path
+using the extension \texttt{".fint"}. Note that the current
+directory is always searched first.
+\begin{verbatim}
+
+> lookupInterface :: [FilePath] -> ModuleIdent -> IO (Maybe FilePath)
+> lookupInterface paths m = lookupFile (ifn : [catPath p ifn | p <- paths])
+>   where ifn = foldr1 catPath (moduleQualifiers m) ++ fintExt
+
+\end{verbatim}
+Literate source files use the extension \texttt{".lcurry"}.
+\begin{verbatim}
+
+> unlitLiterate :: FilePath -> String -> String
+> unlitLiterate fn s
+>   | not (isLiterateSource fn) = s
+>   | null es = s'
+>   | otherwise = error es
+>   where (es,s') = unlit fn s
+
+> isLiterateSource :: FilePath -> Bool
+> isLiterateSource fn = litExt `isSuffixOf` fn
+
+\end{verbatim}
+The \texttt{doDump} function writes the selected information to the
+standard output.
+\begin{verbatim}
+
+> doDump :: Options -> (Dump,Doc) -> IO ()
+> doDump opts (d,x) =
+>   when (d `elem` dump opts)
+>        (print (text hd $$ text (replicate (length hd) '=') $$ x))
+>   where hd = dumpHeader d
+
+> dumpHeader :: Dump -> String
+> dumpHeader DumpRenamed = "Module after renaming"
+> dumpHeader DumpTypes = "Types"
+> dumpHeader DumpDesugared = "Source code after desugaring"
+> dumpHeader DumpSimplified = "Source code after simplification"
+> dumpHeader DumpLifted = "Source code after lifting"
+> dumpHeader DumpIL = "Intermediate code"
+> dumpHeader DumpCase = "Intermediate code after case simplification"
+> --dumpHeader DumpTransformed = "Transformed code" 
+> --dumpHeader DumpNormalized = "Intermediate code after normalization"
+> --dumpHeader DumpCam = "Abstract machine code"
+
+
+\end{verbatim}
+The functions \texttt{genFlat} and \texttt{genAbstract} generate
+flat and abstract curry representations depending on the specified option.
+If the interface of a modified Curry module did not change, the corresponding 
+file name will be returned within the result of \texttt{genFlat} (depending
+on the compiler flag "force") and other modules importing this module won't
+be dependent on it any longer.
+\begin{verbatim}
+
+> genFlat :: Options -> FilePath -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv 
+>            -> Interface -> Module -> IL.Module -> IO CompilerResults
+> genFlat opts fname mEnv tyEnv tcEnv aEnv intf mod il
+>   | flat opts
+>     = do writeFlat opts Nothing fname cEnv mEnv tyEnv tcEnv aEnv il
+>          let (flatInterface,intMsgs) = genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il
+>          if force opts
+>            then 
+>              do writeInterface flatInterface intMsgs
+>                 return defaultResults
+>            else 
+>               do mfint <- readFlatInterface fintName
+>                  let flatIntf = fromMaybe emptyIntf mfint
+>                  if mfint == mfint  -- necessary to close the file 'fintName'
+>                        && not (interfaceCheck flatIntf flatInterface)
+>                     then 
+>                        do writeInterface flatInterface intMsgs
+>                           return defaultResults
+>                     else return defaultResults
+>   | flatXml opts
+>     = writeXML (output opts) fname cEnv il >> return defaultResults
+>   | otherwise
+>     = internalError "@Modules.genFlat: illegal option"
+>  where
+>    fintName = rootname fname ++ fintExt
+>    cEnv = curryEnv mEnv tcEnv intf mod
+>    emptyIntf = Prog "" [] [] [] []
+>    writeInterface intf msgs = do
+>          unless (noWarn opts) (printMessages msgs)
+>          writeFlatCurry fintName intf
+
+
+> genAbstract :: Options -> FilePath  -> ValueEnv -> TCEnv -> Module 
+>                -> IO CompilerResults
+> genAbstract opts fname tyEnv tcEnv mod
+>    | abstract opts
+>      = do writeTypedAbs Nothing fname tyEnv tcEnv mod 
+>           return defaultResults
+>    | untypedAbstract opts
+>      = do writeUntypedAbs Nothing fname tyEnv tcEnv mod
+>           return defaultResults
+>    | otherwise
+>      = internalError "@Modules.genAbstract: illegal option"
+
+> printMessages :: Show a => [a] -> IO ()
+> printMessages []   = return ()
+> printMessages msgs = hPutStrLn stderr $ unlines $ map show msgs
+
+\end{verbatim}
+The function \texttt{ppTypes} is used for pretty-printing the types
+from the type environment.
+\begin{verbatim}
+
+> ppTypes :: ModuleIdent -> [(Ident,ValueInfo)] -> Doc
+> ppTypes m = vcat . map (ppIDecl . mkDecl) . filter (isValue . snd)
+>   where mkDecl (v,Value _ (ForAll _ ty)) =
+>           IFunctionDecl undefined (qualify v) (arrowArity ty) 
+>		      (fromQualType m ty)
+>         isValue (DataConstructor _ _) = False
+>         isValue (NewtypeConstructor _ _) = False
+>         isValue (Value _ _) = True
+>         isValue (Label _ _ _) = False
+
+
+\end{verbatim}
+A module which doesn't contain a \texttt{module ... where} declaration
+obtains its filename as module identifier (unlike the definition in
+Haskell and original MCC where a module obtains \texttt{main}).
+\begin{verbatim}
+
+> patchModuleId :: FilePath -> Module -> Module
+> patchModuleId fn (Module mid mexports decls)
+>    | (moduleName mid) == "main"
+>      = Module (mkMIdent [basename (rootname fn)]) mexports decls
+>    | otherwise
+>      = Module mid mexports decls
+
+
+\end{verbatim}
+Various filename extensions
+\begin{verbatim}
+
+> cExt = ".c"
+> xmlExt = "_flat.xml"
+> flatExt = ".fcy"
+> fintExt = ".fint"
+> acyExt = ".acy"
+> uacyExt = ".uacy"
+> sourceRepExt = ".cy"
+> intfExt = ".icurry"
+> litExt = ".lcurry"
+
+\end{verbatim}
+Error functions.
+\begin{verbatim}
+
+> interfaceNotFound :: ModuleIdent -> String
+> interfaceNotFound m = "Interface for module " ++ moduleName m ++ " not found"
+
+> cyclicImport :: ModuleIdent -> [ModuleIdent] -> String
+> cyclicImport m [] = "Recursive import for module " ++ moduleName m
+> cyclicImport m ms =
+>   "Cyclic import dependency between modules " ++ moduleName m ++
+>     modules "" ms
+>   where modules comma [m] = comma ++ " and " ++ moduleName m
+>         modules _ (m:ms) = ", " ++ moduleName m ++ modules "," ms
+
+> wrongInterface :: ModuleIdent -> ModuleIdent -> String
+> wrongInterface m m' =
+>   "Expected interface for " ++ show m ++ " but found " ++ show m'
+
+\end{verbatim}
diff --git a/src/NestEnv.lhs b/src/NestEnv.lhs
new file mode 100644
--- /dev/null
+++ b/src/NestEnv.lhs
@@ -0,0 +1,73 @@
+
+% $Id: NestEnv.lhs,v 1.11 2003/10/04 17:04:23 wlux Exp $
+%
+% Copyright (c) 1999-2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{NestEnv.lhs}
+\subsection{Nested Environments}
+The \texttt{NestEnv} environment type extends top-level environments
+(see section~\ref{sec:toplevel-env}) to manage nested scopes. Local
+scopes allow only for a single, unambiguous definition.
+
+As a matter of convenience, the module \texttt{TopEnv} is exported by
+the module \texttt{NestEnv}.  Thus, only the latter needs to be
+imported.
+\begin{verbatim}
+
+> module NestEnv(module TopEnv, NestEnv, bindNestEnv,qualBindNestEnv,
+>                lookupNestEnv,qualLookupNestEnv,
+>                toplevelEnv,globalEnv,nestEnv) where
+> import Env
+> import TopEnv
+> import Ident
+
+> data NestEnv a = GlobalEnv (TopEnv a) | LocalEnv (NestEnv a) (Env Ident a)
+>                  deriving Show
+
+> instance Functor NestEnv where
+>   fmap f (GlobalEnv env) = GlobalEnv (fmap f env)
+>   fmap f (LocalEnv genv env) = LocalEnv (fmap f genv) (fmap f env)
+
+> bindNestEnv :: Ident -> a -> NestEnv a -> NestEnv a
+> bindNestEnv x y (GlobalEnv env) 
+>   = GlobalEnv (bindTopEnv "NestEnv.bindNestEnv" x y env)
+> bindNestEnv x y (LocalEnv genv env) =
+>   case lookupEnv x env of
+>     Just _ -> error "internal error: bindNestEnv"
+>     Nothing -> LocalEnv genv (bindEnv x y env)
+
+> qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a
+> qualBindNestEnv x y (GlobalEnv env) 
+>   = GlobalEnv (qualBindTopEnv "NestEnv.qualBindNestEnv" x y env)
+> qualBindNestEnv x y (LocalEnv genv env)
+>   | isQualified x = error "internal error: qualBindNestEnv"
+>   | otherwise =
+>       case lookupEnv x' env of
+>         Just _ -> error "internal error: qualBindNestEnv"
+>         Nothing -> LocalEnv genv (bindEnv x' y env)
+>   where x' = unqualify x
+
+> lookupNestEnv :: Ident -> NestEnv a -> [a]
+> lookupNestEnv x (GlobalEnv env) = lookupTopEnv x env
+> lookupNestEnv x (LocalEnv genv env) =
+>   case lookupEnv x env of
+>     Just y -> [y]
+>     Nothing -> lookupNestEnv x genv
+
+> qualLookupNestEnv :: QualIdent -> NestEnv a -> [a]
+> qualLookupNestEnv x env
+>   | isQualified x = qualLookupTopEnv x (toplevelEnv env)
+>   | otherwise = lookupNestEnv (unqualify x) env
+
+> toplevelEnv :: NestEnv a -> TopEnv a
+> toplevelEnv (GlobalEnv env) = env
+> toplevelEnv (LocalEnv genv _) = toplevelEnv genv
+
+> globalEnv :: TopEnv a -> NestEnv a
+> globalEnv = GlobalEnv
+
+> nestEnv :: NestEnv a -> NestEnv a
+> nestEnv env = LocalEnv env emptyEnv
+
+\end{verbatim}
diff --git a/src/OldScopeEnv.hs b/src/OldScopeEnv.hs
new file mode 100644
--- /dev/null
+++ b/src/OldScopeEnv.hs
@@ -0,0 +1,170 @@
+module OldScopeEnv (ScopeEnv,
+		    newScopeEnv,
+		    insertIdent, getIdentLevel,
+		    isVisible, isDeclared,
+		    beginScope, endScope,
+		    getLevel,
+		    genIdent, genIdentList) where
+
+import Data.Maybe
+
+import Ident
+import Env
+
+
+
+-------------------------------------------------------------------------------
+
+-- Type for representing an environment containing identifiers in several
+-- scope levels
+type ScopeEnv = (IdEnv, [IdEnv], Int)
+
+-------------------------------------------------------------------------------
+
+-- Generates a new instance of a scope table
+newScopeEnv :: ScopeEnv
+newScopeEnv = (newIdEnv, [], 0)
+
+
+-- Inserts an identifier into the current level of the scope environment
+insertIdent :: Ident -> ScopeEnv -> ScopeEnv
+insertIdent ident (topleveltab, leveltabs, level)
+   = case leveltabs of
+       (lt:lts) -> (topleveltab, (insertId level ident lt):lts, level)
+       []       -> ((insertId level ident topleveltab), [], 0)
+
+
+-- Returns the declaration level of an identifier if it exists
+getIdentLevel :: Ident -> ScopeEnv -> Maybe Int
+getIdentLevel ident (topleveltab, leveltabs, _)
+   = case leveltabs of
+       (lt:_) -> maybe (getIdLevel ident topleveltab) Just (getIdLevel ident lt)
+       []     -> getIdLevel ident topleveltab
+
+
+-- Checks whether the specified identifier is visible in the current scope
+-- (i.e. checks whether the identifier occurs in the scope environment)
+isVisible :: Ident -> ScopeEnv -> Bool
+isVisible ident (topleveltab, leveltabs, _)
+   = case leveltabs of
+       (lt:_) -> idExists ident lt || idExists ident topleveltab
+       []     -> idExists ident topleveltab
+
+
+-- Checks whether the specified identifier is declared in the
+-- current scope (i.e. checks whether the identifier occurs in the
+-- current level of the scope environment)
+isDeclared :: Ident -> ScopeEnv -> Bool
+isDeclared ident (topleveltab, leveltabs, level)
+   = case leveltabs of
+       (lt:_) -> maybe False ((==) level) (getIdLevel ident lt)
+       []     -> maybe False ((==) 0) (getIdLevel ident topleveltab)
+
+
+-- Increases the level of the scope.
+beginScope :: ScopeEnv -> ScopeEnv
+beginScope (topleveltab, leveltabs, level)
+   = case leveltabs of
+       (lt:lts) -> (topleveltab, (lt:lt:lts), level + 1)
+       []       -> (topleveltab, [newIdEnv], 1)
+
+
+-- Decreases the level of the scope. Identifier from higher levels
+-- will be lost.
+endScope :: ScopeEnv -> ScopeEnv
+endScope (topleveltab, leveltabs, level)
+   = case leveltabs of
+       (_:lts) -> (topleveltab, lts, level - 1)
+       []      -> (topleveltab, [], 0)
+
+
+-- Returns the level of the current scope. Top level is 0
+getLevel :: ScopeEnv -> Int
+getLevel (_, _, level) = level
+
+
+-- Generates a new identifier for the specified name. The new identifier is 
+-- unique within the current scope. If no identifier can be generated for 
+-- 'name' then 'Nothing' will be returned
+genIdent :: String -> ScopeEnv -> Maybe Ident
+genIdent name (topleveltab, leveltabs, _)
+   = case leveltabs of
+       (lt:_) -> genId name lt
+       []     -> genId name topleveltab
+
+
+-- Generates a list of new identifiers where each identifier has
+-- the prefix 'name' followed by  an index (i.e. "var3" if 'name' was "var").
+-- All returned identifiers are unique within the current scope.
+genIdentList :: Int -> String -> ScopeEnv -> [Ident]
+genIdentList size name scopeenv = p_genIdentList size name scopeenv 0
+ where
+   p_genIdentList s n env i
+      | s == 0 
+	= []
+      | otherwise
+	= maybe (p_genIdentList s n env (i + 1))
+	        (\ident -> ident:(p_genIdentList (s - 1) 
+				                 n 
+				                 (insertIdent ident env) 
+				                 (i + 1)))
+		(genIdent (n ++ (show i)) env)
+
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+-- Private declarations...
+
+type IdEnv = Env IdRep Int
+
+data IdRep = Name String | Index Int deriving (Eq, Ord)
+
+
+-------------------------------------------------------------------------------
+
+--
+newIdEnv :: IdEnv
+newIdEnv = emptyEnv
+
+
+--
+insertId :: Int -> Ident -> IdEnv -> IdEnv
+insertId level ident env
+   = bindEnv (Name (name ident)) 
+             level 
+	     (bindEnv (Index (uniqueId ident)) level env)
+
+
+--
+idExists :: Ident -> IdEnv -> Bool
+idExists ident env = indexExists (uniqueId ident) env
+
+
+--
+getIdLevel :: Ident -> IdEnv -> Maybe Int
+getIdLevel ident env = lookupEnv (Index (uniqueId ident)) env
+
+
+--
+genId n env
+   | nameExists n env = Nothing
+   | otherwise        = Just (p_genId (mkIdent n) 0)
+ where
+   p_genId ident index
+      | indexExists index env = p_genId ident (index + 1)
+      | otherwise             = renameIdent ident index
+
+
+--
+nameExists :: String -> IdEnv -> Bool
+nameExists name env = isJust (lookupEnv (Name name) env)
+
+
+--
+indexExists :: Int -> IdEnv -> Bool
+indexExists index env = isJust (lookupEnv (Index index) env)
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/PatchPrelude.hs b/src/PatchPrelude.hs
new file mode 100644
--- /dev/null
+++ b/src/PatchPrelude.hs
@@ -0,0 +1,40 @@
+module PatchPrelude where
+
+
+import ExtendedFlat
+
+
+-- the prelude has to be extended by data declarations for list and tuples
+
+prelude = "Prelude"
+
+patchPreludeFCY :: Prog -> Prog
+patchPreludeFCY (Prog name imports types funcs ops)
+   | name == prelude
+     = Prog name [] (prelude_types_fcy ++ types) funcs ops
+   | otherwise
+     = Prog name imports types funcs ops
+
+prelude_types_fcy :: [TypeDecl]
+prelude_types_fcy =
+  let unit = mkQName (prelude,"()")
+      nil  = mkQName (prelude,"[]") in
+  [Type unit Public [] [(Cons unit 0 Public [])],
+   Type nil Public [0] 
+        [Cons nil 0 Public [],
+         Cons (mkQName (prelude,":")) 2 Public 
+              [TVar 0, TCons nil [TVar 0]]]] ++
+  map tupleType [2..maxTupleArity]
+
+tupleType ar = 
+  let tuplecons = mkQName (prelude,"("++take (ar-1) (repeat ',')++")") in
+  Type tuplecons Public [0..ar-1]
+       [Cons tuplecons ar Public (map TVar [0..ar-1])]
+
+-- Maximal arity of tuples:
+maxTupleArity = 15
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
diff --git a/src/PathUtils.lhs b/src/PathUtils.lhs
new file mode 100644
--- /dev/null
+++ b/src/PathUtils.lhs
@@ -0,0 +1,60 @@
+
+% $Id: PathUtils.lhs,v 1.5 2003/05/04 16:12:35 wlux Exp $
+%
+% Copyright (c) 1999-2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{PathUtils.lhs}
+\section{Pathnames}
+This module implements some utility functions for manipulating path
+names and finding files.
+\begin{verbatim}
+
+> module PathUtils(basename, rootname,extension, catPath,
+>                  lookupFile,
+>                  currySubdir,writeModule,readModule,
+>                  doesModuleExist,maybeReadModule,getModuleModTime) where
+
+> import System.FilePath
+> import System.Directory
+> import CurrySubdir
+
+\end{verbatim}
+
+Most of this module is superseded by System.FilePath from package filepath.
+
+Within this module we assume Unix style path semantics, i.e.\ 
+components of a path name are separated by forward slash characters
+(\texttt{/}) and file extensions are separated with a dot character
+(\texttt{.}).
+
+\end{verbatim}
+
+> catPath :: FilePath -> FilePath -> FilePath
+> catPath = combine
+>
+> rootname, extension :: FilePath -> FilePath
+> rootname = dropExtension
+> extension = takeExtension
+
+\end{verbatim}
+
+The function \texttt{lookupFile} can be used to search for files. It
+returns the first name from the argument list for which a regular file
+exists in the file system.
+\begin{verbatim}
+
+> lookupFile :: [FilePath] -> IO (Maybe FilePath)
+> lookupFile fns = lookupFile' (concatMap (\ fn -> [inCurrySubdir fn,fn]) fns)
+>   where
+>     lookupFile' [] = return Nothing
+>     lookupFile' (fn:fns) =
+>      do
+>       so <- doesFileExist fn
+>       if so then return (Just fn) else lookupFile' fns
+
+\end{verbatim}
+
+
+
+
diff --git a/src/Position.lhs b/src/Position.lhs
new file mode 100644
--- /dev/null
+++ b/src/Position.lhs
@@ -0,0 +1,95 @@
+> {-# LANGUAGE DeriveDataTypeable #-}
+
+% -*- LaTeX -*-
+% $Id: Position.lhs,v 1.2 2000/10/08 09:55:43 lux Exp $
+%
+% $Log: Position.lhs,v $
+% Revision 1.2  2000/10/08 09:55:43  lux
+% Column numbers now start at 1. If the column number is less than 1 it
+% will not be shown.
+%
+% Revision 1.1  2000/07/23 11:03:37  lux
+% Positions now implemented in a separate module.
+%
+%
+\nwfilename{Position.lhs}
+\section{Positions}
+A source file position consists of a filename, a line number, and a
+column number. A tab stop is assumed at every eighth column.
+\begin{verbatim}
+
+> module Position where
+> import Data.Generics
+
+> newtype SrcRef = SrcRef [Int] deriving (Typeable,Data) -- a pointer to the origin
+
+-- the instances for standard classes or such that SrcRefs are invisible
+
+> instance Show SrcRef where show _ = ""
+> instance Read SrcRef where readsPrec _ s = [(noRef,s)]
+> instance Eq SrcRef   where _ == _ = True
+> instance Ord SrcRef  where compare _ _ = EQ
+
+> noRef :: SrcRef
+> noRef = SrcRef []
+>
+> incSrcRef :: SrcRef -> Int -> SrcRef
+> incSrcRef (SrcRef [i]) j = SrcRef [i+j]
+> incSrcRef is  _ = error $ "internal error; increment source ref: " ++ show is
+
+> data Position 
+>   = Position{ file :: FilePath, line :: Int, column :: Int, ast :: SrcRef }
+>   | AST { ast :: SrcRef }
+>   deriving (Eq, Ord,Data,Typeable)
+>
+> incPosition :: Position -> Int -> Position
+> incPosition p j = p{ast=incSrcRef (ast p) j}
+
+
+> instance Read Position where
+>   readsPrec p s = 
+>     [ (Position{file="",line=i,column=j,ast=noRef},s')  | ((i,j),s') <- readsPrec p s]
+
+> instance Show Position where
+>   showsPrec _ Position{file=fn,line=l,column=c} =
+>     (if null fn then id else shows fn . showString ", ") .
+>     showString "line " . shows l .
+>     (if c > 0 then showChar '.' . shows c else id)
+>   showsPrec _ AST{} = id
+
+> tabWidth :: Int
+> tabWidth = 8
+
+> first :: FilePath -> Position
+> first fn = Position fn 1 1 noRef
+
+> incr :: Position -> Int -> Position
+> incr p@Position{column=c} n = p{column=c + n}
+
+> next :: Position -> Position
+> next = flip incr 1
+
+> tab :: Position -> Position
+> tab p@Position{column=c} = p{column=c + tabWidth - (c - 1) `mod` tabWidth}
+
+> nl :: Position -> Position
+> nl p@Position{line=l} = p{line=l + 1, column=1}
+
+> noPos, noPos' :: Position
+> noPos  = Position{ file = "", line = 0, column = 0, ast = noRef }
+> noPos' = AST noRef
+
+> showLine :: Position -> String
+> showLine x@Position{line=l,column=c} 
+>      | x == noPos = ""
+>      | otherwise = "(line " ++ show l ++ "." ++ show c ++ ") "
+
+\end{verbatim}
+
+> class SrcRefOf a where
+>   srcRefsOf :: a -> [SrcRef]
+>   srcRefsOf = (:[]) . srcRefOf
+>   srcRefOf :: a -> SrcRef
+>   srcRefOf = head . srcRefsOf
+
+> instance SrcRefOf Position where srcRefOf = ast
diff --git a/src/PrecCheck.lhs b/src/PrecCheck.lhs
new file mode 100644
--- /dev/null
+++ b/src/PrecCheck.lhs
@@ -0,0 +1,462 @@
+
+% $Id: PrecCheck.lhs,v 1.21 2004/02/15 22:10:34 wlux Exp $
+%
+% Copyright (c) 2001-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{PrecCheck.lhs}
+\section{Checking Precedences of Infix Operators}
+The parser does not know the relative precedences of infix operators
+and therefore parses them as if they all associate to the right and
+have the same precedence. After performing the definition checks,
+the compiler is going to process the infix applications in the module
+and rearrange infix applications according to the relative precedences
+of the operators involved.
+\begin{verbatim}
+
+> module PrecCheck(precCheck,precCheckGoal) where
+
+> import Data.List
+
+> import Base
+
+\end{verbatim}
+For each declaration group, including the module-level, the compiler
+first checks that its fixity declarations contain no duplicates and
+that there is a corresponding value or constructor declaration in that
+group. The fixity declarations are then used for extending the
+imported precedence environment.
+\begin{verbatim}
+
+> bindPrecs :: ModuleIdent -> [Decl] -> PEnv -> PEnv
+> bindPrecs m ds pEnv =
+>   case linear ops of
+>     Linear ->
+>       case [PIdent p op | PIdent p op <- ops, op `notElem` bvs] of
+>         [] -> foldr bindPrec pEnv fixDs
+>         PIdent p op : _ -> errorAt' (undefinedOperator op)
+>     NonLinear (PIdent p op) -> errorAt' (duplicatePrecedence op)
+>   where (fixDs,nonFixDs) = partition isInfixDecl ds
+>         bvs = concatMap boundValues nonFixDs
+>         ops = [PIdent p op | InfixDecl p _ _ ops <- fixDs, op <- ops]
+>         bindPrec (InfixDecl _ fix pr ops) pEnv
+>           | p == defaultP = pEnv
+>           | otherwise = foldr (flip (bindP m) p) pEnv ops
+>           where p = OpPrec fix pr
+
+> boundValues :: Decl -> [Ident]
+> boundValues (DataDecl _ _ _ cs) = map constr cs
+>   where constr (ConstrDecl _ _ c _) = c
+>         constr (ConOpDecl _ _ _ op _) = op
+> boundValues (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]
+> boundValues (FunctionDecl _ f _) = [f]
+> boundValues (ExternalDecl _ _ _ f _) = [f]
+> boundValues (FlatExternalDecl _ fs) = fs
+> boundValues (PatternDecl _ t _) = bv t
+> boundValues (ExtraVariables _ vs) = vs
+> boundValues _ = []
+
+\end{verbatim}
+With the help of the precedence environment, the compiler checks all
+infix applications and sections in the program. This pass will modify
+the parse tree such that for a nested infix application the operator
+with the lowest precedence becomes the root and that two adjacent
+operators with the same precedence will not have conflicting
+associativities. Note that the top-level precedence environment has to
+be returned because it is needed for constructing the module's
+interface.
+\begin{verbatim}
+
+> precCheck :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])
+> precCheck = checkDecls
+
+> precCheckGoal :: PEnv -> Goal -> Goal
+> precCheckGoal pEnv (Goal p e ds) = Goal p (checkExpr m pEnv' e) ds'
+>   where (pEnv',ds') = checkDecls m pEnv ds
+>         m = emptyMIdent
+
+> checkDecls :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])
+> checkDecls m pEnv ds = pEnv' `seq` (pEnv',ds')
+>   where pEnv' = bindPrecs m ds pEnv
+>         ds' = map (checkDecl m pEnv') ds
+
+> checkDecl :: ModuleIdent -> PEnv -> Decl -> Decl
+> checkDecl m pEnv (FunctionDecl p f eqs) =
+>   FunctionDecl p f (map (checkEqn m pEnv) eqs)
+> checkDecl m pEnv (PatternDecl p t rhs) =
+>   PatternDecl p (checkConstrTerm pEnv t) (checkRhs m pEnv rhs)
+> checkDecl _ _ d = d
+
+> checkEqn :: ModuleIdent -> PEnv -> Equation -> Equation
+> checkEqn m pEnv (Equation p lhs rhs) =
+>   Equation p (checkLhs pEnv lhs) (checkRhs m pEnv rhs)
+
+> checkLhs :: PEnv -> Lhs -> Lhs
+> checkLhs pEnv (FunLhs f ts) = FunLhs f (map (checkConstrTerm pEnv) ts)
+> checkLhs pEnv (OpLhs t1 op t2) = t1' `seq` t2' `seq` OpLhs t1' op t2'
+>   where t1' = checkOpL pEnv op (checkConstrTerm pEnv t1)
+>         t2' = checkOpR pEnv op (checkConstrTerm pEnv t2)
+> checkLhs pEnv (ApLhs lhs ts) =
+>   ApLhs (checkLhs pEnv lhs) (map (checkConstrTerm pEnv) ts)
+
+> checkConstrTerm :: PEnv -> ConstrTerm -> ConstrTerm
+> checkConstrTerm _ (LiteralPattern l) = LiteralPattern l
+> checkConstrTerm _ (NegativePattern op l) = NegativePattern op l
+> checkConstrTerm _ (VariablePattern v) = VariablePattern v
+> checkConstrTerm pEnv (ConstructorPattern c ts) =
+>   ConstructorPattern c (map (checkConstrTerm pEnv) ts)
+> checkConstrTerm pEnv (InfixPattern t1 op t2) =
+>   fixPrecT pEnv InfixPattern
+>	 (checkConstrTerm pEnv t1) op (checkConstrTerm pEnv t2)
+> checkConstrTerm pEnv (ParenPattern t) =
+>   ParenPattern (checkConstrTerm pEnv t)
+> checkConstrTerm pEnv (TuplePattern p ts) =
+>   TuplePattern p (map (checkConstrTerm pEnv) ts)
+> checkConstrTerm pEnv (ListPattern p ts) =
+>   ListPattern p (map (checkConstrTerm pEnv) ts)
+> checkConstrTerm pEnv (AsPattern v t) =
+>   AsPattern v (checkConstrTerm pEnv t)
+> checkConstrTerm pEnv (LazyPattern p t) =
+>   LazyPattern p (checkConstrTerm pEnv t)
+> checkConstrTerm pEnv (FunctionPattern f ts) =
+>   FunctionPattern f (map (checkConstrTerm pEnv) ts)
+> checkConstrTerm pEnv (InfixFuncPattern t1 op t2) =
+>   fixPrecT pEnv InfixFuncPattern 
+>	 (checkConstrTerm pEnv t1) op (checkConstrTerm pEnv t2)
+> checkConstrTerm pEnv (RecordPattern fs r) =
+>   RecordPattern (map (checkFieldPattern pEnv) fs)
+>	          (maybe Nothing (Just . checkConstrTerm pEnv) r)
+
+> checkFieldPattern :: PEnv -> Field ConstrTerm -> Field ConstrTerm
+> checkFieldPattern pEnv (Field p label patt) =
+>     Field p label (checkConstrTerm pEnv patt)
+
+> checkRhs :: ModuleIdent -> PEnv -> Rhs -> Rhs
+> checkRhs m pEnv (SimpleRhs p e ds) = SimpleRhs p (checkExpr m pEnv' e) ds'
+>   where (pEnv',ds') = checkDecls m pEnv ds
+> checkRhs m pEnv (GuardedRhs es ds) =
+>   GuardedRhs (map (checkCondExpr m pEnv') es) ds'
+>   where (pEnv',ds') = checkDecls m pEnv ds
+
+> checkCondExpr :: ModuleIdent -> PEnv -> CondExpr -> CondExpr
+> checkCondExpr m pEnv (CondExpr p g e) =
+>   CondExpr p (checkExpr m pEnv g) (checkExpr m pEnv e)
+
+> checkExpr :: ModuleIdent -> PEnv -> Expression -> Expression
+> checkExpr _ _ (Literal l) = Literal l
+> checkExpr _ _ (Variable v) = Variable v
+> checkExpr _ _ (Constructor c) = Constructor c
+> checkExpr m pEnv (Paren e) = Paren (checkExpr m  pEnv e)
+> checkExpr m pEnv (Typed e ty) = Typed (checkExpr m  pEnv e) ty
+> checkExpr m pEnv (Tuple p es) = Tuple p (map (checkExpr m  pEnv) es)
+> checkExpr m pEnv (List p es) = List p (map (checkExpr m  pEnv) es)
+> checkExpr m pEnv (ListCompr p e qs) = ListCompr p (checkExpr m  pEnv' e) qs'
+>   where (pEnv',qs') = mapAccumL (checkStmt m ) pEnv qs
+> checkExpr m pEnv (EnumFrom e) = EnumFrom (checkExpr m pEnv e)
+> checkExpr m pEnv (EnumFromThen e1 e2) =
+>   EnumFromThen (checkExpr m pEnv e1) (checkExpr m pEnv e2)
+> checkExpr m pEnv (EnumFromTo e1 e2) =
+>   EnumFromTo (checkExpr m pEnv e1) (checkExpr m pEnv e2)
+> checkExpr m pEnv (EnumFromThenTo e1 e2 e3) =
+>   EnumFromThenTo (checkExpr m pEnv e1)
+>                  (checkExpr m pEnv e2)
+>                  (checkExpr m pEnv e3)
+> checkExpr m pEnv (UnaryMinus op e) = UnaryMinus op (checkExpr m pEnv e)
+> checkExpr m pEnv (Apply e1 e2) =
+>   Apply (checkExpr m pEnv e1) (checkExpr m pEnv e2)
+> checkExpr m pEnv (InfixApply e1 op e2) =
+>   fixPrec pEnv (checkExpr m pEnv e1) op (checkExpr m pEnv e2)
+> checkExpr m pEnv (LeftSection e op) =
+>   checkLSection pEnv op (checkExpr m pEnv e)
+> checkExpr m pEnv (RightSection op e) =
+>   checkRSection pEnv op (checkExpr m pEnv e)
+> checkExpr m pEnv (Lambda r ts e) =
+>   Lambda r (map (checkConstrTerm pEnv) ts) (checkExpr m pEnv e)
+> checkExpr m pEnv (Let ds e) = Let ds' (checkExpr m pEnv' e)
+>   where (pEnv',ds') = checkDecls m pEnv ds
+> checkExpr m pEnv (Do sts e) = Do sts' (checkExpr m pEnv' e)
+>   where (pEnv',sts') = mapAccumL (checkStmt m ) pEnv sts
+> checkExpr m pEnv (IfThenElse r e1 e2 e3) =
+>   IfThenElse r (checkExpr m pEnv e1)
+>              (checkExpr m pEnv e2)
+>              (checkExpr m pEnv e3)
+> checkExpr m pEnv (Case r e alts) =
+>   Case r (checkExpr m pEnv e) (map (checkAlt m pEnv) alts)
+> checkExpr m pEnv (RecordConstr fs) =
+>   RecordConstr (map (checkFieldExpr m pEnv) fs)
+> checkExpr m pEnv (RecordSelection e label) =
+>   RecordSelection (checkExpr m pEnv e) label
+> checkExpr m pEnv (RecordUpdate fs e) =
+>   RecordUpdate (map (checkFieldExpr m pEnv) fs) (checkExpr m pEnv e)
+
+> checkFieldExpr :: ModuleIdent -> PEnv -> Field Expression -> Field Expression
+> checkFieldExpr m pEnv (Field p label e) =
+>   Field p label (checkExpr m  pEnv e)
+
+> checkStmt :: ModuleIdent -> PEnv -> Statement -> (PEnv,Statement)
+> checkStmt m pEnv (StmtExpr p e) = (pEnv,StmtExpr p (checkExpr m pEnv e))
+> checkStmt m pEnv (StmtDecl ds) = pEnv' `seq` (pEnv',StmtDecl ds')
+>   where (pEnv',ds') = checkDecls m pEnv ds
+> checkStmt m pEnv (StmtBind p t e) =
+>   (pEnv,StmtBind p (checkConstrTerm pEnv t) (checkExpr m pEnv e))
+
+> checkAlt :: ModuleIdent -> PEnv -> Alt -> Alt
+> checkAlt m pEnv (Alt p t rhs) =
+>   Alt p (checkConstrTerm pEnv t) (checkRhs m pEnv rhs)
+
+\end{verbatim}
+The functions \texttt{fixPrec}, \texttt{fixUPrec}, and
+\texttt{fixRPrec} check the relative precedences of adjacent infix
+operators in nested infix applications and unary negations. The
+expressions will be reordered such that the infix operator with the
+lowest precedence becomes the root of the expression. \emph{The
+functions rely on the fact that the parser constructs infix
+applications in a right-associative fashion}, i.e., the left argument
+of an infix application will never be an infix application. In
+addition, a unary negation will never have an infix application as
+its argument.
+
+The function \texttt{fixPrec} checks whether the left argument of an
+infix application is a unary negation and eventually reorders the
+expression if the precedence of the infix operator is higher than that
+of the negation. This will be done with the help of the function
+\texttt{fixUPrec}. In any case, the function \texttt{fixRPrec} is used
+for fixing the precedence of the infix operator and that of its right
+argument. Note that both arguments already have been checked before
+\texttt{fixPrec} is called.
+\begin{verbatim}
+
+> fixPrec :: PEnv -> Expression -> InfixOp -> Expression
+>         -> Expression
+> fixPrec pEnv (UnaryMinus uop e1) op e2
+>   | pr < 6 || pr == 6 && fix == InfixL =
+>       fixRPrec pEnv (UnaryMinus uop e1) op e2
+>   | pr > 6 = fixUPrec pEnv uop e1 op e2
+>   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op)
+>   where OpPrec fix pr = opPrec op pEnv
+> fixPrec pEnv e1 op e2 = fixRPrec pEnv e1 op e2
+
+> fixUPrec :: PEnv -> Ident -> Expression -> InfixOp -> Expression
+>          -> Expression
+> fixUPrec pEnv uop  _ op (UnaryMinus _ _) =
+>   errorAt' $ ambiguousParse "operator" (opName op) (qualify uop)
+> fixUPrec pEnv uop e1 op1 (InfixApply e2 op2 e3)
+>   | pr2 < 6 || pr2 == 6 && fix2 == InfixL =
+>       InfixApply (fixUPrec pEnv uop e1 op1 e2) op2 e3
+>   | pr2 > 6 = UnaryMinus uop (fixRPrec pEnv e1 op1 (InfixApply e2 op2 e3))
+>   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op2)
+>   where OpPrec fix1 pr1 = opPrec op1 pEnv
+>         OpPrec fix2 pr2 = opPrec op2 pEnv
+> fixUPrec _ uop e1 op e2 = UnaryMinus uop (InfixApply e1 op e2)
+
+> fixRPrec :: PEnv -> Expression -> InfixOp -> Expression
+>          -> Expression
+> fixRPrec pEnv e1 op (UnaryMinus uop e2)
+>   | pr < 6 = InfixApply e1 op (UnaryMinus uop e2)
+>   | otherwise =
+>       errorAt' $ ambiguousParse "operator" (opName op) (qualify uop)
+>   where OpPrec _ pr = opPrec op pEnv
+> fixRPrec pEnv e1 op1 (InfixApply e2 op2 e3)
+>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR =
+>       InfixApply e1 op1 (InfixApply e2 op2 e3)
+>   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL =
+>       InfixApply (fixPrec pEnv e1 op1 e2) op2 e3
+>   | otherwise =
+>       errorAt' $ ambiguousParse "operator" (opName op1) (opName op2)
+>   where OpPrec fix1 pr1 = opPrec op1 pEnv
+>         OpPrec fix2 pr2 = opPrec op2 pEnv
+> fixRPrec _ e1 op e2 = InfixApply e1 op e2
+
+\end{verbatim}
+The functions \texttt{checkLSection} and \texttt{checkRSection} are
+used for handling the precedences inside left and right sections.
+These functions only need to check that an infix operator occurring in
+the section has either a higher precedence than the section operator
+or both operators have the same precedence and are both left
+associative for a left section and right associative for a right
+section, respectively.
+\begin{verbatim}
+
+> checkLSection :: PEnv -> InfixOp -> Expression -> Expression
+> checkLSection pEnv op e@(UnaryMinus uop _)
+>   | pr < 6 || pr == 6 && fix == InfixL = LeftSection e op
+>   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op)
+>   where OpPrec fix pr = opPrec op pEnv
+> checkLSection pEnv op1 e@(InfixApply _ op2 _)
+>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL =
+>       LeftSection e op1
+>   | otherwise =
+>       errorAt' $ ambiguousParse "operator" (opName op1) (opName op2)
+>   where OpPrec fix1 pr1 = opPrec op1 pEnv
+>         OpPrec fix2 pr2 = opPrec op2 pEnv
+> checkLSection _ op e = LeftSection e op
+
+> checkRSection :: PEnv -> InfixOp -> Expression -> Expression
+> checkRSection pEnv op e@(UnaryMinus uop _)
+>   | pr < 6 = RightSection op e
+>   | otherwise = errorAt' $ ambiguousParse "unary" (qualify uop) (opName op)
+>   where OpPrec _ pr = opPrec op pEnv
+> checkRSection pEnv op1 e@(InfixApply _ op2 _)
+>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR =
+>       RightSection op1 e
+>   | otherwise =
+>       errorAt' $ ambiguousParse "operator" (opName op1) (opName op2)
+>   where OpPrec fix1 pr1 = opPrec op1 pEnv
+>         OpPrec fix2 pr2 = opPrec op2 pEnv
+> checkRSection _ op e = RightSection op e
+
+\end{verbatim}
+The functions \texttt{fixPrecT} and \texttt{fixRPrecT} check the
+relative precedences of adjacent infix operators in patterns. The
+patterns will be reordered such that the infix operator with the
+lowest precedence becomes the root of the term. \emph{The functions
+rely on the fact that the parser constructs infix patterns in a
+right-associative fashion}, i.e., the left argument of an infix pattern
+will never be an infix pattern. The functions also check whether the
+left and right arguments of an infix pattern are negative literals. In
+this case, the negation must bind more tightly than the operator for
+the pattern to be accepted.
+\begin{verbatim}
+
+> fixPrecT ::  PEnv 
+>             -> (ConstrTerm -> QualIdent -> ConstrTerm -> ConstrTerm)
+>	      -> ConstrTerm -> QualIdent -> ConstrTerm  
+>             -> ConstrTerm
+> fixPrecT pEnv infixpatt t1@(NegativePattern uop l) op t2
+>   | pr < 6 || pr == 6 && fix == InfixL 
+>     = fixRPrecT pEnv infixpatt t1 op t2
+>   | otherwise 
+>     = errorAt' $ invalidParse "unary" uop op
+>   where OpPrec fix pr = prec op pEnv
+> fixPrecT pEnv infixpatt t1 op t2 
+>   = fixRPrecT pEnv infixpatt t1 op t2
+
+> fixRPrecT :: PEnv 
+>              -> (ConstrTerm -> QualIdent -> ConstrTerm -> ConstrTerm)
+>              -> ConstrTerm  -> QualIdent -> ConstrTerm
+>              -> ConstrTerm
+> fixRPrecT pEnv infixpatt t1 op t2@(NegativePattern uop l)
+>   | pr < 6    = infixpatt t1 op t2
+>   | otherwise = errorAt' $ invalidParse "unary" uop op
+>   where OpPrec _ pr = prec op pEnv
+> fixRPrecT pEnv infixpatt t1 op1 (InfixPattern t2 op2 t3)
+>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR
+>     = infixpatt t1 op1 (InfixPattern t2 op2 t3)
+>   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
+>     = InfixPattern (fixPrecT pEnv infixpatt t1 op1 t2) op2 t3
+>   | otherwise 
+>     = errorAt' $ ambiguousParse "operator" op1 op2
+>   where OpPrec fix1 pr1 = prec op1 pEnv
+>         OpPrec fix2 pr2 = prec op2 pEnv
+> fixRPrecT pEnv infixpatt t1 op1 (InfixFuncPattern t2 op2 t3)
+>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR
+>     = infixpatt t1 op1 (InfixFuncPattern t2 op2 t3)
+>   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
+>     = InfixFuncPattern (fixPrecT pEnv infixpatt t1 op1 t2) op2 t3
+>   | otherwise 
+>     = errorAt' $ ambiguousParse "operator" op1 op2
+>   where OpPrec fix1 pr1 = prec op1 pEnv
+>         OpPrec fix2 pr2 = prec op2 pEnv
+> fixRPrecT _ infixpatt t1 op t2 = infixpatt t1 op t2
+
+> {-fixPrecT :: Position -> PEnv -> ConstrTerm -> QualIdent -> ConstrTerm
+>          -> ConstrTerm
+> fixPrecT p pEnv t1@(NegativePattern uop l) op t2
+>   | pr < 6 || pr == 6 && fix == InfixL = fixRPrecT p pEnv t1 op t2
+>   | otherwise = errorAt p $ invalidParse "unary" uop op
+>   where OpPrec fix pr = prec op pEnv
+> fixPrecT p pEnv t1 op t2 = fixRPrecT p pEnv t1 op t2-}
+
+> {-fixRPrecT :: Position -> PEnv -> ConstrTerm -> QualIdent -> ConstrTerm
+>           -> ConstrTerm
+> fixRPrecT p pEnv t1 op t2@(NegativePattern uop l)
+>   | pr < 6 = InfixPattern t1 op t2
+>   | otherwise = errorAt p $ invalidParse "unary" uop op
+>   where OpPrec _ pr = prec op pEnv
+> fixRPrecT p pEnv t1 op1 (InfixPattern t2 op2 t3)
+>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR =
+>       InfixPattern t1 op1 (InfixPattern t2 op2 t3)
+>   | pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL =
+>       InfixPattern (fixPrecT p pEnv t1 op1 t2) op2 t3
+>   | otherwise = errorAt p $ ambiguousParse "operator" op1 op2
+>   where OpPrec fix1 pr1 = prec op1 pEnv
+>         OpPrec fix2 pr2 = prec op2 pEnv
+> fixRPrecT _ _ t1 op t2 = InfixPattern t1 op t2-}
+
+\end{verbatim}
+The functions \texttt{checkOpL} and \texttt{checkOpR} check the left
+and right arguments of an operator declaration. If they are infix
+patterns they must bind more tightly than the operator, otherwise the
+left-hand side of the declaration is invalid.
+\begin{verbatim}
+
+> checkOpL :: PEnv -> Ident -> ConstrTerm -> ConstrTerm
+> checkOpL pEnv op t@(NegativePattern uop l)
+>   | pr < 6 || pr == 6 && fix == InfixL = t
+>   | otherwise = errorAt' $ invalidParse "unary" uop (qualify op)
+>   where OpPrec fix pr = prec (qualify op) pEnv
+> checkOpL pEnv op1 t@(InfixPattern _ op2 _)
+>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL = t
+>   | otherwise = errorAt' $ invalidParse "operator" op1 op2
+>   where OpPrec fix1 pr1 = prec (qualify op1) pEnv
+>         OpPrec fix2 pr2 = prec op2 pEnv
+> checkOpL _ _ t = t
+
+> checkOpR :: PEnv -> Ident -> ConstrTerm -> ConstrTerm
+> checkOpR pEnv op t@(NegativePattern uop l)
+>   | pr < 6 = t
+>   | otherwise = errorAt' $ invalidParse "unary" uop (qualify op)
+>   where OpPrec _ pr = prec (qualify op) pEnv
+> checkOpR pEnv op1 t@(InfixPattern _ op2 _)
+>   | pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR = t
+>   | otherwise = errorAt' $ invalidParse "operator" op1 op2
+>   where OpPrec fix1 pr1 = prec (qualify op1) pEnv
+>         OpPrec fix2 pr2 = prec op2 pEnv
+> checkOpR _ _ t = t
+
+\end{verbatim}
+The functions \texttt{opPrec} and \texttt{prec} return the fixity and
+operator precedence of an entity. Even though precedence checking is
+performed after the renaming phase, we have to be prepared to see
+ambiguous identifiers here. This may happen while checking the root of
+an operator definition that shadows an imported definition.
+\begin{verbatim}
+
+> opPrec :: InfixOp -> PEnv -> OpPrec
+> opPrec op = prec (opName op)
+
+> prec :: QualIdent -> PEnv -> OpPrec
+> prec op env =
+>   case qualLookupP op env of
+>     [] -> defaultP
+>     PrecInfo _ p : _ -> p
+
+\end{verbatim}
+Error messages.
+\begin{verbatim}
+
+> undefinedOperator :: Ident -> (Position,String)
+> undefinedOperator op = 
+>  (positionOfIdent op,
+>   "no definition for " ++ name op ++ " in this scope")
+
+> duplicatePrecedence :: Ident -> (Position,String)
+> duplicatePrecedence op = 
+>  (positionOfIdent op,
+>   "More than one fixity declaration for " ++ name op)
+
+> invalidParse :: String -> Ident -> QualIdent -> (Position,String)
+> invalidParse what op1 op2 =
+>  (positionOfIdent op1,
+>   "Invalid use of " ++ what ++ " " ++ name op1 ++ " with " ++ qualName op2 ++
+>   (showLine $ positionOfQualIdent op2))
+
+> ambiguousParse :: String -> QualIdent -> QualIdent -> (Position,String)
+> ambiguousParse what op1 op2 =
+>  (positionOfQualIdent op1,
+>   "Ambiguous use of " ++ what ++ " " ++ qualName op1 ++
+>   " with " ++ qualName op2 ++ (showLine $ positionOfQualIdent op2))
+
+\end{verbatim}
diff --git a/src/Pretty.lhs b/src/Pretty.lhs
new file mode 100644
--- /dev/null
+++ b/src/Pretty.lhs
@@ -0,0 +1,905 @@
+Hand converted to standard Haskell     -- jcp
+
+*********************************************************************************
+*                                                                               *
+*       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 wierd 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 itc 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  is behaves like sep,  but it uses <> for horizontal conposition
+        fcat is 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
+
+
+
+\begin{code}
+module Pretty (
+        Doc,            -- Abstract
+        Mode(..), TextDetails(..),
+	Style,
+
+        empty, nest,
+
+        text, char, ptext,
+        int, integer, float, double, rational,
+        parens, brackets, braces, quotes, doubleQuotes,
+        semi, comma, colon, space, equals,
+        lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+
+        (<>), (<+>), hcat, hsep, 
+        ($$), ($+$), vcat, 
+        sep, cat, 
+        fsep, fcat, 
+
+        hang, punctuate,
+        
+        renderStyle, 
+        render, fullRender
+  ) where
+
+-- Don't import Util( assertPanic ) because it makes a loop in the module structure
+
+import Data.Ratio
+infixl 6 <> 
+infixl 6 <+>
+infixl 5 $$, $+$
+\end{code}
+
+
+
+*********************************************************
+*                                                       *
+\subsection{CPP magic so that we can compile with both GHC and Hugs}
+*                                                       *
+*********************************************************
+
+The library uses unboxed types to get a bit more speed, but these CPP macros
+allow you to use either GHC or Hugs.  To get GHC, just set the CPP variable
+        __GLASGOW_HASKELL__
+
+
+*********************************************************
+*                                                       *
+\subsection{The interface}
+*                                                       *
+*********************************************************
+
+The primitive @Doc@ values
+
+\begin{code}
+empty                     :: Doc
+text                      :: String -> Doc 
+char                      :: Char -> Doc
+
+semi, comma, colon, space, equals              :: Doc
+lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
+
+parens, brackets, braces  :: Doc -> Doc 
+quotes, doubleQuotes      :: Doc -> Doc
+
+int      :: Int -> Doc
+integer  :: Integer -> Doc
+float    :: Float -> Doc
+double   :: Double -> Doc
+rational :: Rational -> Doc
+\end{code}
+
+
+Combining @Doc@ values
+
+\begin{code}
+(<>)   :: 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
+\end{code}
+
+GHC-specific ones.
+
+\begin{code}
+hang :: Doc -> Int -> Doc -> Doc
+punctuate :: Doc -> [Doc] -> [Doc]      -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
+\end{code}
+
+Displaying @Doc@ values. 
+
+\begin{code}
+instance Show Doc where
+  showsPrec prec doc cont = showDoc doc cont
+
+render     :: Doc -> String             -- Uses default style
+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
+
+renderStyle  :: Style -> Doc -> String
+data Style = Style { lineLength     :: Int,     -- In chars
+                     ribbonsPerLine :: Float,   -- Ratio of ribbon length to line length
+                     mode :: Mode
+             }
+style :: Style          -- The default style
+style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
+
+data Mode = PageMode            -- Normal 
+          | ZigZagMode          -- With zig-zag cuts
+          | LeftMode            -- No indentation, infinitely long lines
+          | OneLineMode         -- All on one line
+
+\end{code}
+
+
+*********************************************************
+*                                                       *
+\subsection{The @Doc@ calculus}
+*                                                       *
+*********************************************************
+
+The @Doc@ combinators satisfy the following laws:
+\begin{verbatim}
+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 
+\end{verbatim}
+
+
+You might think that the following verion of <m1> would
+be neater:
+\begin{verbatim}
+<3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$ 
+                                         nest (-length s) y)
+\end{verbatim}
+But it doesn't work, for if x=empty, we would have
+\begin{verbatim}
+        text s $$ y = text s <> (empty $$ nest (-length s) y)
+                    = text s <> nest (-length s) y
+\end{verbatim}
+
+
+
+*********************************************************
+*                                                       *
+\subsection{Simple derived definitions}
+*                                                       *
+*********************************************************
+
+\begin{code}
+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 = 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
+\end{code}
+
+
+*********************************************************
+*                                                       *
+\subsection{The @Doc@ data type}
+*                                                       *
+*********************************************************
+
+A @Doc@ represents a {\em set} of layouts.  A @Doc@ with
+no occurrences of @Union@ or @NoDoc@ represents just one layout.
+\begin{code}
+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'
+\end{code}
+
+Here are the invariants:
+\begin{itemize}
+\item
+The argument of @NilAbove@ is never @Empty@. Therefore
+a @NilAbove@ occupies at least two lines.
+
+\item
+The arugment of @TextBeside@ is never @Nest@.
+
+\item 
+The layouts of the two arguments of @Union@ both flatten to the same string.
+
+\item 
+The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
+
+\item
+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.
+
+\item 
+An empty document is always represented by @Empty@.
+It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
+
+\item 
+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.
+\end{itemize}
+
+\begin{code}
+        -- 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
+
+\end{code}
+
+
+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)
+
+
+
+*********************************************************
+*                                                       *
+\subsection{@empty@, @text@, @nest@, @union@}
+*                                                       *
+*********************************************************
+
+\begin{code}
+empty = Empty
+
+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       (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
+\end{code}
+
+*********************************************************
+*                                                       *
+\subsection{Vertical composition @$$@}
+*                                                       *
+*********************************************************
+
+
+\begin{code}
+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 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 = textBeside_ s sl rest
+                                    where
+                                      k1   = k - sl
+                                      rest = case p of
+                                                Empty -> nilAboveNest g k1 q
+                                                other -> aboveNest  p g k1 q
+\end{code}
+
+\begin{code}
+nilAboveNest :: Bool -> Int -> RDoc -> RDoc
+-- Specification: text s <> nilaboveNest g k q 
+--              = text s <> (text "" $g$ nest k q)
+
+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)
+\end{code}
+
+
+*********************************************************
+*                                                       *
+\subsection{Horizontal composition @<>@}
+*                                                       *
+*********************************************************
+
+\begin{code}
+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
+\end{code}
+
+\begin{code}
+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
+\end{code}
+
+*********************************************************
+*                                                       *
+\subsection{Separate, @sep@, Hughes version}
+*                                                       *
+*********************************************************
+
+\begin{code}
+-- 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 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
+\end{code}
+
+*********************************************************
+*                                                       *
+\subsection{@fill@}
+*                                                       *
+*********************************************************
+
+\begin{code}
+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 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 (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
+\end{code}
+
+
+*********************************************************
+*                                                       *
+\subsection{Selecting the best layout}
+*                                                       *
+*********************************************************
+
+\begin{code}
+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 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 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
+\end{code}
+
+@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
+@first@ returns its first argument if it is non-empty, otherwise its second.
+
+\begin{code}
+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
+\end{code}
+
+@oneLiner@ returns the one-line members of the given set of @Doc@s.
+
+\begin{code}
+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
+\end{code}
+
+
+
+*********************************************************
+*                                                       *
+\subsection{Displaying the best layout}
+*                                                       *
+*********************************************************
+
+
+\begin{code}
+renderStyle Style{mode=mode, lineLength=lineLength, ribbonsPerLine=ribbonsPerLine} doc 
+  = fullRender mode lineLength ribbonsPerLine 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
+\end{code}
+
+\begin{code}
+
+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 (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 s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
+    
+        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)
+\end{code}
+
diff --git a/src/Qual.lhs b/src/Qual.lhs
new file mode 100644
--- /dev/null
+++ b/src/Qual.lhs
@@ -0,0 +1,166 @@
+
+% $Id: Qual.lhs,v 1.18 2004/02/15 22:10:36 wlux Exp $
+%
+% Copyright (c) 2001-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{Qual.lhs}
+\section{Proper Qualification}
+After checking the module and before starting the translation into the
+intermediate language, the compiler properly qualifies all
+constructors and (global) functions occurring in a pattern or
+expression such that their module prefix matches the module of their
+definition. This is done also for functions and constructors declared
+in the current module. Only functions and variables declared in local
+declarations groups as well as function arguments remain unchanged.
+
+\em{Note:} The modified version also qualifies type constructors
+\begin{verbatim}
+
+> module Qual(qual,qualGoal) where
+> import Base
+> import TopEnv
+
+> qual :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl]
+> qual m tyEnv ds = map (qualDecl m tyEnv) ds
+
+> qualGoal :: ValueEnv -> Goal -> Goal
+> qualGoal tyEnv (Goal p e ds) =
+>   Goal p (qualExpr (mkMIdent []) tyEnv e) 
+>          (map (qualDecl (mkMIdent []) tyEnv) ds)
+
+> qualDecl :: ModuleIdent -> ValueEnv -> Decl -> Decl
+> qualDecl m tyEnv (FunctionDecl p f eqs) =
+>   FunctionDecl p f (map (qualEqn m tyEnv) eqs)
+> qualDecl m tyEnv (PatternDecl p t rhs) =
+>   PatternDecl p (qualTerm m tyEnv t) (qualRhs m tyEnv rhs)
+> qualDecl _ _ d = d
+
+> qualEqn :: ModuleIdent -> ValueEnv -> Equation -> Equation
+> qualEqn m tyEnv (Equation p lhs rhs) =
+>   Equation p (qualLhs m tyEnv lhs) (qualRhs m tyEnv rhs)
+
+> qualLhs :: ModuleIdent -> ValueEnv -> Lhs -> Lhs
+> qualLhs m tyEnv (FunLhs f ts) = FunLhs f (map (qualTerm m tyEnv) ts)
+> qualLhs m tyEnv (OpLhs t1 op t2) =
+>   OpLhs (qualTerm m tyEnv t1) op (qualTerm m tyEnv t2)
+> qualLhs m tyEnv (ApLhs lhs ts) =
+>   ApLhs (qualLhs m tyEnv lhs) (map (qualTerm m tyEnv) ts)
+
+> qualTerm :: ModuleIdent -> ValueEnv -> ConstrTerm -> ConstrTerm
+> qualTerm _ _ (LiteralPattern l) = LiteralPattern l
+> qualTerm _ _ (NegativePattern op l) = NegativePattern op l
+> qualTerm _ _ (VariablePattern v) = VariablePattern v
+> qualTerm m tyEnv (ConstructorPattern c ts) =
+>   ConstructorPattern (qualIdent m tyEnv c) (map (qualTerm m tyEnv) ts)
+> qualTerm m tyEnv (InfixPattern t1 op t2) =
+>   InfixPattern (qualTerm m tyEnv t1) 
+>                (qualIdent m tyEnv op) 
+>                (qualTerm m tyEnv t2)
+> qualTerm m tyEnv (ParenPattern t) = ParenPattern (qualTerm m tyEnv t)
+> qualTerm m tyEnv (TuplePattern p ts) = TuplePattern p (map (qualTerm m tyEnv) ts)
+> qualTerm m tyEnv (ListPattern p ts) = ListPattern p (map (qualTerm m tyEnv) ts)
+> qualTerm m tyEnv (AsPattern v t) = AsPattern v (qualTerm m tyEnv t)
+> qualTerm m tyEnv (LazyPattern p t) = LazyPattern p (qualTerm m tyEnv t)
+> qualTerm m tyEnv (FunctionPattern f ts) =
+>   FunctionPattern (qualIdent m tyEnv f) (map (qualTerm m tyEnv) ts)
+> qualTerm m tyEnv (InfixFuncPattern t1 op t2) =
+>   InfixFuncPattern (qualTerm m tyEnv t1) 
+>		     (qualIdent m tyEnv op) 
+>	             (qualTerm m tyEnv t2)
+> qualTerm m tyEnv (RecordPattern fs rt) =
+>   RecordPattern (map (qualFieldPattern m tyEnv) fs)
+>	          (maybe Nothing (Just . qualTerm m tyEnv) rt)
+
+> qualFieldPattern :: ModuleIdent -> ValueEnv -> Field ConstrTerm
+>	           -> Field ConstrTerm
+> qualFieldPattern m tyEnv (Field p l t) = Field p l (qualTerm m tyEnv t)
+
+> qualRhs :: ModuleIdent -> ValueEnv -> Rhs -> Rhs
+> qualRhs m tyEnv (SimpleRhs p e ds) =
+>   SimpleRhs p (qualExpr m tyEnv e) (map (qualDecl m tyEnv) ds) 
+> qualRhs m tyEnv (GuardedRhs es ds) =
+>   GuardedRhs (map (qualCondExpr m tyEnv) es) (map (qualDecl m tyEnv) ds)
+
+> qualCondExpr :: ModuleIdent -> ValueEnv -> CondExpr -> CondExpr
+> qualCondExpr m tyEnv (CondExpr p g e) =
+>   CondExpr p (qualExpr m tyEnv g) (qualExpr m tyEnv e)
+
+> qualExpr :: ModuleIdent -> ValueEnv -> Expression -> Expression
+> qualExpr _ _ (Literal l) = Literal l
+> qualExpr m tyEnv (Variable v) = Variable (qualIdent m tyEnv v)
+> qualExpr m tyEnv (Constructor c) = Constructor (qualIdent m tyEnv c)
+> qualExpr m tyEnv (Paren e) = Paren (qualExpr m tyEnv e)
+> qualExpr m tyEnv (Typed e ty) = Typed (qualExpr m tyEnv e) ty
+> qualExpr m tyEnv (Tuple p es) = Tuple p (map (qualExpr m tyEnv) es)
+> qualExpr m tyEnv (List p es) = List p (map (qualExpr m tyEnv) es)
+> qualExpr m tyEnv (ListCompr p e qs) =
+>   ListCompr p (qualExpr m tyEnv e) (map (qualStmt m tyEnv) qs)
+> qualExpr m tyEnv (EnumFrom e) = EnumFrom (qualExpr m tyEnv e)
+> qualExpr m tyEnv (EnumFromThen e1 e2) =
+>   EnumFromThen (qualExpr m tyEnv e1) (qualExpr m tyEnv e2)
+> qualExpr m tyEnv (EnumFromTo e1 e2) =
+>   EnumFromTo (qualExpr m tyEnv e1) (qualExpr m tyEnv e2)
+> qualExpr m tyEnv (EnumFromThenTo e1 e2 e3) =
+>   EnumFromThenTo (qualExpr m tyEnv e1) 
+>                  (qualExpr m tyEnv e2) 
+>                  (qualExpr m tyEnv e3)
+> qualExpr m tyEnv (UnaryMinus op e) = UnaryMinus op (qualExpr m tyEnv e)
+> qualExpr m tyEnv (Apply e1 e2) = 
+>   Apply (qualExpr m tyEnv e1) (qualExpr m tyEnv e2)
+> qualExpr m tyEnv (InfixApply e1 op e2) =
+>   InfixApply (qualExpr m tyEnv e1) (qualOp m tyEnv op) (qualExpr m tyEnv e2)
+> qualExpr m tyEnv (LeftSection e op) =
+>   LeftSection (qualExpr m tyEnv e) (qualOp m tyEnv op)
+> qualExpr m tyEnv (RightSection op e) =
+>   RightSection (qualOp m tyEnv op) (qualExpr m tyEnv e)
+> qualExpr m tyEnv (Lambda r ts e) =
+>   Lambda r (map (qualTerm m tyEnv) ts) (qualExpr m tyEnv e)
+> qualExpr m tyEnv (Let ds e) = 
+>   Let (map (qualDecl m tyEnv) ds) (qualExpr m tyEnv e)
+> qualExpr m tyEnv (Do sts e) = 
+>   Do (map (qualStmt m tyEnv) sts) (qualExpr m tyEnv e)
+> qualExpr m tyEnv (IfThenElse r e1 e2 e3) =
+>   IfThenElse r (qualExpr m tyEnv e1) 
+>              (qualExpr m tyEnv e2) 
+>              (qualExpr m tyEnv e3)
+> qualExpr m tyEnv (Case r e alts) =
+>   Case r (qualExpr m tyEnv e) (map (qualAlt m tyEnv) alts)
+> qualExpr m tyEnv (RecordConstr fs) =
+>   RecordConstr (map (qualFieldExpr m tyEnv) fs)
+> qualExpr m tyEnv (RecordSelection e l) =
+>   RecordSelection (qualExpr m tyEnv e) l
+> qualExpr m tyEnv (RecordUpdate fs e) =
+>   RecordUpdate (map (qualFieldExpr m tyEnv) fs) (qualExpr m tyEnv e)
+
+> qualStmt :: ModuleIdent -> ValueEnv -> Statement -> Statement
+> qualStmt m tyEnv (StmtExpr p e) = StmtExpr p (qualExpr m tyEnv e)
+> qualStmt m tyEnv (StmtBind p t e) =
+>   StmtBind p (qualTerm m tyEnv t) (qualExpr m tyEnv e)
+> qualStmt m tyEnv (StmtDecl ds) = StmtDecl (map (qualDecl m tyEnv) ds)
+
+> qualAlt :: ModuleIdent -> ValueEnv -> Alt -> Alt
+> qualAlt m tyEnv (Alt p t rhs) = 
+>   Alt p (qualTerm m tyEnv t) (qualRhs m tyEnv rhs)
+
+> qualFieldExpr :: ModuleIdent -> ValueEnv -> Field Expression
+>	        -> Field Expression
+> qualFieldExpr m tyEnv (Field p l e) = Field p l (qualExpr m tyEnv e)
+
+> qualOp :: ModuleIdent -> ValueEnv -> InfixOp -> InfixOp
+> qualOp m tyEnv (InfixOp op) = InfixOp (qualIdent m tyEnv op)
+> qualOp m tyEnv (InfixConstr op) = InfixConstr (qualIdent m tyEnv op)
+
+> qualIdent :: ModuleIdent -> ValueEnv -> QualIdent -> QualIdent
+> qualIdent m tyEnv x
+>   | not (isQualified x) && uniqueId (unqualify x) /= 0 = x
+>   | otherwise =
+>       case (qualLookupValue x tyEnv) of
+>         [y] -> origName y
+>         vs  -> case (qualLookupValue (qualQualify m x) tyEnv) of
+>                  [y] -> origName y
+>                  _ -> qualQualify m x -- internalError ("qualIdent: " ++ show x)
+
+\end{verbatim}
diff --git a/src/SCC.lhs b/src/SCC.lhs
new file mode 100644
--- /dev/null
+++ b/src/SCC.lhs
@@ -0,0 +1,59 @@
+
+% $Id: SCC.lhs,v 1.3 2003/04/30 21:29:06 wlux Exp $
+%
+% Copyright (c) 2000,2002-2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{SCC.lhs}
+\section{Computing strongly connected components}
+At various places in the compiler we had to partition a list of
+declarations into strongly connected components. The function
+\texttt{scc} computes this relation in two steps. First, the list is
+topologically sorted ``downwards'' using the \emph{defs} relation.
+Then the resulting list is sorted ``upwards'' using the \emph{uses}
+relation and partitioned into the connected components. Both relations
+are computed within this module using the bound and free names of each
+declaration.
+
+In order to avoid useless recomputations, the code in the module first
+decorates the declarations with their bound and free names and a
+unique number. The latter is only used to provide a trivial ordering
+so that the declarations can be used as set elements.
+\begin{verbatim}
+
+> module SCC(scc) where
+> import Set
+
+> data Node a b = Node{ key::Int, bvs::[b], fvs::[b], node::a }
+
+> instance Eq (Node a b) where
+>   n1 == n2 = key n1 == key n2
+> instance Ord (Node b a) where
+>   n1 `compare` n2 = key n1 `compare` key n2
+
+> scc :: Eq b => (a -> [b])              -- entities defined by node
+>             -> (a -> [b])              -- entities used by node
+>             -> [a]                     -- list of nodes
+>             -> [[a]]                   -- strongly connected components
+> scc bvs fvs = map (map node) . tsort' . tsort . zipWith wrap [0..]
+>   where wrap i n = Node i (bvs n) (fvs n) n
+
+> tsort :: Eq b => [Node a b] -> [Node a b]
+> tsort xs = snd (dfs xs zeroSet [])
+>   where dfs [] marks stack = (marks,stack)
+>         dfs (x:xs) marks stack
+>           | x `elemSet` marks = dfs xs marks stack
+>           | otherwise = dfs xs marks' (x:stack')
+>           where (marks',stack') = dfs (defs x) (x `addToSet` marks) stack
+>         defs x = filter (any (`elem` fvs x) . bvs) xs
+
+> tsort' :: Eq b => [Node a b] -> [[Node a b]]
+> tsort' xs = snd (dfs xs zeroSet [])
+>   where dfs [] marks stack = (marks,stack)
+>         dfs (x:xs) marks stack
+>           | x `elemSet` marks = dfs xs marks stack
+>           | otherwise = dfs xs marks' ((x:concat stack'):stack)
+>           where (marks',stack') = dfs (uses x) (x `addToSet` marks) []
+>         uses x = filter (any (`elem` bvs x) . fvs) xs
+
+\end{verbatim}
diff --git a/src/ScopeEnv.hs b/src/ScopeEnv.hs
new file mode 100644
--- /dev/null
+++ b/src/ScopeEnv.hs
@@ -0,0 +1,176 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- ScopeEnv - provides functions and data types for dealing with nested
+--            scope environments to store data from nested scopes
+--
+-- This module should be imported using "import qualified" to avoid name
+-- clashes
+--
+-- November 2005,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+module ScopeEnv (ScopeEnv,
+		 new, insert, update, modify, lookup, sureLookup,
+		 level, exists, beginScope, endScope, endScopeUp,
+		 toList, toLevelList, currentLevel) where
+
+import Env
+import Prelude hiding (lookup)
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+-- Returns an empty scope environment
+new :: Ord a => ScopeEnv a b
+new = ScopeEnv 0 emptyEnv []
+
+
+-- Inserts a value under a key into the environment of the current scope
+insert :: Ord a => a -> b -> ScopeEnv a b -> ScopeEnv a b
+insert key val env = modifySE insertLev env
+ where
+ insertLev lev local = bindEnv key (val,lev) local
+
+
+-- Updates the value stored under an existing key in the environment of 
+-- the current scope
+update :: Ord a => a -> b -> ScopeEnv a b -> ScopeEnv a b
+update key val env = modifySE updateLev env
+ where
+ updateLev lev local = maybe local 
+		             (\ (_,lev') ->  bindEnv key (val,lev') local)
+			     (lookupEnv key local)
+
+-- Modifies the value of an existing key by applying the function 'fun'
+-- in the environment of the current scope
+modify :: Ord a => (b -> b) -> a -> ScopeEnv a b -> ScopeEnv a b
+modify fun key env = modifySE modifyLev env
+ where
+ modifyLev lev local 
+    = maybe local
+            (\ (val',lev') -> bindEnv key (fun val', lev') local)
+	    (lookupEnv key local)
+
+
+-- Looks up the value which is stored under a key from the environment of
+-- the current scope
+lookup :: Ord a => a -> ScopeEnv a b -> Maybe b
+lookup key env = selectSE lookupLev env
+ where
+ lookupLev lev local = maybe Nothing (Just . fst) (lookupEnv key local)
+
+
+-- Similar to 'lookup', but returns an alternative value, if the key
+-- doesn't exist in the environment of the current scope
+sureLookup :: Ord a => a -> b -> ScopeEnv a b -> b
+sureLookup key alt env = maybe alt id (lookup key env)
+
+
+-- Returns the level of the last insertion of a key
+level :: Ord a => a -> ScopeEnv a b -> Int
+level key env = selectSE levelLev env
+ where
+ levelLev lev local = maybe (-1) snd (lookupEnv key local)
+
+
+-- Checks, whether a key exists in the environment of the current scope
+exists :: Ord a => a -> ScopeEnv a b -> Bool
+exists key env = selectSE existsLev env
+ where
+ existsLev lev local = maybe False (const True) (lookupEnv key local)
+
+
+-- Switches to the next scope (i.e. pushes the environment of the current
+-- scope onto the top of an scope stack and increments the level counter)
+beginScope :: Ord a => ScopeEnv a b -> ScopeEnv a b
+beginScope (ScopeEnv lev top [])
+   = ScopeEnv (lev + 1) top [top]
+beginScope (ScopeEnv lev top (local:locals))
+   = ScopeEnv (lev + 1) top (local:local:locals)
+
+
+-- Switches to the previous scope (i.e. pops the environment from the top
+-- of the scope stack and decrements the level counter)
+endScope :: Ord a => ScopeEnv a b -> ScopeEnv a b
+endScope (ScopeEnv _ top [])
+   = ScopeEnv 0 top []
+endScope (ScopeEnv lev top (_:locals))
+   = ScopeEnv (lev - 1) top locals
+
+
+-- Behaves like 'endScope' but additionally updates the environment of
+-- the previous scope by updating all keys with the corresponding values
+-- from the poped environment
+endScopeUp :: Ord a => ScopeEnv a b -> ScopeEnv a b
+endScopeUp (ScopeEnv _ top [])
+   = ScopeEnv 0 top []
+endScopeUp (ScopeEnv lev top (local:[]))
+   = ScopeEnv 0 (foldr (updateSE local) top (envToList top)) []
+endScopeUp (ScopeEnv lev top (local:local':locals))
+   = ScopeEnv (lev - 1) 
+              top 
+	      ((foldr (updateSE local) local' (envToList local')):locals)
+
+
+-- Returns the environment of current scope as a (key,value) list
+toList :: Ord a => ScopeEnv a b -> [(a,b)]
+toList env = selectSE toListLev env
+ where
+ toListLev lev local = map (\ (key,(val,_)) -> (key,val)) (envToList local)
+
+
+-- Returns all (key,value) pairs from the environment of the current scope 
+-- which has been inserted in the current level
+toLevelList :: Ord a => ScopeEnv a b -> [(a,b)]
+toLevelList env = selectSE toLevelListLev env
+ where
+ toLevelListLev lev local
+    = map (\ (key,(val,_)) -> (key,val))
+          (filter (\ (_,(_,lev')) -> lev' == lev) (envToList local))
+
+
+-- Returns the current level
+currentLevel :: Ord a => ScopeEnv a b -> Int
+currentLevel env = selectSE const env
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+-- Privates...
+
+--
+modifySE :: (Int -> Env a (b,Int) -> Env a (b,Int)) -> ScopeEnv a b 
+          -> ScopeEnv a b
+modifySE f (ScopeEnv _ top []) 
+   = ScopeEnv 0 (f 0 top) []
+modifySE f (ScopeEnv lev top (local:locals))
+   = ScopeEnv lev top ((f lev local):locals)
+
+--
+selectSE :: (Int -> Env a (b,Int) -> c) -> ScopeEnv a b -> c
+selectSE f (ScopeEnv _ top [])        = f 0 top
+selectSE f (ScopeEnv lev _ (local:_)) = f lev local
+
+--
+updateSE :: Ord a => Env a (b,Int) -> (a,(b,Int)) ->  Env a (b,Int) 
+          -> Env a (b,Int)
+updateSE local (key,(_,lev)) local'
+   = maybe local' 
+           (\ (val',lev') 
+	    -> if lev == lev' then bindEnv key (val',lev) local' 
+                              else local')
+	   (lookupEnv key local)
+
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+-- Data type for representing information in nested scopes.
+data ScopeEnv a b = ScopeEnv Int (Env a (b,Int)) [Env a (b,Int)]
+		    deriving Show
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/Set.lhs b/src/Set.lhs
new file mode 100644
--- /dev/null
+++ b/src/Set.lhs
@@ -0,0 +1,91 @@
+% -*- LaTeX -*-
+% $Id: Set.lhs,v 1.6 2002/12/20 14:58:46 lux Exp $
+%
+% Copyright (c) 2002, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Set.lhs}
+\section{Sets}
+The module \texttt{Set} implements sets as a special case of finite
+maps.
+\begin{verbatim}
+
+> module Set where
+
+> import Data.List
+> import Data.Maybe
+
+> import Map
+
+> infixl 8 `addToSet`, `deleteFromSet`
+> infixl 7 `unionSet`, `intersectionSet`
+> infixl 6 `diffSet`, `symDiffSet`
+> infix  4 `subsetSet`, `elemSet`, `notElemSet`
+
+> newtype Set a = Set (FM a ())
+
+\end{verbatim}
+Two sets are equal if both contain the same elements.
+\begin{verbatim}
+
+> instance Ord a => Eq (Set a) where
+>   xs == ys = toListSet xs == toListSet ys
+
+> instance (Ord a, Show a) => Show (Set a) where
+>   showsPrec p set =
+>     showChar '{' . showElems (map shows (toListSet set)) . showChar '}'
+>     where showElems = flip (foldr ($)) . intersperse (showChar ',')      -- $
+
+> nullSet :: Ord a => Set a -> Bool
+> nullSet = null . toListSet
+
+> zeroSet :: Ord a => Set a
+> zeroSet = Set zeroFM
+
+> unitSet :: Ord a => a -> Set a
+> unitSet x = Set (unitFM x ())
+
+> addToSet :: Ord a => a -> Set a -> Set a
+> addToSet x (Set xs) = Set (addToFM x () xs)
+
+> deleteFromSet :: Ord a => a -> Set a -> Set a
+> deleteFromSet x (Set xs) = Set (deleteFromFM x xs)
+
+> elemSet :: Ord a => a -> Set a -> Bool
+> elemSet x (Set xs) = isJust (lookupFM x xs)
+
+> notElemSet :: Ord a => a -> Set a -> Bool
+> notElemSet x set = not (elemSet x set)
+
+> subsetSet :: Ord a => Set a -> Set a -> Bool
+> subsetSet xs ys = all (`elemSet` ys) (toListSet xs)
+
+> fromListSet :: Ord a => [a] -> Set a
+> fromListSet = foldr addToSet zeroSet
+
+> toListSet :: Ord a => Set a -> [a]
+> toListSet (Set xs) = map fst (toListFM xs)
+
+> unionSet :: Ord a => Set a -> Set a -> Set a
+> unionSet xs ys = foldr addToSet xs (toListSet ys)
+
+> unionSets :: Ord a => [Set a] -> Set a
+> unionSets = foldr unionSet zeroSet
+
+> intersectionSet :: Ord a => Set a -> Set a -> Set a
+> intersectionSet xs ys =
+>   foldr addToSet zeroSet [y | y <- toListSet ys, y `elemSet` xs]
+
+> diffSet :: Ord a => Set a -> Set a -> Set a
+> diffSet xs ys = foldr deleteFromSet xs (toListSet ys)
+
+> symDiffSet :: Ord a => Set a -> Set a -> Set a
+> symDiffSet xs ys = unionSet (diffSet xs ys) (diffSet ys xs)
+
+> mapSet :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b
+> mapSet f = fromListSet . map f . toListSet
+
+> domainFM :: Ord a => FM a b -> Set a
+> domainFM = Set . fmap (const ())
+
+\end{verbatim}
diff --git a/src/ShowCurrySyntax.hs b/src/ShowCurrySyntax.hs
new file mode 100644
--- /dev/null
+++ b/src/ShowCurrySyntax.hs
@@ -0,0 +1,493 @@
+--- Transform a CurrySyntax module into a string representation without any
+--- pretty printing.
+--- Behaves like a derived Show instance even on parts with a specific one.
+--- 
+--- @author Sebastian Fischer (sebf@informatik.uni-kiel.de)
+--- @version December 2008
+--- bug fixed by bbr
+
+
+module ShowCurrySyntax ( showModule ) where
+
+import Ident
+import Position
+import CurrySyntax
+
+showModule :: Module -> String
+showModule m = showsModule m "\n"
+
+showsModule :: Module -> ShowS
+showsModule (Module mident espec decls)
+  = showsString "Module "
+  . showsModuleIdent mident . newline
+  . showsMaybe showsExportSpec espec . newline
+  . showsList (\d -> showsDecl d . newline) decls
+
+showsPosition :: Position -> ShowS
+showsPosition Position{line=row,column=col} = showsPair shows shows (row,col)
+-- showsPosition (Position file row col)
+--   = showsString "(Position "
+--   . shows file . space
+--   . shows row . space
+--   . shows col
+--   . showsString ")"
+
+showsExportSpec :: ExportSpec -> ShowS
+showsExportSpec (Exporting pos exports)
+  = showsString "(Exporting "
+  . showsPosition pos . space
+  . showsList showsExport exports
+  . showsString ")"
+
+showsExport :: Export -> ShowS
+showsExport (Export qident)
+  = showsString "(Export " . showsQualIdent qident . showsString ")"
+showsExport (ExportTypeWith qident ids)
+  = showsString "(ExportTypeWith "
+  . showsQualIdent qident . space
+  . showsList showsIdent ids
+  . showsString ")"
+showsExport (ExportTypeAll qident)
+  = showsString "(ExportTypeAll " . showsQualIdent qident . showsString ")"
+showsExport (ExportModule m) 
+  = showsString "(ExportModule " . showsModuleIdent m . showChar ')'
+
+showsImportSpec :: ImportSpec -> ShowS
+showsImportSpec (Importing pos imports)
+  = showsString "(Importing "
+  . showsPosition pos . space
+  . showsList showsImport imports
+  . showsString ")"
+showsImportSpec (Hiding pos imports)
+  = showsString "(Hiding "
+  . showsPosition pos . space
+  . showsList showsImport imports
+  . showsString ")"
+
+showsImport :: Import -> ShowS
+showsImport (Import ident)
+  = showsString "(Import " . showsIdent ident . showsString ")"
+showsImport (ImportTypeWith ident idents)
+  = showsString "(ImportTypeWith "
+  . showsIdent ident . space
+  . showsList showsIdent idents
+  . showsString ")"
+showsImport (ImportTypeAll ident)
+  = showsString "(ImportTypeAll " . showsIdent ident . showsString ")"
+
+showsDecl :: Decl -> ShowS
+showsDecl (ImportDecl pos mident quali mmident mimpspec)
+  = showsString "(ImportDecl "
+  . showsPosition pos . space
+  . showsModuleIdent mident . space
+  . shows quali . space
+  . showsMaybe showsModuleIdent mmident . space
+  . showsMaybe showsImportSpec mimpspec
+  . showsString ")"
+showsDecl (InfixDecl pos infx prec idents)
+  = showsString "(InfixDecl "
+  . showsPosition pos . space
+  . shows infx . space
+  . shows prec . space
+  . showsList showsIdent idents
+  . showsString ")"
+showsDecl (DataDecl pos ident idents consdecls)
+  = showsString "(DataDecl "
+  . showsPosition pos . space
+  . showsIdent ident . space
+  . showsList showsIdent idents . space
+  . showsList showsConsDecl consdecls
+  . showsString ")"
+showsDecl (NewtypeDecl pos ident idents newconsdecl)
+  = showsString "(NewtypeDecl "
+  . showsPosition pos . space
+  . showsIdent ident . space
+  . showsList showsIdent idents . space
+  . showsNewConsDecl newconsdecl
+  . showsString ")"
+showsDecl (TypeDecl pos ident idents typ)
+  = showsString "(TypeDecl "
+  . showsPosition pos . space
+  . showsIdent ident . space
+  . showsList showsIdent idents . space
+  . showsTypeExpr typ
+  . showsString ")"
+showsDecl (TypeSig pos idents typ)
+  = showsString "(TypeSig "
+  . showsPosition pos . space
+  . showsList showsIdent idents . space
+  . showsTypeExpr typ
+  . showsString ")"
+showsDecl (EvalAnnot pos idents annot)
+  = showsString "(EvalAnnot "
+  . showsPosition pos . space
+  . showsList showsIdent idents . space
+  . shows annot
+  . showsString ")"
+showsDecl (FunctionDecl pos ident eqs)
+  = showsString "(FunctionDecl "
+  . showsPosition pos . space
+  . showsIdent ident . space
+  . showsList showsEquation eqs
+  . showsString ")"
+showsDecl (ExternalDecl pos cconv mstr ident typ)
+  = showsString "(ExternalDecl "
+  . showsPosition pos . space
+  . shows cconv . space
+  . shows mstr . space
+  . showsIdent ident . space
+  . showsTypeExpr typ
+  . showsString ")"
+showsDecl (FlatExternalDecl pos idents)
+  = showsString "(FlatExternalDecl "
+  . showsPosition pos . space
+  . showsList showsIdent idents
+  . showsString ")"
+showsDecl (PatternDecl pos cons rhs)
+  = showsString "(PatternDecl "
+  . showsPosition pos . space
+  . showsConsTerm cons . space
+  . showsRhs rhs
+  . showsString ")"
+showsDecl (ExtraVariables pos idents)
+  = showsString "(ExtraVariables "
+  . showsPosition pos . space
+  . showsList showsIdent idents
+  . showsString ")"
+
+showsConsDecl :: ConstrDecl -> ShowS
+showsConsDecl (ConstrDecl pos idents ident types)
+  = showsString "(ConstrDecl "
+  . showsPosition pos . space
+  . showsList showsIdent idents . space
+  . showsIdent ident . space
+  . showsList showsTypeExpr types
+  . showsString ")"
+showsConstrDecl (ConOpDecl pos idents rtyp ident ltyp)
+  = showsString "(ConOpDecl "
+  . showsPosition pos . space
+  . showsList showsIdent idents . space
+  . showsTypeExpr rtyp . space
+  . showsIdent ident . space
+  . showsTypeExpr ltyp
+  . showsString ")"
+
+showsNewConsDecl :: NewConstrDecl -> ShowS
+showsNewConsDecl (NewConstrDecl pos idents ident typ)
+  = showsString "(NewConstrDecl "
+  . showsPosition pos . space
+  . showsList showsIdent idents . space
+  . showsIdent ident . space
+  . showsTypeExpr typ
+  . showsString ")"
+
+showsTypeExpr :: TypeExpr -> ShowS
+showsTypeExpr (ConstructorType qident types)
+  = showsString "(ConstructorType "
+  . showsQualIdent qident . space
+  . showsList showsTypeExpr types
+  . showsString ")"
+showsTypeExpr (VariableType ident)
+  = showsString "(VariableType " . showsIdent ident . showsString ")"
+showsTypeExpr (TupleType types)
+  = showsString "(TupleType " . showsList showsTypeExpr types . showsString ")"
+showsTypeExpr (ListType typ)
+  = showsString "(ListType " . showsTypeExpr typ . showsString ")"
+showsTypeExpr (ArrowType dom ran)
+  = showsString "(ArrowType "
+  . showsTypeExpr dom . space
+  . showsTypeExpr ran
+  . showsString ")"
+showsTypeExpr (RecordType fieldts mtyp)
+  = showsString "(RecordType "
+  . showsList (showsPair (showsList showsIdent) showsTypeExpr) fieldts . space
+  . showsMaybe showsTypeExpr mtyp
+  . showsString ")"
+
+showsEquation :: Equation -> ShowS
+showsEquation (Equation pos lhs rhs)
+  = showsString "(Equation "
+  . showsPosition pos . space
+  . showsLhs lhs . space
+  . showsRhs rhs
+  . showsString ")"
+
+showsLhs :: Lhs -> ShowS
+showsLhs (FunLhs ident conss)
+  = showsString "(FunLhs "
+  . showsIdent ident . space
+  . showsList showsConsTerm conss
+  . showsString ")"
+showsLhs (OpLhs cons1 ident cons2)
+  = showsString "(OpLhs "
+  . showsConsTerm cons1 . space
+  . showsIdent ident . space
+  . showsConsTerm cons2
+  . showsString ")"
+showsLhs (ApLhs lhs conss)
+  = showsString "(ApLhs "
+  . showsLhs lhs . space
+  . showsList showsConsTerm conss
+  . showsString ")"
+
+showsRhs :: Rhs -> ShowS
+showsRhs (SimpleRhs pos exp decls)
+  = showsString "(SimpleRhs "
+  . showsPosition pos . space
+  . showsExpression exp . space
+  . showsList showsDecl decls
+  . showsString ")"
+showsRhs (GuardedRhs cexps decls)
+  = showsString "(GuardedRhs "
+  . showsList showsCondExpr cexps . space
+  . showsList showsDecl decls
+  . showsString ")"
+
+showsCondExpr :: CondExpr -> ShowS
+showsCondExpr (CondExpr pos exp1 exp2)
+  = showsString "(CondExpr "
+  . showsPosition pos . space
+  . showsExpression exp1 . space
+  . showsExpression exp2
+  . showsString ")"
+
+showsLiteral :: Literal -> ShowS
+showsLiteral (Char _ c) = showsString "(Char " . shows c . showsString ")"
+showsLiteral (Int ident n)
+  = showsString "(Int "
+  . showsIdent ident . space
+  . shows n
+  . showsString ")"
+showsLiteral (Float _ x) = showsString "(Float " . shows x . showsString ")"
+showsLiteral (String _ s) = showsString "(String " . shows s . showsString ")"
+
+showsConsTerm :: ConstrTerm -> ShowS
+showsConsTerm (LiteralPattern lit)
+  = showsString "(LiteralPattern "
+  . showsLiteral lit
+  . showsString ")"
+showsConsTerm (NegativePattern ident lit)
+  = showsString "(NegativePattern "
+  . showsIdent ident . space
+  . showsLiteral lit
+  . showsString ")"
+showsConsTerm (VariablePattern ident)
+  = showsString "(VariablePattern "
+  . showsIdent ident 
+  . showsString ")"
+showsConsTerm (ConstructorPattern qident conss)
+  = showsString "(ConstructorPattern "
+  . showsQualIdent qident . space
+  . showsList showsConsTerm conss
+  . showsString ")"
+showsConsTerm (InfixPattern cons1 qident cons2)
+  = showsString "(InfixPattern "
+  . showsConsTerm cons1 . space
+  . showsQualIdent qident . space
+  . showsConsTerm cons2
+  . showsString ")"
+showsConsTerm (ParenPattern cons)
+  = showsString "(ParenPattern "
+  . showsConsTerm cons
+  . showsString ")"
+showsConsTerm (TuplePattern _ conss)
+  = showsString "(TuplePattern "
+  . showsList showsConsTerm conss
+  . showsString ")"
+showsConsTerm (ListPattern _ conss)
+  = showsString "(ListPattern "
+  . showsList showsConsTerm conss
+  . showsString ")"
+showsConsTerm (AsPattern ident cons)
+  = showsString "(AsPattern "
+  . showsIdent ident . space
+  . showsConsTerm cons
+  . showsString ")"
+showsConsTerm (LazyPattern _ cons)
+  = showsString "(LazyPattern "
+  . showsConsTerm cons
+  . showsString ")"
+showsConsTerm (FunctionPattern qident conss)
+  = showsString "(FunctionPattern "
+  . showsQualIdent qident . space
+  . showsList showsConsTerm conss
+  . showsString ")"
+showsConsTerm (InfixFuncPattern cons1 qident cons2)
+  = showsString "(InfixFuncPattern "
+  . showsConsTerm cons1 . space
+  . showsQualIdent qident . space
+  . showsConsTerm cons2
+  . showsString ")"
+showsConsTerm (RecordPattern cfields mcons)
+  = shows "(RecordPattern "
+  . showsList (showsField showsConsTerm) cfields . space
+  . showsMaybe showsConsTerm mcons
+  . showsString ")"
+
+showsExpression :: Expression -> ShowS
+showsExpression (Literal lit)
+  = showsString "(Literal " . showsLiteral lit . showsString ")"
+showsExpression (Variable qident)
+  = showsString "(Variable " . showsQualIdent qident . showsString ")"
+showsExpression (Constructor qident)
+  = showsString "(Constructor " . showsQualIdent qident . showsString ")"
+showsExpression (Paren exp)
+  = showsString "(Paren " . showsExpression exp . showsString ")"
+showsExpression (Typed exp typ)
+  = showsString "(Typed "
+  . showsExpression exp . space
+  . showsTypeExpr typ
+  . showsString ")"
+showsExpression (Tuple _ exps)
+  = showsString "(Tuple " . showsList showsExpression exps . showsString ")"
+showsExpression (List _ exps)
+  = showsString "(List " . showsList showsExpression exps . showsString ")"
+showsExpression (ListCompr _ exp stmts)
+  = showsString "(ListCompr "
+  . showsExpression exp . space
+  . showsList showsStatement stmts
+  . showsString ")"
+showsExpression (EnumFrom exp)
+  = showsString "(EnumFrom " . showsExpression exp . showsString ")"
+showsExpression (EnumFromThen exp1 exp2)
+  = showsString "(EnumFromThen "
+  . showsExpression exp1 . space
+  . showsExpression exp2
+  . showsString ")"
+showsExpression (EnumFromTo exp1 exp2)
+  = showsString "(EnumFromTo "
+  . showsExpression exp1 . space
+  . showsExpression exp2
+  . showsString ")"
+showsExpression (EnumFromThenTo exp1 exp2 exp3)
+  = showsString "(EnumFromThenTo "
+  . showsExpression exp1 . space
+  . showsExpression exp2 . space
+  . showsExpression exp3
+  . showsString ")"
+showsExpression (UnaryMinus ident exp)
+  = showsString "(UnaryMinus "
+  . showsIdent ident . space
+  . showsExpression exp
+  . showsString ")"
+showsExpression (Apply exp1 exp2)
+  = showsString "(Apply "
+  . showsExpression exp1 . space
+  . showsExpression exp2
+  . showsString ")"
+showsExpression (InfixApply exp1 op exp2)
+  = showsString "(InfixApply "
+  . showsExpression exp1 . space
+  . showsInfixOp op . space
+  . showsExpression exp2
+  . showsString ")"
+showsExpression (LeftSection exp op)
+  = showsString "(LeftSection "
+  . showsExpression exp . space
+  . showsInfixOp op
+  . showsString ")"
+showsExpression (RightSection op exp)
+  = showsString "(RightSection "
+  . showsInfixOp op . space
+  . showsExpression exp
+  . showsString ")"
+showsExpression (Lambda _ conss exp)
+  = showsString "(Lambda "
+  . showsList showsConsTerm conss . space
+  . showsExpression exp 
+  . showsString ")"
+showsExpression (Let decls exp)
+  = showsString "(Let "
+  . showsList showsDecl decls . space
+  . showsExpression exp 
+  . showsString ")"
+showsExpression (Do stmts exp)
+  = showsString "(Do "
+  . showsList showsStatement stmts . space
+  . showsExpression exp
+  . showsString ")"
+showsExpression (IfThenElse _ exp1 exp2 exp3)
+  = showsString "(IfThenElse "
+  . showsExpression exp1 . space
+  . showsExpression exp2 . space
+  . showsExpression exp3
+  . showsString ")"
+showsExpression (Case _ exp alts)
+  = showsString "(Case "
+  . showsExpression exp . space
+  . showsList showsAlt alts
+  . showsString ")"
+showsExpression (RecordConstr efields)
+  = showsString "(RecordConstr "
+  . showsList (showsField showsExpression) efields
+  . showsString ")"
+showsExpression (RecordSelection exp ident)
+  = showsString "(RecordSelection "
+  . showsExpression exp . space
+  . showsIdent ident
+  . showsString ")"
+showsExpression (RecordUpdate efields exp)
+  = showsString "(RecordUpdate "
+  . showsList (showsField showsExpression) efields . space
+  . showsExpression exp
+  . showsString ")"
+
+showsInfixOp :: InfixOp -> ShowS
+showsInfixOp (InfixOp qident)
+  = showsString "(InfixOp " . showsQualIdent qident . showsString ")"
+showsInfixOp (InfixConstr qident)
+  = showsString "(InfixConstr " . showsQualIdent qident . showsString ")"
+
+showsStatement :: Statement -> ShowS
+showsStatement (StmtExpr _ exp)
+  = showsString "(StmtExpr " . showsExpression exp . showsString ")"
+showsStatement (StmtDecl decls)
+  = showsString "(StmtDecl " . showsList showsDecl decls . showsString ")"
+showsStatement (StmtBind _ cons exp)
+  = showsString "(StmtBind "
+  . showsConsTerm cons . space
+  . showsExpression exp
+  . showsString ")"
+
+showsAlt :: Alt -> ShowS
+showsAlt (Alt pos cons rhs)
+  = showsString "(Alt "
+  . showsPosition pos . space
+  . showsConsTerm cons . space
+  . showsRhs rhs
+  . showsString ")"
+
+showsField :: (a -> ShowS) -> Field a -> ShowS
+showsField sa (Field pos ident a)
+  = showsString "(Field "
+  . showsPosition pos . space
+  . showsIdent ident . space
+  . sa a
+  . showsString ")"
+
+showsString :: String -> ShowS
+showsString = (++)
+
+space :: ShowS
+space = showsString " "
+
+newline :: ShowS
+newline = showsString "\n"
+
+showsMaybe :: (a -> ShowS) -> Maybe a -> ShowS
+showsMaybe shs
+  = maybe (showsString "Nothing")
+          (\x -> showsString "(Just " . shs x . showsString ")")
+
+showsList :: (a -> ShowS) -> [a] -> ShowS
+showsList _ [] = showsString "[]"
+showsList shs (x:xs)
+  = showsString "["
+  . foldl (\sys y -> sys . showsString "," . shs y) (shs x) xs
+  . showsString "]"
+
+showsPair :: (a -> ShowS) -> (b -> ShowS) -> (a,b) -> ShowS
+showsPair sa sb (a,b)
+  = showsString "(" . sa a . showsString "," . sb b . showsString ")"
+
+
diff --git a/src/Simplify.lhs b/src/Simplify.lhs
new file mode 100644
--- /dev/null
+++ b/src/Simplify.lhs
@@ -0,0 +1,466 @@
+% $Id: Simplify.lhs,v 1.10 2004/02/13 14:02:58 wlux Exp $
+%
+% Copyright (c) 2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{Simplify.lhs}
+\section{Optimizing the Desugared Code}\label{sec:simplify}
+After desugaring the source code, but before lifting local
+declarations, the compiler performs a few simple optimizations to
+improve the efficiency of the generated code. In addition, the
+optimizer replaces pattern bindings with simple variable bindings and
+selector functions.
+
+Currently, the following optimizations are implemented:
+\begin{itemize}
+\item Remove unused declarations.
+\item Inline simple constants.
+\item Compute minimal binding groups.
+\item Under certain conditions, inline local function definitions.
+\end{itemize}
+\begin{verbatim}
+
+> module Simplify(simplify) where
+
+> import Control.Monad
+
+> import Base
+> import Combined
+> import Env
+> import SCC
+> import Typing
+
+
+> type SimplifyState a = StateT ValueEnv (ReaderT EvalEnv (StateT Int Id)) a
+> type InlineEnv = Env Ident Expression
+> type SimplifyFlags = Bool
+ 
+> flatFlag :: SimplifyFlags -> Bool
+> flatFlag   x = x
+
+> simplify :: SimplifyFlags -> ValueEnv -> EvalEnv -> Module -> (Module,ValueEnv)
+> simplify flags tyEnv evEnv m 
+>   = runSt (callRt (callSt (simplifyModule flags m) tyEnv) evEnv) 1
+
+> simplifyModule :: SimplifyFlags -> Module -> SimplifyState (Module,ValueEnv)
+> simplifyModule flat (Module m es ds) =
+>   do
+>     ds' <- mapM (simplifyDecl flat m emptyEnv) ds
+>     tyEnv <- fetchSt
+>     return (Module m es ds',tyEnv)
+
+> simplifyDecl :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Decl -> SimplifyState Decl
+> simplifyDecl flat m env (FunctionDecl p f eqs) =
+>   liftM (FunctionDecl p f . concat) (mapM (simplifyEquation flat m env) eqs)
+> simplifyDecl flat m env (PatternDecl p t rhs) =
+>   liftM (PatternDecl p t) (simplifyRhs flat m env rhs)
+> simplifyDecl _ _ _ d = return d
+
+\end{verbatim}
+After simplifying the right hand side of an equation, the compiler
+transforms declarations of the form
+\begin{quote}\tt
+  $f\;t_1\dots t_{k-k'}\;x_{k-k'+1}\dots x_{k}$ =
+    let $f'\;t'_1\dots t'_{k'}$ = $e$ in
+    $f'\;x_1\dots x_{k'}$
+\end{quote}
+into the equivalent definition
+\begin{quote}\tt
+  $f\;t_1\dots t_{k-k'}\;(x_{k-k'+1}$@$t'_1)\dots(x_k$@$t'_{k'})$ = $e$
+\end{quote}
+where the arities of $f$ and $f'$ are $k$ and $k'$, respectively, and
+$x_{k-k'+1},\dots,x_{k}$ are variables. This optimization was
+introduced in order to avoid an auxiliary function being generated for
+definitions whose right-hand side is a $\lambda$-expression, e.g.,
+\verb|f . g = \x -> f (g x)|. This declaration is transformed into
+\verb|(.) f g x = let lambda x = f (g x) in lambda x| by desugaring
+and in turn is optimized into \verb|(.) f g x = f (g x)|, here. The
+transformation can obviously be generalized to the case where $f'$ is
+defined by more than one equation. However, we must be careful not to
+change the evaluation mode of arguments. Therefore, the transformation
+is applied only if $f$ and $f'$ use them same evaluation mode or all
+of the arguments $t'_1,\dots,t'_k$ are variables. Actually, the
+transformation could be applied to the case where the arguments
+$t_1,\dots,t_{k-k'}$ are all variables as well, but in this case the
+evaluation mode of $f$ may have to be changed to match that of $f'$.
+
+We have to be careful with this optimization in conjunction with
+newtype constructors. It is possible that the local function is
+applied only partially, e.g., for
+\begin{verbatim}
+  newtype ST s a = ST (s -> (a,s))
+  returnST x = ST (\s -> (x,s))
+\end{verbatim}
+the desugared code is equivalent to
+\begin{verbatim}
+  returnST x = let lambda1 s = (x,s) in lambda1
+\end{verbatim}
+We must not ``optimize'' this into \texttt{returnST x s = (x,s)}
+because the compiler assumes that \texttt{returnST} is a unary
+function.
+
+Note that this transformation is not strictly semantic preserving as
+the evaluation order of arguments can be changed. This happens if $f$
+is defined by more than one rule with overlapping patterns and the
+local functions of each rule have disjoint patterns. As an example,
+consider the function
+\begin{verbatim}
+  f (Just x) _ = let g (Left z)  = x + z in g
+  f _ (Just y) = let h (Right z) = y + z in h
+\end{verbatim}
+The definition of \texttt{f} is non-deterministic because of the
+overlapping patterns in the first and second argument. However, the
+optimized definition
+\begin{verbatim}
+  f (Just x) _ (Left z)  = x + z
+  f _ (Just y) (Right z) = y + z
+\end{verbatim}
+is deterministic. It will evaluate and match the third argument first,
+whereas the original definition is going to evaluate the first or the
+second argument first, depending on the non-deterministic branch
+chosen. As such definitions are presumably rare, and the optimization
+avoids a non-deterministic split of the computation, we put up with
+the change of evaluation order.
+
+This transformation is actually just a special case of inlining a
+(local) function definition. We are unable to handle the general case
+because it would require to represent the pattern matching code
+explicitly in a Curry expression.
+\begin{verbatim}
+
+> simplifyEquation :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Equation
+>                  -> SimplifyState [Equation]
+> simplifyEquation flat m env (Equation p lhs rhs) =
+>   do
+>     rhs' <- simplifyRhs flat m env rhs
+>     tyEnv <- fetchSt
+>     evEnv <- liftSt envRt
+>     return (inlineFun flat m tyEnv evEnv p lhs rhs')
+
+> inlineFun :: SimplifyFlags -> ModuleIdent -> ValueEnv -> EvalEnv -> Position -> Lhs -> Rhs
+>           -> [Equation]
+> inlineFun flags m tyEnv evEnv p (FunLhs f ts)
+>           (SimpleRhs _ (Let [FunctionDecl _ f' eqs'] e) _)
+>   | f' `notElem` qfv m eqs' && e' == Variable (qualify f') &&
+>     n == arrowArity (funType m tyEnv (qualify f')) &&
+>     (evMode evEnv f == evMode evEnv f' ||
+>      and [all isVarPattern ts | Equation _ (FunLhs _ ts) _ <- eqs']) =
+>     map (merge p f ts' vs') eqs'
+>   where n :: Int                      -- type signature necessary for nhc
+>         (n,vs',ts',e') = etaReduce 0 [] (reverse ts) e
+>         merge p f ts vs (Equation _ (FunLhs _ ts') rhs) =
+>           Equation p (FunLhs f (ts ++ zipWith AsPattern vs ts')) rhs
+>         etaReduce n vs (VariablePattern v : ts) (Apply e (Variable v'))
+>           | qualify v == v' = etaReduce (n+1) (v:vs) ts e
+>         etaReduce n vs ts e = (n,vs,reverse ts,e)
+> inlineFun _ _ _ _ p lhs rhs = [Equation p lhs rhs]
+
+> simplifyRhs :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Rhs -> SimplifyState Rhs
+> simplifyRhs flat m env (SimpleRhs p e _) =
+>   do
+>     e' <- simplifyExpr flat m env e
+>     return (SimpleRhs p e' [])
+
+\end{verbatim}
+Variables that are bound to (simple) constants and aliases to other
+variables are substituted. In terms of conventional compiler
+technology these optimizations correspond to constant folding and copy
+propagation, respectively. The transformation is applied recursively
+to a substituted variable in order to handle chains of variable
+definitions.
+
+The bindings of a let expression are sorted topologically in
+order to split them into minimal binding groups. In addition,
+local declarations occurring on the right hand side of a pattern
+declaration are lifted into the enclosing binding group using the
+equivalence (modulo $\alpha$-conversion) of \texttt{let}
+$x$~=~\texttt{let} \emph{decls} \texttt{in} $e_1$ \texttt{in} $e_2$
+and \texttt{let} \emph{decls}\texttt{;} $x$~=~$e_1$ \texttt{in} $e_2$.
+This transformation avoids the creation of some redundant lifted
+functions in later phases of the compiler.
+\begin{verbatim}
+
+> simplifyExpr :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Expression
+>              -> SimplifyState Expression
+> simplifyExpr _ _ _ (Literal l) = return (Literal l)
+> simplifyExpr flat m env (Variable v)
+>   | isQualified v = return (Variable v)
+>   | otherwise = maybe (return (Variable v)) (simplifyExpr flat m env)
+>                       (lookupEnv (unqualify v) env)
+> simplifyExpr _ _ _ (Constructor c) = return (Constructor c)
+> simplifyExpr flags m env (Apply (Let ds e1) e2) 
+>   = simplifyExpr flags m env (Let ds (Apply e1 e2))
+> simplifyExpr flags m env (Apply (Case r e1 alts) e2) 
+>   = simplifyExpr flags m env (Case r e1 (map (applyToAlt e2) alts))
+>   where applyToAlt e (Alt p t rhs) = Alt p t (applyRhs rhs e)
+>         applyRhs (SimpleRhs p e1 _) e2 = SimpleRhs p (Apply e1 e2) []
+> simplifyExpr flat m env (Apply e1 e2) =
+>   do
+>     e1' <- simplifyExpr flat m env e1
+>     e2' <- simplifyExpr flat m env e2
+>     return (Apply e1' e2')
+> simplifyExpr flags m env (Let ds e) =
+>   do
+>     tyEnv <- fetchSt
+>     dss' <- mapM (sharePatternRhs m tyEnv) ds
+>     simplifyLet flags m env
+>       (scc bv (qfv m) (foldr (hoistDecls flags) [] (concat dss'))) e
+> simplifyExpr flat m env (Case r e alts) =
+>   do
+>     e' <- simplifyExpr flat m env e
+>     alts' <- mapM (simplifyAlt flat m env) alts
+>     return (Case r e' alts')
+> 
+
+> simplifyAlt :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Alt -> SimplifyState Alt
+> simplifyAlt flat m env (Alt p t rhs) =
+>   liftM (Alt p t) (simplifyRhs flat m env rhs)
+
+> hoistDecls :: SimplifyFlags -> Decl -> [Decl] -> [Decl]
+> hoistDecls flags (PatternDecl p t (SimpleRhs p' (Let ds e) _)) ds' 
+>  = foldr (hoistDecls flags) ds' (PatternDecl p t (SimpleRhs p' e []) : ds)
+> hoistDecls _ d ds = d : ds
+
+\end{verbatim}
+The declaration groups of a let expression are first processed from
+outside to inside, simplifying the right hand sides and collecting
+inlineable expressions on the fly. At present, only simple constants
+and aliases to other variables are inlined. A constant is considered
+simple if it is either a literal, a constructor, or a non-nullary
+function. Note that it is not possible to define nullary functions in
+local declarations in Curry. Thus, an unqualified name always refers
+to either a variable or a non-nullary function.  Applications of
+constructors and partial applications of functions to at least one
+argument are not inlined because the compiler has to allocate space
+for them, anyway. In order to prevent non-termination, recursive
+binding groups are not processed.
+
+With the list of inlineable expressions, the body of the let is
+simplified and then the declaration groups are processed from inside
+to outside to construct the simplified, nested let expression. In
+doing so unused bindings are discarded. In addition, all pattern
+bindings are replaced by simple variable declarations using selector
+functions to access the pattern variables.
+\begin{verbatim}
+
+> simplifyLet :: SimplifyFlags -> ModuleIdent -> InlineEnv -> [[Decl]] -> Expression
+>             -> SimplifyState Expression
+> simplifyLet flat m env [] e = simplifyExpr flat m env e
+> simplifyLet flags m env (ds:dss) e =
+>   do
+>     ds' <- mapM (simplifyDecl flags m env) ds
+>     tyEnv <- fetchSt
+>     e' <- simplifyLet flags m (inlineVars flags m tyEnv ds' env) dss e
+>     dss'' <-
+>       mapM (expandPatternBindings flags m tyEnv (qfv m ds' ++ qfv m e')) ds'
+>     return (foldr (mkLet flags m) e' 
+>                   (scc bv (qfv m) (concat dss'')))
+
+> inlineVars :: SimplifyFlags -> ModuleIdent -> ValueEnv -> [Decl] -> InlineEnv -> InlineEnv
+> inlineVars flags m tyEnv [PatternDecl _ (VariablePattern v) (SimpleRhs _ e _)] env
+>   | canInline e = bindEnv v e env
+>   where canInline (Literal _) = True
+>         canInline (Constructor _) = True
+>         canInline (Variable v')
+>           | isQualified v' = arrowArity (funType m tyEnv v') > 0
+>           | otherwise = v /= unqualify v'
+>         canInline _ = False
+> inlineVars _ _ _ _ env = env
+
+> mkLet :: SimplifyFlags -> ModuleIdent -> [Decl] -> Expression -> Expression
+> mkLet flags m [ExtraVariables p vs] e
+>   | null vs' = e
+>   | otherwise = Let [ExtraVariables p vs'] e
+>   where vs' = filter (`elem` qfv m e) vs
+> mkLet flags m [PatternDecl _ (VariablePattern v) (SimpleRhs _ e _)] (Variable v')
+>   | v' == qualify v && v `notElem` qfv m e = e
+> mkLet flags m ds e
+>   | null (filter (`elem` qfv m e) (bv ds)) = e
+>   | otherwise = Let ds e
+
+\end{verbatim}
+\label{pattern-binding}
+In order to implement lazy pattern matching in local declarations,
+pattern declarations $t$~\texttt{=}~$e$ where $t$ is not a variable
+are transformed into a list of declarations
+$v_0$~\texttt{=}~$e$\texttt{;} $v_1$~\texttt{=}~$f_1$~$v_0$\texttt{;}
+\dots{} $v_n$~\texttt{=}~$f_n$~$v_0$ where $v_0$ is a fresh variable,
+$v_1,\dots,v_n$ are the variables occurring in $t$ and the auxiliary
+functions $f_i$ are defined by $f_i$~$t$~\texttt{=}~$v_i$ (see also
+appendix D.8 of the Curry report~\cite{Hanus:Report}). The bindings
+$v_0$~\texttt{=}~$e$ are introduced before splitting the declaration
+groups of the enclosing let expression (cf. the \texttt{Let} case in
+\texttt{simplifyExpr} above) so that they are placed in their own
+declaration group whenever possible. In particular, this ensures that
+the new binding is discarded when the expression $e$ is itself a
+variable.
+
+Unfortunately, this transformation introduces a well-known space
+leak~\cite{Wadler87:Leaks,Sparud93:Leaks} because the matched
+expression cannot be garbage collected until all of the matched
+variables have been evaluated. Consider the following function:
+\begin{verbatim}
+  f x | all (' ' ==) cs = c where (c:cs) = x
+\end{verbatim}
+One might expect the call \verb|f (replicate 10000 ' ')| to execute in
+constant space because (the tail of) the long list of blanks is
+consumed and discarded immediately by \texttt{all}. However, the
+application of the selector function that extracts the head of the
+list is not evaluated until after the guard has succeeded and thus
+prevents the list from being garbage collected.
+
+In order to avoid this space leak we use the approach
+from~\cite{Sparud93:Leaks} and update all pattern variables when one
+of the selector functions has been evaluated. Therefore all pattern
+variables except for the matched one are passed as additional
+arguments to each of the selector functions. Thus, each of these
+variables occurs twice in the argument list of a selector function,
+once in the first argument and also as one of the remaining arguments.
+This duplication of names is used by the compiler to insert the code
+that updates the variables when generating abstract machine code.
+
+By its very nature, this transformation introduces cyclic variable
+bindings. Since cyclic bindings are not supported by PAKCS, we revert
+to a simpler translation when generating FlatCurry output.
+
+We will add only those pattern variables as additional arguments which
+are actually used in the code. This reduces the number of auxiliary
+variables and can prevent the introduction of a recursive binding
+group when only a single variable is used. It is also the reason for
+performing this transformation here instead of in the \texttt{Desugar}
+module. The selector functions are defined in a local declaration on
+the right hand side of a projection declaration so that there is
+exactly one declaration for each used variable.
+
+Another problem of the translation scheme is the handling of pattern
+variables with higher-order types, e.g.,
+\begin{verbatim}
+  strange :: [a->a] -> Maybe (a->a)
+  strange xs = Just x
+    where (x:_) = xs
+\end{verbatim}
+By reusing the types of the pattern variables, the selector function
+\verb|f (x:_) = x| has type \texttt{[a->a] -> a -> a} and therefore
+seems to be binary function. Thus, in the goal \verb|strange []| the
+selector is only applied partially and not evaluated. Note that this
+goal will fail without the type annotation. In order to ensure that a
+selector function is always evaluated when the corresponding variable
+is used, we assume that the projection declarations -- ignoring the
+additional arguments to prevent the space leak -- are actually defined
+by $f_i$~$t$~\texttt{= I}~$v_i$, using a private renaming type
+\begin{verbatim}
+  newtype Identity a = I a
+\end{verbatim}
+As newtype constructors are completely transparent to the compiler,
+this does not change the generated code, but only the types of the
+selector functions.
+\begin{verbatim}
+
+> sharePatternRhs :: ModuleIdent -> ValueEnv -> Decl -> SimplifyState [Decl]
+> sharePatternRhs m tyEnv (PatternDecl p t rhs) =
+>   case t of
+>     VariablePattern _ -> return [PatternDecl p t rhs]
+>     _ -> 
+>       do
+>         v0 <- freshIdent m patternId (monoType (typeOf tyEnv t))
+>         let v = addRefId (ast p) v0
+>         return [PatternDecl p t (SimpleRhs p (mkVar v) []),
+>                 PatternDecl p (VariablePattern v) rhs]
+>   where patternId n = mkIdent ("_#pat" ++ show n)
+> sharePatternRhs _ _ d = return [d]
+
+> expandPatternBindings :: SimplifyFlags -> ModuleIdent -> ValueEnv -> [Ident] 
+>    -> Decl -> SimplifyState [Decl]
+>
+> expandPatternBindings flags m tyEnv fvs (PatternDecl p t (SimpleRhs p' e _)) =
+>   case t of
+>     VariablePattern _ -> return [PatternDecl p t (SimpleRhs p' e [])]
+>     _
+>       | flatFlag flags ->
+>           do
+>             fs <- sequence (zipWith getId tys vs)
+>             return (zipWith (flatProjectionDecl p t e) fs vs)
+>       | otherwise ->
+>           do
+>             fs <- mapM (freshIdent m fpSelectorId . selectorType ty)
+>                        (shuffle tys)
+>             return (zipWith (projectionDecl p t e) fs (shuffle vs))
+>
+>       where getId t v = freshIdent m 
+>                            (\ i -> updIdentName ( ++'#':name v) (fpSelectorId i))
+>                            (flatSelectorType ty t)
+>             
+>             vs = filter (`elem` fvs) (bv t)
+>             ty = typeOf tyEnv t
+>             tys = map (typeOf tyEnv) vs
+>             selectorType ty0 (ty:tys) =
+>               polyType (foldr TypeArrow (identityType ty) (ty0:tys))
+>
+>             selectorDecl p f t (v:vs) =
+>               funDecl p f (t:map VariablePattern vs) (mkVar v)
+>             projectionDecl p t e f (v:vs) =
+>               varDecl p v (Let [selectorDecl p f t (v:vs)]
+>                                (foldl applyVar (Apply (mkVar f) e) vs))
+>
+>             flatSelectorType ty0 ty =
+>               polyType (TypeArrow ty0 (identityType ty))
+>             flatSelectorDecl p f t v = funDecl p f [t] (mkVar v)
+>             flatProjectionDecl p t e f v =
+>               varDecl p v (Let [flatSelectorDecl p f t v] (Apply (mkVar f) e))
+>
+> expandPatternBindings _ _ _ _ d = return [d]
+
+\end{verbatim}
+Auxiliary functions
+\begin{verbatim}
+
+> isVarPattern :: ConstrTerm -> Bool
+> isVarPattern (VariablePattern _) = True
+> isVarPattern (AsPattern _ t) = isVarPattern t
+> isVarPattern (ConstructorPattern _ _) = False
+> isVarPattern (LiteralPattern _) = False
+
+> funType :: ModuleIdent -> ValueEnv -> QualIdent -> Type
+> funType m tyEnv f =
+>   case (qualLookupValue f tyEnv) of
+>     [Value _ (ForAll _ ty)] -> ty
+>     vs -> case (qualLookupValue (qualQualify m f) tyEnv) of
+>             [Value _ (ForAll _ ty)] -> ty
+>             _ -> internalError ("funType " ++ show f)
+
+> evMode :: EvalEnv -> Ident -> Maybe EvalAnnotation
+> evMode evEnv f = lookupEnv f evEnv
+
+> freshIdent :: ModuleIdent -> (Int -> Ident) -> TypeScheme
+>            -> SimplifyState Ident
+> freshIdent m f ty =
+>   do
+>     x <- liftM f (liftSt (liftRt (updateSt (1 +))))
+>     updateSt_ (bindFun m x ty)
+>     return x
+
+> shuffle :: [a] -> [[a]]
+> shuffle xs = shuffle id xs
+>   where shuffle _ [] = []
+>         shuffle f (x:xs) = (x : f xs) : shuffle (f . (x:)) xs
+
+> mkVar :: Ident -> Expression
+> mkVar = Variable . qualify
+
+> applyVar :: Expression -> Ident -> Expression
+> applyVar e v = Apply e (mkVar v)
+
+> varDecl :: Position -> Ident -> Expression -> Decl
+> varDecl p v e = PatternDecl p (VariablePattern v) (SimpleRhs p e [])
+
+> funDecl :: Position -> Ident -> [ConstrTerm] -> Expression -> Decl
+> funDecl p f ts e =
+>   FunctionDecl p f [Equation p (FunLhs f ts) (SimpleRhs p e [])]
+
+> identityType :: Type -> Type
+> identityType = TypeConstructor qIdentityId . return
+>   where qIdentityId = qualify (mkIdent "Identity")
+
+\end{verbatim}
diff --git a/src/Subst.lhs b/src/Subst.lhs
new file mode 100644
--- /dev/null
+++ b/src/Subst.lhs
@@ -0,0 +1,127 @@
+% -*- LaTeX -*-
+% $Id: Subst.lhs,v 1.7 2002/12/20 13:12:51 lux Exp $
+%
+% Copyright (c) 2002, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Subst.lhs}
+\section{Substitutions}
+The module {\tt Subst} implements substitutions. A substitution
+$\sigma = \left\{x_1\mapsto t_1,\dots,x_n\mapsto t_n\right\}$ is a
+finite mapping from (finitely many) variables $x_1,\dots,x_n$ to
+some kind of expression or term.
+
+In order to implement substitutions efficiently composed
+substitutions are marked with a boolean flag (see below).
+\begin{verbatim}
+
+> module Subst where
+
+> import Map
+
+> data Subst a b = Subst Bool (FM a b) deriving Show
+
+> idSubst :: Ord a => Subst a b
+> idSubst = Subst False zeroFM
+
+> substToList :: Ord v => Subst v e -> [(v,e)]
+> substToList (Subst _ sigma) = toListFM sigma
+
+> bindSubst :: Ord v => v -> e -> Subst v e -> Subst v e
+> bindSubst v e (Subst comp sigma) = Subst comp (addToFM v e sigma)
+
+> unbindSubst :: Ord v => v -> Subst v e -> Subst v e
+> unbindSubst v (Subst comp sigma) = Subst comp (deleteFromFM v sigma)
+
+\end{verbatim}
+For any substitution we have the following definitions:
+\begin{displaymath}
+  \begin{array}{l}
+    \sigma(x) = \left\{\begin{array}{ll}
+        t_i&\mbox{if $x=x_i$}\\
+        x&\mbox{otherwise}\end{array}\right. \\
+    \mathop{{\mathcal D}om}(\sigma) = \left\{x_1,\dots,x_n\right\} \\
+    \mathop{{\mathcal C}odom}(\sigma) = \left\{t_1,\dots,t_n\right\}
+  \end{array}  
+\end{displaymath}
+Note that obviously the set of variables must be a subset of the set
+of expressions. Also it is usually possible to extend the substitution
+to a homomorphism on the codomain of the substitution. This is
+captured by the following class declaration:
+\begin{verbatim}
+
+class Ord v => Subst v e where
+  var :: v -> e
+  subst :: Subst v e -> e -> e
+
+\end{verbatim}
+With the help of the injection \texttt{var}, we can then compute the
+substitution for a variable $\sigma(v)$ and also the composition of
+two substitutions
+$(\sigma_1 \circ \sigma_2)(e) \mathop{:=} \sigma_1(\sigma_2(e))$. A
+naive implementation of the composition were
+\begin{verbatim}
+  compose sigma sigma' =
+    foldr (uncurry bindSubst) sigma (substToList (fmap (subst sigma) sigma'))
+\end{verbatim}
+However, such an implementation is very inefficient because the
+number of substiutions applied to a variable increases in
+$\mathcal{O}(n)$ of the number of compositions.
+
+A more efficient implementation is to apply \texttt{subst} again to
+the value substituted for a variable in
+$\mathop{{\mathcal D}om}(\sigma)$. However, this is correct only as
+long as the result of the substitution does not include any variables
+which are in $\mathop{{\mathcal D}om}(\sigma)$. For instance, it is
+impossible to implement simple variable renamings in this way.
+
+Therefore we use the simple strategy to apply \texttt{subst} again
+only in case of a substitution which was returned from \texttt{compose}.
+\begin{verbatim}
+
+substVar :: Subst v e => Subst v e -> v -> e
+substVar (Subst comp sigma) v = maybe (var v) subst' (lookupFM v sigma)
+  where subst' = if comp then subst (Subst comp sigma) else id
+
+> compose :: (Show v,Ord v,Show e) => Subst v e -> Subst v e -> Subst v e
+> compose sigma sigma' =
+>   composed (foldr (uncurry bindSubst) sigma' (substToList sigma))
+>   where dom = domain sigma
+>         dom' = domain sigma'
+>         domain = map fst . substToList
+>         composed (Subst _ sigma) = Subst True sigma
+
+\end{verbatim}
+Unfortunately Haskell does not (yet) support multi-parameter type
+classes. For that reason we have to define a separate class for each
+kind of variable type for these functions. We implement
+\texttt{substVar} as a function that takes the class functions as an
+additional parameters. As an example for the use of this function the
+module includes a class \texttt{IntSubst} for substitution whose
+domain are integer numbers.
+\begin{verbatim}
+
+> substVar' :: Ord v => (v -> e) -> (Subst v e -> e -> e)
+>           -> Subst v e -> v -> e
+> substVar' var subst (Subst comp sigma) v =
+>   maybe (var v) subst' (lookupFM v sigma)
+>   where subst' = if comp then subst (Subst comp sigma) else id
+
+> class IntSubst e where
+>   ivar :: Int -> e
+>   isubst :: Subst Int e -> e -> e
+
+> isubstVar :: IntSubst e => Subst Int e -> Int -> e
+> isubstVar = substVar' ivar isubst
+
+\end{verbatim}
+The function \texttt{restrictSubstTo} implements the restriction of a
+substitution to a given subset of its domain.
+\begin{verbatim}
+
+> restrictSubstTo :: Ord v => [v] -> Subst v e -> Subst v e
+> restrictSubstTo vs (Subst comp sigma) =
+>   foldr (uncurry bindSubst) (Subst comp zeroFM)
+>         (filter ((`elem` vs) . fst) (toListFM sigma))
+
+\end{verbatim}
diff --git a/src/SyntaxCheck.lhs b/src/SyntaxCheck.lhs
new file mode 100644
--- /dev/null
+++ b/src/SyntaxCheck.lhs
@@ -0,0 +1,1183 @@
+
+% $Id: SyntaxCheck.lhs,v 1.53 2004/02/15 22:10:37 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{SyntaxCheck.lhs}
+\section{Syntax Checks}
+After the type declarations have been checked, the compiler performs a
+syntax check on the remaining declarations. This check disambiguates
+nullary data constructors and variables which -- in contrast to
+Haskell -- is not possible on purely syntactic criteria. In addition,
+this pass checks for undefined as well as ambiguous variables and
+constructors. In order to allow lifting of local definitions in
+later phases, all local variables are renamed by adding a unique
+key.\footnote{Actually, all variables defined in the same scope share
+the same key.} Finally, all (adjacent) equations of a function are
+merged into a single definition.
+\begin{verbatim}
+
+> module SyntaxCheck(syntaxCheck) where
+
+> import Data.Maybe
+> import Data.List
+> import Control.Monad
+
+> import Base
+> import Env
+> import NestEnv
+> import Combined
+> import Utils
+
+\end{verbatim}
+The syntax checking proceeds as follows. First, the compiler extracts
+information about all imported values and data constructors from the
+imported (type) environments. Next, the data constructors defined in
+the current module are entered into this environment. After this
+all record labels are entered into the environment too. If a record
+identifier is already assigned to a constructor, then an error will be
+generated. Finally, all
+declarations are checked within the resulting environment. In
+addition, this process will also rename the local variables.
+\begin{verbatim}
+
+> syntaxCheck :: Bool -> ModuleIdent -> ImportEnv -> ArityEnv -> ValueEnv 
+>                -> TCEnv -> [Decl] -> [Decl]
+> syntaxCheck withExt m iEnv aEnv tyEnv tcEnv ds =
+>   case linear (concatMap constrs tds) of
+>     --Linear -> tds ++ run (checkModule withExt m env vds)
+>     Linear -> map (checkTypeDecl withExt m) tds
+>	        ++ run (checkModule withExt m env2 vds)
+>     NonLinear c -> errorAt' (duplicateData c)
+>   where (tds,vds) = partition isTypeDecl ds
+>	  (rs, tds') = partition isRecordDecl tds
+>         env1 = foldr (bindTypes m) -- (bindConstrs m) 
+>	               (globalEnv (fmap (renameInfo tcEnv iEnv aEnv) tyEnv)) 
+>	               tds'
+>	  env2 = foldr (bindTypes m) env1 rs
+
+> --syntaxCheckGoal :: Bool -> ValueEnv -> Goal -> Goal
+> --syntaxCheckGoal withExt tyEnv g =
+> --  run (checkGoal withExt (mkMIdent []) (globalEnv (fmap renameInfo tyEnv)) g)
+
+\end{verbatim}
+A global state transformer is used for generating fresh integer keys
+by which the variables get renamed.
+\begin{verbatim}
+
+> type RenameState a = StateT Int Id a
+
+> run :: RenameState a -> a
+> run m = runSt m (globalKey + 1)
+
+> newId :: RenameState Int
+> newId = updateSt (1 +)
+
+\end{verbatim}
+\ToDo{Probably the state transformer should use an \texttt{Integer} 
+counter.}
+
+A nested environment is used for recording information about the data
+constructors and variables in the module. For every data constructor
+its arity is saved. This is used for checking that all constructor
+applications in patterns are saturated. For local variables the
+environment records the new name of the variable after renaming.
+Global variables are recorded with qualified identifiers in order
+to distinguish multiply declared entities.
+
+Currently records must explicitly be declared together with their labels.
+When constructing or updating a record, it is necessary to compute 
+all its labels using just one of them. Thus for each label 
+the record identifier and all its labels are entered into the environment
+
+\em{Note:} the function \texttt{qualLookupVar} has been extended to
+allow the usage of the qualified list constructor \texttt{(prelude.:)}.
+\begin{verbatim}
+
+> type RenameEnv = NestEnv RenameInfo
+> data RenameInfo = Constr Int 
+>                 | GlobalVar Int QualIdent 
+>                 | LocalVar Int Ident
+>	          | RecordLabel QualIdent [Ident]
+>	    deriving (Eq,Show)
+
+> globalKey :: Int
+> globalKey = uniqueId (mkIdent "")
+
+> renameInfo :: TCEnv -> ImportEnv -> ArityEnv -> ValueInfo -> RenameInfo
+> renameInfo tcEnv iEnv aEnv (DataConstructor _ (ForAllExist _ _ ty)) 
+>    = Constr (arrowArity ty)
+> renameInfo tcEnv iEnv aEnv (NewtypeConstructor _ _) 
+>    = Constr 1
+> renameInfo tcEnv iEnv aEnv (Value qid _)
+>    = let (mmid, id) = splitQualIdent qid
+>          qid' = maybe qid 
+>	                (\mid -> maybe qid 
+>		                       (\mid' -> qualifyWith mid' id)
+>				       (lookupAlias mid iEnv))
+>		        mmid
+>      in case (lookupArity id aEnv) of
+>	    [ArityInfo _ arity] -> GlobalVar arity qid
+>           rs -> case (qualLookupArity qid' aEnv) of
+>	            [ArityInfo _ arity] -> GlobalVar arity qid
+>	            _ -> maybe (internalError "renameInfo: missing arity")
+>	                       (\ (ArityInfo _ arity) -> GlobalVar arity qid)
+>		               (find (\ (ArityInfo qid'' _) 
+>			              -> qid'' == qid) rs)
+> renameInfo tcEnv iEnv aEnv (Label l r _)
+>    = case (qualLookupTC r tcEnv) of
+>        [AliasType _ _ (TypeRecord fs _)] ->
+>          RecordLabel r (map fst fs)
+>        _ -> internalError "renameInfo: no record"
+
+\end{verbatim}
+Since record types are currently translated into data types, it is
+necessary to ensure that all identifiers for records and constructors
+are different. Furthermore it is not allowed to declare a label more
+than once.
+\begin{verbatim}
+
+> bindTypes :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv
+> bindTypes m (DataDecl _ tc _ cs) env = foldr (bindConstr m) env cs
+> bindTypes m (NewtypeDecl _ tc _ nc) env = bindNewConstr m nc env
+> bindTypes m (TypeDecl _ t _ (RecordType fs r)) env =
+>    -- | isJust r = internalError "bindTypes: illegal record declaration"
+>    -- | null fs = errorAt (positionOfIdent t) emptyRecord
+>    -- | otherwise =
+>      case (qualLookupVar (qualifyWith m t) env) of
+>        [] -> foldr (bindRecordLabel m t (concatMap fst fs)) env fs
+>        rs | any isConstr rs -> errorAt' (illegalRecordId t)
+>           | otherwise
+>             -> foldr (bindRecordLabel m t (concatMap fst fs)) env fs
+> bindTypes _ _ env = env
+
+> bindRecordLabel :: ModuleIdent -> Ident -> [Ident] 
+>	             -> ([Ident],TypeExpr) -> RenameEnv -> RenameEnv
+> bindRecordLabel m t labels (ls,_) env = 
+>     foldr (\l -> case (lookupVar l env) of
+>                    [] -> bindGlobal m l
+>                             (RecordLabel (qualifyWith m t) labels)
+>                    _  -> errorAt' (duplicateDefinition l)
+>	    ) env ls
+
+> --bindConstrs :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv
+> --bindConstrs m (DataDecl _ tc _ cs) env = foldr (bindConstr m) env cs
+> --bindConstrs m (NewtypeDecl _ tc _ nc) env = bindNewConstr m nc env
+> --bindConstrs _ _ env = env
+
+> bindConstr :: ModuleIdent -> ConstrDecl -> RenameEnv -> RenameEnv
+> bindConstr m (ConstrDecl _ _ c tys) = bindGlobal m c (Constr (length tys))
+> bindConstr m (ConOpDecl _ _ _ op _) = bindGlobal m op (Constr 2)
+
+> bindNewConstr :: ModuleIdent -> NewConstrDecl -> RenameEnv -> RenameEnv
+> bindNewConstr m (NewConstrDecl _ _ c _) = bindGlobal m c (Constr 1)
+
+> bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv
+> bindFuncDecl m (FunctionDecl _ id equs) env
+>    | null equs = internalError "bindFuncDecl: missing equations"
+>    | otherwise = let (_,ts) = getFlatLhs (head equs)
+>		   in  bindGlobal m 
+>	                          id 
+>			          (GlobalVar (length ts) (qualifyWith m id))
+>	                          env
+> bindFuncDecl m (ExternalDecl _ _ _ id texpr) env
+>    = bindGlobal m id (GlobalVar (typeArity texpr) (qualifyWith m id)) env
+> bindFuncDecl m (TypeSig _ ids texpr) env
+>    = foldr bindTS env (map (qualifyWith m) ids)
+>  where
+>  bindTS qid env 
+>     | null (qualLookupVar qid env)
+>       = bindGlobal m (unqualify qid) (GlobalVar (typeArity texpr) qid) env
+>     | otherwise
+>       = env
+> bindFuncDecl _ _ env = env
+
+> bindVarDecl :: Decl -> RenameEnv -> RenameEnv
+> bindVarDecl (FunctionDecl _ id equs) env
+>    | null equs 
+>      = internalError "bindFuncDecl: missing equations"
+>    | otherwise 
+>      = let (_,ts) = getFlatLhs (head equs)
+>	 in  bindLocal (unRenameIdent id) (LocalVar (length ts) id) env
+> bindVarDecl (PatternDecl p t _) env
+>    = foldr bindVar env (bv t)
+> bindVarDecl (ExtraVariables p vs) env
+>    = foldr bindVar env vs 
+> bindVarDecl _ env = env
+
+> bindVar :: Ident -> RenameEnv -> RenameEnv
+> bindVar v env
+>   | v' == anonId = env
+>   | otherwise = bindLocal v' (LocalVar 0 v) env
+>   where v' = unRenameIdent v
+
+> bindGlobal :: ModuleIdent -> Ident -> RenameInfo -> RenameEnv -> RenameEnv
+> bindGlobal m c r = bindNestEnv c r . qualBindNestEnv (qualifyWith m c) r
+
+> bindLocal :: Ident -> RenameInfo -> RenameEnv -> RenameEnv
+> bindLocal f r = bindNestEnv f r
+
+> lookupVar :: Ident -> RenameEnv -> [RenameInfo]
+> lookupVar v env = lookupNestEnv v env ++! lookupTupleConstr v
+
+> qualLookupVar :: QualIdent -> RenameEnv -> [RenameInfo]
+> qualLookupVar v env =
+>   qualLookupNestEnv v env
+>   ++! qualLookupListCons v env
+>   ++! lookupTupleConstr (unqualify v)
+
+> qualLookupListCons :: QualIdent -> RenameEnv -> [RenameInfo]
+> qualLookupListCons v env
+>    | (isJust mmid) && ((fromJust mmid) == preludeMIdent) && (ident == consId)
+>       = qualLookupNestEnv (qualify ident) env
+>    | otherwise = []
+>  where (mmid, ident) = splitQualIdent v
+
+> lookupTupleConstr :: Ident -> [RenameInfo]
+> lookupTupleConstr v
+>   | isTupleId v = [Constr (tupleArity v)]
+>   | otherwise = []
+
+\end{verbatim}
+When a module is checked, the global declaration group is checked. The
+resulting renaming environment can be discarded. The same is true for
+a goal. Note that all declarations in the goal must be considered as
+local declarations.
+\begin{verbatim}
+
+> checkModule :: Bool -> ModuleIdent -> RenameEnv -> [Decl] -> RenameState [Decl]
+> checkModule withExt m env ds = liftM snd (checkTopDecls withExt m env ds)
+
+> checkTopDecls :: Bool -> ModuleIdent -> RenameEnv -> [Decl]
+>               -> RenameState (RenameEnv,[Decl])
+> checkTopDecls withExt m env ds = 
+>   checkDeclGroup (bindFuncDecl m) withExt m globalKey env ds
+
+> --checkGoal :: Bool -> ModuleIdent -> RenameEnv -> Goal -> RenameState Goal
+> --checkGoal withExt m env (Goal p e ds) =
+> --  do
+> --    (env',ds') <- checkLocalDecls withExt m env ds
+> --    e' <- checkExpr withExt p m env' e
+> --    return (Goal p e' ds')
+
+> checkTypeDecl :: Bool -> ModuleIdent -> Decl -> Decl
+> checkTypeDecl withExt m d@(TypeDecl p r tvs (RecordType fs rty))
+>   | not withExt = errorAt (positionOfIdent r) noRecordExt
+>   | isJust rty = internalError "checkTypeDecl - illegal record type"
+>   | null fs = errorAt (positionOfIdent r) emptyRecord
+>   | otherwise = TypeDecl p r tvs (RecordType fs Nothing)
+> checkTypeDecl _ _ d = d
+
+\end{verbatim}
+Each declaration group opens a new scope and uses a distinct key
+for renaming the variables in this scope. In a declaration group,
+first the left hand sides of all declarations are checked, next the
+compiler checks that there is a definition for every type signature
+and evaluation annotation in this group. Finally, the right hand sides
+are checked and adjacent equations for the same function are merged
+into a single definition.
+
+The function \texttt{checkDeclLhs} also handles the case where a
+pattern declaration is recognized as a function declaration by the
+parser. This happens, e.g., for the declaration \verb|where Just x = y|
+because the parser cannot distinguish nullary constructors and
+functions. Note that pattern declarations are not allowed on the
+top-level.
+\begin{verbatim}
+
+> checkLocalDecls :: Bool -> ModuleIdent -> RenameEnv -> [Decl] 
+>                  -> RenameState (RenameEnv,[Decl])
+> checkLocalDecls withExt m env ds =
+>   newId >>= \k -> checkDeclGroup bindVarDecl withExt m k (nestEnv env) ds
+
+> checkDeclGroup :: (Decl -> RenameEnv -> RenameEnv) -> Bool -> ModuleIdent
+>                 -> Int -> RenameEnv -> [Decl] 
+>                 -> RenameState (RenameEnv,[Decl])
+> checkDeclGroup bindDecl withExt m k env ds =
+>   mapM (checkDeclLhs withExt k m env) ds' >>=
+>   checkDecls bindDecl withExt m env . joinEquations
+>  where ds' = sortFuncDecls ds
+
+> checkDeclLhs :: Bool -> Int -> ModuleIdent -> RenameEnv -> Decl -> RenameState Decl
+> checkDeclLhs withExt k _ _ (InfixDecl p fix pr ops) =
+>   return (InfixDecl p fix pr (map (flip renameIdent k) ops))
+> checkDeclLhs withExt k _ env (TypeSig p vs ty) =
+>   return (TypeSig p (map (checkVar "type signature" k env) vs) ty)
+> checkDeclLhs withExt k _ env (EvalAnnot p fs ev) =
+>   return (EvalAnnot p (map (checkVar "evaluation annotation" k env) fs) ev)
+> checkDeclLhs withExt k m env (FunctionDecl p _ eqs) = 
+>   checkEquationLhs withExt k m env p eqs
+> checkDeclLhs withExt k _ env (ExternalDecl p cc ie f ty) =
+>   return (ExternalDecl p cc ie (checkVar "external declaration" k env f) ty)
+> checkDeclLhs withExt k _ env (FlatExternalDecl p fs) =
+>   return (FlatExternalDecl p
+>             (map (checkVar "external declaration" k env) fs))
+> checkDeclLhs withExt k m env (PatternDecl p t rhs) =
+>   do
+>     t' <- checkConstrTerm withExt k p m env t
+>     return (PatternDecl p t' rhs)
+> checkDeclLhs withExt k _ env (ExtraVariables p vs) =
+>   return (ExtraVariables p
+>             (map (checkVar "free variables declaration" k env) vs))
+> checkDeclLhs _ _ _ _ d = return d
+
+> checkEquationLhs :: Bool -> Int -> ModuleIdent -> RenameEnv -> Position 
+>	           -> [Equation] -> RenameState Decl
+> checkEquationLhs withExt k m env p [Equation p' lhs rhs] =
+>   either (return . funDecl) (checkDeclLhs withExt k m env . patDecl)
+>          (checkEqLhs m k env p' lhs)
+>   where funDecl (f,lhs) = FunctionDecl p f [Equation p' lhs rhs]
+>         patDecl t
+>           | k == globalKey = errorAt p noToplevelPattern
+>           | otherwise = PatternDecl p' t rhs
+> checkEquationLhs _ _ _ _ _ _ = internalError "checkEquationLhs"
+
+> checkEqLhs :: ModuleIdent -> Int -> RenameEnv -> Position -> Lhs
+>            -> Either (Ident,Lhs) ConstrTerm
+> checkEqLhs m k env _ (FunLhs f ts)
+>   | isDataConstr f env
+>     = if k /= globalKey
+>       then Right (ConstructorPattern (qualify f) ts)
+>       else if null (qualLookupVar (qualifyWith m f) env)
+>            then Left (f',FunLhs f' ts)
+>	     else errorAt (positionOfIdent f) noToplevelPattern
+>   | otherwise = Left (f',FunLhs f' ts)
+>   where f' = renameIdent f k
+> checkEqLhs m k env p (OpLhs t1 op t2)
+>   | isDataConstr op env 
+>     = if k /= globalKey
+>       then checkOpLhs k env (infixPattern t1 (qualify op)) t2
+>       else if null (qualLookupVar (qualifyWith m op) env)
+>            then Left (op',OpLhs t1 op' t2)
+>	     else errorAt p noToplevelPattern
+>   | otherwise = Left (op',OpLhs t1 op' t2)
+>   where op' = renameIdent op k
+>         infixPattern (InfixPattern t1 op1 t2) op2 t3 =
+>           InfixPattern t1 op1 (infixPattern t2 op2 t3)
+>         infixPattern t1 op t2 = InfixPattern t1 op t2
+> checkEqLhs m k env p (ApLhs lhs ts) =
+>   case checkEqLhs m k env p lhs of
+>     Left (f',lhs') -> Left (f',ApLhs lhs' ts)
+>     Right _ -> errorAt' $ nonVariable "curried definition" f
+>   where (f,_) = flatLhs lhs
+
+> checkOpLhs :: Int -> RenameEnv -> (ConstrTerm -> ConstrTerm) -> ConstrTerm
+>            -> Either (Ident,Lhs) ConstrTerm
+> checkOpLhs k env f (InfixPattern t1 op t2)
+>   | isJust m || isDataConstr op' env =
+>       checkOpLhs k env (f . InfixPattern t1 op) t2
+>   | otherwise = Left (op'',OpLhs (f t1) op'' t2)
+>   where (m,op') = splitQualIdent op
+>         op'' = renameIdent op' k
+> checkOpLhs _ _ f t = Right (f t)
+
+> checkVar :: String -> Int -> RenameEnv -> Ident -> Ident
+> checkVar what k env v 
+>   | False && isDataConstr v env = errorAt' (nonVariable what v)---------------
+>   | otherwise = renameIdent v k
+
+
+> checkDecls :: (Decl -> RenameEnv -> RenameEnv) -> Bool -> ModuleIdent
+>	        -> RenameEnv -> [Decl] -> RenameState (RenameEnv,[Decl])
+> checkDecls bindDecl withExt m env ds = 
+>   case linear bvs of
+>     Linear ->
+>       case linear tys of
+>         Linear ->
+>           case linear evs of
+>             Linear ->
+>               case filter (`notElem` tys) fs' of
+>                 [] -> liftM ((,) env') 
+>		              (mapM (checkDeclRhs withExt bvs m env'') ds)
+>                 f : _ -> errorAt' (noTypeSig f)
+>             NonLinear v -> errorAt' (duplicateEvalAnnot v)
+>         NonLinear v -> errorAt' (duplicateTypeSig v)
+>     NonLinear v -> errorAt' (duplicateDefinition v)
+>   where vds = filter isValueDecl ds
+>	  tds = filter isTypeSig ds
+>         bvs = concat (map vars vds)
+>         tys = concat (map vars tds)
+>         evs = concat (map vars (filter isEvalAnnot ds))
+>         fs' = [f | FlatExternalDecl _ fs <- ds, f <- fs]
+>         env' = foldr bindDecl env vds
+>         env'' = foldr bindDecl env' tds
+
+> checkDeclRhs :: Bool -> [Ident] -> ModuleIdent -> RenameEnv -> Decl 
+>              -> RenameState Decl
+> checkDeclRhs withExt bvs _ _ (TypeSig p vs ty) =
+>   return (TypeSig p (map (checkLocalVar bvs ) vs) ty)
+> checkDeclRhs withExt bvs _ _ (EvalAnnot p vs ev) =
+>   return (EvalAnnot p (map (checkLocalVar bvs ) vs) ev)
+> checkDeclRhs withExt _ m env (FunctionDecl p f eqs) =
+>   liftM (FunctionDecl p f) (mapM (checkEquation withExt m env) eqs)
+> checkDeclRhs withExt _ m env (PatternDecl p t rhs) =
+>   liftM (PatternDecl p t) (checkRhs withExt m env rhs)
+> checkDeclRhs _ _ _ _ d = return d
+
+> checkLocalVar :: [Ident] -> Ident -> Ident
+> checkLocalVar bvs v
+>   | v `elem` bvs = v
+>   | otherwise = errorAt' (noBody v)
+
+> joinEquations :: [Decl] -> [Decl]
+> joinEquations [] = []
+> joinEquations (FunctionDecl p f eqs : FunctionDecl p' f' [eq] : ds)
+>   | f == f' =
+>       if arity (head eqs) == arity eq then
+>         joinEquations (FunctionDecl p f (eqs ++ [eq]) : ds)
+>       else
+>         errorAt' (differentArity f)
+>   where arity (Equation _ lhs _) = length $ snd $ flatLhs lhs
+> joinEquations (d : ds) = d : joinEquations ds
+
+> checkEquation :: Bool -> ModuleIdent -> RenameEnv -> Equation -> RenameState Equation
+> checkEquation withExt m env (Equation p lhs rhs) =
+>   do
+>     (env',lhs') <- checkLhs withExt p m env lhs
+>     rhs' <- checkRhs withExt m env' rhs
+>     return (Equation p lhs' rhs')
+
+> checkLhs :: Bool -> Position -> ModuleIdent -> RenameEnv -> Lhs 
+>             -> RenameState (RenameEnv,Lhs)
+> checkLhs withExt p m env lhs =
+>   newId >>= \k ->
+>   checkLhsTerm withExt k p m env lhs >>=
+>   return . checkConstrTerms withExt (nestEnv env)
+
+> checkLhsTerm :: Bool -> Int -> Position -> ModuleIdent -> RenameEnv -> Lhs 
+>                 -> RenameState Lhs
+> checkLhsTerm withExt k p m env (FunLhs f ts) =
+>   do
+>     ts' <- mapM (checkConstrTerm withExt k p m env) ts
+>     return (FunLhs f ts')
+> checkLhsTerm withExt k p m env (OpLhs t1 op t2) =
+>   let wrongCalls = concatMap (checkParenConstrTerm (Just (qualify op)))
+>                               [t1,t2] in
+>   if not (null wrongCalls)
+>     then errorAt (positionOfIdent op) 
+>                  (infixWithoutParens wrongCalls)
+>     else  do
+>       t1' <- checkConstrTerm withExt k p m env t1
+>       t2' <- checkConstrTerm withExt k p m env t2 
+>       return (OpLhs t1' op t2')
+>
+> checkLhsTerm withExt k p m env (ApLhs lhs ts) =
+>   do
+>     lhs' <- checkLhsTerm withExt k p m env lhs
+>     ts' <- mapM (checkConstrTerm withExt k p m env) ts
+>     return (ApLhs lhs' ts')
+
+> checkArgs :: Bool -> Position -> ModuleIdent -> RenameEnv -> [ConstrTerm]
+>           -> RenameState (RenameEnv,[ConstrTerm])
+> checkArgs withExt p m env ts =
+>   newId >>= \k ->
+>   mapM (checkConstrTerm withExt k p m env) ts >>=
+>   return . checkConstrTerms withExt (nestEnv env)
+
+> checkConstrTerms :: QuantExpr t => Bool -> RenameEnv -> t
+>                  -> (RenameEnv,t)
+> checkConstrTerms withExt env ts =
+>   case linear bvs of
+>     Linear -> (foldr bindVar env bvs,ts)
+>     NonLinear v -> errorAt' (duplicateVariable v)
+>   where bvs = bv ts
+
+> checkConstrTerm :: Bool -> Int -> Position -> ModuleIdent -> RenameEnv
+>	             -> ConstrTerm -> RenameState ConstrTerm
+> checkConstrTerm _ _ _ _ _ (LiteralPattern l) =
+>   liftM LiteralPattern (renameLiteral l)
+> checkConstrTerm _ _ _ _ _ (NegativePattern op l) =
+>   liftM (NegativePattern op) (renameLiteral l)
+> checkConstrTerm withExt k p m env (VariablePattern v)
+>   | v == anonId 
+>     = liftM (VariablePattern . renameIdent anonId) newId
+>   | otherwise 
+>     = checkConstrTerm withExt k p m env (ConstructorPattern (qualify v) [])
+> checkConstrTerm withExt k p m env (ConstructorPattern c ts) =
+>   case qualLookupVar c env of
+>     [Constr n]
+>       | n == n' ->
+>           liftM (ConstructorPattern c) 
+>	          (mapM (checkConstrTerm withExt k p m env) ts)
+>       | otherwise -> errorAt' (wrongArity c n n')
+>       where n' = length ts
+>     [r]
+>       | null ts && not (isQualified c) ->
+>	    return (VariablePattern (renameIdent (varIdent r) k))
+>       | withExt ->
+>           do ts' <- mapM (checkConstrTerm withExt k p m env) ts
+>	       if n' > n
+>	          then let (ts1,ts2) = splitAt n ts'
+>	               in  return (genFuncPattAppl 
+>			             (FunctionPattern (qualVarIdent r) 
+>				                      ts1) 
+>	                             ts2)
+>	          else return (FunctionPattern (qualVarIdent r) ts')
+>       | otherwise -> errorAt (positionOfQualIdent c) noFuncPattExt  
+>	where n = arity r
+>	      n' = length ts
+>     rs -> case (qualLookupVar (qualQualify m c) env) of
+>             []
+>               | null ts && not (isQualified c) ->
+>	            return (VariablePattern (renameIdent (unqualify c) k))
+>	        | null rs -> errorAt' (undefinedData c)
+>		| otherwise -> errorAt' (ambiguousData c)
+>             [Constr n]
+>               | n == n' ->
+>                   liftM (ConstructorPattern (qualQualify m c)) 
+>                         (mapM (checkConstrTerm withExt k p m env) ts)
+>               | otherwise -> errorAt' (wrongArity c n n')
+>               where n' = length ts
+>	      [r]
+>	        | null ts && not (isQualified c) ->
+>                   return (VariablePattern (renameIdent (varIdent r) k))
+>               | withExt ->
+>	            do ts' <- mapM (checkConstrTerm withExt k p m env) ts
+>	               if n' > n
+>	                  then let (ts1,ts2) = splitAt n ts'
+>	                       in  return 
+>			             (genFuncPattAppl 
+>			                (FunctionPattern (qualVarIdent r) ts1) 
+>	                                ts2)
+>	                  else return (FunctionPattern (qualVarIdent r) ts')
+>	        | otherwise -> errorAt (positionOfQualIdent c) noFuncPattExt
+>               where n = arity r
+>		      n' = length ts
+>             _ -> errorAt' (ambiguousData c)
+> checkConstrTerm withExt k p m env (InfixPattern t1 op t2) =
+>   case (qualLookupVar op env) of
+>     [Constr n]
+>       | n == 2 ->
+>           do t1' <- checkConstrTerm withExt k p m env t1
+>	       t2' <- checkConstrTerm withExt k p m env t2
+>              return (InfixPattern t1' op t2') 
+>       | otherwise -> errorAt' (wrongArity op n 2)
+>     [r]
+>       | withExt ->
+>           do t1' <- checkConstrTerm withExt k p m env t1
+>	       t2' <- checkConstrTerm withExt k p m env t2
+>              return (InfixFuncPattern t1' op t2')
+>       | otherwise -> errorAt p noFuncPattExt    
+>     rs -> case (qualLookupVar (qualQualify m op) env) of
+>             [] | null rs -> errorAt' (undefinedData op)
+>                | otherwise -> errorAt' (ambiguousData op)
+>             [Constr n]
+>               | n == 2 ->
+>                   do t1' <- checkConstrTerm withExt k p m env t1
+>	               t2' <- checkConstrTerm withExt k p m env t2
+>                      return (InfixPattern t1' (qualQualify m op) t2') 
+>               | otherwise -> errorAt' (wrongArity op n 2)
+>	      [r]
+>               | withExt ->
+>	            do t1' <- checkConstrTerm withExt k p m env t1
+>	               t2' <- checkConstrTerm withExt k p m env t2
+>		       return (InfixFuncPattern t1' (qualQualify m op) t2')
+>	        | otherwise -> errorAt p noFuncPattExt
+>             _ -> errorAt' (ambiguousData op)
+> checkConstrTerm withExt k p m env (ParenPattern t) =
+>   liftM ParenPattern (checkConstrTerm withExt k p m env t)
+> checkConstrTerm withExt k p m env (TuplePattern pos ts) =
+>   liftM (TuplePattern pos) (mapM (checkConstrTerm withExt k p m env) ts)
+> checkConstrTerm withExt k p m env (ListPattern pos ts) =
+>   liftM (ListPattern pos) (mapM (checkConstrTerm withExt k p m env) ts)
+> checkConstrTerm withExt k p m env (AsPattern v t) =
+>   liftM (AsPattern (checkVar "@ pattern" k env v))
+>         (checkConstrTerm withExt k p m env t)
+> checkConstrTerm withExt k p m env (LazyPattern pos t) =
+>   liftM (LazyPattern pos) (checkConstrTerm withExt k p m env t)
+> checkConstrTerm withExt k p m env (RecordPattern fs t)
+>   | not withExt = errorAt p noRecordExt
+>   | not (null fs) =
+>     let (Field _ label patt) = head fs
+>         p' = positionOfIdent label
+>     in  case (lookupVar label env) of
+>           [] -> errorAt' (undefinedLabel label)
+>           [RecordLabel r ls]
+>             | not (null duplicates) ->
+>	        errorAt' (duplicateLabel (head duplicates))
+>	      | isNothing t && not (null missings) ->
+>	        errorAt (positionOfIdent label) 
+>                       (missingLabel (head missings) r "record pattern")
+>             | maybe True ((==) (VariablePattern anonId)) t ->
+>	        do fs' <- mapM (checkFieldPatt withExt k m r env) fs
+>	           t'  <- maybe (return Nothing)
+>	                        (\t' -> checkConstrTerm withExt k p m env t'
+>			                >>= return . Just)
+>			        t
+>	           return (RecordPattern fs' t')
+>	      | otherwise -> errorAt p illegalRecordPatt
+>            where ls' = map fieldLabel fs
+>                  duplicates = maybeToList (dup ls')
+>		   missings = ls \\ ls'
+>	    [_] -> errorAt' (notALabel label)
+>	    _ -> errorAt' (duplicateDefinition label)
+>   | otherwise = errorAt p emptyRecord
+
+> checkFieldPatt :: Bool -> Int -> ModuleIdent -> QualIdent -> RenameEnv
+>	            -> Field ConstrTerm -> RenameState (Field ConstrTerm)
+> checkFieldPatt withExt k m r env (Field p l t)
+>    = case (lookupVar l env) of
+>        [] -> errorAt' (undefinedLabel l)
+>        [RecordLabel r' _]
+>          | r == r' -> do t' <- checkConstrTerm withExt k 
+>                                   (positionOfIdent l) m env t
+>		           return (Field p l t')
+>          | otherwise -> errorAt' (illegalLabel l r)
+>        [_] -> errorAt' (notALabel l)
+>	 _ -> errorAt' (duplicateDefinition l)
+
+> checkRhs :: Bool -> ModuleIdent -> RenameEnv -> Rhs -> RenameState Rhs
+> checkRhs withExt m env (SimpleRhs p e ds) =
+>   do
+>     (env',ds') <- checkLocalDecls withExt m env ds
+>     e' <- checkExpr withExt p m env' e
+>     return (SimpleRhs p e' ds')
+> checkRhs withExt m env (GuardedRhs es ds) =
+>   do
+>     (env',ds') <- checkLocalDecls withExt m env ds
+>     es' <- mapM (checkCondExpr withExt m env') es
+>     return (GuardedRhs es' ds')
+
+> checkCondExpr :: Bool -> ModuleIdent -> RenameEnv -> CondExpr -> RenameState CondExpr
+> checkCondExpr withExt m env (CondExpr p g e) =
+>   do
+>     g' <- checkExpr withExt p m env g
+>     e' <- checkExpr withExt p m env e
+>     return (CondExpr p g' e')
+
+> checkExpr :: Bool -> Position -> ModuleIdent -> RenameEnv -> Expression 
+>           -> RenameState Expression
+> checkExpr _ _ _ _ (Literal l) = liftM Literal (renameLiteral l)
+> checkExpr withExt _ m env (Variable v) =
+>   case (qualLookupVar v env) of
+>     [] ->  errorAt' (undefinedVariable v)
+>     [Constr _] -> return (Constructor v)
+>     [GlobalVar _ _] -> return (Variable v)
+>     [LocalVar _ v'] -> return (Variable (qualify v'))
+>     rs -> case (qualLookupVar (qualQualify m v) env) of
+>             [] -> errorAt' (ambiguousIdent rs v)
+>             [Constr _] -> return (Constructor v)
+>             [GlobalVar _ _] -> return (Variable v)
+>             [LocalVar _ v'] -> return (Variable (qualify v'))
+>             rs' -> errorAt' (ambiguousIdent rs' v)
+> checkExpr withExt p m env (Constructor c) = 
+>   checkExpr withExt p m env (Variable c)
+> checkExpr withExt p m env (Paren e) = 
+>   liftM Paren (checkExpr withExt p m env e)
+> checkExpr withExt p m env (Typed e ty) = 
+>   liftM (flip Typed ty) (checkExpr withExt p m env e)
+> checkExpr withExt p m env (Tuple pos es) = 
+>   liftM (Tuple pos) (mapM (checkExpr withExt p m env) es)
+> checkExpr withExt p m env (List pos es) = 
+>   liftM (List pos) (mapM (checkExpr withExt p m env) es)
+> checkExpr withExt p m env (ListCompr pos e qs) =
+>   do
+>     (env',qs') <- mapAccumM (checkStatement withExt p m) env qs
+>     e' <- checkExpr withExt p m env' e
+>     return (ListCompr pos e' qs')
+> checkExpr withExt p m env (EnumFrom e) = 
+>   liftM EnumFrom (checkExpr withExt p m env e)
+> checkExpr withExt p m env (EnumFromThen e1 e2) =
+>   do
+>     e1' <- checkExpr withExt p m env e1
+>     e2' <- checkExpr withExt p m env e2
+>     return (EnumFromThen e1' e2')
+> checkExpr withExt p m env (EnumFromTo e1 e2) =
+>   do
+>     e1' <- checkExpr withExt p m env e1
+>     e2' <- checkExpr withExt p m env e2
+>     return (EnumFromTo e1' e2')
+> checkExpr withExt p m env (EnumFromThenTo e1 e2 e3) =
+>   do
+>     e1' <- checkExpr withExt p m env e1
+>     e2' <- checkExpr withExt p m env e2
+>     e3' <- checkExpr withExt p m env e3
+>     return (EnumFromThenTo e1' e2' e3')
+> checkExpr withExt p m env (UnaryMinus op e) = 
+>   liftM (UnaryMinus op) (checkExpr withExt p m env e)
+> checkExpr withExt p m env (Apply e1 e2) =
+>   do
+>     e1' <- checkExpr withExt p m env e1
+>     e2' <- checkExpr withExt p m env e2
+>     return (Apply e1' e2')
+> checkExpr withExt p m env (InfixApply e1 op e2) =
+>   do
+>     e1' <- checkExpr withExt p m env e1
+>     e2' <- checkExpr withExt p m env e2
+>     return (InfixApply e1' (checkOp m env op) e2')
+> checkExpr withExt p m env (LeftSection e op) =
+>   liftM (flip LeftSection (checkOp m env op)) (checkExpr withExt p m env e)
+> checkExpr withExt p m env (RightSection op e) =
+>   liftM (RightSection (checkOp m env op)) (checkExpr withExt p m env e)
+> checkExpr withExt p m env (Lambda r ts e) =
+>   do
+>     (env',ts') <- checkArgs withExt p m env ts
+>     e' <- checkExpr withExt p m env' e
+>     return (Lambda r ts' e')
+> checkExpr withExt p m env (Let ds e) =
+>   do
+>     (env',ds') <- checkLocalDecls withExt m env ds
+>     e' <- checkExpr withExt p m env' e
+>     return (Let ds' e')
+> checkExpr withExt p m env (Do sts e) =
+>   do
+>     (env',sts') <- mapAccumM (checkStatement withExt p m) env sts
+>     e' <- checkExpr withExt p m env' e
+>     return (Do sts' e')
+> checkExpr withExt p m env (IfThenElse r e1 e2 e3) =
+>   do
+>     e1' <- checkExpr withExt p m env e1
+>     e2' <- checkExpr withExt p m env e2
+>     e3' <- checkExpr withExt p m env e3
+>     return (IfThenElse r e1' e2' e3')
+> checkExpr withExt p m env (Case r e alts) =
+>   do
+>     e' <- checkExpr withExt p m env e
+>     alts' <- mapM (checkAlt withExt m env) alts
+>     return (Case r e' alts')
+> checkExpr withExt p m env (RecordConstr fs)
+>   | not withExt = errorAt p noRecordExt
+>   | not (null fs) = 
+>     let (Field _ label expr) = head fs
+>     in  case (lookupVar label env) of
+>           [] -> errorAt' (undefinedLabel label)
+>	    [RecordLabel r ls]
+>              | not (null duplicates) ->
+>                errorAt' (duplicateLabel (head duplicates))
+>              | not (null missings) ->
+>	         errorAt (positionOfIdent label) 
+>                        (missingLabel (head missings) r "record construction")
+>	       | otherwise ->
+>	         do fs' <- mapM (checkFieldExpr withExt m r env) fs
+>	            return (RecordConstr fs')
+>	      where ls' = map fieldLabel fs
+>	            duplicates = maybeToList (dup ls')
+>		    missings = ls \\ ls'
+>           [_] -> errorAt' (notALabel label)
+>	    _ -> errorAt' (duplicateDefinition label)
+>   | otherwise = errorAt p emptyRecord
+> checkExpr withExt p m env (RecordSelection e l)
+>   | not withExt = errorAt p noRecordExt
+>   | otherwise =
+>     case (lookupVar l env) of
+>       [] -> errorAt' (undefinedLabel l)
+>       [RecordLabel r ls] ->
+>         do e' <- checkExpr withExt p m env e
+>            return (RecordSelection e' l)
+>       [_] -> errorAt' (notALabel l)
+>       _ -> errorAt' (duplicateDefinition l)
+> checkExpr withExt p m env (RecordUpdate fs e)
+>   | not withExt = errorAt p noRecordExt
+>   | not (null fs) =
+>     let (Field _ label expr) = head fs
+>     in  case (lookupVar label env) of
+>           [] -> errorAt' (undefinedLabel label)
+>	    [RecordLabel r ls]
+>             | not (null duplicates) ->
+>	        errorAt' (duplicateLabel (head duplicates))
+>	      | otherwise ->
+>	        do fs' <- mapM (checkFieldExpr withExt m r env) fs
+>	           e' <- checkExpr withExt (positionOfIdent label) m env e
+>	           return (RecordUpdate fs' e')
+>	      where duplicates = maybeToList (dup (map fieldLabel fs))
+>	    [_] -> errorAt' (notALabel label)
+>	    _ -> errorAt' (duplicateDefinition label)
+>   | otherwise = errorAt p emptyRecord
+
+> checkStatement :: Bool -> Position -> ModuleIdent -> RenameEnv -> Statement
+>                -> RenameState (RenameEnv,Statement)
+> checkStatement withExt p m env (StmtExpr pos e) =
+>   do
+>     e' <- checkExpr withExt p m env e
+>     return (env,StmtExpr pos e')
+> checkStatement withExt p m env (StmtBind pos t e) =
+>   do
+>     e' <- checkExpr withExt p m env e
+>     (env',[t']) <- checkArgs withExt p m env [t]
+>     return (env',StmtBind pos t' e')
+> checkStatement withExt _ m env (StmtDecl ds) =
+>   do
+>     (env',ds') <- checkLocalDecls withExt m env ds
+>     return (env',StmtDecl ds')
+
+> checkAlt :: Bool -> ModuleIdent -> RenameEnv -> Alt -> RenameState Alt
+> checkAlt withExt m env (Alt p t rhs) =
+>   do
+>     (env',[t']) <- checkArgs withExt p m env [t]
+>     rhs' <- checkRhs withExt m env' rhs
+>     return (Alt p t' rhs')
+
+> checkFieldExpr :: Bool -> ModuleIdent -> QualIdent -> RenameEnv 
+>	            -> Field Expression -> RenameState (Field Expression)
+> checkFieldExpr withExt m r env (Field p l e)
+>    = case (lookupVar l env) of
+>        [] -> errorAt' (undefinedLabel l)
+>        [RecordLabel r' _]
+>          | r == r' -> do e' <- checkExpr withExt (positionOfIdent l) m env e
+>		           return (Field p l e')
+>          | otherwise -> errorAt' (illegalLabel l r)
+>        [_] -> errorAt' (notALabel l)
+>	 _ -> errorAt' (duplicateDefinition l)
+
+
+> checkOp :: ModuleIdent -> RenameEnv -> InfixOp -> InfixOp
+> checkOp m env op =
+>   case (qualLookupVar v env) of
+>     [] -> errorAt' (undefinedVariable v)
+>     [Constr _] -> InfixConstr v
+>     [GlobalVar _ _] -> InfixOp v
+>     [LocalVar _ v'] -> InfixOp (qualify v')
+>     rs -> case (qualLookupVar (qualQualify m v) env) of
+>             [] -> errorAt' (ambiguousIdent rs v)
+>             [Constr _] -> InfixConstr v
+>             [GlobalVar _ _] -> InfixOp v
+>             [LocalVar _ v'] -> InfixOp (qualify v')
+>             rs' -> errorAt' (ambiguousIdent rs' v)
+>   where v = opName op
+
+\end{verbatim}
+Auxiliary definitions.
+\begin{verbatim}
+
+> constrs :: Decl -> [Ident]
+> constrs (DataDecl _ _ _ cs) = map constr cs
+>   where constr (ConstrDecl _ _ c _) = c
+>         constr (ConOpDecl _ _ _ op _) = op
+> constrs (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]
+> constrs _ = []
+
+> vars :: Decl -> [Ident]
+> vars (TypeSig p fs _) = fs
+> vars (EvalAnnot p fs _) = fs
+> vars (FunctionDecl p f _) = [f]
+> vars (ExternalDecl p _ _ f _) = [f]
+> vars (FlatExternalDecl p fs) = fs
+> vars (PatternDecl p t _) = (bv t)
+> vars (ExtraVariables p vs) = vs
+> vars _ = []
+
+> renameLiteral :: Literal -> RenameState Literal
+> renameLiteral (Int v i) = liftM (flip Int i . renameIdent v) newId
+> renameLiteral l = return l
+
+
+Since the compiler expects all rules of the same function to be together,
+it is necessary to sort the list of declarations.
+
+> sortFuncDecls :: [Decl] -> [Decl]
+> sortFuncDecls decls = sortFD emptyEnv [] decls
+>  where
+>  sortFD env res [] = reverse res
+>  sortFD env res (decl:decls)
+>     = case decl of
+>	  FunctionDecl _ ident _
+>	     | isJust (lookupEnv ident env)
+>	       -> sortFD env (insertBy cmpFuncDecl decl res) decls
+>	     | otherwise
+>              -> sortFD (bindEnv ident () env) (decl:res) decls
+>	  _    -> sortFD env (decl:res) decls
+
+> cmpFuncDecl :: Decl -> Decl -> Ordering
+> cmpFuncDecl (FunctionDecl _ id1 _) (FunctionDecl _ id2 _)
+>    | id1 == id2 = EQ
+>    | otherwise  = GT
+> cmpFuncDecl decl1 decl2 = GT
+
+> cmpPos :: Position -> Position -> Ordering
+> cmpPos p1 p2 | lp1 < lp2  = LT
+>              | lp1 == lp2 = EQ
+>              | otherwise  = GT
+>  where lp1 = line p1
+>        lp2 = line p2
+
+> getDeclPos :: Decl -> Position
+> getDeclPos (ImportDecl pos _ _ _ _) = pos
+> getDeclPos (InfixDecl pos _ _ _) = pos
+> getDeclPos (DataDecl pos _ _ _) = pos
+> getDeclPos (NewtypeDecl pos _ _ _) = pos
+> getDeclPos (TypeDecl pos _ _ _) = pos
+> getDeclPos (TypeSig pos _ _) = pos
+> getDeclPos (EvalAnnot pos _ _) = pos
+> getDeclPos (FunctionDecl pos _ _) = pos
+> getDeclPos (ExternalDecl pos _ _ _ _) = pos
+> getDeclPos (FlatExternalDecl pos _) = pos
+> getDeclPos (PatternDecl pos _ _) = pos
+> getDeclPos (ExtraVariables pos _) = pos
+
+\end{verbatim}
+Due to the lack of a capitalization convention in Curry, it is
+possible that an identifier may ambiguously refer to a data
+constructor and a function provided that both are imported from some
+other module. When checking whether an identifier denotes a
+constructor there are two options with regard to ambiguous
+identifiers:
+\begin{enumerate}
+\item Handle the identifier as a data constructor if at least one of
+  the imported names is a data constructor.
+\item Handle the identifier as a data constructor only if all imported
+  entities are data constructors.
+\end{enumerate}
+We choose the first possibility here because in the second case a
+redefinition of a constructor can magically become possible if a
+function with the same name is imported. It seems better to warn
+the user about the fact that the identifier is ambiguous.
+\begin{verbatim}
+
+> isDataConstr :: Ident -> RenameEnv -> Bool
+> isDataConstr v = any isConstr . lookupVar v . globalEnv . toplevelEnv
+
+> isConstr :: RenameInfo -> Bool
+> isConstr (Constr _) = True
+> isConstr (GlobalVar _ _) = False
+> isConstr (LocalVar _ _) = False
+> isConstr (RecordLabel _ _) = False
+
+> varIdent :: RenameInfo -> Ident
+> varIdent (GlobalVar _ v) = unqualify v
+> varIdent (LocalVar _ v) =  v
+> varIdent _ = internalError "not a variable"
+
+> qualVarIdent :: RenameInfo -> QualIdent
+> qualVarIdent (GlobalVar _ v) = v
+> qualVarIdent (LocalVar _ v) = qualify v
+> qualVarIdent _ = internalError "not a qualified variable"
+
+> arity :: RenameInfo -> Int
+> arity (Constr n) = n
+> arity (GlobalVar n _) = n
+> arity (LocalVar n _) = n
+> arity (RecordLabel _ ls) = length ls
+
+\end{verbatim}
+Unlike expressions, constructor terms have no possibility to represent
+over-applications in function patterns. Therefore it is necessary to
+transform them to nested
+function patterns using the prelude function \texttt{apply}. E.g. the
+the function pattern \texttt{(id id 10)} is transformed to
+\texttt{(apply (id id) 10)}
+\begin{verbatim}
+
+> genFuncPattAppl :: ConstrTerm -> [ConstrTerm] -> ConstrTerm
+> genFuncPattAppl term [] = term
+> genFuncPattAppl term (t:ts) 
+>    = FunctionPattern qApplyId [genFuncPattAppl term ts, t]
+>  where
+>  qApplyId = qualifyWith preludeMIdent (mkIdent "apply")
+
+\end{verbatim}
+Miscellaneous functions.
+\begin{verbatim}
+
+> typeArity :: TypeExpr -> Int
+> typeArity (ArrowType _ t2) = 1 + typeArity t2
+> typeArity _                = 0
+
+> getFlatLhs :: Equation -> (Ident,[ConstrTerm])
+> getFlatLhs (Equation  _ lhs _) = flatLhs lhs
+
+> dup :: Eq a => [a] -> Maybe a
+> dup [] = Nothing
+> dup (x:xs) | elem x xs = Just x
+>            | otherwise = dup xs
+
+\end{verbatim}
+Error messages.
+\begin{verbatim}
+
+> undefinedVariable :: QualIdent -> (Position,String)
+> undefinedVariable v = 
+>     (positionOfQualIdent v,
+>      qualName v ++ " is undefined")
+
+> undefinedData :: QualIdent -> (Position,String)
+> undefinedData c =  
+>     (positionOfQualIdent c,
+>      "Undefined data constructor " ++ qualName c)
+
+> undefinedLabel :: Ident -> (Position,String)
+> undefinedLabel l =   
+>     (positionOfIdent l,
+>      "Undefined record label `" ++ name l ++ "`")
+
+> ambiguousIdent :: [RenameInfo] -> QualIdent -> (Position,String)
+> ambiguousIdent rs
+>   | any isConstr rs = ambiguousData
+>   | otherwise = ambiguousVariable
+
+> ambiguousVariable :: QualIdent -> (Position,String)
+> ambiguousVariable v =  
+>     (positionOfQualIdent v,
+>      "Ambiguous variable " ++ qualName v)
+
+> ambiguousData :: QualIdent -> (Position,String)
+> ambiguousData c =  
+>     (positionOfQualIdent c,
+>      "Ambiguous data constructor " ++ qualName c)
+
+> duplicateDefinition :: Ident -> (Position,String)
+> duplicateDefinition v =
+>     (positionOfIdent v,
+>      "More than one definition for `" ++ name v ++ "`")
+
+> duplicateVariable :: Ident -> (Position,String)
+> duplicateVariable v = 
+>     (positionOfIdent v,
+>      name v ++ " occurs more than once in pattern")
+
+> duplicateData :: Ident -> (Position,String)
+> duplicateData c = 
+>     (positionOfIdent c,
+>      "More than one definition for data constructor `"
+>	            ++ name c ++ "`")
+
+> duplicateTypeSig :: Ident -> (Position,String)
+> duplicateTypeSig v =  
+>     (positionOfIdent v,
+>      "More than one type signature for `" ++ name v ++ "`")
+
+> duplicateEvalAnnot :: Ident -> (Position,String)
+> duplicateEvalAnnot v =   
+>     (positionOfIdent v,
+>      "More than one eval annotation for `" ++ name v ++ "`")
+
+> duplicateLabel :: Ident -> (Position,String)
+> duplicateLabel l =   
+>     (positionOfIdent l,
+>      "Multiple occurrence of record label `" ++ name l ++ "`")
+
+> missingLabel :: Ident -> QualIdent -> String -> String 
+> missingLabel l r what = 
+>     "Missing label `" ++ name l 
+>     ++ "` in the " ++ what ++ " of `" 
+>     ++ name (unqualify r) ++ "`" --qualName r
+
+
+> illegalLabel :: Ident -> QualIdent -> (Position,String)
+> illegalLabel l r =   
+>     (positionOfIdent l,
+>      "Label `" ++ name l ++ "` is not defined in record `" 
+>	     ++ name (unqualify r) ++ "`") --qualName r
+
+> illegalRecordId :: Ident -> (Position,String)
+> illegalRecordId r = 
+>    (positionOfIdent r,
+>     "Record identifier `" ++ name r 
+>	      ++ "` already assigned to a data constructor")
+
+> nonVariable :: String -> Ident -> (Position,String)
+> nonVariable what c = 
+>  (positionOfIdent c,     
+>   "Data constructor `" ++ name c ++ "` in left hand side of " ++ what)
+
+> noBody :: Ident -> (Position,String)
+> noBody v = 
+>  (positionOfIdent v,     
+>   "No body for `" ++ name v ++ "`")
+
+> noTypeSig :: Ident -> (Position,String)
+> noTypeSig f = 
+>  (positionOfIdent f,     
+>   "No type signature for external function `" ++ name f ++ "`")
+
+> noToplevelPattern :: String
+> noToplevelPattern = "Pattern declaration not allowed at top-level"
+
+> notALabel :: Ident -> (Position,String)
+> notALabel l =  
+>  (positionOfIdent l,     
+>   "`" ++ name l ++ "` is not a record label")
+
+> emptyRecord :: String
+> emptyRecord = "empty records are not allowed"
+
+> differentArity :: Ident -> (Position,String)
+> differentArity f =   
+>  (positionOfIdent f,     
+>   "Equations for `" ++ name f ++ "` have different arities")
+
+> wrongArity :: QualIdent -> Int -> Int -> (Position,String)
+> wrongArity c arity argc =  
+>  (positionOfQualIdent c,    
+>   "Data constructor " ++ qualName c ++ " expects " ++ arguments arity ++
+>   " but is applied to " ++ show argc)
+>   where arguments 0 = "no arguments"
+>         arguments 1 = "1 argument"
+>         arguments n = show n ++ " arguments"
+
+> --partialFuncPatt :: QualIdent -> Int -> Int -> String
+> --partialFuncPatt f arity argc =
+> --   "Function pattern " ++ qualName f ++ " expects at least " 
+> --   ++ arguments arity ++ " but is applied to " ++ show argc
+> -- where arguments 0 = "no arguments"
+> --       arguments 1 = "1 argument"
+> --       arguments n = show n ++ " arguments"
+
+> noExpressionStatement :: String
+> noExpressionStatement =
+>   "Last statement in a do expression must be an expression"
+
+> illegalRecordPatt :: String
+> illegalRecordPatt = "Expexting `_` after `|` in the record pattern"
+
+> noFuncPattExt :: String
+> noFuncPattExt = "function patterns are not supported in standard curry"
+>	        ++ extMessage
+
+> noRecordExt :: String
+> noRecordExt = "records are not supported in standard curry"
+>             ++ extMessage
+
+> extMessage :: String
+> extMessage = "\n(Use flag -e to enable extended curry)"
+
+> infixWithoutParens :: [(QualIdent,QualIdent)] -> String
+> infixWithoutParens calls =
+>     "Missing parens in infix patterns: \n" ++
+>     unlines (map (\(q1,q2) -> show q1 ++ " " ++ 
+>                               showLine (positionOfQualIdent q1) ++ 
+>                               "calls " ++ show q2 ++ " " ++ 
+>                               showLine (positionOfQualIdent q2)) calls)
+
+\end{verbatim}
+
+checkParen 
+@param Aufrufende InfixFunktion
+@param ConstrTerm
+@return Liste mit fehlerhaften Funktionsaufrufen
+\begin{verbatim}
+
+> checkParenConstrTerm :: (Maybe QualIdent) -> ConstrTerm -> [(QualIdent,QualIdent)]
+> checkParenConstrTerm _ (LiteralPattern _) = []
+> checkParenConstrTerm _ (NegativePattern _ _) = []
+> checkParenConstrTerm _ (VariablePattern _) = []
+> checkParenConstrTerm _ (ConstructorPattern qualIdent constrTerms) =
+>     concatMap (checkParenConstrTerm Nothing) constrTerms
+> checkParenConstrTerm mCaller (InfixPattern constrTerm1 qualIdent constrTerm2) =
+>     maybe [] (\c -> [(c,qualIdent)]) mCaller ++
+>     checkParenConstrTerm Nothing constrTerm1 ++
+>     checkParenConstrTerm Nothing constrTerm2
+> checkParenConstrTerm _ (ParenPattern constrTerm) =
+>     checkParenConstrTerm Nothing constrTerm
+> checkParenConstrTerm _ (TuplePattern _ constrTerms) =
+>     concatMap (checkParenConstrTerm Nothing) constrTerms
+> checkParenConstrTerm _ (ListPattern _ constrTerms) =
+>     concatMap (checkParenConstrTerm Nothing) constrTerms
+> checkParenConstrTerm mCaller (AsPattern _ constrTerm) =
+>     checkParenConstrTerm mCaller constrTerm
+> checkParenConstrTerm mCaller (LazyPattern _ constrTerm) =
+>     checkParenConstrTerm mCaller constrTerm
+> checkParenConstrTerm _ (FunctionPattern _ constrTerms) =
+>     concatMap (checkParenConstrTerm Nothing) constrTerms
+> checkParenConstrTerm mCaller (InfixFuncPattern constrTerm1 qualIdent constrTerm2) =
+>     maybe [] (\c -> [(c,qualIdent)]) mCaller ++
+>     checkParenConstrTerm Nothing constrTerm1 ++
+>     checkParenConstrTerm Nothing constrTerm2
+> checkParenConstrTerm _ (RecordPattern fieldConstrTerms mConstrTerm) =  
+>     maybe [] (checkParenConstrTerm Nothing) mConstrTerm ++
+>     concatMap (\(Field _ _ constrTerm) -> checkParenConstrTerm Nothing constrTerm) 
+>               fieldConstrTerms
+
+\end{verbatim}
diff --git a/src/SyntaxColoring.hs b/src/SyntaxColoring.hs
new file mode 100644
--- /dev/null
+++ b/src/SyntaxColoring.hs
@@ -0,0 +1,873 @@
+module SyntaxColoring (Program,Code(..),TypeKind(..),ConstructorKind(..),
+                       IdentifierKind(..),FunctionKind(..),filename2program,
+                       code2string,getQualIdent, position2code,
+                       area2codes) where
+
+import Debug.Trace
+
+import Data.Maybe
+import Data.List
+
+import CurryLexer
+import Position
+import Frontend
+import Ident
+import CurrySyntax 
+import Data.Char hiding(Space)
+import Message
+import Control.Exception
+import PathUtils (readModule)
+
+
+debug = False -- mergen von Token und Codes
+
+trace' s x = if debug then trace s x else x
+
+
+debug' = False -- messages
+
+trace'' s x = if debug' then trace s x else x
+
+debug'' = False -- parseResults und codes
+
+trace''' s x = if debug'' then trace s x else x
+
+type Program = [(Int,Int,Code)] 
+
+data Code =  Keyword String
+           | Space Int
+           | NewLine
+           | ConstructorName  ConstructorKind QualIdent
+           | TypeConstructor  TypeKind QualIdent
+           | Function FunctionKind QualIdent
+           | ModuleName ModuleIdent
+           | Commentary String
+           | NumberCode String
+           | StringCode String
+           | CharCode String
+           | Symbol String
+           | Identifier IdentifierKind QualIdent
+           | CodeWarning [Message] Code
+           | CodeError [Message] Code
+           | NotParsed String deriving Show
+           
+data TypeKind = TypeDecla
+              | TypeUse
+              | TypeExport deriving Show          
+
+data ConstructorKind = ConstrPattern
+                     | ConstrCall
+                     | ConstrDecla
+                     | OtherConstrKind deriving Show
+                     
+data IdentifierKind = IdDecl
+                    | IdOccur
+                    | UnknownId  deriving Show         
+                      
+data FunctionKind = InfixFunction
+                  | TypSig
+                  | FunDecl
+                  | FunctionCall
+                  | OtherFunctionKind deriving Show      
+                  
+                  
+                  
+--- @param importpaths
+--- @param filename                  
+--- @return program
+filename2program :: [String] -> String -> IO Program
+filename2program paths filename=
+     readModule filename >>= \ cont ->
+     (catchError show (typingParse paths filename  cont)) >>= \ typingParseResult ->
+     (catchError show (fullParse paths filename  cont)) >>= \ fullParseResult ->             
+     (catchError show (return (parse filename cont))) >>= \ parseResult ->
+     (catchError show (return (Frontend.lex filename cont))) >>= \ lexResult ->    
+     return (genProgram cont (typingParseResult : fullParseResult : [parseResult]) lexResult)    
+                        
+
+     
+        
+--- @param plaintext
+--- @param list with parse-Results with descending quality  e.g. [typingParse,fullParse,parse]                                        
+--- @param lex-Result
+--- @return program
+genProgram :: String -> [Result Module] -> Result [(Position,Token)] -> Program       
+genProgram _ parseResults (Result mess posNtokList) = 
+    let messages = (prepareMessages 
+                      (concatMap getMessages parseResults ++                         
+                       mess))
+        mergedMessages = (mergeMessages' (trace' ("Messages: " ++ show messages) messages) 
+                                      posNtokList)
+        (nameList,codes) = catIdentifiers parseResults in
+    trace''' ("parseResults : " ++ show parseResults ++ "\n\nCodes: " ++ show codes ++ "\n\nToken: " ++ show mergedMessages)
+             (tokenNcodes2codes
+                      nameList
+                      1 
+                      1
+                      mergedMessages 
+                      codes)            
+
+    
+genProgram plainText parseResults (Failure messages) =
+     trace' (unlines (map (\(Message _ _ str) -> str) allMessages)) 
+            (buildMessagesIntoPlainText allMessages plainText)    
+  where
+      allMessages = prepareMessages (concatMap getMessages parseResults ++ 
+                                     messages)   
+     
+
+    
+--- @param Program
+--- @param line
+--- @param col
+--- @return Code at this Position                  
+position2code :: Program -> Int -> Int -> Maybe Code                 
+position2code []  _ _ = Nothing
+position2code [_] _ _ = Nothing
+position2code ((l,c,code):xs@((_,c2,_):_)) line col
+     | line == l && col >= c && col < c2 = Just code
+     | l > line = Nothing
+     | otherwise = position2code xs line col
+     
+area2codes :: Program -> Position -> Position -> [Code]     
+area2codes [] _ _ = []
+area2codes xxs@((l,c,code):xs) p1@Position{file=file} p2 
+     | p1 > p2 = area2codes xxs p2 p1
+     | posEnd >= p1 && posBegin <= p2  = code : area2codes xs p1 p2
+     | posBegin > p2 = []
+     | otherwise = area2codes xs p1 p2
+   where
+      posBegin = Position file l c noRef
+      posEnd   = Position file l (c + (length (code2string code))) noRef
+                  
+
+--- this function intercepts errors and converts it to Messages      
+--- @param a show-function for (Result a)                    
+--- @param a function that generates a (Result a)
+--- @return (Result a) without runtimeerrors   
+catchError :: (Result a -> String) -> IO (Result a) -> IO (Result a)
+catchError toString toDo = Control.Exception.catch (toDo >>= returnComplete toString) handler 
+  where     
+      handler (ErrorCall str) = return (Failure [setMessagePosition (Message Error Nothing str)])
+      handler  e = return (Failure [Message Error Nothing (show e)])       
+             
+      returnComplete :: (a -> String) -> a -> IO a
+      returnComplete toString a = f (toString a) (return a)
+          where
+             f [] r = r
+             f (_:xs) r = f xs r                      
+                  
+--- @param code
+--- @return qualIdent if available                   
+getQualIdent :: Code -> Maybe QualIdent
+getQualIdent (ConstructorName _ qualIdent) = Just qualIdent
+getQualIdent (Function _ qualIdent) = Just qualIdent
+getQualIdent (Identifier _ qualIdent) = Just qualIdent                      
+getQualIdent (TypeConstructor _ qualIdent) = Just qualIdent
+getQualIdent  _ = Nothing                  
+                  
+                    
+-- privates-----------------------------------------------------------------------------------
+
+                  
+codeWithoutPos :: (Int,Int,Code) -> Code
+codeWithoutPos (_,_,c) = c                  
+                  
+-- DEBUGGING----------- wird bald nicht mehr gebraucht
+
+setMessagePosition :: Message -> Message
+setMessagePosition m@(Message _ (Just p) _) = trace'' ("pos:" ++ show p ++ ":" ++ show m) m
+setMessagePosition (Message typ _ m) = 
+        let mes@(Message _ pos _) =  (Message typ (getPositionFromString m) m) in
+        trace'' ("pos:" ++ show pos ++ ":" ++ show mes) mes
+
+getPositionFromString :: String -> Maybe Position
+getPositionFromString message =
+     if line > 0 && col > 0 
+          then Just Position{file=file,line=line,column=col,ast=noRef}
+          else Nothing
+  where
+      file = takeWhile (/= '"') (tail (dropWhile (/= '"') message))
+      line = readInt (takeWhile (/= '.') (drop 7 (dropWhile (/= ',') message)))
+      col = readInt (takeWhile (/= ':') (tail (dropWhile (/= '.') (drop 7 (dropWhile (/= ',') message)))))
+      
+     
+readInt :: String -> Int 
+readInt s = 
+      let onlyNum = filter isDigit s in
+      if null onlyNum
+         then 0
+         else read onlyNum :: Int
+
+-- -------------------------
+
+  
+
+-- -------------------------
+
+
+flatCode :: Code -> Code
+flatCode (CodeWarning _ code) = code
+flatCode (CodeError _ code) = code
+flatCode code = code
+             
+
+                 
+-- ----------Message---------------------------------------                  
+                  
+
+getMessages :: Result a -> [Message]
+getMessages (Result mess _) = mess
+getMessages (Failure mess) = mess
+
+lessMessage :: Message -> Message -> Bool
+lessMessage (Message _ mPos1 _) (Message _ mPos2 _) = mPos1 < mPos2
+
+nubMessages :: [Message] -> [Message] 
+nubMessages = nubBy eqMessage
+
+eqMessage :: Message -> Message -> Bool
+eqMessage (Message f1 p1 s1) (Message f2 p2 s2) = (f1 == f2) && (p1 == p2) && (s1 == s2)
+
+prepareMessages :: [Message] -> [Message]   
+prepareMessages = qsort lessMessage . map setMessagePosition . nubMessages
+
+hasError [] = False
+hasError ((Message Error _ _):ms) = True
+hasError (_:ms) = hasError ms
+
+buildMessagesIntoPlainText :: [Message] -> String -> Program
+buildMessagesIntoPlainText messages text = 
+    buildMessagesIntoPlainText' messages (lines text) [] 1
+ where
+    buildMessagesIntoPlainText' :: [Message] -> [String] -> [String] -> Int -> Program
+    buildMessagesIntoPlainText' _ [] [] _ = 
+          []
+    buildMessagesIntoPlainText' _ [] postStrs line = 
+          [(line,1,NotParsed (unlines postStrs))]    
+    buildMessagesIntoPlainText' [] preStrs postStrs line = 
+          [(line,1,NotParsed (unlines (preStrs ++ postStrs)))]  
+            
+    buildMessagesIntoPlainText' messages (str:preStrs) postStrs ln = 
+          let (pre,post) = partition isLeq messages in
+          if null pre 
+             then buildMessagesIntoPlainText' post preStrs (postStrs ++ [str]) (ln + 1)
+             else (ln,1,NotParsed (unlines postStrs)) : 
+                  (if hasError pre then (ln,1,CodeError pre (NotParsed str)) : [(ln,1,NewLine)] 
+                                   else (ln,1,CodeWarning pre (NotParsed str)) : [(ln,1,NewLine)]) ++
+                  (buildMessagesIntoPlainText' post preStrs [] (ln + 1)) 
+      where 
+         isLeq (Message _ (Just p) _) = line p <= ln 
+         isLeq _ = True
+                
+        
+        
+
+     
+--- @param parse-Modules  [typingParse,fullParse,parse] 
+catIdentifiers :: [Result Module] -> ([(ModuleIdent,ModuleIdent)],[Code])
+catIdentifiers [] = ([],[])
+catIdentifiers [(Failure _)] = ([],[])
+catIdentifiers [(Result _ m@(Module moduleIdent maybeExportSpec decls))] =
+    catIdentifiers' m Nothing
+catIdentifiers ((Failure _):y:ys) = 
+    catIdentifiers (y:ys)     
+catIdentifiers rs@((Result _ m@(Module _ _ _)):y:ys) =  
+    catIdentifiers' (getLastModule (reverse rs)) (Just m)
+  where
+    getLastModule ((Failure _):xs) = getLastModule xs
+    getLastModule ((Result _ m@(Module _ _ _)):_) = m
+    
+--- @param parse-Module
+--- @param Maybe betterParse-Module    
+catIdentifiers' :: Module -> Maybe Module -> ([(ModuleIdent,ModuleIdent)],[Code])
+catIdentifiers' (Module moduleIdent maybeExportSpec decls)
+                Nothing =
+      let codes = (concatMap decl2codes (qsort lessDecl decls)) in
+      (concatMap renamedImports decls,      
+      ([ModuleName moduleIdent] ++
+       (maybe [] exportSpec2codes  maybeExportSpec)  ++
+       codes))     
+catIdentifiers' (Module moduleIdent maybeExportSpec1 _)
+                (Just (Module _ maybeExportSpec2 decls)) =
+      let codes = (concatMap decl2codes (qsort lessDecl decls)) in
+      (concatMap renamedImports decls,
+      replaceFunctionCalls $ 
+        map (addModuleIdent moduleIdent) $
+          ([ModuleName moduleIdent] ++
+           (mergeExports2codes  
+              (maybe [] (\(Exporting _ i) -> i)  maybeExportSpec1)
+              (maybe [] (\(Exporting _ i) -> i)  maybeExportSpec2))  ++
+           codes))     
+  
+     
+renamedImports :: Decl -> [(ModuleIdent,ModuleIdent)]
+renamedImports decl =
+    case decl of
+        (ImportDecl _ oldName _ (Just newName) _) -> [(oldName,newName)]
+        _ -> []
+   
+                      
+replaceFunctionCalls :: [Code] -> [Code]                  
+replaceFunctionCalls codes = map (idOccur2functionCall qualIdents) codes
+   where
+      qualIdents = findFunctionDecls codes
+                                              
+
+findFunctionDecls :: [Code] -> [QualIdent]
+findFunctionDecls  =  mapMaybe getQualIdent . 
+                      filter isFunctionDecl .                       
+                      map flatCode                   
+
+isFunctionDecl  :: Code -> Bool
+isFunctionDecl  (Function FunDecl _)  = True
+isFunctionDecl  _ = False  
+
+idOccur2functionCall :: [QualIdent] -> Code -> Code
+idOccur2functionCall qualIdents ide@(Identifier IdOccur qualIdent)  
+   | isQualified qualIdent = (Function FunctionCall qualIdent)
+   | elem qualIdent qualIdents = (Function FunctionCall qualIdent)
+   | otherwise = ide
+idOccur2functionCall qualIdents (CodeWarning mess code) =
+       (CodeWarning mess (idOccur2functionCall qualIdents code))
+idOccur2functionCall qualIdents (CodeError mess code) =
+       (CodeError mess (idOccur2functionCall qualIdents code))       
+idOccur2functionCall _ code = code
+  
+
+addModuleIdent :: ModuleIdent -> Code -> Code
+addModuleIdent moduleIdent (Function x qualIdent) 
+    | uniqueId (unqualify qualIdent) == 0 =
+        (Function x (qualQualify moduleIdent qualIdent))
+    | otherwise = (Function x qualIdent)   
+addModuleIdent moduleIdent cn@(ConstructorName x qualIdent) 
+    | not $ isQualified qualIdent =
+        (ConstructorName x (qualQualify moduleIdent qualIdent)) 
+    | otherwise = cn       
+addModuleIdent moduleIdent tc@(TypeConstructor TypeDecla qualIdent) 
+    | not $ isQualified qualIdent =
+        (TypeConstructor TypeDecla (qualQualify moduleIdent qualIdent)) 
+    | otherwise = tc         
+addModuleIdent moduleIdent (CodeWarning mess code) =
+      (CodeWarning mess (addModuleIdent moduleIdent code))   
+addModuleIdent moduleIdent (CodeError mess code) =
+      (CodeError mess (addModuleIdent moduleIdent code))       
+addModuleIdent _ c = c
+                        
+-- ----------------------------------------
+
+mergeMessages :: [Message] -> [(Position,Token)] -> [([Message],Position,Token)]
+mergeMessages mess pos = mergeMessages' (prepareMessages mess) pos
+
+
+
+mergeMessages' :: [Message] -> [(Position,Token)] -> [([Message],Position,Token)]
+mergeMessages' _ [] = []
+mergeMessages' [] ((p,t):ps) = ([],p,t) : mergeMessages' [] ps
+mergeMessages' mss@(m@(Message _ mPos x):ms) ((p,t):ps)  
+    | mPos <= Just p = (trace' (show mPos ++ " <= " ++ show (Just p) ++ " Message: " ++ x) ([m],p,t)) : mergeMessages' ms ps 
+    | otherwise = ([],p,t) : mergeMessages' mss ps
+
+
+tokenNcodes2codes :: [(ModuleIdent,ModuleIdent)] -> Int -> Int -> [([Message],Position,Token)] -> [Code] -> [(Int,Int,Code)]
+tokenNcodes2codes _ _ _ [] _ = []          
+tokenNcodes2codes nameList currLine currCol toks@((messages,pos@Position{line=line,column=col},token):ts) codes 
+    | currLine < line = 
+           trace' (" NewLine: ")
+           ((currLine,currCol,NewLine) :
+           tokenNcodes2codes nameList (currLine + 1) 1 toks codes)
+    | currCol < col =  
+           trace' (" Space " ++ show (col - currCol))
+           ((currLine,currCol,Space (col - currCol)) :         
+           tokenNcodes2codes nameList currLine col toks codes)
+    | isTokenIdentifier token && null codes =    
+           trace' ("empty Code-List, Token: " ++ show (line,col) ++ show token)
+           (addMessage [(currLine,currCol,NotParsed tokenStr)] ++ tokenNcodes2codes nameList newLine newCol ts codes)
+    | not (isTokenIdentifier token) = 
+           trace' (" Token ist kein Identifier: " ++ tokenStr ) 
+           (addMessage [(currLine,currCol,token2code token)] ++ tokenNcodes2codes nameList newLine newCol ts codes) 
+    | tokenStr == code2string (head codes) =
+           trace' (" Code wird genommen: " ++ show (head codes) )
+           (addMessage [(currLine,currCol,head codes)] ++ tokenNcodes2codes nameList newLine newCol ts (tail codes)) 
+    | tokenStr == code2qualString (renameModuleIdents nameList (head codes)) =
+           let mIdent = maybe Nothing rename (getModuleIdent (head codes)) 
+               lenMod = maybe 0 (length . moduleName) mIdent
+               startPos = maybe currCol (const (currCol + lenMod + 1)) mIdent
+               symbol = [(currLine,currCol + lenMod,Symbol ".")]               
+               prefix = maybe [] 
+                              ( (: symbol) . 
+                                ( \i -> (currLine,
+                                         currCol,
+                                         ModuleName i))) 
+                              mIdent in
+           trace' (" Code wird genommen: " ++ show (head codes) )
+           (addMessage (prefix ++ [(currCol,startPos,head codes)]) ++ tokenNcodes2codes nameList newLine newCol ts (tail codes))           
+    | elem tokenStr (codeQualifiers (head codes)) =
+           trace' (" Token: "++ tokenStr ++" ist Modulname von: " ++ show (head codes) )
+           (addMessage [(currLine,currCol,ModuleName (mkMIdent [tokenStr]))] ++ 
+                    tokenNcodes2codes nameList newLine newCol ts codes)                  
+    | otherwise = 
+           trace' (" Token: "++ 
+                   tokenStr ++
+                   ",Code faellt weg:" ++ 
+                   code2string (head codes) ++ 
+                   "|" ++ 
+                   code2qualString (head codes))
+           (tokenNcodes2codes nameList currLine currCol toks (tail codes))
+  where
+      tokenStr = token2string token            
+      newLine  = (currLine + length (lines tokenStr)) - 1 
+      newCol   = currCol + length tokenStr   
+
+      rename mid = Just $ maybe mid id (lookup mid nameList)
+
+      addMessage [] = []
+      addMessage ((l,c,code):cs)
+         | null messages = ((l,c,code):cs)
+         | hasError messages = 
+               trace' ("Error bei code: " ++ show codes ++ ":" ++ show messages) 
+                      ((l,c,CodeError messages code): addMessage cs)
+         | otherwise = trace' ("Warning bei code: " ++ show codes ++ ":" ++ show messages) 
+                              ((l,c,CodeWarning messages code): addMessage cs)
+      
+      
+renameModuleIdents :: [(ModuleIdent,ModuleIdent)] -> Code -> Code
+renameModuleIdents nameList c =
+    case c of
+        Function x qualIdent -> Function x (rename qualIdent (splitQualIdent qualIdent))
+        Identifier x qualIdent -> Identifier x (rename qualIdent (splitQualIdent qualIdent))
+        _ -> c
+  where
+    rename x (Nothing,_) = x
+    rename x (Just m,i) = maybe x (\ m' -> qualifyWith m' i) (lookup m nameList)
+           
+{-
+codeWithoutUniqueID ::  Code -> String
+codeWithoutUniqueID code = maybe (code2string code) (name . unqualify) $ getQualIdent code
+     
+
+codeUnqualify :: Code -> Code
+codeUnqualify code = maybe code (setQualIdent code . qualify . unqualify)  $ getQualIdent code  
+-}  
+          
+codeQualifiers :: Code -> [String]
+codeQualifiers = maybe [] moduleQualifiers . getModuleIdent
+
+getModuleIdent :: Code -> Maybe ModuleIdent
+getModuleIdent (ConstructorName _ qualIdent) = fst $ splitQualIdent qualIdent
+getModuleIdent (Function _ qualIdent) = fst $ splitQualIdent qualIdent
+getModuleIdent (ModuleName moduleIdent) = Just moduleIdent
+getModuleIdent (Identifier _ qualIdent) = fst $ splitQualIdent qualIdent                     
+getModuleIdent (TypeConstructor _ qualIdent) = fst $ splitQualIdent qualIdent
+getModuleIdent _ = Nothing
+
+
+  
+{-
+setQualIdent :: Code -> QualIdent -> Code
+setQualIdent (Keyword str) _ = (Keyword str)
+setQualIdent (Space i) _ = (Space i)
+setQualIdent NewLine _ = NewLine
+setQualIdent (ConstructorName kind _) qualIdent = (ConstructorName kind qualIdent)
+setQualIdent (Function kind _) qualIdent = (Function kind qualIdent)
+setQualIdent (ModuleName moduleIdent) _ = (ModuleName moduleIdent)
+setQualIdent (Commentary str) _ = (Commentary str)
+setQualIdent (NumberCode str) _ = (NumberCode str)
+setQualIdent (Symbol str) _ = (Symbol str)
+setQualIdent (Identifier kind _) qualIdent = (Identifier kind qualIdent)                      
+setQualIdent (TypeConstructor kind _) qualIdent = (TypeConstructor kind qualIdent)
+setQualIdent (StringCode str) _ = (StringCode str)                                 
+setQualIdent (CharCode str) _ = (CharCode str)             
+-}
+                  
+code2string (Keyword str) = str
+code2string (Space i)= concat (replicate i " ")
+code2string NewLine = "\n"
+code2string (ConstructorName _ qualIdent) = name $ unqualify qualIdent
+code2string (Function _ qualIdent) = name $ unqualify qualIdent
+code2string (ModuleName moduleIdent) = moduleName moduleIdent
+code2string (Commentary str) = str
+code2string (NumberCode str) = str
+code2string (Symbol str) = str
+code2string (Identifier _ qualIdent) = name $ unqualify qualIdent                      
+code2string (TypeConstructor _ qualIdent) = name $ unqualify qualIdent
+code2string (StringCode str) = str                                 
+code2string (CharCode str) = str
+code2string (NotParsed str) = str
+code2string _ = "" -- error / warning
+ 
+code2qualString (ConstructorName _ qualIdent) = qualName qualIdent
+code2qualString (Function _ qualIdent) = qualName qualIdent
+code2qualString (Identifier _ qualIdent) = qualName qualIdent                      
+code2qualString (TypeConstructor _ qualIdent) = qualName qualIdent
+code2qualString x = code2string x
+
+
+
+token2code :: Token -> Code
+token2code tok@(Token cat _)
+    | elem cat [IntTok,FloatTok,IntegerTok]
+         = NumberCode (token2string tok)
+    | elem cat [KW_case,KW_choice,KW_data,KW_do,KW_else,KW_eval,KW_external,
+                KW_free,KW_if,KW_import,KW_in,KW_infix,KW_infixl,KW_infixr,
+                KW_let,KW_module,KW_newtype,KW_of,KW_rigid,KW_then,KW_type,
+                KW_where,Id_as,Id_ccall,Id_forall,Id_hiding,Id_interface,Id_primitive,
+                Id_qualified]
+         =  Keyword (token2string tok)
+    | elem cat [LeftParen,RightParen,Semicolon,LeftBrace,RightBrace,LeftBracket,
+                RightBracket,Comma,Underscore,Backquote,
+                At,Colon,DotDot,DoubleColon,Equals,Backslash,Bar,LeftArrow,RightArrow,
+                Tilde]
+         = Symbol (token2string tok)
+    | elem cat [LineComment, NestedComment]
+         = Commentary (token2string tok)
+    | isTokenIdentifier tok
+         = Identifier UnknownId $ qualify $ mkIdent $ token2string tok
+    | cat == StringTok 
+         = StringCode (token2string tok)
+    | cat == CharTok
+         = CharCode (token2string tok)          
+    | elem cat [EOF,VSemicolon,VRightBrace] = Space 0 
+    
+isTokenIdentifier :: Token -> Bool
+isTokenIdentifier (Token cat _) = 
+  elem cat [Id,QId,Sym,QSym,Sym_Dot,Sym_Minus,Sym_MinusDot]
+    
+-- DECL Position
+
+getPosition :: Decl -> Position
+getPosition (ImportDecl pos _ _ _ _) = pos     
+getPosition (InfixDecl pos _ _ _) = pos     
+getPosition (DataDecl pos _ _ _) = pos     
+getPosition (NewtypeDecl pos _ _ _) = pos
+getPosition (TypeDecl pos _ _ _) = pos   
+getPosition (TypeSig pos _ _) = pos    
+getPosition (EvalAnnot pos _ _) = pos
+getPosition (FunctionDecl pos _ _) = pos    
+getPosition (ExternalDecl pos _ _ _ _) = pos
+getPosition (FlatExternalDecl pos _) = pos    
+getPosition (PatternDecl pos _ _) = pos    
+getPosition (ExtraVariables pos _) = pos
+             
+
+lessDecl :: Decl -> Decl -> Bool
+lessDecl decl1 decl2 = getPosition decl1 < getPosition decl2
+
+qsort _ []     = []
+qsort less (x:xs) = qsort less [y | y <- xs, less y x] ++ [x] ++ qsort less [y | y <- xs, not $ less y x]
+
+
+
+-- DECL TO CODE -------------------------------------------------------------------- 
+
+
+
+exportSpec2codes ::  ExportSpec -> [Code]
+exportSpec2codes (Exporting _ exports) = concatMap (export2codes [])  exports
+
+--- @param parse-Exports
+--- @param betterParse-Exports
+mergeExports2codes :: [Export] -> [Export]  -> [Code]
+mergeExports2codes [] _ = []
+mergeExports2codes (e:es) xs = concatMap (export2codes xs)  (e:es)
+
+
+export2codes :: [Export] -> Export -> [Code]
+export2codes exports e@(Export qualIdent) 
+    | length (filter checkDouble exports) /= 1 =      
+       [Identifier UnknownId qualIdent]
+    | otherwise =
+       let [export] = (filter checkDouble exports) in
+       export2c export     
+  where    
+    checkDouble (ExportTypeWith q _) = eqQualIdent qualIdent q
+    checkDouble (Export q) = eqQualIdent qualIdent q
+    checkDouble _ = False
+    
+    eqQualIdent q1 q2 
+      | q1 == q2 = True
+      | not (isQualified q1) = unqualify q1 == unqualify q2
+      | otherwise = False
+      
+    export2c (Export qualIdent) = 
+         [Function OtherFunctionKind qualIdent]
+    export2c _ = 
+         [TypeConstructor TypeExport qualIdent]
+         
+    
+    
+       
+export2codes _ (ExportTypeWith qualIdent idents) = 
+     [TypeConstructor TypeExport qualIdent] ++ map (Function OtherFunctionKind . qualify) idents
+export2codes _ (ExportTypeAll  qualIdent) = 
+     [TypeConstructor TypeExport qualIdent]  
+export2codes _ (ExportModule moduleIdent) = 
+     [ModuleName moduleIdent]
+
+decl2codes :: Decl -> [Code]            
+decl2codes (ImportDecl _ moduleIdent xQualified mModuleIdent importSpec) = 
+     [ModuleName moduleIdent] ++
+     maybe [] ((:[]) . ModuleName) mModuleIdent ++
+     maybe [] (importSpec2codes moduleIdent)  importSpec
+decl2codes (InfixDecl _ _ _ idents) =
+     (map (Function InfixFunction . qualify) idents) 
+decl2codes (DataDecl _ ident idents constrDecls) =
+     [TypeConstructor TypeDecla (qualify ident)] ++ 
+     map (Identifier UnknownId . qualify) idents ++
+     concatMap constrDecl2codes constrDecls
+decl2codes (NewtypeDecl xPosition xIdent yIdents xNewConstrDecl) =
+     []
+decl2codes (TypeDecl _ ident idents typeExpr) =
+     TypeConstructor TypeDecla (qualify ident) : 
+     map (Identifier UnknownId . qualify) idents ++ 
+     typeExpr2codes typeExpr
+decl2codes (TypeSig _ idents typeExpr) =
+     map (Function TypSig . qualify) idents ++ typeExpr2codes typeExpr   
+decl2codes (EvalAnnot xPosition idents xEvalAnnotation) =
+     map (Function FunDecl . qualify) idents
+decl2codes (FunctionDecl _ _ equations) =
+     concatMap equation2codes equations  
+decl2codes (ExternalDecl xPosition xCallConv xString xIdent xTypeExpr) =
+     []
+decl2codes (FlatExternalDecl _ idents) =
+     map (Function FunDecl . qualify) idents   
+decl2codes (PatternDecl xPosition constrTerm rhs) =
+     constrTerm2codes constrTerm ++ rhs2codes rhs
+decl2codes (ExtraVariables _ idents) =
+     map (Identifier IdDecl . qualify) idents
+  
+equation2codes :: Equation -> [Code]
+equation2codes (Equation _ lhs rhs) =
+     lhs2codes lhs ++ rhs2codes rhs
+     
+lhs2codes :: Lhs -> [Code]
+lhs2codes (FunLhs ident constrTerms) =
+    (Function FunDecl $ qualify ident) : concatMap constrTerm2codes constrTerms
+lhs2codes (OpLhs constrTerm1 ident constrTerm2) =
+    constrTerm2codes constrTerm1 ++ [Function FunDecl $ qualify ident] ++ constrTerm2codes constrTerm2
+lhs2codes (ApLhs lhs constrTerms) =
+    lhs2codes lhs ++ concatMap constrTerm2codes constrTerms     
+
+rhs2codes :: Rhs -> [Code]
+rhs2codes (SimpleRhs _ expression decls) =
+    expression2codes expression ++ concatMap decl2codes decls
+rhs2codes (GuardedRhs condExprs decls) =
+    concatMap condExpr2codes condExprs ++ concatMap decl2codes decls
+    
+condExpr2codes :: CondExpr -> [Code]
+condExpr2codes (CondExpr _ expression1 expression2) =   
+   expression2codes expression1 ++ expression2codes expression2    
+    
+constrTerm2codes :: ConstrTerm -> [Code]
+constrTerm2codes (LiteralPattern literal) = []
+constrTerm2codes (NegativePattern ident literal) = []
+constrTerm2codes (VariablePattern ident) = [Identifier IdDecl (qualify ident)]
+constrTerm2codes (ConstructorPattern qualIdent constrTerms) =
+    (ConstructorName ConstrPattern qualIdent) : concatMap constrTerm2codes constrTerms
+constrTerm2codes (InfixPattern constrTerm1 qualIdent constrTerm2) =
+    constrTerm2codes constrTerm1 ++ [ConstructorName ConstrPattern qualIdent] ++ constrTerm2codes constrTerm2
+constrTerm2codes (ParenPattern constrTerm) = constrTerm2codes constrTerm
+constrTerm2codes (TuplePattern _ constrTerms) = concatMap constrTerm2codes constrTerms
+constrTerm2codes (ListPattern _ constrTerms) = concatMap constrTerm2codes constrTerms
+constrTerm2codes (AsPattern ident constrTerm) =
+    (Function OtherFunctionKind $ qualify ident) : constrTerm2codes constrTerm
+constrTerm2codes (LazyPattern _ constrTerm) = constrTerm2codes constrTerm
+constrTerm2codes (FunctionPattern qualIdent constrTerms) = 
+    (Function OtherFunctionKind qualIdent) : concatMap constrTerm2codes constrTerms
+constrTerm2codes (InfixFuncPattern constrTerm1 qualIdent constrTerm2) =
+    constrTerm2codes constrTerm1 ++ [Function InfixFunction qualIdent] ++ constrTerm2codes constrTerm2
+   
+expression2codes :: Expression -> [Code]
+expression2codes (Literal literal) = []
+expression2codes (Variable qualIdent) = 
+    [Identifier IdOccur qualIdent]
+expression2codes (Constructor qualIdent) = 
+    [ConstructorName ConstrCall qualIdent]
+expression2codes (Paren expression) = 
+    expression2codes expression
+expression2codes (Typed expression typeExpr) = 
+    expression2codes expression ++ typeExpr2codes typeExpr
+expression2codes (Tuple _ expressions) = 
+    concatMap expression2codes expressions
+expression2codes (List _ expressions) = 
+    concatMap expression2codes expressions
+expression2codes (ListCompr _ expression statements) = 
+    expression2codes expression ++ concatMap statement2codes statements
+expression2codes (EnumFrom expression) = 
+    expression2codes expression
+expression2codes (EnumFromThen expression1 expression2) = 
+    expression2codes expression1 ++ expression2codes expression2
+expression2codes (EnumFromTo expression1 expression2) = 
+    expression2codes expression1 ++ expression2codes expression2
+expression2codes (EnumFromThenTo expression1 expression2 expression3) = 
+    expression2codes expression1 ++ 
+    expression2codes expression2 ++ 
+    expression2codes expression3
+expression2codes (UnaryMinus ident expression) = 
+    [Symbol (name ident)] ++ expression2codes expression 
+expression2codes (Apply expression1 expression2) = 
+    expression2codes expression1 ++ expression2codes expression2
+expression2codes (InfixApply expression1 infixOp expression2) = 
+    expression2codes expression1 ++ infixOp2codes infixOp ++ expression2codes expression2
+expression2codes (LeftSection expression infixOp) = 
+    expression2codes expression ++ infixOp2codes infixOp
+expression2codes (RightSection infixOp expression) = 
+    infixOp2codes infixOp ++ expression2codes expression
+expression2codes (Lambda _ constrTerms expression) = 
+    concatMap constrTerm2codes constrTerms ++ expression2codes expression
+expression2codes (Let decls expression) = 
+    concatMap decl2codes decls ++ expression2codes expression
+expression2codes (Do statements expression) = 
+    concatMap statement2codes statements ++ expression2codes expression
+expression2codes (IfThenElse _ expression1 expression2 expression3) = 
+    expression2codes expression1 ++ expression2codes expression2 ++ expression2codes expression3
+expression2codes (Case _ expression alts) = 
+    expression2codes expression ++ concatMap alt2codes alts
+    
+infixOp2codes :: InfixOp -> [Code]
+infixOp2codes (InfixOp qualIdent) = [Function InfixFunction qualIdent]
+infixOp2codes (InfixConstr qualIdent) = [ConstructorName OtherConstrKind qualIdent]
+
+
+statement2codes :: Statement -> [Code] 
+statement2codes (StmtExpr _ expression) =
+    expression2codes expression
+statement2codes (StmtDecl decls) =
+    concatMap decl2codes decls
+statement2codes (StmtBind _ constrTerm expression) =
+     constrTerm2codes constrTerm ++ expression2codes expression
+
+
+alt2codes :: Alt -> [Code]
+alt2codes (Alt _ constrTerm rhs) =
+    constrTerm2codes constrTerm ++ rhs2codes rhs
+         
+constrDecl2codes :: ConstrDecl -> [Code]
+constrDecl2codes (ConstrDecl _ idents ident typeExprs) =
+    (ConstructorName ConstrDecla $ qualify ident) : concatMap typeExpr2codes typeExprs
+constrDecl2codes (ConOpDecl _ idents typeExpr1 ident typeExpr2) =   
+    typeExpr2codes typeExpr1 ++ [ConstructorName ConstrDecla $ qualify ident] ++ typeExpr2codes typeExpr2
+
+         
+importSpec2codes :: ModuleIdent -> ImportSpec -> [Code]
+importSpec2codes moduleIdent (Importing _ imports) = concatMap (import2codes moduleIdent) imports
+importSpec2codes moduleIdent (Hiding _ imports) = concatMap (import2codes moduleIdent) imports
+
+import2codes :: ModuleIdent -> Import -> [Code]
+import2codes moduleIdent (Import ident) =
+     [Function OtherFunctionKind $ qualifyWith moduleIdent ident]  
+import2codes moduleIdent (ImportTypeWith ident idents) = 
+     [ConstructorName OtherConstrKind $ qualifyWith moduleIdent ident] ++ 
+     map (Function OtherFunctionKind . qualifyWith moduleIdent) idents
+import2codes moduleIdent (ImportTypeAll  ident) = 
+     [ConstructorName OtherConstrKind $ qualifyWith moduleIdent ident]  
+     
+typeExpr2codes :: TypeExpr -> [Code]     
+typeExpr2codes (ConstructorType qualIdent typeExprs) = 
+    (TypeConstructor TypeUse qualIdent) : concatMap typeExpr2codes typeExprs
+typeExpr2codes (VariableType ident) = 
+    [Identifier IdOccur (qualify ident)]
+typeExpr2codes (TupleType typeExprs) = 
+    concatMap typeExpr2codes typeExprs
+typeExpr2codes (ListType typeExpr) = 
+    typeExpr2codes typeExpr
+typeExpr2codes (ArrowType typeExpr1 typeExpr2) = 
+    typeExpr2codes typeExpr1 ++ typeExpr2codes typeExpr2
+
+-- TOKEN TO STRING ------------------------------------------------------------
+
+token2string (Token Id a) = attributes2string a
+token2string (Token QId a) = attributes2string a
+token2string (Token Sym a) = attributes2string a
+token2string (Token QSym a) = attributes2string a
+token2string (Token IntTok a) = attributes2string a
+token2string (Token FloatTok a) = attributes2string a
+token2string (Token CharTok a) = attributes2string a
+token2string (Token IntegerTok a) = attributes2string a
+token2string (Token StringTok a) = attributes2string a
+token2string (Token LeftParen _) = "("
+token2string (Token RightParen _) = ")"
+token2string (Token Semicolon _) = ";"
+token2string (Token LeftBrace _) = "{"
+token2string (Token RightBrace _) = "}"
+token2string (Token LeftBracket _) = "["
+token2string (Token RightBracket _) = "]"
+token2string (Token Comma _) = ","
+token2string (Token Underscore _) = "_"
+token2string (Token Backquote _) = "`"
+token2string (Token VSemicolon _) = ""
+token2string (Token VRightBrace _) = ""
+token2string (Token At _) = "@"
+token2string (Token Colon _) = ":"
+token2string (Token DotDot _) = ".."
+token2string (Token DoubleColon _) = "::"
+token2string (Token Equals _) = "="
+token2string (Token Backslash _) = "\\"
+token2string (Token Bar _) = "|"
+token2string (Token LeftArrow _) = "<-"
+token2string (Token RightArrow _) = "->"
+token2string (Token Tilde _) = "~"
+token2string (Token Sym_Dot _) = "."
+token2string (Token Sym_Minus _) = "-"
+token2string (Token Sym_MinusDot _) = "-."
+token2string (Token KW_case _) = "case"
+token2string (Token KW_choice _) = "choice"
+token2string (Token KW_data _) = "data"
+token2string (Token KW_do _) = "do"
+token2string (Token KW_else _) = "else"
+token2string (Token KW_eval _) = "eval"
+token2string (Token KW_external _) = "external"
+token2string (Token KW_free _) = "free"
+token2string (Token KW_if _) = "if"
+token2string (Token KW_import _) = "import"
+token2string (Token KW_in _) = "in"
+token2string (Token KW_infix _) = "infix"
+token2string (Token KW_infixl _) = "infixl"
+token2string (Token KW_infixr _) = "infixr"
+token2string (Token KW_let _) = "let"
+token2string (Token KW_module _) = "module"
+token2string (Token KW_newtype _) = "newtype"
+token2string (Token KW_of _) = "of"
+token2string (Token KW_rigid _) = "rigid"
+token2string (Token KW_then _) = "then"
+token2string (Token KW_type _) = "type"
+token2string (Token KW_where _) = "where"
+token2string (Token Id_as _) = "as"
+token2string (Token Id_ccall _) = "ccall"
+token2string (Token Id_forall _) = "forall"
+token2string (Token Id_hiding _) = "hiding"
+token2string (Token Id_interface _) = "interface"
+token2string (Token Id_primitive _) = "primitive"
+token2string (Token Id_qualified _) = "qualified"
+token2string (Token EOF _) = ""
+token2string (Token LineComment (StringAttributes sval _)) = sval
+token2string (Token NestedComment (StringAttributes sval _)) = sval
+
+attributes2string NoAttributes = ""
+attributes2string (CharAttributes cval _) = showCh cval 
+attributes2string (IntAttributes ival _) = show ival
+attributes2string (FloatAttributes fval _) = show fval
+attributes2string (IntegerAttributes intval _) = show intval
+attributes2string (StringAttributes sval _) = showSt sval 
+attributes2string (IdentAttributes mIdent ident) =concat (intersperse "." (mIdent ++ [ident])) 
+
+basename = reverse .  takeWhile (/='/')    . reverse
+
+showCh c    
+   | c == '\\' = "'\\\\'"
+   | elem c ('\127' : ['\001' .. '\031']) = show c
+   | otherwise = toString c
+  where
+    toString c = "'" ++ c : "'"
+
+showSt = addQuotes . concatMap toGoodChar 
+   where
+      addQuotes x = "\"" ++ x ++ "\""
+
+toGoodChar c     
+   | c == '\\' = "\\\\"
+   | elem c ('\127' : ['\001' .. '\031']) = justShow c
+   | c == '"' = "\\\""
+   | otherwise = c : "" 
+ where
+     justShow = reverse . tail . reverse . tail . show
diff --git a/src/TopEnv.lhs b/src/TopEnv.lhs
new file mode 100644
--- /dev/null
+++ b/src/TopEnv.lhs
@@ -0,0 +1,146 @@
+
+% $Id: TopEnv.lhs,v 1.20 2003/10/04 17:04:32 wlux Exp $
+%
+% Copyright (c) 1999-2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{TopEnv.lhs}
+\subsection{Top-Level Environments}\label{sec:toplevel-env}
+The module \texttt{TopEnv} implements environments for qualified and
+possibly ambiguous identifiers. An identifier is ambiguous if two
+different entities are imported under the same name or if a local
+definition uses the same name as an imported entity. Following an idea
+presented in \cite{DiatchkiJonesHallgren02:ModuleSystem}, an
+identifier is associated with a list of entities in order to handle
+ambiguous names properly.
+
+In general, two entities are considered equal if the names of their
+original definitions match.  However, in the case of algebraic data
+types it is possible to hide some or all of their data constructors on
+import and export, respectively. In this case we have to merge both
+imports such that all data constructors which are visible through any
+import path are visible in the current module. The class
+\texttt{Entity} is used to handle this merge.
+
+The code in this module ensures that the list of entities returned by
+the functions \texttt{lookupTopEnv} and \texttt{qualLookupTopEnv}
+contains exactly one element for each imported entity regardless of
+how many times and from which module(s) it was imported. Thus, the
+result of these function is a list with exactly one element if and
+only if the identifier is unambiguous. The module names associated
+with an imported entity identify the modules from which the entity was
+imported.
+\begin{verbatim}
+
+> module TopEnv(TopEnv, Entity(..), emptyTopEnv,
+>               predefTopEnv,qualImportTopEnv,importTopEnv,
+>               bindTopEnv,qualBindTopEnv,rebindTopEnv,qualRebindTopEnv,
+>               unbindTopEnv,lookupTopEnv,qualLookupTopEnv,
+>               allImports,moduleImports,localBindings) where
+
+> import Data.Maybe
+
+> import Env
+> import Ident
+> import Utils
+
+> data Source = Local | Import [ModuleIdent] deriving (Eq,Show)
+
+> class Entity a where
+>  origName :: a -> QualIdent
+>  merge    :: a -> a -> Maybe a
+>  merge x y
+>    | origName x == origName y = Just x
+>    | otherwise = Nothing
+
+> newtype TopEnv a = TopEnv (Env QualIdent [(Source,a)]) deriving Show
+
+> instance Functor TopEnv where
+>   fmap f (TopEnv env) = TopEnv (fmap (map (apSnd f)) env)
+
+> entities :: QualIdent -> Env QualIdent [(Source,a)] -> [(Source,a)]
+> entities x env = fromMaybe [] (lookupEnv x env)
+
+> emptyTopEnv :: TopEnv a
+> emptyTopEnv = TopEnv emptyEnv
+
+> predefTopEnv :: Entity a => QualIdent -> a -> TopEnv a -> TopEnv a
+> predefTopEnv x y (TopEnv env) =
+>   case lookupEnv x env of
+>     Just _ -> error "internal error: predefTopEnv"
+>     Nothing -> TopEnv (bindEnv x [(Import [],y)] env)
+
+> importTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a
+> importTopEnv m x y (TopEnv env) =
+>   TopEnv (bindEnv x' (mergeImport m y (entities x' env)) env)
+>   where x' = qualify x
+
+> qualImportTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a
+>                  -> TopEnv a
+> qualImportTopEnv m x y (TopEnv env) =
+>   TopEnv (bindEnv x' (mergeImport m y (entities x' env)) env)
+>   where x' = qualifyWith m x
+
+> mergeImport :: Entity a => ModuleIdent -> a -> [(Source,a)] -> [(Source,a)]
+> mergeImport m x [] = [(Import [m],x)]
+> mergeImport m x ((Local,x') : xs) = (Local,x') : mergeImport m x xs
+> mergeImport m x ((Import ms,x') : xs) =
+>   case merge x x' of
+>     Just x'' -> (Import (m:ms),x'') : xs
+>     Nothing -> (Import ms,x') : mergeImport m x xs
+
+> bindTopEnv :: String -> Ident -> a -> TopEnv a -> TopEnv a
+> bindTopEnv fun x y env = qualBindTopEnv fun (qualify x) y env
+
+> qualBindTopEnv :: String -> QualIdent -> a -> TopEnv a -> TopEnv a
+> qualBindTopEnv fun x y (TopEnv env) =
+>   TopEnv (bindEnv x (bindLocal y (entities x env)) env)
+>   where bindLocal y ys
+>           | null [y' | (Local,y') <- ys] = (Local,y) : ys
+>           | otherwise = error ("internal error: \"qualBindTopEnv " 
+>		                 ++ show x ++ "\" failed in function \""
+>			         ++ fun ++ "\"")
+
+> rebindTopEnv :: Ident -> a -> TopEnv a -> TopEnv a
+> rebindTopEnv = qualRebindTopEnv . qualify
+
+> qualRebindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
+> qualRebindTopEnv x y (TopEnv env) =
+>   TopEnv (bindEnv x (rebindLocal (entities x env)) env)
+>   where rebindLocal [] = error "internal error: qualRebindTopEnv"
+>         rebindLocal ((Local,_) : ys) = (Local,y) : ys
+>         rebindLocal ((Import ms,y) : ys) = (Import ms,y) : rebindLocal ys
+
+> unbindTopEnv :: Ident -> TopEnv a -> TopEnv a
+> unbindTopEnv x (TopEnv env) =
+>   TopEnv (bindEnv x' (unbindLocal (entities x' env)) env)
+>   where x' = qualify x
+>         unbindLocal [] = error "internal error: unbindTopEnv"
+>         unbindLocal ((Local,_) : ys) = ys
+>         unbindLocal ((Import ms,y) : ys) = (Import ms,y) : unbindLocal ys
+
+> lookupTopEnv :: Ident -> TopEnv a -> [a]
+> lookupTopEnv = qualLookupTopEnv . qualify
+
+> qualLookupTopEnv :: QualIdent -> TopEnv a -> [a]
+> qualLookupTopEnv x (TopEnv env) = map snd (entities x env)
+
+> allImports :: TopEnv a -> [(QualIdent,a)]
+> allImports (TopEnv env) =
+>   [(x,y) | (x,ys) <- envToList env, (Import _,y) <- ys]
+
+> unqualBindings :: TopEnv a -> [(Ident,(Source,a))]
+> unqualBindings (TopEnv env) =
+>   [(x',y) | (x,ys) <- takeWhile (not . isQualified . fst) (envToList env),
+>             let x' = unqualify x, y <- ys]
+
+> moduleImports :: ModuleIdent -> TopEnv a -> [(Ident,a)]
+> moduleImports m env =
+>   [(x,y) | (x,(Import ms,y)) <- unqualBindings env, m `elem` ms]
+
+> localBindings :: TopEnv a -> [(Ident,a)]
+> localBindings env = [(x,y) | (x,(Local,y)) <- unqualBindings env]
+
+\end{verbatim}
diff --git a/src/TypeCheck.lhs b/src/TypeCheck.lhs
new file mode 100644
--- /dev/null
+++ b/src/TypeCheck.lhs
@@ -0,0 +1,1346 @@
+
+% $Id: TypeCheck.lhs,v 1.90 2004/11/06 18:34:07 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{TypeCheck.lhs}
+\section{Type Checking Curry Programs}
+This module implements the type checker of the Curry compiler. The
+type checker is invoked after the syntactic correctness of the program
+has been verified. Local variables have been renamed already. Thus the
+compiler can maintain a flat type environment (which is necessary in
+order to pass the type information to later phases of the compiler).
+The type checker now checks the correct typing of all expressions and
+also verifies that the type signatures given by the user match the
+inferred types. The type checker uses algorithm
+W~\cite{DamasMilner82:Principal} for inferring the types of
+unannotated declarations, but allows for polymorphic recursion when a
+type annotation is present.
+\begin{verbatim}
+
+> module TypeCheck(typeCheck,typeCheckGoal) where
+
+> import Control.Monad
+> import Data.List
+> import Data.Maybe
+
+> import Base
+> import Pretty
+> import Ident
+> import CurryPP
+> import Env
+> import TopEnv
+> import Set
+> import Combined
+> import SCC
+> import TypeSubst
+> import Utils
+
+> infixl 5 $-$
+
+> ($-$) :: Doc -> Doc -> Doc
+> x $-$ y = x $$ space $$ y
+
+\end{verbatim}
+Type checking proceeds as follows. First, the type constructor
+environment is initialized by adding all types defined in the current
+module. Next, the types of all data constructors and field labels
+are entered into the type environment and then a type inference 
+for all function and value definitions is performed. 
+The type checker returns the resulting type
+constructor and type environments.
+\begin{verbatim}
+
+> typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv,ValueEnv)
+> typeCheck m tcEnv tyEnv ds =
+>   run (tcDecls m tcEnv' emptyEnv vds >>
+>        liftSt fetchSt >>= \theta -> fetchSt >>= \tyEnv' ->
+>        return (tcEnv',subst theta tyEnv'))
+>       (bindLabels m tcEnv' (bindConstrs m tcEnv' tyEnv))
+>   where (tds,vds) = partition isTypeDecl ds
+>         tcEnv' = bindTypes m tds tcEnv
+
+\end{verbatim}
+Type checking of a goal expression is simpler because the type
+constructor environment is fixed already and there are no
+type declarations in a goal.
+\begin{verbatim}
+
+> typeCheckGoal :: TCEnv -> ValueEnv -> Goal -> ValueEnv
+> typeCheckGoal tcEnv tyEnv (Goal p e ds) =
+>    run (tcRhs m0 tcEnv tyEnv emptyEnv (SimpleRhs p e ds) >>
+>         liftSt fetchSt >>= \theta -> fetchSt >>= \tyEnv' ->
+>         return (subst theta tyEnv')) tyEnv
+>   where m0 = mkMIdent []
+
+\end{verbatim}
+The type checker makes use of nested state monads in order to
+maintain the type environment, the current substitution, and a counter
+which is used for generating fresh type variables.
+\begin{verbatim}
+
+> type TcState a = StateT ValueEnv (StateT TypeSubst (StateT Int Id)) a
+
+> run :: TcState a -> ValueEnv -> a
+> run m tyEnv = runSt (callSt (callSt m tyEnv) idSubst) 0
+
+\end{verbatim}
+\paragraph{Defining Types}
+Before type checking starts, the types defined in the local module
+have to be entered into the type constructor environment. All type
+synonyms occurring in the definitions are fully expanded and all type
+constructors are qualified with the name of the module in which they
+are defined. This is possible because Curry does not allow (mutually)
+recursive type synonyms. In order to simplify the expansion of type
+synonyms, the compiler first performs a dependency analysis on the
+type definitions. This also makes it easy to identify (mutually)
+recursive synonyms.
+
+Note that \texttt{bindTC} is passed the \emph{final} type constructor
+environment in order to handle the expansion of type synonyms. This
+does not lead to a termination problem because \texttt{sortTypeDecls}
+already has checked that there are no recursive type synonyms.
+
+We have to be careful with existentially quantified type variables for
+data constructors. An existentially quantified type variable may
+shadow a universally quantified variable from the left hand side of
+the type declaration. In order to avoid wrong indices being assigned
+to these variables, we replace all shadowed variables in the left hand
+side by \texttt{anonId} before passing them to \texttt{expandMonoType}
+and \texttt{expandMonoTypes}, respectively.
+\begin{verbatim}
+
+> bindTypes :: ModuleIdent -> [Decl] -> TCEnv -> TCEnv
+> bindTypes m ds tcEnv = tcEnv'
+>   where tcEnv' = foldr (bindTC m tcEnv') tcEnv (sortTypeDecls m ds)
+
+> bindTC :: ModuleIdent -> TCEnv -> Decl -> TCEnv -> TCEnv
+> bindTC m tcEnv (DataDecl _ tc tvs cs) =
+>   bindTypeInfo DataType m tc tvs (map (Just . mkData) cs)
+>   where mkData (ConstrDecl _ evs c tys) = Data c (length evs) tys'
+>           where tys' = expandMonoTypes m tcEnv (cleanTVars tvs evs) tys
+>         mkData (ConOpDecl _ evs ty1 op ty2) = Data op (length evs) tys'
+>           where tys' = expandMonoTypes m tcEnv (cleanTVars tvs evs) [ty1,ty2]
+> bindTC m tcEnv (NewtypeDecl _ tc tvs (NewConstrDecl _ evs c ty)) =
+>   bindTypeInfo RenamingType m tc tvs (Data c (length evs) ty')
+>   where ty' = expandMonoType m tcEnv (cleanTVars tvs evs) ty
+> bindTC m tcEnv (TypeDecl _ tc tvs ty) =
+>   bindTypeInfo AliasType m tc tvs (expandMonoType m tcEnv tvs ty)
+> bindTC _ _ _ = id
+
+> cleanTVars :: [Ident] -> [Ident] -> [Ident]
+> cleanTVars tvs evs = [if tv `elem` evs then anonId else tv | tv <- tvs]
+
+> sortTypeDecls :: ModuleIdent -> [Decl] -> [Decl]
+> sortTypeDecls m = map (typeDecl m) . scc bound free
+>   where bound (DataDecl _ tc _ _) = [tc]
+>         bound (NewtypeDecl _ tc _ _) = [tc]
+>         bound (TypeDecl _ tc _ _) = [tc]
+>         free (DataDecl _ _ _ _) = []
+>         free (NewtypeDecl _ _ _ _) = []
+>         free (TypeDecl _ _ _ ty) = ft m ty []
+
+> typeDecl :: ModuleIdent -> [Decl] -> Decl
+> typeDecl _ [] = internalError "typeDecl"
+> typeDecl _ [d@(DataDecl _ _ _ _)] = d
+> typeDecl _ [d@(NewtypeDecl _ _ _ _)] = d
+> typeDecl m [d@(TypeDecl p tc _ ty)]
+>   | tc `elem` ft m ty [] = errorAt' (recursiveTypes [tc])
+>   | otherwise = d
+> typeDecl _ (TypeDecl p tc _ _ : ds) =
+>   errorAt' (recursiveTypes (tc : [tc' | TypeDecl _ tc' _ _ <- ds]))
+
+> ft :: ModuleIdent -> TypeExpr -> [Ident] -> [Ident]
+> ft m (ConstructorType tc tys) tcs =
+>   maybe id (:) (localIdent m tc) (foldr (ft m) tcs tys)
+> ft _ (VariableType _) tcs = tcs
+> ft m (TupleType tys) tcs = foldr (ft m) tcs tys
+> ft m (ListType ty) tcs = ft m ty tcs
+> ft m (ArrowType ty1 ty2) tcs = ft m ty1 $ ft m ty2 $ tcs
+> ft m (RecordType fs rty) tcs = 
+>   foldr (ft m) (maybe tcs (\ty -> ft m ty tcs) rty) (map snd fs)
+
+\end{verbatim}
+\paragraph{Defining Data Constructors}
+In the next step, the types of all data constructors are entered into
+the type environment using the information just entered into the type
+constructor environment. Thus, we can be sure that all type variables
+have been properly renamed and all type synonyms are already expanded.
+\begin{verbatim}
+
+> bindConstrs :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
+> bindConstrs m tcEnv tyEnv =
+>   foldr (bindData . snd) tyEnv (localBindings tcEnv)
+>   where bindData (DataType tc n cs) tyEnv =
+>           foldr (bindConstr m n (constrType tc n)) tyEnv (catMaybes cs)
+>         bindData (RenamingType tc n (Data c n' ty)) tyEnv =
+>           bindGlobalInfo NewtypeConstructor m c
+>                          (ForAllExist n n' (TypeArrow ty (constrType tc n)))
+>                          tyEnv
+>         bindData (AliasType _ _ _) tyEnv = tyEnv
+>         bindConstr m n ty (Data c n' tys) =
+>           bindGlobalInfo DataConstructor m c
+>                          (ForAllExist n n' (foldr TypeArrow ty tys))
+>         constrType tc n = TypeConstructor tc (map TypeVariable [0..n-1])
+
+\end{verbatim}
+\paragraph{Defining Field Labels}
+Records can only be declared as type aliases. So currently there is
+nothing more to do than entering all typed record fields (labels) 
+which occur in record types on the right-hand-side of type aliases 
+into the type environment. Since we use the type constructor environment
+again, we can be sure that all type variables
+have been properly renamed and all type synonyms are already expanded.
+\begin{verbatim}
+
+> bindLabels :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
+> bindLabels m tcEnv tyEnv =
+>   foldr (bindFieldLabels . snd) tyEnv (localBindings tcEnv)
+>   where bindFieldLabels (AliasType r _ (TypeRecord fs _)) tyEnv =
+>           foldr (bindField r) tyEnv fs
+>	  bindFieldLabels _ tyEnv = tyEnv
+>	  
+>         bindField r (l,ty) tyEnv =
+>           case (lookupValue l tyEnv) of
+>             [] -> bindLabel l r (polyType ty) tyEnv 
+>             _  -> tyEnv
+
+\end{verbatim}
+\paragraph{Type Signatures}
+The type checker collects type signatures in a flat environment. All
+anonymous variables occurring in a signature are replaced by fresh
+names. However, the type is not expanded so that the signature is
+available for use in the error message that is printed when the
+inferred type is less general than the signature.
+\begin{verbatim}
+
+> type SigEnv = Env Ident TypeExpr
+
+> bindTypeSig :: Ident -> TypeExpr -> SigEnv -> SigEnv
+> bindTypeSig = bindEnv
+
+> bindTypeSigs :: Decl -> SigEnv -> SigEnv
+> bindTypeSigs (TypeSig _ vs ty) env =
+>   foldr (flip bindTypeSig (nameSigType ty)) env vs 
+> bindTypeSigs _ env = env
+
+> lookupTypeSig :: Ident -> SigEnv -> Maybe TypeExpr
+> lookupTypeSig = lookupEnv
+
+> qualLookupTypeSig :: ModuleIdent -> QualIdent -> SigEnv -> Maybe TypeExpr
+> qualLookupTypeSig m f sigs = localIdent m f >>= flip lookupTypeSig sigs
+
+> nameSigType :: TypeExpr -> TypeExpr
+> nameSigType ty = fst (nameType ty (filter (`notElem` fv ty) nameSupply))
+
+> nameTypes :: [TypeExpr] -> [Ident] -> ([TypeExpr],[Ident])
+> nameTypes (ty:tys) tvs = (ty':tys',tvs'')
+>   where (ty',tvs') = nameType ty tvs
+>         (tys',tvs'') = nameTypes tys tvs'
+> nameTypes [] tvs = ([],tvs)
+
+> nameType :: TypeExpr -> [Ident] -> (TypeExpr,[Ident])
+> nameType (ConstructorType tc tys) tvs = (ConstructorType tc tys',tvs')
+>   where (tys',tvs') = nameTypes tys tvs
+> nameType (VariableType tv) (tv':tvs)
+>   | tv == anonId = (VariableType tv',tvs)
+>   | otherwise = (VariableType tv,tv':tvs)
+> nameType (TupleType tys) tvs = (TupleType tys',tvs')
+>   where (tys',tvs') = nameTypes tys tvs
+> nameType (ListType ty) tvs = (ListType ty',tvs')
+>   where (ty',tvs') = nameType ty tvs
+> nameType (ArrowType ty1 ty2) tvs = (ArrowType ty1' ty2',tvs'')
+>   where (ty1',tvs') = nameType ty1 tvs
+>         (ty2',tvs'') = nameType ty2 tvs'
+> nameType (RecordType fs rty) tvs = 
+>   (RecordType (zip ls tys') (listToMaybe rty'), tvs)
+>   where (ls, tys) = unzip fs
+>         (tys', tvs') = nameTypes tys tvs
+>         (rty', tvs'') = nameTypes (maybeToList rty) tvs
+        
+\end{verbatim}
+\paragraph{Type Inference}
+Before type checking a group of declarations, a dependency analysis is
+performed and the declaration group is eventually transformed into
+nested declaration groups which are checked separately. Within each
+declaration group, first the left hand sides of all declarations are
+typed. Next, the right hand sides of the declarations are typed in the
+extended type environment. Finally, the types for the left and right
+hand sides are unified and the types of all defined functions are
+generalized. The generalization step will also check that the type
+signatures given by the user match the inferred types.
+
+Argument and result types of foreign functions using the
+\texttt{ccall} calling convention are restricted to the basic types
+\texttt{Bool}, \texttt{Char}, \texttt{Int}, and \texttt{Float}. In
+addition, \texttt{IO}~$t$ is a legitimate result type when $t$ is
+either one of the basic types or \texttt{()}.
+
+\ToDo{Extend the set of legitimate types to match the types admitted
+  by the Haskell Foreign Function Interface
+  Addendum.~\cite{Chakravarty03:FFI}}
+\begin{verbatim}
+
+> tcDecls :: ModuleIdent -> TCEnv -> SigEnv -> [Decl] -> TcState ()
+> tcDecls m tcEnv sigs ds =
+>   mapM_ (tcDeclGroup m tcEnv (foldr bindTypeSigs sigs ods))
+>         (scc bv (qfv m) vds)
+>   where (vds,ods) = partition isValueDecl ds
+
+> tcDeclGroup :: ModuleIdent -> TCEnv -> SigEnv -> [Decl] -> TcState ()
+> --tcDeclGroup m tcEnv _ [ForeignDecl p cc _ f ty] =
+> --  tcForeignFunct m tcEnv p cc f ty
+> tcDeclGroup m tcEnv _ [ExternalDecl _ _ _ f ty] =
+>   tcExternalFunct m tcEnv f ty
+> tcDeclGroup m tcEnv sigs [FlatExternalDecl _ fs] =
+>   mapM_ (tcFlatExternalFunct m tcEnv sigs) fs
+> tcDeclGroup m tcEnv sigs [ExtraVariables _ vs] =
+>   mapM_ (tcExtraVar m tcEnv sigs ) vs
+> tcDeclGroup m tcEnv sigs ds =
+>   do
+>     tyEnv0 <- fetchSt
+>     tysLhs <- mapM (tcDeclLhs m tcEnv sigs) ds
+>     tysRhs <- mapM (tcDeclRhs m tcEnv tyEnv0 sigs) ds
+>     sequence_ (zipWith3 (unifyDecl m) ds tysLhs tysRhs)
+>     theta <- liftSt fetchSt
+>     mapM_ (genDecl m tcEnv sigs (fvEnv (subst theta tyEnv0)) theta) ds
+
+> --tcForeignFunct :: ModuleIdent -> TCEnv -> Position -> CallConv -> Ident
+> --               -> TypeExpr -> TcState ()
+> --tcForeignFunct m tcEnv p cc f ty =
+> --  updateSt_ (bindFun m f (checkForeignType cc (expandPolyType tcEnv ty)))
+> --  where checkForeignType CallConvPrimitive ty = ty
+> --        checkForeignType CallConvCCall (ForAll n ty) =
+> --          ForAll n (checkCCallType ty)
+> --        checkCCallType (TypeArrow ty1 ty2)
+> --          | isCArgType ty1 = TypeArrow ty1 (checkCCallType ty2)
+> --          | otherwise = errorAt p (invalidCType "argument" m ty1)
+> --        checkCCallType ty
+> --          | isCResultType ty = ty
+> --          | otherwise = errorAt p (invalidCType "result" m ty)
+> --        isCArgType (TypeConstructor tc []) = tc `elem` basicTypeId
+> --        isCArgType _ = False
+> --        isCResultType (TypeConstructor tc []) = tc `elem` basicTypeId
+> --        isCResultType (TypeConstructor tc [ty]) =
+> --          tc == qIOId && (ty == unitType || isCArgType ty)
+> --        isCResultType _ = False
+> --        basicTypeId = [qBoolId,qCharId,qIntId,qFloatId]
+
+> tcExternalFunct :: ModuleIdent -> TCEnv -> Ident -> TypeExpr -> TcState ()
+> tcExternalFunct m tcEnv  f ty =
+>   updateSt_ (bindFun m f (expandPolyType m tcEnv ty))
+
+> tcFlatExternalFunct :: ModuleIdent -> TCEnv -> SigEnv -> Ident -> TcState ()
+> tcFlatExternalFunct m tcEnv sigs f =
+>   typeOf f tcEnv sigs >>= updateSt_ . bindFun m f
+>   where typeOf f tcEnv sigs =
+>           case lookupTypeSig f sigs of
+>             Just ty -> return (expandPolyType m tcEnv ty)
+>             Nothing -> internalError "tcFlatExternalFunct"
+
+> tcExtraVar :: ModuleIdent -> TCEnv -> SigEnv -> Ident
+>            -> TcState ()
+> tcExtraVar m tcEnv sigs v =
+>   typeOf v tcEnv sigs >>= updateSt_ . bindFun m v . monoType
+>   where typeOf v tcEnv sigs =
+>           case lookupTypeSig v sigs of
+>             Just ty
+>               | n == 0 -> return ty'
+>               | otherwise -> errorAt' (polymorphicFreeVar v)
+>               where ForAll n ty' = expandPolyType m tcEnv ty
+>             Nothing -> freshTypeVar
+
+> tcDeclLhs :: ModuleIdent -> TCEnv -> SigEnv -> Decl -> TcState Type
+> tcDeclLhs m tcEnv sigs (FunctionDecl p f _) =
+>   tcConstrTerm m tcEnv sigs p (VariablePattern f)
+> tcDeclLhs m tcEnv sigs (PatternDecl p t _) = tcConstrTerm m tcEnv sigs p t
+
+> tcDeclRhs :: ModuleIdent -> TCEnv -> ValueEnv -> SigEnv -> Decl
+>           -> TcState Type
+> tcDeclRhs m tcEnv tyEnv0 sigs (FunctionDecl _ f (eq:eqs)) =
+>   tcEquation m tcEnv tyEnv0 sigs eq >>= flip tcEqns eqs
+>   where tcEqns ty [] = return ty
+>         tcEqns ty (eq@(Equation p _ _):eqs) =
+>           tcEquation m tcEnv tyEnv0 sigs eq >>=
+>           unify p "equation" (ppDecl (FunctionDecl p f [eq])) m ty >>
+>           tcEqns ty eqs
+> tcDeclRhs m tcEnv tyEnv0 sigs (PatternDecl _ _ rhs) =
+>   tcRhs m tcEnv tyEnv0 sigs rhs
+
+> unifyDecl :: ModuleIdent -> Decl -> Type -> Type -> TcState ()
+> unifyDecl m (FunctionDecl p f _) =
+>   unify p "function binding" (text "Function:" <+> ppIdent f) m
+> unifyDecl m (PatternDecl p t _) =
+>   unify p "pattern binding" (ppConstrTerm 0 t) m
+
+\end{verbatim}
+In Curry we cannot generalize the types of let-bound variables because
+they can refer to logic variables. Without this monomorphism
+restriction unsound code like
+\begin{verbatim}
+bug = x =:= 1 & x =:= 'a'
+  where x :: a
+        x = fresh
+fresh :: a
+fresh = x where x free
+\end{verbatim}
+could be written. Note that \texttt{fresh} has the polymorphic type
+$\forall\alpha.\alpha$. This is correct because \texttt{fresh} is a
+function and therefore returns a different variable at each
+invocation.
+
+The code in \texttt{genVar} below also verifies that the inferred type
+for a variable or function matches the type declared in a type
+signature. As the declared type is already used for assigning an initial
+type to a variable when it is used, the inferred type can only be more
+specific. Therefore, if the inferred type does not match the type
+signature the declared type must be too general.
+\begin{verbatim}
+
+> genDecl :: ModuleIdent -> TCEnv -> SigEnv -> Set Int -> TypeSubst -> Decl
+>         -> TcState ()
+> genDecl m tcEnv sigs lvs theta (FunctionDecl _ f _) =
+>   updateSt_ (genVar True m tcEnv sigs lvs theta f)
+> genDecl m tcEnv sigs lvs theta (PatternDecl p t _) =
+>   mapM_ (updateSt_ . genVar False m tcEnv sigs lvs theta ) (bv t)
+
+> genVar :: Bool -> ModuleIdent -> TCEnv -> SigEnv -> Set Int -> TypeSubst
+>        -> Ident -> ValueEnv -> ValueEnv
+> genVar poly m tcEnv sigs lvs theta v tyEnv =
+>   case lookupTypeSig v sigs of
+>     Just sigTy
+>       | cmpTypes sigma (expandPolyType m tcEnv sigTy) -> tyEnv'
+>       | otherwise -> errorAt (positionOfIdent v) 
+>                              (typeSigTooGeneral m what sigTy sigma)
+>     Nothing -> tyEnv'
+>   where what = text (if poly then "Function:" else "Variable:") <+> ppIdent v
+>         tyEnv' = rebindFun m v sigma tyEnv
+>         sigma = genType poly (subst theta (varType v tyEnv))
+>         genType poly (ForAll n ty)
+>           | n > 0 = internalError ("genVar: " ++ showLine (positionOfIdent v) ++ 
+>                                    show v ++ " :: " ++ show ty)
+>           | poly = gen lvs ty
+>           | otherwise = monoType ty
+>         cmpTypes (ForAll _ t1) (ForAll _ t2) = equTypes t1 t2
+
+> tcEquation :: ModuleIdent -> TCEnv -> ValueEnv -> SigEnv -> Equation
+>            -> TcState Type
+> tcEquation m tcEnv tyEnv0 sigs (Equation p lhs rhs) =
+>   do
+>     tys <- mapM (tcConstrTerm m tcEnv sigs p) ts
+>     ty <- tcRhs m tcEnv tyEnv0 sigs rhs
+>     checkSkolems p m (text "Function: " <+> ppIdent f) tyEnv0
+>                  (foldr TypeArrow ty tys)
+>   where (f,ts) = flatLhs lhs
+
+> tcLiteral :: ModuleIdent -> Literal -> TcState Type
+> tcLiteral _ (Char _ _) = return charType
+> tcLiteral m (Int v _)  = --return intType
+>   do
+>     ty <- freshConstrained [intType,floatType]
+>     updateSt_ (bindFun m v (monoType ty))
+>     return ty
+> tcLiteral _ (Float _ _) = return floatType
+> tcLiteral _ (String _ _) = return stringType
+
+> tcConstrTerm :: ModuleIdent -> TCEnv -> SigEnv -> Position -> ConstrTerm
+>              -> TcState Type
+> tcConstrTerm m tcEnv sigs _ (LiteralPattern l) = tcLiteral m l
+> tcConstrTerm m tcEnv sigs _ (NegativePattern _ l) = tcLiteral m l
+> tcConstrTerm m tcEnv sigs _ (VariablePattern v) =
+>   do 
+>     ty <- case lookupTypeSig v sigs of
+>             Just t -> inst (expandPolyType m tcEnv t)
+>             Nothing -> freshTypeVar
+>     updateSt_ (bindFun m v (monoType ty))
+>     return ty
+>   
+> tcConstrTerm m tcEnv sigs p t@(ConstructorPattern c ts) =
+>   do
+>     tyEnv <- fetchSt
+>     ty <- skol (constrType m c tyEnv)
+>     unifyArgs (ppConstrTerm 0 t) ts ty
+>   where unifyArgs _ [] ty = return ty
+>         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =
+>           tcConstrTerm m tcEnv sigs p t >>=
+>           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>                 m ty1 >>
+>           unifyArgs doc ts ty2
+>         unifyArgs _ _ _ = internalError "tcConstrTerm"
+> tcConstrTerm m tcEnv sigs p t@(InfixPattern t1 op t2) =
+>   do
+>     tyEnv <- fetchSt
+>     ty <- skol (constrType m op tyEnv)
+>     unifyArgs (ppConstrTerm 0 t) [t1,t2] ty
+>   where unifyArgs _ [] ty = return ty
+>         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =
+>           tcConstrTerm m tcEnv sigs p t >>=
+>           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>                 m ty1 >>
+>           unifyArgs doc ts ty2
+>         unifyArgs _ _ _ = internalError "tcConstrTerm"
+> tcConstrTerm m tcEnv sigs p (ParenPattern t) = tcConstrTerm m tcEnv sigs p t
+> tcConstrTerm m tcEnv sigs p (TuplePattern _ ts)
+>  | null ts = return unitType
+>  | otherwise = liftM tupleType $ mapM (tcConstrTerm m tcEnv sigs p) ts   -- $
+> tcConstrTerm m tcEnv sigs p t@(ListPattern _ ts) =
+>   freshTypeVar >>= flip (tcElems (ppConstrTerm 0 t)) ts
+>   where tcElems _ ty [] = return (listType ty)
+>         tcElems doc ty (t:ts) =
+>           tcConstrTerm m tcEnv sigs p t >>=
+>           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>                 m ty >>
+>           tcElems doc ty ts
+> tcConstrTerm m tcEnv sigs p t@(AsPattern v t') =
+>   do
+>     ty1 <- tcConstrTerm m tcEnv sigs p (VariablePattern v)
+>     ty2 <- tcConstrTerm m tcEnv sigs p t'
+>     unify p "pattern" (ppConstrTerm 0 t) m ty1 ty2
+>     return ty1
+> tcConstrTerm m tcEnv sigs p (LazyPattern _ t) = tcConstrTerm m tcEnv sigs p t
+> tcConstrTerm m tcEnv sigs p t@(FunctionPattern f ts) =
+>   do
+>     tyEnv <- fetchSt
+>     ty <- inst (funType m f tyEnv) --skol (constrType m c tyEnv)
+>     unifyArgs (ppConstrTerm 0 t) ts ty
+>   where unifyArgs _ [] ty = return ty
+>         unifyArgs doc (t:ts) ty@(TypeVariable _) =
+>           do (alpha,beta) <- tcArrow p "function pattern" doc m ty
+>	       ty' <- tcConstrTermFP m tcEnv sigs p t
+>	       unify p "function pattern"
+>	             (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>	             m ty' alpha
+>	       unifyArgs doc ts beta
+>         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =
+>           tcConstrTermFP m tcEnv sigs p t >>=
+>           unify p "function pattern" 
+>	          (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>                 m ty1 >>
+>           unifyArgs doc ts ty2
+>         unifyArgs _ _ ty = internalError ("tcConstrTerm: " ++ show ty)
+> tcConstrTerm m tcEnv sigs p t@(InfixFuncPattern t1 op t2) =
+>   tcConstrTerm m tcEnv sigs p (FunctionPattern op [t1,t2])
+> tcConstrTerm m tcEnv sigs p r@(RecordPattern fs rt)
+>   | isJust rt =
+>     do
+>       ty <- tcConstrTerm m tcEnv sigs p (fromJust rt)
+>       fts <- mapM (tcFieldPatt (tcConstrTerm m tcEnv sigs) m) fs
+>       alpha <- freshVar id
+>	let rty = TypeRecord fts (Just alpha)
+>	unify p "record pattern" (ppConstrTerm 0 r) m ty rty
+>       return rty
+>   | otherwise =
+>     do
+>       fts <- mapM (tcFieldPatt (tcConstrTerm m tcEnv sigs) m) fs
+>       return (TypeRecord fts Nothing)
+
+\end{verbatim}
+In contrast to usual patterns, the type checking routine for arguments of 
+function patterns \texttt{tcConstrTermFP} differs from \texttt{tcConstrTerm}
+because of possibly multiple occurrences of variables.
+\begin{verbatim}
+
+> tcConstrTermFP :: ModuleIdent -> TCEnv -> SigEnv -> Position -> ConstrTerm
+>                   -> TcState Type
+> tcConstrTermFP m tcEnv sigs p (LiteralPattern l) = tcLiteral m l
+> tcConstrTermFP m tcEnv sigs p (NegativePattern _ l) = tcLiteral m l
+> tcConstrTermFP m tcEnv sigs p (VariablePattern v) =
+>   do
+>     ty <- maybe freshTypeVar 
+>                 (inst . expandPolyType m tcEnv) 
+>                 (lookupTypeSig v sigs)
+>     tyEnv <- fetchSt
+>     ty' <- maybe (updateSt_ (bindFun m v (monoType ty)) >> return ty)
+>                  (\ (ForAll _ t) -> return t)
+>	           (sureVarType v tyEnv)
+>     return ty' 
+> tcConstrTermFP m tcEnv sigs p t@(ConstructorPattern c ts) =
+>   do
+>     tyEnv <- fetchSt
+>     ty <- skol (constrType m c tyEnv)
+>     unifyArgs (ppConstrTerm 0 t) ts ty
+>   where unifyArgs _ [] ty = return ty
+>         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =
+>           tcConstrTermFP m tcEnv sigs p t >>=
+>           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>                 m ty1 >>
+>           unifyArgs doc ts ty2
+>         unifyArgs _ _ _ = internalError "tcConstrTermFP"
+> tcConstrTermFP m tcEnv sigs p t@(InfixPattern t1 op t2) =
+>   do
+>     tyEnv <- fetchSt
+>     ty <- skol (constrType m op tyEnv)
+>     unifyArgs (ppConstrTerm 0 t) [t1,t2] ty
+>   where unifyArgs _ [] ty = return ty
+>         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =
+>           tcConstrTermFP m tcEnv sigs p t >>=
+>           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>                 m ty1 >>
+>           unifyArgs doc ts ty2
+>         unifyArgs _ _ _ = internalError "tcConstrTermFP"
+> tcConstrTermFP m tcEnv sigs p (ParenPattern t) = tcConstrTermFP m tcEnv sigs p t
+> tcConstrTermFP m tcEnv sigs p (TuplePattern _ ts)
+>  | null ts = return unitType
+>  | otherwise = liftM tupleType $ mapM (tcConstrTermFP m tcEnv sigs p) ts   -- $
+> tcConstrTermFP m tcEnv sigs p t@(ListPattern _ ts) =
+>   freshTypeVar >>= flip (tcElems (ppConstrTerm 0 t)) ts
+>   where tcElems _ ty [] = return (listType ty)
+>         tcElems doc ty (t:ts) =
+>           tcConstrTermFP m tcEnv sigs p t >>=
+>           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>                 m ty >>
+>           tcElems doc ty ts
+> tcConstrTermFP m tcEnv sigs p t@(AsPattern v t') =
+>   do
+>     ty1 <- tcConstrTermFP m tcEnv sigs p (VariablePattern v)
+>     ty2 <- tcConstrTermFP m tcEnv sigs p t'
+>     unify p "pattern" (ppConstrTerm 0 t) m ty1 ty2
+>     return ty1
+> tcConstrTermFP m tcEnv sigs p (LazyPattern _ t) = tcConstrTermFP m tcEnv sigs p t
+> tcConstrTermFP m tcEnv sigs p t@(FunctionPattern f ts) =
+>   do
+>     tyEnv <- fetchSt
+>     ty <- inst (funType m f tyEnv) --skol (constrType m c tyEnv)
+>     unifyArgs (ppConstrTerm 0 t) ts ty
+>   where unifyArgs _ [] ty = return ty
+>         unifyArgs doc (t:ts) ty@(TypeVariable _) =
+>           do (alpha,beta) <- tcArrow p "function pattern" doc m ty
+>	       ty' <- tcConstrTermFP m tcEnv sigs p t
+>	       unify p "function pattern"
+>	             (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>	             m ty' alpha
+>	       unifyArgs doc ts beta
+>         unifyArgs doc (t:ts) (TypeArrow ty1 ty2) =
+>           tcConstrTermFP m tcEnv sigs p t >>=
+>           unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>                 m ty1 >>
+>           unifyArgs doc ts ty2
+>         unifyArgs _ _ _ = internalError "tcConstrTermFP"
+> tcConstrTermFP m tcEnv sigs p t@(InfixFuncPattern t1 op t2) =
+>   tcConstrTermFP m tcEnv sigs p (FunctionPattern op [t1,t2])
+> tcConstrTermFP m tcEnv sigs p r@(RecordPattern fs rt)
+>   | isJust rt =
+>     do
+>       ty <- tcConstrTermFP m tcEnv sigs p (fromJust rt)
+>       fts <- mapM (tcFieldPatt (tcConstrTermFP m tcEnv sigs) m) fs
+>       alpha <- freshVar id
+>	let rty = TypeRecord fts (Just alpha)
+>	unify p "record pattern" (ppConstrTerm 0 r) m ty rty
+>       return rty
+>   | otherwise =
+>     do
+>       fts <- mapM (tcFieldPatt (tcConstrTermFP m tcEnv sigs) m) fs
+>       return (TypeRecord fts Nothing)
+
+> tcFieldPatt :: (Position -> ConstrTerm -> TcState Type) -> ModuleIdent
+>             -> Field ConstrTerm -> TcState (Ident,Type)
+> tcFieldPatt tcPatt m f@(Field _ l t) =
+>   do
+>     tyEnv <- fetchSt
+>     let p = positionOfIdent l
+>     lty <- maybe (freshTypeVar
+>	             >>= (\lty' ->
+>		           updateSt_
+>		             (bindLabel l (qualifyWith m (mkIdent "#Rec"))
+>		                        (polyType lty'))
+>		           >> return lty'))
+>	           (\ (ForAll _ lty') -> return lty')
+>	           (sureLabelType l tyEnv)
+>     ty <- tcPatt p t
+>     unify p "record" (text "Field:" <+> ppFieldPatt f) m lty ty
+>     return (l,ty)
+
+> tcRhs :: ModuleIdent -> TCEnv -> ValueEnv -> SigEnv -> Rhs -> TcState Type
+> tcRhs m tcEnv tyEnv0 sigs (SimpleRhs p e ds) =
+>   do
+>     tcDecls m tcEnv sigs ds
+>     ty <- tcExpr m tcEnv sigs p e
+>     checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty
+> tcRhs m tcEnv tyEnv0 sigs (GuardedRhs es ds) =
+>   do
+>     tcDecls m tcEnv sigs ds
+>     tcCondExprs m tcEnv tyEnv0 sigs es
+
+> tcCondExprs :: ModuleIdent -> TCEnv -> ValueEnv -> SigEnv -> [CondExpr]
+>             -> TcState Type
+> tcCondExprs m tcEnv tyEnv0 sigs es =
+>   do
+>     gty <- if length es > 1 then return boolType
+>                             else freshConstrained [successType,boolType]
+>     ty <- freshTypeVar
+>     tcCondExprs' gty ty es
+>   where tcCondExprs' gty ty [] = return ty
+>         tcCondExprs' gty ty (e:es) =
+>           tcCondExpr gty ty e >> tcCondExprs' gty ty es
+>         tcCondExpr gty ty (CondExpr p g e) =
+>           tcExpr m tcEnv sigs p g >>=
+>           unify p "guard" (ppExpr 0 g) m gty >>
+>           tcExpr m tcEnv sigs p e >>=
+>           checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 >>=
+>           unify p "guarded expression" (ppExpr 0 e) m ty
+
+> tcExpr :: ModuleIdent -> TCEnv -> SigEnv -> Position -> Expression
+>        -> TcState Type
+> tcExpr m _ _ _ (Literal l) = tcLiteral m l
+> tcExpr m tcEnv sigs p (Variable v) =
+>   case qualLookupTypeSig m v sigs of
+>     Just ty -> inst (expandPolyType m tcEnv ty)
+>     Nothing -> fetchSt >>= inst . funType m v
+> tcExpr m tcEnv sigs p (Constructor c) = fetchSt >>= instExist . constrType m c
+> tcExpr m tcEnv sigs p (Typed e sig) =
+>   do
+>     tyEnv0 <- fetchSt
+>     ty <- tcExpr m tcEnv sigs p e
+>     inst sigma' >>=
+>       flip (unify p "explicitly typed expression" (ppExpr 0 e) m) ty
+>     theta <- liftSt fetchSt
+>     let sigma = gen (fvEnv (subst theta tyEnv0)) (subst theta ty)
+>     unless (sigma == sigma')
+>       (errorAt p (typeSigTooGeneral m (text "Expression:" <+> ppExpr 0 e)
+>                  sig' sigma))
+>     return ty
+>   where sig' = nameSigType sig
+>         sigma' = expandPolyType m tcEnv sig'
+> tcExpr m tcEnv sigs p (Paren e) = tcExpr m tcEnv sigs p e
+> tcExpr m tcEnv sigs p (Tuple _ es)
+>   | null es = return unitType
+>   | otherwise = liftM tupleType $ mapM (tcExpr m tcEnv sigs p) es        -- $
+> tcExpr m tcEnv sigs p e@(List _ es) = freshTypeVar >>= tcElems (ppExpr 0 e) es
+>   where tcElems _ [] ty = return (listType ty)
+>         tcElems doc (e:es) ty =
+>           tcExpr m tcEnv sigs p e >>=
+>           unify p "expression" (doc $-$ text "Term:" <+> ppExpr 0 e)
+>                 m ty >>
+>           tcElems doc es ty
+> tcExpr m tcEnv sigs p (ListCompr _ e qs) =
+>   do
+>     tyEnv0 <- fetchSt
+>     mapM_ (tcQual m tcEnv sigs p) qs
+>     ty <- tcExpr m tcEnv sigs p e
+>     checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 (listType ty)
+> tcExpr m tcEnv sigs p e@(EnumFrom e1) =
+>   do
+>     ty1 <- tcExpr m tcEnv sigs p e1
+>     unify p "arithmetic sequence"
+>           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) m intType ty1
+>     return (listType intType)
+> tcExpr m tcEnv sigs p e@(EnumFromThen e1 e2) =
+>   do
+>     ty1 <- tcExpr m tcEnv sigs p e1
+>     ty2 <- tcExpr m tcEnv sigs p e2
+>     unify p "arithmetic sequence"
+>           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) m intType ty1
+>     unify p "arithmetic sequence"
+>           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) m intType ty2
+>     return (listType intType)
+> tcExpr m tcEnv sigs p e@(EnumFromTo e1 e2) =
+>   do
+>     ty1 <- tcExpr m tcEnv sigs p e1
+>     ty2 <- tcExpr m tcEnv sigs p e2
+>     unify p "arithmetic sequence"
+>           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) m intType ty1
+>     unify p "arithmetic sequence"
+>           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) m intType ty2
+>     return (listType intType)
+> tcExpr m tcEnv sigs p e@(EnumFromThenTo e1 e2 e3) =
+>   do
+>     ty1 <- tcExpr m tcEnv sigs p e1
+>     ty2 <- tcExpr m tcEnv sigs p e2
+>     ty3 <- tcExpr m tcEnv sigs p e3
+>     unify p "arithmetic sequence"
+>           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) m intType ty1
+>     unify p "arithmetic sequence"
+>           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2) m intType ty2
+>     unify p "arithmetic sequence"
+>           (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e3) m intType ty3
+>     return (listType intType)
+> tcExpr m tcEnv sigs p e@(UnaryMinus op e1) =
+>   do
+>     opTy <- opType op
+>     ty1 <- tcExpr m tcEnv sigs p e1
+>     unify p "unary negation" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
+>           m opTy ty1
+>     return ty1
+>   where opType op
+>           | op == minusId = freshConstrained [intType,floatType]
+>           | op == fminusId = return floatType
+>           | otherwise = internalError ("tcExpr unary " ++ name op)
+> tcExpr m tcEnv sigs p e@(Apply e1 e2) =
+>   do
+>     ty1 <- tcExpr m tcEnv sigs p e1
+>     ty2 <- tcExpr m tcEnv sigs p e2
+>     (alpha,beta) <-
+>       tcArrow p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
+>               m ty1
+>     unify p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2)
+>           m alpha ty2
+>     return beta
+> tcExpr m tcEnv sigs p e@(InfixApply e1 op e2) =
+>   do
+>     opTy <- tcExpr m tcEnv sigs p (infixOp op)
+>     ty1 <- tcExpr m tcEnv sigs p e1
+>     ty2 <- tcExpr m tcEnv sigs p e2
+>     (alpha,beta,gamma) <-
+>       tcBinary p "infix application"
+>                (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) m opTy
+>     unify p "infix application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
+>           m alpha ty1
+>     unify p "infix application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e2)
+>           m beta ty2
+>     return gamma
+> tcExpr m tcEnv sigs p e@(LeftSection e1 op) =
+>   do
+>     opTy <- tcExpr m tcEnv sigs p (infixOp op)
+>     ty1 <- tcExpr m tcEnv sigs p e1
+>     (alpha,beta) <-
+>       tcArrow p "left section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op)
+>               m opTy
+>     unify p "left section" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
+>           m alpha ty1
+>     return beta
+> tcExpr m tcEnv sigs p e@(RightSection op e1) =
+>   do
+>     opTy <- tcExpr m tcEnv sigs p (infixOp op)
+>     ty1 <- tcExpr m tcEnv sigs p e1
+>     (alpha,beta,gamma) <-
+>       tcBinary p "right section"
+>                (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) m opTy
+>     unify p "right section" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
+>           m beta ty1
+>     return (TypeArrow alpha gamma)
+> tcExpr m tcEnv sigs p exp@(Lambda r ts e) =
+>   do
+>     tyEnv0 <- fetchSt
+>     tys <- mapM (tcConstrTerm m tcEnv sigs p) ts
+>     ty <- tcExpr m tcEnv sigs p e
+>     checkSkolems p m (text "Expression:" <+> ppExpr 0 exp) tyEnv0
+>                  (foldr TypeArrow ty tys)
+> tcExpr m tcEnv sigs p (Let ds e) =
+>   do
+>     tyEnv0 <- fetchSt
+>     theta <- liftSt fetchSt
+>     tcDecls m tcEnv sigs ds
+>     ty <- tcExpr m tcEnv sigs p e
+>     checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty
+> tcExpr m tcEnv sigs p (Do sts e) =
+>   do
+>     tyEnv0 <- fetchSt
+>     mapM_ (tcStmt m tcEnv sigs p) sts
+>     alpha <- freshTypeVar
+>     ty <- tcExpr m tcEnv sigs p e
+>     unify p "statement" (ppExpr 0 e) m (ioType alpha) ty
+>     checkSkolems p m (text "Expression:" <+> ppExpr 0 e) tyEnv0 ty
+> tcExpr m tcEnv sigs p e@(IfThenElse _ e1 e2 e3) =
+>   do
+>     ty1 <- tcExpr m tcEnv sigs p e1
+>     unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1)
+>           m boolType ty1
+>     ty2 <- tcExpr m tcEnv sigs p e2
+>     ty3 <- tcExpr m tcEnv sigs p e3
+>     unify p "expression" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e3)
+>           m ty2 ty3
+>     return ty3
+> tcExpr m tcEnv sigs p (Case _ e alts) =
+>   do
+>     tyEnv0 <- fetchSt
+>     ty <- tcExpr m tcEnv sigs p e
+>     alpha <- freshTypeVar
+>     tcAlts tyEnv0 ty alpha alts
+>   where tcAlts tyEnv0 _ ty [] = return ty
+>         tcAlts tyEnv0 ty1 ty2 (alt:alts) =
+>           tcAlt (ppAlt alt) tyEnv0 ty1 ty2 alt >> tcAlts tyEnv0 ty1 ty2 alts
+>         tcAlt doc tyEnv0 ty1 ty2 (Alt p t rhs) =
+>           tcConstrTerm m tcEnv sigs p t >>=
+>           unify p "case pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t)
+>                 m ty1 >>
+>           tcRhs m tcEnv tyEnv0 sigs rhs >>=
+>           unify p "case branch" doc m ty2
+> tcExpr m tcEnv sigs p (RecordConstr fs) =
+>   do 
+>     fts <- mapM (tcFieldExpr m tcEnv sigs equals) fs
+>     --when (1 == length fs)
+>     --     (error (show fs ++ "\n" ++ show fts))
+>     return (TypeRecord fts Nothing)
+> tcExpr m tcEnv sigs p r@(RecordSelection e l) =
+>   do
+>     ty <- tcExpr m tcEnv sigs p e
+>     tyEnv <- fetchSt
+>     lty <- maybe (freshTypeVar 
+>	             >>= (\lty' -> 
+>		           updateSt_ 
+>		             (bindLabel l (qualifyWith m (mkIdent "#Rec"))
+>		                        (monoType lty'))
+>	                   >> return lty'))
+>                  (\ (ForAll _ lty') -> return lty')
+>	           (sureLabelType l tyEnv)
+>     alpha <- freshVar id
+>     let rty = TypeRecord [(l,lty)] (Just alpha)
+>     unify p "record selection" (ppExpr 0 r) m ty rty
+>     return lty
+> tcExpr m tcEnv sigs p r@(RecordUpdate fs e) =
+>   do
+>     ty <- tcExpr m tcEnv sigs p e
+>     fts <- mapM (tcFieldExpr m tcEnv sigs (text ":=")) fs
+>     alpha <- freshVar id
+>     let rty = TypeRecord fts (Just alpha)
+>     unify p "record update" (ppExpr 0 r) m ty rty
+>     return ty
+
+> tcQual :: ModuleIdent -> TCEnv -> SigEnv -> Position -> Statement
+>        -> TcState ()
+> tcQual m tcEnv sigs p (StmtExpr _ e) =
+>   do
+>     ty <- tcExpr m tcEnv sigs p e
+>     unify p "guard" (ppExpr 0 e) m boolType ty
+> tcQual m tcEnv sigs p q@(StmtBind _ t e) =
+>   do
+>     ty1 <- tcConstrTerm m tcEnv sigs p t
+>     ty2 <- tcExpr m tcEnv sigs p e
+>     unify p "generator" (ppStmt q $-$ text "Term:" <+> ppExpr 0 e)
+>           m (listType ty1) ty2
+> tcQual m tcEnv sigs p (StmtDecl ds) = tcDecls m tcEnv sigs ds
+
+> tcStmt :: ModuleIdent -> TCEnv -> SigEnv -> Position -> Statement
+>        -> TcState ()
+> tcStmt m tcEnv sigs p (StmtExpr _ e) =
+>   do
+>     alpha <- freshTypeVar
+>     ty <- tcExpr m tcEnv sigs p e
+>     unify p "statement" (ppExpr 0 e) m (ioType alpha) ty
+> tcStmt m tcEnv sigs p st@(StmtBind _ t e) =
+>   do
+>     ty1 <- tcConstrTerm m tcEnv sigs p t
+>     ty2 <- tcExpr m tcEnv sigs p e
+>     unify p "statement" (ppStmt st $-$ text "Term:" <+> ppExpr 0 e)
+>           m (ioType ty1) ty2
+> tcStmt m tcEnv sigs p (StmtDecl ds) = tcDecls m tcEnv sigs ds
+
+> tcFieldExpr :: ModuleIdent -> TCEnv -> SigEnv -> Doc -> Field Expression
+>	      -> TcState (Ident,Type)
+> tcFieldExpr m tcEnv sigs comb f@(Field _ l e) =
+>   do
+>     tyEnv <- fetchSt
+>     let p = positionOfIdent l
+>     lty <- maybe (freshTypeVar 
+>	             >>= (\lty' -> 
+>		           updateSt_ 
+>		             (bindLabel l (qualifyWith m (mkIdent "#Rec"))
+>		                          (monoType lty'))
+>	                   >> return lty'))
+>                  inst
+>	           (sureLabelType l tyEnv)
+>     ty <- tcExpr m tcEnv sigs p e
+>     unify p "record" (text "Field:" <+> ppFieldExpr comb f) m lty ty
+>     return (l,ty)
+
+\end{verbatim}
+The function \texttt{tcArrow} checks that its argument can be used as
+an arrow type $\alpha\rightarrow\beta$ and returns the pair
+$(\alpha,\beta)$. Similarly, the function \texttt{tcBinary} checks
+that its argument can be used as an arrow type
+$\alpha\rightarrow\beta\rightarrow\gamma$ and returns the triple
+$(\alpha,\beta,\gamma)$.
+\begin{verbatim}
+
+> tcArrow :: Position -> String -> Doc -> ModuleIdent -> Type
+>         -> TcState (Type,Type)
+> tcArrow p what doc m ty =
+>   do
+>     theta <- liftSt fetchSt
+>     unaryArrow (subst theta ty)
+>   where unaryArrow (TypeArrow ty1 ty2) = return (ty1,ty2)
+>         unaryArrow (TypeVariable tv) =
+>           do
+>             alpha <- freshTypeVar
+>             beta <- freshTypeVar
+>             liftSt (updateSt_ (bindVar tv (TypeArrow alpha beta)))
+>             return (alpha,beta)
+>         unaryArrow ty = errorAt p (nonFunctionType what doc m ty)
+
+> tcBinary :: Position -> String -> Doc -> ModuleIdent -> Type
+>          -> TcState (Type,Type,Type)
+> tcBinary p what doc m ty = tcArrow p what doc m ty >>= uncurry binaryArrow
+>   where binaryArrow ty1 (TypeArrow ty2 ty3) = return (ty1,ty2,ty3)
+>         binaryArrow ty1 (TypeVariable tv) =
+>           do
+>             beta <- freshTypeVar
+>             gamma <- freshTypeVar
+>             liftSt (updateSt_ (bindVar tv (TypeArrow beta gamma)))
+>             return (ty1,beta,gamma)
+>         binaryArrow ty1 ty2 =
+>           errorAt p (nonBinaryOp what doc m (TypeArrow ty1 ty2))
+
+\end{verbatim}
+\paragraph{Unification}
+The unification uses Robinson's algorithm (cf., e.g., Chap.~9
+of~\cite{PeytonJones87:Book}).
+\begin{verbatim}
+
+> unify :: Position -> String -> Doc -> ModuleIdent -> Type -> Type
+>       -> TcState ()
+> unify p what doc m ty1 ty2 =
+>   liftSt $ {-$-}
+>   do
+>     theta <- fetchSt
+>     let ty1' = subst theta ty1
+>     let ty2' = subst theta ty2
+>     either (errorAt p . typeMismatch what doc m ty1' ty2')
+>            (updateSt_ . compose)
+>            (unifyTypes m ty1' ty2')
+
+> unifyTypes :: ModuleIdent -> Type -> Type -> Either Doc TypeSubst
+> unifyTypes _ (TypeVariable tv1) (TypeVariable tv2)
+>   | tv1 == tv2 = Right idSubst
+>   | otherwise = Right (bindSubst tv1 (TypeVariable tv2) idSubst)
+> unifyTypes m (TypeVariable tv) ty
+>   | tv `elem` typeVars ty = Left (recursiveType m tv ty)
+>   | otherwise = Right (bindSubst tv ty idSubst)
+> unifyTypes m ty (TypeVariable tv)
+>   | tv `elem` typeVars ty = Left (recursiveType m tv ty)
+>   | otherwise = Right (bindSubst tv ty idSubst)
+> unifyTypes _ (TypeConstrained tys1 tv1) (TypeConstrained tys2 tv2)
+>   | tv1 == tv2 = Right idSubst
+>   | tys1 == tys2 = Right (bindSubst tv1 (TypeConstrained tys2 tv2) idSubst)
+> unifyTypes m (TypeConstrained tys tv) ty =
+>   foldr (choose . unifyTypes m ty) (Left (incompatibleTypes m ty (head tys)))
+>         tys
+>   where choose (Left _) theta' = theta'
+>         choose (Right theta) _ = Right (bindSubst tv ty theta)
+> unifyTypes m ty (TypeConstrained tys tv) =
+>   foldr (choose . unifyTypes m ty) (Left (incompatibleTypes m ty (head tys)))
+>         tys
+>   where choose (Left _) theta' = theta'
+>         choose (Right theta) _ = Right (bindSubst tv ty theta)
+> unifyTypes m (TypeConstructor tc1 tys1) (TypeConstructor tc2 tys2)
+>   | tc1 == tc2 = unifyTypeLists m tys1 tys2
+> unifyTypes m (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) =
+>   unifyTypeLists m [ty11,ty12] [ty21,ty22]
+> unifyTypes _ (TypeSkolem k1) (TypeSkolem k2)
+>   | k1 == k2 = Right idSubst
+> unifyTypes m (TypeRecord fs1 Nothing) tr2@(TypeRecord fs2 Nothing)
+>   | length fs1 == length fs2 = unifyTypedLabels m fs1 tr2
+> unifyTypes m tr1@(TypeRecord fs1 Nothing) tr2@(TypeRecord fs2 (Just a2)) =
+>   either Left
+>          (\res -> either Left 
+>	                   (Right . compose res) 
+>                          (unifyTypes m (TypeVariable a2) tr1))
+>          (unifyTypedLabels m fs2 tr1)
+> unifyTypes m tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) =
+>   unifyTypes m tr2 tr1
+> unifyTypes m (TypeRecord fs1 (Just a1)) tr2@(TypeRecord fs2 (Just a2)) =
+>   let (fs1', rs1, rs2) = splitFields fs1 fs2
+>   in  either 
+>         Left
+>         (\res -> 
+>           either 
+>             Left 
+>	      (\res' -> Right (compose res res'))
+>	      (unifyTypeLists m [TypeVariable a1,
+>			         TypeRecord (fs1 ++ rs2) Nothing]
+>	                        [TypeVariable a2,
+>			         TypeRecord (fs2 ++ rs1) Nothing]))
+>         (unifyTypedLabels m fs1' tr2)
+>   where
+>   splitFields fs1 fs2 = split' [] [] fs2 fs1
+>   split' fs1' rs1 rs2 [] = (fs1',rs1,rs2)
+>   split' fs1' rs1 rs2 ((l,ty):fs1) =
+>     maybe (split' fs1' ((l,ty):rs1) rs2 fs1)
+>           (const (split' ((l,ty):fs1') rs1 (remove l rs2) fs1))
+>           (lookup l rs2)
+> unifyTypes m ty1 ty2 = Left (incompatibleTypes m ty1 ty2)
+
+> unifyTypeLists :: ModuleIdent -> [Type] -> [Type] -> Either Doc TypeSubst
+> unifyTypeLists _ [] _ = Right idSubst
+> unifyTypeLists _ _ [] = Right idSubst
+> unifyTypeLists m (ty1:tys1) (ty2:tys2) =
+>   either Left (unifyTypesTheta m ty1 ty2) (unifyTypeLists m tys1 tys2)
+>   where unifyTypesTheta m ty1 ty2 theta =
+>           either Left (Right . flip compose theta)
+>                  (unifyTypes m (subst theta ty1) (subst theta ty2))
+
+> unifyTypedLabels :: ModuleIdent -> [(Ident,Type)] -> Type 
+>	           -> Either Doc TypeSubst
+> unifyTypedLabels m [] (TypeRecord _ _) = Right idSubst
+> unifyTypedLabels m ((l,ty):fs1) tr@(TypeRecord fs2 _) =
+>   either Left
+>          (\r -> 
+>            maybe (Left (missingLabel m l tr))
+>                  (\ty' -> 
+>		     either (const (Left (incompatibleLabelTypes m l ty ty')))
+>	                    (Right . flip compose r)
+>	                    (unifyTypes m ty ty'))
+>                  (lookup l fs2))
+>          (unifyTypedLabels m fs1 tr)
+> unifyTypedLabels _ _ _ = internalError "unifyTypedLabels"
+
+\end{verbatim}
+For each declaration group, the type checker has to ensure that no
+skolem type escapes its scope.
+\begin{verbatim}
+
+> checkSkolems :: Position -> ModuleIdent -> Doc -> ValueEnv -> Type
+>              -> TcState Type
+> checkSkolems p m what tyEnv ty =
+>   do
+>     theta <- liftSt fetchSt
+>     let ty' = subst theta ty
+>         fs = fsEnv (subst theta tyEnv)
+>     unless (all (`elemSet` fs) (typeSkolems ty'))
+>            (errorAt p (skolemEscapingScope m what ty'))
+>     --error (show ty ++ " ## " ++ show (subst theta ty))
+>     return ty'
+
+\end{verbatim}
+\paragraph{Instantiation and Generalization}
+We use negative offsets for fresh type variables.
+\begin{verbatim}
+
+> fresh :: (Int -> a) -> TcState a
+> fresh f = liftM f (liftSt (liftSt (updateSt (1 +))))
+
+> freshVar :: (Int -> a) -> TcState a
+> freshVar f = fresh (\n -> f (- n - 1))
+
+> freshTypeVar :: TcState Type
+> freshTypeVar = freshVar TypeVariable
+
+> freshConstrained :: [Type] -> TcState Type
+> freshConstrained tys = freshVar (TypeConstrained tys)
+
+> freshSkolem :: TcState Type
+> freshSkolem = fresh TypeSkolem
+
+> inst :: TypeScheme -> TcState Type
+> inst (ForAll n ty) =
+>   do
+>     tys <- replicateM n freshTypeVar
+>     return (expandAliasType tys ty)
+
+> instExist :: ExistTypeScheme -> TcState Type
+> instExist (ForAllExist n n' ty) =
+>   do
+>     tys <- replicateM (n + n') freshTypeVar
+>     return (expandAliasType tys ty)
+
+> skol :: ExistTypeScheme -> TcState Type
+> skol (ForAllExist n n' ty) =
+>   do
+>     tys <- replicateM n freshTypeVar
+>     tys' <- replicateM n' freshSkolem
+>     return (expandAliasType (tys ++ tys') ty)
+
+> gen :: Set Int -> Type -> TypeScheme
+> gen gvs ty =
+>   ForAll (length tvs) (subst (foldr2 bindSubst idSubst tvs tvs') ty)
+>   where tvs = [tv | tv <- nub (typeVars ty), tv `notElemSet` gvs]
+>         tvs' = map TypeVariable [0..]
+
+\end{verbatim}
+\paragraph{Auxiliary Functions}
+The functions \texttt{constrType}, \texttt{varType}, and
+\texttt{funType} are used to retrieve the type of constructors,
+pattern variables, and variables in expressions, respectively, from
+the type environment. Because the syntactical correctness has already
+been verified by the syntax checker, none of these functions should
+fail.
+
+Note that \texttt{varType} can handle ambiguous identifiers and
+returns the first available type. This function is used for looking up
+the type of an identifier on the left hand side of a rule where it
+unambiguously refers to the local definition.
+\begin{verbatim}
+
+> constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme
+> constrType m c tyEnv =
+>   case qualLookupValue c tyEnv of
+>     [DataConstructor _ sigma] -> sigma
+>     [NewtypeConstructor _ sigma] -> sigma
+>     _ -> case (qualLookupValue (qualQualify m c) tyEnv) of
+>            [DataConstructor _ sigma] -> sigma
+>            [NewtypeConstructor _ sigma] -> sigma
+>            _ -> internalError ("constrType " ++ show c)
+
+> varType :: Ident -> ValueEnv -> TypeScheme
+> varType v tyEnv =
+>   case lookupValue v tyEnv of
+>     Value _ sigma : _ -> sigma
+>     _ -> internalError ("varType " ++ show v)
+
+> sureVarType :: Ident -> ValueEnv -> Maybe TypeScheme
+> sureVarType v tyEnv =
+>   case lookupValue v tyEnv of
+>     Value _ sigma : _ -> Just sigma
+>     _ -> Nothing
+
+> funType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
+> funType m f tyEnv =
+>   case (qualLookupValue f tyEnv) of
+>     [Value _ sigma] -> sigma
+>     vs -> case (qualLookupValue (qualQualify m f) tyEnv) of
+>             [Value _ sigma] -> sigma
+>             _ -> internalError ("funType " ++ show f)
+
+> sureFunType :: ModuleIdent -> QualIdent -> ValueEnv -> Maybe TypeScheme
+> sureFunType m f tyEnv =
+>   case (qualLookupValue f tyEnv) of
+>     [Value _ sigma] -> Just sigma
+>     vs -> case (qualLookupValue (qualQualify m f) tyEnv) of
+>             [Value _ sigma] -> Just sigma
+>             _ -> Nothing
+
+> labelType :: Ident -> ValueEnv -> TypeScheme
+> labelType l tyEnv =
+>   case lookupValue l tyEnv of
+>     Label _ _ sigma : _ -> sigma
+>     _ -> internalError ("labelType " ++ show l)
+
+> sureLabelType :: Ident -> ValueEnv -> Maybe TypeScheme
+> sureLabelType l tyEnv =
+>   case lookupValue l tyEnv of
+>     Label _ _ sigma : _ -> Just sigma
+>     _ -> Nothing
+
+
+\end{verbatim}
+The function \texttt{expandType} expands all type synonyms in a type
+and also qualifies all type constructors with the name of the module
+in which the type was defined.
+\begin{verbatim}
+
+> expandMonoType :: ModuleIdent -> TCEnv -> [Ident] -> TypeExpr -> Type
+> expandMonoType m tcEnv tvs ty = expandType m tcEnv (toType tvs ty)
+
+> expandMonoTypes :: ModuleIdent -> TCEnv -> [Ident] -> [TypeExpr] -> [Type]
+> expandMonoTypes m tcEnv tvs tys = map (expandType m tcEnv) (toTypes tvs tys)
+
+> expandPolyType :: ModuleIdent -> TCEnv -> TypeExpr -> TypeScheme
+> expandPolyType m tcEnv ty = 
+>     polyType $ normalize $ expandMonoType m tcEnv [] ty
+
+> expandType :: ModuleIdent -> TCEnv -> Type -> Type
+> expandType m tcEnv (TypeConstructor tc tys) =
+>   case qualLookupTC tc tcEnv of
+>     [DataType tc' _ _] -> TypeConstructor tc' tys'
+>     [RenamingType tc' _ _] -> TypeConstructor tc' tys'
+>     [AliasType _ _ ty] -> expandAliasType tys' ty
+>     _ -> case (qualLookupTC (qualQualify m tc) tcEnv) of
+>            [DataType tc' _ _] -> TypeConstructor tc' tys'
+>            [RenamingType tc' _ _] -> TypeConstructor tc' tys'
+>            [AliasType _ _ ty] -> expandAliasType tys' ty
+>            _ -> internalError ("expandType " ++ show tc)
+>   where tys' = map (expandType m tcEnv) tys
+> expandType _ _ (TypeVariable tv) = TypeVariable tv
+> expandType _ _ (TypeConstrained tys tv) = TypeConstrained tys tv
+> expandType m tcEnv (TypeArrow ty1 ty2) =
+>   TypeArrow (expandType m tcEnv ty1) (expandType m tcEnv ty2)
+> expandType _ tcEnv (TypeSkolem k) = TypeSkolem k
+> expandType m tcEnv (TypeRecord fs rv) =
+>   TypeRecord (map (\ (l,ty) -> (l, expandType m tcEnv ty)) fs) rv
+
+\end{verbatim}
+The functions \texttt{fvEnv} and \texttt{fsEnv} compute the set of
+free type variables and free skolems of a type environment,
+respectively. We ignore the types of data constructors here because we
+know that they are closed.
+\begin{verbatim}
+
+> fvEnv :: ValueEnv -> Set Int
+> fvEnv tyEnv =
+>   fromListSet [tv | ty <- localTypes tyEnv, tv <- typeVars ty, tv < 0]
+
+> fsEnv :: ValueEnv -> Set Int
+> fsEnv tyEnv = unionSets (map (fromListSet . typeSkolems) (localTypes tyEnv))
+
+> localTypes :: ValueEnv -> [Type]
+> localTypes tyEnv = [ty | (_,Value _ (ForAll _ ty)) <- localBindings tyEnv]
+
+\end{verbatim}
+Miscellaneous functions.
+\begin{verbatim}
+
+> remove :: Eq a => a -> [(a,b)] -> [(a,b)]
+> remove _ [] = []
+> remove k ((k',e):kes) | k == k'   = kes
+>		        | otherwise = (k',e):(remove k kes) 
+
+\end{verbatim}
+Error functions.
+\begin{verbatim}
+
+> recursiveTypes :: [Ident] -> (Position,String)
+> recursiveTypes [tc] = 
+>     (positionOfIdent tc,
+>      "Recursive synonym type " ++ name tc)
+> recursiveTypes (tc:tcs) =
+>  (positionOfIdent tc,
+>   "Recursive synonym types " ++ name tc ++ types "" tcs)
+>   where types comma [tc] = comma ++ " and " ++ name tc ++
+>                            showLine (positionOfIdent tc) 
+>         types _ (tc:tcs) = ", " ++ name tc ++ 
+>                            showLine (positionOfIdent tc) ++ 
+>                            types "," tcs
+
+> polymorphicFreeVar :: Ident -> (Position,String)
+> polymorphicFreeVar v =
+>  (positionOfIdent v,
+>   "Free variable " ++ name v ++ " has a polymorphic type")
+
+> typeSigTooGeneral :: ModuleIdent -> Doc -> TypeExpr -> TypeScheme -> String
+> typeSigTooGeneral m what ty sigma = show $
+>   vcat [text "Type signature too general", what,
+>         text "Inferred type:" <+> ppTypeScheme m sigma,
+>         text "Type signature:" <+> ppTypeExpr 0 ty]
+
+> nonFunctionType :: String -> Doc -> ModuleIdent -> Type -> String
+> nonFunctionType what doc m ty = show $
+>   vcat [text "Type error in" <+> text what, doc,
+>         text "Type:" <+> ppType m ty,
+>         text "Cannot be applied"]
+
+> nonBinaryOp :: String -> Doc -> ModuleIdent -> Type -> String
+> nonBinaryOp what doc m ty = show $
+>   vcat [text "Type error in" <+> text what, doc,
+>         text "Type:" <+> ppType m ty,
+>         text "Cannot be used as binary operator"]
+
+> typeMismatch :: String -> Doc -> ModuleIdent -> Type -> Type -> Doc -> String
+> typeMismatch what doc m ty1 ty2 reason = show $
+>   vcat [text "Type error in" <+> text what, doc,
+>         text "Inferred type:" <+> ppType m ty2,
+>         text "Expected type:" <+> ppType m ty1,
+>         reason]
+
+> skolemEscapingScope :: ModuleIdent -> Doc -> Type -> String
+> skolemEscapingScope m what ty = show $
+>   vcat [text "Existential type escapes out of its scope", what,
+>         text "Type:" <+> ppType m ty]
+
+> invalidCType :: String -> ModuleIdent -> Type -> String
+> invalidCType what m ty = show $
+>   vcat [text ("Invalid " ++ what ++ " type in foreign declaration"),
+>         ppType m ty]
+
+> recursiveType :: ModuleIdent -> Int -> Type -> Doc
+> recursiveType m tv ty = incompatibleTypes m (TypeVariable tv) ty
+
+> missingLabel :: ModuleIdent -> Ident -> Type -> Doc
+> missingLabel m l rty =
+>   sep [text "Missing field for label" <+> ppIdent l,
+>        text "in the record type" <+> ppType m rty]
+
+> incompatibleTypes :: ModuleIdent -> Type -> Type -> Doc
+> incompatibleTypes m ty1 ty2 =
+>   sep [text "Types" <+> ppType m ty1,
+>        nest 2 (text "and" <+> ppType m ty2),
+>        text "are incompatible"]
+
+> incompatibleLabelTypes :: ModuleIdent -> Ident -> Type -> Type -> Doc
+> incompatibleLabelTypes m l ty1 ty2 =
+>   sep [text "Labeled types" <+> ppIdent l <> text "::" <> ppType m ty1,
+>        nest 10 (text "and" <+> ppIdent l <> text "::" <> ppType m ty2),
+>        text "are incompatible"]
+
+\end{verbatim}
diff --git a/src/TypeSubst.lhs b/src/TypeSubst.lhs
new file mode 100644
--- /dev/null
+++ b/src/TypeSubst.lhs
@@ -0,0 +1,102 @@
+
+% $Id: TypeSubst.lhs,v 1.2 2004/02/08 22:14:01 wlux Exp $
+%
+% Copyright (c) 2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{TypeSubst.lhs}
+\section{Type Substitutions}
+This module implements substitutions on types.
+\begin{verbatim}
+
+> module TypeSubst(module TypeSubst, idSubst,bindSubst,compose) where
+
+
+> import Data.Maybe
+> import Data.List
+
+> import Subst
+> import Base
+> import TopEnv
+
+> type TypeSubst = Subst Int Type
+
+> class SubstType a where
+>   subst :: TypeSubst -> a -> a
+
+> bindVar :: Int -> Type -> TypeSubst -> TypeSubst
+> bindVar tv ty = compose (bindSubst tv ty idSubst)
+
+> substVar :: TypeSubst -> Int -> Type
+> substVar = substVar' TypeVariable subst
+
+> instance SubstType Type where
+>   subst sigma (TypeConstructor tc tys) =
+>     TypeConstructor tc (map (subst sigma) tys)
+>   subst sigma (TypeVariable tv) = substVar sigma tv
+>   subst sigma (TypeConstrained tys tv) =
+>     case substVar sigma tv of
+>       TypeVariable tv -> TypeConstrained tys tv
+>       ty -> ty
+>   subst sigma (TypeArrow ty1 ty2) =
+>     TypeArrow (subst sigma ty1) (subst sigma ty2)
+>   subst sigma (TypeSkolem k) = TypeSkolem k
+>   subst sigma (TypeRecord fs rv)
+>     | isJust rv =
+>       case substVar sigma (fromJust rv) of
+>         TypeVariable tv -> TypeRecord fs' (Just tv)
+>         ty -> ty
+>     | otherwise = TypeRecord fs' Nothing
+>    where fs' = map (\ (l,ty) -> (l, subst sigma ty)) fs
+
+> instance SubstType TypeScheme where
+>   subst sigma (ForAll n ty) =
+>     ForAll n (subst (foldr unbindSubst sigma [0..n-1]) ty)
+
+> instance SubstType ExistTypeScheme where
+>   subst sigma (ForAllExist n n' ty) =
+>     ForAllExist n n' (subst (foldr unbindSubst sigma [0..n+n'-1]) ty)
+
+> instance SubstType ValueInfo where
+>   subst theta (DataConstructor c ty) = DataConstructor c ty
+>   subst theta (NewtypeConstructor c ty) = NewtypeConstructor c ty
+>   subst theta (Value v ty) = Value v (subst theta ty)
+>   subst theta (Label l r ty) = Label l r (subst theta ty)
+
+> instance SubstType a => SubstType (TopEnv a) where
+>   subst = fmap . subst
+
+\end{verbatim}
+The function \texttt{expandAliasType} expands all occurrences of a
+type synonym in a type. After the expansion we have to reassign the
+type indices for all type variables. Otherwise, expanding a type
+synonym like \verb|type Pair' a b = (b,a)| could break the invariant
+that the universally quantified type variables are assigned indices in
+the order of their occurrence. This is handled by the function
+\texttt{normalize}.
+\begin{verbatim}
+
+> expandAliasType :: [Type] -> Type -> Type
+> expandAliasType tys (TypeConstructor tc tys') =
+>   TypeConstructor tc (map (expandAliasType tys) tys')
+> expandAliasType tys (TypeVariable n)
+>   | n >= 0 = tys !! n
+>   | otherwise = TypeVariable n
+> expandAliasType _ (TypeConstrained tys n) = TypeConstrained tys n
+> expandAliasType tys (TypeArrow ty1 ty2) =
+>   TypeArrow (expandAliasType tys ty1) (expandAliasType tys ty2)
+> expandAliasType _ (TypeSkolem k) = TypeSkolem k
+> expandAliasType tys (TypeRecord fs rv)
+>   | isJust rv =
+>     let (TypeVariable tv) = expandAliasType tys (TypeVariable (fromJust rv))
+>     in  TypeRecord fs' (Just tv)
+>   | otherwise =
+>     TypeRecord fs' Nothing
+>  where fs' = map (\ (l,ty) -> (l, expandAliasType tys ty)) fs
+
+> normalize :: Type -> Type
+> normalize ty = expandAliasType [TypeVariable (occur tv) | tv <- [0..]] ty
+>   where tvs = zip (nub (filter (>= 0) (typeVars ty))) [0..]
+>         occur tv = fromJust (lookup tv tvs)
+
+\end{verbatim}
diff --git a/src/Types.lhs b/src/Types.lhs
new file mode 100644
--- /dev/null
+++ b/src/Types.lhs
@@ -0,0 +1,217 @@
+% $Id: Types.lhs,v 1.11 2004/02/08 22:14:02 wlux Exp $
+%
+% Copyright (c) 2002, Wolfgang Lux
+% See LICENSE for the full license.
+%
+% Modified by Martin Engelke (men@informatik.uni-kiel.de)
+%
+\nwfilename{Types.lhs}
+\section{Types}
+This module modules provides the definitions for the internal 
+representation of types in the compiler.
+\begin{verbatim}
+
+> module Types where
+
+> import Data.List
+> import Data.Maybe
+
+> import Ident
+
+\end{verbatim}
+A type is either a type variable, an application of a type constructor
+to a list of arguments, or an arrow type. The \texttt{TypeConstrained}
+case is used for representing type variables that are restricted to a
+particular set of types. At present, this is used for typing guard
+expressions, which are restricted to be either of type \texttt{Bool}
+or of type \texttt{Success}, and integer literals, which are
+restricted to types \texttt{Int} and \texttt{Float}. If the type is
+not restricted it defaults to the first type from the constraint list.
+The case \texttt{TypeSkolem} is used for handling skolem types, which
+result from the use of existentially quantified data constructors.
+
+Type variables are represented with deBruijn style indices. Universally
+quantified type variables are assigned indices in the order of their
+occurrence in the type from left to right. This leads to a canonical
+representation of types where $\alpha$-equivalence of two types
+coincides with equality of the representation.
+
+Note that even though \texttt{TypeConstrained} variables use indices
+as well, these variables must never be quantified.
+\begin{verbatim}
+
+> data Type =
+>     TypeConstructor QualIdent [Type]
+>   | TypeVariable Int
+>   | TypeConstrained [Type] Int
+>   | TypeArrow Type Type
+>   | TypeSkolem Int
+>   | TypeRecord [(Ident,Type)] (Maybe Int)
+>   deriving (Eq,Show)
+
+\end{verbatim}
+The function \texttt{isArrowType} checks whether a type is a function
+type $t_1 \rightarrow t_2 \rightarrow \dots \rightarrow t_n$ . The
+function \texttt{arrowArity} computes the arity $n$ of a function type
+and \texttt{arrowBase} returns the type $t_n$.
+\begin{verbatim}
+
+> isArrowType :: Type -> Bool
+> isArrowType (TypeArrow _ _) = True
+> isArrowType _ = False
+
+> arrowArity :: Type -> Int
+> arrowArity (TypeArrow _ ty) = 1 + arrowArity ty
+> arrowArity _ = 0
+
+> arrowArgs :: Type -> [Type]
+> arrowArgs (TypeArrow ty1 ty2) = ty1 : arrowArgs ty2
+> arrowArgs ty = []
+
+> arrowBase :: Type -> Type
+> arrowBase (TypeArrow _ ty) = arrowBase ty
+> arrowBase ty = ty
+
+\end{verbatim}
+The functions \texttt{typeVars}, \texttt{typeConstrs},
+\texttt{typeSkolems} return a list of all type variables, type
+constructors, or skolems occurring in a type $t$, respectively. Note
+that \texttt{TypeConstrained} variables are not included in the set of
+type variables because they cannot be generalized.
+\begin{verbatim}
+
+> typeVars :: Type -> [Int]
+> typeVars ty = vars ty []
+>   where vars (TypeConstructor _ tys) tvs = foldr vars tvs tys
+>         vars (TypeVariable tv) tvs = tv : tvs
+>         vars (TypeConstrained _ _) tvs = tvs
+>         vars (TypeArrow ty1 ty2) tvs = vars ty1 (vars ty2 tvs)
+>         vars (TypeSkolem _) tvs = tvs
+>         vars (TypeRecord fs rtv) tvs =
+>             foldr vars (maybe tvs (: tvs) rtv) (map snd fs)
+
+> typeConstrs :: Type -> [QualIdent]
+> typeConstrs ty = types ty []
+>   where types (TypeConstructor tc tys) tcs = tc : foldr types tcs tys
+>         types (TypeVariable _) tcs = tcs
+>         types (TypeConstrained _ _) tcs = tcs
+>         types (TypeArrow ty1 ty2) tcs = types ty1 (types ty2 tcs)
+>         types (TypeSkolem _) tcs = tcs
+>         types (TypeRecord fs _) tcs =
+>             foldr types tcs (map snd fs)
+
+> typeSkolems :: Type -> [Int]
+> typeSkolems ty = skolems ty []
+>   where skolems (TypeConstructor _ tys) sks = foldr skolems sks tys
+>         skolems (TypeVariable _) sks = sks
+>         skolems (TypeConstrained _ _) sks = sks
+>         skolems (TypeArrow ty1 ty2) sks = skolems ty1 (skolems ty2 sks)
+>         skolems (TypeSkolem k) sks = k : sks
+>         skolems (TypeRecord fs _) sks =
+>             foldr skolems sks (map snd fs)
+
+> equTypes :: Type -> Type -> Bool
+> equTypes t1 t2 = fst (equ [] t1 t2)
+>  where 
+>  equ is (TypeConstructor qid1 ts1) (TypeConstructor qid2 ts2)
+>     | qid1 == qid2 = equs is ts1 ts2
+>     | otherwise    = (False, is)
+>  equ is (TypeVariable i1) (TypeVariable i2)
+>     = maybe (True, (i1,i2):is) 
+>             (\ i2' -> (i2 == i2', is))
+>             (lookup i1 is)
+>  equ is (TypeConstrained ts1 i1) (TypeConstrained ts2 i2)
+>     = let (res, is') = equs is ts1 ts2
+>       in  maybe (res, (i1,i2):is')
+>                 (\ i2' -> (res && i2 == i2', is'))
+>                 (lookup i1 is')
+>  equ is (TypeArrow tf1 tt1) (TypeArrow tf2 tt2)
+>     = let (res1, is1) = equ is tf1 tf2
+>           (res2, is2) = equ is1 tt1 tt2
+>       in  (res1 && res2, is2)
+>  equ is (TypeSkolem i1) (TypeSkolem i2)
+>     = maybe (True, (i1,i2):is)
+>             (\ i2' -> (i2 == i2', is))
+>             (lookup i1 is)
+>  equ is (TypeRecord fs1 r1) (TypeRecord fs2 r2)
+>     | isJust r1 && isJust r2
+>       = let (res1, is1) = equ is (TypeVariable (fromJust r1))
+>		                   (TypeVariable (fromJust r2))
+>             (res2, is2) = equRecords is1 fs1 fs2
+>         in  (res1 && res2, is2)
+>     | isNothing r1 && isNothing r2 = equRecords is fs1 fs2
+>     | otherwise = (False, is)
+>  equ is _ _ = (False, is)
+>	
+>  equRecords is fs1 fs2 | length fs1 == length fs2 = equrec is fs1 fs2
+>		         | otherwise = (False, is)
+>    where
+>    equrec is [] fs2 = (True, is)
+>    equrec is ((l,t):fs1) fs2
+>       = let (res1, is1) = maybe (False,is) (equ is t) (lookup l fs2)
+>             (res2, is2) = equrec is1 fs1 fs2
+>         in  (res1 && res2, is2)
+>
+>  equs is [] [] = (True, is)
+>  equs is (t1:ts1) (t2:ts2)
+>     = let (res1, is1) = equ is t1 t2
+>           (res2, is2) = equs is1 ts1 ts2
+>       in  (res1 && res2, is2)
+
+\end{verbatim}
+We support two kinds of quantifications of types here, universally
+quantified type schemes $\forall\overline{\alpha} .
+\tau(\overline{\alpha})$ and universally and existentially quantified
+type schemes $\forall\overline{\alpha} \exists\overline{\eta} .
+\tau(\overline{\alpha},\overline{\eta})$.  In both, quantified type
+variables are assigned ascending indices starting from 0. Therefore it
+is sufficient to record the numbers of quantified type variables in
+the \texttt{ForAll} and \texttt{ForAllExist} constructors. In case of
+the latter, the first of the two numbers is the number of universally
+quantified variables and the second the number of existentially
+quantified variables.
+\begin{verbatim}
+
+> data TypeScheme = ForAll Int Type deriving (Eq,Show)
+> data ExistTypeScheme = ForAllExist Int Int Type deriving (Eq,Show)
+
+\end{verbatim}
+The functions \texttt{monoType} and \texttt{polyType} translate a type
+$\tau$ into a monomorphic type scheme $\forall.\tau$ and a polymorphic
+type scheme $\forall\overline{\alpha}.\tau$ where $\overline{\alpha} =
+\textrm{fv}(\tau)$, respectively. \texttt{polyType} assumes that all
+universally quantified variables in the type are assigned indices
+starting with 0 and does not renumber the variables.
+\begin{verbatim}
+
+> monoType, polyType :: Type -> TypeScheme
+> monoType ty = ForAll 0 ty
+> polyType ty = ForAll (maximum (-1 : typeVars ty) + 1) ty
+
+\end{verbatim}
+There are a few predefined types:
+\begin{verbatim}
+
+> unitType,boolType,charType,intType,floatType,stringType,successType :: Type
+> unitType = primType unitId []
+> boolType = primType boolId []
+> charType = primType charId []
+> intType = primType intId []
+> floatType = primType floatId []
+> stringType = listType charType
+> successType = primType successId []
+
+> listType,ioType :: Type -> Type
+> listType ty = primType listId [ty]
+> ioType ty = primType ioId [ty]
+
+> tupleType :: [Type] -> Type
+> tupleType tys = primType (tupleId (length tys)) tys
+
+> primType :: Ident -> [Type] -> Type
+> primType = TypeConstructor . qualifyWith preludeMIdent
+
+> typeVar :: Int -> Type
+> typeVar = TypeVariable
+
+\end{verbatim}
diff --git a/src/Typing.lhs b/src/Typing.lhs
new file mode 100644
--- /dev/null
+++ b/src/Typing.lhs
@@ -0,0 +1,401 @@
+
+% $Id: Typing.lhs,v 1.7 2004/02/12 19:13:12 wlux Exp $
+%
+% Copyright (c) 2003-2006, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Typing.lhs}
+\section{Computing the Type of Curry Expressions}
+\begin{verbatim}
+
+> module Typing(Typeable(..)) where
+
+> import Data.Maybe
+> import Control.Monad
+
+> import Base
+> import TypeSubst
+> import Combined
+> import TopEnv
+> import Utils
+
+
+\end{verbatim}
+During the transformation of Curry source code into the intermediate
+language, the compiler has to recompute the types of expressions. This
+is simpler than type checking because the types of all variables are
+known. Yet, the compiler still must handle functions and constructors
+with polymorphic types and instantiate their type schemes using fresh
+type variables. Since all types computed by \texttt{typeOf} are
+monomorphic, we can use type variables with non-negative offsets for
+the instantiation of type schemes here without risk of name conflicts.
+Using non-negative offsets also makes it easy to distinguish these
+fresh variables from free type variables introduce during type
+inference, which must be regarded as constants here.
+
+However, using non-negative offsets for fresh type variables gives
+rise to two problems when those types are entered back into the type
+environment, e.g., while introducing auxiliary variables during
+desugaring. The first is that those type variables now appear to be
+universally quantified variables, but with indices greater than the
+number of quantified type variables.\footnote{To be precise, this can
+  happen only for auxiliary variables, which have monomorphic types,
+  whereas auxiliary functions will be assigned polymorphic types and
+  these type variables will be properly quantified. However, in this
+  case the assigned types may be too general.} This results in an
+internal error (``Prelude.!!: index too large'') whenever such a type
+is instantiated. The second problem is that there may be inadvertent
+name captures because \texttt{computeType} always uses indices
+starting at 0 for the fresh type variables. In order to avoid these
+problems, \texttt{computeType} renames all type variables with
+non-negative offsets after the final type has been computed, using
+negative indices below the one with the smallest value occurring in
+the type environment. Computing the minimum index of all type
+variables in the type environment seems prohibitively inefficient.
+However, recall that, thanks to laziness, the minimum is computed only
+when the final type contains any type variables with non-negative
+indices. This happens, for instance, 36 times while compiling the
+prelude (for 159 evaluated applications of \texttt{typeOf}) and only
+twice while compiling the standard \texttt{IO} module (for 21
+applications of \texttt{typeOf}).\footnote{These numbers were obtained
+  for version 0.9.9.}
+
+A careful reader will note that inadvertent name captures are still
+possible if one computes the types of two or more auxiliary variables
+before actually entering their types into the environment. Therefore,
+make sure that you enter the types of these auxiliary variables
+immediately into the type environment, unless you are sure that those
+types cannot contain fresh type variables. One such case are the free
+variables of a goal.
+
+\ToDo{In the long run, this module should be made obsolete by adding
+attributes to the abstract syntax tree -- e.g., along the lines of
+Chap.~6 in~\cite{PeytonJonesLester92:Book} -- and returning an
+abstract syntax tree attributed with type information together with
+the type environment from type inference. This also would allow
+getting rid of the identifiers in the representation of integer
+literals, which are used in order to implement overloading of
+integer constants.}
+
+\ToDo{When computing the type of an expression with a type signature
+make use of the annotation instead of recomputing its type. In order
+to do this, we must either ensure that the types are properly
+qualified and expanded or we need access to the type constructor
+environment.}
+\begin{verbatim}
+
+> type TyState a = StateT TypeSubst (StateT Int Id) a
+
+> run :: TyState a -> ValueEnv -> a
+> run m tyEnv = runSt (callSt m idSubst) 0
+
+> class Typeable a where
+>   typeOf :: ValueEnv -> a -> Type
+
+> instance Typeable Ident where
+>   typeOf = computeType identType
+
+> instance Typeable ConstrTerm where
+>   typeOf = computeType argType
+
+> instance Typeable Expression where
+>   typeOf = computeType exprType
+
+> instance Typeable Rhs where
+>   typeOf = computeType rhsType
+
+> computeType f tyEnv x = normalize (run doComputeType tyEnv)
+>   where doComputeType =
+>           do
+>             ty <- f tyEnv x
+>             theta <- fetchSt
+>             return (fixTypeVars tyEnv (subst theta ty))
+
+> fixTypeVars :: ValueEnv -> Type -> Type
+> fixTypeVars tyEnv ty = subst (foldr2 bindSubst idSubst tvs tvs') ty
+>   where tvs = filter (>= 0) (typeVars ty)
+>         tvs' = map TypeVariable [n - 1,n - 2 ..]
+>         n = minimum (0 : concatMap typeVars tys)
+>         tys = [ty | (_,Value _ (ForAll _ ty)) <- localBindings tyEnv]
+
+> identType :: ValueEnv -> Ident -> TyState Type
+> identType tyEnv x = instUniv (varType x tyEnv)
+
+> litType :: ValueEnv -> Literal -> TyState Type
+> litType _ (Char _ _)    = return charType
+> litType tyEnv (Int v _) = identType tyEnv v
+> litType _ (Float _ _)   = return floatType
+> litType _ (String _ _)  = return stringType
+
+> argType :: ValueEnv -> ConstrTerm -> TyState Type
+> argType tyEnv (LiteralPattern l) = litType tyEnv l
+> argType tyEnv (NegativePattern _ l) = litType tyEnv l
+> argType tyEnv (VariablePattern v) = identType tyEnv v
+> argType tyEnv (ConstructorPattern c ts) =
+>   do
+>     ty <- instUnivExist (constrType c tyEnv)
+>     tys <- mapM (argType tyEnv) ts
+>     unifyList (init (flatten ty)) tys
+>     return (last (flatten ty))
+>   where flatten (TypeArrow ty1 ty2) = ty1 : flatten ty2
+>         flatten ty = [ty]
+> argType tyEnv (InfixPattern t1 op t2) =
+>   argType tyEnv (ConstructorPattern op [t1,t2])
+> argType tyEnv (ParenPattern t) = argType tyEnv t
+> argType tyEnv (TuplePattern _ ts)
+>   | null ts = return unitType
+>   | otherwise = liftM tupleType $ mapM (argType tyEnv) ts                -- $
+> argType tyEnv (ListPattern _ ts) = freshTypeVar >>= flip elemType ts
+>   where elemType ty [] = return (listType ty)
+>         elemType ty (t:ts) =
+>           argType tyEnv t >>= unify ty >> elemType ty ts
+> argType tyEnv (AsPattern v _) = argType tyEnv (VariablePattern v)
+> argType tyEnv (LazyPattern _ t) = argType tyEnv t
+> argType tyEnv (FunctionPattern f ts) =
+>   do 
+>     ty <- instUniv (funType f tyEnv)
+>     tys <- mapM (argType tyEnv) ts
+>     unifyList (init (flatten ty)) tys
+>     return (last (flatten ty))
+>   where flatten (TypeArrow ty1 ty2) = ty1 : flatten ty2
+>         flatten ty = [ty]
+> argType tyEnv (InfixFuncPattern t1 op t2) =
+>   argType tyEnv (FunctionPattern op [t1,t2])
+> argType tyEnv (RecordPattern fs r)
+>   | isJust r =
+>     do
+>       tys <- mapM (fieldPattType tyEnv) fs
+>       rty <- argType tyEnv (fromJust r)
+>       (TypeVariable i) <- freshTypeVar
+>       unify rty (TypeRecord tys (Just i))
+>       return rty
+>   | otherwise =
+>     do
+>       tys <- mapM (fieldPattType tyEnv) fs
+>       return (TypeRecord tys Nothing)
+
+> fieldPattType :: ValueEnv -> Field ConstrTerm -> TyState (Ident,Type)
+> fieldPattType tyEnv (Field _ l t) =
+>   do
+>     lty <- instUniv (labelType l tyEnv)
+>     ty <- argType tyEnv t
+>     unify lty ty
+>     return (l,lty)
+
+> exprType :: ValueEnv -> Expression -> TyState Type
+> exprType tyEnv (Literal l) = litType tyEnv l
+> exprType tyEnv (Variable v) = instUniv (funType v tyEnv)
+> exprType tyEnv (Constructor c) = instUnivExist (constrType c tyEnv)
+> exprType tyEnv (Typed e _) = exprType tyEnv e
+> exprType tyEnv (Paren e) = exprType tyEnv e
+> exprType tyEnv (Tuple _ es)
+>   | null es = return unitType
+>   | otherwise = liftM tupleType $ mapM (exprType tyEnv) es
+> exprType tyEnv (List _ es) = freshTypeVar >>= flip elemType es
+>   where elemType ty [] = return (listType ty)
+>         elemType ty (e:es) =
+>           exprType tyEnv e >>= unify ty >> elemType ty es
+> exprType tyEnv (ListCompr _ e _) = liftM listType $ exprType tyEnv e
+> exprType tyEnv (EnumFrom _) = return (listType intType)
+> exprType tyEnv (EnumFromThen _ _) = return (listType intType)
+> exprType tyEnv (EnumFromTo _ _) = return (listType intType)
+> exprType tyEnv (EnumFromThenTo _ _ _) = return (listType intType)
+> exprType tyEnv (UnaryMinus _ e) = exprType tyEnv e
+> exprType tyEnv (Apply e1 e2) =
+>   do
+>     (ty1,ty2) <- exprType tyEnv e1 >>= unifyArrow
+>     exprType tyEnv e2 >>= unify ty1
+>     return ty2
+> exprType tyEnv (InfixApply e1 op e2) =
+>   do
+>     (ty1,ty2,ty3) <- exprType tyEnv (infixOp op) >>= unifyArrow2
+>     exprType tyEnv e1 >>= unify ty1
+>     exprType tyEnv e2 >>= unify ty2
+>     return ty3
+> exprType tyEnv (LeftSection e op) =
+>   do
+>     (ty1,ty2,ty3) <- exprType tyEnv (infixOp op) >>= unifyArrow2
+>     exprType tyEnv e >>= unify ty1
+>     return (TypeArrow ty2 ty3)
+> exprType tyEnv (RightSection op e) =
+>   do
+>     (ty1,ty2,ty3) <- exprType tyEnv (infixOp op) >>= unifyArrow2
+>     exprType tyEnv e >>= unify ty2
+>     return (TypeArrow ty1 ty3)
+> exprType tyEnv (Lambda _ args e) =
+>   do
+>     tys <- mapM (argType tyEnv) args
+>     ty <- exprType tyEnv e
+>     return (foldr TypeArrow ty tys)
+> exprType tyEnv (Let _ e) = exprType tyEnv e
+> exprType tyEnv (Do _ e) = exprType tyEnv e
+> exprType tyEnv (IfThenElse _ e1 e2 e3) =
+>   do
+>     exprType tyEnv e1 >>= unify boolType
+>     ty2 <- exprType tyEnv e2
+>     ty3 <- exprType tyEnv e3
+>     unify ty2 ty3
+>     return ty3
+> exprType tyEnv (Case _ _ alts) = freshTypeVar >>= flip altType alts
+>   where altType ty [] = return ty
+>         altType ty (Alt _ _ rhs:alts) =
+>           rhsType tyEnv rhs >>= unify ty >> altType ty alts
+> exprType tyEnv (RecordConstr fs) =
+>   do 
+>     tys <- mapM (fieldExprType tyEnv) fs
+>     return (TypeRecord tys Nothing)
+> exprType tyEnv (RecordSelection r l) =
+>   do 
+>     lty <- instUniv (labelType l tyEnv)
+>     rty <- exprType tyEnv r
+>     (TypeVariable i) <- freshTypeVar
+>     unify rty (TypeRecord [(l,lty)] (Just i))
+>     return lty
+> exprType tyEnv (RecordUpdate fs r) =
+>   do
+>     tys <- mapM (fieldExprType tyEnv) fs
+>     rty <- exprType tyEnv r
+>     (TypeVariable i) <- freshTypeVar
+>     unify rty (TypeRecord tys (Just i))
+>     return rty
+
+> rhsType :: ValueEnv -> Rhs -> TyState Type
+> rhsType tyEnv (SimpleRhs _ e _) = exprType tyEnv e
+> rhsType tyEnv (GuardedRhs es _) = freshTypeVar >>= flip condExprType es
+>   where condExprType ty [] = return ty
+>         condExprType ty (CondExpr _ _ e:es) =
+>           exprType tyEnv e >>= unify ty >> condExprType ty es
+
+> fieldExprType :: ValueEnv -> Field Expression -> TyState (Ident,Type)
+> fieldExprType tyEnv (Field _ l e) =
+>   do
+>     lty <- instUniv (labelType l tyEnv)
+>     ty <- exprType tyEnv e
+>     unify lty ty
+>     return (l,lty)
+
+\end{verbatim}
+In order to avoid name conflicts with non-generalized type variables
+in a type we instantiate quantified type variables using non-negative
+offsets here.
+\begin{verbatim}
+
+> freshTypeVar :: TyState Type
+> freshTypeVar = liftM TypeVariable $ liftSt $ updateSt (1 +)
+
+> instType :: Int -> Type -> TyState Type
+> instType n ty =
+>   do
+>     tys <- sequence (replicate n freshTypeVar)
+>     return (expandAliasType tys ty)
+
+> instUniv :: TypeScheme -> TyState Type
+> instUniv (ForAll n ty) = instType n ty
+
+> instUnivExist :: ExistTypeScheme -> TyState Type
+> instUnivExist (ForAllExist n n' ty) = instType (n + n') ty
+
+\end{verbatim}
+When unifying two types, the non-generalized variables, i.e.,
+variables with negative offsets, must not be substituted. Otherwise,
+the unification algorithm is identical to the one used by the type
+checker.
+\begin{verbatim}
+
+> unify :: Type -> Type -> TyState ()
+> unify ty1 ty2 =
+>   updateSt_ (\theta -> unifyTypes (subst theta ty1) (subst theta ty2) theta)
+
+> unifyList :: [Type] -> [Type] -> TyState ()
+> unifyList tys1 tys2 = sequence_ (zipWith unify tys1 tys2)
+
+> unifyArrow :: Type -> TyState (Type,Type)
+> unifyArrow ty =
+>   do
+>     theta <- fetchSt
+>     case subst theta ty of
+>       TypeVariable tv
+>         | tv >= 0 ->
+>             do
+>               ty1 <- freshTypeVar
+>               ty2 <- freshTypeVar
+>               updateSt_ (bindVar tv (TypeArrow ty1 ty2))
+>               return (ty1,ty2)
+>       TypeArrow ty1 ty2 -> return (ty1,ty2)
+>       ty' -> internalError ("unifyArrow (" ++ show ty' ++ ")")
+
+> unifyArrow2 :: Type -> TyState (Type,Type,Type)
+> unifyArrow2 ty =
+>   do
+>     (ty1,ty2) <- unifyArrow ty
+>     (ty21,ty22) <- unifyArrow ty2
+>     return (ty1,ty21,ty22)
+
+> unifyTypes :: Type -> Type -> TypeSubst -> TypeSubst
+> unifyTypes (TypeVariable tv1) (TypeVariable tv2) theta
+>   | tv1 == tv2 = theta
+> unifyTypes (TypeVariable tv) ty theta
+>   | tv >= 0 = bindVar tv ty theta
+> unifyTypes ty (TypeVariable tv) theta
+>   | tv >= 0 = bindVar tv ty theta
+> unifyTypes (TypeConstructor tc1 tys1) (TypeConstructor tc2 tys2) theta
+>   | tc1 == tc2 = foldr2 unifyTypes theta tys1 tys2
+> unifyTypes (TypeConstrained tys1 tv1) (TypeConstrained tys2 tv2) theta
+>   | tv1 == tv2 = theta
+> unifyTypes (TypeArrow ty11 ty12) (TypeArrow ty21 ty22) theta =
+>   unifyTypes ty11 ty21 (unifyTypes ty12 ty22 theta)
+> unifyTypes (TypeSkolem k1) (TypeSkolem k2) theta
+>   | k1 == k2 = theta
+> unifyTypes (TypeRecord fs1 Nothing) (TypeRecord fs2 Nothing) theta
+>   | length fs1 == length fs2 = foldr (unifyTypedLabels fs1) theta fs2
+> unifyTypes tr1@(TypeRecord fs1 Nothing) (TypeRecord fs2 (Just a2)) theta =
+>   unifyTypes (TypeVariable a2)
+>              tr1
+>              (foldr (unifyTypedLabels fs1) theta fs2)
+> unifyTypes tr1@(TypeRecord _ (Just _)) tr2@(TypeRecord _ Nothing) theta =
+>   unifyTypes tr2 tr1 theta
+> unifyTypes (TypeRecord fs1 (Just a1)) (TypeRecord fs2 (Just a2)) theta =
+>   unifyTypes (TypeVariable a1)
+>              (TypeVariable a2)
+>              (foldr (unifyTypedLabels fs1) theta fs2)
+> unifyTypes ty1 ty2 _ =
+>   internalError ("unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")")
+
+> unifyTypedLabels :: [(Ident,Type)] -> (Ident,Type) -> TypeSubst -> TypeSubst
+> unifyTypedLabels fs1 (l,ty) theta =
+>   maybe theta (\ty1 -> unifyTypes ty1 ty theta) (lookup l fs1)
+
+\end{verbatim}
+The functions \texttt{constrType}, \texttt{varType}, and
+\texttt{funType} are used for computing the type of constructors,
+pattern variables, and variables.
+
+\ToDo{These functions should be shared with the type checker.}
+\begin{verbatim}
+
+> constrType :: QualIdent -> ValueEnv -> ExistTypeScheme
+> constrType c tyEnv =
+>   case qualLookupValue c tyEnv of
+>     [DataConstructor _ sigma] -> sigma
+>     [NewtypeConstructor _ sigma] -> sigma
+>     _ -> internalError ("constrType " ++ show c)
+
+> varType :: Ident -> ValueEnv -> TypeScheme
+> varType v tyEnv =
+>   case lookupValue v tyEnv of
+>     [Value _ sigma] -> sigma
+>     _ -> internalError ("varType " ++ show v)
+
+> funType :: QualIdent -> ValueEnv -> TypeScheme
+> funType f tyEnv =
+>   case qualLookupValue f tyEnv of
+>     [Value _ sigma] -> sigma
+>     _ -> internalError ("funType " ++ show f)
+
+> labelType :: Ident -> ValueEnv -> TypeScheme
+> labelType l tyEnv =
+>   case lookupValue l tyEnv of
+>     [Label _ _ sigma] -> sigma
+>     _ -> internalError ("labelType " ++ show l)
+
+\end{verbatim}
diff --git a/src/Unlit.lhs b/src/Unlit.lhs
new file mode 100644
--- /dev/null
+++ b/src/Unlit.lhs
@@ -0,0 +1,110 @@
+% -*- LaTeX -*-
+% $Id: Unlit.lhs,v 1.2 2002/10/01 06:55:50 lux Exp $
+%
+% $Log: Unlit.lhs,v $
+% Revision 1.2  2002/10/01 06:55:50  lux
+% unlit returns an error message to the caller instead of calling error.
+%
+% Revision 1.1  2000/02/07 14:05:55  lux
+% The compiler now supports literate source files. Literate source files
+% must end with the suffix ".lcurry".
+%
+%
+\nwfilename{Unlit.lhs}
+\section{Literate comments}
+Since version 0.7 of the language report, Curry accepts literate
+source programs. In a literate source all program lines must begin
+with a greater sign in the first column. All other lines are assumed
+to be documentation. In order to avoid some common errors with
+literate programs, Curry requires at least one program line to be
+present in the file. In addition, every block of program code must be
+preceded by a blank line and followed by a blank line.
+
+The module \texttt{Unlit} acts as a preprocessor which converts
+literate source programs into the ``un-literate'' format accepted by
+the lexer. The implementation, together with the comments below, was
+derived from appendix D in the Haskell 1.2 report.
+\begin{verbatim}
+
+> module Unlit(unlit) where
+> import Data.Char
+> import Position
+
+\end{verbatim}
+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.
+\begin{verbatim}
+
+> data Classified = Program String | Blank | Comment
+
+\end{verbatim}
+In a literate program, program lines begin with a \verb|>| character,
+blank lines contain only whitespace, and all other lines are comment
+lines.
+\begin{verbatim}
+
+> classify :: String -> Classified
+> classify ""            = Blank
+> classify (c:cs)
+>   | c == '>'           = Program cs
+>   | all isSpace (c:cs) = Blank
+>   | otherwise          = Comment
+
+\end{verbatim}
+In the corresponding program, program lines have the leading \verb|>|
+replaced by a leading space, to preserve tab alignments.
+\begin{verbatim}
+
+> unclassify :: Classified -> String
+> unclassify (Program cs) = ' ' : cs
+> unclassify Blank        = ""
+> unclassify Comment      = ""
+
+\end{verbatim}
+Process a literate program into error messages (if any) and the
+corresponding non-literate program.
+\begin{verbatim}
+
+> unlit :: FilePath -> String -> (String,String)
+> unlit fn lcy = (es,cy)
+>   where cs = map classify (lines lcy)
+>         es = unlines (errors fn cs)
+>         cy = unlines (map unclassify cs)
+
+\end{verbatim}
+Check that each program line is not adjacent to a comment line and
+there is at least one program line.
+\begin{verbatim}
+
+> errors :: FilePath -> [Classified] -> [String]
+> errors fn cs =
+>   concat (zipWith3 adjacent (iterate nl (first fn)) cs (tail cs)) ++
+>   empty fn (filter isProgram cs)
+
+\end{verbatim}
+Given a line number and a pair of adjacent lines, generate a list of
+error messages, which will contain either one entry or none.
+\begin{verbatim}
+
+> adjacent :: Position -> Classified -> Classified -> [String]
+> adjacent p (Program _) Comment     = [message (nl p) "after"]
+> adjacent p Comment     (Program _) = [message p "before"]
+> adjacent p _           _           = []
+
+> message p w = show p ++ ": comment line " ++ w ++ " program line."
+
+\end{verbatim}
+Given the list of program lines generate an error if this list is
+empty.
+\begin{verbatim}
+
+> empty :: FilePath -> [Classified] -> [String]
+> empty fn [] = [show (first fn) ++ ": no code in literate script"]
+> empty fn _ = []
+
+> isProgram :: Classified -> Bool
+> isProgram (Program _) = True
+> isProgram _ = False
+
+\end{verbatim}
diff --git a/src/Utils.lhs b/src/Utils.lhs
new file mode 100644
--- /dev/null
+++ b/src/Utils.lhs
@@ -0,0 +1,101 @@
+% -*- LaTeX -*-
+% $Id: Utils.lhs,v 1.4 2003/10/04 17:04:38 wlux Exp $
+%
+% Copyright (c) 2001-2003, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Utils.lhs}
+\section{Utility Functions}
+The module \texttt{Utils} provides a few simple functions that are
+commonly used in the compiler, but not implemented in the Haskell
+\texttt{Prelude} or standard library.
+\begin{verbatim}
+
+> module Utils where
+> infixr 5 ++!
+
+\end{verbatim}
+\paragraph{Pairs}
+The functions \texttt{apFst} and \texttt{apSnd} apply a function to
+the first and second components of a pair, resp.
+\begin{verbatim}
+
+> apFst f (x,y) = (f x,y)
+> apSnd f (x,y) = (x,f y)
+
+\end{verbatim}
+\paragraph{Triples}
+The \texttt{Prelude} does not contain standard functions for
+triples. We provide projection, (un-)currying, and mapping for triples
+here.
+\begin{verbatim}
+
+> fst3 (x,_,_) = x
+> snd3 (_,y,_) = y
+> thd3 (_,_,z) = z
+
+> apFst3 f (x,y,z) = (f x,y,z)
+> apSnd3 f (x,y,z) = (x,f y,z)
+> apThd3 f (x,y,z) = (x,y,f z)
+
+> curry3 f x y z = f (x,y,z)
+> uncurry3 f (x,y,z) = f x y z
+
+\end{verbatim}
+\paragraph{Lists}
+The function \texttt{(++!)} is variant of the list concatenation
+operator \texttt{(++)} that ignores the second argument if the first
+is a non-empty list. When lists are used to encode non-determinism in
+Haskell, this operator has the same effect as the cut operator in
+Prolog, hence the \texttt{!} in the name.
+\begin{verbatim}
+
+> (++!) :: [a] -> [a] -> [a]
+> xs ++! ys = if null xs then ys else xs
+
+\end{verbatim}
+\paragraph{Strict fold}
+The function \texttt{foldl\_strict} is a strict version of
+\texttt{foldl}, i.e., it evaluates the binary applications before
+the recursion. This has the advantage that \texttt{foldl\_strict} does
+not construct a large application which is then evaluated in the base
+case of the recursion.
+\begin{verbatim}
+
+> foldl_strict :: (a -> b -> a) -> a -> [b] -> a
+> foldl_strict f z []     = z
+> foldl_strict f z (x:xs) = let z' = f z x in  z' `seq` foldl_strict f z' xs
+
+\end{verbatim}
+\paragraph{Folding with two lists}
+Fold operations with two arguments lists can be defined using
+\texttt{zip} and \texttt{foldl} or \texttt{foldr}, resp. Our
+definitions are unfolded for efficiency reasons.
+\begin{verbatim}
+
+> foldl2 :: (a -> b -> c -> a) -> a -> [b] -> [c] -> a
+> foldl2 f z []     _      = z
+> foldl2 f z _      []     = z
+> foldl2 f z (x:xs) (y:ys) = foldl2 f (f z x y) xs ys
+
+> foldr2 :: (a -> b -> c -> c) -> c -> [a] -> [b] -> c
+> foldr2 f z []     _      = z
+> foldr2 f z _      []     = z
+> foldr2 f z (x:xs) (y:ys) = f x y (foldr2 f z xs ys)
+
+\end{verbatim}
+\paragraph{Monadic fold with an accumulator}
+The function \texttt{mapAccumM} is a generalization of
+\texttt{mapAccumL} to monads like \texttt{foldM} is for
+\texttt{foldl}.
+\begin{verbatim}
+
+> mapAccumM :: Monad m => (a -> b -> m (a,c)) -> a -> [b] -> m (a,[c])
+> mapAccumM _ s [] = return (s,[])
+> mapAccumM f s (x:xs) =
+>   do
+>     (s',y) <- f s x
+>     (s'',ys) <- mapAccumM f s' xs
+>     return (s'',y:ys)
+
+\end{verbatim}
diff --git a/src/WarnCheck.hs b/src/WarnCheck.hs
new file mode 100644
--- /dev/null
+++ b/src/WarnCheck.hs
@@ -0,0 +1,910 @@
+-------------------------------------------------------------------------------
+--
+-- WarnCheck - Searches for potentially irregular code and generates
+--             warning messages
+--                
+-- February 2006,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+module WarnCheck (warnCheck) where
+
+import Control.Monad
+import Data.List
+
+import CurrySyntax
+import Ident
+import Position
+import Base (ValueEnv, ValueInfo(..), qualLookupValue, lookupValue)
+import TopEnv
+import qualified ScopeEnv
+import ScopeEnv (ScopeEnv)
+import Message
+import Env
+
+
+
+
+-------------------------------------------------------------------------------
+
+-- Find potentially incorrect code in a Curry program and generate
+-- the following warnings for:
+--    - unreferenced variables
+--    - shadowing variables
+--    - idle case alternatives
+--    - overlapping case alternatives
+--    - function rules which are not together
+warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [Message]
+warnCheck mid vals imports decls
+   = run (do addImportedValues vals
+	     addModuleId mid
+	     checkImports imports
+	     foldM' insertDecl decls
+	     foldM' (checkDecl mid) decls
+             checkDeclOccurrences decls
+	 )
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+--
+checkDecl :: ModuleIdent -> Decl -> CheckState ()
+checkDecl mid (DataDecl pos ident params cdecls)
+   = do beginScope
+	foldM' insertTypeVar params
+	foldM' (checkConstrDecl mid) cdecls
+	params' <- filterM isUnrefTypeVar params
+	when (not (null params')) 
+	     (foldM' genWarning' (map unrefTypeVar params'))
+	endScope
+checkDecl mid (TypeDecl _ ident params texpr)
+   = do beginScope
+	foldM' insertTypeVar params
+	checkTypeExpr mid texpr
+	params' <- filterM isUnrefTypeVar params
+	when (not (null params'))
+	     (foldM' genWarning'  (map unrefTypeVar params'))
+	endScope
+checkDecl mid (FunctionDecl pos ident equs)
+   = do beginScope
+	foldM' (checkEquation mid) equs
+	c <- isConsId ident
+	idents' <- returnUnrefVars
+	when (not (c || null idents')) 
+             (foldM' genWarning' (map unrefVar idents'))
+	endScope
+checkDecl mid (PatternDecl _ cterm rhs)
+   = do checkConstrTerm mid cterm
+	checkRhs mid rhs
+checkDecl _ _ = return ()
+
+-- Checks locally declared identifiers (i.e. functions and logic variables)
+-- for shadowing
+checkLocalDecl :: Decl -> CheckState ()
+checkLocalDecl (FunctionDecl pos ident _)
+   = do s <- isShadowingVar ident
+	when s (genWarning' (shadowingVar ident))
+checkLocalDecl (ExtraVariables pos idents)
+   = do idents' <- filterM isShadowingVar idents
+	when (not (null idents'))
+	     (foldM' genWarning' (map shadowingVar idents'))
+checkLocalDecl (PatternDecl _ constrTerm _)
+   = checkConstrTerm (mkMIdent []) constrTerm
+checkLocalDecl _ = return ()
+
+--
+checkConstrDecl :: ModuleIdent -> ConstrDecl -> CheckState ()
+checkConstrDecl mid (ConstrDecl _ _ ident texprs)
+   = do visitId ident
+	foldM' (checkTypeExpr mid) texprs
+checkConstrDecl mid (ConOpDecl _ _ texpr1 ident texpr2)
+   = do visitId ident
+	checkTypeExpr mid texpr1
+	checkTypeExpr mid texpr2
+
+
+checkTypeExpr :: ModuleIdent -> TypeExpr -> CheckState ()
+checkTypeExpr mid (ConstructorType qid texprs)
+   = do maybe (return ()) visitTypeId (localIdent mid qid)
+	foldM' (checkTypeExpr mid ) texprs
+checkTypeExpr mid  (VariableType ident)
+   = visitTypeId ident
+checkTypeExpr mid  (TupleType texprs)
+   = foldM' (checkTypeExpr mid ) texprs
+checkTypeExpr mid  (ListType texpr)
+   = checkTypeExpr mid  texpr
+checkTypeExpr mid  (ArrowType texpr1 texpr2)
+   = do checkTypeExpr mid  texpr1
+	checkTypeExpr mid  texpr2
+checkTypeExpr mid  (RecordType fields restr)
+   = do foldM' (checkTypeExpr mid ) (map snd fields)
+	maybe (return ()) (checkTypeExpr mid ) restr
+
+--
+checkEquation :: ModuleIdent -> Equation -> CheckState ()
+checkEquation mid (Equation _ lhs rhs)
+   = do checkLhs mid lhs
+	checkRhs mid rhs
+
+--
+checkLhs :: ModuleIdent -> Lhs -> CheckState ()
+checkLhs mid (FunLhs ident cterms)
+   = do visitId ident
+	foldM' (checkConstrTerm mid) cterms
+	foldM' (insertConstrTerm False) cterms
+checkLhs mid (OpLhs cterm1 ident cterm2)
+   = checkLhs mid (FunLhs ident [cterm1, cterm2])
+checkLhs mid (ApLhs lhs cterms)
+   = do checkLhs mid lhs
+	foldM' (checkConstrTerm mid ) cterms
+	foldM' (insertConstrTerm False) cterms
+
+--
+checkRhs :: ModuleIdent -> Rhs -> CheckState ()
+checkRhs mid (SimpleRhs _ expr decls)
+   = do beginScope  -- function arguments can be overwritten by local decls
+	foldM' checkLocalDecl decls
+	foldM' insertDecl decls
+	foldM' (checkDecl mid) decls
+	checkDeclOccurrences decls
+	checkExpression mid expr
+	idents' <- returnUnrefVars
+	when (not (null idents'))
+	     (foldM' genWarning' (map unrefVar idents'))
+	endScope
+checkRhs mid (GuardedRhs cexprs decls)
+   = do beginScope
+	foldM' checkLocalDecl decls
+	foldM' insertDecl decls
+	foldM' (checkDecl mid) decls
+	checkDeclOccurrences decls
+	foldM' (checkCondExpr mid) cexprs
+	idents' <- returnUnrefVars
+	when (not (null idents'))
+	     (foldM' genWarning' (map unrefVar idents'))
+	endScope
+
+--
+checkCondExpr :: ModuleIdent -> CondExpr -> CheckState ()
+checkCondExpr mid (CondExpr _ cond expr)
+   = do checkExpression mid cond
+	checkExpression mid expr
+
+-- 
+checkConstrTerm :: ModuleIdent -> ConstrTerm -> CheckState ()
+checkConstrTerm mid (VariablePattern ident)
+   = do s <- isShadowingVar ident
+	when s (genWarning' (shadowingVar ident))
+checkConstrTerm mid (ConstructorPattern _ cterms)
+   = foldM' (checkConstrTerm mid ) cterms
+checkConstrTerm mid (InfixPattern cterm1 qident cterm2)
+   = checkConstrTerm mid (ConstructorPattern qident [cterm1, cterm2])
+checkConstrTerm mid (ParenPattern cterm)
+   = checkConstrTerm mid cterm
+checkConstrTerm mid (TuplePattern _ cterms)
+   = foldM' (checkConstrTerm mid ) cterms
+checkConstrTerm mid (ListPattern _ cterms)
+   = foldM' (checkConstrTerm mid ) cterms
+checkConstrTerm mid (AsPattern ident cterm)
+   = do s <- isShadowingVar ident
+	when s (genWarning' (shadowingVar ident))
+	checkConstrTerm mid cterm
+checkConstrTerm mid (LazyPattern _ cterm)
+   = checkConstrTerm mid cterm
+checkConstrTerm mid (FunctionPattern _ cterms)
+   = foldM' (checkConstrTerm mid ) cterms
+checkConstrTerm mid  (InfixFuncPattern cterm1 qident cterm2)
+   = checkConstrTerm mid  (FunctionPattern qident [cterm1, cterm2])
+checkConstrTerm mid  (RecordPattern fields restr)
+   = do foldM' (checkFieldPattern mid) fields
+	maybe (return ()) (checkConstrTerm mid ) restr
+checkConstrTerm _ _ = return ()
+
+--
+checkExpression :: ModuleIdent -> Expression -> CheckState ()
+checkExpression mid (Variable qident)
+   = maybe (return ()) visitId (localIdent mid qident)
+checkExpression mid (Paren expr)
+   = checkExpression mid expr
+checkExpression mid (Typed expr _)
+   = checkExpression mid expr
+checkExpression mid (Tuple _ exprs)
+   = foldM' (checkExpression mid ) exprs
+checkExpression mid (List _ exprs)
+   = foldM' (checkExpression mid ) exprs
+checkExpression mid (ListCompr _ expr stmts)
+   = do beginScope
+	foldM' (checkStatement mid ) stmts
+	checkExpression mid expr
+	idents' <- returnUnrefVars
+	when (not (null idents'))
+	     (foldM' genWarning' (map unrefVar idents'))
+	endScope
+checkExpression mid  (EnumFrom expr)
+   = checkExpression mid  expr
+checkExpression mid  (EnumFromThen expr1 expr2)
+   = foldM' (checkExpression mid ) [expr1, expr2]
+checkExpression mid  (EnumFromTo expr1 expr2)
+   = foldM' (checkExpression mid ) [expr1, expr2]
+checkExpression mid  (EnumFromThenTo expr1 expr2 expr3)
+   = foldM' (checkExpression mid ) [expr1, expr2, expr3]
+checkExpression mid  (UnaryMinus _ expr)
+   = checkExpression mid  expr
+checkExpression mid  (Apply expr1 expr2)
+   = foldM' (checkExpression mid ) [expr1, expr2]
+checkExpression mid  (InfixApply expr1 op expr2)
+   = do maybe (return ()) (visitId) (localIdent mid (opName op))
+	foldM' (checkExpression mid ) [expr1, expr2]
+checkExpression mid  (LeftSection expr _)
+   = checkExpression mid  expr
+checkExpression mid  (RightSection _ expr)
+   = checkExpression mid  expr
+checkExpression mid  (Lambda _ cterms expr)
+   = do beginScope
+	foldM' (checkConstrTerm mid ) cterms
+	foldM' (insertConstrTerm False) cterms
+	checkExpression mid expr
+	idents' <- returnUnrefVars
+	when (not (null idents'))
+	     (foldM' genWarning' (map unrefVar idents'))
+	endScope
+checkExpression mid  (Let decls expr)
+   = do beginScope
+	foldM' checkLocalDecl decls
+	foldM' insertDecl decls
+	foldM' (checkDecl mid) decls
+	checkDeclOccurrences decls
+	checkExpression mid  expr
+	idents' <- returnUnrefVars
+	when (not (null idents'))
+	     (foldM' genWarning' (map unrefVar idents'))
+	endScope
+checkExpression mid  (Do stmts expr)
+   = do beginScope
+	foldM' (checkStatement mid ) stmts
+	checkExpression mid  expr
+	idents' <- returnUnrefVars
+	when (not (null idents'))
+	     (foldM' genWarning' (map unrefVar idents'))
+	endScope
+checkExpression mid  (IfThenElse _ expr1 expr2 expr3)
+   = foldM' (checkExpression mid ) [expr1, expr2, expr3]
+checkExpression mid  (Case _ expr alts)
+   = do checkExpression mid  expr
+	foldM' (checkAlt mid) alts
+	checkCaseAlternatives mid alts
+checkExpression mid (RecordConstr fields)
+   = foldM' (checkFieldExpression mid) fields
+checkExpression mid (RecordSelection expr ident)
+   = checkExpression mid expr -- Hier auch "visitId ident" ?
+checkExpression mid (RecordUpdate fields expr)
+   = do foldM' (checkFieldExpression mid) fields
+	checkExpression mid expr
+checkExpression _ _  = return ()
+
+--
+checkStatement :: ModuleIdent -> Statement -> CheckState ()
+checkStatement mid (StmtExpr _ expr)
+   = checkExpression mid expr
+checkStatement mid (StmtDecl decls)
+   = do foldM' checkLocalDecl decls
+	foldM' insertDecl decls
+	foldM' (checkDecl mid) decls
+	checkDeclOccurrences decls
+checkStatement mid (StmtBind _ cterm expr)
+   = do checkConstrTerm mid cterm
+	insertConstrTerm False cterm
+	checkExpression mid expr
+
+--
+checkAlt :: ModuleIdent -> Alt -> CheckState ()
+checkAlt mid (Alt pos cterm rhs)
+   = do beginScope 
+	checkConstrTerm mid  cterm
+	insertConstrTerm False cterm
+	checkRhs mid rhs
+	idents' <-  returnUnrefVars
+	when (not (null idents'))
+	     (foldM' genWarning' (map unrefVar idents'))
+	endScope
+
+--
+checkFieldExpression :: ModuleIdent -> Field Expression -> CheckState ()
+checkFieldExpression mid (Field _ ident expr)
+   = checkExpression mid expr -- Hier auch "visitId ident" ?
+
+--
+checkFieldPattern :: ModuleIdent -> Field ConstrTerm -> CheckState ()
+checkFieldPattern mid (Field _ ident cterm)
+   = checkConstrTerm mid  cterm
+
+-- Check for idle and overlapping case alternatives
+checkCaseAlternatives :: ModuleIdent -> [Alt] -> CheckState ()
+checkCaseAlternatives mid alts
+   = do checkIdleAlts mid alts
+	checkOverlappingAlts mid alts
+
+--
+checkIdleAlts :: ModuleIdent -> [Alt] -> CheckState ()
+checkIdleAlts mid alts
+   = do alts' <- dropUnless' isVarAlt alts
+	let idles = tail_ [] alts'
+	    (Alt pos _ _) = head idles
+	unless (null idles) (genWarning pos idleCaseAlts)
+ where
+ isVarAlt (Alt _ (VariablePattern id) _) 
+    = isVarId id
+ isVarAlt (Alt _ (ParenPattern (VariablePattern id)) _) 
+    = isVarId id
+ isVarAlt (Alt _ (AsPattern _ (VariablePattern id)) _)
+    = isVarId id
+ isVarAlt _ = return False
+
+--
+checkOverlappingAlts :: ModuleIdent -> [Alt] -> CheckState ()
+checkOverlappingAlts mid [] = return ()
+checkOverlappingAlts mid (alt:alts)
+   = do (altsr, alts') <- partition' (equalAlts alt) alts
+        mapM_ (\ (Alt pos _ _) -> genWarning pos overlappingCaseAlt) altsr
+	checkOverlappingAlts mid alts'
+ where
+ equalAlts (Alt _ cterm1 _) (Alt _ cterm2 _) = equalConstrTerms cterm1 cterm2
+
+ equalConstrTerms (LiteralPattern l1) (LiteralPattern l2)
+    = return (l1 == l2)
+ equalConstrTerms (NegativePattern id1 l1) (NegativePattern id2 l2) 
+    = return (id1 == id2 && l1 == l2)
+ equalConstrTerms (VariablePattern id1) (VariablePattern id2)
+    = do p <- isConsId id1 
+	 return (p && id1 == id2)
+ equalConstrTerms (ConstructorPattern qid1 cs1)
+		  (ConstructorPattern qid2 cs2)
+    = if qid1 == qid2
+      then all' (\ (c1,c2) -> equalConstrTerms c1 c2) (zip cs1 cs2)
+      else return False
+ equalConstrTerms (InfixPattern lcs1 qid1 rcs1)
+		  (InfixPattern lcs2 qid2 rcs2)
+    = equalConstrTerms (ConstructorPattern qid1 [lcs1, rcs1])
+                       (ConstructorPattern qid2 [lcs2, rcs2])
+ equalConstrTerms (ParenPattern cterm1) (ParenPattern cterm2)
+    = equalConstrTerms cterm1 cterm2
+ equalConstrTerms (TuplePattern _ cs1) (TuplePattern _ cs2)
+    = equalConstrTerms (ConstructorPattern (qTupleId 2) cs1)
+                       (ConstructorPattern (qTupleId 2) cs2)
+ equalConstrTerms (ListPattern _ cs1) (ListPattern _ cs2)
+    = cmpListM equalConstrTerms cs1 cs2
+ equalConstrTerms (AsPattern id1 cterm1) (AsPattern id2 cterm2)
+    = equalConstrTerms cterm1 cterm2
+ equalConstrTerms (LazyPattern _ cterm1) (LazyPattern _ cterm2)
+    = equalConstrTerms cterm1 cterm2
+ equalConstrTerms _ _ = return False
+
+
+-- Find function rules which are not together
+checkDeclOccurrences :: [Decl] -> CheckState ()
+checkDeclOccurrences decls = checkDO (mkIdent "") emptyEnv decls
+ where
+ checkDO prevId env [] = return ()
+ checkDO prevId env ((FunctionDecl pos ident _):decls)
+    = do c <- isConsId ident
+	 if not (c || prevId == ident)
+          then (maybe (checkDO ident (bindEnv ident pos env) decls)
+	              (\pos' -> genWarning' (rulesNotTogether ident pos')
+		                >> checkDO ident env decls)
+	              (lookupEnv ident env))
+	  else checkDO ident env decls
+ checkDO _ env (_:decls) 
+    = checkDO (mkIdent "") env decls
+
+
+-- check import declarations for multiply imported modules
+checkImports :: [Decl] -> CheckState ()
+checkImports imps = checkImps emptyEnv imps
+ where
+ checkImps env [] = return ()
+ checkImps env ((ImportDecl pos mid _ _ spec):imps)
+    | mid /= preludeMIdent
+      = maybe (checkImps (bindEnv mid (fromImpSpec spec) env) imps)
+              (\ishs -> checkImpSpec env pos mid ishs spec
+	                >>= (\env' -> checkImps env' imps))
+	      (lookupEnv mid env)
+    | otherwise
+      = checkImps env imps
+ checkImps env (_:imps) = checkImps env imps
+
+ checkImpSpec env pos mid (is,hs) Nothing
+    = genWarning' (multiplyImportedModule mid) >> return env
+ checkImpSpec env pos mid (is,hs) (Just (Importing _ is'))
+    | null is && any (\i' -> notElem i' hs) is'
+      = do genWarning' (multiplyImportedModule mid)
+	   return (bindEnv mid (is',hs) env)
+    | null iis
+      = return (bindEnv mid (is' ++ is,hs) env)
+    | otherwise
+      = do foldM' genWarning'
+		  (map ((multiplyImportedSymbol mid) . impName) iis)
+	   return (bindEnv mid (unionBy cmpImport is' is,hs) env)
+  where iis = intersectBy cmpImport is' is
+ checkImpSpec env pos mid (is,hs) (Just (Hiding _ hs'))
+    | null ihs
+      = return (bindEnv mid (is,hs' ++ hs) env)
+    | otherwise
+      = do foldM' genWarning' 
+		  (map ((multiplyHiddenSymbol mid) . impName) ihs)
+	   return (bindEnv mid (is,unionBy cmpImport hs' hs) env)
+  where ihs = intersectBy cmpImport hs' hs
+
+ cmpImport (ImportTypeWith id1 cs1) (ImportTypeWith id2 cs2)
+    = id1 == id2 && null (intersect cs1 cs2)
+ cmpImport i1 i2 = (impName i1) == (impName i2)
+
+ impName (Import id)           = id
+ impName (ImportTypeAll id)    = id
+ impName (ImportTypeWith id _) = id
+
+ fromImpSpec Nothing                 = ([],[])
+ fromImpSpec (Just (Importing _ is)) = (is,[])
+ fromImpSpec (Just (Hiding _ hs))    = ([],hs)
+
+
+-------------------------------------------------------------------------------
+-- For detecting unreferenced variables, the following functions updates the 
+-- current check state by adding identifiers occuring in declaration left hand 
+-- sides.
+
+--
+insertDecl :: Decl -> CheckState ()
+insertDecl (DataDecl _ ident _ cdecls)
+   = do insertTypeConsId ident
+	foldM' insertConstrDecl cdecls
+insertDecl (TypeDecl _ ident _ texpr)
+   = do insertTypeConsId ident
+	insertTypeExpr texpr
+insertDecl (FunctionDecl _ ident _)
+   = do c <- isConsId ident
+	unless c (insertVar ident)
+insertDecl (ExternalDecl _ _ _ ident _)
+   = insertVar ident
+insertDecl (FlatExternalDecl _ idents)
+   = foldM' insertVar idents
+insertDecl (PatternDecl _ cterm _)
+   = insertConstrTerm False cterm
+insertDecl (ExtraVariables _ idents)
+   = foldM' insertVar idents
+insertDecl _ = return ()
+
+--
+insertTypeExpr :: TypeExpr -> CheckState ()
+insertTypeExpr (VariableType _) = return ()
+insertTypeExpr (ConstructorType _ texprs)
+   = foldM' insertTypeExpr texprs
+insertTypeExpr (TupleType texprs)
+   = foldM' insertTypeExpr texprs
+insertTypeExpr (ListType texpr)
+   = insertTypeExpr texpr
+insertTypeExpr (ArrowType texpr1 texpr2)
+   = foldM' insertTypeExpr [texpr1,texpr2]
+insertTypeExpr (RecordType fields restr)
+   = do --foldM' insertVar (concatMap fst fields)
+	maybe (return ()) insertTypeExpr restr
+
+--
+insertConstrDecl :: ConstrDecl -> CheckState ()
+insertConstrDecl (ConstrDecl _ _ ident _)
+   = insertConsId ident
+insertConstrDecl (ConOpDecl _ _ _ ident _)
+   = insertConsId ident
+
+-- Notes: 
+--    - 'fp' indicates whether 'checkConstrTerm' deals with the arguments
+--      of a function pattern or not.
+--    - Since function patterns are not recognized before syntax check, it is
+--      necessary to determine, whether a constructor pattern represents a
+--      constructor or a function. 
+insertConstrTerm :: Bool -> ConstrTerm -> CheckState ()
+insertConstrTerm fp (VariablePattern ident)
+   | fp        = do c <- isConsId ident
+		    v <- isVarId ident
+		    unless c (if (name ident) /= "_" && v
+			         then visitId ident
+			         else insertVar ident)
+   | otherwise = do c <- isConsId ident
+	            unless c (insertVar ident)
+insertConstrTerm fp (ConstructorPattern qident cterms)
+   = do c <- isQualConsId qident
+	if c then foldM' (insertConstrTerm fp) cterms
+	     else foldM' (insertConstrTerm True) cterms
+insertConstrTerm fp (InfixPattern cterm1 qident cterm2)
+   = insertConstrTerm fp (ConstructorPattern qident [cterm1, cterm2])
+insertConstrTerm fp (ParenPattern cterm)
+   = insertConstrTerm fp cterm
+insertConstrTerm fp (TuplePattern _ cterms)
+   = foldM' (insertConstrTerm fp) cterms
+insertConstrTerm fp (ListPattern _ cterms)
+   = foldM' (insertConstrTerm fp) cterms
+insertConstrTerm fp (AsPattern ident cterm)
+   = do insertVar ident
+	insertConstrTerm fp cterm
+insertConstrTerm fp (LazyPattern _ cterm)
+   = insertConstrTerm fp cterm
+insertConstrTerm _ (FunctionPattern _ cterms)
+   = foldM' (insertConstrTerm True) cterms
+insertConstrTerm _ (InfixFuncPattern cterm1 qident cterm2)
+   = insertConstrTerm True (FunctionPattern qident [cterm1, cterm2])
+insertConstrTerm fp (RecordPattern fields restr)
+   = do foldM' (insertFieldPattern fp) fields
+	maybe (return ()) (insertConstrTerm fp) restr
+insertConstrTerm _ _ = return ()
+
+--
+insertFieldPattern :: Bool -> Field ConstrTerm -> CheckState ()
+insertFieldPattern fp (Field _ _ cterm)
+   = insertConstrTerm fp cterm
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+
+-- Data type for distinguishing identifiers as either (type) constructors or
+-- (type) variables (including functions).
+-- The Boolean flag in 'VarInfo' is used to mark variables when they are used 
+-- within expressions.
+data IdInfo = ConsInfo | VarInfo Bool deriving Show
+
+--
+isVariable :: IdInfo -> Bool
+isVariable (VarInfo _) = True
+isVariable _           = False
+
+--
+isConstructor :: IdInfo -> Bool
+isConstructor ConsInfo = True
+isConstructor _        = False
+
+--
+variableVisited :: IdInfo -> Bool
+variableVisited (VarInfo v) = v
+variableVisited _           = True
+
+--
+visitVariable :: IdInfo -> IdInfo
+visitVariable info = case info of
+		       VarInfo _ -> VarInfo True
+		       _         -> info
+
+
+-- Data type for representing the current state of generating warnings.
+-- The monadic representation of the state allows the usage of monadic 
+-- syntax (do expression) for dealing easier and safer with its
+-- contents.
+data CheckState a = CheckState (CState () -> CState a)
+
+data CState a = CState {messages  :: [Message],
+			scope     :: ScopeEnv QualIdent IdInfo,
+			values    :: ValueEnv,
+			moduleId  :: ModuleIdent,
+			result    :: a
+		       }
+
+--
+emptyState :: CState ()
+emptyState = CState {messages  = [],
+		     scope     = ScopeEnv.new,
+		     values    = emptyTopEnv,
+		     moduleId  = mkMIdent [],
+		     result    = ()
+		    }
+
+--
+modifyScope :: (ScopeEnv QualIdent IdInfo -> ScopeEnv QualIdent IdInfo)
+	       -> CState a -> CState a
+modifyScope f state = state{ scope = f (scope state) }
+
+
+-- 'CheckState' is declared as an instance of 'Monad' to use its actions
+-- in 'do' expressions
+instance Monad CheckState where
+
+ -- (>>=) :: CheckState a -> (a -> CheckState b) -> CheckState b
+ (CheckState f) >>= g 
+    = CheckState (\state -> let state'       = f state
+		                CheckState h = g (result state')
+		            in  h (state'{ result = () }))
+
+ -- (>>) :: CheckState a -> CheckState b -> CheckState b
+ a >> b = a >>= (\_ -> b)
+
+ -- return :: a -> CheckState a
+ return val = CheckState (\state -> state{ result = val })
+
+
+--
+genWarning :: Position -> (WarningType,String) -> CheckState ()
+genWarning pos (warnType,msg)
+   = CheckState (\state -> state{ messages = warnMsg:(messages state) })
+ where warnMsg = message (Warning warnType) pos msg
+ 
+genWarning' :: (Position,WarningType,String) -> CheckState ()
+genWarning' (pos,warnType,msg)
+   = CheckState (\state -> state{ messages = warnMsg:(messages state) })
+ where warnMsg = message (Warning warnType) pos msg 
+
+--
+insertVar :: Ident -> CheckState ()
+insertVar id 
+   | isAnnonId id = return ()
+   | otherwise
+     = CheckState 
+         (\state -> modifyScope 
+	              (ScopeEnv.insert (commonId id) (VarInfo False)) state)
+
+--
+insertTypeVar :: Ident -> CheckState ()
+insertTypeVar id
+   | isAnnonId id = return ()
+   | otherwise    
+     = CheckState 
+         (\state -> modifyScope 
+	              (ScopeEnv.insert (typeId id) (VarInfo False)) state)
+
+--
+insertConsId :: Ident -> CheckState ()
+insertConsId id
+   = CheckState 
+       (\state -> modifyScope (ScopeEnv.insert (commonId id) ConsInfo) state)
+
+--
+insertTypeConsId :: Ident -> CheckState ()
+insertTypeConsId id
+   = CheckState 
+       (\state -> modifyScope (ScopeEnv.insert (typeId id) ConsInfo) state)
+
+--
+isVarId :: Ident -> CheckState Bool
+isVarId id
+   = CheckState (\state -> state{ result = isVar state (commonId id) })
+
+--
+isConsId :: Ident -> CheckState Bool
+isConsId id 
+   = CheckState (\state -> state{ result = isCons state (qualify id) })
+
+--
+isQualConsId :: QualIdent -> CheckState Bool
+isQualConsId qid
+   = CheckState (\state -> state{ result = isCons state qid })
+
+--
+isShadowingVar :: Ident -> CheckState Bool
+isShadowingVar id 
+   = CheckState 
+       (\state -> state{ result = isShadowing state (commonId id) })
+
+--
+isShadowingTypeVar :: Ident -> CheckState Bool
+isShadowingTypeVar id
+   = CheckState 
+       (\state -> state{ result = isShadowing state (typeId id) })
+
+--
+visitId :: Ident -> CheckState ()
+visitId id 
+   = CheckState 
+       (\state -> modifyScope 
+	            (ScopeEnv.modify visitVariable (commonId id)) state)
+
+--
+visitTypeId :: Ident -> CheckState ()
+visitTypeId id 
+   = CheckState 
+       (\state -> modifyScope 
+	            (ScopeEnv.modify visitVariable (typeId id)) state)
+
+--
+isUnrefVar :: Ident -> CheckState Bool
+isUnrefVar id 
+   = CheckState (\state -> state{ result = isUnref state (commonId id) })
+
+--
+isUnrefTypeVar :: Ident -> CheckState Bool
+isUnrefTypeVar id
+   = CheckState (\state -> state{ result = isUnref state (typeId id) })
+
+--
+returnUnrefVars :: CheckState [Ident]
+returnUnrefVars 
+   = CheckState (\state -> 
+	   	    let ids    = map fst (ScopeEnv.toLevelList (scope state))
+                        unrefs = filter (isUnref state) ids
+	            in  state{ result = map unqualify unrefs })
+
+--
+addModuleId :: ModuleIdent -> CheckState ()
+addModuleId mid = CheckState (\state -> state{ moduleId = mid })
+
+--
+returnModuleId :: CheckState ModuleIdent
+returnModuleId = CheckState (\state -> state{ result = moduleId state })
+
+--
+beginScope :: CheckState ()
+beginScope = CheckState (\state -> modifyScope ScopeEnv.beginScope state)
+
+--
+endScope :: CheckState ()
+endScope = CheckState (\state -> modifyScope ScopeEnv.endScopeUp state)
+
+
+-- Adds the content of a value environment to the state
+addImportedValues :: ValueEnv -> CheckState ()
+addImportedValues vals = CheckState (\state -> state{ values = vals })
+
+--
+foldM' :: (a -> CheckState ()) -> [a] -> CheckState ()
+foldM' f [] = return ()
+foldM' f (x:xs) = f x >> foldM' f xs
+
+--
+dropUnless' :: (a -> CheckState Bool) -> [a] -> CheckState [a]
+dropUnless' mpred [] = return []
+dropUnless' mpred (x:xs)
+   = do p <- mpred x
+	if p then return (x:xs) else dropUnless' mpred xs
+
+--
+partition' :: (a -> CheckState Bool) -> [a] -> CheckState ([a],[a])
+partition' mpred xs = part mpred [] [] xs
+ where
+ part mpred ts fs [] = return (reverse ts, reverse fs)
+ part mpred ts fs (x:xs)
+   = do p <- mpred x
+	if p then part mpred (x:ts) fs xs
+	     else part mpred ts (x:fs) xs
+
+--
+all' :: (a -> CheckState Bool) -> [a] -> CheckState Bool
+all' mpred [] = return True
+all' mpred (x:xs)
+   = do p <- mpred x
+	if p then all' mpred xs else return False
+
+
+-- Runs a 'CheckState' action and returns the list of messages
+run ::  CheckState a -> [Message]
+run (CheckState f)
+   = reverse (messages (f emptyState))
+
+
+-------------------------------------------------------------------------------
+
+--
+isShadowing :: CState a -> QualIdent -> Bool
+isShadowing state qid
+   = let sc = scope state
+     in  maybe False isVariable (ScopeEnv.lookup qid sc)
+	 && ScopeEnv.level qid sc < ScopeEnv.currentLevel sc
+
+--
+isUnref :: CState a -> QualIdent -> Bool
+isUnref state qid 
+   = let sc = scope state
+     in  maybe False (not . variableVisited) (ScopeEnv.lookup qid sc)
+         && ScopeEnv.level qid sc == ScopeEnv.currentLevel sc
+
+--
+isVar :: CState a -> QualIdent -> Bool
+isVar state qid = maybe (isAnnonId (unqualify qid)) 
+	           isVariable 
+		   (ScopeEnv.lookup qid (scope state))
+
+--
+isCons :: CState a -> QualIdent -> Bool
+isCons state qid = maybe (isImportedCons state qid)
+		         isConstructor
+			 (ScopeEnv.lookup qid (scope state))
+ where
+ isImportedCons state qid
+    = case (qualLookupValue qid (values state)) of
+        (DataConstructor _ _):_    -> True
+        (NewtypeConstructor _ _):_ -> True
+        _                          -> False
+
+
+--
+isAnnonId :: Ident -> Bool
+isAnnonId id = (name id) == "_"
+
+
+-- Since type identifiers and normal identifiers (e.g. functions, variables
+-- or constructors) don't share the same namespace, it is necessary
+-- to distinguish them in the scope environment of the check state.
+-- For this reason type identifiers are annotated with 1 and normal
+-- identifiers are annotated with 0.
+--
+commonId :: Ident -> QualIdent
+commonId id = qualify (unRenameIdent id)
+
+--
+typeId :: Ident -> QualIdent
+typeId id = qualify (renameIdent id 1)
+
+
+-------------------------------------------------------------------------------
+-- Warnings...
+
+unrefTypeVar :: Ident -> (Position,WarningType,String)
+unrefTypeVar id = 
+  (positionOfIdent id,
+   UnrefTypeVar,
+   "unreferenced type variable \"" ++ show id ++ "\"")
+
+unrefVar :: Ident -> (Position,WarningType,String)
+unrefVar id = 
+  (positionOfIdent id,
+   UnrefVar,
+   "unreferenced variable \"" ++ show id ++ "\"")
+
+shadowingVar :: Ident -> (Position,WarningType,String)
+shadowingVar id = 
+  (positionOfIdent id,
+   ShadowingVar,
+   "shadowing symbol \"" ++ show id ++ "\"")
+
+idleCaseAlts :: (WarningType,String)
+idleCaseAlts = (IdleCaseAlt,"idle case alternative(s)")
+
+overlappingCaseAlt :: (WarningType,String)
+overlappingCaseAlt = (OverlapCase,"redundant overlapping case alternative")
+
+rulesNotTogether :: Ident -> Position -> (Position,WarningType,String)
+rulesNotTogether id pos
+  = (positionOfIdent id,
+     RulesNotTogether,
+     "rules for function \"" ++ show id ++ "\" "    
+     ++ "are not together "
+     ++ "(first occurrence at " 
+     ++ show (line pos) ++ "." ++ show (column pos) ++ ")")
+
+multiplyImportedModule :: ModuleIdent -> (Position,WarningType,String)
+multiplyImportedModule mid 
+  = (positionOfModuleIdent mid,
+     MultipleImportModule,
+     "module \"" ++ show mid ++ "\" was imported more than once")
+
+multiplyImportedSymbol :: ModuleIdent -> Ident -> (Position,WarningType,String)
+multiplyImportedSymbol mid ident
+  = (positionOfIdent ident,
+     MultipleImportSymbol,
+     "symbol \"" ++ show ident ++ "\" was imported from module \""
+     ++ show mid ++ "\" more than once")
+
+multiplyHiddenSymbol :: ModuleIdent -> Ident -> (Position,WarningType,String)
+multiplyHiddenSymbol mid ident
+  = (positionOfIdent ident,
+     MultipleHiding,
+     "symbol \"" ++ show ident ++ "\" from module \"" ++ show mid
+     ++ "\" was hidden more than once")
+
+
+-------------------------------------------------------------------------------
+-- Miscellaneous
+
+-- safer versions of 'tail' and 'head'
+tail_ :: [a] -> [a] -> [a]
+tail_ alt []     = alt
+tail_ _   (_:xs) = xs
+
+head_ :: a -> [a] -> a
+head_ alt []    = alt
+head_ _   (x:_) = x
+
+--
+cmpListM :: Monad m => (a -> a -> m Bool) -> [a] -> [a] -> m Bool
+cmpListM cmpM []     []     = return True
+cmpListM cmpM (x:xs) (y:ys) = do c <- cmpM x y
+				 if c then cmpListM cmpM xs ys 
+				      else return False
+cmpListM cmpM _      _      = return False
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
diff --git a/src/currydoc.css b/src/currydoc.css
new file mode 100644
--- /dev/null
+++ b/src/currydoc.css
@@ -0,0 +1,34 @@
+/* Use monospace fonts for typewriter styles */
+pre, tt, code { font-family: monospace }
+
+/* Use always white background */
+body { background: white; color: black }
+
+/* Show hyperlinks without underscore */
+a:visited, a:link, a:active { text-decoration: none }
+
+.keyword { color:blue }
+.constructorname_constrpattern { color : #FF00FF }
+.constructorname_constrcall { color : #FF00FF }
+.constructorname_constrdecla { color : #FF00FF }
+.constructorname_otherconstrkind { color : #FF00FF }
+.typeconstructor_typedecla  { color : #ff7f50 }
+.typeconstructor_typeuse  { color : #ff7f50 }
+.typeconstructor_typeexport  { color : #ff7f50 }
+.function_infixfunction  { color : #800080 }
+.function_typsig  { color : #800080 }
+.function_fundecl  { color : #800080 }
+.function_functioncall  { color : #800080 }
+.function_otherfunctionkind  { color : #800080 }
+.moduleName  { color : #800000 }
+.commentary  { color : green }
+.numberCode  { color : #008080 }
+.stringCode  { color : #800000 }
+.charCode  { color : #800000 }
+.symbol  { color : #C0C0C0 }
+.identifier_iddecl   { color : black }
+.identifier_idoccur   { color : black }
+.identifier_unknownid   { color : black }
+.codeWarning  {font-weight: bold;font-style:italic; color : red }
+.codeError  { font-style:italic; color : #a52a2a }
+.notParsed  { font-style:italic; color : #C0C0C0 }
diff --git a/src/cymake.hs b/src/cymake.hs
new file mode 100644
--- /dev/null
+++ b/src/cymake.hs
@@ -0,0 +1,110 @@
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+--
+-- cymake - The Curry builder
+--
+--          Command line tool for generating Curry representations (e.g.
+--          FlatCurry, AbstractCurry) for a Curry source file including
+--          all imported modules.
+--
+-- September 2005,
+-- Martin Engelke (men@informatik.uni-kiel.de)
+--
+
+module Main(main) where
+
+import Data.List
+import Data.Maybe
+import System.IO
+import System.Environment
+import System.Exit
+import Control.Monad (unless)
+import Data.Char (isDigit)
+
+import GetOpt
+import CurryBuilder
+import CurryCompilerOpts
+import CurryHtml
+
+-------------------------------------------------------------------------------
+
+-- The command line tool.
+main :: IO ()
+main = do prog    <- getProgName
+	  args    <- getArgs
+	  cymake prog args 
+
+
+-------------------------------------------------------------------------------
+
+-- Checks the command line arguments and invokes the builder.
+cymake :: String -> [String] -> IO ()
+cymake prog args 
+   | elem Help opts = printUsage prog
+   | null files     = badUsage prog ["no files"]
+   | null errs' && not (elem Html opts)    = do
+       unless (noVerb options') 
+              (putStrLn  $ "This is cymake, version 1.1." 
+                         ++ filter isDigit "$Revision: 3620 $")
+       mapM_ (buildCurry options') files
+   | null errs' = do
+      let importFiles = nub $ importPaths opts'
+          outputFile  = maybe "" id (output opts')
+      mapM_ (source2html importFiles outputFile) files
+                              
+   | otherwise      = badUsage prog errs'
+ where
+ (opts, files, errs) = getOpt Permute options args
+ opts'    = foldr selectOption defaultOpts opts
+ options' = if  flat opts' || flatXml opts' 
+	        || abstract opts' || untypedAbstract opts' || parseOnly opts'
+	        then  opts'
+	        else  opts'{ flat = True }
+ errs'    = errs ++ check options' files
+
+
+-- Prints usage information of the command line tool.
+printUsage :: String -> IO ()
+printUsage prog
+   = do putStrLn (usageInfo header options)
+	exitWith ExitSuccess
+ where
+ header = "usage: " ++ prog ++ " [OPTION] ... MODULE ..."
+
+
+-- Prints errors
+badUsage :: String -> [String] -> IO ()
+badUsage prog errs
+   = do mapM (\err -> putErrLn (prog ++ ": " ++ err)) errs
+	abortWith ["Try '" ++ prog ++ " -" ++ "-help' for more information"]
+
+
+-- Checks options and files.
+check :: Options -> [String] -> [String]
+check opts files
+   | null files 
+     = ["no files"]
+   | isJust (output opts) && length files > 1
+     = ["cannot specify -o with multiple targets"]
+   | otherwise
+     = []
+
+
+-------------------------------------------------------------------------------
+-- Error handling
+
+-- Prints an error message on 'stderr'
+putErrLn :: String -> IO ()
+putErrLn = hPutStrLn stderr
+
+-- Prints a list of error messages on 'stderr'
+putErrsLn :: [String] -> IO ()
+putErrsLn = mapM_ putErrLn
+
+-- Prints a list of error messages on 'stderr' and aborts the program
+abortWith :: [String] -> IO a
+abortWith errs = putErrsLn errs >> exitWith (ExitFailure 1)
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------