diff --git a/curry-frontend.cabal b/curry-frontend.cabal
--- a/curry-frontend.cabal
+++ b/curry-frontend.cabal
@@ -1,5 +1,5 @@
Name: curry-frontend
-Version: 0.2.2
+Version: 0.2.3
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".
@@ -25,36 +25,29 @@
Executable cymake
hs-source-dirs: src
Main-is: cymake.hs
- Build-Depends: base >= 3 && < 4, mtl, old-time, directory, filepath, containers
- 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
+ Build-Depends: base >= 3 && < 4, curry-base == 0.2.2, mtl, old-time, containers, pretty
+ ghc-options: -fwarn-unused-binds -fwarn-unused-imports -auto-all
+ Other-Modules: 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
+ Curry.AbstractCurry,
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, Filenames,
+ Imports,
TypeCheck,
InterfaceCheck,
Types, Frontend, PrecCheck
TypeSubst, GenAbstractCurry
- PrettyCombinators, Typing
+ Typing
GenFlatCurry, KindCheck, Qual
SCC, Utils, GetOpt
Lift, ScopeEnv, WarnCheck
- Desugar, Curry.Base.Ident,
+ Desugar,
Simplify
-
--- Executable pretty-ecy
--- hs-source-dirs: src
--- Main-is: pretty-ecy.hs
--- Build-Depends: base >= 3 && < 4
diff --git a/src/Base.lhs b/src/Base.lhs
--- a/src/Base.lhs
+++ b/src/Base.lhs
@@ -25,7 +25,7 @@
> import Curry.Base.Ident
> import Curry.Base.Position
> import Types
-> import Curry.Syntax
+> import qualified Curry.Syntax as CS
> import Curry.Syntax.Utils
> import TopEnv
> import Utils
@@ -47,33 +47,33 @@
order of type variables in the left hand side of a type declaration.
\begin{verbatim}
-> toQualType :: ModuleIdent -> [Ident] -> TypeExpr -> Type
+> toQualType :: ModuleIdent -> [Ident] -> CS.TypeExpr -> Type
> toQualType m tvs = qualifyType m . toType tvs
-> toQualTypes :: ModuleIdent -> [Ident] -> [TypeExpr] -> [Type]
+> toQualTypes :: ModuleIdent -> [Ident] -> [CS.TypeExpr] -> [Type]
> toQualTypes m tvs = map (qualifyType m) . toTypes tvs
-> toType :: [Ident] -> TypeExpr -> Type
+> toType :: [Ident] -> CS.TypeExpr -> Type
> toType tvs ty = toType' (Map.fromList (zip (tvs ++ tvs') [0..])) ty
> where tvs' = [tv | tv <- nub (fv ty), tv `notElem` tvs]
-> toTypes :: [Ident] -> [TypeExpr] -> [Type]
+> toTypes :: [Ident] -> [CS.TypeExpr] -> [Type]
> toTypes tvs tys = map (toType' (Map.fromList (zip (tvs ++ tvs') [0..]))) tys
> where tvs' = [tv | tv <- nub (concatMap fv tys), tv `notElem` tvs]
-> toType' :: Map.Map Ident Int -> TypeExpr -> Type
-> toType' tvs (ConstructorType tc tys) =
+> toType' :: Map.Map Ident Int -> CS.TypeExpr -> Type
+> toType' tvs (CS.ConstructorType tc tys) =
> TypeConstructor tc (map (toType' tvs) tys)
-> toType' tvs (VariableType tv) =
+> toType' tvs (CS.VariableType tv) =
> maybe (internalError ("toType " ++ show tv)) TypeVariable (Map.lookup tv tvs)
-> toType' tvs (TupleType tys)
+> toType' tvs (CS.TupleType tys)
> | null tys = TypeConstructor (qualify unitId) []
> | otherwise = TypeConstructor (qualify (tupleId (length tys'))) tys'
> where tys' = map (toType' tvs) tys
-> toType' tvs (ListType ty) = TypeConstructor (qualify listId) [toType' tvs ty]
-> toType' tvs (ArrowType ty1 ty2) =
+> toType' tvs (CS.ListType ty) = TypeConstructor (qualify listId) [toType' tvs ty]
+> toType' tvs (CS.ArrowType ty1 ty2) =
> TypeArrow (toType' tvs ty1) (toType' tvs ty2)
-> toType' tvs (RecordType fs rty) =
+> toType' tvs (CS.RecordType fs rty) =
> TypeRecord (concatMap (\ (ls,ty) -> map (\l -> (l, toType' tvs ty)) ls) fs)
> (maybe Nothing
> (\ty -> case toType' tvs ty of
@@ -81,25 +81,25 @@
> _ -> internalError ("toType " ++ show ty))
> rty)
-> fromQualType :: ModuleIdent -> Type -> TypeExpr
+> fromQualType :: ModuleIdent -> Type -> CS.TypeExpr
> fromQualType m = fromType . unqualifyType m
-> fromType :: Type -> TypeExpr
+> fromType :: Type -> CS.TypeExpr
> fromType (TypeConstructor tc tys)
-> | isTupleId c = TupleType tys'
-> | c == listId && length tys == 1 = ListType (head tys')
-> | c == unitId && null tys = TupleType []
-> | otherwise = ConstructorType tc tys'
+> | isTupleId c = CS.TupleType tys'
+> | c == listId && length tys == 1 = CS.ListType (head tys')
+> | c == unitId && null tys = CS.TupleType []
+> | otherwise = CS.ConstructorType tc tys'
> where c = unqualify tc
> tys' = map fromType tys
> fromType (TypeVariable tv) =
-> VariableType (if tv >= 0 then nameSupply !! tv
+> CS.VariableType (if tv >= 0 then nameSupply !! tv
> else mkIdent ('_' : show (-tv)))
> fromType (TypeConstrained tys _) = fromType (head tys)
-> fromType (TypeArrow ty1 ty2) = ArrowType (fromType ty1) (fromType ty2)
-> fromType (TypeSkolem k) = VariableType (mkIdent ("_?" ++ show k))
+> fromType (TypeArrow ty1 ty2) = CS.ArrowType (fromType ty1) (fromType ty2)
+> fromType (TypeSkolem k) = CS.VariableType (mkIdent ("_?" ++ show k))
> fromType (TypeRecord fs rty) =
-> RecordType (map (\ (l,ty) -> ([l], fromType ty)) fs)
+> CS.RecordType (map (\ (l,ty) -> ([l], fromType ty)) fs)
> (maybe Nothing (Just . fromType . TypeVariable) rty)
@@ -109,44 +109,19 @@
The compiler maintains a global environment holding all (directly or
indirectly) imported interfaces.
-The function \texttt{bindFlatInterfac} transforms FlatInterface
+The function \texttt{bindFlatInterface} transforms FlatInterface
information (type \texttt{FlatCurry.Prog} to MCC interface declarations
(type \texttt{CurrySyntax.IDecl}. This is necessary to process
FlatInterfaces instead of ".icurry" files when using MCC as frontend
for PAKCS.
\begin{verbatim}
-> type ModuleEnv = Map.Map ModuleIdent [IDecl]
+> type ModuleEnv = Map.Map ModuleIdent [CS.IDecl]
-> lookupModule :: ModuleIdent -> ModuleEnv -> Maybe [IDecl]
+> lookupModule :: ModuleIdent -> ModuleEnv -> Maybe [CS.IDecl]
> lookupModule = Map.lookup
-\end{verbatim}
-The label environment is used to store information of labels.
-Unlike unsual identifiers like in functions, types etc. identifiers
-of labels are always represented unqualified. Since the common type
-environment (type \texttt{ValueEnv}) has some problems with handling
-imported unqualified identifiers, it is necessary to process the type
-information for labels seperately.
-\begin{verbatim}
-> data LabelInfo = LabelType Ident QualIdent Type deriving Show
-
-> type LabelEnv = Map.Map Ident [LabelInfo]
-
-> bindLabelType :: Ident -> QualIdent -> Type -> LabelEnv -> LabelEnv
-> bindLabelType l r ty 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 = Map.findWithDefault []
-
-> initLabelEnv :: LabelEnv
-> initLabelEnv = Map.empty
-
-
\end{verbatim}
\paragraph{Type constructors}
For all defined types the compiler must maintain kind information. At
@@ -404,8 +379,8 @@
> type ImportEnv = Map.Map ModuleIdent ModuleIdent
-> bindAlias :: Decl -> ImportEnv -> ImportEnv
-> bindAlias (ImportDecl _ mid _ mmid _)
+> bindAlias :: CS.Decl -> ImportEnv -> ImportEnv
+> bindAlias (CS.ImportDecl _ mid _ mmid _)
> = Map.insert mid (fromMaybe mid mmid)
> lookupAlias :: ModuleIdent -> ImportEnv -> Maybe ModuleIdent
@@ -432,16 +407,16 @@
introduction of unlimited integer constants in the parser / lexer.
\begin{verbatim}
-> data OpPrec = OpPrec Infix Integer deriving Eq
+> data OpPrec = OpPrec CS.Infix Integer deriving Eq
> instance Show OpPrec where
> showsPrec _ (OpPrec fix p) = showString (assoc fix) . shows p
-> where assoc InfixL = "left "
-> assoc InfixR = "right "
-> assoc Infix = "non-assoc "
+> where assoc CS.InfixL = "left "
+> assoc CS.InfixR = "right "
+> assoc CS.Infix = "non-assoc "
> defaultP :: OpPrec
-> defaultP = OpPrec InfixL 9
+> defaultP = OpPrec CS.InfixL 9
\end{verbatim}
The lookup functions for the environment which maintains the operator
@@ -478,7 +453,7 @@
sufficient.
\begin{verbatim}
-> type EvalEnv = Map.Map Ident EvalAnnotation
+> type EvalEnv = Map.Map Ident CS.EvalAnnotation
\end{verbatim}
@@ -501,7 +476,7 @@
> initPEnv :: PEnv
> initPEnv =
-> predefTopEnv qConsId (PrecInfo qConsId (OpPrec InfixR 5)) emptyTopEnv
+> predefTopEnv qConsId (PrecInfo qConsId (OpPrec CS.InfixR 5)) emptyTopEnv
> initTCEnv :: TCEnv
> initTCEnv = foldr (uncurry predefTC) emptyTopEnv predefTypes
@@ -564,66 +539,19 @@
\ToDo{The \texttt{nameSupply} should respect the current case mode,
i.e., use upper case for variables in Prolog mode.}
-Here is a list of predicates identifying various kinds of
-declarations.
-\begin{verbatim}
-
-> isImportDecl, isInfixDecl, isTypeDecl :: Decl -> Bool
-> isTypeSig, isEvalAnnot, isExtraVariables, isValueDecl :: Decl -> Bool
-> isImportDecl (ImportDecl _ _ _ _ _) = True
-> isImportDecl _ = False
-> isInfixDecl (InfixDecl _ _ _ _) = True
-> isInfixDecl _ = False
-> isTypeDecl (DataDecl _ _ _ _) = True
-> isTypeDecl (NewtypeDecl _ _ _ _) = True
-> isTypeDecl (TypeDecl _ _ _ _) = True
-> isTypeDecl _ = False
-> isTypeSig (TypeSig _ _ _) = True
-> isTypeSig (ExternalDecl _ _ _ _ _) = True
-> isTypeSig _ = False
-> isEvalAnnot (EvalAnnot _ _ _) = True
-> isEvalAnnot _ = False
-> isExtraVariables (ExtraVariables _ _) = True
-> isExtraVariables _ = False
-> isValueDecl (FunctionDecl _ _ _) = True
-> isValueDecl (ExternalDecl _ _ _ _ _) = True
-> isValueDecl (FlatExternalDecl _ _) = True
-> isValueDecl (PatternDecl _ _ _) = True
-> isValueDecl (ExtraVariables _ _) = True
-> isValueDecl _ = False
-> isRecordDecl (TypeDecl _ _ _ (RecordType _ _)) = True
-> isRecordDecl _ = False
-
-> isIImportDecl :: IDecl -> Bool
-> isIImportDecl (IImportDecl _ _) = True
-> isIImportDecl _ = False
-
\end{verbatim}
-The function \texttt{infixOp} converts an infix operator into an
-expression.
-\begin{verbatim}
-
-> infixOp :: InfixOp -> Expression
-> infixOp (InfixOp op) = Variable op
-> infixOp (InfixConstr op) = Constructor op
-
-\end{verbatim}
-The function \texttt{linear} checks whether a list of entities is
+The function \texttt{findDouble} checks whether a list of entities is
linear, i.e., if every entity in the list occurs only once. If it is
non-linear, the first offending object is returned.
\begin{verbatim}
-> data Linear a = Linear | NonLinear a
-
-> linear :: Eq a => [a] -> Linear a
-> linear (x:xs)
-> | x `elem` xs = NonLinear x
-> | otherwise = linear xs
-> linear [] = Linear
+> findDouble :: Eq a => [a] -> Maybe a
+> findDouble (x:xs)
+> | x `elem` xs = Just x
+> | otherwise = findDouble xs
+> findDouble [] = Nothing
\end{verbatim}
-
-
diff --git a/src/Curry/AbstractCurry.hs b/src/Curry/AbstractCurry.hs
--- a/src/Curry/AbstractCurry.hs
+++ b/src/Curry/AbstractCurry.hs
@@ -30,7 +30,7 @@
import Data.List(intersperse)
-import PathUtils (writeModule,readModule)
+import Curry.Files.PathUtils (writeModule,readModule)
------------------------------------------------------------------------------
diff --git a/src/Curry/Base/Ident.lhs b/src/Curry/Base/Ident.lhs
deleted file mode 100644
--- a/src/Curry/Base/Ident.lhs
+++ /dev/null
@@ -1,352 +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 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)
diff --git a/src/Curry/Base/MessageMonad.hs b/src/Curry/Base/MessageMonad.hs
deleted file mode 100644
--- a/src/Curry/Base/MessageMonad.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-{-# 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
diff --git a/src/Curry/Base/Position.lhs b/src/Curry/Base/Position.lhs
deleted file mode 100644
--- a/src/Curry/Base/Position.lhs
+++ /dev/null
@@ -1,96 +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 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
diff --git a/src/Curry/ExtendedFlat.hs b/src/Curry/ExtendedFlat.hs
deleted file mode 100644
--- a/src/Curry/ExtendedFlat.hs
+++ /dev/null
@@ -1,475 +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 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
----
---- (Prog modname imports typedecls functions opdecls translation_table)
----
---- 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.
----
---- 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.
----
-
-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.
----
---- 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.
----
-
-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:
----
---- 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
----
---- @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.
----
---- 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).
----
-
-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
-
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
diff --git a/src/Curry/Syntax/LLParseComb.lhs b/src/Curry/Syntax/LLParseComb.lhs
--- a/src/Curry/Syntax/LLParseComb.lhs
+++ b/src/Curry/Syntax/LLParseComb.lhs
@@ -1,4 +1,3 @@
-% -*- LaTeX -*-
% $Id: LLParseComb.lhs,v 1.26 2004/02/15 23:11:30 wlux Exp $
%
% Copyright (c) 1999-2004, Wolfgang Lux
@@ -49,7 +48,6 @@
> 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
@@ -60,7 +58,7 @@
> (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) $ -- $
+> showsPrec p (Parser e ps) = showParen (p >= 10) $
> showString "Parser " . shows (isJust e) .
> showChar ' ' . shows (Map.keysSet ps)
@@ -200,13 +198,13 @@
> f <$> p = succeed f <*> p
> (<$->) :: Symbol s => a -> Parser s b c -> Parser s a c
-> f <$-> p = const f <$> p {-$-}
+> f <$-> p = const f <$> p
> (<*->) :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c
-> p <*-> q = const <$> p <*> q {-$-}
+> 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 {-$-}
+> 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
@@ -238,7 +236,7 @@
> 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) {-$-}
+> 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
@@ -247,7 +245,7 @@
> 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) {-$-}
+> 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
diff --git a/src/Curry/Syntax/Lexer.lhs b/src/Curry/Syntax/Lexer.lhs
--- a/src/Curry/Syntax/Lexer.lhs
+++ b/src/Curry/Syntax/Lexer.lhs
@@ -273,7 +273,7 @@
> isIdent, isSym, isOctit, isHexit :: Char -> Bool
> isIdent c = isAlphaNum c || c `elem` "'_"
-> isSym 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'
diff --git a/src/Curry/Syntax/Pretty.lhs b/src/Curry/Syntax/Pretty.lhs
--- a/src/Curry/Syntax/Pretty.lhs
+++ b/src/Curry/Syntax/Pretty.lhs
@@ -15,10 +15,11 @@
> module Curry.Syntax.Pretty where
+> import Text.PrettyPrint.HughesPJ
+
> import Curry.Base.Ident
> import Curry.Syntax.Type
-> import PrettyCombinators
\end{verbatim}
Pretty print a module
diff --git a/src/Curry/Syntax/Utils.hs b/src/Curry/Syntax/Utils.hs
--- a/src/Curry/Syntax/Utils.hs
+++ b/src/Curry/Syntax/Utils.hs
@@ -1,8 +1,15 @@
module Curry.Syntax.Utils(Expr, fv, qfv,
- QuantExpr, bv) where
+ QuantExpr, bv,
+ isEvalAnnot, isTypeSig,
+ infixOp,
+ isTypeDecl, isValueDecl,
+ isInfixDecl,
+ isRecordDecl, isImportDecl) where
+
import qualified Data.Set as Set
+
import Curry.Base.Ident
import Curry.Syntax.Type
@@ -200,3 +207,51 @@
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)
+
+
+
+{-
+ Here is a list of predicates identifying various kinds of
+ declarations.
+-}
+
+isImportDecl, isInfixDecl, isTypeDecl :: Decl -> Bool
+isTypeSig, isEvalAnnot, isValueDecl :: Decl -> Bool
+
+isImportDecl (ImportDecl _ _ _ _ _) = True
+isImportDecl _ = False
+
+isInfixDecl (InfixDecl _ _ _ _) = True
+isInfixDecl _ = False
+
+isTypeDecl (DataDecl _ _ _ _) = True
+isTypeDecl (NewtypeDecl _ _ _ _) = True
+isTypeDecl (TypeDecl _ _ _ _) = True
+isTypeDecl _ = False
+
+isTypeSig (TypeSig _ _ _) = True
+isTypeSig (ExternalDecl _ _ _ _ _) = True
+isTypeSig _ = False
+
+isEvalAnnot (EvalAnnot _ _ _) = True
+isEvalAnnot _ = False
+
+isValueDecl (FunctionDecl _ _ _) = True
+isValueDecl (ExternalDecl _ _ _ _ _) = True
+isValueDecl (FlatExternalDecl _ _) = True
+isValueDecl (PatternDecl _ _ _) = True
+isValueDecl (ExtraVariables _ _) = True
+isValueDecl _ = False
+
+isRecordDecl (TypeDecl _ _ _ (RecordType _ _)) = True
+isRecordDecl _ = False
+
+
+{-
+ The function \texttt{infixOp} converts an infix operator into an
+ expression.
+-}
+
+infixOp :: InfixOp -> Expression
+infixOp (InfixOp op) = Variable op
+infixOp (InfixConstr op) = Constructor op
diff --git a/src/CurryBuilder.hs b/src/CurryBuilder.hs
--- a/src/CurryBuilder.hs
+++ b/src/CurryBuilder.hs
@@ -23,9 +23,15 @@
import Modules (compileModule)
import CurryCompilerOpts
import CurryDeps
-import Filenames
-import PathUtils
+import Curry.Files.Filenames
+import Curry.Files.PathUtils
+
+flatName' :: Options -> FilePath -> FilePath
+flatName' o
+ | extendedFlat o = extFlatName
+ | otherwise = flatName
+
-------------------------------------------------------------------------------
-- Compiles the Curry program 'file' including all imported modules, depending
@@ -64,7 +70,7 @@
= do
flatIntfExists <- doesModuleExist (flatIntName file')
if flatIntfExists
- then smake [flatName file'] --[flatName file', flatIntName file']
+ then smake [flatName' options file'] --[flatName file', flatIntName file']
(file':(catMaybes (map flatInterface mods)))
(compileFile file')
(skipFile file')
@@ -89,12 +95,12 @@
return ()
targetNames fn
- | flat options = [flatName fn] -- , flatIntName fn]
+ | flat options = [flatName' options fn] -- , flatIntName fn]
| flatXml options = [xmlName fn]
| abstract options = [acyName fn]
| untypedAbstract options = [uacyName fn]
| parseOnly options = [maybe (sourceRepName fn) id (output options)]
- | otherwise = [flatName fn] -- , flatIntName fn]
+ | otherwise = [flatName' options fn] -- , flatIntName fn]
flatInterface mod
= case (lookup mod deps) of
diff --git a/src/CurryCompilerOpts.hs b/src/CurryCompilerOpts.hs
--- a/src/CurryCompilerOpts.hs
+++ b/src/CurryCompilerOpts.hs
@@ -34,7 +34,7 @@
parseOnly :: Bool, -- generate source representation
withExtensions :: Bool, -- enable extended functionalities
dump :: [Dump] -- dumps
- }
+ } deriving Show
-- Default compiler options
@@ -116,10 +116,6 @@
"dump intermediate language before lifting",
Option "" ["dump-case"] (NoArg (Dump [DumpCase]))
"dump intermediate language after case simplification",
- Option "" ["dump-transformed"] (NoArg (Dump [DumpTransformed]))
- "dump IL code after debugging transformation",
- Option "" ["dump-normalized"] (NoArg (Dump [DumpNormalized]))
- "dump IL code after normalization",
Option "?h" ["help"] (NoArg Help)
"display this help and exit"
]
@@ -158,8 +154,6 @@
| DumpLifted -- dump source after lambda-lifting
| DumpIL -- dump IL code after translation
| DumpCase -- dump IL code after case elimination
- | DumpTransformed -- dump transformed code
- | DumpNormalized -- dump IL code after normalization
deriving (Eq,Bounded,Enum,Show)
diff --git a/src/CurryDeps.lhs b/src/CurryDeps.lhs
--- a/src/CurryDeps.lhs
+++ b/src/CurryDeps.lhs
@@ -25,11 +25,13 @@
> import Curry.Base.Ident
> import Curry.Base.MessageMonad
+> import Curry.Files.Filenames
+> import Curry.Files.PathUtils
+
> import Curry.Syntax hiding(Interface(..))
> import SCC
-> import Filenames
-> import PathUtils
+
> data Source = Source FilePath [ModuleIdent]
> | Interface FilePath
diff --git a/src/CurryEnv.hs b/src/CurryEnv.hs
--- a/src/CurryEnv.hs
+++ b/src/CurryEnv.hs
@@ -95,7 +95,7 @@
-- Generate interface declarations for all type synonyms in the module.
genTypeSyns :: TCEnv -> Module -> [IDecl]
genTypeSyns tcEnv (Module mident _ decls)
- = concatMap (genTypeSynDecl mident tcEnv) decls
+ = concatMap (genTypeSynDecl mident tcEnv) (filter isTypeSyn decls)
--
genTypeSynDecl :: ModuleIdent -> TCEnv -> Decl -> [IDecl]
@@ -170,3 +170,12 @@
[RenamingType qident' _ _] -> Just qident'
[AliasType qident' _ _] -> Just qident'
_ -> Nothing
+
+
+
+isTypeSyn :: Decl -> Bool
+isTypeSyn (TypeDecl _ _ _ texpr)
+ = case texpr of
+ RecordType _ _ -> False
+ _ -> True
+isTypeSyn _ = False
diff --git a/src/CurryHtml.hs b/src/CurryHtml.hs
--- a/src/CurryHtml.hs
+++ b/src/CurryHtml.hs
@@ -6,8 +6,9 @@
import Curry.Base.Ident
import Curry.Base.MessageMonad
+import Curry.Files.PathUtils (readModule, writeModule, getCurryPath)
+
import SyntaxColoring
-import PathUtils (readModule, writeModule, getCurryPath)
import Frontend
diff --git a/src/Desugar.lhs b/src/Desugar.lhs
--- a/src/Desugar.lhs
+++ b/src/Desugar.lhs
@@ -209,7 +209,7 @@
> where
> fixType tyEnv
> | typeOf tyEnv v == floatType
-> = Float (ast $ positionOfIdent v) (fromIntegral i)
+> = Float (srcRefOf $ positionOfIdent v) (fromIntegral i)
> | otherwise = Int v i
> desugarLiteral (Float p f) = return (Left (Float p f))
> desugarLiteral (String (SrcRef [i]) cs)
@@ -292,7 +292,7 @@
> do
> 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')
+> return (patDecl p{astRef=pos} t (mkVar v') : ds,VariablePattern v')
\end{verbatim}
diff --git a/src/Exports.lhs b/src/Exports.lhs
--- a/src/Exports.lhs
+++ b/src/Exports.lhs
@@ -40,15 +40,15 @@
> expandInterface :: Module -> TCEnv -> ValueEnv -> Module
> expandInterface (Module m es ds) tcEnv tyEnv =
> --error (show es')
-> case linear [unqualify tc | ExportTypeWith tc _ <- es'] of
-> Linear ->
-> case linear ([c | ExportTypeWith _ cs <- es', c <- cs] ++
+> case findDouble [unqualify tc | ExportTypeWith tc _ <- es'] of
+> Nothing ->
+> case findDouble ([c | ExportTypeWith _ cs <- es', c <- cs] ++
> [unqualify f | Export f <- es']) of
-> Linear -> Module m (Just (Exporting NoPos es')) ds
-> NonLinear v -> errorAt' (ambiguousExportValue v)
-> NonLinear tc -> errorAt' (ambiguousExportType tc)
+> Nothing -> Module m (Just (Exporting NoPos es')) ds
+> Just v -> errorAt' (ambiguousExportValue v)
+> Just tc -> errorAt' (ambiguousExportType tc)
> where ms = Set.fromList [fromMaybe m asM | ImportDecl _ m _ asM _ <- ds]
-> es' = joinExports $ -- $
+> es' = joinExports $
> maybe (expandLocalModule tcEnv tyEnv)
> (expandSpecs ms m tcEnv tyEnv)
> es
diff --git a/src/Filenames.hs b/src/Filenames.hs
deleted file mode 100644
--- a/src/Filenames.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-module Filenames(module Filenames,
-
- ) where
-
-import System.FilePath
-
--- Various filename extensions
-
-
-
-curryExt, lcurryExt, icurryExt, oExt :: String
-curryExt = ".curry"
-
-lcurryExt = ".lcurry"
-
-icurryExt = ".icurry"
-
-flatExt = ".fcy"
-
-flatIntExt = ".fint"
--- fintExt = ".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]
-
-{-
- 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.
--}
-
-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
diff --git a/src/Frontend.hs b/src/Frontend.hs
--- a/src/Frontend.hs
+++ b/src/Frontend.hs
@@ -15,18 +15,23 @@
import Control.Monad.Error
import Prelude hiding (lex)
-import Modules
-import CurryBuilder
-import CurryCompilerOpts
+
import Curry.Base.MessageMonad
+import Curry.Base.Ident
+import Curry.Base.Position
+
+import Curry.Files.Filenames
+import Curry.Files.PathUtils
+
import qualified Curry.Syntax as CS
import Curry.Syntax.Lexer
+import Modules
+import CurryBuilder
+import CurryCompilerOpts
+
import CurryDeps
-import Curry.Base.Ident
-import Curry.Base.Position
-import Filenames
-import PathUtils
+
import Base(ModuleEnv)
-------------------------------------------------------------------------------
diff --git a/src/GenAbstractCurry.hs b/src/GenAbstractCurry.hs
--- a/src/GenAbstractCurry.hs
+++ b/src/GenAbstractCurry.hs
@@ -17,6 +17,7 @@
import Data.Char
import Curry.Syntax
+import Curry.Syntax.Utils
import Curry.AbstractCurry
import Base
diff --git a/src/GenFlatCurry.hs b/src/GenFlatCurry.hs
--- a/src/GenFlatCurry.hs
+++ b/src/GenFlatCurry.hs
@@ -10,24 +10,32 @@
module GenFlatCurry (genFlatCurry,
genFlatInterface) where
+
import Control.Monad.State
import Control.Monad
import Data.Maybe
import Data.List
import qualified Data.Map as Map
+
import Curry.Base.MessageMonad
import Curry.Base.Ident as Id
+import qualified Curry.Syntax as CS
+
+import Curry.ExtendedFlat.Type
+import Curry.ExtendedFlat.TypeInference
+
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 TopEnv(topEnvMap)
import CurryEnv (CurryEnv)
import qualified CurryEnv
import ScopeEnv (ScopeEnv)
@@ -37,7 +45,8 @@
import PatchPrelude
-trace _ x = x
+import Debug.Trace
+trace' _ x = x
-------------------------------------------------------------------------------
@@ -45,9 +54,10 @@
genFlatCurry :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv
-> ArityEnv -> IL.Module -> (Prog, [WarnMsg])
genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv mod
- = (patchPreludeFCY prog, messages)
+ = (prog', messages)
where (prog, messages)
- = run opts cEnv mEnv tyEnv tcEnv aEnv False (visitModule mod)
+ = run opts cEnv mEnv tyEnv tcEnv aEnv False (visitModule mod)
+ prog' = adjustTypeInfo $ patchPreludeFCY prog
-- transforms intermediate language code (IL) to FlatCurry interfaces
@@ -62,10 +72,93 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
+
+-- The environment 'FlatEnv' is embedded in the monadic representation
+-- 'FlatState' which allows the usage of 'do' expressions.
+
+type FlatState a = State FlatEnv a
+
+-- Data type for representing an environment which contains information needed
+-- for generating FlatCurry code.
+data FlatEnv = FlatEnv{ moduleIdE :: ModuleIdent,
+ functionIdE :: (QualIdent, [(Ident, IL.Type)]),
+ compilerOptsE :: Options,
+ moduleEnvE :: ModuleEnv,
+ arityEnvE :: ArityEnv,
+ typeEnvE :: ValueEnv, -- types of defined values
+ tConsEnvE :: TCEnv,
+ publicEnvE :: Map.Map Ident IdentExport,
+ fixitiesE :: [CS.IDecl],
+ typeSynonymsE :: [CS.IDecl],
+ importsE :: [CS.IDecl],
+ exportsE :: [CS.Export],
+ interfaceE :: [CS.IDecl],
+ varIndexE :: Int,
+ varIdsE :: ScopeEnv Ident VarIndex,
+ tvarIndexE :: Int,
+ messagesE :: [WarnMsg],
+ genInterfaceE :: Bool,
+ localTypes :: Map.Map QualIdent IL.Type,
+ constrTypes :: Map.Map QualIdent IL.Type
+ }
+
+data IdentExport = NotConstr -- function, type-constructor
+ | OnlyConstr -- constructor
+ | NotOnlyConstr -- constructor, function, type-constructor
+
+
+
+
+-- Runs a 'FlatState' action and returns the result
+run :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv
+ -> Bool -> FlatState a -> (a, [WarnMsg])
+run opts cEnv mEnv tyEnv tcEnv aEnv genIntf f
+ = (result, messagesE env)
+ where
+ (result, env) = runState f env0
+ env0 = FlatEnv{ moduleIdE = CurryEnv.moduleId cEnv,
+ functionIdE = (qualify (mkIdent ""), []),
+ compilerOptsE = opts,
+ moduleEnvE = mEnv,
+ arityEnvE = aEnv,
+ typeEnvE = tyEnv,
+ tConsEnvE = tcEnv,
+ publicEnvE = genPubEnv (CurryEnv.moduleId cEnv)
+ (CurryEnv.interface cEnv),
+ fixitiesE = CurryEnv.infixDecls cEnv,
+ typeSynonymsE = CurryEnv.typeSynonyms cEnv,
+ importsE = CurryEnv.imports cEnv,
+ exportsE = CurryEnv.exports cEnv,
+ interfaceE = CurryEnv.interface cEnv,
+ varIndexE = 0,
+ varIdsE = ScopeEnv.new,
+ tvarIndexE =0,
+ messagesE = [],
+ genInterfaceE = genIntf,
+ localTypes = Map.empty,
+ constrTypes = Map.fromList (getConstrTypes tcEnv)
+ }
+
+getConstrTypes :: TCEnv -> [(QualIdent, IL.Type)]
+getConstrTypes tcEnv = trace' (show tinfos) tinfos
+ where tcList = Map.toList $ topEnvMap tcEnv
+ tinfos = [ foo tqid conid argtypes targnum
+ | (_, (_, DataType tqid targnum dts):_) <- tcList
+ , Just (Data conid _ argtypes) <- dts]
+ foo tqid conid argtypes targnum
+ = let conname = QualIdent (qualidMod tqid) conid
+ resulttype = IL.TypeConstructor tqid (map IL.TypeVariable [0..targnum-1])
+ contype = foldr IL.TypeArrow resulttype (map ttrans argtypes)
+ in (conname, contype)
+
+
--
visitModule :: IL.Module -> FlatState Prog
-visitModule (IL.Module mid imps decls)
- = whenFlatCurry
+visitModule (IL.Module mid imps decls) = do
+ -- insert local decls into localDecls
+ let ts = [ (qn, t) | IL.FunctionDecl qn _ t _ <- decls ]
+ modify (\ s -> s {localTypes = Map.fromList ts})
+ whenFlatCurry
(do ops <- genOpDecls
datas <- mapM visitDataDecl (filter isDataDecl decls)
types <- genTypeSynonyms
@@ -123,12 +216,12 @@
visitType :: IL.Type -> FlatState TypeExpr
visitType (IL.TypeConstructor qident types)
= do texprs <- mapM visitType types
- qname <- visitQualIdent qident
+ qname <- visitQualTypeIdent qident
if (qualName qident) == "Identity"
then return (head texprs)
else return (TCons qname texprs)
visitType (IL.TypeVariable index)
- = return (TVar (int2num index))
+ = return (TVar (abs index))
visitType (IL.TypeArrow type1 type2)
= do texpr1 <- visitType type1
texpr2 <- visitType type2
@@ -137,22 +230,20 @@
--
visitFuncDecl :: IL.Decl -> FlatState FuncDecl
visitFuncDecl (IL.FunctionDecl qident params typeexpr expression)
- = whenFlatCurry
- (do setFunctionId qident
- is <- mapM newVarIndex params
- texpr <- visitType typeexpr
- expr <- visitExpression expression
- qname <- visitQualIdent qident
- vis <- getVisibility False qident
- clearVarIndices
- return (Func qname (length params) vis texpr (Rule is expr)))
- (do setFunctionId qident
- texpr <- visitType typeexpr
- qname <- visitQualIdent qident
- clearVarIndices
- return (Func qname (length params) Public texpr (Rule [] (Var $ mkIdx 0))))
+ = let argtypes = splitoffArgTypes typeexpr params
+ in do setFunctionId (qident, argtypes)
+ qname <- visitQualIdent qident
+ whenFlatCurry (do is <- mapM newVarIndex params
+ texpr <- visitType typeexpr
+ expr <- visitExpression expression
+ vis <- getVisibility False qident
+ clearVarIndices
+ return (Func qname (length params) vis texpr (Rule is expr)))
+ (do texpr <- visitType typeexpr
+ clearVarIndices
+ return (Func qname (length params) Public texpr (Rule [] (Var $ mkIdx 0))))
visitFuncDecl (IL.ExternalDecl qident _ name typeexpr)
- = do setFunctionId qident
+ = do setFunctionId (qident, [])
texpr <- visitType typeexpr
qname <- visitQualIdent qident
vis <- getVisibility False qident
@@ -173,15 +264,14 @@
visitExpression (IL.Function qident _)
= do arity_ <- lookupIdArity qident
qname <- visitQualIdent qident
- -- ftype <- lookupIdType qident
- -- let qident' = qname{ typeofQName = ftype }
- maybe (internalError (funcArity qident))
+ maybe (internalError (funcArity qname))
(\arity -> genFuncCall qname arity [])
arity_
visitExpression (IL.Constructor qident arity)
= do arity_ <- lookupIdArity qident
+ qname <- visitQualIdent qident
maybe (internalError (consArity qident))
- (\arity -> genConsCall qident arity [])
+ (\arity -> genConsCall qname arity [])
arity_
visitExpression (IL.Apply e1 e2)
= genFlatApplication e1 e2
@@ -206,6 +296,7 @@
newVarIndex (bindingIdent binding)
bind <- visitBinding binding
expr <- visitExpression expression
+ -- is it correct that there is no endScope? (hsi)
return (Let [bind] expr)
visitExpression (IL.Letrec bindings expression)
= do beginScope
@@ -216,32 +307,6 @@
return (Let binds expr)
-getTypeOf :: Ident -> FlatState (Maybe TypeExpr)
-getTypeOf ident = do
- (valEnv, _) <- environments
- case lookupValue ident valEnv of
- Value _ (ForAll _ t) : _
- -> do t <- visitType (ttrans t)
- trace ("getTypeOf(" ++ show ident ++ ") = " ++ show t)$
- return (Just t)
- v -> trace ("lookupValue did not return a value for index " ++ show ident ++ ", instead " ++ show v)
- (return Nothing)
- where ttrans :: Type -> IL.Type
- ttrans (TypeConstructor i ts)
- = IL.TypeConstructor i (map ttrans ts)
- ttrans (TypeVariable v)
- = IL.TypeVariable v
- ttrans (TypeConstrained [] v)
- = trace (msg1 v) $ IL.TypeVariable v
- ttrans (TypeConstrained (v:_) i)
- = trace (msg2 i ilt) ilt
- where ilt = ttrans v
- ttrans (TypeArrow f x) = IL.TypeArrow (ttrans f) (ttrans x)
- ttrans s@(TypeSkolem _) = error $ "in ttrans: " ++ show s
- ttrans s@(TypeRecord _ _) = error $ "in ttrans: " ++ show s
- msg1 i = "in ttrans: empty TypeConstrained, coerced to type var #" ++ show i
- msg2 i t = "in ttrans: TypeConstrained with index " ++ show i ++ ", coerced to " ++ show t
-
--
visitLiteral :: IL.Literal -> FlatState Literal
visitLiteral (IL.Char rs c) = return (Charc rs c)
@@ -345,8 +410,22 @@
= Id.moduleName preludeMIdent
| otherwise
= maybe (Id.moduleName mid) Id.moduleName mmod
- return (curry mkQName mod $ name ident)
+ ftype <- lookupIdType qident
+ return (QName Nothing ftype mod $ name ident)
+-- This variant of visitQualIdent does not look up the type of the identifier,
+-- which is wise when the identifier is bound to a type, because looking up
+-- the type of a type via lookupIdType will get stuck in an endless loop. (hsi)
+visitQualTypeIdent :: QualIdent -> FlatState QName
+visitQualTypeIdent qident
+ = do mid <- moduleId
+ let (mmod, ident) = (qualidMod qident, qualidId qident)
+ mod | elem ident [listId, consId, nilId, unitId] || isTupleId ident
+ = Id.moduleName preludeMIdent
+ | otherwise
+ = maybe (Id.moduleName mid) Id.moduleName mmod
+ return (QName Nothing Nothing mod $ name ident)
+
--
visitExternalName :: String -> FlatState String
visitExternalName name
@@ -488,8 +567,9 @@
arity_
(IL.Constructor qident _)
-> do arity_ <- lookupIdArity qident
+ qname <- visitQualIdent qident
maybe (internalError (consArity qident))
- (\arity -> genConsCall qident arity args)
+ (\arity -> genConsCall qname arity args)
arity_
_ -> do expr <- visitExpression expression
genApplicComb expr args
@@ -508,26 +588,22 @@
where cnt = length args
--
-genConsCall :: QualIdent -> Int -> [IL.Expression] -> FlatState Expr
-genConsCall qident arity args
+genConsCall :: QName -> Int -> [IL.Expression] -> FlatState Expr
+genConsCall qname arity args
| arity > cnt
- = do qname <- visitQualIdent qident
- genComb qname args (ConsPartCall (arity - cnt))
+ = genComb qname args (ConsPartCall (arity - cnt))
| arity < cnt
= do let (funcargs, applicargs) = splitAt arity args
- qname <- visitQualIdent qident
conscall <- genComb qname funcargs ConsCall
genApplicComb conscall applicargs
| otherwise
- = do qname <- visitQualIdent qident
- genComb qname args ConsCall
+ = genComb qname args ConsCall
where cnt = length args
--
genComb :: QName -> [IL.Expression] -> CombType -> FlatState Expr
genComb qname args combtype
= do exprs <- mapM visitExpression args
--- qname <- visitQualIdent qident
return (Comb combtype qname exprs)
--
@@ -569,7 +645,8 @@
genTypeSynonym :: CS.IDecl -> FlatState TypeDecl
genTypeSynonym (CS.ITypeDecl _ qident params typeexpr)
= do let is = [0 .. (length params) - 1]
- (tyEnv,tcEnv) <- environments
+ tyEnv <- gets typeEnvE
+ tcEnv <- gets tConsEnvE
let typeexpr' = elimRecordTypes tyEnv tcEnv typeexpr
texpr <- visitType (fst (cs2ilType (zip params is) typeexpr'))
qname <- visitQualIdent qident
@@ -613,7 +690,8 @@
genRecordLabel :: Maybe ModuleIdent -> [(Ident,Int)] -> ([Ident],CS.TypeExpr)
-> FlatState ConsDecl
genRecordLabel mod vis ([ident],typeexpr)
- = do (tyEnv,tcEnv) <- environments
+ = do tyEnv <- gets typeEnvE
+ tcEnv <- gets tConsEnvE
let typeexpr' = elimRecordTypes tyEnv tcEnv typeexpr
texpr <- visitType (fst (cs2ilType vis typeexpr'))
qname <- visitQualIdent ((maybe qualify qualifyWith mod)
@@ -812,10 +890,6 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-int2num :: Int -> Int
-int2num = abs
-
-
emap :: (e -> a -> (b,e)) -> e -> [a] -> ([b], e)
emap _ env [] = ([], env)
emap f env (x:xs) = let (x',env') = f env x
@@ -825,80 +899,16 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
--- Data type for representing an environment which contains information needed
--- for generating FlatCurry code.
-data FlatEnv = FlatEnv{ moduleIdE :: ModuleIdent,
- functionIdE :: QualIdent, -- function name for error messages
- compilerOptsE :: Options,
- moduleEnvE :: ModuleEnv,
- arityEnvE :: ArityEnv,
- typeEnvE :: ValueEnv,
- tConsEnvE :: TCEnv,
- publicEnvE :: Map.Map Ident IdentExport,
- fixitiesE :: [CS.IDecl],
- typeSynonymsE :: [CS.IDecl],
- importsE :: [CS.IDecl],
- exportsE :: [CS.Export],
- interfaceE :: [CS.IDecl],
- varIndexE :: Int,
- varIdsE :: ScopeEnv Ident VarIndex,
- tvarIndexE :: Int,
- tvarIdsE :: ScopeEnv Ident TVarIndex,
- messagesE :: [WarnMsg],
- genInterfaceE :: Bool
- }
-
-data IdentExport = NotConstr -- function, type-constructor
- | OnlyConstr -- constructor
- | NotOnlyConstr -- constructor, function, type-constructor
-
-
-
--- The environment 'FlatEnv' is embedded in the monadic representation
--- 'FlatState' which allows the usage of 'do' expressions.
-type FlatState a = State FlatEnv a
-
-
--- Runs a 'FlatState' action and returns the result
-run :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv
- -> Bool -> FlatState a -> (a, [WarnMsg])
-run opts cEnv mEnv tyEnv tcEnv aEnv genIntf f
- = (result, messagesE env)
- where
- (result, env) = runState f env0
- env0 = FlatEnv{ moduleIdE = CurryEnv.moduleId cEnv,
- functionIdE = qualify (mkIdent ""),
- compilerOptsE = opts,
- moduleEnvE = mEnv,
- arityEnvE = aEnv,
- typeEnvE = tyEnv,
- tConsEnvE = tcEnv,
- publicEnvE = genPubEnv (CurryEnv.moduleId cEnv)
- (CurryEnv.interface cEnv),
- fixitiesE = CurryEnv.infixDecls cEnv,
- typeSynonymsE = CurryEnv.typeSynonyms cEnv,
- importsE = CurryEnv.imports cEnv,
- exportsE = CurryEnv.exports cEnv,
- interfaceE = CurryEnv.interface cEnv,
- varIndexE = 0,
- varIdsE = ScopeEnv.new,
- tvarIndexE = 0,
- tvarIdsE = ScopeEnv.new,
- messagesE = [],
- genInterfaceE = genIntf
- }
-
-
--
moduleId :: FlatState ModuleIdent
moduleId = gets moduleIdE
--
functionId :: FlatState QualIdent
-functionId = gets functionIdE
+functionId = gets (fst . functionIdE)
--
-setFunctionId :: QualIdent -> FlatState ()
+setFunctionId :: (QualIdent, [(Ident, IL.Type)]) -> FlatState ()
setFunctionId qid = modify (\env -> env{ functionIdE = qid })
--
@@ -926,10 +936,6 @@
typeSynonyms = gets typeSynonymsE
--
-environments :: FlatState (ValueEnv,TCEnv)
-environments = gets (\env -> (typeEnvE env, tConsEnvE env))
-
---
isPublic :: Bool -> QualIdent -> FlatState Bool
isPublic isConstr qid = gets (\env -> maybe False isP
(Map.lookup (unqualify qid)
@@ -957,30 +963,70 @@
_ -> Nothing
_ -> Nothing
---
+
+
+getTypeOf :: Ident -> FlatState (Maybe TypeExpr)
+getTypeOf ident = do
+ valEnv <- gets typeEnvE
+ case lookupValue ident valEnv of
+ Value _ (ForAll _ t) : _
+ -> do t <- visitType (ttrans t)
+ trace' ("getTypeOf(" ++ show ident ++ ") = " ++ show t)$
+ return (Just t)
+ DataConstructor _ (ForAllExist _ _ t):_
+ -> do t <- visitType (ttrans t)
+ trace' ("getTypeOfDataCon(" ++ show ident ++ ") = " ++ show t)$
+ return (Just t)
+ _ -> do (_,ats) <- gets functionIdE
+ case lookup ident ats of
+ Just t -> liftM Just (visitType t)
+ Nothing -> trace' ("lookupValue did not return a value for index " ++ show ident)
+ (return Nothing)
+ttrans :: Type -> IL.Type
+ttrans (TypeConstructor i ts)
+ = IL.TypeConstructor i (map ttrans ts)
+ttrans (TypeVariable v)
+ = IL.TypeVariable v
+ttrans (TypeConstrained [] v)
+ = IL.TypeVariable v
+ttrans (TypeConstrained (v:_) i)
+ = ttrans v
+ttrans (TypeArrow f x) = IL.TypeArrow (ttrans f) (ttrans x)
+ttrans s@(TypeSkolem _) = error $ "in ttrans: " ++ show s
+ttrans s@(TypeRecord _ _) = error $ "in ttrans: " ++ show s
+
+
+
+-- Constructor (:) receives special treatment throughout the
+-- whole implementation. We won't depart from that for mere
+-- aesthetic reasons. (hsi)
lookupIdType :: QualIdent -> FlatState (Maybe TypeExpr)
+lookupIdType (QualIdent Nothing (Ident _ ":" _))
+ = return (Just (FuncType (TVar 0) (FuncType (l0) (l0))))
+ where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]
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
-
+ lt <- gets localTypes
+ ct <- gets constrTypes
+ case Map.lookup qid lt `mplus` Map.lookup qid ct of
+ Just t -> trace' ("lookupIdType local " ++ show (qid, t)) $ liftM Just (visitType t) -- local name or constructor
+ Nothing -> case [ t | Value _ (ForAll _ t) <- qualLookupValue qid aEnv ] of
+ t : _ -> liftM Just (visitType (IL.translType t)) -- imported name
+ [] -> case qualidMod qid of
+ Nothing -> trace' ("no type for " ++ show qid) $ return Nothing -- no known type
+ Just _ -> lookupIdType qid {qualidMod = Nothing}
+--
-- Generates a new index for a variable
newVarIndex :: Ident -> FlatState VarIndex
-newVarIndex id
+newVarIndex ident
= do idx0 <- gets varIndexE
- ty <- getTypeOf id
+ ty <- getTypeOf ident
let idx = idx0 + 1
vid = VarIndex ty idx
vids <- gets varIdsE
modify (\env -> env{ varIndexE = idx,
- varIdsE = ScopeEnv.insert id vid vids
+ varIdsE = ScopeEnv.insert ident vid vids
})
return vid
@@ -1009,15 +1055,13 @@
--
beginScope :: FlatState ()
beginScope = modify
- (\env -> env { varIdsE = ScopeEnv.beginScope (varIdsE env),
- tvarIdsE = ScopeEnv.beginScope (tvarIdsE env)
+ (\env -> env { varIdsE = ScopeEnv.beginScope (varIdsE env)
})
--
endScope :: FlatState ()
endScope = modify
- (\env -> env { varIdsE = ScopeEnv.endScope (varIdsE env),
- tvarIdsE = ScopeEnv.endScope (tvarIdsE env)
+ (\env -> env { varIdsE = ScopeEnv.endScope (varIdsE env)
})
--
@@ -1088,3 +1132,11 @@
bindEnvRecordLabel r env ([lab], _) = bindIdentExport (recSelectorId (qualify r) lab) False expo
where
expo = (bindIdentExport (recUpdateId (qualify r) lab) False env)
+
+
+splitoffArgTypes :: IL.Type -> [Ident] -> [(Ident, IL.Type)]
+splitoffArgTypes (IL.TypeArrow l r) (i:is) = (i, l):splitoffArgTypes r is
+splitoffArgTypes _ [] = []
+splitoffArgTypes _ _ = error "internal error in splitoffArgTypes"
+
+
diff --git a/src/IL/CurryToIL.lhs b/src/IL/CurryToIL.lhs
--- a/src/IL/CurryToIL.lhs
+++ b/src/IL/CurryToIL.lhs
@@ -254,8 +254,8 @@
> 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 =
+> -- - | 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))
@@ -272,10 +272,10 @@
> (IL.Function
> (qualifyWith preludeMIdent (mkIdent "commit"))
> 1)
-> (match (ast pos) IL.Rigid vs
+> (match (srcRefOf pos) IL.Rigid vs
> (map (translEquation tyEnv vs vs'') eqs))
> | otherwise
-> = match (ast pos) ev vs (map (translEquation tyEnv vs vs'') eqs)
+> = match (srcRefOf pos) ev vs (map (translEquation tyEnv vs vs'') eqs)
> ---
> -- (vs',vs'') = splitAt (arrowArity ty) (argNames (mkIdent ""))
@@ -351,7 +351,7 @@
> translLiteral :: Literal -> IL.Literal
> translLiteral (Char p c) = IL.Char p c
-> translLiteral (Int id i) = IL.Int (ast (positionOfIdent id)) i
+> translLiteral (Int id i) = IL.Int (srcRefOf (positionOfIdent id)) i
> translLiteral (Float p f) = IL.Float p f
> translLiteral _ = internalError "translLiteral"
diff --git a/src/IL/Pretty.lhs b/src/IL/Pretty.lhs
--- a/src/IL/Pretty.lhs
+++ b/src/IL/Pretty.lhs
@@ -15,10 +15,10 @@
> module IL.Pretty(ppModule) where
>
+> import Text.PrettyPrint.HughesPJ
+
> import Curry.Base.Ident
->
> import IL.Type
-> import PrettyCombinators
> default(Int,Double)
diff --git a/src/IL/Type.lhs b/src/IL/Type.lhs
--- a/src/IL/Type.lhs
+++ b/src/IL/Type.lhs
@@ -1,3 +1,5 @@
+> {-# LANGUAGE DeriveDataTypeable #-}
+
% $Id: IL.lhs,v 1.18 2003/10/28 05:43:38 wlux Exp $
%
% Copyright (c) 1999-2003 Wolfgang Lux
@@ -40,6 +42,7 @@
> module IL.Type where
+> import Data.Generics
> import Curry.Base.Ident
> import Curry.Base.Position (SrcRef(..))
@@ -59,7 +62,7 @@
> TypeConstructor QualIdent [Type]
> | TypeVariable Int
> | TypeArrow Type Type
-> deriving (Eq,Show)
+> deriving (Eq,Show, Typeable, Data)
> data Literal = Char SrcRef Char | Int SrcRef Integer | Float SrcRef Double deriving (Eq,Show)
diff --git a/src/IL/XML.lhs b/src/IL/XML.lhs
--- a/src/IL/XML.lhs
+++ b/src/IL/XML.lhs
@@ -20,6 +20,7 @@
> module IL.XML(module IL.XML) where
+> import Text.PrettyPrint.HughesPJ
> import Data.Maybe
> import Curry.Base.Ident
@@ -27,7 +28,6 @@
> import IL.Type
> import CurryEnv
-> import PrettyCombinators
diff --git a/src/InterfaceCheck.hs b/src/InterfaceCheck.hs
--- a/src/InterfaceCheck.hs
+++ b/src/InterfaceCheck.hs
@@ -11,7 +11,7 @@
import Data.List
-import Curry.ExtendedFlat
+import Curry.ExtendedFlat.Type
diff --git a/src/KindCheck.lhs b/src/KindCheck.lhs
--- a/src/KindCheck.lhs
+++ b/src/KindCheck.lhs
@@ -28,6 +28,7 @@
> import Data.Maybe
> import Curry.Syntax
+> import Curry.Syntax.Utils(isTypeDecl)
> import Curry.Base.Position
> import Curry.Base.Ident
> import Base hiding (bindArity)
@@ -45,9 +46,9 @@
> kindCheck :: ModuleIdent -> TCEnv -> [Decl] -> [Decl]
> kindCheck m tcEnv ds =
-> case linear (map tconstr ds') of
-> Linear -> map (checkDecl m kEnv) ds
-> NonLinear tc -> errorAt' (duplicateType tc)
+> case findDouble (map tconstr ds') of
+> Nothing -> map (checkDecl m kEnv) ds
+> Just tc -> errorAt' (duplicateType tc)
> where ds' = filter isTypeDecl ds
> kEnv = foldr (bindArity m) (fmap tcArity tcEnv) ds'
diff --git a/src/Modules.lhs b/src/Modules.lhs
--- a/src/Modules.lhs
+++ b/src/Modules.lhs
@@ -21,7 +21,7 @@
> simpleCheckModule, checkModule
> ) where
-
+> import Text.PrettyPrint.HughesPJ
> import Data.List
> import qualified Data.Map as Map
> import System.IO
@@ -31,10 +31,23 @@
> import Curry.Base.MessageMonad
> import Curry.Base.Position
> import Curry.Base.Ident
+
+> import Curry.Files.Filenames
+> import Curry.Files.PathUtils
+
> import Curry.Syntax
+> import Curry.Syntax.Utils(isImportDecl)
> import Curry.Syntax.Pretty(ppModule,ppIDecl)
> import Curry.Syntax.ShowModule(showModule)
+> import Curry.ExtendedFlat.Type
+> import qualified Curry.ExtendedFlat.Type as EF
+
+> import qualified IL.Type as IL
+> import IL.CurryToIL(ilTrans)
+> import qualified IL.Pretty(ppModule)
+> import IL.XML(xmlModule)
+
> import Base
> import Types
> import KindCheck(kindCheck)
@@ -50,25 +63,21 @@
> import Desugar(desugar)
> import Simplify(simplify)
> import Lift(lift)
-> import qualified IL.Type as IL
-> import IL.CurryToIL(ilTrans)
-> import IL.XML(xmlModule)
-> import Curry.ExtendedFlat
+
> import GenFlatCurry (genFlatCurry,genFlatInterface)
> import qualified Curry.AbstractCurry as AC
> import GenAbstractCurry
> import InterfaceCheck
> import CurryEnv
-> import qualified IL.Pretty(ppModule)
+
> import CurryCompilerOpts(Options(..),Dump(..))
> import CaseCompletion
-> import PathUtils
-> import Filenames
+
+
> import TypeSubst
-> import PrettyCombinators
> import TopEnv
-> import qualified Curry.ExtendedFlat as EF
+
\end{verbatim}
The function \texttt{compileModule} is the main entry-point of this
module for compiling a Curry source module. Depending on the command
@@ -112,7 +121,10 @@
> writeModule outputFile outputMod
> return Nothing
> else
-> do (tyEnv, tcEnv, aEnv, m', intf, _) <- checkModule opts mEnv m
+> do -- checkModule checks types, and then transModule introduces new
+> -- functions (by lambda lifting in 'desugar'). Consequence: The
+> -- type of the newly introduced functions are not inferred (hsi)
+> (tyEnv, tcEnv, aEnv, m', intf, _) <- checkModule opts mEnv m
> let (il,aEnv',dumps) = transModule fcy False False
> mEnv tyEnv tcEnv aEnv m'
> mapM_ (doDump opts) dumps
@@ -299,7 +311,7 @@
\begin{verbatim}
> importLabels :: ModuleEnv -> [Decl] -> LabelEnv
-> importLabels mEnv ds = foldl importLabelTypes initLabelEnv ds
+> importLabels mEnv ds = foldl importLabelTypes Map.empty ds
> where
> importLabelTypes lEnv (ImportDecl p m _ asM is) =
> case (Map.lookup m mEnv) of
@@ -456,32 +468,7 @@
Interface files are updated by the Curry builder when necessary.
(see module \texttt{CurryBuilder}).
-Description of the following obsolete functions:
-After checking the module successfully, the compiler may need to
-update the module's interface file. The file will be updated only if
-the interface has been changed or the file did not exist before.
-
-The code is a little bit tricky because we must make sure that the
-interface file is closed before rewriting the interface, even if it
-has not been read completely. On the other hand, we must not apply
-\texttt{hClose} too early. Note that there is no need to close the
-interface explicitly if the interface check succeeds because the whole
-file must have been read in this case. In addition, we do not update
-the interface file in this case and therefore it doesn't matter when
-the file is closed.
-\begin{verbatim}
-
\end{verbatim}
-The compiler searches for interface files in the import search path
-using the extension \texttt{".fint"}. Note that the current
-directory is always searched first.
-\begin{verbatim}
-
-> lookupInterface :: [FilePath] -> ModuleIdent -> IO (Maybe FilePath)
-> lookupInterface paths m = lookupFile ("":paths) [flatIntExt] ifn
-> where ifn = foldr1 catPath (moduleQualifiers m)
-
-\end{verbatim}
The \texttt{doDump} function writes the selected information to the
standard output.
\begin{verbatim}
@@ -500,9 +487,6 @@
> dumpHeader DumpLifted = "Source code after lifting"
> dumpHeader DumpIL = "Intermediate code"
> dumpHeader DumpCase = "Intermediate code after case simplification"
-> --dumpHeader DumpTransformed = "Transformed code"
-> --dumpHeader DumpNormalized = "Intermediate code after normalization"
-> --dumpHeader DumpCam = "Abstract machine code"
\end{verbatim}
@@ -687,3 +671,23 @@
>
> pos = first m
> ts' = filter (not . isSpecialPreludeType) ts
+
+
+
+
+\end{verbatim}
+The label environment is used to store information of labels.
+Unlike unsual identifiers like in functions, types etc. identifiers
+of labels are always represented unqualified. Since the common type
+environment (type \texttt{ValueEnv}) has some problems with handling
+imported unqualified identifiers, it is necessary to process the type
+information for labels seperately.
+\begin{verbatim}
+
+> data LabelInfo = LabelType Ident QualIdent Type deriving Show
+
+> type LabelEnv = Map.Map Ident [LabelInfo]
+
+> bindLabelType :: Ident -> QualIdent -> Type -> LabelEnv -> LabelEnv
+> bindLabelType l r ty = Map.insertWith (++) l [LabelType l r ty]
+
diff --git a/src/PatchPrelude.hs b/src/PatchPrelude.hs
--- a/src/PatchPrelude.hs
+++ b/src/PatchPrelude.hs
@@ -1,7 +1,7 @@
module PatchPrelude where
-import Curry.ExtendedFlat
+import Curry.ExtendedFlat.Type
-- the prelude has to be extended by data declarations for list and tuples
diff --git a/src/PathUtils.hs b/src/PathUtils.hs
deleted file mode 100644
--- a/src/PathUtils.hs
+++ /dev/null
@@ -1,122 +0,0 @@
-{-
- $Id: PathUtils.lhs,v 1.5 2003/05/04 16:12:35 wlux Exp $
-
- Copyright (c) 1999-2003, Wolfgang Lux
- See LICENSE for the full license.
--}
-
-module PathUtils(-- re-exports from System.FilePath:
- takeBaseName, -- replaceExtension,
- dropExtension,
- takeDirectory, takeExtension,
- pathSeparator,
- catPath,
-
- lookupModule, lookupFile, getCurryPath,
- writeModule,readModule,
- doesModuleExist,maybeReadModule,getModuleModTime) where
-
-import System.FilePath
-import System.Directory
-import System.Time (ClockTime)
-
-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
-
-lookupFile :: [FilePath] -> [String] -> String -> IO (Maybe FilePath)
-lookupFile paths exts file = lookupFile' paths'
- where
- paths' = do p <- paths
- e <- exts
- let fn = p `combine` replaceExtension file e
- [fn, inCurrySubdir fn]
- lookupFile' [] = return Nothing
- lookupFile' (fn:paths)
- = do so <- doesFileExist fn
- if so then return (Just fn) else lookupFile' paths
-
-
-
--- add a subdirectory to a given filename
--- if it is not already present
---
--- inSubdir ""
-
-inSubdir :: FilePath -> FilePath -> FilePath
-inSubdir sub fn = joinPath $ add (splitDirectories fn)
- where
- add ps@[n] = sub:ps
- add ps@[p,n] | p==sub = ps
- add (p:ps) = p:add ps
-
---The sub directory to hide files in:
-
-currySubdir :: String
-currySubdir = ".curry"
-
-inCurrySubdir :: FilePath -> FilePath
-inCurrySubdir = inSubdir currySubdir
-
---write a file to curry subdirectory
-
-writeModule :: FilePath -> String -> IO ()
-writeModule filename contents = do
- let filename' = inCurrySubdir filename
- subdir = takeDirectory filename'
- ensureDirectoryExists subdir
- writeFile filename' contents
-
-ensureDirectoryExists :: FilePath -> IO ()
-ensureDirectoryExists dir
- = do ex <- doesDirectoryExist dir
- unless ex (createDirectory dir)
-
--- do things with file in subdir
-
-onExistingFileDo :: (FilePath -> IO a) -> FilePath -> IO a
-onExistingFileDo act filename = do
- ex <- doesFileExist filename
- if ex then act filename
- else act $ inCurrySubdir filename
-
-readModule :: FilePath -> IO String
-readModule = onExistingFileDo readFile
-
-maybeReadModule :: FilePath -> IO (Maybe String)
-maybeReadModule filename =
- catch (readModule filename >>= return . Just) (\_ -> return Nothing)
-
-doesModuleExist :: FilePath -> IO Bool
-doesModuleExist = onExistingFileDo doesFileExist
-
-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
-
diff --git a/src/PrecCheck.lhs b/src/PrecCheck.lhs
--- a/src/PrecCheck.lhs
+++ b/src/PrecCheck.lhs
@@ -37,12 +37,12 @@
> bindPrecs :: ModuleIdent -> [Decl] -> PEnv -> PEnv
> bindPrecs m ds pEnv =
-> case linear ops of
-> Linear ->
+> case findDouble ops of
+> Nothing ->
> case [ op | op <- ops, op `notElem` bvs] of
> [] -> foldr bindPrec pEnv fixDs
> op : _ -> errorAt' (undefinedOperator op)
-> NonLinear op -> errorAt' (duplicatePrecedence op)
+> Just op -> errorAt' (duplicatePrecedence op)
> where (fixDs,nonFixDs) = partition isInfixDecl ds
> bvs = concatMap boundValues nonFixDs
> ops = [ op | InfixDecl p _ _ ops <- fixDs, op <- ops]
diff --git a/src/PrettyCombinators.lhs b/src/PrettyCombinators.lhs
deleted file mode 100644
--- a/src/PrettyCombinators.lhs
+++ /dev/null
@@ -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 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 $$
-~~~~~~~~~~~
- (x $$ y) $$ z = x $$ (y $$ z)
- empty $$ x = x
- x $$ empty = x
-
- ...ditto $+$...
-
-Laws for <>
-~~~~~~~~~~~
- (x <> y) <> z = x <> (y <> z)
- empty <> x = empty
- x <> empty = x
-
- ...ditto <+>...
-
-Laws for text
-~~~~~~~~~~~~~
- text s <> text t = text (s++t)
- text "" <> x = x, if x non-empty
-
-Laws for nest
-~~~~~~~~~~~~~
- nest 0 x = x
- nest k (nest k' x) = nest (k+k') x
- nest k (x <> y) = nest k z <> nest k y
- nest k (x $$ y) = nest k x $$ nest k y
- nest k empty = empty
- x <> nest k y = x <> y, if x non-empty
-
-** Note the side condition on ! It is this that
-** makes it OK for empty to be a left unit for <>.
-
-Miscellaneous
-~~~~~~~~~~~~~
- (text s <> x) $$ y = text s <> ((text "" <> x)) $$
- nest (-length s) y)
-
- (x $$ y) <> z = x $$ (y <> z)
- if y non-empty
-
-
-Laws for list versions
-~~~~~~~~~~~~~~~~~~~~~~
- sep (ps++[empty]++qs) = sep (ps ++ qs)
- ...ditto hsep, hcat, vcat, fill...
-
- nest k (sep ps) = sep (map (nest k) ps)
- ...ditto hsep, hcat, vcat, fill...
-
-Laws for oneLiner
-~~~~~~~~~~~~~~~~~
- oneLiner (nest k p) = nest k (oneLiner p)
- oneLiner (x <> y) = oneLiner x <> oneLiner y
-\end{verbatim}
-
-
-You might think that the following verion of 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 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 "" 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 nest k (hsep ys))
--- `union` x $$ nest k (vcat ys)
-
-sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
-sep1 g NoDoc k ys = NoDoc
-sep1 g (p `Union` q) k ys = sep1 g p k ys
- `union_`
- (aboveNest q False k (reduceDoc (vcat ys)))
-
-sep1 g Empty k ys = mkNest k (sepX g ys)
-sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
-
-sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
-sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
-
--- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
--- Called when we have already found some text in the first item
--- We have to eat up nests
-
-sepNB g (Nest _ p) k ys = sepNB g p k ys
-
-sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))
- `mkUnion`
- nilAboveNest False k (reduceDoc (vcat ys))
- where
- rest | g = hsep ys
- | otherwise = hcat ys
-
-sepNB g p k ys = sep1 g p k ys
-\end{code}
-
-*********************************************************
-* *
-\subsection{@fill@}
-* *
-*********************************************************
-
-\begin{code}
-fsep = fill True
-fcat = fill False
-
--- Specification:
--- fill [] = empty
--- fill [p] = p
--- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
--- (fill (oneLiner p2 : ps))
--- `union`
--- p1 $$ fill ps
-
-fill g [] = empty
-fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
-
-
-fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
-fill1 g NoDoc k ys = NoDoc
-fill1 g (p `Union` q) k ys = fill1 g p k ys
- `union_`
- (aboveNest q False k (fill g ys))
-
-fill1 g Empty k ys = mkNest k (fill g ys)
-fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
-
-fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
-fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
-
-fillNB g (Nest _ p) k ys = fillNB g p k ys
-fillNB g Empty k [] = Empty
-fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
- `mkUnion`
- nilAboveNest False k (fill g (y:ys))
- where
- k1 | g = k - 1
- | otherwise = k
-
-fillNB g p k ys = fill1 g p k ys
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{Selecting the best layout}
-* *
-*********************************************************
-
-\begin{code}
-best :: Mode
- -> Int -- Line length
- -> Int -- Ribbon length
- -> RDoc
- -> RDoc -- No unions in here!
-
-best OneLineMode w r p
- = get p
- where
- get Empty = Empty
- get NoDoc = NoDoc
- get (NilAbove p) = nilAbove_ (get p)
- get (TextBeside s sl p) = textBeside_ s sl (get p)
- get (Nest k p) = get p -- Elide nest
- get (p `Union` q) = first (get p) (get q)
-
-best mode w r p
- = get w p
- where
- get :: Int -- (Remaining) width of line
- -> Doc -> Doc
- get w Empty = Empty
- get w NoDoc = NoDoc
- get w (NilAbove p) = nilAbove_ (get w p)
- get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
- get w (Nest k p) = nest_ k (get (w - k) p)
- get w (p `Union` q) = nicest w r (get w p) (get w q)
-
- get1 :: Int -- (Remaining) width of line
- -> Int -- Amount of first line already eaten up
- -> Doc -- This is an argument to TextBeside => eat Nests
- -> Doc -- No unions in here!
-
- get1 w sl Empty = Empty
- get1 w sl NoDoc = NoDoc
- get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
- get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
- get1 w sl (Nest k p) = get1 w sl p
- get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
- (get1 w sl q)
-
-nicest w r p q = nicest1 w r 0 p q
-nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
- | otherwise = q
-
-fits :: Int -- Space available
- -> Doc
- -> Bool -- True if *first line* of Doc fits in space available
-
-fits n p | n < 0 = False
-fits n NoDoc = False
-fits n Empty = True
-fits n (NilAbove _) = True
-fits n (TextBeside _ sl p) = fits (n - sl) p
-
-minn x y | x < y = x
- | otherwise = y
-\end{code}
-
-@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
-@first@ returns its first argument if it is non-empty, otherwise its second.
-
-\begin{code}
-first p q | nonEmptySet p = p
- | otherwise = q
-
-nonEmptySet NoDoc = False
-nonEmptySet (p `Union` q) = True
-nonEmptySet Empty = True
-nonEmptySet (NilAbove p) = True -- NoDoc always in first line
-nonEmptySet (TextBeside _ _ p) = nonEmptySet p
-nonEmptySet (Nest _ p) = nonEmptySet p
-\end{code}
-
-@oneLiner@ returns the one-line members of the given set of @Doc@s.
-
-\begin{code}
-oneLiner :: Doc -> Doc
-oneLiner NoDoc = NoDoc
-oneLiner Empty = Empty
-oneLiner (NilAbove p) = NoDoc
-oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
-oneLiner (Nest k p) = nest_ k (oneLiner p)
-oneLiner (p `Union` q) = oneLiner p
-\end{code}
-
-
-
-*********************************************************
-* *
-\subsection{Displaying the best layout}
-* *
-*********************************************************
-
-
-\begin{code}
-renderStyle Style{mode=mode, lineLength=lineLength, ribbonsPerLine=ribbonsPerLine} doc
- = fullRender mode lineLength ribbonsPerLine string_txt "" doc
-
-render doc = showDoc doc ""
-showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
-
-string_txt (Chr c) s = c:s
-string_txt (Str s1) s2 = s1 ++ s2
-string_txt (PStr s1) s2 = s1 ++ s2
-\end{code}
-
-\begin{code}
-
-fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
-fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)
-
-fullRender mode line_length ribbons_per_line txt end doc
- = display mode line_length ribbon_length txt end best_doc
- where
- best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
-
- hacked_line_length, ribbon_length :: Int
- ribbon_length = round (fromIntegral line_length / ribbons_per_line)
- hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
-
-display mode page_width ribbon_width txt end doc
- = case page_width - ribbon_width of { gap_width ->
- case gap_width `quot` 2 of { shift ->
- let
- lay k (Nest k1 p) = lay (k + k1) p
- lay k Empty = end
-
- lay k (NilAbove p) = nl_text `txt` lay k p
-
- lay k (TextBeside s sl p)
- = case mode of
- ZigZagMode | k >= gap_width
- -> nl_text `txt` (
- Str (multi_ch shift '/') `txt` (
- nl_text `txt` (
- lay1 (k - shift) s sl p)))
-
- | k < 0
- -> nl_text `txt` (
- Str (multi_ch shift '\\') `txt` (
- nl_text `txt` (
- lay1 (k + shift) s sl p )))
-
- other -> lay1 k s sl p
-
- lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
-
- lay2 k (NilAbove p) = nl_text `txt` lay k p
- lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
- lay2 k (Nest _ p) = lay2 k p
- lay2 k Empty = end
- in
- lay 0 doc
- }}
-
-cant_fail = error "easy_display: NoDoc"
-easy_display nl_text txt end doc
- = lay doc cant_fail
- where
- lay NoDoc no_doc = no_doc
- lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc
- lay (Nest k p) no_doc = lay p no_doc
- lay Empty no_doc = end
- lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line
- lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
-
-indent n | n >= 8 = '\t' : indent (n - 8)
- | otherwise = spaces n
-
-multi_ch 0 ch = ""
-multi_ch n ch = ch : multi_ch (n - 1) ch
-
-spaces 0 = ""
-spaces n = ' ' : spaces (n - 1)
-\end{code}
-
diff --git a/src/ScopeEnv.hs b/src/ScopeEnv.hs
--- a/src/ScopeEnv.hs
+++ b/src/ScopeEnv.hs
@@ -21,6 +21,13 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
+-- Data type for representing information in nested scopes.
+data ScopeEnv a b = ScopeEnv Int (Map.Map a (b,Int)) [Map.Map a (b,Int)]
+ deriving Show
+
+
+-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
-- Returns an empty scope environment
new :: Ord a => ScopeEnv a b
new = ScopeEnv 0 Map.empty []
@@ -162,14 +169,6 @@
else local')
(Map.lookup key local)
-
-
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-
--- Data type for representing information in nested scopes.
-data ScopeEnv a b = ScopeEnv Int (Map.Map a (b,Int)) [Map.Map a (b,Int)]
- deriving Show
-------------------------------------------------------------------------------
diff --git a/src/Simplify.lhs b/src/Simplify.lhs
--- a/src/Simplify.lhs
+++ b/src/Simplify.lhs
@@ -374,7 +374,7 @@
> _ ->
> do
> v0 <- freshIdent m patternId (monoType (typeOf tyEnv t))
-> let v = addRefId (ast p) v0
+> let v = addRefId (srcRefOf p) v0
> return [PatternDecl p t (SimpleRhs p (mkVar v) []),
> PatternDecl p (VariablePattern v) rhs]
> where patternId n = mkIdent ("_#pat" ++ show n)
diff --git a/src/Subst.lhs b/src/Subst.lhs
--- a/src/Subst.lhs
+++ b/src/Subst.lhs
@@ -1,6 +1,3 @@
-% -*- LaTeX -*-
-% $Id: Subst.lhs,v 1.7 2002/12/20 13:12:51 lux Exp $
-%
% Copyright (c) 2002, Wolfgang Lux
% See LICENSE for the full license.
%
diff --git a/src/SyntaxCheck.lhs b/src/SyntaxCheck.lhs
--- a/src/SyntaxCheck.lhs
+++ b/src/SyntaxCheck.lhs
@@ -50,11 +50,11 @@
> syntaxCheck :: Bool -> ModuleIdent -> ImportEnv -> ArityEnv -> ValueEnv -> TCEnv -> [Decl] -> [Decl]
> syntaxCheck withExt m iEnv aEnv tyEnv tcEnv ds =
-> case linear (concatMap constrs tds) of
-> --Linear -> tds ++ run (checkModule withExt m env vds)
-> Linear -> map (checkTypeDecl withExt m) tds
+> case findDouble (concatMap constrs tds) of
+> --Nothing -> tds ++ run (checkModule withExt m env vds)
+> Nothing -> map (checkTypeDecl withExt m) tds
> ++ run (checkModule withExt m env2 vds)
-> NonLinear c -> errorAt' (duplicateData c)
+> Just c -> errorAt' (duplicateData c)
> where (tds,vds) = partition isTypeDecl ds
> (rs, tds') = partition isRecordDecl tds
> env1 = foldr (bindTypes m) -- (bindConstrs m)
@@ -143,9 +143,9 @@
> bindTypes m (DataDecl _ tc _ cs) env = foldr (bindConstr m) env cs
> bindTypes m (NewtypeDecl _ tc _ nc) env = bindNewConstr m nc env
> bindTypes m (TypeDecl _ t _ (RecordType fs r)) env =
-> -- | isJust r = internalError "bindTypes: illegal record declaration"
-> -- | null fs = errorAt (positionOfIdent t) emptyRecord
-> -- | otherwise =
+> -- - | isJust r = internalError "bindTypes: illegal record declaration"
+> -- - | null fs = errorAt (positionOfIdent t) emptyRecord
+> -- - | otherwise =
> case (qualLookupVar (qualifyWith m t) env) of
> [] -> foldr (bindRecordLabel m t (concatMap fst fs)) env fs
> rs | any isConstr rs -> errorAt' (illegalRecordId t)
@@ -375,19 +375,19 @@
> checkDecls :: (Decl -> RenameEnv -> RenameEnv) -> Bool -> ModuleIdent
> -> RenameEnv -> [Decl] -> RenameState (RenameEnv,[Decl])
> checkDecls bindDecl withExt m env ds =
-> case linear bvs of
-> Linear ->
-> case linear tys of
-> Linear ->
-> case linear evs of
-> Linear ->
+> case findDouble bvs of
+> Nothing ->
+> case findDouble tys of
+> Nothing ->
+> case findDouble evs of
+> Nothing ->
> case filter (`notElem` tys) fs' of
> [] -> liftM ((,) env')
> (mapM (checkDeclRhs withExt bvs m env'') ds)
> f : _ -> errorAt' (noTypeSig f)
-> NonLinear v -> errorAt' (duplicateEvalAnnot v)
-> NonLinear v -> errorAt' (duplicateTypeSig v)
-> NonLinear v -> errorAt' (duplicateDefinition v)
+> Just v -> errorAt' (duplicateEvalAnnot v)
+> Just v -> errorAt' (duplicateTypeSig v)
+> Just v -> errorAt' (duplicateDefinition v)
> where vds = filter isValueDecl ds
> tds = filter isTypeSig ds
> bvs = concat (map vars vds)
@@ -472,9 +472,9 @@
> checkConstrTerms :: QuantExpr t => Bool -> RenameEnv -> t
> -> (RenameEnv,t)
> checkConstrTerms withExt env ts =
-> case linear bvs of
-> Linear -> (foldr bindVar env bvs,ts)
-> NonLinear v -> errorAt' (duplicateVariable v)
+> case findDouble bvs of
+> Nothing -> (foldr bindVar env bvs,ts)
+> Just v -> errorAt' (duplicateVariable v)
> where bvs = bv ts
> checkConstrTerm :: Bool -> Int -> Position -> ModuleIdent -> RenameEnv
diff --git a/src/SyntaxColoring.hs b/src/SyntaxColoring.hs
--- a/src/SyntaxColoring.hs
+++ b/src/SyntaxColoring.hs
@@ -129,7 +129,7 @@
getPositionFromString :: String -> Maybe Position
getPositionFromString message =
if line > 0 && col > 0
- then Just Position{file=file,line=line,column=col,ast=noRef}
+ then Just Position{file=file,line=line,column=col,astRef=noRef}
else Nothing
where
file = takeWhile (/= '"') (tail (dropWhile (/= '"') message))
diff --git a/src/TopEnv.lhs b/src/TopEnv.lhs
--- a/src/TopEnv.lhs
+++ b/src/TopEnv.lhs
@@ -34,11 +34,12 @@
imported.
\begin{verbatim}
-> module TopEnv(TopEnv, Entity(..), emptyTopEnv,
+> module TopEnv(TopEnv(..), Entity(..), emptyTopEnv,
> predefTopEnv,qualImportTopEnv,importTopEnv,
> bindTopEnv,qualBindTopEnv,rebindTopEnv,qualRebindTopEnv,
> unbindTopEnv,lookupTopEnv,qualLookupTopEnv,
-> allImports,moduleImports,localBindings) where
+> allImports,moduleImports,localBindings
+> ) where
> import Data.Maybe
> import qualified Data.Map as Map
@@ -55,7 +56,8 @@
> | origName x == origName y = Just x
> | otherwise = Nothing
-> newtype TopEnv a = TopEnv (Map.Map QualIdent [(Source,a)]) deriving Show
+> newtype TopEnv a = TopEnv { topEnvMap :: Map.Map QualIdent [(Source,a)]
+> } deriving Show
> instance Functor TopEnv where
> fmap f (TopEnv env) = TopEnv (fmap (map (second f)) env)
diff --git a/src/TypeCheck.lhs b/src/TypeCheck.lhs
--- a/src/TypeCheck.lhs
+++ b/src/TypeCheck.lhs
@@ -23,6 +23,7 @@
> module TypeCheck(typeCheck) where
+> import Text.PrettyPrint.HughesPJ
> import Control.Monad.State as S
> import Data.List
> import Data.Maybe
@@ -38,7 +39,6 @@
> import Base
> import Types
-> import PrettyCombinators
> import TopEnv
> import SCC
> import TypeSubst
@@ -478,7 +478,7 @@
> tcConstrTerm m tcEnv sigs p (ParenPattern t) = tcConstrTerm m tcEnv sigs p t
> tcConstrTerm m tcEnv sigs p (TuplePattern _ ts)
> | null ts = return unitType
-> | otherwise = liftM tupleType $ mapM (tcConstrTerm m tcEnv sigs p) ts -- $
+> | otherwise = liftM tupleType $ mapM (tcConstrTerm m tcEnv sigs p) ts
> tcConstrTerm m tcEnv sigs p t@(ListPattern _ ts) =
> freshTypeVar >>= flip (tcElems (ppConstrTerm 0 t)) ts
> where tcElems _ ty [] = return (listType ty)
@@ -577,7 +577,7 @@
> tcConstrTermFP m tcEnv sigs p (ParenPattern t) = tcConstrTermFP m tcEnv sigs p t
> tcConstrTermFP m tcEnv sigs p (TuplePattern _ ts)
> | null ts = return unitType
-> | otherwise = liftM tupleType $ mapM (tcConstrTermFP m tcEnv sigs p) ts -- $
+> | otherwise = liftM tupleType $ mapM (tcConstrTermFP m tcEnv sigs p) ts
> tcConstrTermFP m tcEnv sigs p t@(ListPattern _ ts) =
> freshTypeVar >>= flip (tcElems (ppConstrTerm 0 t)) ts
> where tcElems _ ty [] = return (listType ty)
@@ -700,7 +700,7 @@
> tcExpr m tcEnv sigs p (Paren e) = tcExpr m tcEnv sigs p e
> tcExpr m tcEnv sigs p (Tuple _ es)
> | null es = return unitType
-> | otherwise = liftM tupleType $ mapM (tcExpr m tcEnv sigs p) es -- $
+> | otherwise = liftM tupleType $ mapM (tcExpr m tcEnv sigs p) es
> tcExpr m tcEnv sigs p e@(List _ es) = freshTypeVar >>= tcElems (ppExpr 0 e) es
> where tcElems _ [] ty = return (listType ty)
> tcElems doc (e:es) ty =
@@ -975,7 +975,7 @@
> unify :: Position -> String -> Doc -> ModuleIdent -> Type -> Type
> -> TcState ()
> unify p what doc m ty1 ty2 =
-> S.lift $ {-$-}
+> S.lift $
> do
> theta <- S.get
> let ty1' = subst theta ty1
diff --git a/src/Typing.lhs b/src/Typing.lhs
--- a/src/Typing.lhs
+++ b/src/Typing.lhs
@@ -16,6 +16,7 @@
> import Curry.Base.Ident
> import Curry.Syntax
+> import Curry.Syntax.Utils
> import Types
> import Base
@@ -148,7 +149,7 @@
> argType tyEnv (ParenPattern t) = argType tyEnv t
> argType tyEnv (TuplePattern _ ts)
> | null ts = return unitType
-> | otherwise = liftM tupleType $ mapM (argType tyEnv) ts -- $
+> | otherwise = liftM tupleType $ mapM (argType tyEnv) ts
> argType tyEnv (ListPattern _ ts) = freshTypeVar >>= flip elemType ts
> where elemType ty [] = return (listType ty)
> elemType ty (t:ts) =
diff --git a/src/Utils.lhs b/src/Utils.lhs
--- a/src/Utils.lhs
+++ b/src/Utils.lhs
@@ -1,4 +1,3 @@
-% -*- LaTeX -*-
% $Id: Utils.lhs,v 1.4 2003/10/04 17:04:38 wlux Exp $
%
% Copyright (c) 2001-2003, Wolfgang Lux
@@ -12,8 +11,6 @@
\begin{verbatim}
> module Utils where
-
-> import Data.List(foldl')
> infixr 5 ++!
diff --git a/src/cymake.hs b/src/cymake.hs
--- a/src/cymake.hs
+++ b/src/cymake.hs
@@ -13,6 +13,8 @@
module Main(main) where
+
+
import Data.List
import Data.Maybe
import System.IO
@@ -21,6 +23,7 @@
import Control.Monad (unless)
import Data.Char (isDigit)
+
import GetOpt
import CurryBuilder(buildCurry)
import CurryCompilerOpts
@@ -45,7 +48,7 @@
| null errs' && not (elem Html opts) = do
unless (noVerb options')
(putStrLn $ "This is cymake, version 0.1."
- ++ filter isDigit "$Revision: 3630 $")
+ ++ filter isDigit "$Revision: 3680 $")
mapM_ (buildCurry options') files
| null errs' = do
let importFiles = nub $ importPaths opts'