packages feed

curry-frontend (empty) → 0.1

raw patch · 70 files changed

+24067/−0 lines, 70 filesdep +basedep +directorydep +filepathsetup-changed

Dependencies added: base, directory, filepath, mtl, old-time

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ curry-frontend.cabal view
@@ -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+
+ src/AbstractCurry.hs view
@@ -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"+  ++------------------------------------------------------------------------------+------------------------------------------------------------------------------
+ src/Arity.hs view
@@ -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+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/Base.lhs view
@@ -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}+++++
+ src/CaseCompletion.hs view
@@ -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)+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/Combined.lhs view
@@ -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}
+ src/CompilerResults.hs view
@@ -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 }+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/CurryBuilder.hs view
@@ -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 ++ "\""++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/CurryCompilerOpts.hs view
@@ -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)+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/CurryDeps.lhs view
@@ -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}
+ src/CurryEnv.hs view
@@ -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+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------++
+ src/CurryHtml.hs view
@@ -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+
+ src/CurryLexer.lhs view
@@ -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}
+ src/CurryPP.lhs view
@@ -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}
+ src/CurryParser.lhs view
@@ -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}
+ src/CurrySubdir.hs view
@@ -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
+ src/CurrySyntax.lhs view
@@ -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])
+ src/Desugar.lhs view
@@ -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}
+ src/Env.lhs view
@@ -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}
+ src/Error.lhs view
@@ -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}
+ src/Eval.lhs view
@@ -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}
+ src/Exports.lhs view
@@ -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}
+ src/ExtendedFlat.hs view
@@ -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++------------------------------------------------------------------------------+------------------------------------------------------------------------------+
+ src/Frontend.hs view
@@ -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\""+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/GenAbstractCurry.hs view
@@ -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)++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/GenFlatCurry.hs view
@@ -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)+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/GetOpt.hs view
@@ -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+-----------------------------------------------------------------------------------------+-}
+ src/IL.lhs view
@@ -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  ++
+ src/ILPP.lhs view
@@ -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}
+ src/ILScope.hs view
@@ -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+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/ILTrans.lhs view
@@ -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}+
+ src/ILxml.lhs view
@@ -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}
+ src/Ident.lhs view
@@ -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)
+ src/Imports.lhs view
@@ -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}
+ src/InterfaceCheck.hs view
@@ -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)+-}+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/KindCheck.lhs view
@@ -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}
+ src/LLParseComb.lhs view
@@ -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}
+ src/LexComb.lhs view
@@ -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}
+ src/Lift.lhs view
@@ -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}
+ src/Map.lhs view
@@ -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}
+ src/Message.hs view
@@ -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+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/Modules.lhs view
@@ -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}
+ src/NestEnv.lhs view
@@ -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}
+ src/OldScopeEnv.hs view
@@ -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)+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/PatchPrelude.hs view
@@ -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+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------+
+ src/PathUtils.lhs view
@@ -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}++++
+ src/Position.lhs view
@@ -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
+ src/PrecCheck.lhs view
@@ -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}
+ src/Pretty.lhs view
@@ -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}+
+ src/Qual.lhs view
@@ -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}
+ src/SCC.lhs view
@@ -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}
+ src/ScopeEnv.hs view
@@ -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+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/Set.lhs view
@@ -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}
+ src/ShowCurrySyntax.hs view
@@ -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 ")"++
+ src/Simplify.lhs view
@@ -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}
+ src/Subst.lhs view
@@ -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}
+ src/SyntaxCheck.lhs view
@@ -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}
+ src/SyntaxColoring.hs view
@@ -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
+ src/TopEnv.lhs view
@@ -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}
+ src/TypeCheck.lhs view
@@ -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}
+ src/TypeSubst.lhs view
@@ -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}
+ src/Types.lhs view
@@ -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}
+ src/Typing.lhs view
@@ -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}
+ src/Unlit.lhs view
@@ -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}
+ src/Utils.lhs view
@@ -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}
+ src/WarnCheck.hs view
@@ -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+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------
+ src/currydoc.css view
@@ -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 }
+ src/cymake.hs view
@@ -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)+++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------