packages feed

curry-frontend 0.2 → 0.2.1

raw patch · 81 files changed

+8225/−9440 lines, 81 files

Files

curry-frontend.cabal view
@@ -1,5 +1,5 @@ Name:          curry-frontend-Version:       0.2+Version:       0.2.1 Cabal-Version: >= 1.6 Synopsis:      Compile the functional logic language Curry to several intermediate formats Description:   The Curry Frontend consists of the executable program "cymake".@@ -26,20 +26,34 @@   hs-source-dirs:   src   Main-is:          cymake.hs   Build-Depends:    base >= 3 && < 4, mtl, old-time, directory, filepath, containers-  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+  ghc-options:      -fwarn-unused-binds -fwarn-unused-imports+-- -fwarn-incomplete-patterns+  Other-Modules:    Curry.Base.Position, Curry.Base.Ident, Curry.Base.MessageMonad+                    Curry.Syntax.Lexer, Curry.Syntax.LexComb+                    Curry.Syntax.Parser, Curry.Syntax.LLParseComb+                    Curry.Syntax.ShowModule, Curry.Syntax.Pretty+                    Curry.Syntax, Curry.Syntax.Type+                    Curry.Syntax.Unlit, Curry.Syntax.Utils+                    Curry.AbstractCurry, Curry.ExtendedFlat+                    CurryBuilder, IL.Type +                    CurryCompilerOpts, Modules, Subst, Arity+                    CurryDeps, Eval, IL.Pretty, NestEnv, SyntaxCheck, Base+                    Exports, IL.Scope, SyntaxColoring, CurryEnv+                    IL.CurryToIL, OldScopeEnv, CurryHtml+                    IL.XML, PatchPrelude, TopEnv, CaseCompletion+                    Imports, PathUtils, TypeCheck+                    InterfaceCheck, +                    Types, Frontend, PrecCheck                     TypeSubst, GenAbstractCurry-                    Pretty, Typing, Combined, CurrySyntax-                    GenFlatCurry, KindCheck, Qual, Unlit, CompilerResults-                    LexComb, SCC, Utils, GetOpt+                    PrettyCombinators, Typing+                    GenFlatCurry, KindCheck, Qual+                    SCC, Utils, GetOpt                     Lift, ScopeEnv, WarnCheck-                    LLParseComb, Desugar, Ident, ShowCurrySyntax+                    Desugar, Curry.Base.Ident,                      Simplify++-- Executable pretty-ecy+--   hs-source-dirs:   src+--   Main-is:          pretty-ecy.hs+--   Build-Depends:    base >= 3 && < 4
− src/AbstractCurry.hs 
@@ -1,282 +0,0 @@----------------------------------------------------------------------------------- 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
@@ -9,9 +9,10 @@ -- module Arity (bindArities) where -import Base-import CurrySyntax-import Ident+import Curry.Base.Ident+import Curry.Syntax++import Base(ArityEnv, bindArity)   -------------------------------------------------------------------------------
src/Base.lhs view
@@ -7,34 +7,30 @@ % \nwfilename{Base.lhs} \section{Common Definitions for the Compiler}-The module \texttt{Base} provides common definitions for the various -phases of the compiler.++The module \texttt{Base} implements the anti-pattern 'God-object'.+By providing common definitions for the various phases of the+compiler, it irrevocably turns the module structure into spaghetti.+(hsi)+ \begin{verbatim} -> module Base(module Base,module Ident,module Position,module Types,->             module CurrySyntax) where+> module Base where  > import Data.List > import Control.Monad > import Data.Maybe-> import qualified Data.Set as Set > import qualified Data.Map as Map -> import Ident -> import Position+> import Curry.Base.Ident +> import Curry.Base.Position > import Types-> import CurrySyntax-> import CurryPP-> import Pretty-> import ExtendedFlat hiding (SrcRef, Fixity(..), TypeExpr, Expr(..))-> import Env+> import Curry.Syntax+> import Curry.Syntax.Utils > import TopEnv-- > import Utils  -> import qualified ExtendedFlat as EF   \end{verbatim} \paragraph{Types}@@ -52,10 +48,10 @@ \begin{verbatim}  > toQualType :: ModuleIdent -> [Ident] -> TypeExpr -> Type-> toQualType m tvs ty = qualifyType m (toType tvs ty)+> toQualType m tvs = qualifyType m . toType tvs  > toQualTypes :: ModuleIdent -> [Ident] -> [TypeExpr] -> [Type]-> toQualTypes m tvs tys = map (qualifyType m) (toTypes tvs tys)+> toQualTypes m tvs = map (qualifyType m) . toTypes tvs  > toType :: [Ident] -> TypeExpr -> Type > toType tvs ty = toType' (Map.fromList (zip (tvs ++ tvs') [0..])) ty@@ -85,26 +81,8 @@ >	                        _ -> 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)+> fromQualType m = fromType . unqualifyType m  > fromType :: Type -> TypeExpr > fromType (TypeConstructor tc tys)@@ -113,7 +91,7 @@ >   | c == unitId && null tys = TupleType [] >   | otherwise = ConstructorType tc tys' >   where c = unqualify tc->         tys' = map (fromType) tys+>         tys' = map fromType tys > fromType (TypeVariable tv) = >   VariableType (if tv >= 0 then nameSupply !! tv >                            else mkIdent ('_' : show (-tv)))@@ -124,28 +102,8 @@ >   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@@ -158,85 +116,10 @@ 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+> type ModuleEnv = Map.Map ModuleIdent [IDecl]  > lookupModule :: ModuleIdent -> ModuleEnv -> Maybe [IDecl]-> lookupModule = lookupEnv+> lookupModule = Map.lookup  \end{verbatim} The label environment is used to store information of labels.@@ -249,19 +132,19 @@  > data LabelInfo = LabelType Ident QualIdent Type deriving Show -> type LabelEnv = Env Ident [LabelInfo]+> type LabelEnv = Map.Map 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)+>   maybe (Map.insert l [LabelType l r ty] lEnv)+>         (\ls -> Map.insert l (LabelType l r ty:ls) lEnv)+>         (Map.lookup l lEnv)  > lookupLabelType :: Ident -> LabelEnv -> [LabelInfo]-> lookupLabelType l lEnv = fromMaybe [] (lookupEnv l lEnv)+> lookupLabelType = Map.findWithDefault []  > initLabelEnv :: LabelEnv-> initLabelEnv = emptyEnv+> initLabelEnv = Map.empty   \end{verbatim}@@ -448,10 +331,10 @@  > qualLookupCons :: QualIdent -> ValueEnv -> [ValueInfo] > qualLookupCons x tyEnv->    | (maybe False ((==) preludeMIdent) mmid) && (id == consId)+>    | maybe False ((==) preludeMIdent) mmid && id == consId >       = qualLookupTopEnv (qualify id) tyEnv >    | otherwise = []->  where (mmid, id) = splitQualIdent x+>  where (mmid, id) = (qualidMod x, qualidId x)  > lookupTuple :: Ident -> [ValueInfo] > lookupTuple c@@ -502,11 +385,11 @@  > qualLookupConsArity :: QualIdent -> ArityEnv -> [ArityInfo] > qualLookupConsArity qid aEnv->    | (maybe False ((==) preludeMIdent) mmid) && (id == consId)+>    | maybe False ((==) preludeMIdent) mmid && id == consId >      = qualLookupTopEnv (qualify id) aEnv >    | otherwise >      = []->  where (mmid, id) = splitQualIdent qid+>  where (mmid, id) = (qualidMod qid, qualidId qid)  > lookupTupleArity :: Ident -> [ArityInfo] > lookupTupleArity id @@ -519,17 +402,17 @@ \paragraph{Module alias} \begin{verbatim} -> type ImportEnv = Env ModuleIdent ModuleIdent+> type ImportEnv = Map.Map ModuleIdent ModuleIdent  > bindAlias :: Decl -> ImportEnv -> ImportEnv-> bindAlias (ImportDecl _ mid _ mmid _) iEnv->    = bindEnv mid (fromMaybe mid mmid) iEnv+> bindAlias (ImportDecl _ mid _ mmid _)+>    = Map.insert mid (fromMaybe mid mmid)  > lookupAlias :: ModuleIdent -> ImportEnv -> Maybe ModuleIdent-> lookupAlias = lookupEnv+> lookupAlias = Map.lookup  > sureLookupAlias :: ModuleIdent -> ImportEnv -> ModuleIdent-> sureLookupAlias m iEnv = fromMaybe m (lookupAlias m iEnv)+> sureLookupAlias m = fromMaybe m . lookupAlias m   \end{verbatim}@@ -595,14 +478,9 @@ sufficient. \begin{verbatim} -> type EvalEnv = Env Ident EvalAnnotation+> type EvalEnv = Map.Map 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@@ -627,18 +505,16 @@  > 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))+>   where predefTC (TypeConstructor tc tys) =+>           predefTopEnv (qualify (unqualify tc)) .+>             DataType tc (length tys) . map Just  > 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 predefDC c ty = predefTopEnv c' (DataConstructor c' ty) >           where c' = qualify c >         constrType (ForAll n ty) n' = ForAllExist n n' . foldr TypeArrow ty @@ -646,11 +522,11 @@ > initAEnv >    = foldr bindPredefArity emptyTopEnv (concatMap snd predefTypes) >  where->  bindPredefArity (Data id _ ts) aEnv->     = bindArity preludeMIdent id (length ts) aEnv+>  bindPredefArity (Data id _ ts)+>     = bindArity preludeMIdent id (length ts)  > initIEnv :: ImportEnv-> initIEnv = emptyEnv+> initIEnv = Map.empty  > predefTypes :: [(Type,[Data [Type]])] > predefTypes =@@ -661,200 +537,7 @@   \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 (`Set.notMember` Set.fromList (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}@@ -937,18 +620,6 @@ >   | 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
@@ -15,13 +15,14 @@  import Data.Maybe -import qualified CurrySyntax+import Curry.Base.Position (SrcRef)+import Curry.Base.Ident+import qualified Curry.Syntax+ import Base (ModuleEnv, lookupModule)-import IL-import Ident-import Position (SrcRef)-import OldScopeEnv as ScopeEnv-import ILScope+import IL.Type+import OldScopeEnv -- as ScopeEnv+import IL.Scope   @@ -66,7 +67,7 @@ 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+   (expr', _, _) = visitExpr mod menv msgs (insertExprScope senv expr) expr  visitDecl mod menv msgs senv (ExternalDecl qident cconv name typeexpr)    = ((ExternalDecl qident cconv name typeexpr), msgs)@@ -108,8 +109,8 @@      = 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+   (expr', _, senv1) = visitExpr mod menv msgs (insertExprScope senv expr) expr+   (alts', _, senv2) = visitListWithEnv (visitAlt mod menv) insertAltScope msgs senv1 alts    (altsR, msgs3) = removeRedundantAlts msgs alts'    (expr2, senv3) = completeConsAlts r mod menv senv2 evalannot expr' altsR @@ -127,7 +128,7 @@ 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+   (expr', _, 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)@@ -224,8 +225,8 @@    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+       let args = OldScopeEnv.genIdentList arity "x" senv3+           senv4 = foldr OldScopeEnv.insertIdent senv3 args        in (ConstructorPattern qident args : cconstrs, senv4)  @@ -537,10 +538,10 @@ 	     (lookupModule mid' menv)  where    cons = head constrs-   (mmid', _) = splitQualIdent cons-   mid' = maybe mid id mmid' +   mid' = fromMaybe mid (qualidMod cons) + -- Find complementary constructors within the declarations of the -- current module getCCFromDecls :: ModuleIdent -> [QualIdent] -> [Decl] -> [(QualIdent, Int)]@@ -570,7 +571,7 @@   -- Find complementary constructors within the module environment-getCCFromIDecls :: ModuleIdent -> [QualIdent] -> [CurrySyntax.IDecl] +getCCFromIDecls :: ModuleIdent -> [QualIdent] -> [Curry.Syntax.IDecl]  		   -> [(QualIdent, Int)] getCCFromIDecls mident constrs idecls    = let@@ -583,30 +584,30 @@  where    p_declaresIConstr qident idecl       = case idecl of-	  CurrySyntax.IDataDecl _ _ _ cdecls+	  Curry.Syntax.IDataDecl _ _ _ cdecls 	      -> any (p_isIConstrDecl qident)  		     (map fromJust (filter isJust cdecls))-	  CurrySyntax.INewtypeDecl _ _ _ ncdecl +	  Curry.Syntax.INewtypeDecl _ _ _ ncdecl  	      -> p_isINewConstrDecl qident ncdecl 	  _   -> False -   p_isIConstrDecl qident (CurrySyntax.ConstrDecl _ _ ident _)+   p_isIConstrDecl qident (Curry.Syntax.ConstrDecl _ _ ident _)       = (unqualify qident) == ident-   p_isIConstrDecl qident (CurrySyntax.ConOpDecl _ _ _ ident _)+   p_isIConstrDecl qident (Curry.Syntax.ConOpDecl _ _ _ ident _)       = (unqualify qident) == ident -   p_isINewConstrDecl qident (CurrySyntax.NewConstrDecl _ _ ident _)+   p_isINewConstrDecl qident (Curry.Syntax.NewConstrDecl _ _ ident _)       = (unqualify qident) == ident     p_extractIConstrDecls idecl       = case idecl of-	  CurrySyntax.IDataDecl _ _ _ cdecls +	  Curry.Syntax.IDataDecl _ _ _ cdecls  	      -> map fromJust (filter isJust cdecls) 	  _   -> [] -   p_getIConstrDeclInfo mid (CurrySyntax.ConstrDecl _ _ ident types)+   p_getIConstrDeclInfo mid (Curry.Syntax.ConstrDecl _ _ ident types)       = (qualifyWith mid ident, length types)-   p_getIConstrDeclInfo mid (CurrySyntax.ConOpDecl _ _ _ ident _)+   p_getIConstrDeclInfo mid (Curry.Syntax.ConOpDecl _ _ _ ident _)       = (qualifyWith mid ident, 2)
− src/Combined.lhs 
@@ -1,166 +0,0 @@-% -*- 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 Control.Monad.Identity--\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 = StateT s Identity--> 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 = runIdentity . 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 Identity 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 = runIdentity . callRt rt--> envRt :: Monad m => ReaderT r m r-> envRt = ReaderT return --\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}
− src/CompilerResults.hs 
@@ -1,24 +0,0 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- 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/Curry/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 Curry.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/Curry/Base/Ident.lhs view
@@ -0,0 +1,352 @@+> {-# 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 Curry.Base.Ident(Ident(..), showIdent,+>                         QualIdent(..),ModuleIdent(..),SrcRefOf(..),+>                         mkIdent, qualName,+>                         renameIdent, unRenameIdent,+>                         mkMIdent, moduleName,+>                         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,+>                         recordExt, labelExt, mkLabelIdent,-- hasPositionIdent,+>                         addPositionIdent, +>                         addPositionModuleIdent,addRef,addRefId,+>                         positionOfQualIdent,updQualIdent ) where++> import Control.Monad(liftM)+> import Data.Char+> import Data.List+> import Data.Maybe+> import Data.Generics+> import Data.Function(on)++> import Curry.Base.Position+++Simple identifiers++> data Ident = Ident { positionOfIdent :: Position,+>                      name :: String,+>                      uniqueId :: Int }+>              deriving (Read, Data, Typeable)+>+> instance Eq Ident where+>     Ident _ m i == Ident _ n j = (m,i) == (n, j)+>+> instance Ord Ident where+>     Ident _ m i `compare` Ident _ n j = (m,i) `compare` (n, j)+>+> instance Show Ident where+>     show = showIdent+>+> showIdent :: Ident -> String+> showIdent  (Ident _ x 0) = x+> showIdent  (Ident _ x n) = x ++ '.' : show n+++Qualified identifiers++> data QualIdent = QualIdent { qualidMod :: Maybe ModuleIdent,+>                              qualidId:: Ident }+>                  deriving (Eq, Ord, Read, Data,Typeable)++> qualName :: QualIdent -> String+> qualName (QualIdent Nothing x) = name x+> qualName (QualIdent (Just m) x) = moduleName m ++ "." ++ name x++> instance Show QualIdent where+>     show = qualName++Module names++> data ModuleIdent = ModuleIdent { positionOfModuleIdent :: Position,+>                                  moduleQualifiers :: [String] }+>                    deriving (Read, Data,Typeable)++> instance Eq ModuleIdent where+>    (==) = (==) `on` moduleQualifiers++> instance Ord ModuleIdent where+>    compare = compare `on` moduleQualifiers++> moduleName :: ModuleIdent -> String+> moduleName = concat . intersperse "." . moduleQualifiers++> instance Show ModuleIdent where+>     show = moduleName++-- -----------------------------------------++> addPositionIdent :: Position -> Ident -> Ident+> addPositionIdent pos (Ident NoPos x n) = Ident pos x n+> addPositionIdent AST{ast=sr} (Ident pos x n)+>     =  Ident pos{ast=sr} x n+> addPositionIdent pos (Ident _ x n) = Ident pos x n++> addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent+> addPositionModuleIdent pos (ModuleIdent _ x) = ModuleIdent pos x ++> positionOfQualIdent :: QualIdent -> Position+> positionOfQualIdent = positionOfIdent . qualidId++> mkIdent :: String -> Ident+> mkIdent x = Ident NoPos x 0++> renameIdent :: Ident -> Int -> Ident+> renameIdent (Ident p x _) n = Ident p x n+++> unRenameIdent :: Ident -> Ident+> unRenameIdent (Ident p x _) = Ident p x 0++> mkMIdent :: [String] -> ModuleIdent+> mkMIdent = ModuleIdent NoPos++> 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"++> isQInfixOp :: QualIdent -> Bool+> 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 = QualIdent Nothing++> qualifyWith :: ModuleIdent -> Ident -> QualIdent+> qualifyWith = QualIdent . Just++> qualQualify :: ModuleIdent -> QualIdent -> QualIdent+> qualQualify m (QualIdent Nothing x) = QualIdent (Just m) x+> qualQualify _ x = x++> isQualified :: QualIdent -> Bool+> isQualified (QualIdent m _) = isJust m++> unqualify :: QualIdent -> Ident+> unqualify (QualIdent _ x) = x++> qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent+> qualUnqualify m qid@(QualIdent Nothing x) = qid+> qualUnqualify m (QualIdent (Just m') x) = QualIdent m'' x+>     where m'' | m == m' = Nothing+>               | otherwise    = Just m'++> localIdent :: ModuleIdent -> QualIdent -> Maybe Ident+> localIdent _ (QualIdent Nothing x) = Just x+> localIdent m (QualIdent (Just m') x)+>   | m == m' = Just x+>   | otherwise = Nothing++> splitQualIdent :: QualIdent -> (Maybe ModuleIdent,Ident)+> splitQualIdent (QualIdent m x) = (m,x)++> updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident) -> QualIdent -> QualIdent+> updQualIdent f g (QualIdent m x) = QualIdent (liftM f m) (g x)++> addRef :: SrcRef -> QualIdent -> QualIdent+> addRef r = updQualIdent id (addRefId r)++> addRefId :: SrcRef -> Ident -> Ident+> addRefId = addPositionIdent . AST++\end{verbatim}+A few identifiers a predefined here.+\begin{verbatim}++> emptyMIdent, mainMIdent, preludeMIdent :: ModuleIdent+> emptyMIdent   = ModuleIdent NoPos []+> mainMIdent    = ModuleIdent NoPos ["main"]+> preludeMIdent = ModuleIdent NoPos ["Prelude"]++> anonId :: Ident+> anonId = Ident NoPos "_" 0++> unitId, boolId, charId, intId, floatId, listId, ioId, successId :: Ident+> unitId    = Ident NoPos "()" 0+> boolId    = Ident NoPos "Bool" 0+> charId    = Ident NoPos "Char" 0+> intId     = Ident NoPos "Int" 0+> floatId   = Ident NoPos "Float" 0+> listId    = Ident NoPos "[]" 0+> ioId      = Ident NoPos "IO" 0+> successId = Ident NoPos "Success" 0++> trueId, falseId, nilId, consId :: Ident+> trueId  = Ident NoPos "True" 0+> falseId = Ident NoPos "False" 0+> nilId   = Ident NoPos "[]" 0+> consId  = Ident NoPos ":" 0++> tupleId :: Int -> Ident+> tupleId n+>   | n >= 2 = Ident NoPos ("(" ++ 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 NoPos "main" 0+> minusId = Ident NoPos "-" 0+> fminusId = Ident NoPos "-." 0++> qUnitId, qNilId, qConsId, qListId :: QualIdent+> qUnitId = QualIdent Nothing unitId+> qListId = QualIdent Nothing listId+> qNilId  = QualIdent Nothing nilId+> qConsId = QualIdent Nothing consId++> qBoolId, qCharId, qIntId, qFloatId, qSuccessId, qIOId :: QualIdent+> qBoolId = QualIdent (Just preludeMIdent) boolId+> qCharId = QualIdent (Just preludeMIdent) charId+> qIntId = QualIdent (Just preludeMIdent) intId+> qFloatId = QualIdent (Just preludeMIdent) floatId+> qSuccessId = QualIdent (Just preludeMIdent) successId+> qIOId = QualIdent (Just preludeMIdent) ioId++> qTrueId, qFalseId :: QualIdent+> qTrueId = QualIdent (Just preludeMIdent) trueId+> qFalseId = QualIdent (Just preludeMIdent) falseId++> qTupleId :: Int -> QualIdent+> qTupleId = QualIdent Nothing . 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 NoPos (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)+++> fpSelExt = "_#selFP"+> recSelExt = "_#selR@"+> recUpdExt = "_#updR@"+> recordExt = "_#Rec:"+> labelExt = "_#Lab:"+++> 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/Curry/Base/MessageMonad.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE FlexibleContexts #-}+{-+  The \texttt{MsgMonad} 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.+-}++module Curry.Base.MessageMonad where++import Control.Monad.Error+import Control.Monad.Writer+import Control.Monad.Identity++import Curry.Base.Position+++type MsgMonadT m = ErrorT WarnMsg (WriterT [WarnMsg] m)++type MsgMonad = MsgMonadT Identity++type MsgMonadIO = MsgMonadT IO++data WarnMsg = WarnMsg { warnPos :: Maybe Position,+                         warnTxt :: String+                       }+instance Error WarnMsg where+    noMsg = WarnMsg Nothing "Failure!"+    strMsg = WarnMsg Nothing++instance Show WarnMsg where+    show = showWarning++-- tell w = Control.Monad.Writer.tell w++showWarning w = "Warning: " ++ pos ++ warnTxt w+    where pos = case warnPos w of+                  Nothing -> ""+                  Just p -> show p ++": "++showError w = "Error: " ++ pos ++ warnTxt w+    where pos = case warnPos w of+                  Nothing -> ""+                  Just p -> show p ++": "++ok :: MsgMonad a -> a+ok = either (error . showError) id . fst . runMsg+++failWith :: (MonadError a m, Error a) => String -> m a1+failWith = throwError . strMsg+++failWithAt :: (MonadError WarnMsg m) => Position -> String -> m a+failWithAt p s  = throwError (WarnMsg (Just p) s)+++warnMessage :: (MonadWriter [WarnMsg] m) => String -> m ()+warnMessage s = tell [WarnMsg Nothing s]+++warnMessageAt :: (MonadWriter [WarnMsg] m) => Position -> String -> m ()+warnMessageAt p s  = tell [WarnMsg (Just p) s]++runMsg :: MsgMonad a -> (Either WarnMsg a, [WarnMsg])+runMsg = runIdentity . runWriterT . runErrorT++-- returnIO :: MsgMonad a -> MsgMonadIO a+-- returnIO x = return$ (runIdentity . runWriterT . runErrorT) x++runMsgIO :: MsgMonad a -> (a -> IO (MsgMonad b)) -> IO (MsgMonad b)+runMsgIO m f+    = case runMsg m of+        (Left e, msgs) -> return (tell msgs >> throwError e)+        (Right x, msgs) -> do m' <- f x+                              case runMsg m' of+                                (Left _,_) -> return m'+                                (Right x', msgs') -> return (tell (msgs ++ msgs') >> return x')++dropIO :: MsgMonad a -> MsgMonadIO a+dropIO x = case runMsg x of+             (Left e, m) -> tell m >> throwError e+             (Right x, m) -> tell m >> return x
+ src/Curry/Base/Position.lhs view
@@ -0,0 +1,96 @@+> {-# 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 Curry.Base.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 }+>   | NoPos+>     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+>   showsPrec _ NoPos = 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}+> incr p _ = p++> next :: Position -> Position+> next = flip incr 1++> tab :: Position -> Position+> tab p@Position{column=c} = p{column=c + tabWidth - (c - 1) `mod` tabWidth}+> tab p = p++> nl :: Position -> Position+> nl p@Position{line=l} = p{line=l + 1, column=1}+> nl p = p++> showLine :: Position -> String+> showLine NoPos = ""+> showLine AST{} = ""+> showLine Position{line=l,column=c} +>     = "(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/Curry/ExtendedFlat.hs view
@@ -0,0 +1,475 @@+------------------------------------------------------------------------------+--- 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 Curry.ExtendedFlat (SrcRef,Prog(..),+                           QName(..), qnOf,mkQName,+                           Visibility(..),+                           TVarIndex, TypeDecl(..), ConsDecl(..), TypeExpr(..),+                           OpDecl(..), Fixity(..),+                           VarIndex(..), mkIdx,+                           FuncDecl(..), Rule(..), +                           CaseType(..), CombType(..), Expr(..), BranchExpr(..),+                           Pattern(..), Literal(..), +		           readFlatCurry, readFlatInterface, readFlat, +		           writeFlatCurry,writeExtendedFlat,gshowsPrec+                          ) where++import Data.List(intersperse)+import Control.Monad (liftM)+import Data.Generics hiding (Fixity)+import Data.Function(on)+import System.FilePath++import PathUtils (writeModule, maybeReadModule)+import Filenames(flatName)+import Curry.Base.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)+++instance Read QName where+  readsPrec d r = +       [ (mkQName nm,s) | (nm,s) <- readsPrec d r ]+    ++ [ (QName r t m n, s) | ((r, t, m, n),s) <- readsPrec d r ]++instance Show QName where+  showsPrec d (QName r t m n)+      = showsPrec d (r,t,m,n)++instance Eq QName where (==) = (==) `on` qnOf++instance Ord QName where compare = compare `on` qnOf++mkQName :: (String,String) -> QName+mkQName = uncurry (QName Nothing Nothing)++qnOf :: QName -> (String,String) +qnOf QName{modName=m,localName=n} = (m,n)+++-------------------------------------------------------------------------+--- 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,+                    idxOf     :: Int+                } deriving (Data,Typeable)++onIndex :: (Int -> Int) -> VarIndex -> VarIndex+onIndex f (VarIndex{ typeofVar = t, idxOf = x})+    = VarIndex t (f x)++onIndexes :: (Int ->Int -> Int) -> VarIndex -> VarIndex -> VarIndex+onIndexes g x = VarIndex (typeofVar x) . (g `on` idxOf) x++mkIdx :: Int -> VarIndex+mkIdx = VarIndex Nothing+++instance Read VarIndex where+  readsPrec d r = +       [ (mkIdx i,s) | (i,s) <- readsPrec d r ]+    ++ [ (VarIndex t i,s) | ((t,i),s) <- readsPrec d r ]++instance Show VarIndex where+  showsPrec d (VarIndex t i)= showsPrec d (t,i)++instance Eq VarIndex where+    (==) = (==) `on` idxOf++instance Ord VarIndex where+    compare = compare `on` idxOf++instance Num VarIndex where+  (+) = onIndexes  (+)+  (*) = onIndexes  (*)+  (-) = onIndexes  (-)+  abs = onIndex abs+  signum = 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 = flatName 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 = replaceExtension fn ".fint"+        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' False prog)++-- Writes a FlatCurry program term with source references into a file.+writeExtendedFlat :: String -> Prog -> IO ()+writeExtendedFlat filename prog =+  writeModule (replaceExtension filename ".efc") (showFlatCurry' True prog)+++showFlatCurry' :: Bool -> Prog -> String+showFlatCurry' b x = gshowsPrec b False x ""++gshowsPrec :: Data a => Bool -> Bool -> a -> ShowS+gshowsPrec showType 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 d+                     `extQ`  showsVarIndex d+                                      +      where+        showsQName :: Bool -> QName -> ShowS+        showsQName d qn@QName{modName=m,localName=n,typeofQName=t} = +          if showType then showParen d (shows qn{srcRef=Nothing})+                      else shows (m,n)++        showsVarIndex :: Bool -> VarIndex -> ShowS+        showsVarIndex d+            | showType  = showParen d . shows+            | otherwise = shows . idxOf++        genericShowsPrec :: Data a => Bool -> a -> ShowS+        genericShowsPrec d t = let args = intersperse (showChar ' ') $+                                          gmapQ (gshowsPrec showType 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 showType False) xs)+                       ++        showsTuple :: (Data a,Data b) => (a,b) -> ShowS+        showsTuple (x,y) = showChar '(' . +                           gshowsPrec showType False x . +                           showChar ',' .+                           gshowsPrec showType 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/Curry/Syntax.hs view
@@ -0,0 +1,36 @@+module Curry.Syntax(module Curry.Syntax.Type,+                   parseModule, parseHeader+                   ) where++import Control.Monad+import Data.List++import Curry.Base.MessageMonad+import Curry.Syntax.Type++import qualified Curry.Syntax.Parser as CSP++import Curry.Syntax.Unlit++++parseModule :: Bool -> FilePath -> String -> MsgMonad Module+parseModule likeFlat fn =+  unlitLiterate fn >=> CSP.parseSource likeFlat fn+++parseHeader :: FilePath -> String -> MsgMonad Module+parseHeader fn =+  unlitLiterate fn >=> CSP.parseHeader fn++-- Literate source files use the extension ".lcurry"+unlitLiterate :: FilePath -> String -> MsgMonad String+unlitLiterate fn s+  | isLiterateSource fn = unlit fn s+  | otherwise = return s++isLiterateSource :: FilePath -> Bool+isLiterateSource fn = litExt `isSuffixOf` fn++litExt = ".lcurry"+
+ src/Curry/Syntax/LLParseComb.lhs view
@@ -0,0 +1,290 @@+% -*- 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 Curry.Syntax.LLParseComb(Symbol(..),Parser,+>                    applyParser,prefixParser, position,succeed,symbol,+>                    (<?>),(<|>),(<|?>),(<*>),(<\>),(<\\>),+>                    opt,(<$>),(<$->),(<*->),(<-*>),(<**>),(<??>),(<.>),+>                    many,many1, sepBy,sepBy1, chainr,chainr1,chainl,chainl1,+>                    bracket,ops, layoutOn,layoutOff,layoutEnd) where++> import Control.Monad+> import Data.Maybe+> import qualified Data.Set as Set+> import qualified Data.Map as Map++> import Curry.Syntax.LexComb+> import Curry.Base.MessageMonad+> import Curry.Base.Position+++> 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))+>                            (Map.Map 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 (Map.keysSet ps)++> applyParser :: Symbol s => Parser s a a -> Lexer s a -> FilePath -> String+>             -> MsgMonad 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+>              -> MsgMonad 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 Map.lookup 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) Map.empty+>   where p success _ pos = success pos pos++> succeed :: Symbol s => a -> Parser s a b+> succeed x = Parser (Just p) Map.empty+>   where p success _ = success x++> symbol :: Symbol s => s -> Parser s s a+> symbol s = Parser Nothing (Map.singleton s p)+>   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) Map.empty+>   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 (Set.null common) = error ("Ambiguous parser for " ++ show common)+>   | otherwise = Parser (e1 `mplus` e2) (Map.union ps1 ps2)+>   where common = Map.keysSet ps1 `Set.intersection` Map.keysSet 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) (Map.union ps1' ps2)+>   where ps1' = Map.fromList [(s,maybe p (try p) (Map.lookup s ps2))+>                           | (s,p) <- Map.toList 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)+>          (Map.union (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++\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.keys ps++> (<\\>) :: Symbol s => Parser s a b -> [s] -> Parser s a b+> Parser e ps <\\> xs = Parser e (foldr Map.delete 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) Map.empty+>   where on success _ pos = pushContext (column pos) . success undefined pos++> layoutOff :: Symbol s => Parser s a b+> layoutOff = Parser (Just off) Map.empty+>   where off success _ pos = pushContext (-1) . success undefined pos++> layoutEnd :: Symbol s => Parser s a b+> layoutEnd = Parser (Just end) Map.empty+>   where end success _ pos = popContext . success undefined pos++\end{verbatim}
+ src/Curry/Syntax/LexComb.lhs view
@@ -0,0 +1,104 @@+% -*- 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 Curry.Syntax.LexComb where++> import Data.Char++> import Curry.Base.MessageMonad+> import Curry.Base.Position++> infixl 1 `thenP`, `thenP_`++> type Indent = Int+> type Context = [Indent]+> type P a = Position -> String -> Bool -> Context -> MsgMonad a++> parse :: P a -> FilePath -> String -> MsgMonad 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 _ _ _ _ = return 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 _ _ _ _ = failWith (parseError pos msg)++> closeP0 :: P a -> P (P a)+> closeP0 lex pos s bol ctxt = return (\_ _ _ _ -> lex pos s bol ctxt)++> closeP1 :: (a -> P b) -> P (a -> P b)+> closeP1 f pos s bol ctxt = return (\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/Curry/Syntax/Lexer.lhs view
@@ -0,0 +1,630 @@++% $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 Curry.Syntax.Lexer (lexFile,lexer, Token (..), Category(..), Attributes(..)) where++> import Data.Char +> import Data.List+> import qualified Data.Map as Map++> import Curry.Syntax.LexComb+> import Curry.Base.Position++++\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 :: Map.Map String Category+> reserved_ops = Map.fromList [+>     ("@",  At),+>     ("::", DoubleColon),+>     ("..", DotDot),+>     ("=",  Equals),+>     ("\\", Backslash),+>     ("|",  Bar),+>     ("<-", LeftArrow),+>     ("->", RightArrow),+>     ("~",  Tilde),+>     (":=", Binds)+>   ]+> reserved_and_special_ops = foldr (uncurry Map.insert) reserved_ops [+>     (":",  Colon),+>     (".",  Sym_Dot),+>     ("-",  Sym_Minus),+>     ("-.", Sym_MinusDot)+>   ]++> reserved_ids, reserved_and_special_ids :: Map.Map String Category+> reserved_ids = Map.fromList [+>     ("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 Map.insert) 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)+>         (Map.lookup 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 (Map.lookup 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)+>         (Map.lookup 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)+>         (Map.lookup 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/Curry/Syntax/Parser.lhs view
@@ -0,0 +1,806 @@++% $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 Curry.Syntax.Parser where++> import Curry.Base.Ident+> import Curry.Base.Position+> import Curry.Base.MessageMonad+> import Curry.Syntax.LLParseComb+> import Curry.Syntax.Type+> import Curry.Syntax.Lexer++> instance Symbol Token where+>   isEOF (Token c _) = c == EOF++\end{verbatim}+\paragraph{Modules}+\begin{verbatim}++> parseSource :: Bool -> FilePath -> String -> MsgMonad Module+> parseSource flat path = +>    fmap addSrcRefs . applyParser ( moduleHeader <*> decls flat) lexer path++> parseHeader :: FilePath -> String -> MsgMonad Module+> parseHeader = prefixParser (moduleHeader <*->+>                             (leftBrace `opt` undefined) <*>+>                             many (importDecl <*-> many semicolon))+>                            lexer++> 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{Declarations}+\begin{verbatim}++> decls :: Bool -> Parser Token [Decl] a+> decls = layout . globalDecls++> 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 -> mkIdentPosition pos . sval) <$> 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 -> mkIdentPosition pos . sval) <$> 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 -> qualify . addPositionIdent p . tupleId . succ . length )+>               <$> 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 = foldr1 (<|>) . map token++> 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 = addPositionIdent pos . mkIdent++\end{verbatim}
+ src/Curry/Syntax/Pretty.lhs view
@@ -0,0 +1,367 @@++% $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 Curry.Syntax.Pretty where++> import Curry.Base.Ident+> import Curry.Syntax.Type++> import PrettyCombinators++\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}++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/Curry/Syntax/ShowModule.hs view
@@ -0,0 +1,499 @@+--- 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 Curry.Syntax.ShowModule ( showModule ) where++import Curry.Base.Ident+import Curry.Base.Position+import Curry.Syntax.Type++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 ")"++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 ")"+++showsIdent :: Ident -> ShowS+showsIdent (Ident _ name n)+  = showsString "(Ident " . shows name . space . shows n . showsString ")"++showsQualIdent :: QualIdent -> ShowS+showsQualIdent (QualIdent mident ident)+    = showsString "(QualIdent "+      . showsMaybe showsModuleIdent mident +      . space+      . showsIdent ident+      . showsString ")"++showsModuleIdent :: ModuleIdent -> ShowS+showsModuleIdent = shows . moduleName
+ src/Curry/Syntax/Type.lhs view
@@ -0,0 +1,315 @@+> {-# 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 Curry.Syntax.Type where++> import Curry.Base.Ident+> import Curry.Base.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}++> 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 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')+>         +>         next :: State Int SrcRef+>         next = do+>           i <- get+>           put $! i+1+>           return (SrcRef [i])
+ src/Curry/Syntax/Unlit.hs view
@@ -0,0 +1,57 @@+{-+  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.+-}+++module Curry.Syntax.Unlit(unlit) where++import Control.Monad(when, zipWithM)+import Data.Char++import Curry.Base.Position+import Curry.Base.MessageMonad+++data Line = Program !Int String+          | Blank | Comment++classify :: Int -> String -> Line+classify l ('>':cs)  = Program l cs+classify _ cs+  | all isSpace cs = Blank+  | otherwise      = Comment++{-+  Process a literate program into error messages (if any) and the+  corresponding non-literate program.+-}++unlit :: FilePath -> String -> MsgMonad String+unlit fn lcy = do ls <- progLines fn (zipWith classify [1..] $ lines lcy)+                  when (all null ls) $+                       failWith (fn ++ ": no code in literate script")+                  return (unlines ls)++{-+  Check that each program line is not adjacent to a comment line and+  there is at least one program line.+-}+progLines :: FilePath -> [Line] -> MsgMonad [String]+progLines fn cs +   = zipWithM adjacent (Blank : cs) cs+  where+    adjacent :: Line -> Line -> MsgMonad String+    adjacent (Program p _) Comment     = message fn p "followed"+    adjacent Comment     (Program p _) = message fn p "preceded"+    adjacent _ (Program _ s)           = return s+    adjacent _ _                       = return ""++message :: String -> Int -> String -> MsgMonad a+message file p w = failWithAt (Position file p 1 noRef) msg+    where msg = "When reading literate source: Program line is " ++ w ++ " by comment line."
+ src/Curry/Syntax/Utils.hs view
@@ -0,0 +1,202 @@+module Curry.Syntax.Utils(Expr, fv, qfv,+                          QuantExpr, bv) where++import qualified Data.Set as Set++import Curry.Base.Ident +import Curry.Syntax.Type++{-+  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.+-}++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 (`Set.notMember` Set.fromList (bv e))++{-+  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.+ -}++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)
src/CurryBuilder.hs view
@@ -13,16 +13,18 @@ import System.Exit import System.Time import Control.Monad+import qualified Data.Map as Map import Data.Maybe import Data.List  import System.IO -import Modules (compileModule_)+import Curry.Base.Ident++import Modules (compileModule) import CurryCompilerOpts  import CurryDeps-import Ident+import Filenames import PathUtils-import Env  ------------------------------------------------------------------------------- @@ -71,7 +73,7 @@   compileFile file     = do unless (noVerb options) (putStrLn ("compiling " ++ file ++ " ..."))-	 compileCurry (compOpts True) file+	 compileModule (compOpts True) file 	 return ()   skipFile file@@ -83,7 +85,7 @@ 		(putStrLn ("generating "   			   ++ (head (targetNames file))                			   ++ " ..."))-	 compileCurry (compOpts False) file+	 compileModule (compOpts False) file 	 return ()   targetNames fn         @@ -121,7 +123,7 @@ genDeps :: [FilePath] -> FilePath 	   -> IO ([(ModuleIdent,Source)], [String]) genDeps paths file-   = fmap (flattenDeps . sortDeps) (deps paths [] emptyEnv file)+   = fmap flattenDeps (deps paths [] Map.empty file)   -------------------------------------------------------------------------------@@ -168,9 +170,6 @@ -- outOfDate :: [ClockTime] -> [ClockTime] -> Bool outOfDate tgtimes dptimes = or (map (\t -> or (map ((<) t) dptimes)) tgtimes)---compileCurry = compileModule_  ------------------------------------------------------------------------------- -- Error handling
src/CurryDeps.lhs view
@@ -13,74 +13,34 @@ dependencies and to update programs composed of multiple modules. \begin{verbatim} -> module CurryDeps where+> module CurryDeps(Source(..),+>                  deps, flattenDeps, sourceDeps, moduleDeps+>                 ) where  > import Data.List+> import qualified Data.Map as Map > import Data.Maybe > import Control.Monad -> import Error-> import Ident-> import Unlit-> import CurrySyntax hiding(Interface(..))-> import CurryParser(parseHeader)-> import SCC-> import Env+> import Curry.Base.Ident+> import Curry.Base.MessageMonad +> import Curry.Syntax hiding(Interface(..))++> import SCC+> import Filenames > 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->           | takeExtension 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+> type SourceEnv = Map.Map ModuleIdent Source  > 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 == icurryExt = return Map.empty >   | e `elem` objectExts = targetDeps paths libraryPaths mEnv r >   | otherwise = targetDeps paths libraryPaths mEnv fn >   where r = dropExtension fn@@ -90,7 +50,7 @@ >            -> IO SourceEnv > targetDeps paths libraryPaths mEnv fn = >   lookupFile [""] sourceExts fn >>=->   maybe (return (bindEnv m Unknown mEnv)) (sourceDeps paths libraryPaths m mEnv)+>   maybe (return (Map.insert m Unknown mEnv)) (sourceDeps paths libraryPaths m mEnv) >   where m = mkMIdent [fn]  \end{verbatim}@@ -108,12 +68,6 @@ directories more than twice. \begin{verbatim} -> lookupModule :: [FilePath] -> [FilePath] -> ModuleIdent->              -> IO (Maybe FilePath)-> lookupModule paths libraryPaths m->     = lookupFile ("" : paths ++ libraryPaths) moduleExts fn->     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@@ -126,7 +80,7 @@ > moduleDeps :: [FilePath] -> [FilePath] -> SourceEnv -> ModuleIdent >            -> IO SourceEnv > moduleDeps paths libraryPaths mEnv m =->   case lookupEnv m mEnv of+>   case Map.lookup m mEnv of >     Just _ -> return mEnv >     Nothing -> >       do@@ -134,265 +88,55 @@ >         case mbFn of >           Just fn >             | icurryExt `isSuffixOf` fn ->->                 return (bindEnv m (Interface fn) mEnv)+>                 return (Map.insert m (Interface fn) mEnv) >             | otherwise -> sourceDeps paths libraryPaths m mEnv fn->           Nothing -> return (bindEnv m Unknown mEnv)+>           Nothing -> return (Map.insert 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) ->+>     case fst $ runMsg $ parseHeader fn s of+>       Right (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)+>         foldM (moduleDeps paths libraryPaths) (Map.insert m (Source fn ms) mEnv) ms+>       Left _ -> return (Map.insert 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) && dropExtension fn /= dropExtension 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"+> flattenDeps :: SourceEnv -> ([(ModuleIdent,Source)],[String])+> flattenDeps = fdeps . sortDeps+>     where+>     sortDeps :: SourceEnv -> [[(ModuleIdent,Source)]]+>     sortDeps = scc modules imports . Map.toList >->         oGen fn' | flat || xml || acy || uacy = []->                  | otherwise   = ["-o", head (targetNames fn')]+>     modules (m, _) = [m] >->         link fn' os = unwords ("link" : "-o" : fn' : os)+>     imports (_,Source _ ms) = ms+>     imports (_,Interface _) = []+>     imports (_,Unknown) = [] >->         flatInt m =->           case lookup m mEnv of->             Just (Source fn' _) ->	        -> Just (flatIntName fn')->             Just (Interface fn') ->	        -> Just (flatIntName (takeBaseName fn'))->             Just Unknown ->	        -> Nothing->             _ -> Nothing+>     fdeps :: [[(ModuleIdent,Source)]] -> ([(ModuleIdent,Source)],[String])+>     fdeps = foldr checkdep ([], [])+>     +>     checkdep [] (ms', es')  = (ms',es')+>     checkdep [m] (ms', es') = (m:ms',es')+>     checkdep dep (ms', es') = (ms',cyclicError (map fst dep) : es') >->         object (Source fn' _) = Just (head (targetNames fn'))->         object (Interface _) = Nothing->         object Unknown = Nothing+>     cyclicError :: [ModuleIdent] -> String+>     cyclicError (m:ms) =+>         "Cylic import dependency between modules " ++ show m ++ rest ms >->         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 -> IO (Maybe FilePath)-> getCurryPath paths fn->   = lookupFile filepaths exts fn->  where->  filepaths = "":paths'->  fnext = takeExtension fn->  exts | null fnext = sourceExts->       | otherwise  = [fnext]->  paths' | pathSeparator `elem` fn = []->         | otherwise               = paths---\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 = replaceExtension sfn icurryExt--> flatName :: FilePath -> FilePath-> flatName fn = replaceExtension fn flatExt--> flatIntName :: FilePath -> FilePath-> flatIntName fn = replaceExtension fn flatIntExt--> xmlName :: FilePath -> FilePath-> xmlName fn = replaceExtension fn xmlExt--> acyName :: FilePath -> FilePath-> acyName fn = replaceExtension fn acyExt--> uacyName :: FilePath -> FilePath-> uacyName fn = replaceExtension fn uacyExt--> sourceRepName :: FilePath -> FilePath-> sourceRepName fn = replaceExtension fn sourceRepExt--> objectName :: Bool -> FilePath -> FilePath-> objectName debug = name (if debug then debugExt else oExt)->   where name ext fn = replaceExtension 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}+>     rest [m] = " and " ++ show m+>     rest ms  = rest' ms+>     rest' [m] = ", and " ++ show m+>     rest' (m:ms) = ", " ++ show m ++ rest' ms
src/CurryEnv.hs view
@@ -7,12 +7,16 @@ -- November 2005, -- Martin Engelke (men@informatik.uni-kiel.de) ---module CurryEnv (CurryEnv, -		 moduleId, exports, imports, interface, infixDecls,-		 typeSynonyms, curryEnv) where+module CurryEnv (CurryEnv(..), curryEnv) where  import Data.Maybe +import Curry.Base.Position+import Curry.Base.Ident++import Curry.Syntax++import Types import Base  @@ -91,14 +95,14 @@ -- 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)+   = concatMap (genTypeSynDecl mident tcEnv) decls  ---genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> IDecl+genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> [IDecl] genTypeSynDecl mid tcEnv (TypeDecl pos ident params texpr)-   = genTypeDecl pos mid ident params tcEnv texpr+   = [genTypeDecl pos mid ident params tcEnv texpr] genTypeSynDecl _ _ _ -   = internalError "@CurryInfo.genTypeSynDecl: illegal declaration"+   = []  -- genTypeDecl :: Position -> ModuleIdent -> Ident -> [Ident] -> TCEnv@@ -166,17 +170,3 @@        [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
@@ -1,11 +1,17 @@-module CurryHtml(program2html,source2html) where+module CurryHtml(source2html) where -import SyntaxColoring-import Ident import Data.Char hiding(Space)-import CurryDeps(getCurryPath)-import PathUtils (writeModule)-       +import Control.Exception++import Curry.Base.Ident+import Curry.Base.MessageMonad++import SyntaxColoring+import PathUtils (readModule, writeModule, getCurryPath)+import Frontend+++ --- translate source file into HTML file with syntaxcoloring --- @param outputfilename --- @param sourcefilename@@ -21,8 +27,38 @@         (if null outputfilename then writeModule output                                  else writeFile   output)            (program2html modulname program)-   +             +--- @param importpaths+--- @param filename                  +--- @return program+filename2program :: [String] -> String -> IO Program+filename2program paths filename+    = do cont <- readModule filename+         typingParseResult <- (catchError (typingParse paths filename  cont))+         fullParseResult <- (catchError (fullParse paths filename  cont))+         parseResult <- (catchError (return (parse filename cont)))+         lexResult <- (catchError (return (Frontend.lex filename cont)))+         return (genProgram cont (typingParseResult : fullParseResult : [parseResult]) lexResult)+++--- 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   ++-- FIXME This is ugly. Avoid exceptions and report failure via MsgMonad instead! (hsi)+catchError :: Show a =>IO (MsgMonad a) -> IO (MsgMonad a)+catchError toDo = Control.Exception.catch (toDo >>= returnNF) handler +  where     +    -- This refers to base3+    handler (ErrorCall str) = return (failWith str)+    handler  e = return (failWith (show e))  +             +    returnNF a = normalform a `seq` return a+    normalform = length . show . runMsg+                        + --- generates htmlcode with syntax highlighting             --- @param modulname --- @param a program@@ -66,15 +102,11 @@ 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)       @@ -89,9 +121,8 @@                       (htmlQuote (code2string c))                                           spanTag :: String -> String -> String-spanTag cl str-   |null cl = str-   | otherwise = "<span class=\""++ cl ++ "\">" ++ str ++ "</span>"+spanTag [] str = str+spanTag cl str = "<span class=\""++ cl ++ "\">" ++ str ++ "</span>"  replace :: Char -> String -> String -> String replace old new = foldr (\ x -> if x == old then (new ++) else ([x]++)) ""@@ -101,7 +132,7 @@  addHtmlLink :: String -> QualIdent -> String addHtmlLink html qualIdent =-   let (maybeModuleIdent,ident) = splitQualIdent qualIdent in   +   let (maybeModuleIdent,ident) = (qualidMod qualIdent, qualidId qualIdent) in    "<a href=\"" ++     (maybe "" (\x -> show x ++ "_curry.html") maybeModuleIdent) ++     "#"++
− src/CurryLexer.lhs 
@@ -1,630 +0,0 @@--% $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 qualified Data.Map as Map--> import LexComb-> import Position----\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 :: Map.Map String Category-> reserved_ops = Map.fromList [->     ("@",  At),->     ("::", DoubleColon),->     ("..", DotDot),->     ("=",  Equals),->     ("\\", Backslash),->     ("|",  Bar),->     ("<-", LeftArrow),->     ("->", RightArrow),->     ("~",  Tilde),->     (":=", Binds)->   ]-> reserved_and_special_ops = foldr (uncurry Map.insert) reserved_ops [->     (":",  Colon),->     (".",  Sym_Dot),->     ("-",  Sym_Minus),->     ("-.", Sym_MinusDot)->   ]--> reserved_ids, reserved_and_special_ids :: Map.Map String Category-> reserved_ids = Map.fromList [->     ("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 Map.insert) 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)->         (Map.lookup 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 (Map.lookup 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)->         (Map.lookup 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)->         (Map.lookup 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 
@@ -1,369 +0,0 @@--% $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 
@@ -1,818 +0,0 @@--% $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/CurrySyntax.lhs 
@@ -1,323 +0,0 @@-> {-# 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
@@ -1,4 +1,3 @@- % $Id: Desugar.lhs,v 1.42 2004/02/15 22:10:32 wlux Exp $ % % Copyright (c) 2001-2004, Wolfgang Lux@@ -60,19 +59,25 @@ all names must be properly qualified before calling this module.} \begin{verbatim} -> module Desugar(desugar,desugarGoal) where+> module Desugar(desugar) where  > import Data.Maybe-> import Control.Monad+> import Control.Arrow(second)+> import Control.Monad.State as S > import Data.List +> import Curry.Base.Position+> import Curry.Base.Ident+> import Curry.Syntax.Utils+> import Curry.Syntax++> import Types > import Base-> import Combined > import Typing > import Utils-> import Ident  + posE = undefined  \end{verbatim}@@ -84,10 +89,10 @@ variables. \begin{verbatim} -> type DesugarState a = StateT ValueEnv (St Int) a+> type DesugarState a = S.StateT ValueEnv (S.State Int) a  > run :: DesugarState a -> ValueEnv -> a-> run m tyEnv = runSt (callSt m tyEnv) 1+> run m tyEnv = S.evalState (S.evalStateT m tyEnv) 1  \end{verbatim} The desugaring phase keeps only the type, function, and value@@ -115,90 +120,12 @@ >     dss <- mapM (desugarRecordDecl m tcEnv) ds >     let ds' = concat dss >     ds'' <- desugarDeclGroup m tcEnv ds'->     tyEnv' <- fetchSt+>     tyEnv' <- S.get >     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@@ -219,7 +146,7 @@ >     return (PatternDecl p t' rhs : concat dss') > desugarDeclLhs m tcEnv (FlatExternalDecl p fs) = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     return (map (externalDecl tyEnv p) fs) >   where externalDecl tyEnv p f = >           ExternalDecl p CallConvPrimitive (Just (name f)) f@@ -243,7 +170,7 @@ > desugarDeclRhs :: ModuleIdent -> TCEnv -> Decl -> DesugarState Decl > desugarDeclRhs m tcEnv (FunctionDecl p f eqs) = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     let ty =  (flip typeOf (Variable (qual f))) tyEnv >     liftM (FunctionDecl p f)  >	    (mapM (desugarEquation m tcEnv (arrowArgs ty)) eqs)@@ -278,7 +205,7 @@  > desugarLiteral :: Literal -> DesugarState (Either Literal ([SrcRef],[Literal])) > desugarLiteral (Char p c) = return (Left (Char p c))-> desugarLiteral (Int v i)  = liftM (Left . fixType) fetchSt+> desugarLiteral (Int v i)  = liftM (Left . fixType) S.get >   where  >    fixType tyEnv >      | typeOf tyEnv v == floatType @@ -312,12 +239,12 @@ > 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))+>     tyEnv <- S.get+>     liftM (if isNewtypeConstr tyEnv c then id else second (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)+>   liftM (second (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@@ -326,7 +253,7 @@ >   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)+>   liftM (second (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] @@ -334,13 +261,13 @@ >   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)+>   liftM (second (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 +>     do tyEnv <- S.get  >	 case (lookupValue (fieldLabel (head fs)) tyEnv) of >          [Label _ r _] ->  >            desugarRecordPattern m tcEnv p ds (map field2Tuple fs) r@@ -363,7 +290,7 @@ >     LazyPattern pos t' -> desugarLazy pos m p ds t' >     _ -> >       do->         v0 <- fetchSt >>= freshIdent m "_#lazy" . monoType . flip typeOf t+>         v0 <- S.get >>= freshIdent m "_#lazy" . monoType . flip typeOf t >         let v' = addPositionIdent (AST pos) v0 >         return (patDecl p{ast=pos} t (mkVar v') : ds,VariablePattern v') @@ -381,7 +308,7 @@ > desugarRhs :: ModuleIdent -> TCEnv -> Position -> Rhs -> DesugarState Rhs > desugarRhs m tcEnv p rhs = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     e' <- desugarExpr m tcEnv p (expandRhs tyEnv prelFailed rhs) >     return (SimpleRhs p e' []) @@ -431,7 +358,7 @@ >   liftM (apply prelEnumFromThenTo) (mapM (desugarExpr m tcEnv p) [e1,e2,e3]) > desugarExpr m tcEnv p (UnaryMinus op e) = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     liftM (Apply (unaryMinus op (typeOf tyEnv e))) (desugarExpr m tcEnv p e) >   where unaryMinus op ty >           | op == minusId =@@ -440,7 +367,7 @@ >           | otherwise = internalError "unaryMinus" > desugarExpr m tcEnv p (Apply (Constructor c) e) = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     liftM (if isNewtypeConstr tyEnv c then id else (Apply (Constructor c))) >           (desugarExpr m tcEnv p e) > desugarExpr m tcEnv p (Apply e1 e2) =@@ -466,7 +393,7 @@ >     return (Apply (Apply prelFlip op') e') > desugarExpr m tcEnv p exp@(Lambda r ts e) = >   do->     f <- fetchSt >>=+>     f <- S.get >>= >          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) =@@ -490,9 +417,9 @@ >   | otherwise = >       do >         e' <- desugarExpr m tcEnv p e->         v <- fetchSt >>= freshIdent m "_#case" . monoType . flip typeOf e+>         v <- S.get >>= freshIdent m "_#case" . monoType . flip typeOf e >         alts' <- mapM (desugarAltLhs m tcEnv) alts->         tyEnv <- fetchSt+>         tyEnv <- S.get >         alts'' <- mapM (desugarAltRhs m tcEnv) >                        (map (expandAlt tyEnv v) (init (tails alts'))) >         return (mkCase m v e' alts'')@@ -504,12 +431,12 @@ >   | otherwise = >       do let l = fieldLabel (head fs) >	       fs' = map field2Tuple fs->          tyEnv <- fetchSt+>          tyEnv <- S.get >	   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+>   do tyEnv <- S.get >      case (lookupValue l tyEnv) of >        [Label _ r _] -> desugarRecordSelection m tcEnv p r l e >        _ -> internalError "desugarExpr: illegal record selection"@@ -518,7 +445,7 @@ >   | otherwise = >       do let l = fieldLabel (head fs) >	       fs' = map field2Tuple fs->          tyEnv <- fetchSt+>          tyEnv <- S.get >	   case (lookupValue l tyEnv) of >            [Label _ r _] -> desugarRecordUpdate m tcEnv p r rexpr fs' >            _  -> internalError "desugarExpr: illegal record update"@@ -582,14 +509,14 @@ > desugarRecordDecl m tcEnv (TypeDecl p r vs (RecordType fss _)) = >   case (qualLookupTC r' tcEnv) of >     [AliasType _ n (TypeRecord fs' _)] ->->       do tyEnv <- fetchSt+>       do tyEnv <- S.get >	   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')+>	   S.modify (bindGlobalInfo DataConstructor m r rcts') >          return (rdecl:(concat rfuncs)) >     _ -> internalError "desugarRecordDecl: no record" >   where r' = qualifyWith m r@@ -637,7 +564,7 @@ > elimFunctionPattern m p [] = return ([],[]) > elimFunctionPattern m p (t:ts) >    | containsFunctionPattern t->      = do tyEnv <- fetchSt+>      = do tyEnv <- S.get >	    ident <- freshIdent m "_#funpatt" (monoType (typeOf tyEnv t)) >	    (ts',its') <- elimFunctionPattern m p ts >           return ((VariablePattern ident):ts', (ident,t):its')@@ -734,7 +661,7 @@ >              (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)+>	   S.modify (bindFun m selId selType . bindFun m updId updType) >	   return [selFunc,updFunc] >     _ -> internalError "genRecordFuncs: wrong type" @@ -805,7 +732,7 @@ >   | isVarPattern t = desugarExpr m tcEnv p (qualExpr t e l) >   | otherwise = >       do->         tyEnv <- fetchSt+>         tyEnv <- S.get >         v0 <- freshIdent m "_#var" (monoType (typeOf tyEnv t)) >         l0 <- freshIdent m "_#var" (monoType (typeOf tyEnv e)) >         let v  = addRefId refBind v0@@ -835,8 +762,8 @@ > freshIdent :: ModuleIdent -> String -> TypeScheme -> DesugarState Ident > freshIdent m prefix ty = >   do->     x <- liftM (mkName prefix) (liftSt (updateSt (1 +)))->     updateSt_ (bindFun m x ty)+>     x <- liftM (mkName prefix) (S.lift (S.modify succ >> S.get))+>     S.modify (bindFun m x ty) >     return x >   where mkName pre n = mkIdent (pre ++ show n) @@ -844,7 +771,6 @@ Prelude entities \begin{verbatim} -> prelUnif = Variable $ preludeIdent "=:=" > prelBind = prel ">>=" > prelBind_ = prel ">>" > prelFlip = Variable $ preludeIdent "flip"@@ -867,7 +793,7 @@  > truePattern = ConstructorPattern qTrueId [] > falsePattern = ConstructorPattern qFalseId []-> successPattern = ConstructorPattern (qualify successId) []+  > preludeIdent :: String -> QualIdent > preludeIdent = qualifyWith preludeMIdent . mkIdent
− src/Env.lhs 
@@ -1,55 +0,0 @@-% -*- 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 qualified Data.Map as Map--> newtype Env a b = Env (Map.Map a b) deriving Show--> emptyEnv :: Ord a => Env a b-> emptyEnv = Env Map.empty--> envToList :: Ord v => Env v e -> [(v,e)]-> envToList (Env rho) = Map.toList rho--> bindEnv :: Ord v => v -> e -> Env v e -> Env v e-> bindEnv v e (Env rho) = Env (Map.insert v e rho)--> unbindEnv :: Ord v => v -> Env v e -> Env v e-> unbindEnv v (Env rho) = Env (Map.delete v rho)--> lookupEnv :: Ord v => v -> Env v e -> Maybe e-> lookupEnv v (Env rho) = Map.lookup v rho--> envSize :: Ord v => Env v e -> Int-> envSize (Env rho) = Map.size rho--> instance Ord a => Functor (Env a) where->   fmap f (Env rho) = Env (fmap f rho)--\end{verbatim}
− src/Error.lhs 
@@ -1,35 +0,0 @@-% -*- 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---\end{verbatim}
src/Eval.lhs view
@@ -11,24 +11,24 @@ happens already while checking the definitions of the module. \begin{verbatim} -> module Eval(evalEnv,evalEnvGoal) where+> module Eval(evalEnv) where++> import qualified Data.Map as Map++> import Curry.Syntax > 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)+> evalEnv = foldr collectAnnotsDecl Map.empty  > collectAnnotsDecl :: Decl -> EvalEnv -> EvalEnv-> collectAnnotsDecl (EvalAnnot _ fs ev) env = foldr (flip bindEval ev) env fs+> collectAnnotsDecl (EvalAnnot _ fs ev) env = foldr (flip Map.insert ev) env fs > collectAnnotsDecl (FunctionDecl _ _ eqs) env = foldr collectAnnotsEqn env eqs > collectAnnotsDecl (PatternDecl _ _ rhs) env = collectAnnotsRhs rhs env > collectAnnotsDecl _ env = env
src/Exports.lhs view
@@ -19,6 +19,10 @@ > import qualified Data.Set as Set > import qualified Data.Map as Map +> import Curry.Syntax+> import Types+> import Curry.Base.Position+> import Curry.Base.Ident > import Base > import TopEnv @@ -40,7 +44,7 @@ >     Linear -> >       case linear ([c | ExportTypeWith _ cs <- es', c <- cs] ++ >                    [unqualify f | Export f <- es']) of->         Linear -> Module m (Just (Exporting noPos es')) ds+>         Linear -> Module m (Just (Exporting NoPos es')) ds >         NonLinear v -> errorAt' (ambiguousExportValue v) >     NonLinear tc -> errorAt' (ambiguousExportType tc)  >   where ms = Set.fromList [fromMaybe m asM | ImportDecl _ m _ asM _ <- ds]@@ -197,7 +201,7 @@ > 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)+>   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@@ -206,7 +210,7 @@ > 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+>   foldr (iInfixDecl m pEnv . qualifyLike (qualidMod tc)) ds cs >   where qualifyLike = maybe qualify qualifyWith  > iInfixDecl :: ModuleIdent -> PEnv -> QualIdent -> [IDecl] -> [IDecl]@@ -214,7 +218,7 @@ >   case qualLookupP op pEnv of >     [] -> ds >     [PrecInfo _ (OpPrec fix pr)] ->->       IInfixDecl noPos fix pr (qualUnqualify m op) : ds+>       IInfixDecl NoPos fix pr (qualUnqualify m op) : ds >     _ -> internalError "infixDecl"  > typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]@@ -226,7 +230,7 @@ >          (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+>           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@@ -240,7 +244,7 @@  > iTypeDecl :: (Position -> QualIdent -> [Ident] -> a -> IDecl) >            -> ModuleIdent -> QualIdent -> Int -> a -> IDecl-> iTypeDecl f m tc n = f noPos (qualUnqualify m tc) (take n nameSupply)+> iTypeDecl f m tc n = f NoPos (qualUnqualify m tc) (take n nameSupply)  > constrDecls :: ModuleIdent -> [Ident] -> [Ident] -> [Maybe (Data [Type])] >             -> [Maybe ConstrDecl]@@ -253,14 +257,14 @@  > 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+>   | 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) +>       IFunctionDecl NoPos (qualUnqualify m f) (arrowArity ty)  >		  (fromQualType m ty) : ds >     _ -> internalError ("funDecl: " ++ show f) > funDecl _ _ (ExportTypeWith _ _) ds = ds@@ -286,9 +290,8 @@ \begin{verbatim}  > usedModules :: [IDecl] -> [ModuleIdent]-> usedModules ds = nub (catMaybes (map modul (foldr identsDecl [] ds)))+> usedModules ds = nub (catMaybes (map qualidMod (foldr identsDecl [] ds))) >   where nub = Set.toList . Set.fromList->         modul = fst . splitQualIdent  > identsDecl :: IDecl -> [QualIdent] -> [QualIdent] > identsDecl (IDataDecl _ tc _ cs) xs =@@ -329,7 +332,7 @@ >     [RenamingType _ n _] -> hidingDataDecl tc n >     _ ->  internalError "hiddenTypeDecl" >   where hidingDataDecl tc n =->           HidingDataDecl noPos (unqualify tc) (take n nameSupply)+>           HidingDataDecl NoPos (unqualify tc) (take n nameSupply)  > hiddenTypes :: [IDecl] -> [QualIdent] > hiddenTypes ds = [tc | tc <- Set.toList tcs, not (isQualified tc)]
− src/ExtendedFlat.hs 
@@ -1,517 +0,0 @@----------------------------------------------------------------------------------- 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,writeExtendedFlat,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)-import System.FilePath------------------------------------------------------------------------------------ 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' False prog)---- Writes a FlatCurry program term with source references into a file.-writeExtendedFlat :: String -> Prog -> IO ()-writeExtendedFlat filename prog =-  writeModule (replaceExtension filename ".efc") (showFlatCurry' True 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' :: Bool -> Prog -> String-showFlatCurry' b x = gshowsPrec b False x ""--gshowsPrec :: Data a => Bool -> Bool -> a -> ShowS-gshowsPrec showType 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 d-                     `extQ`  showsVarIndex d-                                      -      where-        showsQName :: Bool -> QName -> ShowS-        showsQName d qn@QName{modName=m,localName=n,typeofQName=t} = -          if showType then showParen d (shows qn{srcRef=Nothing})-                      else shows (m,n)--        showsVarIndex :: Bool -> VarIndex -> ShowS-        showsVarIndex d v@VarIndex{index=i} = -          if showType then showParen d (shows v)-                      else shows i--        genericShowsPrec :: Data a => Bool -> a -> ShowS-        genericShowsPrec d t = let args = intersperse (showChar ' ') $-                                          gmapQ (gshowsPrec showType 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 showType False) xs)-                       --        showsTuple :: (Data a,Data b) => (a,b) -> ShowS-        showsTuple (x,y) = showChar '(' . -                           gshowsPrec showType False x . -                           showChar ',' .-                           gshowsPrec showType 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
@@ -7,37 +7,27 @@ -- December 2005, -- Martin Engelke (men@informatik.uni-kiel.de) ---module Frontend (lex, parse, fullParse, typingParse, abstractIO, flatIO,-		 Result(..), Message(..)-		)where+module Frontend (lex, parse, fullParse, typingParse)where -import Data.List import Data.Maybe-import Control.Monad+import qualified Data.Map as Map+import Control.Monad.Writer+import Control.Monad.Error 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+import Curry.Base.MessageMonad+import qualified Curry.Syntax as CS+import Curry.Syntax.Lexer +import CurryDeps+import Curry.Base.Ident+import Curry.Base.Position+import Filenames+import PathUtils+import Base(ModuleEnv)  ------------------------------------------------------------------------------- -------------------------------------------------------------------------------@@ -45,18 +35,15 @@ -- 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 [])+lex :: FilePath -> String -> MsgMonad [(Position,Token)]+lex fn src = 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]+parse :: FilePath -> String -> MsgMonad CS.Module+parse fn src = CS.parseModule True fn src >>= genCurrySyntax fn   -- Returns the syntax tree of the source program 'src' (type 'Module'; see@@ -65,26 +52,25 @@ -- 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)+fullParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad CS.Module)+fullParse paths fn src = -- liftM msgmonad2result $+                         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)+typingParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad 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)+abstractIO :: [FilePath] -> FilePath -> String -> IO (MsgMonad 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 @@ -92,17 +78,9 @@ -- 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":+flatIO :: [FilePath] -> FilePath -> String -> IO (MsgMonad FCY.Prog)+flatIO paths fn src = genFlatIO paths fn (parse fn src)+-}  ------------------------------------------------------------------------------- -------------------------------------------------------------------------------@@ -118,52 +96,45 @@   ---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]+genCurrySyntax :: FilePath -> CS.Module -> MsgMonad (CS.Module)+genCurrySyntax fn mod+    = let mod'@(CS.Module mid _ _) = patchModuleId fn (importPrelude fn mod)+      in if isValidModuleId fn mid+	 then return mod'+	 else failWith $ err_invalidModuleName mid   ---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)+genFullCurrySyntax :: (Options -> Base.ModuleEnv -> CS.Module -> IO (t1, t2, t3, CS.Module, t4, [WarnMsg]))+                   -> [FilePath] -> t -> MsgMonad CS.Module -> IO (MsgMonad CS.Module)+genFullCurrySyntax check paths fn m+   = runMsgIO m $ \mod -> do errs <- makeInterfaces paths mod+	                     if null errs+	                       then do mEnv <- loadInterfaces paths mod+		                       (_, _, _, mod', _, msgs') <- check (opts paths) mEnv mod+		                       return (tell msgs' >> return  mod')+	                       else return (failWith (head errs))  ----genAbstractIO :: [FilePath] -> FilePath -> Result CS.Module-	      -> IO (Result ACY.CurryProg)-genAbstractIO paths fn (Result msgs mod)-   = do errs <- makeInterfaces paths mod+{-+genAbstractIO :: [FilePath] -> FilePath -> MsgMonad CS.Module+	      -> IO (MsgMonad ACY.CurryProg)+genAbstractIO paths fn m+   = runMsgIO m $ \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)+		   return (tell msgs' >> return (genTypedAbstract tyEnv tcEnv mod'))+	   else return (failWith $ head errs)   ---genFlatIO :: [FilePath] -> FilePath -> Result CS.Module -> IO (Result FCY.Prog)-genFlatIO paths fn (Result msgs mod)-   = do errs <- makeInterfaces paths mod+genFlatIO :: [FilePath] -> FilePath -> MsgMonad CS.Module -> IO (MsgMonad FCY.Prog)+genFlatIO paths fn m+   = runMsgIO m $ \ mod -> +     do errs <- makeInterfaces paths mod 	if null errs then 	   (do mEnv <- loadInterfaces paths mod 	       (tyEnv, tcEnv, aEnv, mod', intf, msgs') <- @@ -174,10 +145,10 @@ 	           cEnv = curryEnv mEnv tcEnv intf mod' 	           (prog,msgs'') = genFlatCurry (opts paths) cEnv mEnv  	                                        tyEnv tcEnv aEnv' il'-               return (Result (msgs'' ++ msgs ++ msgs') prog)+               return (tell msgs'' >> tell msgs' >> return prog) 	   )-	   else return (Failure (msgs ++ map (message_ Error) errs))-genFlatIO _ _ (Failure msgs) = return (Failure msgs)+	   else return (failWith $ head errs)+-}   -------------------------------------------------------------------------------@@ -188,16 +159,15 @@ 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)+       (deps, errs) <- fmap flattenDeps (foldM (moduleDeps paths []) Map.empty 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)+	       (file':mapMaybe (flatInterface deps) mods)+	       (compileModule (opts paths) file')+	       (return Nothing) 	 return ()  compile _ _ = return () @@ -207,47 +177,12 @@ 	Just (Interface file) -> Just (flatIntName (dropExtension 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 [takeBaseName 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) == takeBaseName 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
src/GenAbstractCurry.hs view
@@ -10,17 +10,20 @@ module GenAbstractCurry (genTypedAbstract,  			 genUntypedAbstract) where +import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Maybe import Data.List import Data.Char -import AbstractCurry+import Curry.Syntax+import Curry.AbstractCurry+ import Base import Types-import Ident-import Position+import Curry.Base.Ident+import Curry.Base.Position import TopEnv-import Env   -------------------------------------------------------------------------------@@ -54,13 +57,13 @@ 	     = mapfoldl genImportDecl env (reverse (importDecls partitions)) 	 (types, _)  	     = mapfoldl genTypeDecl env (reverse (typeDecls partitions))-	 (funcs, _) -	     = mapfoldl (genFuncDecl False) +	 (_, funcs) +	     = Map.mapAccumWithKey (genFuncDecl False)  	                env  			(funcDecls partitions) 	 (ops, _)    	     = mapfoldl genOpDecl env (reverse (opDecls partitions))-     in  CurryProg modname imps types funcs ops+     in  CurryProg modname imps types (Map.elems funcs) ops   -------------------------------------------------------------------------------@@ -87,16 +90,16 @@ 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)}+   = partitions {opDecls = map (\id -> (InfixDecl pos fix prec [id])) idents+		           ++ opDecls partitions } partitionDecl partitions decl    = case decl of        ImportDecl _ _ _ _ _ -         -> partitions {importDecls = decl:(importDecls partitions)}+         -> partitions {importDecls = decl: importDecls partitions }        DataDecl _ _ _ _     -         -> partitions {typeDecls = decl:(typeDecls partitions)}+         -> partitions {typeDecls = decl : typeDecls partitions }        TypeDecl _ _ _ _     -         -> partitions {typeDecls = decl:(typeDecls partitions)}+         -> partitions {typeDecls = decl : typeDecls partitions }        _ -> partitions  @@ -106,7 +109,7 @@    = partitions {funcDecls = foldl partitionFuncDecl (funcDecls partitions) ids}  where    partitionFuncDecl funcs' id-      = insertEntry id ((genDecl id):(fromMaybe [] (lookup id funcs'))) funcs'+      = Map.insert id (genDecl id : fromMaybe [] (Map.lookup id funcs')) funcs'   -- Data type for representing partitions of CurrySyntax declarations@@ -117,14 +120,14 @@ -- to collect them within an association list data Partitions = Partitions {importDecls :: [Decl], 			      typeDecls   :: [Decl],-			      funcDecls   :: [(Ident,[Decl])],+			      funcDecls   :: Map.Map Ident [Decl], 			      opDecls     :: [Decl] 			     } deriving Show  -- Generates initial partitions. emptyPartitions = Partitions {importDecls = [], 			      typeDecls   = [],-			      funcDecls   = [],+			      funcDecls   = Map.empty, 			      opDecls     = [] 			     }  @@ -202,15 +205,15 @@          (ls,ts) = unzip fs          (ts',env1) = mapfoldl genTypeExpr env ts          ls' = map name ls-     in  case mr of+     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) +           (Just r@(RecordType _ _))+             -> let (CRecordType fields rbase, env2) = genTypeExpr env1 r+		    fields' = foldr (uncurry insertEntry)  				    fields 			            (zip ls' ts') 		in  (CRecordType fields' rbase, env2)@@ -240,8 +243,8 @@ --   - 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)+genFuncDecl :: Bool -> AbstractEnv -> Ident -> [Decl] -> (AbstractEnv, CFuncDecl)+genFuncDecl isLocal env ident decls    | not (null decls)      = let name          = genQName False env (qualify ident) 	   visibility    = genVisibility env ident@@ -255,21 +258,21 @@ 			         (\ (FunctionDecl _ _ equs) 				  -> mapfoldl genRule env1 equs) 				 (find isFunctionDecl decls)-           mexternal     = applyMaybe genExternal (find isExternal decls)+           mexternal     = fmap 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)+       in  (env3, CFunc name arity visibility typeexpr rule)    | otherwise      = internalError ("missing declaration for function \"" 		      ++ show ident ++ "\"")  where    genFuncType env decls       | acytype == UntypedAcy-	= applyMaybe (genTypeSig env) (find isTypeSig decls)+	= fmap (genTypeSig env) (find isTypeSig decls)       | acytype == TypedAcy-	= applyMaybe (genTypeExpr env) mftype+	= fmap (genTypeExpr env) mftype       | otherwise  	= Nothing     where @@ -300,7 +303,7 @@ 		mtypeexpr     compArityFromType (CTVar _)        = 0-   compArityFromType (CFuncType _ t2) = 1 + (compArityFromType t2)+   compArityFromType (CFuncType _ t2) = 1 + compArityFromType t2    compArityFromType (CTCons _ _)     = 0     compRule evalannot rules mexternal@@ -371,7 +374,7 @@     -- The association list 'fdecls' is necessary because function    -- rules may not be together in the declaration list-   genLocals :: AbstractEnv -> [(Ident,[Decl])] -> [Decl] +   genLocals :: AbstractEnv -> Map.Map Ident [Decl] -> [Decl]  	        -> ([CLocalDecl], AbstractEnv)    genLocals env _ [] = ([], env)    genLocals env fdecls ((FunctionDecl _ ident _):decls)@@ -390,15 +393,15 @@ 	      (locals, env2)  		= genLocals (endScope env1) 		            fdecls -			    ((FlatExternalDecl pos (tail idents)):decls)+			    (FlatExternalDecl pos (tail idents):decls)           in  (funcdecl:locals, env2)-   genLocals env fdecls ((PatternDecl pos constr rhs):decls)+   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)+	in  (CLocalPat patt expr plocals:locals, env4)    genLocals env fdecls ((ExtraVariables pos idents):decls)       | null idents  = genLocals env fdecls decls       | otherwise@@ -408,23 +411,23 @@ 					 ++ " for free variable \"" 					 ++ show ident ++ "\"")) 		         (getVarIndex env ident)-	      decls' = (ExtraVariables pos (tail idents)):decls+	      decls' = ExtraVariables pos (tail idents) : decls 	      (locals, env') = genLocals env fdecls decls'-          in  ((CLocalVar (idx, name ident)):locals, env')+          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 +   genLocalFuncDecl :: AbstractEnv -> Map.Map 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)+		      (Map.lookup ident fdecls)+	    (_, funcdecl) = genFuncDecl True env ident fdecl         in  (CLocalFunc funcdecl, env)     genLocalPattern pos env (LiteralPattern lit)@@ -477,7 +480,7 @@       = let (fields', env1) = mapfoldl (genField genLocalPattern) env fields 	    (mr', env2) 		= maybe (Nothing, env1)-		        ((applyFst Just) . (genLocalPattern pos env1))+		        (applyFst Just . genLocalPattern pos env1) 			mr 	in  (CPRecord fields' mr', env2) @@ -518,7 +521,7 @@ 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)+     in  genExpr pos env (foldr (Apply . Apply cons) nil args) genExpr pos env (ListCompr _ expr stmts)    = let (stmts', env1) = mapfoldl (genStatement pos) (beginScope env) stmts 	 (expr', env2)  = genExpr pos env1 expr@@ -659,7 +662,7 @@ genPattern pos env (RecordPattern fields mr)    = let (fields', env1) = mapfoldl (genField genPattern) env fields          (mr', env2)     = maybe (Nothing, env1)-                                 ((applyFst Just) . (genPattern pos env1))+                                 (applyFst Just . genPattern pos env1) 				 mr      in  (CPRecord fields' mr', env2) @@ -693,12 +696,10 @@    | otherwise      = genQualName qident  where-  ident = unqualify qident-   genQualName qid-     = let (mmid, id) = splitQualIdent qid+     = let (mmid, id) = (qualidMod qid, qualidId qid) 	   mid = maybe (moduleId env)-		       (\mid' -> fromMaybe mid' (lookupEnv mid' (imports env)))+		       (\mid' -> fromMaybe mid' (Map.lookup mid' (imports env))) 		       mmid        in  (moduleName mid, name id) @@ -749,12 +750,12 @@ data AbstractEnv = AbstractEnv {moduleId   :: ModuleIdent, 				typeEnv    :: ValueEnv, 				tconsEnv   :: TCEnv,-				exports    :: Env Ident (),-				imports    :: Env ModuleIdent ModuleIdent,+				exports    :: Set.Set Ident,+				imports    :: Map.Map ModuleIdent ModuleIdent, 				varIndex   :: Int, 				tvarIndex  :: Int,-				varScope   :: [Env Ident Int],-				tvarScope  :: [Env Ident Int],+				varScope   :: [Map.Map Ident Int],+				tvarScope  :: [Map.Map Ident Int],                                 acyType    :: AbstractType 			       } deriving Show @@ -770,12 +771,12 @@        {moduleId     = mid, 	typeEnv      = tyEnv, 	tconsEnv     = tcEnv,-	exports      = foldl (buildExportTable mid decls) emptyEnv exps',-	imports      = foldl buildImportTable emptyEnv decls,+	exports      = foldl (buildExportTable mid decls) Set.empty exps',+	imports      = foldl buildImportTable Map.empty decls, 	varIndex     = 0, 	tvarIndex    = 0,-	varScope     = [emptyEnv],-	tvarScope    = [emptyEnv],+	varScope     = [Map.empty],+	tvarScope    = [Map.empty],         acyType      = absType        }  where@@ -785,25 +786,25 @@ -- 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 (DataDecl _ ident _ _:ds) +   = ExportTypeAll (qualifyWith mid ident) : buildExports mid ds buildExports mid ((NewtypeDecl _ ident _ _):ds)-   = (ExportTypeAll (qualifyWith mid ident)):(buildExports mid ds)+   = ExportTypeAll (qualifyWith mid ident) : buildExports mid ds buildExports mid ((TypeDecl _ ident _ _):ds)-   = (Export (qualifyWith mid ident)):(buildExports mid 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)+   = 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 :: ModuleIdent -> [Decl] -> Set.Set Ident -> Export +                 -> Set.Set Ident buildExportTable mid _ exptab (Export qident)    | isJust (localIdent mid qident)      = insertExportedIdent exptab (unqualify qident)@@ -826,8 +827,8 @@ buildExportTable _ _ exptab (ExportModule _) = exptab  ---insertExportedIdent :: Env Ident () -> Ident -> Env Ident ()-insertExportedIdent env ident = bindEnv ident () env+insertExportedIdent :: Set.Set Ident -> Ident -> Set.Set Ident+insertExportedIdent env ident = Set.insert ident env  -- getConstrIdents :: Decl -> [Ident]@@ -839,16 +840,16 @@   -- Builds a table for dereferencing import aliases-buildImportTable :: Env ModuleIdent ModuleIdent -> Decl-		    -> Env ModuleIdent ModuleIdent+buildImportTable :: Map.Map ModuleIdent ModuleIdent -> Decl+		    -> Map.Map ModuleIdent ModuleIdent buildImportTable env (ImportDecl _ mid _ malias _)-   = bindEnv (fromMaybe mid malias) mid env+   = Map.insert (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))+isExported env ident = Set.member ident (exports env)   -- Generates an unique index for the  variable 'ident' and inserts it@@ -857,9 +858,9 @@ genVarIndex env ident     = let idx   = varIndex env          vtabs = varScope env-	 vtab  = head vtabs --if null vtabs then emptyEnv else head vtabs+	 vtab  = head vtabs --if null vtabs then Map.empty else head vtabs      in  (idx, env {varIndex = idx + 1,-		    varScope = (bindEnv ident idx vtab):(sureTail vtabs)})+		    varScope = Map.insert 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.@@ -867,20 +868,20 @@ genTVarIndex env ident    = let idx   = tvarIndex env          vtabs = tvarScope env-	 vtab  = head vtabs --if null vtabs then emptyEnv else head vtabs+	 vtab  = head vtabs --if null vtabs then Map.empty else head vtabs      in  (idx, env {tvarIndex = idx + 1,-		    tvarScope = (bindEnv ident idx vtab):(sureTail vtabs)})+		    tvarScope = Map.insert 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))+getVarIndex env ident = Map.lookup 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))+getTVarIndex env ident = Map.lookup ident (head (tvarScope env))   -- Generates an indentifier which doesn't occur in the variable table@@ -895,31 +896,18 @@          = 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]}+		      varScope  = [Map.empty],+		      tvarScope = [Map.empty]}  -- 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}+beginScope env = env {varScope  = head vs :vs,+		      tvarScope = head tvs :tvs }  where  vs  = varScope env  tvs = tvarScope env@@ -969,7 +957,7 @@ -- Checks, whether a symbol is defined in the Prelude. isPreludeSymbol :: QualIdent -> Bool isPreludeSymbol qident-   = let (mmid, ident) = splitQualIdent qident+   = let (mmid, ident) = (qualidMod qident, qualidId qident)      in  (isJust mmid && preludeMIdent == fromJust mmid)          || elem ident [unitId, listId, nilId, consId] 	 || isTupleId ident@@ -986,7 +974,7 @@ qualLookupType :: QualIdent -> ValueEnv -> Maybe TypeExpr qualLookupType qident tyEnv    = case (qualLookupValue qident tyEnv) of-       [Value _ ts] -> (\ (ForAll _ ty) -> Just (toCSType ty)) ts+       [Value _ ts] -> (\ (ForAll _ ty) -> Just (fromType ty)) ts        _            -> Nothing  -- Looks up the type of a symbol in the type environment and@@ -994,66 +982,14 @@ lookupType :: Ident -> ValueEnv -> Maybe TypeExpr lookupType ident tyEnv    = case (lookupValue ident tyEnv) of-       [Value _ ts] -> (\ (ForAll _ ty) -> Just (toCSType ty)) ts+       [Value _ ts] -> (\ (ForAll _ ty) -> Just (fromType 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)+simplifyLhs = snd . flatLhs  simplifyRhsExpr :: Rhs -> [(Expression, Expression)] simplifyRhsExpr (SimpleRhs _ expr _) @@ -1066,11 +1002,7 @@ 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-+-- FIXME This mapfold is a twisted mapAccumL -- 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)@@ -1084,7 +1016,7 @@ insertEntry k e [] = [(k,e)] insertEntry k e ((x,y):xys)    | k == x    = (k,e):xys-   | otherwise = (x,y):(insertEntry k e xys)+   | otherwise = (x,y) : insertEntry k e xys   -- Returns the list without the first element. If the list is empty, an
src/GenFlatCurry.hs view
@@ -15,32 +15,27 @@ import Data.Maybe import Data.List import qualified Data.Map as Map-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 Curry.Base.MessageMonad+import Curry.Base.Ident as Id +import Base {-(ArityEnv, ArityInfo(..), ModuleEnv,  +	     TCEnv, TypeInfo(..), ValueEnv, ValueInfo(..),+	     lookupValue, qualLookupTC,+	     qualLookupArity, lookupArity,  internalError,+             qualLookupValue)-}+import Curry.ExtendedFlat+import qualified IL.Type as IL+import qualified IL.CurryToIL as IL+import qualified Curry.Syntax 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 Debug.Trace  trace _ x = x @@ -48,7 +43,7 @@  -- transforms intermediate language code (IL) to FlatCurry code genFlatCurry :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -		-> ArityEnv -> IL.Module -> (Prog, [Message])+		-> ArityEnv -> IL.Module -> (Prog, [WarnMsg]) genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv mod    = (patchPreludeFCY prog, messages)  where (prog, messages) @@ -57,7 +52,7 @@  -- transforms intermediate language code (IL) to FlatCurry interfaces genFlatInterface :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv-		 -> ArityEnv -> IL.Module -> (Prog, [Message])+		 -> ArityEnv -> IL.Module -> (Prog, [WarnMsg]) genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv mod    = (patchPreludeFCY intf, messages)  where (intf, messages) @@ -177,16 +172,19 @@    = liftM Var (lookupVarIndex ident) visitExpression (IL.Function qident _)    = do arity_ <- lookupIdArity qident+        qname <- visitQualIdent qident+   --     ftype <- lookupIdType qident+   --     let qident' = qname{ typeofQName = ftype } 	maybe (internalError (funcArity qident))-	      (\arity -> genFuncCall qident arity [])+	      (\arity -> genFuncCall qname 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.Apply e1 e2)+   = genFlatApplication e1 e2 visitExpression (IL.Case r evalannot expression alts)    = do ea       <- visitEval evalannot 	expr     <- visitExpression expression@@ -208,12 +206,10 @@ 	newVarIndex (bindingIdent binding)         bind <- visitBinding binding 	expr <- visitExpression expression-	case expr of-	  Let binds expr' -> return (Let (bind:binds) expr')-	  _               -> return (Let [bind] expr)+        return (Let [bind] expr) visitExpression (IL.Letrec bindings expression)    = do beginScope-	mapM_ newVarIndex (map bindingIdent bindings)+	mapM_ (newVarIndex . bindingIdent) bindings 	binds <- mapM visitBinding bindings 	expr  <- visitExpression expression 	endScope@@ -275,8 +271,8 @@  -- visitEval :: IL.Eval -> FlatState CaseType-visitEval IL.Rigid = return (Rigid)-visitEval IL.Flex  = return (Flex)+visitEval IL.Rigid = return Rigid+visitEval IL.Flex  = return Flex  -- visitBinding :: IL.Binding -> FlatState (VarIndex, Expr)@@ -300,8 +296,8 @@ 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]+		            (qualidMod qident)+	    is  = [0 .. length params - 1] 	cdecls <- mapM (visitConstrIDecl mid (zip params is))  		       (catMaybes constrs_) 	qname  <- visitQualIdent qident@@ -317,7 +313,7 @@ visitConstrIDecl :: ModuleIdent -> [(Ident, Int)] -> CS.ConstrDecl  		    -> FlatState ConsDecl visitConstrIDecl mid tis (CS.ConstrDecl _ _ ident typeexprs)-   = do texprs <- mapM visitType (map (fst . cs2ilType tis) typeexprs)+   = do texprs <- mapM (visitType . (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)@@ -338,13 +334,13 @@  -- visitModuleIdent :: ModuleIdent -> FlatState String-visitModuleIdent mident = return (Id.moduleName mident)+visitModuleIdent = return . Id.moduleName  -- visitQualIdent :: QualIdent -> FlatState QName visitQualIdent qident    = do mid <- moduleId-	let (mmod, ident) = splitQualIdent qident+	let (mmod, ident) = (qualidMod qident, qualidId qident) 	    mod | elem ident [listId, consId, nilId, unitId] || isTupleId ident 		  = Id.moduleName preludeMIdent 		| otherwise@@ -354,7 +350,7 @@ -- visitExternalName :: String -> FlatState String visitExternalName name -   = moduleId >>= (\mid -> return ((Id.moduleName mid) ++ "." ++ name))+   = moduleId >>= \mid -> return (Id.moduleName mid ++ "." ++ name)   -------------------------------------------------------------------------------@@ -372,11 +368,11 @@ getExportedImports    = do mid  <- moduleId 	exps <- exports-	genExportedIDecls (envToList (getExpImports mid emptyEnv exps))+	genExportedIDecls (Map.toList (getExpImports mid Map.empty exps))  ---getExpImports :: ModuleIdent -> Env ModuleIdent [CS.Export] -> [CS.Export]-		 -> Env ModuleIdent [CS.Export]+getExpImports :: ModuleIdent -> Map.Map ModuleIdent [CS.Export] -> [CS.Export]+		 -> Map.Map ModuleIdent [CS.Export] getExpImports mident expenv [] = expenv getExpImports mident expenv ((CS.Export qident):exps)    = getExpImports mident @@ -394,20 +390,19 @@ 	 	   (bindExpImport mident qident (CS.ExportTypeAll qident) expenv)  		   exps getExpImports mident expenv ((CS.ExportModule mident'):exps)-   = getExpImports mident (bindEnv mident' [] expenv) exps+   = getExpImports mident (Map.insert mident' [] expenv) exps  -- bindExpImport :: ModuleIdent -> QualIdent -> CS.Export -	         -> Env ModuleIdent [CS.Export] -> Env ModuleIdent [CS.Export]+	         -> Map.Map ModuleIdent [CS.Export] -> Map.Map 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)+     = let (Just mod) = qualidMod qident+       in  maybe (Map.insert mod [export] expenv)+	         (\es -> Map.insert mod (export:es) expenv) +		 (Map.lookup mod expenv)  -- genExportedIDecls :: [(ModuleIdent,[CS.Export])] -> FlatState [CS.IDecl]@@ -477,9 +472,9 @@ -------------------------------------------------------------------------------  ---genFlatApplication :: IL.Expression -> FlatState Expr-genFlatApplication applicexpr-   = genFlatApplic [] applicexpr+genFlatApplication :: IL.Expression -> IL.Expression -> FlatState Expr+genFlatApplication e1 e2+   = genFlatApplic [e2] e1  where    genFlatApplic args expression        = case expression of@@ -487,8 +482,9 @@ 	      -> genFlatApplic (expr2:args) expr1 	  (IL.Function qident _) 	      -> do arity_ <- lookupIdArity qident+                    qname <- visitQualIdent qident 		    maybe (internalError (funcArity qident))-			  (\arity -> genFuncCall qident arity args)+			  (\arity -> genFuncCall qname arity args) 			  arity_ 	  (IL.Constructor qident _) 	      -> do arity_ <- lookupIdArity qident@@ -499,36 +495,39 @@ 		    genApplicComb expr args  ---genFuncCall :: QualIdent -> Int -> [IL.Expression] -> FlatState Expr-genFuncCall qident arity args+genFuncCall :: QName -> Int -> [IL.Expression] -> FlatState Expr+genFuncCall qname arity args    | arity > cnt -     = genComb qident args (FuncPartCall (arity - cnt))+     = genComb qname args (FuncPartCall (arity - cnt))    | arity < cnt       = do let (funcargs, applicargs) = splitAt arity args-	  funccall <- genComb qident funcargs FuncCall+	  funccall <- genComb qname funcargs FuncCall 	  genApplicComb funccall applicargs    | otherwise   -     = genComb qident args FuncCall+     = genComb qname 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))+     = do qname <- visitQualIdent qident+          genComb qname args (ConsPartCall (arity - cnt))    | arity < cnt      = do let (funcargs, applicargs) = splitAt arity args-	  conscall <- genComb qident funcargs ConsCall+          qname <- visitQualIdent qident+	  conscall <- genComb qname funcargs ConsCall 	  genApplicComb conscall applicargs    | otherwise -     = genComb qident args ConsCall +     = do qname <- visitQualIdent qident+          genComb qname args ConsCall   where cnt = length args  ---genComb :: QualIdent -> [IL.Expression] -> CombType -> FlatState Expr-genComb qident args combtype+genComb :: QName -> [IL.Expression] -> CombType -> FlatState Expr+genComb qname args combtype    = do exprs <- mapM visitExpression args-	qname <- visitQualIdent qident+--	qname <- visitQualIdent qident 	return (Comb combtype qname exprs) 	  --@@ -544,7 +543,7 @@  -- genOpDecls :: FlatState [OpDecl]-genOpDecls = fixities >>= (\fix -> mapM genOpDecl fix)+genOpDecls = fixities >>= mapM genOpDecl  -- genOpDecl :: CS.IDecl -> FlatState OpDecl@@ -604,7 +603,7 @@ genRecordType :: CS.IDecl -> FlatState TypeDecl genRecordType (CS.ITypeDecl _ qident params (CS.RecordType fields _))    = do let is = [0 .. (length params) - 1]-	    (mod,ident) = splitQualIdent qident+	    (mod,ident) = (qualidMod qident, qualidId qident) 	qname <- visitQualIdent ((maybe qualify qualifyWith mod)  				 (recordExtId ident)) 	labels <- mapM (genRecordLabel mod (zip params is)) fields@@ -682,17 +681,14 @@      = internalError ("GenFlatCurry.matchTypeVars: " 		      ++ show ty ++ "\n" ++ show typeexpr) -  matchList ms tys typeexprs-     = foldl (\ms' (ty,typeexpr) -> match ms' ty typeexpr)-             ms-	     (zip tys typeexprs)+  matchList ms tys+     = foldl (\ms' (ty,typeexpr) -> match ms' ty typeexpr) ms . zip tys   flattenRecordTypeFields :: [([Ident],CS.TypeExpr)] -> [(Ident,CS.TypeExpr)]-flattenRecordTypeFields fss+flattenRecordTypeFields    = concatMap (\ (labels, typeexpr) 		-> map (\label -> (label,typeexpr)) labels)-               fss  ------------------------------------------------------------------------------- @@ -756,29 +752,10 @@ missingVarIndex id = "GenFlatCurry: missing index for \"" ++ show id ++ "\""  -overlappingRules qid = (OverlapRules,-                           "function \""-		        ++ show qid +overlappingRules qid =  "function \""+		        ++ qualName 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]+		        ++ "overlapping rules"   -------------------------------------------------------------------------------@@ -851,13 +828,13 @@ -- Data type for representing an environment which contains information needed -- for generating FlatCurry code. data FlatEnv = FlatEnv{ moduleIdE     :: ModuleIdent,-			  functionIdE   :: QualIdent,+			  functionIdE   :: QualIdent,    -- function name for error messages 			  compilerOptsE :: Options, 			  moduleEnvE    :: ModuleEnv, 			  arityEnvE     :: ArityEnv, 			  typeEnvE      :: ValueEnv, 			  tConsEnvE     :: TCEnv,-			  publicEnvE    :: Env Ident IdentExport,+			  publicEnvE    :: Map.Map Ident IdentExport, 			  fixitiesE     :: [CS.IDecl], 			  typeSynonymsE :: [CS.IDecl], 			  importsE      :: [CS.IDecl],@@ -867,7 +844,7 @@ 			  varIdsE       :: ScopeEnv Ident VarIndex, 			  tvarIndexE    :: Int, 			  tvarIdsE      :: ScopeEnv Ident TVarIndex,-			  messagesE     :: [Message],+			  messagesE     :: [WarnMsg], 			  genInterfaceE :: Bool 			} @@ -884,7 +861,7 @@  -- Runs a 'FlatState' action and returns the result run :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv -    -> Bool -> FlatState a -> (a, [Message])+    -> Bool -> FlatState a -> (a, [WarnMsg]) run opts cEnv mEnv tyEnv tcEnv aEnv genIntf f    = (result, messagesE env)  where@@ -955,7 +932,7 @@ -- isPublic :: Bool -> QualIdent -> FlatState Bool isPublic isConstr qid = gets (\env -> maybe False isP-                                      (lookupEnv (unqualify qid) +                                      (Map.lookup (unqualify qid)                                         (publicEnvE env)))   where     isP NotConstr = not isConstr@@ -965,7 +942,7 @@ -- lookupModuleIntf :: ModuleIdent -> FlatState (Maybe [CS.IDecl]) lookupModuleIntf mid-   = gets (lookupEnv mid . moduleEnvE)+   = gets (Map.lookup mid . moduleEnvE)  -- lookupIdArity :: QualIdent -> FlatState (Maybe Int)@@ -980,6 +957,20 @@ 			      _               -> Nothing 		      _  -> Nothing +--+lookupIdType :: QualIdent -> FlatState (Maybe TypeExpr)+lookupIdType qid+   = do aEnv <- gets typeEnvE+        lookupT qid aEnv+    where+      lookupT qid aEnv = let vals = qualLookupValue qid aEnv +                             ts = [ t | Value _ (ForAll _ t) <- vals]+                         in case ts of +                              t : _ -> do t' <- visitType (IL.translType t)+                                          return (Just t')+                              [] -> error ("no type for " ++ show qid ++ show vals ++ show aEnv) -- return Nothing++ -- Generates a new index for a variable newVarIndex :: Ident -> FlatState VarIndex newVarIndex id@@ -1005,46 +996,11 @@ 				        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)+genWarning :: String -> FlatState ()+genWarning msg    = modify (\env -> env{ messagesE = warnMsg:(messagesE env) })-    where warnMsg = message_ (Warning warnType) msg+    where warnMsg = WarnMsg Nothing msg  -- genInterface :: FlatState Bool@@ -1076,14 +1032,14 @@ -- 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+genPubEnv :: ModuleIdent -> [CS.IDecl] -> Map.Map Ident IdentExport+genPubEnv mid idecls = foldl (bindEnvIDecl mid) Map.empty idecls -bindIdentExport :: Ident -> Bool -> Env Ident IdentExport -> Env Ident IdentExport+bindIdentExport :: Ident -> Bool -> Map.Map Ident IdentExport -> Map.Map 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)+    maybe (Map.insert id (if isConstr then OnlyConstr else NotConstr) env)+          (\ ie -> Map.insert id (updateIdentExport ie isConstr) env)+          (Map.lookup id env)   where     updateIdentExport OnlyConstr True  = OnlyConstr     updateIdentExport OnlyConstr False = NotOnlyConstr@@ -1093,7 +1049,7 @@   ---bindEnvIDecl :: ModuleIdent -> Env Ident IdentExport -> CS.IDecl -> Env Ident IdentExport+bindEnvIDecl :: ModuleIdent -> Map.Map Ident IdentExport -> CS.IDecl -> Map.Map Ident IdentExport bindEnvIDecl mid env (CS.IDataDecl _ qid _ mcdecls)    = maybe env             (\id -> foldl bindEnvConstrDecl@@ -1111,30 +1067,24 @@ bindEnvIDecl _ env _ = env  ---bindEnvITypeDecl :: Env Ident IdentExport -> Ident -> CS.TypeExpr-		    -> Env Ident IdentExport+bindEnvITypeDecl :: Map.Map Ident IdentExport -> Ident -> CS.TypeExpr+		    -> Map.Map 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 :: Map.Map Ident IdentExport -> CS.ConstrDecl -> Map.Map 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 :: Map.Map Ident IdentExport -> CS.NewConstrDecl -> Map.Map 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)------------------------------------------------------------------------------------------------------------------------------------------------------------------+bindEnvRecordLabel :: Ident -> Map.Map Ident IdentExport -> ([Ident],CS.TypeExpr) -> Map.Map Ident IdentExport+bindEnvRecordLabel r env ([lab], _) = bindIdentExport (recSelectorId (qualify r) lab) False expo+    where +      expo = (bindIdentExport (recUpdateId (qualify r) lab) False env)
− src/IL.lhs 
@@ -1,108 +0,0 @@-% $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/IL/CurryToIL.lhs view
@@ -0,0 +1,598 @@++% $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 IL.CurryToIL(ilTrans,ilTransIntf, translType) where++> import Data.Maybe+> import Data.List+> import qualified Data.Set as Set+> import qualified Data.Map as Map++> import Curry.Base.Position+> import Curry.Base.Ident+> import Curry.Syntax+> import Curry.Syntax.Utils++> import Types+> import Base+> import qualified IL.Type as IL+> import Utils++++\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)+>			     Map.empty+>			     fs'+>		  tys = map (\i -> maybe (TypeVariable (i+n))+>			                 (elimRecordTypes m tyEnv tcEnv n)+>		                         (Map.lookup i vs))+>		            is +>	      in  TypeConstructor r tys+>	    _ -> internalError "elimRecordTypes: no record type"+>       _ -> internalError "elimRecordTypes: no label"++> matchTypeVars :: [(Ident,Type)] -> Map.Map Int Type -> (Ident,Type) +>	           -> Map.Map Int Type+> matchTypeVars fs vs (l,ty) =+>   maybe vs (match vs ty) (lookup l fs)+>   where+>   match vs (TypeVariable i) ty' = Map.insert 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 = Map.Map 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' = Map.lookup 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 Map.empty)) ts+>   where translArg env (VariablePattern v) = fromJust (Map.lookup 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 Map.empty 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 = Map.insert v' v env+> bindRenameEnv v (ConstructorPattern _ ts) env =+>   foldr2 bindRenameEnv env (argNames v) ts+> bindRenameEnv v (AsPattern v' t) env = Map.insert 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)+>         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 = Map.lookup (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 Map.insert 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 = Set.toList . Set.delete m . Set.fromList . 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) (qualidMod x)++\end{verbatim}+
+ src/IL/Pretty.lhs view
@@ -0,0 +1,167 @@+% $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 IL.Pretty(ppModule)  where+> +> import Curry.Base.Ident+> +> import IL.Type+> import PrettyCombinators++> 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/IL/Scope.hs view
@@ -0,0 +1,124 @@+module IL.Scope (getModuleScope,+		insertDeclScope, insertConstrDeclScope,+		insertCallConvScope, insertTypeScope,+		insertLiteralScope, insertConstrTermScope,+		insertExprScope, insertAltScope,+		insertBindingScope) where++import Curry.Base.Ident++import IL.Type+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/IL/Type.lhs view
@@ -0,0 +1,109 @@+% $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.Type where++> import Curry.Base.Ident+> import Curry.Base.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/IL/XML.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 IL.XML(module IL.XML) where++> import Data.Maybe++> import Curry.Base.Ident+> import qualified Curry.Syntax as CS++> import IL.Type+> import CurryEnv+> import PrettyCombinators++++> -- 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, _) = 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,_)    = 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,_)  = 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 (fromEnum 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/ILPP.lhs 
@@ -1,166 +0,0 @@-% -*- 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 
@@ -1,124 +0,0 @@-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 
@@ -1,595 +0,0 @@--% $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 qualified Data.Set as Set-> import qualified Data.Map as Map--> import Base-> import qualified IL-> import Utils-> import Env-----\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)->			     Map.empty->			     fs'->		  tys = map (\i -> maybe (TypeVariable (i+n))->			                 (elimRecordTypes m tyEnv tcEnv n)->		                         (Map.lookup i vs))->		            is ->	      in  TypeConstructor r tys->	    _ -> internalError "elimRecordTypes: no record type"->       _ -> internalError "elimRecordTypes: no label"--> matchTypeVars :: [(Ident,Type)] -> Map.Map Int Type -> (Ident,Type) ->	           -> Map.Map Int Type-> matchTypeVars fs vs (l,ty) =->   maybe vs (match vs ty) (lookup l fs)->   where->   match vs (TypeVariable i) ty' = Map.insert 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 = Set.toList . Set.delete m . Set.fromList . 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 
@@ -1,518 +0,0 @@--% $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 
@@ -1,415 +0,0 @@-> {-# 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
@@ -16,8 +16,11 @@ > import qualified Data.Set as Set > import qualified Data.Map as Map +> import Curry.Syntax+> import Types+> import Curry.Base.Position+> import Curry.Base.Ident > import Base-> import Env > import TopEnv  @@ -31,10 +34,10 @@ 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+> type ExpPEnv = Map.Map Ident PrecInfo+> type ExpTCEnv = Map.Map Ident TypeInfo+> type ExpValueEnv = Map.Map Ident ValueInfo+> type ExpArityEnv = Map.Map Ident ArityInfo  \end{verbatim} When an interface is imported, the compiler first transforms the@@ -69,10 +72,10 @@ > isVisible _ _ = const True  > importEntities :: Entity a => ModuleIdent -> Bool -> (Ident -> Bool)->                -> (a -> a) -> Env Ident a -> TopEnv a -> TopEnv a+>                -> (a -> a) -> Map.Map 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]+>         [(x,f y) | (x,y) <- Map.toList mEnv, isVisible x] >   where importUnqual m x y = importTopEnv m x y . qualImportTopEnv m x y  > importData :: (Ident -> Bool) -> TypeInfo -> TypeInfo@@ -111,18 +114,18 @@ 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+> intfEnv :: (ModuleIdent -> IDecl -> Map.Map Ident a -> Map.Map Ident a)+>         -> Interface -> Map.Map Ident a+> intfEnv bind (Interface m ds) = foldr (bind m) Map.empty ds  > bindPrec :: ModuleIdent -> IDecl -> ExpPEnv -> ExpPEnv > bindPrec m (IInfixDecl _ fix p op) =->   bindEnv (unqualify op) (PrecInfo (qualQualify m op) (OpPrec fix p))+>   Map.insert (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) =+>   | isJust (Map.lookup (unqualify tc) mTCEnv) = >     mTCEnv >   | otherwise = >     bindType DataType m tc tvs (map (fmap mkData) cs) mTCEnv@@ -150,7 +153,7 @@ > 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) +>   Map.insert (unqualify tc) . f (qualQualify m tc) (length tvs)   > bindTy :: ModuleIdent -> IDecl -> ExpValueEnv -> ExpValueEnv > bindTy m (IDataDecl _ tc tvs cs) =@@ -163,7 +166,7 @@ > --  flip (foldr (bindRecLabel m r')) fs > --  where r' = qualifyWith m (fromRecordExtId (unqualify r)) > bindTy m (IFunctionDecl _ f _ ty) =->   bindEnv (unqualify f)+>   Map.insert (unqualify f) >           (Value (qualQualify m f) (polyType (toQualType m [] ty))) > bindTy m _ = id @@ -183,27 +186,27 @@ > --bindRecLabel :: ModuleIdent -> QualIdent -> ([Ident],TypeExpr) > --      -> ExpValueEnv -> ExpValueEnv > --bindRecLabel m r ([l],ty) =-> --  bindEnv l (Label (qualify l) r (polyType (toQualType m [] ty)))+> --  Map.insert 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)+> bindValue f m tc tvs c evs ty = Map.insert 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))+>         qualifyLike x = maybe qualify qualifyWith (qualidMod 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+>    = Map.insert (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+>    = Map.insert c (ArityInfo (qualifyWith m c) (length tys)) expAEnv > bindConstrA m (ConOpDecl _ _ _ c _) expAEnv->    = bindEnv c (ArityInfo (qualifyWith m c) 2) expAEnv+>    = Map.insert c (ArityInfo (qualifyWith m c) 2) expAEnv  \end{verbatim} After the environments have been initialized, the optional import@@ -262,14 +265,14 @@ > expandThing :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident >             -> [Import] > expandThing m tcEnv tyEnv tc =->   case lookupEnv tc tcEnv of+>   case Map.lookup 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+>   case Map.lookup f tyEnv of >     Just v >       | isConstr v -> maybe (errorAt' (importDataConstr m f)) id tcImport >       | otherwise -> Import f : maybe [] id tcImport@@ -281,21 +284,21 @@ > expandHide :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident >            -> [Import] > expandHide m tcEnv tyEnv tc =->   case lookupEnv tc tcEnv of+>   case Map.lookup 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+>   case Map.lookup 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+>   case Map.lookup tc tcEnv of >     Just (DataType _ _ cs') -> >       ImportTypeWith tc (map (checkConstr [c | Just (Data c _ _) <- cs']) cs) >     Just (RenamingType _ _ (Data c _ _)) ->@@ -308,7 +311,7 @@  > expandTypeAll :: ModuleIdent -> ExpTCEnv -> Ident -> Import > expandTypeAll m tcEnv tc =->   case lookupEnv tc tcEnv of+>   case Map.lookup 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)@@ -357,11 +360,6 @@ > 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 =
src/InterfaceCheck.hs view
@@ -11,7 +11,7 @@  import Data.List -import ExtendedFlat+import Curry.ExtendedFlat
src/KindCheck.lhs view
@@ -23,10 +23,13 @@ is defined more than once. \begin{verbatim} -> module KindCheck(kindCheck,kindCheckGoal) where+> module KindCheck(kindCheck) where  > import Data.Maybe +> import Curry.Syntax+> import Curry.Base.Position+> import Curry.Base.Ident > import Base hiding (bindArity) > import TopEnv @@ -44,16 +47,10 @@ > kindCheck m tcEnv ds = >   case linear (map tconstr ds') of >     Linear -> map (checkDecl m kEnv) ds->     NonLinear (PIdent p tc) -> errorAt' (duplicateType tc)+>     NonLinear 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}@@ -113,7 +110,7 @@ >   | tv `elem` tvs = errorAt' (nonLinear tv) >   | otherwise = tv : checkTypeLhs kEnv tvs >   where isTypeConstr tv = not (null (lookupKind tv kEnv))-> checkTypeLhs kEnv [] = []+> checkTypeLhs _ [] = []  > checkConstrDecl :: ModuleIdent -> KindEnv -> [Ident] -> ConstrDecl -> ConstrDecl > checkConstrDecl m kEnv tvs (ConstrDecl p evs c tys) =@@ -268,10 +265,10 @@ 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 :: Decl -> Ident+> tconstr (DataDecl p tc _ _) = tc+> tconstr (NewtypeDecl p tc _ _) = tc+> tconstr (TypeDecl p tc _ _) = tc > tconstr _ = internalError "tconstr"  \end{verbatim}
− src/LLParseComb.lhs 
@@ -1,292 +0,0 @@-% -*- 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 Control.Monad-> import Data.Maybe-> import qualified Data.Set as Set-> import qualified Data.Map as Map---> import Position---> 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))->                            (Map.Map 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 (Map.keysSet 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 Map.lookup 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) Map.empty->   where p success _ pos = success pos pos--> succeed :: Symbol s => a -> Parser s a b-> succeed x = Parser (Just p) Map.empty->   where p success _ = success x--> symbol :: Symbol s => s -> Parser s s a-> symbol s = Parser Nothing (Map.singleton s p)->   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) Map.empty->   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 (Set.null common) = error ("Ambiguous parser for " ++ show common)->   | otherwise = Parser (e1 `mplus` e2) (Map.union ps1 ps2)->   where common = Map.keysSet ps1 `Set.intersection` Map.keysSet 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) (Map.union ps1' ps2)->   where ps1' = Map.fromList [(s,maybe p (try p) (Map.lookup s ps2))->                           | (s,p) <- Map.toList 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)->          (Map.union (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--\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.keys ps--> (<\\>) :: Symbol s => Parser s a b -> [s] -> Parser s a b-> Parser e ps <\\> xs = Parser e (foldr Map.delete 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) Map.empty->   where on success _ pos = pushContext (column pos) . success undefined pos--> layoutOff :: Symbol s => Parser s a b-> layoutOff = Parser (Just off) Map.empty->   where off success _ pos = pushContext (-1) . success undefined pos--> layoutEnd :: Symbol s => Parser s a b-> layoutEnd = Parser (Just end) Map.empty->   where end success _ pos = popContext . success undefined pos--\end{verbatim}
− src/LexComb.lhs 
@@ -1,102 +0,0 @@-% -*- 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
@@ -20,23 +20,24 @@ > module Lift(lift) where  > import Control.Monad+> import qualified Control.Monad.State as S > import Data.List+> import qualified Data.Map as Map > import qualified Data.Set as Set +> import Curry.Syntax+> import Curry.Syntax.Utils+> import Types+> import Curry.Base.Ident > import Base-> import Env > import TopEnv----> 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+>           S.evalState (S.evalStateT (abstractModule m ds) tyEnv) evEnv  \end{verbatim} \paragraph{Abstraction}@@ -49,16 +50,16 @@ i.e. the function applied to its free variables. \begin{verbatim} -> type AbstractState a = StateT ValueEnv (St EvalEnv) a-> type AbstractEnv = Env Ident Expression+> type AbstractState a = S.StateT ValueEnv (S.State EvalEnv) a+> type AbstractEnv = Map.Map Ident Expression  > abstractModule :: ModuleIdent -> [Decl] >                -> AbstractState ([Decl],ValueEnv,EvalEnv) > abstractModule m ds = >   do->     ds' <- mapM (abstractDecl m "" [] emptyEnv) ds->     tyEnv' <- fetchSt->     evEnv' <- liftSt fetchSt+>     ds' <- mapM (abstractDecl m "" [] Map.empty) ds+>     tyEnv' <- S.get+>     evEnv' <- S.lift S.get >     return (ds',tyEnv',evEnv')  > abstractDecl :: ModuleIdent -> String -> [Ident] -> AbstractEnv -> Decl@@ -149,9 +150,9 @@ >     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'))+>     fs' <- liftM (\tyEnv -> filter (not . isLifted tyEnv) fs) S.get+>     S.modify (abstractFunTypes m pre fvs fs')+>     S.lift (S.modify (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@@ -160,8 +161,8 @@ >         fvs = filter (`elem` lvs) (Set.toList fvsRhs) >         env' = foldr (bindF (map mkVar fvs)) env fs >         fvsRhs = Set.unions->           [Set.fromList (maybe [v] (qfv m) (lookupEnv v env)) | v <- qfv m fds]->         bindF fvs f = bindEnv f (apply (mkFun m pre f) fvs)+>           [Set.fromList (maybe [v] (qfv m) (Map.lookup v env)) | v <- qfv m fds]+>         bindF fvs f = Map.insert f (apply (mkFun m pre f) fvs) >         isLifted tyEnv f = null (lookupValue f tyEnv)  > abstractFunTypes :: ModuleIdent -> String -> [Ident] -> [Ident]@@ -176,8 +177,8 @@ > 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)+>           case Map.lookup f evEnv of+>             Just ev -> Map.insert (liftIdent pre f) ev (Map.delete f evEnv) >             Nothing -> evEnv  > abstractFunDecl :: ModuleIdent -> String -> [Ident] -> [Ident]@@ -196,7 +197,7 @@ > 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)+>                       (Map.lookup (unqualify v) env) > abstractExpr _ _ _ _ (Constructor c) = return (Constructor c) > abstractExpr m pre lvs env (Apply e1 e2) = >   do@@ -216,14 +217,6 @@ > 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@@ -273,10 +266,6 @@ > 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}
− src/Message.hs 
@@ -1,74 +0,0 @@---------------------------------------------------------------------------------------------------------------------------------------------------------------------- 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
@@ -15,54 +15,59 @@ import declarations are commented out \begin{verbatim} -> module Modules(compileModule, compileModule_,+> module Modules(compileModule,+>                importPrelude, patchModuleId, >	         loadInterfaces, transModule, >	         simpleCheckModule, checkModule >	        ) where + > import Data.List+> import qualified Data.Map as Map > import System.IO > import Data.Maybe > import Control.Monad +> import Curry.Base.MessageMonad+> import Curry.Base.Position+> import Curry.Base.Ident+> import Curry.Syntax+> import Curry.Syntax.Pretty(ppModule,ppIDecl)+> import Curry.Syntax.ShowModule(showModule)+ > import Base-> import Unlit(unlit)-> import CurryParser(parseSource,parseGoal) -- xxxGoal entfernen-> import ShowCurrySyntax(showModule)-> import KindCheck(kindCheck,kindCheckGoal)+> import Types+> import KindCheck(kindCheck) > import SyntaxCheck(syntaxCheck)-> import PrecCheck(precCheck,precCheckGoal)-> import TypeCheck(typeCheck,typeCheckGoal)-> import WarnCheck-> import Message+> import PrecCheck(precCheck)+> import TypeCheck(typeCheck)+> import WarnCheck(warnCheck) > import Arity > import Imports(importInterface,importInterfaceIntf,importUnifyData) > import Exports(expandInterface,exportInterface)-> import Eval(evalEnv,evalEnvGoal)-> import Qual(qual,qualGoal)-> import Desugar(desugar,desugarGoal)+> import Eval(evalEnv)+> import Qual(qual)+> import Desugar(desugar) > import Simplify(simplify) > import Lift(lift)-> import qualified IL-> import ILTrans(ilTrans,ilTransIntf)-> import ILxml(xmlModule) -- check-> import ExtendedFlat+> import qualified IL.Type as IL+> import IL.CurryToIL(ilTrans)+> import IL.XML(xmlModule)+> import Curry.ExtendedFlat > import GenFlatCurry (genFlatCurry,genFlatInterface)-> import AbstractCurry+> import qualified Curry.AbstractCurry as AC > import GenAbstractCurry > import InterfaceCheck > import CurryEnv-> import CurryPP(ppModule,ppInterface,ppIDecl,ppGoal)-> import qualified ILPP(ppModule)+> import qualified IL.Pretty(ppModule) > import CurryCompilerOpts(Options(..),Dump(..))-> import CompilerResults > import CaseCompletion > import PathUtils+> import Filenames > import TypeSubst-> import Pretty-> import Error-> import Env+> import PrettyCombinators > import TopEnv+> import qualified Curry.ExtendedFlat as EF   \end{verbatim} The function \texttt{compileModule} is the main entry-point of this@@ -88,13 +93,10 @@ 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 =+> compileModule :: Options -> FilePath -> IO (Maybe FilePath)+> compileModule opts fn = >   do->     mod <- liftM (parseModule likeFlat fn) (readModule fn)+>     mod <- liftM (importPrelude fn . ok . parseModule likeFlat fn) (readModule fn) >     let m = patchModuleId fn mod >     checkModuleId fn m >     mEnv <- loadInterfaces (importPaths opts) m@@ -103,12 +105,12 @@ >          do (tyEnv, tcEnv, aEnv, m', intf, _) <- simpleCheckModule opts mEnv m >             if uacy then genAbstract opts fn tyEnv tcEnv m' >                     else do->                       let outputFile = maybe (replaceExtension fn sourceRepExt) +>                       let outputFile = maybe (sourceRepName fn) >                                              id  >                                              (output opts) >                           outputMod = showModule m' >                       writeModule outputFile outputMod->                       return defaultResults+>                       return Nothing >        else >          do (tyEnv, tcEnv, aEnv, m', intf, _) <- checkModule opts mEnv m >             let (il,aEnv',dumps) = transModule fcy False False @@ -125,15 +127,11 @@ >         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+>            | otherwise  = return Nothing  > loadInterfaces :: [FilePath] -> Module -> IO ModuleEnv > loadInterfaces paths (Module m _ ds) =->   foldM (loadInterface paths [m]) emptyEnv+>   foldM (loadInterface paths [m]) Map.empty >         [(p,m) | ImportDecl p m _ _ _ <- ds]  > checkModuleId :: Monad m => FilePath -> Module -> m ()@@ -146,7 +144,7 @@ >	        ++ ".curry\"")  > simpleCheckModule :: Options -> ModuleEnv -> Module ->	    -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[Message])+>	    -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[WarnMsg]) > simpleCheckModule opts mEnv (Module m es ds) = >   do unless (noWarn opts) (printMessages msgs) >      return (tyEnv'', tcEnv, aEnv'', modul, intf, msgs)@@ -160,12 +158,12 @@ >			   $ 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'') +>         (_,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])+>      -> IO (ValueEnv,TCEnv,ArityEnv,Module,Interface,[WarnMsg]) > checkModule opts mEnv (Module m es ds) = >   do unless (noWarn opts) (printMessages msgs) >      when (m == mkMIdent ["field114..."])@@ -216,8 +214,8 @@ >	           (DumpDesugared,ppModule desugared), >                  (DumpSimplified,ppModule simplified), >                  (DumpLifted,ppModule lifted),->                  (DumpIL,ILPP.ppModule il),->	           (DumpCase,ILPP.ppModule il')+>                  (DumpIL,IL.Pretty.ppModule il),+>	           (DumpCase,IL.Pretty.ppModule il') >	          ]  > qualifyEnv :: ModuleEnv -> PEnv -> TCEnv -> ValueEnv -> ArityEnv@@ -228,7 +226,7 @@ >    foldr bindGlobal tyEnv' (localBindings tyEnv), >    foldr bindQual aEnv' (localBindings aEnv)) >   where (pEnv',tcEnv',tyEnv',aEnv') =->           foldl importInterface initEnvs (envToList mEnv)+>           foldl importInterface initEnvs (Map.toList mEnv) >         importInterface (pEnv,tcEnv,tyEnv,aEnv) (m,ds) = >           importInterfaceIntf (Interface m ds) pEnv tcEnv tyEnv aEnv >         bindQual (_,y) = qualBindTopEnv "Modules.qualifyEnv" (origName y) y@@ -236,30 +234,18 @@ >           | 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 (replaceExtension sfn xmlExt) tfn+>   where ofn  = fromMaybe (xmlName sfn) 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 (replaceExtension 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{extendedFlat=False}->                  (genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il)->                  (fromMaybe (takeBaseName sfn ++ fintExt) tfn)+>                        (fromMaybe (flatName sfn) tfn) -> writeFlatFile :: (Show a) => Options -> (Prog, [a]) -> String -> IO Prog+> writeFlatFile :: Options -> (Prog, [WarnMsg]) -> String -> IO Prog > writeFlatFile opts@Options{extendedFlat=ext} (res,msgs) fname = do >         unless (noWarn opts) (printMessages msgs) >	  if ext then writeExtendedFlat fname res@@ -270,125 +256,20 @@ > writeTypedAbs :: Maybe FilePath -> FilePath -> ValueEnv -> TCEnv -> Module >	           -> IO () > writeTypedAbs tfn sfn tyEnv tcEnv mod->    = writeCurry fname (genTypedAbstract tyEnv tcEnv mod)->  where fname = fromMaybe (replaceExtension sfn acyExt) tfn+>    = AC.writeCurry fname (genTypedAbstract tyEnv tcEnv mod)+>  where fname = fromMaybe (acyName sfn) tfn  > writeUntypedAbs :: Maybe FilePath -> FilePath -> ValueEnv -> TCEnv   >	             -> Module -> IO () > writeUntypedAbs tfn sfn tyEnv tcEnv mod->    = writeCurry fname (genUntypedAbstract tyEnv tcEnv mod)->  where fname = fromMaybe (replaceExtension sfn uacyExt) tfn+>    = AC.writeCurry fname (genUntypedAbstract tyEnv tcEnv mod)+>  where fname = fromMaybe (uacyName sfn) tfn  > 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}@@ -397,7 +278,7 @@ > 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+>           case Map.lookup m mEnv of >             Just ds -> importInterface p (fromMaybe m asM) q is >                                        (Interface m ds) pEnv tcEnv tyEnv aEnv >             Nothing -> internalError "importModule"@@ -421,7 +302,7 @@ > importLabels mEnv ds = foldl importLabelTypes initLabelEnv ds >   where >   importLabelTypes lEnv (ImportDecl p m _ asM is) =->     case (lookupModule m mEnv) of+>     case (Map.lookup m mEnv) of >       Just ds' -> foldl (importLabelType p (fromMaybe m asM) is) lEnv ds' >       Nothing -> internalError "importLabels" >   importLabelTypes lEnv _ = lEnv@@ -449,10 +330,10 @@  > addImportedLabels :: ModuleIdent -> LabelEnv -> ValueEnv -> ValueEnv > addImportedLabels m lEnv tyEnv = ->   foldr addLabelType tyEnv (concatMap snd (envToList lEnv))+>   foldr addLabelType tyEnv (concatMap snd (Map.toList lEnv)) >   where >   addLabelType (LabelType l r ty) tyEnv = ->     let m' = fromMaybe m (fst (splitQualIdent r))+>     let m' = fromMaybe m (qualidMod r) >     in  importTopEnv m' l  >                      (Label (qualify l) (qualQualify m' r) (polyType ty))  >	               tyEnv@@ -511,7 +392,7 @@ > 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+>   where ids = [decl | decl@(ImportDecl _ _ _ _ _) <- ds] >         ds' = ImportDecl (first fn) preludeMIdent >                          (preludeMIdent `elem` map importedModule ids) >                          Nothing Nothing : ds@@ -536,7 +417,7 @@ >       lookupInterface paths m >>= >       maybe (errorAt p (interfaceNotFound m)) >             (compileInterface paths ctxt mEnv m)->   where isLoaded m mEnv = maybe False (const True) (lookupModule m mEnv)+>   where isLoaded m mEnv = maybe False (const True) (Map.lookup m mEnv)  \end{verbatim} After reading an interface, all imported interfaces are recursively@@ -571,18 +452,7 @@ >         (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}). @@ -601,25 +471,6 @@ 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 = dropExtension 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@@ -627,24 +478,10 @@ \begin{verbatim}  > lookupInterface :: [FilePath] -> ModuleIdent -> IO (Maybe FilePath)-> lookupInterface paths m = lookupFile ("":paths) [fintExt] ifn+> lookupInterface paths m = lookupFile ("":paths) [flatIntExt] ifn >   where ifn = foldr1 catPath (moduleQualifiers m)  \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}@@ -678,7 +515,7 @@ \begin{verbatim}  > genFlat :: Options -> FilePath -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv ->            -> Interface -> Module -> IL.Module -> IO CompilerResults+>            -> Interface -> Module -> IL.Module -> IO (Maybe FilePath) > genFlat opts fname mEnv tyEnv tcEnv aEnv intf mod il >   | flat opts >     = do writeFlat opts Nothing fname cEnv mEnv tyEnv tcEnv aEnv il@@ -686,7 +523,7 @@ >          if force opts >            then  >              do writeInterface flatInterface intMsgs->                 return defaultResults+>                 return Nothing >            else  >               do mfint <- readFlatInterface fintName >                  let flatIntf = fromMaybe emptyIntf mfint@@ -694,14 +531,14 @@ >                        && not (interfaceCheck flatIntf flatInterface) >                     then  >                        do writeInterface flatInterface intMsgs->                           return defaultResults->                     else return defaultResults+>                           return Nothing+>                     else return Nothing >   | flatXml opts->     = writeXML (output opts) fname cEnv il >> return defaultResults+>     = writeXML (output opts) fname cEnv il >> return Nothing >   | otherwise >     = internalError "@Modules.genFlat: illegal option" >  where->    fintName = replaceExtension fname fintExt+>    fintName = flatIntName fname >    cEnv = curryEnv mEnv tcEnv intf mod >    emptyIntf = Prog "" [] [] [] [] >    writeInterface intf msgs = do@@ -710,20 +547,20 @@   > genAbstract :: Options -> FilePath  -> ValueEnv -> TCEnv -> Module ->                -> IO CompilerResults+>                -> IO (Maybe FilePath) > genAbstract opts fname tyEnv tcEnv mod >    | abstract opts >      = do writeTypedAbs Nothing fname tyEnv tcEnv mod ->           return defaultResults+>           return Nothing >    | untypedAbstract opts >      = do writeUntypedAbs Nothing fname tyEnv tcEnv mod->           return defaultResults+>           return Nothing >    | otherwise >      = internalError "@Modules.genAbstract: illegal option" -> printMessages :: Show a => [a] -> IO ()+> printMessages :: [WarnMsg] -> IO () > printMessages []   = return ()-> printMessages msgs = hPutStrLn stderr $ unlines $ map show msgs+> printMessages msgs = hPutStrLn stderr $ unlines $ map showWarning msgs  \end{verbatim} The function \texttt{ppTypes} is used for pretty-printing the types@@ -756,20 +593,6 @@   \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} @@ -789,3 +612,78 @@ >   "Expected interface for " ++ show m ++ " but found " ++ show m'  \end{verbatim}+++++> bindFlatInterface :: Prog -> ModuleEnv -> ModuleEnv+> bindFlatInterface (Prog m imps ts fs os)+>    = Map.insert (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],Curry.Syntax.TypeExpr)+>  genLabeledType (Cons qn _ _ [t])+>     = ([renameLabel (fromLabelExtId (mkIdent $ localName qn))], genTypeExpr t)+>+>  genTypeExpr :: EF.TypeExpr -> Curry.Syntax.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 :: EF.QName -> QualIdent+>  genQualIdent EF.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 EF.QName{modName=mod,localName=name} _ _ _) +>     = (name == "[]" || name == "()") && mod == "Prelude"+>  isSpecialPreludeType _ = False+>+>  pos = first m+>  ts' = filter (not . isSpecialPreludeType) ts
src/NestEnv.lhs view
@@ -18,13 +18,17 @@ > module NestEnv(module TopEnv, NestEnv, bindNestEnv,qualBindNestEnv, >                lookupNestEnv,qualLookupNestEnv, >                toplevelEnv,globalEnv,nestEnv) where-> import Env++> import qualified Data.Map as Map++> import Curry.Base.Ident+ > import TopEnv-> import Ident -> data NestEnv a = GlobalEnv (TopEnv a) | LocalEnv (NestEnv a) (Env Ident a)->                  deriving Show +> data NestEnv a = GlobalEnv (TopEnv a) | LocalEnv (NestEnv a) (Map.Map 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)@@ -33,9 +37,9 @@ > bindNestEnv x y (GlobalEnv env)  >   = GlobalEnv (bindTopEnv "NestEnv.bindNestEnv" x y env) > bindNestEnv x y (LocalEnv genv env) =->   case lookupEnv x env of+>   case Map.lookup x env of >     Just _ -> error "internal error: bindNestEnv"->     Nothing -> LocalEnv genv (bindEnv x y env)+>     Nothing -> LocalEnv genv (Map.insert x y env)  > qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a > qualBindNestEnv x y (GlobalEnv env) @@ -43,15 +47,15 @@ > qualBindNestEnv x y (LocalEnv genv env) >   | isQualified x = error "internal error: qualBindNestEnv" >   | otherwise =->       case lookupEnv x' env of+>       case Map.lookup x' env of >         Just _ -> error "internal error: qualBindNestEnv"->         Nothing -> LocalEnv genv (bindEnv x' y env)+>         Nothing -> LocalEnv genv (Map.insert 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+>   case Map.lookup x env of >     Just y -> [y] >     Nothing -> lookupNestEnv x genv @@ -68,6 +72,6 @@ > globalEnv = GlobalEnv  > nestEnv :: NestEnv a -> NestEnv a-> nestEnv env = LocalEnv env emptyEnv+> nestEnv env = LocalEnv env Map.empty  \end{verbatim}
src/OldScopeEnv.hs view
@@ -7,10 +7,9 @@ 		    genIdent, genIdentList) where  import Data.Maybe--import Ident-import Env+import qualified Data.Map as Map +import Curry.Base.Ident   -------------------------------------------------------------------------------@@ -23,7 +22,7 @@  -- Generates a new instance of a scope table newScopeEnv :: ScopeEnv-newScopeEnv = (newIdEnv, [], 0)+newScopeEnv = (Map.empty, [], 0)   -- Inserts an identifier into the current level of the scope environment@@ -66,7 +65,7 @@ beginScope (topleveltab, leveltabs, level)    = case leveltabs of        (lt:lts) -> (topleveltab, (lt:lt:lts), level + 1)-       []       -> (topleveltab, [newIdEnv], 1)+       []       -> (topleveltab, [Map.empty], 1)   -- Decreases the level of the scope. Identifier from higher levels@@ -116,24 +115,20 @@ ------------------------------------------------------------------------------- -- Private declarations... -type IdEnv = Env IdRep Int+type IdEnv = Map.Map 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)) +   = Map.insert (Name (name ident))               level -	     (bindEnv (Index (uniqueId ident)) level env)+	     (Map.insert (Index (uniqueId ident)) level env)   --@@ -143,7 +138,7 @@  -- getIdLevel :: Ident -> IdEnv -> Maybe Int-getIdLevel ident env = lookupEnv (Index (uniqueId ident)) env+getIdLevel ident env = Map.lookup (Index (uniqueId ident)) env   --@@ -158,12 +153,12 @@  -- nameExists :: String -> IdEnv -> Bool-nameExists name env = isJust (lookupEnv (Name name) env)+nameExists name env = isJust (Map.lookup (Name name) env)   -- indexExists :: Int -> IdEnv -> Bool-indexExists index env = isJust (lookupEnv (Index index) env)+indexExists index env = isJust (Map.lookup (Index index) env)   -------------------------------------------------------------------------------
src/PatchPrelude.hs view
@@ -1,7 +1,7 @@ module PatchPrelude where  -import ExtendedFlat+import Curry.ExtendedFlat   -- the prelude has to be extended by data declarations for list and tuples
src/PathUtils.hs view
@@ -6,12 +6,13 @@ -}  module PathUtils(-- re-exports from System.FilePath:-                 takeBaseName, replaceExtension, dropExtension,+                 takeBaseName, -- replaceExtension,+                 dropExtension,                  takeDirectory, takeExtension,                   pathSeparator,                  catPath, -                 lookupFile,+                 lookupModule, lookupFile, getCurryPath,                  writeModule,readModule,                  doesModuleExist,maybeReadModule,getModuleModTime) where @@ -21,7 +22,16 @@  import Control.Monad (unless) +import Curry.Base.Ident+import Filenames ++lookupModule :: [FilePath] -> [FilePath] -> ModuleIdent+             -> IO (Maybe FilePath)+lookupModule paths libraryPaths m+    = lookupFile ("" : paths ++ libraryPaths) moduleExts fn+      where fn = foldr1 catPath (moduleQualifiers m)+ catPath :: FilePath -> FilePath -> FilePath catPath = combine @@ -65,7 +75,7 @@ writeModule filename contents = do   let filename' = inCurrySubdir filename       subdir = takeDirectory filename'-  ensureDirectoryExists (takeDirectory filename')+  ensureDirectoryExists subdir   writeFile filename' contents  ensureDirectoryExists :: FilePath -> IO ()@@ -93,3 +103,20 @@  getModuleModTime :: FilePath -> IO ClockTime getModuleModTime = onExistingFileDo getModificationTime+++{-+  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.+-}+getCurryPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)+getCurryPath paths fn = lookupFile filepaths exts fn+    where+      filepaths = "":paths'+      fnext = takeExtension fn+      exts | null fnext = sourceExts+           | otherwise  = [fnext]+      paths' | pathSeparator `elem` fn = []+             | otherwise               = paths+
− src/Position.lhs 
@@ -1,94 +0,0 @@-> {-# 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
@@ -16,10 +16,15 @@ of the operators involved. \begin{verbatim} -> module PrecCheck(precCheck,precCheckGoal) where+> module PrecCheck(precCheck) where  > import Data.List +> import Curry.Base.Position+> import Curry.Base.Ident+> import Curry.Syntax+> import Curry.Syntax.Utils+ > import Base  \end{verbatim}@@ -34,13 +39,13 @@ > bindPrecs m ds pEnv = >   case linear ops of >     Linear ->->       case [PIdent p op | PIdent p op <- ops, op `notElem` bvs] of+>       case [ op | op <- ops, op `notElem` bvs] of >         [] -> foldr bindPrec pEnv fixDs->         PIdent p op : _ -> errorAt' (undefinedOperator op)->     NonLinear (PIdent p op) -> errorAt' (duplicatePrecedence op)+>         op : _ -> errorAt' (undefinedOperator op)+>     NonLinear op -> errorAt' (duplicatePrecedence op) >   where (fixDs,nonFixDs) = partition isInfixDecl ds >         bvs = concatMap boundValues nonFixDs->         ops = [PIdent p op | InfixDecl p _ _ ops <- fixDs, op <- ops]+>         ops = [ op | InfixDecl p _ _ ops <- fixDs, op <- ops] >         bindPrec (InfixDecl _ fix pr ops) pEnv >           | p == defaultP = pEnv >           | otherwise = foldr (flip (bindP m) p) pEnv ops@@ -72,11 +77,6 @@ > 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@@ -247,8 +247,7 @@ >       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+>   where OpPrec fix2 pr2 = opPrec op2 pEnv > fixUPrec _ uop e1 op e2 = UnaryMinus uop (InfixApply e1 op e2)  > fixRPrec :: PEnv -> Expression -> InfixOp -> Expression
− src/Pretty.lhs 
@@ -1,905 +0,0 @@-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/PrettyCombinators.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 PrettyCombinators (+        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
@@ -19,17 +19,16 @@ \em{Note:} The modified version also qualifies type constructors \begin{verbatim} -> module Qual(qual,qualGoal) where+> module Qual(qual) where++> import Curry.Base.Ident+> import Curry.Syntax+ > 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) =
src/ScopeEnv.hs view
@@ -15,7 +15,7 @@ 		 level, exists, beginScope, endScope, endScopeUp, 		 toList, toLevelList, currentLevel) where -import Env+import qualified Data.Map as Map import Prelude hiding (lookup)  -------------------------------------------------------------------------------@@ -23,14 +23,14 @@  -- Returns an empty scope environment new :: Ord a => ScopeEnv a b-new = ScopeEnv 0 emptyEnv []+new = ScopeEnv 0 Map.empty []   -- 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+ insertLev lev local = Map.insert key (val,lev) local   -- Updates the value stored under an existing key in the environment of @@ -39,8 +39,8 @@ update key val env = modifySE updateLev env  where  updateLev lev local = maybe local -		             (\ (_,lev') ->  bindEnv key (val,lev') local)-			     (lookupEnv key local)+		             (\ (_,lev') ->  Map.insert key (val,lev') local)+			     (Map.lookup key local)  -- Modifies the value of an existing key by applying the function 'fun' -- in the environment of the current scope@@ -49,8 +49,8 @@  where  modifyLev lev local      = maybe local-            (\ (val',lev') -> bindEnv key (fun val', lev') local)-	    (lookupEnv key local)+            (\ (val',lev') -> Map.insert key (fun val', lev') local)+	    (Map.lookup key local)   -- Looks up the value which is stored under a key from the environment of@@ -58,7 +58,7 @@ 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)+ lookupLev lev local = maybe Nothing (Just . fst) (Map.lookup key local)   -- Similar to 'lookup', but returns an alternative value, if the key@@ -71,14 +71,14 @@ level :: Ord a => a -> ScopeEnv a b -> Int level key env = selectSE levelLev env  where- levelLev lev local = maybe (-1) snd (lookupEnv key local)+ levelLev lev local = maybe (-1) snd (Map.lookup 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)+ existsLev lev local = maybe False (const True) (Map.lookup key local)   -- Switches to the next scope (i.e. pushes the environment of the current@@ -106,18 +106,18 @@ endScopeUp (ScopeEnv _ top [])    = ScopeEnv 0 top [] endScopeUp (ScopeEnv lev top (local:[]))-   = ScopeEnv 0 (foldr (updateSE local) top (envToList top)) []+   = ScopeEnv 0 (foldr (updateSE local) top (Map.toList top)) [] endScopeUp (ScopeEnv lev top (local:local':locals))    = ScopeEnv (lev - 1)                top -	      ((foldr (updateSE local) local' (envToList local')):locals)+	      ((foldr (updateSE local) local' (Map.toList 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)+ toListLev lev local = map (\ (key,(val,_)) -> (key,val)) (Map.toList local)   -- Returns all (key,value) pairs from the environment of the current scope @@ -127,7 +127,7 @@  where  toLevelListLev lev local     = map (\ (key,(val,_)) -> (key,val))-          (filter (\ (_,(_,lev')) -> lev' == lev) (envToList local))+          (filter (\ (_,(_,lev')) -> lev' == lev) (Map.toList local))   -- Returns the current level@@ -140,7 +140,7 @@ -- Privates...  ---modifySE :: (Int -> Env a (b,Int) -> Env a (b,Int)) -> ScopeEnv a b +modifySE :: (Int -> Map.Map a (b,Int) -> Map.Map a (b,Int)) -> ScopeEnv a b            -> ScopeEnv a b modifySE f (ScopeEnv _ top [])     = ScopeEnv 0 (f 0 top) []@@ -148,19 +148,19 @@    = ScopeEnv lev top ((f lev local):locals)  ---selectSE :: (Int -> Env a (b,Int) -> c) -> ScopeEnv a b -> c+selectSE :: (Int -> Map.Map 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 :: Ord a => Map.Map a (b,Int) -> (a,(b,Int)) ->  Map.Map a (b,Int) +          -> Map.Map a (b,Int) updateSE local (key,(_,lev)) local'    = maybe local'             (\ (val',lev') -	    -> if lev == lev' then bindEnv key (val',lev) local' +	    -> if lev == lev' then Map.insert key (val',lev) local'                                else local')-	   (lookupEnv key local)+	   (Map.lookup key local)   @@ -168,7 +168,7 @@ -------------------------------------------------------------------------------  -- Data type for representing information in nested scopes.-data ScopeEnv a b = ScopeEnv Int (Env a (b,Int)) [Env a (b,Int)]+data ScopeEnv a b = ScopeEnv Int (Map.Map a (b,Int)) [Map.Map a (b,Int)] 		    deriving Show
− src/ShowCurrySyntax.hs 
@@ -1,493 +0,0 @@---- 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
@@ -24,17 +24,23 @@  > module Simplify(simplify) where -> import Control.Monad+> import Control.Monad.Reader as R+> import Control.Monad.State as S+> import qualified Data.Map as Map +> import Curry.Base.Position+> import Curry.Base.Ident+> import Curry.Syntax+> import Curry.Syntax.Utils++> import Types > import Base-> import Combined-> import Env > import SCC > import Typing  -> type SimplifyState a = StateT ValueEnv (ReaderT EvalEnv (St Int)) a-> type InlineEnv = Env Ident Expression+> type SimplifyState a = S.StateT ValueEnv (ReaderT EvalEnv (S.State Int)) a+> type InlineEnv = Map.Map Ident Expression > type SimplifyFlags = Bool   > flatFlag :: SimplifyFlags -> Bool@@ -42,13 +48,13 @@  > simplify :: SimplifyFlags -> ValueEnv -> EvalEnv -> Module -> (Module,ValueEnv) > simplify flags tyEnv evEnv m ->   = runSt (callRt (callSt (simplifyModule flags m) tyEnv) evEnv) 1+>   = S.evalState (R.runReaderT (S.evalStateT (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+>     ds' <- mapM (simplifyDecl flat m Map.empty) ds+>     tyEnv <- S.get >     return (Module m es ds',tyEnv)  > simplifyDecl :: SimplifyFlags -> ModuleIdent -> InlineEnv -> Decl -> SimplifyState Decl@@ -135,22 +141,23 @@ > simplifyEquation flat m env (Equation p lhs rhs) = >   do >     rhs' <- simplifyRhs flat m env rhs->     tyEnv <- fetchSt->     evEnv <- liftSt envRt+>     tyEnv <- S.get+>     evEnv <- S.lift R.ask >     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') &&+>   | True -- False -- inlining of functions is deactivated (hsi)+>    && 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'+>     map (mergeEqns 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) =+>         mergeEqns 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@@ -188,7 +195,7 @@ > simplifyExpr flat m env (Variable v) >   | isQualified v = return (Variable v) >   | otherwise = maybe (return (Variable v)) (simplifyExpr flat m env)->                       (lookupEnv (unqualify v) env)+>                       (Map.lookup (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))@@ -203,7 +210,7 @@ >     return (Apply e1' e2') > simplifyExpr flags m env (Let ds e) = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     dss' <- mapM (sharePatternRhs m tyEnv) ds >     simplifyLet flags m env >       (scc bv (qfv m) (foldr (hoistDecls flags) [] (concat dss'))) e@@ -251,7 +258,7 @@ > simplifyLet flags m env (ds:dss) e = >   do >     ds' <- mapM (simplifyDecl flags m env) ds->     tyEnv <- fetchSt+>     tyEnv <- S.get >     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'@@ -260,13 +267,15 @@  > 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+>   | canInline e = Map.insert v e env+>   where+>   canInline (Literal _) = True+>   canInline (Constructor _) = True+>   canInline _ = False -- inlining of variables is deactivated (hsi)+>   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@@ -431,14 +440,14 @@ >             _ -> internalError ("funType " ++ show f)  > evMode :: EvalEnv -> Ident -> Maybe EvalAnnotation-> evMode evEnv f = lookupEnv f evEnv+> evMode evEnv f = Map.lookup 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)+>     x <- liftM f (S.lift (R.lift ( S.modify succ >> S.get)))+>     S.modify (bindFun m x ty) >     return x  > shuffle :: [a] -> [[a]]
src/SyntaxCheck.lhs view
@@ -24,12 +24,16 @@  > import Data.Maybe > import Data.List-> import Control.Monad+> import qualified Data.Map as Map+> import Control.Monad.State as S +> import Curry.Syntax+> import Curry.Syntax.Utils+> import Types+> import Curry.Base.Position+> import Curry.Base.Ident > import Base-> import Env > import NestEnv-> import Combined > import Utils  \end{verbatim}@@ -44,8 +48,7 @@ addition, this process will also rename the local variables. \begin{verbatim} -> syntaxCheck :: Bool -> ModuleIdent -> ImportEnv -> ArityEnv -> ValueEnv ->                -> TCEnv -> [Decl] -> [Decl]+> 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)@@ -59,22 +62,18 @@ >	               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 = St Int a+> type RenameState a = S.State Int a  > run :: RenameState a -> a-> run m = runSt m (globalKey + 1)+> run m = S.evalState m (globalKey + 1)  > newId :: RenameState Int-> newId = updateSt (1 +)+> newId = S.modify succ >> S.get  \end{verbatim} \ToDo{Probably the state transformer should use an \texttt{Integer} @@ -113,7 +112,7 @@ > renameInfo tcEnv iEnv aEnv (NewtypeConstructor _ _)  >    = Constr 1 > renameInfo tcEnv iEnv aEnv (Value qid _)->    = let (mmid, id) = splitQualIdent qid+>    = let (mmid, id) = (qualidMod qid, qualidId qid) >          qid' = maybe qid  >	                (\mid -> maybe qid  >		                       (\mid' -> qualifyWith mid' id)@@ -234,7 +233,7 @@ >    | (isJust mmid) && ((fromJust mmid) == preludeMIdent) && (ident == consId) >       = qualLookupNestEnv (qualify ident) env >    | otherwise = []->  where (mmid, ident) = splitQualIdent v+>  where (mmid, ident) = (qualidMod v, qualidId v)  > lookupTupleConstr :: Ident -> [RenameInfo] > lookupTupleConstr v@@ -256,13 +255,6 @@ > 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@@ -370,7 +362,7 @@ >   | 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+>   where (m,op') = (qualidMod op, qualidId op) >         op'' = renameIdent op' k > checkOpLhs _ _ f t = Right (f t) @@ -591,8 +583,7 @@ > 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+>     let (Field _ label _) = head fs >     in  case (lookupVar label env) of >           [] -> errorAt' (undefinedLabel label) >           [RecordLabel r ls]@@ -741,7 +732,7 @@ > checkExpr withExt p m env (RecordConstr fs) >   | not withExt = errorAt p noRecordExt >   | not (null fs) = ->     let (Field _ label expr) = head fs+>     let (Field _ label _) = head fs >     in  case (lookupVar label env) of >           [] -> errorAt' (undefinedLabel label) >	    [RecordLabel r ls]@@ -772,7 +763,7 @@ > checkExpr withExt p m env (RecordUpdate fs e) >   | not withExt = errorAt p noRecordExt >   | not (null fs) =->     let (Field _ label expr) = head fs+>     let (Field _ label _) = head fs >     in  case (lookupVar label env) of >           [] -> errorAt' (undefinedLabel label) >	    [RecordLabel r ls]@@ -868,16 +859,16 @@ it is necessary to sort the list of declarations.  > sortFuncDecls :: [Decl] -> [Decl]-> sortFuncDecls decls = sortFD emptyEnv [] decls+> sortFuncDecls decls = sortFD Map.empty [] decls >  where >  sortFD env res [] = reverse res >  sortFD env res (decl:decls) >     = case decl of >	  FunctionDecl _ ident _->	     | isJust (lookupEnv ident env)+>	     | isJust (Map.lookup ident env) >	       -> sortFD env (insertBy cmpFuncDecl decl res) decls >	     | otherwise->              -> sortFD (bindEnv ident () env) (decl:res) decls+>              -> sortFD (Map.insert ident () env) (decl:res) decls >	  _    -> sortFD env (decl:res) decls  > cmpFuncDecl :: Decl -> Decl -> Ordering@@ -886,26 +877,13 @@ >    | 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+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@@ -1106,18 +1084,6 @@ >   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"
src/SyntaxColoring.hs view
@@ -1,24 +1,24 @@ module SyntaxColoring (Program,Code(..),TypeKind(..),ConstructorKind(..),-                       IdentifierKind(..),FunctionKind(..),filename2program,+                       IdentifierKind(..),FunctionKind(..), genProgram,                        code2string,getQualIdent, position2code,                        area2codes) where  import Debug.Trace+import Data.Function(on)  import Data.Maybe+import Data.Either 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) +import Curry.Base.Position+import Curry.Base.Ident+import Curry.Base.MessageMonad+import Curry.Syntax +import Curry.Syntax.Lexer ++ debug = False -- mergen von Token und Codes  trace' s x = if debug then trace s x else x@@ -28,10 +28,6 @@  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@@ -47,9 +43,9 @@            | CharCode String            | Symbol String            | Identifier IdentifierKind QualIdent-           | CodeWarning [Message] Code-           | CodeError [Message] Code-           | NotParsed String deriving Show+           | CodeWarning [WarnMsg] Code+           | NotParsed String+             deriving Show             data TypeKind = TypeDecla               | TypeUse@@ -71,50 +67,21 @@                   | 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)   -     +genProgram :: String -> [MsgMonad Module] -> MsgMonad [(Position,Token)] -> Program       +genProgram plainText parseResults m+    = case runMsg m of+        (Left e, msgs) -> buildMessagesIntoPlainText (e : msgs) plainText+        (Right posNtokList, mess) +            -> let messages = (prepareMessages (concatMap getMessages parseResults ++ mess))+                   mergedMessages = (mergeMessages' (trace' ("Messages: " ++ show messages) messages) posNtokList)+                   (nameList,codes) = catIdentifiers parseResults+               in tokenNcodes2codes nameList 1 1 mergedMessages codes       --- @param Program@@ -138,25 +105,9 @@      | 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                      +      posEnd   = Position file l (c + length (code2string code)) noRef                   +   --- @param code --- @return qualIdent if available                    getQualIdent :: Code -> Maybe QualIdent@@ -167,18 +118,12 @@ 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+setMessagePosition :: WarnMsg -> WarnMsg+setMessagePosition m@(WarnMsg (Just p) _) = trace'' ("pos:" ++ show p ++ ":" ++ show m) m+setMessagePosition (WarnMsg _ m) = +        let mes@(WarnMsg pos _) =  (WarnMsg (getPositionFromString m) m) in         trace'' ("pos:" ++ show pos ++ ":" ++ show mes) mes  getPositionFromString :: String -> Maybe Position@@ -208,7 +153,6 @@  flatCode :: Code -> Code flatCode (CodeWarning _ code) = code-flatCode (CodeError _ code) = code flatCode code = code               @@ -216,31 +160,28 @@ -- ----------Message---------------------------------------                                      -getMessages :: Result a -> [Message]-getMessages (Result mess _) = mess-getMessages (Failure mess) = mess+getMessages :: MsgMonad a -> [WarnMsg]+getMessages = snd . runMsg --(Result mess _) = mess+-- getMessages (Failure mess) = mess -lessMessage :: Message -> Message -> Bool-lessMessage (Message _ mPos1 _) (Message _ mPos2 _) = mPos1 < mPos2+lessMessage :: WarnMsg -> WarnMsg -> Bool+lessMessage (WarnMsg mPos1 _) (WarnMsg mPos2 _) = mPos1 < mPos2 -nubMessages :: [Message] -> [Message] +nubMessages :: [WarnMsg] -> [WarnMsg]  nubMessages = nubBy eqMessage -eqMessage :: Message -> Message -> Bool-eqMessage (Message f1 p1 s1) (Message f2 p2 s2) = (f1 == f2) && (p1 == p2) && (s1 == s2)+eqMessage :: WarnMsg -> WarnMsg -> Bool+eqMessage (WarnMsg p1 s1) (WarnMsg p2 s2) = (p1 == p2) && (s1 == s2) -prepareMessages :: [Message] -> [Message]   +prepareMessages :: [WarnMsg] -> [WarnMsg]    prepareMessages = qsort lessMessage . map setMessagePosition . nubMessages -hasError [] = False-hasError ((Message Error _ _):ms) = True-hasError (_:ms) = hasError ms -buildMessagesIntoPlainText :: [Message] -> String -> Program+buildMessagesIntoPlainText :: [WarnMsg] -> String -> Program buildMessagesIntoPlainText messages text =      buildMessagesIntoPlainText' messages (lines text) [] 1  where-    buildMessagesIntoPlainText' :: [Message] -> [String] -> [String] -> Int -> Program+    buildMessagesIntoPlainText' :: [WarnMsg] -> [String] -> [String] -> Int -> Program     buildMessagesIntoPlainText' _ [] [] _ =            []     buildMessagesIntoPlainText' _ [] postStrs line = @@ -253,11 +194,11 @@           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)) +                  (ln,1,CodeWarning pre (NotParsed str)) :+                  (ln,1,NewLine) :+                  buildMessagesIntoPlainText' post preStrs [] (ln + 1)       where -         isLeq (Message _ (Just p) _) = line p <= ln +         isLeq (WarnMsg (Just p) _) = line p <= ln           isLeq _ = True                          @@ -265,19 +206,19 @@        --- @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+catIdentifiers :: [MsgMonad Module] -> ([(ModuleIdent,ModuleIdent)],[Code])+catIdentifiers = catIds . rights . map (fst . runMsg)+    where +      catIds [] = ([],[])+      catIds [m] =+          catIdentifiers' m Nothing+      catIds rs@(m:y:ys) =  +          catIdentifiers' (last rs) (Just m)     +-- not in base befoer base4++rights  xs = [ x | Right x <- xs]+ --- @param parse-Module --- @param Maybe betterParse-Module     catIdentifiers' :: Module -> Maybe Module -> ([(ModuleIdent,ModuleIdent)],[Code])@@ -285,19 +226,18 @@                 Nothing =       let codes = (concatMap decl2codes (qsort lessDecl decls)) in       (concatMap renamedImports decls,      -      ([ModuleName moduleIdent] ++-       (maybe [] exportSpec2codes  maybeExportSpec)  ++-       codes))     +      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) $+        map (addModuleIdent moduleIdent)           ([ModuleName moduleIdent] ++-           (mergeExports2codes  +           mergeExports2codes                 (maybe [] (\(Exporting _ i) -> i)  maybeExportSpec1)-              (maybe [] (\(Exporting _ i) -> i)  maybeExportSpec2))  +++              (maybe [] (\(Exporting _ i) -> i)  maybeExportSpec2) ++            codes))              @@ -325,55 +265,46 @@  idOccur2functionCall :: [QualIdent] -> Code -> Code idOccur2functionCall qualIdents ide@(Identifier IdOccur qualIdent)  -   | isQualified qualIdent = (Function FunctionCall qualIdent)-   | elem qualIdent qualIdents = (Function FunctionCall 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))       +       CodeWarning mess (idOccur2functionCall qualIdents code) idOccur2functionCall _ code = code     addModuleIdent :: ModuleIdent -> Code -> Code-addModuleIdent moduleIdent (Function x qualIdent) +addModuleIdent moduleIdent c@(Function x qualIdent)      | uniqueId (unqualify qualIdent) == 0 =-        (Function x (qualQualify moduleIdent qualIdent))-    | otherwise = (Function x qualIdent)   +        Function x (qualQualify moduleIdent qualIdent)+    | otherwise = c addModuleIdent moduleIdent cn@(ConstructorName x qualIdent)      | not $ isQualified qualIdent =-        (ConstructorName x (qualQualify moduleIdent qualIdent)) +        ConstructorName x (qualQualify moduleIdent qualIdent)     | otherwise = cn        addModuleIdent moduleIdent tc@(TypeConstructor TypeDecla qualIdent)      | not $ isQualified qualIdent =-        (TypeConstructor TypeDecla (qualQualify moduleIdent 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))       +    CodeWarning 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' :: [WarnMsg] -> [(Position,Token)] -> [([WarnMsg],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 +mergeMessages' mss@(m@(WarnMsg 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 :: [(ModuleIdent,ModuleIdent)] -> Int -> Int -> [([WarnMsg],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: ")+           trace' " NewLine: "            ((currLine,currCol,NewLine) :            tokenNcodes2codes nameList (currLine + 1) 1 toks codes)     | currCol < col =  @@ -419,14 +350,11 @@       newLine  = (currLine + length (lines tokenStr)) - 1        newCol   = currCol + length tokenStr    -      rename mid = Just $ maybe mid id (lookup mid nameList)+      rename mid = Just $ fromMaybe mid (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)+         | null messages = (l,c,code):cs          | otherwise = trace' ("Warning bei code: " ++ show codes ++ ":" ++ show messages)                                ((l,c,CodeWarning messages code): addMessage cs)       @@ -434,12 +362,12 @@ 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))+        Function x qualIdent -> Function x (rename qualIdent (qualidMod qualIdent))+        Identifier x qualIdent -> Identifier x (rename qualIdent (qualidMod qualIdent))         _ -> c   where-    rename x (Nothing,_) = x-    rename x (Just m,i) = maybe x (\ m' -> qualifyWith m' i) (lookup m nameList)+    rename x (Nothing) = x+    rename x (Just m) = maybe x (\ m' -> qualifyWith m' (qualidId x)) (lookup m nameList)             {- codeWithoutUniqueID ::  Code -> String@@ -454,11 +382,11 @@ codeQualifiers = maybe [] moduleQualifiers . getModuleIdent  getModuleIdent :: Code -> Maybe ModuleIdent-getModuleIdent (ConstructorName _ qualIdent) = fst $ splitQualIdent qualIdent-getModuleIdent (Function _ qualIdent) = fst $ splitQualIdent qualIdent+getModuleIdent (ConstructorName _ qualIdent) = qualidMod qualIdent+getModuleIdent (Function _ qualIdent) = qualidMod qualIdent getModuleIdent (ModuleName moduleIdent) = Just moduleIdent-getModuleIdent (Identifier _ qualIdent) = fst $ splitQualIdent qualIdent                     -getModuleIdent (TypeConstructor _ qualIdent) = fst $ splitQualIdent qualIdent+getModuleIdent (Identifier _ qualIdent) = qualidMod qualIdent                     +getModuleIdent (TypeConstructor _ qualIdent) = qualidMod qualIdent getModuleIdent _ = Nothing  @@ -551,7 +479,7 @@                lessDecl :: Decl -> Decl -> Bool-lessDecl decl1 decl2 = getPosition decl1 < getPosition decl2+lessDecl = (<) `on` getPosition  qsort _ []     = [] qsort less (x:xs) = qsort less [y | y <- xs, less y x] ++ [x] ++ qsort less [y | y <- xs, not $ less y x]@@ -598,7 +526,7 @@              export2codes _ (ExportTypeWith qualIdent idents) = -     [TypeConstructor TypeExport qualIdent] ++ map (Function OtherFunctionKind . qualify) idents+     TypeConstructor TypeExport qualIdent : map (Function OtherFunctionKind . qualify) idents export2codes _ (ExportTypeAll  qualIdent) =       [TypeConstructor TypeExport qualIdent]   export2codes _ (ExportModule moduleIdent) = @@ -610,9 +538,9 @@      maybe [] ((:[]) . ModuleName) mModuleIdent ++      maybe [] (importSpec2codes moduleIdent)  importSpec decl2codes (InfixDecl _ _ _ idents) =-     (map (Function InfixFunction . qualify) idents) +     map (Function InfixFunction . qualify) idents decl2codes (DataDecl _ ident idents constrDecls) =-     [TypeConstructor TypeDecla (qualify ident)] ++ +     TypeConstructor TypeDecla (qualify ident) :       map (Identifier UnknownId . qualify) idents ++      concatMap constrDecl2codes constrDecls decl2codes (NewtypeDecl xPosition xIdent yIdents xNewConstrDecl) =@@ -642,7 +570,7 @@       lhs2codes :: Lhs -> [Code] lhs2codes (FunLhs ident constrTerms) =-    (Function FunDecl $ qualify ident) : concatMap constrTerm2codes 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) =@@ -663,17 +591,17 @@ constrTerm2codes (NegativePattern ident literal) = [] constrTerm2codes (VariablePattern ident) = [Identifier IdDecl (qualify ident)] constrTerm2codes (ConstructorPattern qualIdent constrTerms) =-    (ConstructorName ConstrPattern qualIdent) : concatMap constrTerm2codes 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+    Function OtherFunctionKind (qualify ident) : constrTerm2codes constrTerm constrTerm2codes (LazyPattern _ constrTerm) = constrTerm2codes constrTerm constrTerm2codes (FunctionPattern qualIdent constrTerms) = -    (Function OtherFunctionKind qualIdent) : concatMap constrTerm2codes constrTerms+    Function OtherFunctionKind qualIdent : concatMap constrTerm2codes constrTerms constrTerm2codes (InfixFuncPattern constrTerm1 qualIdent constrTerm2) =     constrTerm2codes constrTerm1 ++ [Function InfixFunction qualIdent] ++ constrTerm2codes constrTerm2    @@ -704,7 +632,7 @@     expression2codes expression2 ++      expression2codes expression3 expression2codes (UnaryMinus ident expression) = -    [Symbol (name ident)] ++ expression2codes expression +    Symbol (name ident) : expression2codes expression  expression2codes (Apply expression1 expression2) =      expression2codes expression1 ++ expression2codes expression2 expression2codes (InfixApply expression1 infixOp expression2) = @@ -744,7 +672,7 @@           constrDecl2codes :: ConstrDecl -> [Code] constrDecl2codes (ConstrDecl _ idents ident typeExprs) =-    (ConstructorName ConstrDecla $ qualify ident) : concatMap typeExpr2codes typeExprs+    ConstructorName ConstrDecla (qualify ident) : concatMap typeExpr2codes typeExprs constrDecl2codes (ConOpDecl _ idents typeExpr1 ident typeExpr2) =        typeExpr2codes typeExpr1 ++ [ConstructorName ConstrDecla $ qualify ident] ++ typeExpr2codes typeExpr2 @@ -757,14 +685,14 @@ import2codes moduleIdent (Import ident) =      [Function OtherFunctionKind $ qualifyWith moduleIdent ident]   import2codes moduleIdent (ImportTypeWith ident idents) = -     [ConstructorName OtherConstrKind $ qualifyWith moduleIdent ident] ++ +     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+    TypeConstructor TypeUse qualIdent : concatMap typeExpr2codes typeExprs typeExpr2codes (VariableType ident) =      [Identifier IdOccur (qualify ident)] typeExpr2codes (TupleType typeExprs) = @@ -851,14 +779,13 @@ 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 : "'"+    toString c = '\'' : c : "'"  showSt = addQuotes . concatMap toGoodChar     where@@ -870,4 +797,4 @@    | c == '"' = "\\\""    | otherwise = c : ""   where-     justShow = reverse . tail . reverse . tail . show+     justShow = init . tail . show
src/TopEnv.lhs view
@@ -41,10 +41,10 @@ >               allImports,moduleImports,localBindings) where  > import Data.Maybe+> import qualified Data.Map as Map+> import Control.Arrow(second)+> import Curry.Base.Ident -> import Env-> import Ident-> import Utils  > data Source = Local | Import [ModuleIdent] deriving (Eq,Show) @@ -55,32 +55,32 @@ >    | origName x == origName y = Just x >    | otherwise = Nothing -> newtype TopEnv a = TopEnv (Env QualIdent [(Source,a)]) deriving Show+> newtype TopEnv a = TopEnv (Map.Map QualIdent [(Source,a)]) deriving Show  > instance Functor TopEnv where->   fmap f (TopEnv env) = TopEnv (fmap (map (apSnd f)) env)+>   fmap f (TopEnv env) = TopEnv (fmap (map (second f)) env) -> entities :: QualIdent -> Env QualIdent [(Source,a)] -> [(Source,a)]-> entities x env = fromMaybe [] (lookupEnv x env)+> entities :: QualIdent -> Map.Map QualIdent [(Source,a)] -> [(Source,a)]+> entities x env = fromMaybe [] (Map.lookup x env)  > emptyTopEnv :: TopEnv a-> emptyTopEnv = TopEnv emptyEnv+> emptyTopEnv = TopEnv Map.empty  > predefTopEnv :: Entity a => QualIdent -> a -> TopEnv a -> TopEnv a > predefTopEnv x y (TopEnv env) =->   case lookupEnv x env of+>   case Map.lookup x env of >     Just _ -> error "internal error: predefTopEnv"->     Nothing -> TopEnv (bindEnv x [(Import [],y)] env)+>     Nothing -> TopEnv (Map.insert 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)+>   TopEnv (Map.insert 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)+>   TopEnv (Map.insert x' (mergeImport m y (entities x' env)) env) >   where x' = qualifyWith m x  > mergeImport :: Entity a => ModuleIdent -> a -> [(Source,a)] -> [(Source,a)]@@ -96,7 +96,7 @@  > qualBindTopEnv :: String -> QualIdent -> a -> TopEnv a -> TopEnv a > qualBindTopEnv fun x y (TopEnv env) =->   TopEnv (bindEnv x (bindLocal y (entities x env)) env)+>   TopEnv (Map.insert x (bindLocal y (entities x env)) env) >   where bindLocal y ys >           | null [y' | (Local,y') <- ys] = (Local,y) : ys >           | otherwise = error ("internal error: \"qualBindTopEnv " @@ -108,14 +108,14 @@  > qualRebindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a > qualRebindTopEnv x y (TopEnv env) =->   TopEnv (bindEnv x (rebindLocal (entities x env)) env)+>   TopEnv (Map.insert 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)+>   TopEnv (Map.insert x' (unbindLocal (entities x' env)) env) >   where x' = qualify x >         unbindLocal [] = error "internal error: unbindTopEnv" >         unbindLocal ((Local,_) : ys) = ys@@ -129,11 +129,11 @@  > allImports :: TopEnv a -> [(QualIdent,a)] > allImports (TopEnv env) =->   [(x,y) | (x,ys) <- envToList env, (Import _,y) <- ys]+>   [(x,y) | (x,ys) <- Map.toList env, (Import _,y) <- ys]  > unqualBindings :: TopEnv a -> [(Ident,(Source,a))] > unqualBindings (TopEnv env) =->   [(x',y) | (x,ys) <- takeWhile (not . isQualified . fst) (envToList env),+>   [(x',y) | (x,ys) <- takeWhile (not . isQualified . fst) (Map.toList env), >             let x' = unqualify x, y <- ys]  > moduleImports :: ModuleIdent -> TopEnv a -> [(Ident,a)]
src/TypeCheck.lhs view
@@ -21,21 +21,25 @@ type annotation is present. \begin{verbatim} -> module TypeCheck(typeCheck,typeCheckGoal) where+> module TypeCheck(typeCheck) where -> import Control.Monad+> import Control.Monad.State as S > import Data.List > import Data.Maybe+> import qualified Data.Map as Map > import qualified Data.Set as Set +> import Curry.Base.Position+> import Curry.Base.Ident+> import Curry.Syntax+> import Curry.Syntax.Pretty+> import Curry.Syntax.Utils++ > import Base-> import Pretty-> import Ident-> import CurryPP-> import Env+> import Types+> import PrettyCombinators > import TopEnv--> import Combined > import SCC > import TypeSubst > import Utils@@ -57,36 +61,24 @@  > typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv,ValueEnv) > typeCheck m tcEnv tyEnv ds =->   run (tcDecls m tcEnv' emptyEnv vds >>->        liftSt fetchSt >>= \theta -> fetchSt >>= \tyEnv' ->+>   run (tcDecls m tcEnv' Map.empty vds >>+>        S.lift S.get >>= \theta -> S.get >>= \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 (St Int)) a+> type TcState a = S.StateT ValueEnv (S.StateT TypeSubst (S.State Int)) a  > run :: TcState a -> ValueEnv -> a-> run m tyEnv = runSt (callSt (callSt m tyEnv) idSubst) 0+> run m tyEnv = S.evalState (S.evalStateT (S.evalStateT m tyEnv) idSubst) 0  \end{verbatim} \paragraph{Defining Types}@@ -218,10 +210,10 @@ inferred type is less general than the signature. \begin{verbatim} -> type SigEnv = Env Ident TypeExpr+> type SigEnv = Map.Map Ident TypeExpr  > bindTypeSig :: Ident -> TypeExpr -> SigEnv -> SigEnv-> bindTypeSig = bindEnv+> bindTypeSig = Map.insert  > bindTypeSigs :: Decl -> SigEnv -> SigEnv > bindTypeSigs (TypeSig _ vs ty) env =@@ -229,7 +221,7 @@ > bindTypeSigs _ env = env  > lookupTypeSig :: Ident -> SigEnv -> Maybe TypeExpr-> lookupTypeSig = lookupEnv+> lookupTypeSig = Map.lookup  > qualLookupTypeSig :: ModuleIdent -> QualIdent -> SigEnv -> Maybe TypeExpr > qualLookupTypeSig m f sigs = localIdent m f >>= flip lookupTypeSig sigs@@ -259,8 +251,8 @@ > 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+>         (tys', _) = nameTypes tys tvs+>         (rty', _) = nameTypes (maybeToList rty) tvs          \end{verbatim} \paragraph{Type Inference}@@ -302,17 +294,17 @@ >   mapM_ (tcExtraVar m tcEnv sigs ) vs > tcDeclGroup m tcEnv sigs ds = >   do->     tyEnv0 <- fetchSt+>     tyEnv0 <- S.get >     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+>     theta <- S.lift S.get >     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)))+> --  S.modify (bindFun m f (checkForeignType cc (expandPolyType tcEnv ty))) > --  where checkForeignType CallConvPrimitive ty = ty > --        checkForeignType CallConvCCall (ForAll n ty) = > --          ForAll n (checkCCallType ty)@@ -332,11 +324,11 @@  > tcExternalFunct :: ModuleIdent -> TCEnv -> Ident -> TypeExpr -> TcState () > tcExternalFunct m tcEnv  f ty =->   updateSt_ (bindFun m f (expandPolyType m tcEnv ty))+>   S.modify (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+>   typeOf f tcEnv sigs >>= S.modify . bindFun m f >   where typeOf f tcEnv sigs = >           case lookupTypeSig f sigs of >             Just ty -> return (expandPolyType m tcEnv ty)@@ -345,7 +337,7 @@ > tcExtraVar :: ModuleIdent -> TCEnv -> SigEnv -> Ident >            -> TcState () > tcExtraVar m tcEnv sigs v =->   typeOf v tcEnv sigs >>= updateSt_ . bindFun m v . monoType+>   typeOf v tcEnv sigs >>= S.modify . bindFun m v . monoType >   where typeOf v tcEnv sigs = >           case lookupTypeSig v sigs of >             Just ty@@ -404,9 +396,9 @@ > genDecl :: ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst -> Decl >         -> TcState () > genDecl m tcEnv sigs lvs theta (FunctionDecl _ f _) =->   updateSt_ (genVar True m tcEnv sigs lvs theta f)+>   S.modify (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)+>   mapM_ (S.modify . genVar False m tcEnv sigs lvs theta ) (bv t)  > genVar :: Bool -> ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst >        -> Ident -> ValueEnv -> ValueEnv@@ -442,7 +434,7 @@ > tcLiteral m (Int v _)  = --return intType >   do >     ty <- freshConstrained [intType,floatType]->     updateSt_ (bindFun m v (monoType ty))+>     S.modify (bindFun m v (monoType ty)) >     return ty > tcLiteral _ (Float _ _) = return floatType > tcLiteral _ (String _ _) = return stringType@@ -456,12 +448,12 @@ >     ty <- case lookupTypeSig v sigs of >             Just t -> inst (expandPolyType m tcEnv t) >             Nothing -> freshTypeVar->     updateSt_ (bindFun m v (monoType ty))+>     S.modify (bindFun m v (monoType ty)) >     return ty >    > tcConstrTerm m tcEnv sigs p t@(ConstructorPattern c ts) = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     ty <- skol (constrType m c tyEnv) >     unifyArgs (ppConstrTerm 0 t) ts ty >   where unifyArgs _ [] ty = return ty@@ -473,7 +465,7 @@ >         unifyArgs _ _ _ = internalError "tcConstrTerm" > tcConstrTerm m tcEnv sigs p t@(InfixPattern t1 op t2) = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     ty <- skol (constrType m op tyEnv) >     unifyArgs (ppConstrTerm 0 t) [t1,t2] ty >   where unifyArgs _ [] ty = return ty@@ -504,7 +496,7 @@ > 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+>     tyEnv <- S.get >     ty <- inst (funType m f tyEnv) --skol (constrType m c tyEnv) >     unifyArgs (ppConstrTerm 0 t) ts ty >   where unifyArgs _ [] ty = return ty@@ -553,14 +545,14 @@ >     ty <- maybe freshTypeVar  >                 (inst . expandPolyType m tcEnv)  >                 (lookupTypeSig v sigs)->     tyEnv <- fetchSt->     ty' <- maybe (updateSt_ (bindFun m v (monoType ty)) >> return ty)+>     tyEnv <- S.get+>     ty' <- maybe (S.modify (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+>     tyEnv <- S.get >     ty <- skol (constrType m c tyEnv) >     unifyArgs (ppConstrTerm 0 t) ts ty >   where unifyArgs _ [] ty = return ty@@ -572,7 +564,7 @@ >         unifyArgs _ _ _ = internalError "tcConstrTermFP" > tcConstrTermFP m tcEnv sigs p t@(InfixPattern t1 op t2) = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     ty <- skol (constrType m op tyEnv) >     unifyArgs (ppConstrTerm 0 t) [t1,t2] ty >   where unifyArgs _ [] ty = return ty@@ -603,7 +595,7 @@ > 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+>     tyEnv <- S.get >     ty <- inst (funType m f tyEnv) --skol (constrType m c tyEnv) >     unifyArgs (ppConstrTerm 0 t) ts ty >   where unifyArgs _ [] ty = return ty@@ -640,11 +632,11 @@ >             -> Field ConstrTerm -> TcState (Ident,Type) > tcFieldPatt tcPatt m f@(Field _ l t) = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     let p = positionOfIdent l >     lty <- maybe (freshTypeVar >	             >>= (\lty' ->->		           updateSt_+>		           S.modify >		             (bindLabel l (qualifyWith m (mkIdent "#Rec")) >		                        (polyType lty')) >		           >> return lty'))@@ -689,15 +681,15 @@ > 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+>     Nothing -> S.get >>= inst . funType m v+> tcExpr m tcEnv sigs p (Constructor c) = S.get >>= instExist . constrType m c > tcExpr m tcEnv sigs p (Typed e sig) = >   do->     tyEnv0 <- fetchSt+>     tyEnv0 <- S.get >     ty <- tcExpr m tcEnv sigs p e >     inst sigma' >>= >       flip (unify p "explicitly typed expression" (ppExpr 0 e) m) ty->     theta <- liftSt fetchSt+>     theta <- S.lift S.get >     let sigma = gen (fvEnv (subst theta tyEnv0)) (subst theta ty) >     unless (sigma == sigma') >       (errorAt p (typeSigTooGeneral m (text "Expression:" <+> ppExpr 0 e)@@ -718,7 +710,7 @@ >           tcElems doc es ty > tcExpr m tcEnv sigs p (ListCompr _ e qs) = >   do->     tyEnv0 <- fetchSt+>     tyEnv0 <- S.get >     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)@@ -814,21 +806,21 @@ >     return (TypeArrow alpha gamma) > tcExpr m tcEnv sigs p exp@(Lambda r ts e) = >   do->     tyEnv0 <- fetchSt+>     tyEnv0 <- S.get >     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+>     tyEnv0 <- S.get+>     theta <- S.lift S.get >     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+>     tyEnv0 <- S.get >     mapM_ (tcStmt m tcEnv sigs p) sts >     alpha <- freshTypeVar >     ty <- tcExpr m tcEnv sigs p e@@ -846,7 +838,7 @@ >     return ty3 > tcExpr m tcEnv sigs p (Case _ e alts) = >   do->     tyEnv0 <- fetchSt+>     tyEnv0 <- S.get >     ty <- tcExpr m tcEnv sigs p e >     alpha <- freshTypeVar >     tcAlts tyEnv0 ty alpha alts@@ -868,10 +860,10 @@ > tcExpr m tcEnv sigs p r@(RecordSelection e l) = >   do >     ty <- tcExpr m tcEnv sigs p e->     tyEnv <- fetchSt+>     tyEnv <- S.get >     lty <- maybe (freshTypeVar  >	             >>= (\lty' -> ->		           updateSt_ +>		           S.modify  >		             (bindLabel l (qualifyWith m (mkIdent "#Rec")) >		                        (monoType lty')) >	                   >> return lty'))@@ -923,11 +915,11 @@ >	      -> TcState (Ident,Type) > tcFieldExpr m tcEnv sigs comb f@(Field _ l e) = >   do->     tyEnv <- fetchSt+>     tyEnv <- S.get >     let p = positionOfIdent l >     lty <- maybe (freshTypeVar  >	             >>= (\lty' -> ->		           updateSt_ +>		           S.modify  >		             (bindLabel l (qualifyWith m (mkIdent "#Rec")) >		                          (monoType lty')) >	                   >> return lty'))@@ -950,14 +942,14 @@ >         -> TcState (Type,Type) > tcArrow p what doc m ty = >   do->     theta <- liftSt fetchSt+>     theta <- S.lift S.get >     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)))+>             S.lift (S.modify (bindVar tv (TypeArrow alpha beta))) >             return (alpha,beta) >         unaryArrow ty = errorAt p (nonFunctionType what doc m ty) @@ -969,7 +961,7 @@ >           do >             beta <- freshTypeVar >             gamma <- freshTypeVar->             liftSt (updateSt_ (bindVar tv (TypeArrow beta gamma)))+>             S.lift (S.modify (bindVar tv (TypeArrow beta gamma))) >             return (ty1,beta,gamma) >         binaryArrow ty1 ty2 = >           errorAt p (nonBinaryOp what doc m (TypeArrow ty1 ty2))@@ -983,13 +975,13 @@ > unify :: Position -> String -> Doc -> ModuleIdent -> Type -> Type >       -> TcState () > unify p what doc m ty1 ty2 =->   liftSt $ {-$-}+>   S.lift $ {-$-} >   do->     theta <- fetchSt+>     theta <- S.get >     let ty1' = subst theta ty1 >     let ty2' = subst theta ty2 >     either (errorAt p . typeMismatch what doc m ty1' ty2')->            (updateSt_ . compose)+>            (S.modify . compose) >            (unifyTypes m ty1' ty2')  > unifyTypes :: ModuleIdent -> Type -> Type -> Either Doc TypeSubst@@ -1086,7 +1078,7 @@ >              -> TcState Type > checkSkolems p m what tyEnv ty = >   do->     theta <- liftSt fetchSt+>     theta <- S.lift S.get >     let ty' = subst theta ty >         fs = fsEnv (subst theta tyEnv) >     unless (all (`Set.member` fs) (typeSkolems ty'))@@ -1100,7 +1092,7 @@ \begin{verbatim}  > fresh :: (Int -> a) -> TcState a-> fresh f = liftM f (liftSt (liftSt (updateSt (1 +))))+> fresh f = liftM f (S.lift (S.lift (S.modify succ >> S.get)))  > freshVar :: (Int -> a) -> TcState a > freshVar f = fresh (\n -> f (- n - 1))@@ -1184,20 +1176,6 @@ >             [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@@ -1319,11 +1297,6 @@ >   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 @@ -1345,3 +1318,14 @@ >        text "are incompatible"]  \end{verbatim}+++\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
src/TypeSubst.lhs view
@@ -15,6 +15,8 @@ > import Data.Maybe > import Data.List +> import Types+ > import Subst > import Base > import TopEnv
src/Types.lhs view
@@ -16,7 +16,7 @@ > import Data.List > import Data.Maybe -> import Ident+> import Curry.Base.Ident  \end{verbatim} A type is either a type variable, an application of a type constructor@@ -47,7 +47,7 @@ >   | TypeArrow Type Type >   | TypeSkolem Int >   | TypeRecord [(Ident,Type)] (Maybe Int)->   deriving (Eq,Show)+>   deriving (Show, Eq)  \end{verbatim} The function \texttt{isArrowType} checks whether a type is a function@@ -172,8 +172,8 @@ quantified variables. \begin{verbatim} -> data TypeScheme = ForAll Int Type deriving (Eq,Show)-> data ExistTypeScheme = ForAllExist Int Int Type deriving (Eq,Show)+> data TypeScheme = ForAll Int Type deriving (Show, Eq)+> data ExistTypeScheme = ForAllExist Int Int Type deriving (Show, Eq)  \end{verbatim} The functions \texttt{monoType} and \texttt{polyType} translate a type@@ -215,3 +215,37 @@ > typeVar = TypeVariable  \end{verbatim}++++> 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+++> 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+
src/Typing.lhs view
@@ -12,10 +12,14 @@  > import Data.Maybe > import Control.Monad+> import Control.Monad.State as S +> import Curry.Base.Ident+> import Curry.Syntax++> import Types > import Base > import TypeSubst-> import Combined > import TopEnv > import Utils @@ -84,10 +88,10 @@ environment.} \begin{verbatim} -> type TyState a = StateT TypeSubst (St Int) a+> type TyState a = S.StateT TypeSubst (S.State Int) a  > run :: TyState a -> ValueEnv -> a-> run m tyEnv = runSt (callSt m idSubst) 0+> run m tyEnv = S.evalState (S.evalStateT m idSubst) 0  > class Typeable a where >   typeOf :: ValueEnv -> a -> Type@@ -108,7 +112,7 @@ >   where doComputeType = >           do >             ty <- f tyEnv x->             theta <- fetchSt+>             theta <- S.get >             return (fixTypeVars tyEnv (subst theta ty))  > fixTypeVars :: ValueEnv -> Type -> Type@@ -281,7 +285,7 @@ \begin{verbatim}  > freshTypeVar :: TyState Type-> freshTypeVar = liftM TypeVariable $ liftSt $ updateSt (1 +)+> freshTypeVar = liftM TypeVariable $ S.lift (S.modify succ >> S.get)  > instType :: Int -> Type -> TyState Type > instType n ty =@@ -304,7 +308,7 @@  > unify :: Type -> Type -> TyState () > unify ty1 ty2 =->   updateSt_ (\theta -> unifyTypes (subst theta ty1) (subst theta ty2) theta)+>   S.modify (\theta -> unifyTypes (subst theta ty1) (subst theta ty2) theta)  > unifyList :: [Type] -> [Type] -> TyState () > unifyList tys1 tys2 = sequence_ (zipWith unify tys1 tys2)@@ -312,14 +316,14 @@ > unifyArrow :: Type -> TyState (Type,Type) > unifyArrow ty = >   do->     theta <- fetchSt+>     theta <- S.get >     case subst theta ty of >       TypeVariable tv >         | tv >= 0 -> >             do >               ty1 <- freshTypeVar >               ty2 <- freshTypeVar->               updateSt_ (bindVar tv (TypeArrow ty1 ty2))+>               S.modify (bindVar tv (TypeArrow ty1 ty2)) >               return (ty1,ty2) >       TypeArrow ty1 ty2 -> return (ty1,ty2) >       ty' -> internalError ("unifyArrow (" ++ show ty' ++ ")")
− src/Unlit.lhs 
@@ -1,110 +0,0 @@-% -*- 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
@@ -12,16 +12,10 @@ \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}+> import Data.List(foldl') -> apFst f (x,y) = (f x,y)-> apSnd f (x,y) = (x,f y)+> infixr 5 ++!  \end{verbatim} \paragraph{Triples}@@ -62,9 +56,9 @@ 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+foldl_strict :: (a -> b -> a) -> a -> [b] -> a+foldl_strict = foldl'+  \end{verbatim} \paragraph{Folding with two lists}
src/WarnCheck.hs view
@@ -8,22 +8,47 @@ -- module WarnCheck (warnCheck) where -import Control.Monad+import Control.Monad.State+import qualified Data.Map as Map import Data.List -import CurrySyntax-import Ident-import Position-import Base (ValueEnv, ValueInfo(..), qualLookupValue, lookupValue)+import Curry.Base.Ident+import Curry.Base.Position+import Curry.Base.MessageMonad+import Curry.Syntax++import Base (ValueEnv, ValueInfo(..), qualLookupValue) import TopEnv import qualified ScopeEnv import ScopeEnv (ScopeEnv)-import Message-import Env  +------------------------------------------------------------------------------- +-- 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. +type CheckState = State CState++data CState = CState {messages  :: [WarnMsg],+		      scope     :: ScopeEnv QualIdent IdInfo,+		      values    :: ValueEnv,+		      moduleId  :: ModuleIdent }++-- Runs a 'CheckState' action and returns the list of messages+run ::  CheckState a -> [WarnMsg]+run f+   = reverse (messages (execState f emptyState))++emptyState :: CState+emptyState = CState {messages  = [],+		     scope     = ScopeEnv.new,+		     values    = emptyTopEnv,+		     moduleId  = mkMIdent []+		    }+ -------------------------------------------------------------------------------  -- Find potentially incorrect code in a Curry program and generate@@ -33,7 +58,7 @@ --    - idle case alternatives --    - overlapping case alternatives --    - function rules which are not together-warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [Message]+warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [WarnMsg] warnCheck mid vals imports decls    = run (do addImportedValues vals 	     addModuleId mid@@ -164,6 +189,7 @@ 	     (foldM' genWarning' (map unrefVar idents')) 	endScope + -- checkCondExpr :: ModuleIdent -> CondExpr -> CheckState () checkCondExpr mid (CondExpr _ cond expr)@@ -325,6 +351,7 @@ 	checkOverlappingAlts mid alts  --+-- FIXME this looks buggy: is alts' required to be non-null or not? (hsi) checkIdleAlts :: ModuleIdent -> [Alt] -> CheckState () checkIdleAlts mid alts    = do alts' <- dropUnless' isVarAlt alts@@ -382,16 +409,16 @@  -- Find function rules which are not together checkDeclOccurrences :: [Decl] -> CheckState ()-checkDeclOccurrences decls = checkDO (mkIdent "") emptyEnv decls+checkDeclOccurrences decls = checkDO (mkIdent "") Map.empty 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)+          then (maybe (checkDO ident (Map.insert ident pos env) decls) 	              (\pos' -> genWarning' (rulesNotTogether ident pos') 		                >> checkDO ident env decls)-	              (lookupEnv ident env))+	              (Map.lookup ident env)) 	  else checkDO ident env decls  checkDO _ env (_:decls)      = checkDO (mkIdent "") env decls@@ -399,15 +426,15 @@  -- check import declarations for multiply imported modules checkImports :: [Decl] -> CheckState ()-checkImports imps = checkImps emptyEnv imps+checkImports imps = checkImps Map.empty imps  where  checkImps env [] = return ()  checkImps env ((ImportDecl pos mid _ _ spec):imps)     | mid /= preludeMIdent-      = maybe (checkImps (bindEnv mid (fromImpSpec spec) env) imps)+      = maybe (checkImps (Map.insert mid (fromImpSpec spec) env) imps)               (\ishs -> checkImpSpec env pos mid ishs spec 	                >>= (\env' -> checkImps env' imps))-	      (lookupEnv mid env)+	      (Map.lookup mid env)     | otherwise       = checkImps env imps  checkImps env (_:imps) = checkImps env imps@@ -417,21 +444,21 @@  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)+	   return (Map.insert mid (is',hs) env)     | null iis-      = return (bindEnv mid (is' ++ is,hs) env)+      = return (Map.insert mid (is' ++ is,hs) env)     | otherwise       = do foldM' genWarning' 		  (map ((multiplyImportedSymbol mid) . impName) iis)-	   return (bindEnv mid (unionBy cmpImport is' is,hs) env)+	   return (Map.insert 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)+      = return (Map.insert mid (is,hs' ++ hs) env)     | otherwise       = do foldM' genWarning'  		  (map ((multiplyHiddenSymbol mid) . impName) ihs)-	   return (bindEnv mid (is,unionBy cmpImport hs' hs) env)+	   return (Map.insert mid (is,unionBy cmpImport hs' hs) env)   where ihs = intersectBy cmpImport hs' hs   cmpImport (ImportTypeWith id1 cs1) (ImportTypeWith id2 cs2)@@ -572,68 +599,29 @@ 		       _         -> 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+	       -> CState -> CState 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 -> String -> CheckState ()+genWarning pos msg+   = modify (\state -> state{ messages = warnMsg:(messages state) })+ where warnMsg = WarnMsg (Just 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 +genWarning' :: (Position, String) -> CheckState ()+genWarning' (pos, msg)+   = modify (\state -> state{ messages = warnMsg:(messages state) })+    where warnMsg = WarnMsg (Just pos) msg   -- insertVar :: Ident -> CheckState () insertVar id     | isAnnonId id = return ()    | otherwise-     = CheckState +     = modify           (\state -> modifyScope  	              (ScopeEnv.insert (commonId id) (VarInfo False)) state) @@ -642,101 +630,90 @@ insertTypeVar id    | isAnnonId id = return ()    | otherwise    -     = CheckState +     = modify           (\state -> modifyScope  	              (ScopeEnv.insert (typeId id) (VarInfo False)) state)  -- insertConsId :: Ident -> CheckState () insertConsId id-   = CheckState +   = modify         (\state -> modifyScope (ScopeEnv.insert (commonId id) ConsInfo) state)  -- insertTypeConsId :: Ident -> CheckState () insertTypeConsId id-   = CheckState +   = modify         (\state -> modifyScope (ScopeEnv.insert (typeId id) ConsInfo) state)  -- isVarId :: Ident -> CheckState Bool isVarId id-   = CheckState (\state -> state{ result = isVar state (commonId id) })+   = gets (\state -> isVar state (commonId id))  -- isConsId :: Ident -> CheckState Bool isConsId id -   = CheckState (\state -> state{ result = isCons state (qualify id) })+   = gets (\state -> isCons state (qualify id))  -- isQualConsId :: QualIdent -> CheckState Bool isQualConsId qid-   = CheckState (\state -> state{ result = isCons state qid })+   = gets (\state -> 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) })+   = gets (\state -> isShadowing state (commonId id))  -- visitId :: Ident -> CheckState () visitId id -   = CheckState +   = modify         (\state -> modifyScope  	            (ScopeEnv.modify visitVariable (commonId id)) state)  -- visitTypeId :: Ident -> CheckState () visitTypeId id -   = CheckState +   = modify         (\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) })+   = gets (\state -> isUnref state (typeId id))  -- returnUnrefVars :: CheckState [Ident] returnUnrefVars -   = CheckState (\state -> +   = gets (\state ->  	   	    let ids    = map fst (ScopeEnv.toLevelList (scope state))                         unrefs = filter (isUnref state) ids-	            in  state{ result = map unqualify unrefs })+	            in  map unqualify unrefs )  -- addModuleId :: ModuleIdent -> CheckState ()-addModuleId mid = CheckState (\state -> state{ moduleId = mid })+addModuleId mid = modify (\state -> state{ moduleId = mid })  ---returnModuleId :: CheckState ModuleIdent-returnModuleId = CheckState (\state -> state{ result = moduleId state }) +withScope :: CheckState a -> CheckState ()+withScope m = beginScope >> m >> endScope+ -- beginScope :: CheckState ()-beginScope = CheckState (\state -> modifyScope ScopeEnv.beginScope state)+beginScope = modify (\state -> modifyScope ScopeEnv.beginScope state)  -- endScope :: CheckState ()-endScope = CheckState (\state -> modifyScope ScopeEnv.endScopeUp state)+endScope = modify (\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 })+addImportedValues vals = modify (\state -> state{ values = vals })  -- foldM' :: (a -> CheckState ()) -> [a] -> CheckState ()@@ -768,36 +745,31 @@ 	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 :: CState -> 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 :: CState -> 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 :: CState -> QualIdent -> Bool isVar state qid = maybe (isAnnonId (unqualify qid))  	           isVariable  		   (ScopeEnv.lookup qid (scope state))  ---isCons :: CState a -> QualIdent -> Bool+isCons :: CState -> QualIdent -> Bool isCons state qid = maybe (isImportedCons state qid) 		         isConstructor 			 (ScopeEnv.lookup qid (scope state))@@ -831,56 +803,49 @@ ------------------------------------------------------------------------------- -- Warnings... -unrefTypeVar :: Ident -> (Position,WarningType,String)+unrefTypeVar :: Ident -> (Position, String) unrefTypeVar id =    (positionOfIdent id,-   UnrefTypeVar,    "unreferenced type variable \"" ++ show id ++ "\"") -unrefVar :: Ident -> (Position,WarningType,String)+unrefVar :: Ident -> (Position, String) unrefVar id =    (positionOfIdent id,-   UnrefVar,-   "unreferenced variable \"" ++ show id ++ "\"")+   "unused declaration of variable \"" ++ show id ++ "\"") -shadowingVar :: Ident -> (Position,WarningType,String)+shadowingVar :: Ident -> (Position, String) shadowingVar id =    (positionOfIdent id,-   ShadowingVar,    "shadowing symbol \"" ++ show id ++ "\"") -idleCaseAlts :: (WarningType,String)-idleCaseAlts = (IdleCaseAlt,"idle case alternative(s)")+idleCaseAlts :: String+idleCaseAlts = "idle case alternative(s)" -overlappingCaseAlt :: (WarningType,String)-overlappingCaseAlt = (OverlapCase,"redundant overlapping case alternative")+overlappingCaseAlt :: String+overlappingCaseAlt = "redundant overlapping case alternative" -rulesNotTogether :: Ident -> Position -> (Position,WarningType,String)+rulesNotTogether :: Ident -> Position -> (Position, 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 :: ModuleIdent -> (Position, String) multiplyImportedModule mid    = (positionOfModuleIdent mid,-     MultipleImportModule,      "module \"" ++ show mid ++ "\" was imported more than once") -multiplyImportedSymbol :: ModuleIdent -> Ident -> (Position,WarningType,String)+multiplyImportedSymbol :: ModuleIdent -> Ident -> (Position, 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 :: ModuleIdent -> Ident -> (Position, String) multiplyHiddenSymbol mid ident   = (positionOfIdent ident,-     MultipleHiding,      "symbol \"" ++ show ident ++ "\" from module \"" ++ show mid      ++ "\" was hidden more than once") @@ -893,9 +858,6 @@ 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
src/cymake.hs view
@@ -16,13 +16,13 @@ import Data.List import Data.Maybe import System.IO-import System.Environment-import System.Exit+import System.Environment(getArgs, getProgName)+import System.Exit(ExitCode(..), exitWith) import Control.Monad (unless) import Data.Char (isDigit)  import GetOpt-import CurryBuilder+import CurryBuilder(buildCurry) import CurryCompilerOpts import CurryHtml @@ -45,7 +45,7 @@    | null errs' && not (elem Html opts)    = do        unless (noVerb options')                (putStrLn  $ "This is cymake, version 0.1." -                         ++ filter isDigit "$Revision: 3624 $")+                         ++ filter isDigit "$Revision: 3630 $")        mapM_ (buildCurry options') files    | null errs' = do       let importFiles = nub $ importPaths opts'