diff --git a/Curry/AbstractCurry.hs b/Curry/AbstractCurry.hs
--- a/Curry/AbstractCurry.hs
+++ b/Curry/AbstractCurry.hs
@@ -1,282 +1,279 @@
-------------------------------------------------------------------------------
---- Library to support meta-programming in Curry.
----
---- This library contains a definition for representing Curry programs
---- in Curry (type "CurryProg") and an I/O action to read Curry programs and
---- transform them into this abstract representation (function "readCurry").
----
---- Note this defines a slightly new format for AbstractCurry
---- in comparison to the first proposal of 2003.
----
---- Assumption: an abstract Curry program is stored in file prog.acy
---- and translated with the parser by "parsecurry -acy prog".
----
---- @author Michael Hanus
---- @version April 2004
----
---- Version for Haskell (slightly modified):
---- July 2005, Martin Engelke (men@informatik.uni-kiel.de)
----
-------------------------------------------------------------------------------
+{- |Library to support meta-programming in Curry.
-module Curry.AbstractCurry (CurryProg(..), QName, CLabel, CVisibility(..),
- CTVarIName, CTypeDecl(..), CConsDecl(..), CTypeExpr(..),
- COpDecl(..), CFixity(..), CVarIName,
- CFuncDecl(..), CRules(..), CEvalAnnot(..),
- CRule(..), CLocalDecl(..), CExpr(..), CStatement(..),
- CPattern(..), CBranchExpr(..), CLiteral(..),
- CField,
- readCurry, writeCurry) where
+ This library contains a definition for representing Curry programs
+ in Curry (type "CurryProg") and an I/O action to read Curry programs and
+ transform them into this abstract representation (function "readCurry").
-import Control.Monad(liftM)
-import Data.List(intersperse)
+ Note this defines a slightly new format for AbstractCurry
+ in comparison to the first proposal of 2003.
-import Curry.Files.PathUtils (writeModule,readModule)
+ Assumption: an abstract Curry program is stored in file prog.acy
+ and translated with the parser by "parsecurry -acy prog".
+ @author Michael Hanus
+ @version April 2004
-------------------------------------------------------------------------------
--- Definition of data types for representing abstract Curry programs:
--- ==================================================================
+ Version for Haskell (slightly modified):
+ July 2005, Martin Engelke (men@informatik.uni-kiel.de)
+-}
---- Data type for representing a Curry module in the intermediate form.
---- A value of this data type has the form
----
---- (CProg modname imports typedecls functions opdecls)
----
---- where modname: name of this module,
---- imports: list of modules names that are imported,
---- typedecls, opdecls, functions: see below
+module Curry.AbstractCurry
+ ( -- * Data types
+ CurryProg (..), QName, CLabel, CVisibility (..), CTVarIName
+ , CTypeDecl (..), CConsDecl (..), CTypeExpr (..), COpDecl (..), CFixity (..)
+ , CVarIName, CFuncDecl (..), CRules (..), CEvalAnnot (..), CRule (..)
+ , CLocalDecl (..), CExpr (..), CStatement (..), CPattern (..)
+ , CBranchExpr (..), CLiteral (..), CField
+ -- * Functions for reading and writing abstract curry terms
+ , readCurry, writeCurry
+ ) where
+import Control.Monad (liftM)
+import Data.List (intercalate)
+
+import Curry.Files.PathUtils (writeModule, readModule)
+
+{- ---------------------------------------------------------------------------
+ Definition of data types for representing abstract Curry programs
+--------------------------------------------------------------------------- -}
+
+{- |Data type for representing a Curry module in the intermediate form.
+ A value of this data type has the form
+
+ (CProg modname imports typedecls functions opdecls)
+
+ where modname: name of this module,
+ imports: list of modules names that are imported,
+ typedecls, opdecls, functions: see below
+-}
data CurryProg = CurryProg String [String] [CTypeDecl] [CFuncDecl] [COpDecl]
- deriving (Read, Show)
+ deriving (Read, Show)
---- The data type for representing qualified names.
---- In AbstractCurry all names are qualified to avoid name clashes.
---- The first component is the module name and the second component the
---- unqualified name as it occurs in the source program.
-type QName = (String,String)
+{- |The type for representing qualified names.
+ In AbstractCurry all names are qualified to avoid name clashes.
+ The first component is the module name and the second component the
+ unqualified name as it occurs in the source program.
+-}
+type QName = (String, String)
---- Type for representing label identifiers
+-- |Type for representing label identifiers
type CLabel = String
--- Data type to specify the visibility of various entities.
+-- |Data type to specify the visibility of various entities.
+data CVisibility = Public -- ^ exported entity
+ | Private -- ^ private entity
+ deriving (Read, Show, Eq)
-data CVisibility = Public -- exported entity
- | Private -- private entity
- deriving (Read, Show, Eq)
+{- |The type for representing type variables.
+ They are represented by (i,n) where i is a type variable index
+ which is unique inside a function and n is a name (if possible,
+ the name written in the source program).
+-}
+type CTVarIName = (Int, String)
+{- |Data type for representing definitions of algebraic data types and type
+ synonyms.
+
+ A data type definition of the form
---- The data type for representing type variables.
---- They are represented by (i,n) where i is a type variable index
---- which is unique inside a function and n is a name (if possible,
---- the name written in the source program).
-type CTVarIName = (Int,String)
+ data t x1...xn = ...| c t1....tkc |...
---- Data type for representing definitions of algebraic data types
---- and type synonyms.
----
---- A data type definition of the form
----
---- data t x1...xn = ...| c t1....tkc |...
----
---- is represented by the Curry term
----
---- (CType t v [i1,...,in] [...(CCons c kc v [t1,...,tkc])...])
----
---- where each ij is the index of the type variable xj
----
---- Note: the type variable indices are unique inside each type declaration
---- and are usually numbered from 0
----
---- Thus, a data type declaration consists of the name of the data type,
---- a list of type parameters and a list of constructor declarations.
----
+ is represented by the Curry term
-data CTypeDecl = CType QName CVisibility [CTVarIName] [CConsDecl]
- | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr
- deriving (Read, Show)
+ (CType t v [i1,...,in] [...(CCons c kc v [t1,...,tkc])...])
+ where each ij is the index of the type variable xj
---- A constructor declaration consists of the name and arity of the
---- constructor and a list of the argument types of the constructor.
+ Note: the type variable indices are unique inside each type declaration
+ and are usually numbered from 0
-data CConsDecl = CCons QName Int CVisibility [CTypeExpr]
- deriving (Read, Show)
+ 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 CTypeDecl = CType QName CVisibility [CTVarIName] [CConsDecl]
+ | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr
+ deriving (Read, Show)
+{- |A constructor declaration consists of the name and arity of the
+ constructor and a list of the argument types of the constructor.
+-}
+data CConsDecl = CCons QName Int CVisibility [CTypeExpr]
+ deriving (Read, Show)
---- Data type for type expressions.
---- A type expression is either a type variable, a function type,
---- or a type constructor application.
----
---- Note: the names of the predefined type constructors are
---- "Int", "Float", "Bool", "Char", "IO", "Success",
---- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
+{- |Data type for type expressions.
+ A type expression is either a type variable, a function type,
+ or a type constructor application.
-data CTypeExpr =
- CTVar CTVarIName -- type variable
- | CFuncType CTypeExpr CTypeExpr -- function type t1->t2
- | CTCons QName [CTypeExpr] -- type constructor application
- | CRecordType [CField CTypeExpr] -- record type (extended Curry)
+ Note: the names of the predefined type constructors are
+ "Int", "Float", "Bool", "Char", "IO", "Success",
+ "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
+-}
+data CTypeExpr
+ = CTVar CTVarIName -- ^ type variable
+ | CFuncType CTypeExpr CTypeExpr -- ^ function type t1->t2
+ | CTCons QName [CTypeExpr] -- ^ type constructor application
+ | CRecordType [CField CTypeExpr] -- ^ record type (extended Curry)
(Maybe CTVarIName)
- deriving (Read, Show)
+ deriving (Read, Show)
+{- |Data type for operator declarations.
+ An operator declaration "fix p n" in Curry corresponds to the
+ AbstractCurry term (COp n fix p).
+-}
+data COpDecl = COp QName CFixity Int deriving (Read, Show)
---- Data type for operator declarations.
---- An operator declaration "fix p n" in Curry corresponds to the
---- AbstractCurry term (COp n fix p).
+-- |Data type for fixity declarations of infix operators
+data CFixity = CInfixOp -- ^ non-associative infix operator
+ | CInfixlOp -- ^ left-associative infix operator
+ | CInfixrOp -- ^ right-associative infix operator
+ deriving (Read, Show, Eq)
-data COpDecl = COp QName CFixity Int deriving (Read, Show)
+{- |Data type for representing object variables.
+ Object variables occurring in expressions are represented by (Var i)
+ where i is a variable index.
+-}
+type CVarIName = (Int, String)
-data CFixity = CInfixOp -- non-associative infix operator
- | CInfixlOp -- left-associative infix operator
- | CInfixrOp -- right-associative infix operator
- deriving (Read, Show, Eq)
+{- |Data type for representing function declarations.
+
+ A function declaration in FlatCurry is a term of the form
+ (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))
---- Data types for representing object variables.
---- Object variables occurring in expressions are represented by (Var i)
---- where i is a variable index.
+ and represents the function "name" with definition
-type CVarIName = (Int,String)
+ name :: type
+ rule1
+ ...
+ rulek
+ Note: the variable indices are unique inside each rule
---- Data type for representing function declarations.
----
---- A function declaration in FlatCurry is a term of the form
----
---- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))
----
---- and represents the function "name" with definition
----
---- name :: type
---- rule1
---- ...
---- rulek
----
---- Note: the variable indices are unique inside each rule
----
---- External functions are represented as (CFunc name arity type (CExternal s))
---- where s is the external name associated to this function.
----
---- Thus, a function declaration consists of the name, arity, type, and
---- a list of rules.
----
+ External functions are represented as (CFunc name arity type (CExternal s))
+ where s is the external name associated to this function.
+ Thus, a function declaration consists of the name, arity, type, and
+ a list of rules.
+
+-}
data CFuncDecl = CFunc QName Int CVisibility CTypeExpr CRules
- deriving (Read, Show)
+ deriving (Read, Show)
---- A rule is either a list of formal parameters together with an expression
---- (i.e., a rule in flat form), a list of general program rules with
---- an evaluation annotation, or it is externally defined
-
+{- |A rule is either a list of formal parameters together with an expression
+ (i.e., a rule in flat form), a list of general program rules with
+ an evaluation annotation, or it is externally defined
+-}
data CRules = CRules CEvalAnnot [CRule]
| CExternal String
- deriving (Read, Show)
-
---- Data type for classifying evaluation annotations for functions.
---- They can be either flexible (default), rigid, or choice.
+ deriving (Read, Show)
+{- |Data type for classifying evaluation annotations for functions.
+ They can be either flexible (default), rigid, or choice.
+-}
data CEvalAnnot = CFlex | CRigid | CChoice deriving (Read, Show, Eq)
---- The most general form of a rule. It consists of a list of patterns
---- (left-hand side), a list of guards ("success" if not present in the
---- source text) with their corresponding right-hand sides, and
---- a list of local declarations.
-data CRule = CRule [CPattern] [(CExpr,CExpr)] [CLocalDecl]
- deriving (Read, Show)
-
---- Data type for representing local (let/where) declarations
-data CLocalDecl =
- CLocalFunc CFuncDecl -- local function declaration
- | CLocalPat CPattern CExpr [CLocalDecl] -- local pattern declaration
- | CLocalVar CVarIName -- local free variable declaration
- deriving (Read, Show)
+{- |The most general form of a rule. It consists of a list of patterns
+ (left-hand side), a list of guards ("success" if not present in the
+ source text) with their corresponding right-hand sides, and
+ a list of local declarations.
+-}
+data CRule = CRule [CPattern] [(CExpr, CExpr)] [CLocalDecl]
+ deriving (Read, Show)
---- Data type for representing Curry expressions.
+-- | Data type for representing local (let/where) declarations
+data CLocalDecl
+ = CLocalFunc CFuncDecl -- ^ local function declaration
+ | CLocalPat CPattern CExpr [CLocalDecl] -- ^ local pattern declaration
+ | CLocalVar CVarIName -- ^ local free variable declaration
+ deriving (Read, Show)
-data CExpr =
- CVar CVarIName -- variable (unique index / name)
- | CLit CLiteral -- literal (Integer/Float/Char constant)
- | CSymbol QName -- a defined symbol with module and name
- | CApply CExpr CExpr -- application (e1 e2)
- | CLambda [CPattern] CExpr -- lambda abstraction
- | CLetDecl [CLocalDecl] CExpr -- local let declarations
- | CDoExpr [CStatement] -- do expression
- | CListComp CExpr [CStatement] -- list comprehension
- | CCase CExpr [CBranchExpr] -- case expression
- | CRecConstr [CField CExpr] -- record construction (extended Curry)
- | CRecSelect CExpr CLabel -- field selection (extended Curry)
- | CRecUpdate [CField CExpr] CExpr -- record update (extended Curry)
+-- |Data type for representing Curry expressions.
+data CExpr
+ = CVar CVarIName -- ^ variable (unique index / name)
+ | CLit CLiteral -- ^ literal (Integer/Float/Char constant)
+ | CSymbol QName -- ^ a defined symbol with module and name
+ | CApply CExpr CExpr -- ^ application (e1 e2)
+ | CLambda [CPattern] CExpr -- ^ lambda abstraction
+ | CLetDecl [CLocalDecl] CExpr -- ^ local let declarations
+ | CDoExpr [CStatement] -- ^ do expression
+ | CListComp CExpr [CStatement] -- ^ list comprehension
+ | CCase CExpr [CBranchExpr] -- ^ case expression
+ | CRecConstr [CField CExpr] -- ^ record construction (extended Curry)
+ | CRecSelect CExpr CLabel -- ^ field selection (extended Curry)
+ | CRecUpdate [CField CExpr] CExpr -- ^ record update (extended Curry)
deriving (Read, Show)
---- Data type for representing statements in do expressions and
---- list comprehensions.
-
-data CStatement = CSExpr CExpr -- an expression (I/O action or boolean)
- | CSPat CPattern CExpr -- a pattern definition
- | CSLet [CLocalDecl] -- a local let declaration
- deriving (Read, Show)
-
---- Data type for representing pattern expressions.
-
-data CPattern =
- CPVar CVarIName -- pattern variable (unique index / name)
- | CPLit CLiteral -- literal (Integer/Float/Char constant)
- | CPComb QName [CPattern] -- application (m.c e1 ... en) of n-ary
- -- constructor m.c (CPComb (m,c) [e1,...,en])
- | CPAs CVarIName CPattern -- as-pattern (extended Curry)
- | CPFuncComb QName [CPattern] -- function pattern (extended Curry)
- | CPLazy CPattern -- lazy pattern (extended Curry)
- | CPRecord [CField CPattern] -- record pattern (extended curry)
- (Maybe CPattern)
- deriving (Read, Show)
+{- |Data type for representing statements in do expressions and
+ list comprehensions.
+-}
+data CStatement
+ = CSExpr CExpr -- ^ an expression (I/O action or boolean)
+ | CSPat CPattern CExpr -- ^ a pattern definition
+ | CSLet [CLocalDecl] -- ^ a local let declaration
+ deriving (Read, Show)
---- Data type for representing branches in case expressions.
+-- |Data type for representing pattern expressions.
+data CPattern
+ -- |pattern variable (unique index / name)
+ = CPVar CVarIName
+ -- |literal (Integer/Float/Char constant)
+ | CPLit CLiteral
+ {- |application (m.c e1 ... en) of n-ary constructor m.c
+ (CPComb (m,c) [e1,...,en]) -}
+ | CPComb QName [CPattern]
+ -- |as-pattern (extended Curry)
+ | CPAs CVarIName CPattern
+ -- |function pattern (extended Curry)
+ | CPFuncComb QName [CPattern]
+ -- |lazy pattern (extended Curry)
+ | CPLazy CPattern
+ -- |record pattern (extended curry)
+ | CPRecord [CField CPattern] (Maybe CPattern)
+ deriving (Read, Show)
+-- |Data type for representing branches in case expressions.
data CBranchExpr = CBranch CPattern CExpr deriving (Read, Show)
---- Data type for representing literals occurring in an expression.
---- It is either an integer, a float, or a character constant.
---- Note: the constructor definition of 'CIntc' differs from the original
---- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'
---- to provide an unlimited range of integer numbers. Furthermore
---- float values are represented with Haskell type 'Double' instead of
---- 'Float'.
-
+{- |Data type for representing literals occurring in an expression.
+ It is either an integer, a float, or a character constant.
+ Note: the constructor definition of 'CIntc' differs from the original
+ PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'
+ to provide an unlimited range of integer numbers. Furthermore
+ float values are represented with Haskell type 'Double' instead of
+ 'Float'.
+-}
data CLiteral = CIntc Integer
| CFloatc Double
| CCharc Char
- deriving (Read, Show, Eq)
-
---- Type for representing labeled fields
+ deriving (Read, Show, Eq)
-type CField a = (CLabel,a)
+-- |Type for representing labeled fields
+type CField a = (CLabel, a)
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
+{- ---------------------------------------------------------------------------
+ Definition of functions for reading and writing 'CurryProg's
+--------------------------------------------------------------------------- -}
--- Reads an AbstractCurry file and returns the corresponding AbstractCurry
--- program term (type 'CurryProg')
+{- |Reads an AbstractCurry file and returns the corresponding AbstractCurry
+ program term (type 'CurryProg')
+-}
readCurry :: String -> IO CurryProg
readCurry = liftM read . readModule
--- Writes an AbstractCurry program term into a file
--- If the flag is set, it will be the hidden .curry sub directory.
+{- |Writes an AbstractCurry program term into a file
+ If the flag is set, it will be the hidden .curry sub directory.
+-}
writeCurry :: Bool -> String -> CurryProg -> IO ()
-writeCurry inHiddenSubdir filename prog
- = catch (writeModule inHiddenSubdir filename (showCurry prog))
- (\e -> ioError e)
+writeCurry inHiddenSubdir filename prog
+ = catch (writeModule inHiddenSubdir filename $ showCurry prog) ioError
--- Shows an AbstractCurry program in a more nicely way.
+-- |Shows an AbstractCurry program in a nicer way.
showCurry :: CurryProg -> String
showCurry (CurryProg mname imps types funcs ops) =
- "CurryProg "++show mname++"\n "++
- show imps ++"\n ["++
- concat (intersperse ",\n " (map show types)) ++"]\n ["++
- concat (intersperse ",\n " (map show funcs)) ++"]\n "++
- show ops ++"\n"
-
-
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
+ "CurryProg " ++ show mname ++ "\n " ++
+ show imps ++ "\n [" ++
+ intercalate ",\n " (map show types) ++ "]\n [" ++
+ intercalate ",\n " (map show funcs) ++ "]\n " ++
+ show ops ++ "\n"
diff --git a/Curry/Base/Ident.lhs b/Curry/Base/Ident.lhs
--- a/Curry/Base/Ident.lhs
+++ b/Curry/Base/Ident.lhs
@@ -26,33 +26,42 @@
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
+> module Curry.Base.Ident
+> ( -- * Identifiers
+> -- ** Data types
+> Ident (..), QualIdent (..), ModuleIdent (..), SrcRefOf (..)
+> -- ** Functions
+> , showIdent, qualName, moduleName, mkIdent, mkMIdent, renameIdent
+> , unRenameIdent, isInfixOp, isQInfixOp, qualify, qualifyWith, qualQualify
+> , isQualified, unqualify, qualUnqualify, localIdent, updIdentName
+> , addPositionIdent, addPositionModuleIdent, addRef, addRefId
+> , positionOfQualIdent, updQualIdent
+> -- * Predefined simple identifiers
+> -- ** Identifiers for modules
+> , emptyMIdent, mainMIdent, preludeMIdent
+> -- ** Identifiers for types
+> , anonId, unitId, boolId, charId, intId, floatId, listId, ioId, successId
+> -- ** Identifiers for constructors
+> , trueId, falseId, nilId, consId, tupleId, isTupleId, tupleArity
+> -- ** Identifiers for functions
+> , mainId, minusId, fminusId
+
+> -- * Predefined qualified identifiers
+> -- ** Identifiers for types
+> , qUnitId, qBoolId, qCharId, qIntId, qFloatId, qListId, qIOId, qSuccessId
+> -- ** Identifiers for constructors
+> , qTrueId, qFalseId, qNilId, qConsId, qTupleId, isQTupleId, qTupleArity
+
+> -- * Extended functionality
+> -- ** Function pattern
+> , fpSelectorId, isFpSelectorId, isQualFpSelectorId
+> -- ** Records
+> , recSelectorId, qualRecSelectorId, recUpdateId, qualRecUpdateId
+> , recordExtId, labelExtId, isRecordExtId, isLabelExtId, fromRecordExtId
+> , fromLabelExtId, renameLabel, recordExt, labelExt, mkLabelIdent
+> ) where
+
> import Control.Monad(liftM)
> import Data.Char
> import Data.List
@@ -63,93 +72,117 @@
> import Curry.Base.Position
-Simple identifiers
+> -- | Simple identifiers
+> data Ident = Ident
+> { positionOfIdent :: Position -- ^ Source code 'Position'
+> , name :: String -- ^ name
+> , uniqueId :: Int -- ^ unique number of the identifier
+> } deriving (Read, Data, Typeable)
-> data Ident = Ident { positionOfIdent :: Position,
-> name :: String,
-> uniqueId :: Int }
-> deriving (Read, Data, Typeable)
->
+> instance SrcRefOf Ident where
+> srcRefOf = srcRefOf . positionOfIdent
+
> instance Eq Ident where
-> Ident _ m i == Ident _ n j = (m,i) == (n, j)
->
+> 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)
->
+> Ident _ m i `compare` Ident _ n j = (m,i) `compare` (n, j)
+
> instance Show Ident where
-> show = showIdent
->
+> show = showIdent
+
+> -- | Show function for an 'Ident'
> 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)
+> -- | Qualified identifiers
+> data QualIdent = QualIdent
+> { qualidMod :: Maybe ModuleIdent -- ^ optional module identifier
+> , qualidId:: Ident -- ^ identifier itself
+> } 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 SrcRefOf QualIdent where
+> srcRefOf = srcRefOf . unqualify
> instance Show QualIdent where
> show = qualName
-Module names
+> -- | show function for qualified identifiers
+> qualName :: QualIdent -> String
+> qualName (QualIdent Nothing x) = name x
+> qualName (QualIdent (Just m) x) = moduleName m ++ "." ++ name x
-> data ModuleIdent = ModuleIdent { positionOfModuleIdent :: Position,
-> moduleQualifiers :: [String] }
-> deriving (Read, Data,Typeable)
+> -- | Module identifiers
+> data ModuleIdent = ModuleIdent
+> { positionOfModuleIdent :: Position -- ^ source code position
+> , moduleQualifiers :: [String] -- ^ hierarchical idenfiers
+> } deriving (Read, Data, Typeable)
+
> instance Eq ModuleIdent where
-> (==) = (==) `on` moduleQualifiers
+> (==) = (==) `on` moduleQualifiers
> instance Ord ModuleIdent where
-> compare = compare `on` moduleQualifiers
+> compare = compare `on` moduleQualifiers
+> -- | Retrieve the hierarchical name of a module
> moduleName :: ModuleIdent -> String
> moduleName = concat . intersperse "." . moduleQualifiers
> instance Show ModuleIdent where
-> show = moduleName
+> show = moduleName
--- -----------------------------------------
+-- Functions for working with identifiers
+> -- | Add a 'Position' to an 'Ident'
> addPositionIdent :: Position -> Ident -> Ident
> addPositionIdent pos (Ident NoPos x n) = Ident pos x n
> addPositionIdent AST{astRef=sr} (Ident pos x n)
> = Ident pos{astRef=sr} x n
> addPositionIdent pos (Ident _ x n) = Ident pos x n
+> -- | Add a 'Position' to a 'ModuleIdent'
> addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent
-> addPositionModuleIdent pos (ModuleIdent _ x) = ModuleIdent pos x
+> addPositionModuleIdent pos mi = mi { positionOfModuleIdent = pos }
+> -- | Retrieve the 'Position' of a 'QualIdent'
> positionOfQualIdent :: QualIdent -> Position
> positionOfQualIdent = positionOfIdent . qualidId
+> -- | Construct an 'Ident' from a 'String'
> mkIdent :: String -> Ident
> mkIdent x = Ident NoPos x 0
+> -- | Rename an 'Ident' by changing its unique number
> renameIdent :: Ident -> Int -> Ident
-> renameIdent id n = id { uniqueId = n }
-
+> renameIdent ident n = ident { uniqueId = n }
+> -- | Revert the renaming of an 'Ident' by resetting its unique number
> unRenameIdent :: Ident -> Ident
-> unRenameIdent (Ident p x _) = Ident p x 0
+> unRenameIdent ident = renameIdent ident 0
+> -- | Change the name of an 'Ident' using a renaming function
+> updIdentName :: (String -> String) -> Ident -> Ident
+> updIdentName f (Ident p n i) =
+> addPositionIdent p $ renameIdent (mkIdent (f n)) i
+
+> -- | Construct a 'ModuleIdent' from a list of 'String's forming the
+> -- the hierarchical module name.
> mkMIdent :: [String] -> ModuleIdent
> mkMIdent = ModuleIdent NoPos
+> -- | Check whether an 'Ident' identifies an infix operation
> isInfixOp :: Ident -> Bool
-> isInfixOp (Ident _ ('<':c:cs) _)=
+> isInfixOp (Ident _ ('<':c:cs) _) =
> last (c:cs) /= '>' || not (isAlphaNum c) && c `notElem` "_(["
-> isInfixOp (Ident _ (c:_) _) = not (isAlphaNum c) && c `notElem` "_(["
-> isInfixOp (Ident _ _ _) = False -- error "Zero-length identifier"
+> isInfixOp (Ident _ (c:_) _) = not (isAlphaNum c) && c `notElem` "_(["
+> isInfixOp (Ident _ _ _) = False -- error "Zero-length identifier"
+> -- | Check whether an 'QualIdent' identifies an infix operation
> isQInfixOp :: QualIdent -> Bool
-> isQInfixOp (QualIdent _ x) = isInfixOp x
+> isQInfixOp = isInfixOp . qualidId
\end{verbatim}
The functions \texttt{qualify} and \texttt{qualifyWith} convert an
@@ -157,118 +190,237 @@
given module prefix, respectively).
\begin{verbatim}
+> -- | Convert an 'Ident' to a 'QualIdent'
> qualify :: Ident -> QualIdent
> qualify = QualIdent Nothing
+> -- | Convert an 'Ident' to a 'QualIdent' with a given 'ModuleIdent'
> qualifyWith :: ModuleIdent -> Ident -> QualIdent
> qualifyWith = QualIdent . Just
+> -- | Convert an 'QualIdent' to a new 'QualIdent' with a given 'ModuleIdent'.
+> -- If the original 'QualIdent' already contains an 'ModuleIdent' it
+> -- remains unchanged.
> qualQualify :: ModuleIdent -> QualIdent -> QualIdent
> qualQualify m (QualIdent Nothing x) = QualIdent (Just m) x
> qualQualify _ x = x
+> -- | Check whether a 'QualIdent' contains a 'ModuleIdent'
> isQualified :: QualIdent -> Bool
-> isQualified (QualIdent m _) = isJust m
+> isQualified = isJust . qualidMod
+> -- | Remove the qualification of an 'QualIdent'
> unqualify :: QualIdent -> Ident
-> unqualify (QualIdent _ x) = x
+> unqualify = qualidId
+> -- | Remove the qualification with a specific 'ModuleIdent'. If the
+> -- original 'QualIdent' has no 'ModuleIdent' or a different one it remains
+> -- unchanged.
> qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent
> qualUnqualify _ qid@(QualIdent Nothing _) = qid
> qualUnqualify m (QualIdent (Just m') x) = QualIdent m'' x
-> where m'' | m == m' = Nothing
-> | otherwise = Just m'
+> where m'' | m == m' = Nothing
+> | otherwise = Just m'
+> -- | Extract the 'Ident' of an 'QualIdent' if it is local to the
+> -- 'ModuleIdent', that if the 'Ident' is unqualified or qualified with
+> -- the given 'ModuleIdent' itself.
> localIdent :: ModuleIdent -> QualIdent -> Maybe Ident
> localIdent _ (QualIdent Nothing x) = Just x
> localIdent m (QualIdent (Just m') x)
> | m == m' = Just x
> | otherwise = Nothing
+> -- | Split a 'QualIdent' into a tuple of its components
> splitQualIdent :: QualIdent -> (Maybe ModuleIdent,Ident)
> splitQualIdent (QualIdent m x) = (m,x)
-> updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident) -> QualIdent -> QualIdent
+> -- | Update a 'QualIdent' by applying functions to its components
+> updQualIdent :: (ModuleIdent -> ModuleIdent)
+> -> (Ident -> Ident)
+> -> QualIdent -> QualIdent
> updQualIdent f g (QualIdent m x) = QualIdent (liftM f m) (g x)
+> -- | Add a 'SrcRef' to an 'Ident'
+> addRefId :: SrcRef -> Ident -> Ident
+> addRefId = addPositionIdent . AST
+
+> -- | Add a 'SrcRef' to a 'QualIdent'
> addRef :: SrcRef -> QualIdent -> QualIdent
> addRef = updQualIdent id . addRefId
-> 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"]
+> -- | 'ModuleIdent' for the empty module
+> emptyMIdent :: ModuleIdent
+> emptyMIdent = ModuleIdent NoPos []
+
+> -- | 'ModuleIdent' for the main module
+> mainMIdent :: ModuleIdent
+> mainMIdent = ModuleIdent NoPos ["main"]
+
+TODO: bjp 2011-01-12: Should it be "main" or "Main"?
+
+> -- | 'ModuleIdent' for the prelude
+> preludeMIdent :: ModuleIdent
> preludeMIdent = ModuleIdent NoPos ["Prelude"]
+> -- | Construct a 'QualIdent' for an 'Ident' using the module prelude
+> qPreludeIdent :: Ident -> QualIdent
+> qPreludeIdent = qualifyWith preludeMIdent
+
+> -- | 'Ident' for anonymous variables
> anonId :: Ident
-> anonId = Ident NoPos "_" 0
+> anonId = mkIdent "_"
-> 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
+-- Identifiers for types
-> trueId, falseId, nilId, consId :: Ident
-> trueId = Ident NoPos "True" 0
-> falseId = Ident NoPos "False" 0
-> nilId = Ident NoPos "[]" 0
-> consId = Ident NoPos ":" 0
+> -- | 'Ident' for the type/value unit ('()')
+> unitId :: Ident
+> unitId = mkIdent "()"
+> -- | 'Ident' for the type 'Bool'
+> boolId :: Ident
+> boolId = mkIdent "Bool"
+
+> -- | 'Ident' for the type 'Char'
+> charId :: Ident
+> charId = mkIdent "Char"
+
+> -- | 'Ident' for the type 'Int'
+> intId :: Ident
+> intId = mkIdent "Int"
+
+> -- | 'Ident' for the type 'Float'
+> floatId :: Ident
+> floatId = mkIdent "Float"
+
+> -- | 'Ident' for the type '[]'
+> listId :: Ident
+> listId = mkIdent "[]"
+
+> -- | 'Ident' for the type 'IO'
+> ioId :: Ident
+> ioId = mkIdent "IO"
+
+> -- | 'Ident' for the type 'Success'
+> successId :: Ident
+> successId = mkIdent "Success"
+
+-- Identifiers for constructors
+
+> -- | 'Ident' for the value 'True'
+> trueId :: Ident
+> trueId = mkIdent "True"
+
+> -- | 'Ident' for the value 'False'
+> falseId :: Ident
+> falseId = mkIdent "False"
+
+> -- | 'Ident' for the value '[]'
+> nilId :: Ident
+> nilId = mkIdent "[]"
+
+> -- | 'Ident' for the function ':'
+> consId :: Ident
+> consId = mkIdent ":"
+
+> -- | Construct an 'Ident' for a n-ary tuple where n >= 2
> tupleId :: Int -> Ident
> tupleId n
> | n >= 2 = Ident NoPos ("(" ++ replicate (n - 1) ',' ++ ")") 0
> | otherwise = error "internal error: tupleId"
+> -- | Check whether an 'Ident' is an identifier for an tuple type
> isTupleId :: Ident -> Bool
> isTupleId x = n > 1 && x == tupleId n
> where n = length (name x) - 1
+> -- | Compute the arity of an tuple identifier
> 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
+-- Identifiers for functions
-> qUnitId, qNilId, qConsId, qListId :: QualIdent
-> qUnitId = QualIdent Nothing unitId
-> qListId = QualIdent Nothing listId
-> qNilId = QualIdent Nothing nilId
-> qConsId = QualIdent Nothing consId
+> -- | 'Ident' for the main function
+> mainId :: Ident
+> mainId = mkIdent "main"
-> 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
+> -- | 'Ident' for the minus function
+> minusId :: Ident
+> minusId = mkIdent "-"
-> qTrueId, qFalseId :: QualIdent
-> qTrueId = QualIdent (Just preludeMIdent) trueId
-> qFalseId = QualIdent (Just preludeMIdent) falseId
+> -- | 'Ident' for the -. function
+> fminusId :: Ident
+> fminusId = mkIdent "-."
+-- Qualified Identifiers for types
+
+> -- | 'QualIdent' for the type/value unit ('()')
+> qUnitId :: QualIdent
+> qUnitId = qualify unitId
+
+> -- | 'QualIdent' for the type 'Bool'
+> qBoolId :: QualIdent
+> qBoolId = qPreludeIdent boolId
+
+> -- | 'QualIdent' for the type 'Char'
+> qCharId :: QualIdent
+> qCharId = qPreludeIdent charId
+
+> -- | 'QualIdent' for the type 'Int'
+> qIntId :: QualIdent
+> qIntId = qPreludeIdent intId
+
+> -- | 'QualIdent' for the type 'Float'
+> qFloatId :: QualIdent
+> qFloatId = qPreludeIdent floatId
+
+> -- | 'QualIdent' for the type '[]'
+> qListId :: QualIdent
+> qListId = qualify listId
+
+> -- | 'QualIdent' for the type 'IO'
+> qIOId :: QualIdent
+> qIOId = qPreludeIdent ioId
+
+> -- | 'QualIdent' for the type 'Success'
+> qSuccessId :: QualIdent
+> qSuccessId = qPreludeIdent successId
+
+-- Qualified Identifiers for constructors
+
+> -- | 'QualIdent' for the constructor 'True'
+> qTrueId :: QualIdent
+> qTrueId = qPreludeIdent trueId
+
+> -- | 'QualIdent' for the constructor 'False'
+> qFalseId :: QualIdent
+> qFalseId = qPreludeIdent falseId
+
+> -- | 'QualIdent' for the constructor '[]'
+> qNilId :: QualIdent
+> qNilId = qualify nilId
+
+> -- | 'QualIdent' for the constructor ':'
+> qConsId :: QualIdent
+> qConsId = qualify consId
+
+> -- | 'QualIdent' for the type of n-ary tuples
> qTupleId :: Int -> QualIdent
-> qTupleId = QualIdent Nothing . tupleId
+> qTupleId = qualify . tupleId
+> -- | Check whether an 'QualIdent' is an identifier for an tuple type
> isQTupleId :: QualIdent -> Bool
> isQTupleId = isTupleId . unqualify
+> -- | Compute the arity of an qualified tuple identifier
> qTupleArity :: QualIdent -> Int
> qTupleArity = tupleArity . unqualify
@@ -276,78 +428,103 @@
Micellaneous function for generating and testing extended identifiers.
\begin{verbatim}
+> -- | Construct an 'Ident' for a function pattern
> fpSelectorId :: Int -> Ident
> fpSelectorId n = Ident NoPos (fpSelExt ++ show n) 0
+> -- | Check whether an 'Ident' is an identifier for a function pattern
> isFpSelectorId :: Ident -> Bool
> isFpSelectorId = any (fpSelExt `isPrefixOf`) . tails . name
+TODO: isInfixOf?
+
+> -- | Check whether an 'QualIdent' is an identifier for a function pattern
> isQualFpSelectorId :: QualIdent -> Bool
> isQualFpSelectorId = isFpSelectorId . unqualify
-> recSelectorId :: QualIdent -> Ident -> Ident
+> -- | Construct an 'Ident' for a record selection pattern
+> recSelectorId :: QualIdent -- ^ identifier of the record
+> -> Ident -- ^ identifier of the label
+> -> Ident
> recSelectorId r l =
> mkIdent (recSelExt ++ name (unqualify r) ++ "." ++ name l)
-> qualRecSelectorId :: ModuleIdent -> QualIdent -> Ident -> QualIdent
+> -- | Construct a 'QualIdent' for a record selection pattern
+> qualRecSelectorId :: ModuleIdent -- ^ default module
+> -> QualIdent -- ^ record identifier
+> -> Ident -- ^ label identifier
+> -> 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)
+> -- | Construct an 'Ident' for a record update pattern
+> recUpdateId :: QualIdent -- ^ record identifier
+> -> Ident -- ^ label identifier
+> -> Ident
+> recUpdateId r l = mkIdent $ recUpdExt ++ name (unqualify r) ++ "." ++ name l
-> qualRecUpdateId :: ModuleIdent -> QualIdent -> Ident -> QualIdent
+> -- | Construct a 'QualIdent' for a record update pattern
+> qualRecUpdateId :: ModuleIdent -- ^ default module
+> -> QualIdent -- ^ record identifier
+> -> Ident -- ^ label identifier
+> -> QualIdent
> qualRecUpdateId m r l = qualifyWith m' (recUpdateId r l)
> where m' = fromMaybe m (fst (splitQualIdent r))
+> -- | Construct an 'Ident' for a record
> recordExtId :: Ident -> Ident
> recordExtId r = mkIdent (recordExt ++ name r)
+> -- | Construct an 'Ident' for a record label
> labelExtId :: Ident -> Ident
> labelExtId l = mkIdent (labelExt ++ name l)
+> -- | Retrieve the 'Ident' from a record identifier
> fromRecordExtId :: Ident -> Ident
-> fromRecordExtId r
+> fromRecordExtId r
> | p == recordExt = mkIdent r'
> | otherwise = r
> where (p,r') = splitAt (length recordExt) (name r)
+> -- | Retrieve the 'Ident' from a record label identifier
> fromLabelExtId :: Ident -> Ident
-> fromLabelExtId l
+> fromLabelExtId l
> | p == labelExt = mkIdent l'
> | otherwise = l
> where (p,l') = splitAt (length labelExt) (name l)
+> -- | Check whether an 'Ident' is an identifier for a record
> isRecordExtId :: Ident -> Bool
> isRecordExtId r = recordExt `isPrefixOf` name r
+> -- | Check whether an 'Ident' is an identifier for a record label
> isLabelExtId :: Ident -> Bool
> isLabelExtId l = labelExt `isPrefixOf` name l
+> -- | Construct an 'Ident' for a record label
> mkLabelIdent :: String -> Ident
> mkLabelIdent c = renameIdent (mkIdent c) (-1)
+> -- | Rename an 'Ident' for a record label
> renameLabel :: Ident -> Ident
> renameLabel l = renameIdent l (-1)
-
-> fpSelExt, recSelExt, recUpdExt, recordExt, labelExt :: String
+> -- | Annotation string for function pattern identifiers
+> fpSelExt :: String
> fpSelExt = "_#selFP"
-> recSelExt = "_#selR@"
-> recUpdExt = "_#updR@"
-> recordExt = "_#Rec:"
-> labelExt = "_#Lab:"
+> -- | Annotation string for record selection identifiers
+> recSelExt :: String
+> recSelExt = "_#selR@"
-> instance SrcRefOf Ident where
-> srcRefOf = srcRefOf . positionOfIdent
+> -- | Annotation string for record update identifiers
+> recUpdExt :: String
+> recUpdExt = "_#updR@"
-> instance SrcRefOf QualIdent where
-> srcRefOf = srcRefOf . unqualify
+> -- | Annotation string for record identifiers
+> recordExt :: String
+> recordExt = "_#Rec:"
-> 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)
+> -- | Annotation string for record label identifiers
+> labelExt :: String
+> labelExt = "_#Lab:"
diff --git a/Curry/Base/MessageMonad.hs b/Curry/Base/MessageMonad.hs
--- a/Curry/Base/MessageMonad.hs
+++ b/Curry/Base/MessageMonad.hs
@@ -1,12 +1,9 @@
{-# LANGUAGE FlexibleContexts #-}
-{-
- The monads MsgMonad and MsgMonadIO provide a common way
- to log warning messages and to stop execution when an
- error occurs. They may be used to integrate different
- compiler passes smoothly.
-
- (c) 2009, Holger Siegel.
+{- | The monads MsgMonad and MsgMonadIO provide a common way to log warning
+ messages and to stop execution when an error occurs. They may be used to
+ integrate different compiler passes smoothly.
+ (c) 2009, Holger Siegel.
-}
module Curry.Base.MessageMonad where
@@ -17,68 +14,82 @@
import Curry.Base.Position
-
+{- | Message monad transformer enabling the reporting of 'WarnMsg's as
+ warnings and additionally a 'WarnMsg' as an error message.
+-}
type MsgMonadT m = ErrorT WarnMsg (WriterT [WarnMsg] m)
+-- | Simple message monad
type MsgMonad = MsgMonadT Identity
+-- | Message monad with underlying 'IO' monad
type MsgMonadIO = MsgMonadT IO
-data WarnMsg = WarnMsg { warnPos :: Maybe Position,
- warnTxt :: String
- }
+-- | Data type for warning messages
+data WarnMsg = WarnMsg
+ { warnPos :: Maybe Position -- ^ optional source code position
+ , warnTxt :: String -- ^ the message itself
+ }
+
instance Error WarnMsg where
- noMsg = WarnMsg Nothing "Failure!"
- strMsg = WarnMsg Nothing
+ noMsg = WarnMsg Nothing "Failure!"
+ strMsg = WarnMsg Nothing
instance Show WarnMsg where
- show = showWarning
+ show = showWarning
+-- | Show a 'WarnMsg' as a warning
+showWarning :: WarnMsg -> String
showWarning w = "Warning: " ++ pos ++ warnTxt w
- where pos = case warnPos w of
- Nothing -> ""
- Just p -> show p ++": "
+ where pos = case warnPos w of
+ Nothing -> ""
+ Just p -> show p ++ ": "
+-- | Show a 'WarnMsg' as an error
+showError :: WarnMsg -> String
showError w = "Error: " ++ pos ++ warnTxt w
- where pos = case warnPos w of
- Nothing -> ""
- Just p -> show p ++": "
+ where pos = case warnPos w of
+ Nothing -> ""
+ Just p -> show p ++ ": "
+-- | Evaluate the value of a 'MsgMonad a'
+runMsg :: MsgMonad a -> (Either WarnMsg a, [WarnMsg])
+runMsg = runIdentity . runWriterT . runErrorT
+
+{- | Directly evaluate to the success value of a 'MsgMonad a'. Errors are
+ converted in a call to the 'error' function.
+-}
ok :: MsgMonad a -> a
ok = either (error . showError) id . fst . runMsg
+-- | Sequence 'MsgMonad' action inside the 'IO' monad.
+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')
-failWith :: (MonadError a m, Error a) => String -> m a1
-failWith = throwError . strMsg
+-- | Convert a 'MsgMonad' to a 'MsgMonadIO'
+dropIO :: MsgMonad a -> MsgMonadIO a
+dropIO m = case runMsg m of
+ (Left e, msgs) -> tell msgs >> throwError e
+ (Right x, msgs) -> tell msgs >> return x
+-- | Abort the computation with an error message
+failWith :: (MonadError a m, Error a) => String -> m b
+failWith = throwError . strMsg
+-- | Abort the computation with an error message at a certain position
failWithAt :: (MonadError WarnMsg m) => Position -> String -> m a
failWithAt p = throwError . WarnMsg (Just p)
-
+-- | Report a warning message
warnMessage :: (MonadWriter [WarnMsg] m) => String -> m ()
warnMessage s = tell [WarnMsg Nothing s]
-
+-- | Report a warning message for a given position
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/Curry/Base/Position.lhs b/Curry/Base/Position.lhs
--- a/Curry/Base/Position.lhs
+++ b/Curry/Base/Position.lhs
@@ -21,7 +21,8 @@
> module Curry.Base.Position where
> import Data.Generics
-> newtype SrcRef = SrcRef [Int] deriving (Typeable,Data) -- a pointer to the origin
+> -- | A pointer to the origin
+> newtype SrcRef = SrcRef [Int] deriving (Data,Typeable)
-- the instances for standard classes or such that SrcRefs are invisible
@@ -30,26 +31,42 @@
> instance Eq SrcRef where _ == _ = True
> instance Ord SrcRef where compare _ _ = EQ
+> -- | The empty source code reference
> noRef :: SrcRef
> noRef = SrcRef []
->
+
+> -- | Increment a source code reference by a given number
> incSrcRef :: SrcRef -> Int -> SrcRef
> incSrcRef (SrcRef [i]) j = SrcRef [i+j]
-> incSrcRef is _ = error $ "internal error; increment source ref: " ++ show is
+> incSrcRef is _ = error $
+> "internal error; increment source ref: " ++ show is
-> data Position
-> = Position{ file :: FilePath, line :: Int, column :: Int, astRef :: SrcRef }
-> | AST { astRef :: SrcRef }
+> -- | Source code positions
+> data Position
+> -- | Normal source code position
+> = Position
+> { file :: FilePath -- ^ 'FilePath' of the source file
+> , line :: Int -- ^ line number, beginning at 1
+> , column :: Int -- ^ column number, beginning at 1
+> , astRef :: SrcRef -- ^ reference to the abstract syntax tree
+> }
+> -- | Position in the abstract syntax tree
+> | AST
+> { astRef :: SrcRef -- ^ reference to the abstract syntax tree
+> }
+> -- | no position
> | NoPos
> deriving (Eq, Ord,Data,Typeable)
+> -- | Increment the position in the abstract syntax tree
> incPosition :: Position -> Int -> Position
> incPosition NoPos _ = NoPos
-> incPosition p j = p{astRef=incSrcRef (astRef p) j}
+> incPosition p j = p { astRef = incSrcRef (astRef p) j }
> instance Read Position where
-> readsPrec p s =
-> [ (Position{file="",line=i,column=j,astRef=noRef},s') | ((i,j),s') <- readsPrec p s]
+> readsPrec p s =
+> [ (Position{file="",line=i,column=j,astRef=noRef},s') |
+> ((i,j),s') <- readsPrec p s]
> instance Show Position where
> showsPrec _ Position{file=fn,line=l,column=c} =
@@ -59,41 +76,51 @@
> showsPrec _ AST{} = id
> showsPrec _ NoPos = id
+> -- | Number of spaces for a tabulator
> tabWidth :: Int
> tabWidth = 8
+> -- | Absolute first position of a file
> first :: FilePath -> Position
> first fn = Position fn 1 1 noRef
+> -- | Increment a position by a number of columns
> incr :: Position -> Int -> Position
> incr p@Position{column=c} n = p{column=c + n}
> incr p _ = p
+> -- | Next position to the right
> next :: Position -> Position
> next = flip incr 1
+> -- | First position after the next tabulator
> tab :: Position -> Position
> tab p@Position{column=c} = p{column=c + tabWidth - (c - 1) `mod` tabWidth}
> tab p = p
+> -- | First position of the next line
> nl :: Position -> Position
> nl p@Position{line=l} = p{line=l + 1, column=1}
> nl p = p
+> -- | Show the line and column of the 'Position'
> showLine :: Position -> String
> showLine NoPos = ""
> showLine AST{} = ""
-> showLine Position{line=l,column=c}
-> = "(line " ++ show l ++ "." ++ show c ++ ") "
-
-\end{verbatim}
+> showLine Position{line=l,column=c}
+> = "(line " ++ show l ++ "." ++ show c ++ ") "
+> -- | Type class for data type containing source code references
> class SrcRefOf a where
+> -- | Retrieve all 'SrcRef's
> srcRefsOf :: a -> [SrcRef]
> srcRefsOf = (:[]) . srcRefOf
+> -- | Retrieve the first 'SrcRef'
> srcRefOf :: a -> SrcRef
> srcRefOf = head . srcRefsOf
> instance SrcRefOf Position where
> srcRefOf NoPos = noRef
-> srcRefOf x = astRef x
+> srcRefOf x = astRef x
+
+\end{verbatim}
diff --git a/Curry/ExtendedFlat/EraseTypes.hs b/Curry/ExtendedFlat/EraseTypes.hs
--- a/Curry/ExtendedFlat/EraseTypes.hs
+++ b/Curry/ExtendedFlat/EraseTypes.hs
@@ -1,88 +1,65 @@
-{-
- Erases type annotations an ExtendedFlat module.
- In functions, it preserves annotations that contain
- free type variables, i.e. type variables which do
- not occur in the function's type signature.
+{- |Erases type annotations in an ExtendedFlat module.
+ In functions, it preserves annotations that contain free type variables,
+ i.e. type variables which do not occur in the function's type signature.
- In the remaining type annotations, free type variables
- are replaced by the unit type ().
+ In the remaining type annotations, free type variables are replaced by the
+ unit type ().
- (c) 2009, Holger Siegel.
+ (c) 2009, Holger Siegel.
-}
-module Curry.ExtendedFlat.EraseTypes(eraseTypes) where
-
-import Control.Monad.Reader
-import qualified Data.Set as Set
+module Curry.ExtendedFlat.EraseTypes (eraseTypes) where
import Curry.ExtendedFlat.Type
import Curry.ExtendedFlat.Goodies
-import Curry.ExtendedFlat.MonadicGoodies
-
--- FIXME the use of lists is not very efficient,
+-- TODO the use of lists is not very efficient,
-- but since the number of type variables is relatively
-- small, we stick with that for now.
type TVarSet = [TVarIndex]
-
eraseTypes :: Prog -> Prog
eraseTypes = updProg id id id (map eraseTypesInFunc) id
-
eraseTypesInFunc :: FuncDecl -> FuncDecl
eraseTypesInFunc (Func qname arity visty funtype rule)
= Func qname arity visty funtype rule'
where rule' = eraseTypesInRule (allTVars funtype) rule
-
eraseTypesInRule :: TVarSet -> Rule -> Rule
-eraseTypesInRule sigtvars r@(External _) = r
-eraseTypesInRule sigtvars (Rule vars expr)
- = Rule (map (eraseTypesInVar sigtvars) vars) (eraseTypesInExpr sigtvars expr)
-
+eraseTypesInRule _ r@(External _) = r
+eraseTypesInRule sigtvars (Rule vars expr) = Rule
+ (map (eraseTypesInVar sigtvars) vars) (eraseTypesInExpr sigtvars expr)
eraseTypesInExpr :: TVarSet -> Expr -> Expr
-eraseTypesInExpr sigtvars
- = rnmAllVars (eraseTypesInVar sigtvars) .
- updQNames (eraseTypesInQName sigtvars)
-
+eraseTypesInExpr sigtvars = rnmAllVars (eraseTypesInVar sigtvars)
+ . updQNames (eraseTypesInQName sigtvars)
eraseTypesInVar :: TVarSet -> VarIndex -> VarIndex
-eraseTypesInVar sigtvars v
- = v {typeofVar = vt' }
- where
- vt = typeofVar v
- usedtvars = maybe [] allTVars vt
- vt' | all (`elem` sigtvars) usedtvars
- = Nothing
- | otherwise
- = fmap (replaceFreeTypesWithEmptyTuple sigtvars) vt
-
+eraseTypesInVar sigtvars v = v {typeofVar = vt' } where
+ vt = typeofVar v
+ usedtvars = maybe [] allTVars vt
+ vt' | all (`elem` sigtvars) usedtvars
+ = Nothing
+ | otherwise
+ = fmap (replaceFreeTypesWithEmptyTuple sigtvars) vt
eraseTypesInQName :: TVarSet -> QName -> QName
-eraseTypesInQName sigtvars v
- = v {typeofQName = qt' }
- where
- qt = typeofQName v
- usedtvars = maybe [] allTVars qt
- qt' | all (`elem` sigtvars) usedtvars
- = Nothing
- | otherwise
- = fmap (replaceFreeTypesWithEmptyTuple sigtvars) qt
-
+eraseTypesInQName sigtvars v = v {typeofQName = qt' } where
+ qt = typeofQName v
+ usedtvars = maybe [] allTVars qt
+ qt' | all (`elem` sigtvars) usedtvars
+ = Nothing
+ | otherwise
+ = fmap (replaceFreeTypesWithEmptyTuple sigtvars) qt
allTVars :: TypeExpr -> [TVarIndex]
-allTVars t = go t []
- where
- go (TVar v) is = v : is
- go (FuncType x e) is = go x (go e is)
- go (TCons _ ts) is = foldr go is ts
-
+allTVars t = go t [] where
+ go (TVar v) is = v : is
+ go (FuncType x e) is = go x (go e is)
+ go (TCons _ ts) is = foldr go is ts
replaceFreeTypesWithEmptyTuple :: TVarSet -> TypeExpr -> TypeExpr
-replaceFreeTypesWithEmptyTuple usedtvars = updTVars foo
- where
- foo tidx
- | tidx `elem` usedtvars = TVar tidx
- | otherwise = TCons (mkQName ("Prelude", "()")) []
+replaceFreeTypesWithEmptyTuple usedtvars = updTVars foo where
+ foo tidx | tidx `elem` usedtvars = TVar tidx
+ | otherwise = TCons (mkQName ("Prelude", "()")) []
diff --git a/Curry/ExtendedFlat/Goodies.hs b/Curry/ExtendedFlat/Goodies.hs
--- a/Curry/ExtendedFlat/Goodies.hs
+++ b/Curry/ExtendedFlat/Goodies.hs
@@ -1,5 +1,5 @@
----------------------------------------------------------------------------
---- This library provides selector functions, test and update operations
+--- This library provides selector functions, test and update operations
--- as well as some useful auxiliary functions for FlatCurry data terms.
--- Most of the provided functions are based on general transformation
--- functions that replace constructors with user-defined
@@ -8,7 +8,7 @@
--- transformations on FlatCurry terms,
--- so the provided functions can be used to implement specific transformations
--- without having to explicitly state the recursion. Essentially, the tedious
---- part of such transformations - descend in fairly complex term structures -
+--- part of such transformations - descend in fairly complex term structures -
--- is abstracted away, which hopefully makes the code more clear and brief.
---
--- @author Sebastian Fischer
@@ -111,14 +111,14 @@
--- update all qualified names in program
updQNamesInProg :: Update Prog QName
-updQNamesInProg f = updProg id id
+updQNamesInProg f = updProg id id
(map (updQNamesInType f)) (map (updQNamesInFunc f)) (map (updOpName f))
--- rename program (update name of and all qualified names in program)
rnmProg :: String -> Prog -> Prog
rnmProg name p = updProgName (const name) (updQNamesInProg rnm p)
where
- rnm qn = if modName qn == progName p
+ rnm qn = if modName qn == progName p
then qn { modName = name }
else qn
@@ -201,7 +201,7 @@
--- update all qualified names in type declaration
updQNamesInType :: Update TypeDecl QName
-updQNamesInType f
+updQNamesInType f
= updType f id id (map (updQNamesInConsDecl f)) (updQNamesInTypeExpr f)
-- ConsDecl ------------------------------------------------------------------
@@ -268,29 +268,39 @@
--- get index from type variable
tVarIndex :: TypeExpr -> TVarIndex
tVarIndex (TVar n) = n
+tVarIndex _ = error $ "Curry.ExtendedFlat.Goodies.tvarIndex: " ++
+ "no type variable"
--- get domain from functional type
domain :: TypeExpr -> TypeExpr
domain (FuncType dom _) = dom
+domain _ = error $ "Curry.ExtendedFlat.Goodies.domain: " ++
+ "no function type"
--- get range from functional type
range :: TypeExpr -> TypeExpr
range (FuncType _ ran) = ran
+range _ = error $ "Curry.ExtendedFlat.Goodies.range: " ++
+ "no function type"
--- get name from constructed type
tConsName :: TypeExpr -> QName
tConsName (TCons name _) = name
+tConsName _ = error $ "Curry.ExtendedFlat.Goodies.tConsName: " ++
+ "no constructor type"
--- get arguments from constructed type
tConsArgs :: TypeExpr -> [TypeExpr]
tConsArgs (TCons _ args) = args
+tConsArgs _ = error $ "Curry.ExtendedFlat.Goodies.tConsArgs: " ++
+ "no constructor type"
--- transform type expression
trTypeExpr :: (TVarIndex -> a) ->
(QName -> [a] -> a) ->
(a -> a -> a) -> TypeExpr -> a
trTypeExpr tvar _ _ (TVar n) = tvar n
-trTypeExpr tvar tcons functype (TCons name args)
+trTypeExpr tvar tcons functype (TCons name args)
= tcons name (map (trTypeExpr tvar tcons functype) args)
trTypeExpr tvar tcons functype (FuncType from to) = functype (f from) (f to)
where
@@ -338,7 +348,7 @@
resultType (TCons name args) = TCons name args
resultType (FuncType _ ran) = resultType ran
---- get indexes of all type variables
+--- get indexes of all type variables
allVarsInTypeExpr :: TypeExpr -> [TVarIndex]
allVarsInTypeExpr = trTypeExpr (:[]) (const concat) (++)
@@ -429,8 +439,8 @@
(TypeExpr -> TypeExpr) ->
(Rule -> Rule) -> FuncDecl -> FuncDecl
updFunc fn fa fv ft fr = trFunc func
- where
- func name arity vis t rule
+ where
+ func name arity vis t rule
= Func (fn name) (fa arity) (fv vis) (ft t) (fr rule)
--- update name of function
@@ -475,7 +485,7 @@
funcRHS f | not (isExternal f) = orCase (funcBody f)
| otherwise = []
where
- orCase e
+ orCase e
| isOr e = concatMap orCase (orExps e)
| isCase e = concatMap orCase (map branchExpr (caseBranches e))
| otherwise = [e]
@@ -515,7 +525,7 @@
--- get rules external declaration
ruleExtDecl :: Rule -> String
-ruleExtDecl = trRule failed id
+ruleExtDecl = trRule failed id
-- Test Operations
@@ -599,22 +609,30 @@
--- get internal number of variable
varNr :: Expr -> VarIndex
varNr (Var n) = n
+varNr _ = error "Curry.ExtendedFlat.Goodies.varNr: no variable"
--- get literal if expression is literal expression
literal :: Expr -> Literal
literal (Lit l) = l
+literal _ = error "Curry.ExtendedFlat.Goodies.literal: no literal"
--- get combination type of a combined expression
combType :: Expr -> CombType
combType (Comb ct _ _) = ct
+combType _ = error $ "Curry.ExtendedFlat.Goodies.combType: " ++
+ "no combined expression"
--- get name of a combined expression
combName :: Expr -> QName
combName (Comb _ name _) = name
+combName _ = error $ "Curry.ExtendedFlat.Goodies.combName: " ++
+ "no combined expression"
--- get arguments of a combined expression
combArgs :: Expr -> [Expr]
combArgs (Comb _ _ args) = args
+combArgs _ = error $ "Curry.ExtendedFlat.Goodies.combArgs: " ++
+ "no combined expression"
--- get number of missing arguments if expression is combined
missingCombArgs :: Expr -> Int
@@ -623,40 +641,57 @@
--- get indices of varoables in let declaration
letBinds :: Expr -> [(VarIndex,Expr)]
letBinds (Let vs _) = vs
+letBinds _ = error $ "Curry.ExtendedFlat.Goodies.letBinds: " ++
+ "no let expression"
--- get body of let declaration
letBody :: Expr -> Expr
letBody (Let _ e) = e
+letBody _ = error $ "Curry.ExtendedFlat.Goodies.letBody: " ++
+ "no let expression"
--- get variable indices from declaration of free variables
freeVars :: Expr -> [VarIndex]
freeVars (Free vs _) = vs
+freeVars _ = error $ "Curry.ExtendedFlat.Goodies.freeVars: " ++
+ "no declaration of free variables"
--- get expression from declaration of free variables
freeExpr :: Expr -> Expr
freeExpr (Free _ e) = e
+freeExpr _ = error $ "Curry.ExtendedFlat.Goodies.freeExpr: " ++
+ "no declaration of free variables"
--- get expressions from or-expression
orExps :: Expr -> [Expr]
orExps (Or e1 e2) = [e1,e2]
+orExps _ = error $ "Curry.ExtendedFlat.Goodies.orExps: " ++
+ "no or expression"
--- get case-type of case expression
caseType :: Expr -> CaseType
caseType (Case _ ct _ _) = ct
+caseType _ = error $ "Curry.ExtendedFlat.Goodies.caseType: " ++
+ "no case expression"
--- get scrutinee of case expression
caseExpr :: Expr -> Expr
caseExpr (Case _ _ e _) = e
+caseExpr _ = error $ "Curry.ExtendedFlat.Goodies.caseExpr: " ++
+ "no case expression"
--- get branch expressions from case expression
caseBranches :: Expr -> [BranchExpr]
caseBranches (Case _ _ _ bs) = bs
+caseBranches _ = error
+ "Curry.ExtendedFlat.Goodies.caseBranches: no case expression"
+
-- Test Operations
--- is expression a variable?
isVar :: Expr -> Bool
-isVar e = case e of
+isVar e = case e of
Var _ -> True
_ -> False
@@ -725,7 +760,7 @@
f = trExpr var lit comb lt fr oR cas branch
trExpr var lit comb lt fr oR cas branch (Case pos ct e bs)
- = cas pos ct (f e) (map (\ (Branch pat e) -> branch pat (f e)) bs)
+ = cas pos ct (f e) (map (\ (Branch pat e') -> branch pat (f e')) bs)
where
f = trExpr var lit comb lt fr oR cas branch
@@ -862,7 +897,7 @@
patArgs :: Pattern -> [VarIndex]
patArgs = trPattern (\_ args -> args) failed
---- get literal from literal pattern
+--- get literal from literal pattern
patLiteral :: Pattern -> Literal
patLiteral = trPattern failed id
@@ -907,7 +942,7 @@
-- required type information. Make sure that the expression is processed by
-- Curry.ExtendedFlat.TypeInference.adjustTypeInfo.)
typeofExpr :: Expr -> Maybe TypeExpr
-typeofExpr expr
+typeofExpr expr
= case expr of
Var vi -> typeofVar vi
Lit l -> Just (typeofLiteral l)
@@ -916,12 +951,12 @@
Let _ e -> typeofExpr e
Or e1 e2 -> typeofExpr e1 `mplus` typeofExpr e2
Case _ _ _ bs -> msum (map (typeofExpr . branchExpr) bs)
- where
+ where
typeofApp :: [a] -> TypeExpr -> Maybe TypeExpr
typeofApp [] t = Just t
typeofApp (_:as) (FuncType _ t) = typeofApp as t
typeofApp (_:_) (TVar _) = Nothing
- typeofApp a@(_:_) (TCons _ _) = Nothing
+ typeofApp (_:_) (TCons _ _) = Nothing
-- ierr = error "internal error in typeofExpr: FuncType expected"
diff --git a/Curry/ExtendedFlat/Type.hs b/Curry/ExtendedFlat/Type.hs
--- a/Curry/ExtendedFlat/Type.hs
+++ b/Curry/ExtendedFlat/Type.hs
@@ -31,7 +31,8 @@
import Data.List(intersperse)
import Control.Monad (liftM)
-import Data.Generics hiding (Fixity)
+import Data.Generics
+ (Data (..), Typeable (..), Typeable2 (..), extQ, ext1Q, showConstr)
import Data.Function(on)
import System.FilePath
diff --git a/Curry/ExtendedFlat/TypeInference.hs b/Curry/ExtendedFlat/TypeInference.hs
--- a/Curry/ExtendedFlat/TypeInference.hs
+++ b/Curry/ExtendedFlat/TypeInference.hs
@@ -1,65 +1,59 @@
-{-# LANGUAGE FlexibleContexts, PatternGuards #-}
-
-{-
- Function adjustTypeInfos annotates every declaration,
- identifier, and application with exact type information.
-
- This information is derived from the more general information
- found in the AST.
+{- |The function adjustTypeInfos annotates every declaration, identifier, and
+ application with exact type information.
- (c) 2009, Holger Siegel.
+ This information is derived from the more general information found in
+ the AST.
+ (c) 2009, Holger Siegel.
-}
+{-# LANGUAGE FlexibleContexts, PatternGuards #-}
+
module Curry.ExtendedFlat.TypeInference
- ( dispType,
- adjustTypeInfo,
- labelVarsWithTypes,
- uniqueTypeIndices,
- genEquations
- ) where
+ ( dispType, adjustTypeInfo, labelVarsWithTypes,uniqueTypeIndices
+ , genEquations
+ ) where
-import Debug.Trace
-import Text.PrettyPrint.HughesPJ
import Control.Monad.State
import Control.Monad.Reader
+import qualified Data.IntMap as IntMap
import Data.Maybe
-import qualified Data.IntMap as IntMap
+import Text.PrettyPrint.HughesPJ
import Curry.ExtendedFlat.Type
import Curry.ExtendedFlat.Goodies
+-- import Debug.Trace
-trace' msg x = x -- trace msg x
+trace' :: String -> b -> b
+trace' _ x = x
+-- trace' = trace
--- | For every identifier that occurs in the right hand side
--- of a declaration, the polymorphic type variables in its
--- type label are replaced by concrete types.
+{- |For every identifier that occurs in the right hand side of a declaration,
+ the polymorphic type variables in its type label are replaced by concrete
+ types. -}
adjustTypeInfo :: Prog -> Prog
-adjustTypeInfo = genEquations .
- uniqueTypeIndices .
- labelVarsWithTypes
+adjustTypeInfo = genEquations . uniqueTypeIndices . labelVarsWithTypes
--- | Displays a TypeExpr as a string
+-- |Displays a 'TypeExpr' as a 'String'
dispType :: TypeExpr -> String
dispType = render . prettyType
prettyType :: TypeExpr -> Doc
-prettyType (TVar i) = text ('t':show i)
+prettyType (TVar i) = text ('t':show i)
prettyType (FuncType f x) = parens (prettyType f) <+> text "->" <+> prettyType x
-prettyType (TCons qn ts) = let n = let (m,l) = qnOf qn in m ++ '.' : l
- in text n <+> hsep (map (parens . prettyType) ts)
-
-prettyAllEqns = render . prettyEqns
- where
- prettyEqn ::(TVarIndex, TypeExpr) -> Doc
- prettyEqn (l, r) = char 't' <> int l <+> text "->" <+> prettyType r
+prettyType (TCons qn ts) = let n = let (m,l) = qnOf qn in m ++ '.' : l
+ in text n <+> hsep (map (parens . prettyType) ts)
- prettyEqns ((m,l), t, eqns)
- = text m <> char '.' <> text l <+> text "::" <+> prettyType t <> char ':'
- $$ nest 5 (vcat (map prettyEqn eqns))
+prettyAllEqns :: ((String, String), TypeExpr, [(TVarIndex, TypeExpr)]) -> String
+prettyAllEqns = render . prettyEqns where
+ prettyEqn ::(TVarIndex, TypeExpr) -> Doc
+ prettyEqn (l, r) = char 't' <> int l <+> text "->" <+> prettyType r
+ prettyEqns ((m,l), t, eqns)
+ = text m <> char '.' <> text l <+> text "::" <+> prettyType t <> char ':'
+ $$ nest 5 (vcat (map prettyEqn eqns))
postOrderExpr :: Monad m => (Expr -> m Expr) -> Expr -> m Expr
postOrderExpr f = po
@@ -81,9 +75,6 @@
poBranch (Branch p rhs) = do rhs' <- po rhs
return (Branch p rhs')
-
-
-
postOrderType :: Monad m => (TypeExpr -> m TypeExpr) -> TypeExpr -> m TypeExpr
postOrderType f = po
where po e@(TVar _) = f e
@@ -93,13 +84,11 @@
po (TCons qn ts) = do ts' <- mapM po ts
f (TCons qn ts')
-
visitTVars :: Monad m => (TVarIndex -> m TypeExpr) -> TypeExpr -> m TypeExpr
visitTVars f = postOrderType f'
where f' (TVar i) = f i
f' t = return t
-
-- ----------------------------------------------------------------------
-- ----------------------------------------------------------------------
@@ -109,14 +98,14 @@
-- labelled with new type variables
labelVarsWithTypes :: Prog -> Prog
labelVarsWithTypes = updProgFuncs updateFunc
- where
- updateFunc = map (\func -> let maxtvi = maxFuncTV func + 1
+ where
+ updateFunc = map (\func -> let maxtvi = maxFuncTV func + 1
in trFunc (foo maxtvi) func)
- foo maxtv qn arity visty te r@(External _) = Func qn arity visty te r
- foo maxtv qn arity visty te r@(Rule vs expr)
+ foo _ qn arity visty te r@(External _) = Func qn arity visty te r
+ foo maxtv qn arity visty te (Rule vs expr)
= let expr' = evalState (runReaderT (withVS vs (po expr)) typeMap) maxtv
- typeMap = trace' (show argTypes) $ IntMap.fromList argTypes
- argTypes = [ (vi, t) | VarIndex (Just t) vi <- vs ]
+ typeMap = trace' (show argTypes') $ IntMap.fromList argTypes'
+ argTypes' = [ (vi, t) | VarIndex (Just t) vi <- vs ]
in Func qn arity visty te (Rule vs expr')
po :: Expr -> TDictM Expr
@@ -138,7 +127,7 @@
= do es' <- mapM po es
n' <- poQName n
return (Comb t n' es')
- po (Free vs e)
+ po (Free vs e)
= do vs' <- mapM poVarIndex vs
e' <- po e
return (Free vs' e')
@@ -156,12 +145,12 @@
return (Case p t e' bs')
poBranch :: BranchExpr -> TDictM BranchExpr
- poBranch (Branch (Pattern qn vs) rhs)
+ poBranch (Branch (Pattern qn vs) rhs)
= do qn' <- poQName qn
vs' <- mapM poVarIndex vs
withVS vs' (do rhs' <- po rhs
return (Branch (Pattern qn' vs') rhs'))
- poBranch (Branch (LPattern l) e)
+ poBranch (Branch (LPattern l) e)
= do rhs' <- po e
return (Branch (LPattern l) rhs')
@@ -172,7 +161,7 @@
poQName :: QName -> TDictM QName
poQName qn
- = do t <- maybe (lift$freshTVar)
+ = do t <- maybe (lift$freshTVar)
return . typeofQName $ qn
return qn{typeofQName = Just t }
@@ -207,11 +196,11 @@
relabelTypes (Case p t e bs)
= do bs' <- mapM relabelPatType bs
return (Case p t e bs')
- where relabelPatType (Branch (Pattern qn vis) e)
+ where relabelPatType (Branch (Pattern qn vis) e')
= do t' <- case typeofQName qn of
Just lt -> relabelType lt
Nothing -> freshTVar
- return (Branch (Pattern qn {typeofQName = Just t'} vis) e)
+ return (Branch (Pattern qn {typeofQName = Just t'} vis) e')
relabelPatType be = return be
relabelTypes t = return t
@@ -220,13 +209,13 @@
where typeFoo i = do m <- get
case IntMap.lookup i m of
Just v -> return v
- Nothing -> do v <- lift freshTVar
+ Nothing -> do v <- lift freshTVar
modify (IntMap.insert i v)
return v
-- ----------------------------------------------------------------------
--- ----------------------------------------------------------------------
+-- ----------------------------------------------------------------------
type TypeMap = IntMap.IntMap TypeExpr
@@ -236,30 +225,30 @@
-- | Specialises all type variables (part of adjustTypeInfo)
genEquations :: Prog -> Prog
genEquations = updProgFuncs updateFunc
- where
- updateFunc = map (\func -> let maxtvi = maxFuncTV func + 1
+ where
+ updateFunc = map (\func -> let maxtvi = maxFuncTV func + 1
in trFunc (foo maxtvi) func)
- foo maxtv qn arity visty te r@(External _) = Func qn arity visty te r
- foo maxtv qn arity visty te r@(Rule vs expr)
- = let h = evalState (execStateT (do argTypes <- mapM varIndexType vs
+ foo _ qn arity visty te r@(External _) = Func qn arity visty te r
+ foo maxtv qn arity visty te (Rule vs expr)
+ = let h = evalState (execStateT (do argTypes' <- mapM varIndexType vs
etype <- equations expr
qnt <- qnType qn
- qnt =:= foldr FuncType etype argTypes
+ _ <- qnt =:= foldr FuncType etype argTypes'
return()
) IntMap.empty) maxtv
in trace' (prettyAllEqns (qnOf qn,te,IntMap.toList h)) Func qn arity visty (specialiseType h te) (specInRule h (Rule vs expr))
-
+
equations :: Expr -> EqnMonad TypeExpr
equations = trExpr varIndexType (return . typeofLiteral) combEqn letEqn frEqn orEqn casEqn branchEqn
where
combEqn :: (CombType -> QName -> [EqnMonad TypeExpr] -> EqnMonad TypeExpr)
combEqn _ qn args
- = do resultType <- lift$freshTVar
- argTypes <- sequence args
+ = do resultType' <- lift$freshTVar
+ argTypes' <- sequence args
tqn <- qnType qn
- tqn =:= foldr FuncType resultType argTypes
- return resultType
+ _ <- tqn =:= foldr FuncType resultType' argTypes'
+ return resultType'
letEqn :: ([(VarIndex, EqnMonad TypeExpr)] -> EqnMonad TypeExpr -> EqnMonad TypeExpr)
letEqn bs = (mapM_ bindEqn bs >>)
@@ -287,8 +276,8 @@
unifLhs scrt (Pattern qn vs)
= do qnt <- qnType qn
-- FIXME: Variablentypen in Map eintragen!!!
- argTypes <- mapM varIndexType vs
- qnt =:= foldr FuncType scrt argTypes
+ argTypes' <- mapM varIndexType vs
+ qnt =:= foldr FuncType scrt argTypes'
branchEqn :: Pattern -> EqnMonad TypeExpr -> EqnMonad (Pattern, TypeExpr)
@@ -305,7 +294,7 @@
-- t =:= u = return t
unify (TVar i) t tm
- | Just s <- IntMap.lookup i tm
+ | Just s <- IntMap.lookup i tm
= unify s t tm
unify s (TVar j) tm
| Just t <- IntMap.lookup j tm
@@ -339,7 +328,7 @@
qnType :: QName -> EqnMonad TypeExpr
qnType = maybe (lift$freshTVar) return . typeofQName
-
+
freshTVar :: MonadState Int m => m TypeExpr
freshTVar = do nextIdx <- get
modify succ
@@ -348,8 +337,9 @@
---------------------------------------------------------------------
+maxFuncTV :: FuncDecl -> TVarIndex
maxFuncTV = trFunc (\qn _ _ te r -> max (maxQNameTV qn) (max (maxTypeTV te) (maxRuleTV r)))
- where
+ where
maxRuleTV = trRule (\vis e -> maximum (maxExprTV e : map maxVarIndexTV vis)) (const (-1))
maxExprTV :: Expr -> Int
@@ -379,7 +369,7 @@
specialiseType :: TypeMap -> TypeExpr -> TypeExpr
specialiseType m t = trTypeExpr (foo m) TCons FuncType t
- where foo m i = maybe (TVar i) (specialiseType m) (IntMap.lookup i m)
+ where foo m' i = maybe (TVar i) (specialiseType m') (IntMap.lookup i m')
-- boilerplate
@@ -394,7 +384,7 @@
where specInExpr
= trExpr var Lit comb letexp free Or Case alt
var = Var . specInVarIndex
- comb ct
+ comb ct
= Comb ct . specInQName
letexp
= Let . map specInBind
diff --git a/Curry/ExtendedFlat/UnMutual.hs b/Curry/ExtendedFlat/UnMutual.hs
--- a/Curry/ExtendedFlat/UnMutual.hs
+++ b/Curry/ExtendedFlat/UnMutual.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE DoRec #-}
{-
Turns mutually recursive declarations into a single recursive
@@ -31,8 +31,8 @@
unMutualProg :: Prog -> Prog
-unMutualProg p = evalState (updProgFuncsM
- (\fdecl -> do
+unMutualProg p = evalState (updProgFuncsM
+ (\fdecl -> do
modify (\st -> st { localCounter = (maximum . map idxOf . allVarsInFunc) fdecl})
updFuncLetsM rmMutualRecursion fdecl)
p) (UnMutualState 1000)
@@ -42,8 +42,9 @@
| allWhnf bs || length bs <= 1
= return (Let bs body)
| otherwise
- = mdo (body', bound, fbs) <- partitionBinds (fvs body) sccs (body, mkTuple fbs, [])
- mkSingleLet body' bound fbs
+ = do
+ rec (body', bound, fbs) <- partitionBinds (fvs body) sccs (body, mkTuple fbs, [])
+ mkSingleLet body' bound fbs
where fvsGraph = depGraph bs
sccs = sortSccs fvsGraph
@@ -69,7 +70,7 @@
nonrecLet :: VarIndex -> Expr -> Expr -> UnMutualMonad Expr
nonrecLet x e1 e2
- | x `elem` allVars e1
+ | x `elem` allVars e1
= do vi <- newLocalName (typeofVar x)
let e2' = subst x (Var vi) e2
return (Let [(vi,e1)] e2')
@@ -128,7 +129,7 @@
by declarations that are needed to define the feedback vriables, and the set of feedback
identifiers is the complete feedback set:
-}
-partitionBinds :: [VarIndex] -> [SCC FvsNode]
+partitionBinds :: [VarIndex] -> [SCC FvsNode]
-> (Expr, Expr, [VarIndex])
-> UnMutualMonad (Expr, Expr, [VarIndex])
@@ -170,7 +171,7 @@
pickFbNode :: [VarIndex] -> [FvsNode] -> (Bind, [FvsNode])
pickFbNode pull defs = (b, d)
- where
+ where
ds = [x | (_, x, _) <- defs]
(b, y, _) = maximumBy (compare `on` weight pull ds) defs
d = [ n | n@(_, x, _) <- defs, x /= y]
@@ -218,8 +219,8 @@
po e@(Free vs e')
| v `elem` vs = e
| otherwise = Free vs (po e')
- po e@(Let bs e')
- | lookup v bs == Nothing
+ po e@(Let bs e')
+ | lookup v bs == Nothing
= Let (map poBind bs) (po e')
| otherwise = e
po (Or l r) = Or (po l) (po r)
@@ -228,7 +229,7 @@
poBranch e@(Branch p rhs)
| v `elem` trPattern (\_ args -> args) (const []) p
= e
- | otherwise
+ | otherwise
= Branch p (po rhs)
diff --git a/Curry/Files/Filenames.hs b/Curry/Files/Filenames.hs
--- a/Curry/Files/Filenames.hs
+++ b/Curry/Files/Filenames.hs
@@ -8,75 +8,132 @@
(c) 2009, Holger Siegel.
-}
-module Curry.Files.Filenames where
+module Curry.Files.Filenames
+ (
+ -- * Special directories
+ currySubdir
-import System.FilePath
+ -- * Common file name extensions
+ , curryExt, lcurryExt, icurryExt
+ , flatExt, extFlatExt, flatIntExt, xmlExt
+ , acyExt, uacyExt
+ , sourceRepExt, oExt, debugExt
+ , sourceExts, moduleExts, objectExts
--- Various filename extensions
-curryExt, lcurryExt, icurryExt, oExt :: String
+ -- * Functions for computing file names
+ , interfName, flatName, extFlatName, flatIntName, xmlName
+ , acyName, uacyName
+ , sourceRepName, objectName
+ ) where
+
+import System.FilePath (replaceExtension)
+
+-- |The hidden subdirectory to hide curry files
+currySubdir :: String
+currySubdir = ".curry"
+
+-- |Filename extension for non-literate curry files
+curryExt :: String
curryExt = ".curry"
+-- |Filename extension for literate curry files
+lcurryExt :: String
lcurryExt = ".lcurry"
+-- |Filename extension for curry interface files
+icurryExt :: String
icurryExt = ".icurry"
+-- |Filename extension for flat-curry files
+flatExt :: String
flatExt = ".fcy"
+-- |Filename extension for extended-flat-curry files
+extFlatExt :: String
extFlatExt = ".efc"
+-- |Filename extension for extended-flat-curry interface files
+flatIntExt :: String
flatIntExt = ".fint"
--- fintExt = ".fint"
+-- |Filename extension for extended-flat-curry xml files
+xmlExt :: String
xmlExt = "_flat.xml"
+-- |Filename extension for abstract-curry files
+acyExt :: String
acyExt = ".acy"
+-- |Filename extension for untyped-abstract-curry files
+uacyExt :: String
uacyExt = ".uacy"
+-- |Filename extension for curry source representation files
+sourceRepExt :: String
sourceRepExt = ".cy"
+-- |Filename extension for object files
+oExt :: String
oExt = ".o"
+-- |Filename extension for debug object files
+debugExt :: String
debugExt = ".d.o"
-sourceExts, moduleExts, objectExts :: [String]
-sourceExts = [curryExt,lcurryExt]
+-- |Filename extension for curry source files
+sourceExts :: [String]
+sourceExts = [curryExt, lcurryExt]
+
+-- |Filename extension for curry module files
+moduleExts :: [String]
moduleExts = sourceExts ++ [icurryExt]
+
+-- |Filename extension for object files
+objectExts :: [String]
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.
--}
+{- ---------------------------------------------------------------------------
+ Computation of file names for a given source file
+--------------------------------------------------------------------------- -}
+-- |Compute the filename of the interface file for a source file
interfName :: FilePath -> FilePath
-interfName sfn = replaceExtension sfn icurryExt
-
+interfName = replaceWithExtension icurryExt
+-- |Compute the filename of the flat curry file for a source file
flatName :: FilePath -> FilePath
-flatName fn = replaceExtension fn flatExt
+flatName = replaceWithExtension flatExt
+-- |Compute the filename of the extended flat curry file for a source file
extFlatName :: FilePath -> FilePath
-extFlatName fn = replaceExtension fn extFlatExt
+extFlatName = replaceWithExtension extFlatExt
+-- |Compute the filename of the flat curry interface file for a source file
flatIntName :: FilePath -> FilePath
-flatIntName fn = replaceExtension fn flatIntExt
+flatIntName = replaceWithExtension flatIntExt
+-- |Compute the filename of the flat curry xml file for a source file
xmlName :: FilePath -> FilePath
-xmlName fn = replaceExtension fn xmlExt
+xmlName = replaceWithExtension xmlExt
+-- |Compute the filename of the abstract curry file for a source file
acyName :: FilePath -> FilePath
-acyName fn = replaceExtension fn acyExt
+acyName = replaceWithExtension acyExt
+-- |Compute the filename of the untyped abstract curry file for a source file
uacyName :: FilePath -> FilePath
-uacyName fn = replaceExtension fn uacyExt
+uacyName = replaceWithExtension uacyExt
+-- |Compute the filename of the source representation file for a source file
sourceRepName :: FilePath -> FilePath
-sourceRepName fn = replaceExtension fn sourceRepExt
+sourceRepName = replaceWithExtension sourceRepExt
+{- |Compute the filename of the object file for a source file.
+ If the first parameter is 'True', the debug object file name is returned
+-}
objectName :: Bool -> FilePath -> FilePath
-objectName debug = name (if debug then debugExt else oExt)
- where name ext fn = replaceExtension fn ext
+objectName debug = replaceWithExtension (if debug then debugExt else oExt)
+
+-- |Replace a filename extension with a new extension
+replaceWithExtension :: String -> FilePath -> FilePath
+replaceWithExtension = flip replaceExtension
diff --git a/Curry/Files/PathUtils.hs b/Curry/Files/PathUtils.hs
--- a/Curry/Files/PathUtils.hs
+++ b/Curry/Files/PathUtils.hs
@@ -5,129 +5,157 @@
See LICENSE for the full license.
-}
-module Curry.Files.PathUtils(-- re-exports from System.FilePath:
- takeBaseName,
- dropExtension,
- takeExtension,
+module Curry.Files.PathUtils
+ ( -- * Re-exports from 'System.FilePath'
+ takeBaseName, dropExtension, takeExtension, takeFileName
- lookupModule, lookupFile, lookupInterface,
- getCurryPath,
- writeModule,readModule,
- doesModuleExist,maybeReadModule,getModuleModTime) where
+ -- * Retrieving curry fiiles
+ , lookupModule, lookupFile, lookupInterface, getCurryPath
+ -- * Reading and writing modules from files
+ , writeModule, readModule, maybeReadModule
+ , doesModuleExist, getModuleModTime
+ ) where
+
+import Control.Monad (liftM)
import System.FilePath
import System.Directory
import System.Time (ClockTime)
-import Control.Monad (unless, liftM)
-
import Curry.Base.Ident
import Curry.Files.Filenames
-lookupModule :: [FilePath] -> [FilePath] -> ModuleIdent
- -> IO (Maybe FilePath)
-lookupModule paths libraryPaths m
- = lookupFile ("" : paths ++ libraryPaths) moduleExts fn
- where fn = foldr1 catPath (moduleQualifiers m)
+{- |Search for a given curry module in the given source file paths and
+ library paths. Note that the current directory is always searched first.
+-}
+lookupModule :: [FilePath] -- ^ list of paths to source files
+ -> [FilePath] -- ^ list of paths to library files
+ -> ModuleIdent -- ^ module identifier
+ -> IO (Maybe FilePath) -- ^ the file path if found
+lookupModule paths libPaths m =
+ lookupFile ("" : paths ++ libPaths) moduleExts fn
+ where fn = foldr1 combine (moduleQualifiers m)
-catPath :: FilePath -> FilePath -> FilePath
-catPath = combine
-{-
- 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.
+{- |Search for an interface file in the import search path using the
+ interface extension 'flatIntExt'. Note that the current directory is
+ always searched first.
-}
+lookupInterface :: [FilePath] -- ^ list of paths to search in
+ -> ModuleIdent -- ^ module identifier
+ -> IO (Maybe FilePath) -- ^ the file path if found
+lookupInterface paths m = lookupFile ("" : paths) [flatIntExt] ifn
+ where ifn = foldr1 combine (moduleQualifiers m)
-lookupInterface :: [FilePath] -> ModuleIdent -> IO (Maybe FilePath)
-lookupInterface ps m = lookupFile ("":ps) [flatIntExt] ifn
- where ifn = foldr1 catPath (moduleQualifiers m)
-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:ps)
- = do so <- doesFileExist fn
- if so then return (Just fn) else lookupFile' ps
+-- |Search for a source file name and eventually return its content
+lookupFile :: [FilePath] -- ^ list of file paths to search in
+ -> [String] -- ^ list of possible extensions of the file
+ -> String -- ^ initial file name
+ -> IO (Maybe FilePath) -- ^ the file path if found
+lookupFile paths exts file = lookupFile' paths' where
+ paths' = do
+ p <- paths
+ e <- exts
+ let fn = p `combine` replaceExtension file e
+ [fn, ensureCurrySubdir fn]
+ lookupFile' [] = return Nothing
+ lookupFile' (fn:ps) = do
+ so <- doesFileExist fn
+ if so then return (Just fn) else lookupFile' ps
+{- | Search in the given list of paths for the given file name. If the file
+ name has no extension then source file extension is assumed. If the file
+ name already contains a directory than the paths to search in are
+ ignored.
+-}
+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
--- add a subdirectory to a given filename
--- if it is not already present
---
--- missing case: inSubdir ""
-inSubdir :: FilePath -> FilePath -> FilePath
-inSubdir sub fn = joinPath $ add (splitDirectories fn)
- where
- add ps@[_] = sub:ps
- add ps@[p,_] | p==sub = ps
- add (p:ps) = p:add ps
- add [] = error "inSubdir: called with empty path"
+-- Writing and reading files
---The sub directory to hide files in:
+{- | Write the content to a file in the given directory or in the
+ 'currySubdir' sub-directory if the first parameter is set to 'True'.
+-}
+writeModule :: Bool -- ^ should the 'currySubdir' be included in the path?
+ -> FilePath -- ^ original path
+ -> String -- ^ file content
+ -> IO ()
+writeModule inSubdir filename contents = do
+ let fn = if inSubdir then ensureCurrySubdir filename else filename
+ createDirectoryIfMissing True $ takeDirectory fn
+ writeFile fn contents
-currySubdir :: String
-currySubdir = ".curry"
-inCurrySubdir :: FilePath -> FilePath
-inCurrySubdir = inSubdir currySubdir
-
---write a file to curry subdirectory
-
-writeModule :: Bool -> FilePath -> String -> IO ()
-writeModule inHiddenSubdir filename contents = do
- let filename' | inHiddenSubdir = inCurrySubdir filename
- | otherwise = 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
-
+{- | Read the content from a file in the given directory or in the
+ 'currySubdir' sub-directory of the given sub-directory.
+-}
readModule :: FilePath -> IO String
readModule = onExistingFileDo readFile
+
+{- | Tries to read the specified module and returns either 'Just String' if
+ reading was successful or 'Nothing' otherwise.
+-}
maybeReadModule :: FilePath -> IO (Maybe String)
-maybeReadModule filename =
- catch (liftM Just (readModule filename)) (\_ -> return Nothing)
+maybeReadModule filename =
+ catch (liftM Just (readModule filename)) (\ _ -> return Nothing)
+
+{- | Check whether a module exists either in the given directory or in the
+ 'currySubdir'.
+-}
doesModuleExist :: FilePath -> IO Bool
doesModuleExist = onExistingFileDo doesFileExist
+
+-- | Get the modification time of a file
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.
+-- Helper functions
+
+
+{- | Ensure that the 'currySubdir' is the last component of the
+ directory structure of the given 'FilePath'. If the 'FilePath' already
+ contains the 'currySubdir' it remains unchanged.
-}
-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
+ensureCurrySubdir :: FilePath -> FilePath
+ensureCurrySubdir = ensureSubdir currySubdir
+
+{- | Ensure that the given sub-directory is the last component of the
+ directory structure of the given 'FilePath'. If the 'FilePath' already
+ contains the sub-directory it remains unchanged.
+-}
+ensureSubdir :: String -- ^ sub-directory to add
+ -> FilePath -- ^ original 'FilePath'
+ -> FilePath -- ^ original 'FilePath'
+ensureSubdir subdir file
+ = replaceDirectory file
+ $ addSub (splitDirectories $ takeDirectory file) subdir where
+ addSub :: [String] -> String -> String
+ addSub [] sub = sub
+ addSub ds sub
+ | last ds == sub = joinPath ds
+ | otherwise = joinPath ds sub
+
+
+{- | Perform an action on a file either in the given directory or else in the
+ 'currySubdir' sub-directory.
+-}
+onExistingFileDo :: (FilePath -> IO a) -> FilePath -> IO a
+onExistingFileDo act filename = do
+ ex <- doesFileExist filename
+ if ex then act filename
+ else act $ ensureCurrySubdir filename
diff --git a/Curry/FlatCurry/Goodies.hs b/Curry/FlatCurry/Goodies.hs
--- a/Curry/FlatCurry/Goodies.hs
+++ b/Curry/FlatCurry/Goodies.hs
@@ -1,5 +1,5 @@
----------------------------------------------------------------------------
---- This library provides selector functions, test and update operations
+--- This library provides selector functions, test and update operations
--- as well as some useful auxiliary functions for FlatCurry data terms.
--- Most of the provided functions are based on general transformation
--- functions that replace constructors with user-defined
@@ -8,7 +8,7 @@
--- transformations on FlatCurry terms,
--- so the provided functions can be used to implement specific transformations
--- without having to explicitly state the recursion. Essentially, the tedious
---- part of such transformations - descend in fairly complex term structures -
+--- part of such transformations - descend in fairly complex term structures -
--- is abstracted away, which hopefully makes the code more clear and brief.
---
--- @author Sebastian Fischer
@@ -107,7 +107,7 @@
--- update all qualified names in program
updQNamesInProg :: Update Prog QName
-updQNamesInProg f = updProg id id
+updQNamesInProg f = updProg id id
(map (updQNamesInType f)) (map (updQNamesInFunc f)) (map (updOpName f))
--- rename program (update name of and all qualified names in program)
@@ -196,7 +196,7 @@
--- update all qualified names in type declaration
updQNamesInType :: Update TypeDecl QName
-updQNamesInType f
+updQNamesInType f
= updType f id id (map (updQNamesInConsDecl f)) (updQNamesInTypeExpr f)
-- ConsDecl ------------------------------------------------------------------
@@ -263,29 +263,39 @@
--- get index from type variable
tVarIndex :: TypeExpr -> TVarIndex
tVarIndex (TVar n) = n
+tVarIndex _ = error $ "Curry.FlatCurry.Goodies.tvarIndex: " ++
+ "no type variable"
--- get domain from functional type
domain :: TypeExpr -> TypeExpr
domain (FuncType dom _) = dom
+domain _ = error $ "Curry.FlatCurry.Goodies.domain: " ++
+ "no function type"
--- get range from functional type
range :: TypeExpr -> TypeExpr
range (FuncType _ ran) = ran
+range _ = error $ "Curry.FlatCurry.Goodies.range: " ++
+ "no function type"
--- get name from constructed type
tConsName :: TypeExpr -> QName
tConsName (TCons name _) = name
+tConsName _ = error $ "Curry.FlatCurry.Goodies.tConsName: " ++
+ "no constructor type"
--- get arguments from constructed type
tConsArgs :: TypeExpr -> [TypeExpr]
tConsArgs (TCons _ args) = args
+tConsArgs _ = error $ "Curry.FlatCurry.Goodies.tConsArgs: " ++
+ "no constructor type"
--- transform type expression
trTypeExpr :: (TVarIndex -> a) ->
(QName -> [a] -> a) ->
(a -> a -> a) -> TypeExpr -> a
trTypeExpr tvar _ _ (TVar n) = tvar n
-trTypeExpr tvar tcons functype (TCons name args)
+trTypeExpr tvar tcons functype (TCons name args)
= tcons name (map (trTypeExpr tvar tcons functype) args)
trTypeExpr tvar tcons functype (FuncType from to) = functype (f from) (f to)
where
@@ -333,7 +343,7 @@
resultType (TCons name args) = TCons name args
resultType (FuncType _ ran) = resultType ran
---- get indexes of all type variables
+--- get indexes of all type variables
allVarsInTypeExpr :: TypeExpr -> [TVarIndex]
allVarsInTypeExpr = trTypeExpr (:[]) (const concat) (++)
@@ -424,8 +434,8 @@
(TypeExpr -> TypeExpr) ->
(Rule -> Rule) -> FuncDecl -> FuncDecl
updFunc fn fa fv ft fr = trFunc func
- where
- func name arity vis t rule
+ where
+ func name arity vis t rule
= Func (fn name) (fa arity) (fv vis) (ft t) (fr rule)
--- update name of function
@@ -470,7 +480,7 @@
funcRHS f | not (isExternal f) = orCase (funcBody f)
| otherwise = []
where
- orCase e
+ orCase e
| isOr e = concatMap orCase (orExps e)
| isCase e = concatMap orCase (map branchExpr (caseBranches e))
| otherwise = [e]
@@ -510,7 +520,7 @@
--- get rules external declaration
ruleExtDecl :: Rule -> String
-ruleExtDecl = trRule failed id
+ruleExtDecl = trRule failed id
-- Test Operations
@@ -594,22 +604,30 @@
--- get internal number of variable
varNr :: Expr -> VarIndex
varNr (Var n) = n
+varNr _ = error "Curry.FlatCurry.Goodies.varNr: no variable"
--- get literal if expression is literal expression
literal :: Expr -> Literal
literal (Lit l) = l
+literal _ = error "Curry.FlatCurry.Goodies.literal: no literal"
--- get combination type of a combined expression
combType :: Expr -> CombType
combType (Comb ct _ _) = ct
+combType _ = error $ "Curry.FlatCurry.Goodies.combType: " ++
+ "no combined expression"
--- get name of a combined expression
combName :: Expr -> QName
combName (Comb _ name _) = name
+combName _ = error $ "Curry.FlatCurry.Goodies.combName: " ++
+ "no combined expression"
--- get arguments of a combined expression
combArgs :: Expr -> [Expr]
combArgs (Comb _ _ args) = args
+combArgs _ = error $ "Curry.FlatCurry.Goodies.combArgs: " ++
+ "no combined expression"
--- get number of missing arguments if expression is combined
missingCombArgs :: Expr -> Int
@@ -618,40 +636,57 @@
--- get indices of varoables in let declaration
letBinds :: Expr -> [(VarIndex,Expr)]
letBinds (Let vs _) = vs
+letBinds _ = error $ "Curry.FlatCurry.Goodies.letBinds: " ++
+ "no let expression"
--- get body of let declaration
letBody :: Expr -> Expr
letBody (Let _ e) = e
+letBody _ = error $ "Curry.FlatCurry.Goodies.letBody: " ++
+ "no let expression"
--- get variable indices from declaration of free variables
freeVars :: Expr -> [VarIndex]
freeVars (Free vs _) = vs
+freeVars _ = error $ "Curry.FlatCurry.Goodies.freeVars: " ++
+ "no declaration of free variables"
--- get expression from declaration of free variables
freeExpr :: Expr -> Expr
freeExpr (Free _ e) = e
+freeExpr _ = error $ "Curry.FlatCurry.Goodies.freeExpr: " ++
+ "no declaration of free variables"
--- get expressions from or-expression
orExps :: Expr -> [Expr]
orExps (Or e1 e2) = [e1,e2]
+orExps _ = error $ "Curry.FlatCurry.Goodies.orExps: " ++
+ "no or expression"
--- get case-type of case expression
caseType :: Expr -> CaseType
caseType (Case ct _ _) = ct
+caseType _ = error $ "Curry.FlatCurry.Goodies.caseType: " ++
+ "no case expression"
--- get scrutinee of case expression
caseExpr :: Expr -> Expr
caseExpr (Case _ e _) = e
+caseExpr _ = error $ "Curry.FlatCurry.Goodies.caseExpr: " ++
+ "no case expression"
+
--- get branch expressions from case expression
caseBranches :: Expr -> [BranchExpr]
caseBranches (Case _ _ bs) = bs
+caseBranches _ = error
+ "Curry.FlatCurry.Goodies.caseBranches: no case expression"
-- Test Operations
--- is expression a variable?
isVar :: Expr -> Bool
-isVar e = case e of
+isVar e = case e of
Var _ -> True
_ -> False
@@ -708,7 +743,7 @@
= comb ct name (map (trExpr var lit comb lt fr oR cas branch) args)
trExpr var lit comb lt fr oR cas branch (Let bs e)
- = lt (map (\ (n,e) -> (n,f e)) bs) (f e)
+ = lt (map (\ (n,e') -> (n,f e')) bs) (f e)
where
f = trExpr var lit comb lt fr oR cas branch
@@ -720,7 +755,7 @@
f = trExpr var lit comb lt fr oR cas branch
trExpr var lit comb lt fr oR cas branch (Case ct e bs)
- = cas ct (f e) (map (\ (Branch pat e) -> branch pat (f e)) bs)
+ = cas ct (f e) (map (\ (Branch pat e') -> branch pat (f e')) bs)
where
f = trExpr var lit comb lt fr oR cas branch
@@ -778,7 +813,7 @@
--- is expression fully evaluated?
isGround :: Expr -> Bool
-isGround e
+isGround e
= case e of
Comb ConsCall _ args -> all isGround args
_ -> isLit e
@@ -788,10 +823,10 @@
allVars e = trExpr (:) (const id) comb lt fr (.) cas branch e []
where
comb _ _ = foldr (.) id
- lt bs e = e . foldr (.) id (map (\ (n,ns) -> (n:) . ns) bs)
- fr vs e = (vs++) . e
- cas _ e bs = e . foldr (.) id bs
- branch pat e = ((args pat)++) . e
+ lt bs e' = e' . foldr (.) id (map (\ (n,ns) -> (n:) . ns) bs)
+ fr vs e' = (vs++) . e'
+ cas _ e' bs = e' . foldr (.) id bs
+ branch pat e' = ((args pat)++) . e'
args pat | isConsPattern pat = patArgs pat
| otherwise = []
@@ -857,7 +892,7 @@
patArgs :: Pattern -> [VarIndex]
patArgs = trPattern (\_ args -> args) failed
---- get literal from literal pattern
+--- get literal from literal pattern
patLiteral :: Pattern -> Literal
patLiteral = trPattern failed id
diff --git a/Curry/FlatCurry/Tools.hs b/Curry/FlatCurry/Tools.hs
--- a/Curry/FlatCurry/Tools.hs
+++ b/Curry/FlatCurry/Tools.hs
@@ -14,9 +14,9 @@
isPublicType, isPublicCons,typeQName,isExternalType,
-- operations on functions:
- funcName, funcArity, funcVisibility, funcType, funcRule,
+ funcName, funcArity, funcVisibility, funcType, funcRule, isPublicFunc,
- updFunc, updFuncName, updFuncArity, updFuncVisibility, updFuncType,
+ updFunc, updFuncName, updFuncArity, updFuncVisibility, updFuncType,
updFuncRule,
funcArgs, funcBody, funcRHS, isExternal, isCombFunc,
@@ -28,13 +28,13 @@
-- operations on function-rules:
isRuleExternal, ruleArgs, ruleBody,
- updRule, updRuleArgs, updRuleBody,
+ updRule, updRuleArgs, updRuleBody, ruleExtDecl, updRuleExtDecl,
rnmAllVarsRule, allVarsRule, updQNamesRule,
-- operations on type-expressions:
isTypeVar, isFuncType, isTypeCons, typeConsName, argTypes, resultType,
- isIOType,typeArity, allTVars,
+ isIOType,typeArity, allTVars,
rnmAllVarsTypeExpr, allTypeCons,
-- operations on expressions:
@@ -56,9 +56,9 @@
updBranch, updBranchPattern, updBranchExpr,
- patCons, patArgs, patLiteral, patExpr,
+ patCons, patArgs, patLiteral, patExpr, updPatArgs, updPatLiteral,
- rnmAllVarsBranch, allVarsBranch,
+ rnmAllVarsBranch, allVarsBranch,
rnmAllVarsPat, allVarsPat,
-- operations on OpDecls
@@ -68,40 +68,44 @@
import Data.Maybe
-import Data.Char
-import Data.List
import Curry.FlatCurry.Type
-infixr 5 -:-
-
--- variant of zipWith for lists of same length
-zipWith' _ [] [] = []
-zipWith' f (x:xs) (y:ys) = f x y : zipWith' f xs ys
-
-- auxiliary functions -------------------------------------------------------
-x -:- xs = Comb ConsCall ("Prelude",":") [x,xs]
-nil = Comb ConsCall ("Prelude","[]") []
-
-char_ :: Char -> Expr
-char_ c = Lit (Charc c)
-
-int_ :: Integer -> Expr
-int_ n = Lit (Intc n)
-
-float_ :: Double -> Expr
-float_ f = Lit (Floatc f)
-
-list_ :: [Expr] -> Expr
-list_ [] = nil
-list_ (x:xs) = x -:- list_ xs
+-- infixr 5 -:-
-string_ :: String -> Expr
-string_ = list_ . map char_
+-- (-:-) :: Expr -> Expr -> Expr
+-- x -:- xs = Comb ConsCall ("Prelude",":") [x,xs]
+--
+-- nil :: Expr
+-- nil = Comb ConsCall ("Prelude","[]") []
+--
+-- char_ :: Char -> Expr
+-- char_ c = Lit (Charc c)
+--
+-- int_ :: Integer -> Expr
+-- int_ n = Lit (Intc n)
+--
+-- float_ :: Double -> Expr
+-- float_ f = Lit (Floatc f)
+--
+-- list_ :: [Expr] -> Expr
+-- list_ [] = nil
+-- list_ (x:xs) = x -:- list_ xs
+--
+-- string_ :: String -> Expr
+-- string_ = list_ . map char_
-- Prog ----------------------------------------------------------------------
+updProg :: (String -> String)
+ -> ([String] -> [String])
+ -> ([TypeDecl] -> [TypeDecl])
+ -> ([FuncDecl] -> [FuncDecl])
+ -> ([OpDecl] -> [OpDecl])
+ -> Prog
+ -> Prog
updProg fn fi ft ff fo (Prog name imps types funcs ops)
= Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops)
@@ -159,15 +163,15 @@
--- update all qualified names in program
updQNamesProg :: (QName -> QName) -> Prog -> Prog
-updQNamesProg f
+updQNamesProg f
= updProg id id (map (updQNamesType f)) (map (updQNamesFunc f))
(map (\ (Op name fix prec) -> Op (f name) fix prec))
rnmProg :: String -> Prog -> Prog
rnmProg name p = updProgName (const name) (updQNamesProg rnm p)
where
- rnm (mod,n) | mod==progName p = (name,n)
- | otherwise = (mod,n)
+ rnm (modul,n) | modul == progName p = (name,n)
+ | otherwise = (modul,n)
-- TypeDecl ------------------------------------------------------------------
@@ -178,17 +182,17 @@
allConstructors (Type _ _ _ cs) = cs
--- select name of constructor
-consQName :: ConsDecl -> QName
+consQName :: ConsDecl -> QName
consQName (Cons n _ _ _) = n
-consArity :: ConsDecl -> Int
+consArity :: ConsDecl -> Int
consArity (Cons _ a _ _) = a
--- update all qualified names in type declaration
updQNamesType :: (QName -> QName) -> TypeDecl -> TypeDecl
updQNamesType f (Type name vis vars decls)
= Type (f name) vis vars (map (updQNamesConsDecl f) decls)
-updQNamesType f (TypeSyn name vis vars t)
+updQNamesType f (TypeSyn name vis vars t)
= TypeSyn (f name) vis vars (updQNamesTypeExpr f t)
--- update all qualified names in constructor declaration
@@ -220,9 +224,16 @@
typeQName (Type n _ _ _) = n
-
+
-- FuncDecl ------------------------------------------------------------------
+updFunc :: (QName -> QName)
+ -> (Int -> Int)
+ -> (Visibility -> Visibility)
+ -> (TypeExpr -> TypeExpr)
+ -> (Rule -> Rule)
+ -> FuncDecl
+ -> FuncDecl
updFunc fn fa fv ft fr (Func name arity vis t rule)
= Func (fn name) (fa arity) (fv vis) (ft t) (fr rule)
@@ -248,7 +259,7 @@
--- is function public?
isPublicFunc :: FuncDecl -> Bool
-isPublicFunc (Func _ _ vis _ _) = vis==Public
+isPublicFunc (Func _ _ vis _ _) = vis == Public
--- update visibility of function
updFuncVisibility :: (Visibility -> Visibility) -> FuncDecl -> FuncDecl
@@ -296,8 +307,8 @@
funcRHS :: FuncDecl -> Maybe [Expr]
funcRHS = maybe Nothing (Just . unwrapCaseOr) . funcBody
where
- unwrapCaseOr e
- | isCase e
+ unwrapCaseOr e
+ | isCase e
= concatMap unwrapCaseOr (map branchExpr (caseBranches e))
| isOr e = concatMap unwrapCaseOr (orExps e)
| otherwise = [e]
@@ -320,7 +331,7 @@
--- rename all variables in function
rnmAllVarsFunc :: (Int -> Int) -> FuncDecl -> FuncDecl
-rnmAllVarsFunc f (Func name arity vis t rule)
+rnmAllVarsFunc f (Func name arity vis t rule)
= Func name arity vis t (rnmAllVarsRule f rule)
--- get variable names in a function declaration
@@ -329,7 +340,12 @@
-- Rule ----------------------------------------------------------------------
-updRule fa fe _ (Rule args exp) = Rule (fa args) (fe exp)
+updRule :: ([VarIndex] -> [VarIndex])
+ -> (Expr -> Expr)
+ -> (String -> String)
+ -> Rule
+ -> Rule
+updRule fa fe _ (Rule args expr) = Rule (fa args) (fe expr)
updRule _ _ f (External s) = External (f s)
--- is rule an external declaration?
@@ -348,8 +364,8 @@
--- get rules body if it's not external
ruleBody :: Rule -> Maybe Expr
-ruleBody (Rule _ exp) = Just exp
-ruleBody (External _) = Nothing
+ruleBody (Rule _ expr) = Just expr
+ruleBody (External _) = Nothing
--- update rules body
updRuleBody :: (Expr -> Expr) -> Rule -> Rule
@@ -372,13 +388,14 @@
--- rename all variables in rule
rnmAllVarsRule :: (Int -> Int) -> Rule -> Rule
-rnmAllVarsRule f (Rule args body)
+rnmAllVarsRule f (Rule args body)
= Rule (map f args) (rnmAllVars f body)
rnmAllVarsRule _ (External s) = External s
--- get variable names in a functions rule
allVarsRule :: Rule -> [Int]
allVarsRule (Rule args body) = args ++ allVars body
+allVarsRule (External _) = []
-- TypeExpr ------------------------------------------------------------------
@@ -394,7 +411,7 @@
FuncType _ _ -> True
_ -> False
---- compute number of arguments by function type
+--- compute number of arguments by function type
typeArity :: TypeExpr -> Int
typeArity (TVar _) = 0
typeArity (TCons _ _) = 0
@@ -417,7 +434,6 @@
--- get argument types from functional type
argTypes :: TypeExpr -> [TypeExpr]
-
argTypes t = case t of
FuncType dom ran -> dom : argTypes ran
_ -> []
@@ -431,11 +447,12 @@
--- rename variables in type declaration
rnmAllVarsTypeExpr :: (Int -> Int) -> TypeExpr -> TypeExpr
rnmAllVarsTypeExpr f (TVar n) = TVar (f n)
-rnmAllVarsTypeExpr f (TCons name args)
+rnmAllVarsTypeExpr f (TCons name args)
= TCons name (map (rnmAllVarsTypeExpr f) args)
-rnmAllVarsTypeExpr f (FuncType dom ran)
- = FuncType (rnmAllVarsTypeExpr f dom) (rnmAllVarsTypeExpr f ran)
+rnmAllVarsTypeExpr f (FuncType dom ran)
+ = FuncType (rnmAllVarsTypeExpr f dom) (rnmAllVarsTypeExpr f ran)
+allTVars :: TypeExpr -> [TVarIndex]
allTVars (TVar n) = [n]
allTVars (TCons _ args) = concatMap allTVars args
allTVars (FuncType t1 t2) = concatMap allTVars [t1,t2]
@@ -449,22 +466,23 @@
--- update all qualified names in type expression
updQNamesTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr
updQNamesTypeExpr _ (TVar n) = TVar n
-updQNamesTypeExpr f (FuncType dom ran)
+updQNamesTypeExpr f (FuncType dom ran)
= FuncType (updQNamesTypeExpr f dom) (updQNamesTypeExpr f ran)
-updQNamesTypeExpr f (TCons name args)
+updQNamesTypeExpr f (TCons name args)
= TCons (f name) (map (updQNamesTypeExpr f) args)
-- Expr ----------------------------------------------------------------------
--- is expression a variable?
isVar :: Expr -> Bool
-isVar e = case e of
+isVar e = case e of
Var _ -> True
_ -> False
--- get internal number of variable
varNr :: Expr -> Int
varNr (Var n) = n
+varNr _ = error "Curry.FlatCurry.Tools.varNr: no variable"
--- is expression a literal expression?
isLit :: Expr -> Bool
@@ -504,10 +522,10 @@
--- is expression fully evaluated?
isGround :: Expr -> Bool
-isGround exp
- = case exp of
+isGround expr
+ = case expr of
Comb ConsCall _ args -> all isGround args
- _ -> isLit exp
+ _ -> isLit expr
--- get literal if expression is literal expression
literal :: Expr -> Maybe Literal
@@ -524,10 +542,13 @@
--- get expression from declaration of free variables
exprFromFreeDecl :: Expr -> Expr
exprFromFreeDecl (Free _ e) = e
+exprFromFreeDecl _ = error $ "Curry.FlatCurry.Tools." ++
+ "exprFromFreeDecl: no declaration of free variables"
--- get expressions from or-expression
orExps :: Expr -> [Expr]
orExps (Or e1 e2) = [e1,e2]
+orExps _ = error "Curry.FlatCurry.Tools.orExps: no or expression"
-- shortcuts
@@ -545,13 +566,13 @@
--- get name of function if expression is a (maybe partial) function call
combFunc :: Expr -> Maybe QName
-combFunc e
+combFunc e
| isFuncCall e || isPartCall e = let Comb _ name _ = e in Just name
| otherwise = Nothing
--- get name of constructor if expression is a constructor call
combCons :: Expr -> Maybe QName
-combCons e
+combCons e
| isConsCall e = let Comb _ name _ = e in Just name
| otherwise = Nothing
@@ -566,11 +587,15 @@
--- is expression a combined expression with given name?
hasName :: QName -> Expr -> Bool
-hasName name (Comb _ name' _) = name==name'
+hasName name (Comb _ name' _) = name == name'
+hasName _ _ = error $ "Curry.FlatCurry.Tools.hasName: " ++
+ "no combined expression"
--- get branch expressions from case expression
caseBranches :: Expr -> [BranchExpr]
caseBranches (Case _ _ bs) = bs
+caseBranches _ = error $ "Curry.FlatCurry.Tools.caseBranches: " ++
+ "no case expression"
-- auxiliary functions
@@ -581,9 +606,9 @@
rnmAllVars f (Comb ct name args) = Comb ct name (map (rnmAllVars f) args)
rnmAllVars f (Free vs e) = Free (map f vs) (rnmAllVars f e)
rnmAllVars f (Or e1 e2) = Or (rnmAllVars f e1) (rnmAllVars f e2)
-rnmAllVars f (Case ct e bs)
+rnmAllVars f (Case ct e bs)
= Case ct (rnmAllVars f e) (map (rnmAllVarsBranch f) bs)
-rnmAllVars f (Let bs e)
+rnmAllVars f (Let bs e)
= Let (map (\ (n,e') -> (f n,rnmAllVars f e')) bs) (rnmAllVars f e)
--- get all variables (even in patterns) in expression
@@ -603,7 +628,7 @@
mapVar f (Comb ct name args) = Comb ct name (map (mapVar f) args)
mapVar f (Free vs e) = Free vs (mapVar f e)
mapVar f (Or e1 e2) = Or (mapVar f e1) (mapVar f e2)
-mapVar f (Case ct e bs)
+mapVar f (Case ct e bs)
= Case ct (mapVar f e) (map (updBranchExpr (mapVar f)) bs)
mapVar f (Let bs e) = Let (map (\ (n,e') -> (n,mapVar f e')) bs) (mapVar f e)
@@ -614,7 +639,7 @@
mapLit f (Comb ct name args) = Comb ct name (map (mapLit f) args)
mapLit f (Free vs e) = Free vs (mapLit f e)
mapLit f (Or e1 e2) = Or (mapLit f e1) (mapLit f e2)
-mapLit f (Case ct e bs)
+mapLit f (Case ct e bs)
= Case ct (mapLit f e) (map (updBranchExpr (mapLit f)) bs)
mapLit f (Let bs e) = Let (map (\ (n,e') -> (n,mapLit f e')) bs) (mapLit f e)
@@ -625,9 +650,9 @@
mapComb f (Comb ct name args) = f (Comb ct name (map (mapComb f) args))
mapComb f (Free vs e) = Free vs (mapComb f e)
mapComb f (Or e1 e2) = Or (mapComb f e1) (mapComb f e2)
-mapComb f (Case ct e bs)
+mapComb f (Case ct e bs)
= Case ct (mapComb f e) (map (updBranchExpr (mapComb f)) bs)
-mapComb f (Let bs e)
+mapComb f (Let bs e)
= Let (map (\ (n,e') -> (n,mapComb f e')) bs) (mapComb f e)
--- map all free declarations in given expression
@@ -637,9 +662,9 @@
mapFree f (Comb ct name args) = Comb ct name (map (mapFree f) args)
mapFree f (Free vs e) = f (Free vs (mapFree f e))
mapFree f (Or e1 e2) = Or (mapFree f e1) (mapFree f e2)
-mapFree f (Case ct e bs)
+mapFree f (Case ct e bs)
= Case ct (mapFree f e) (map (updBranchExpr (mapFree f)) bs)
-mapFree f (Let bs e)
+mapFree f (Let bs e)
= Let (map (\ (n,e') -> (n,mapFree f e')) bs) (mapFree f e)
--- map all or expressions in given expression
@@ -649,7 +674,7 @@
mapOr f (Comb ct name args) = Comb ct name (map (mapOr f) args)
mapOr f (Free vs e) = Free vs (mapOr f e)
mapOr f (Or e1 e2) = f (Or (mapOr f e1) (mapOr f e2))
-mapOr f (Case ct e bs)
+mapOr f (Case ct e bs)
= Case ct (mapOr f e) (map (updBranchExpr (mapOr f)) bs)
mapOr f (Let bs e) = Let (map (\ (n,e') -> (n,mapOr f e')) bs) (mapOr f e)
@@ -660,9 +685,9 @@
mapCase f (Comb ct name args) = Comb ct name (map (mapCase f) args)
mapCase f (Free vs e) = Free vs (mapCase f e)
mapCase f (Or e1 e2) = Or (mapCase f e1) (mapCase f e2)
-mapCase f (Case ct e bs)
+mapCase f (Case ct e bs)
= f (Case ct (mapCase f e) (map (updBranchExpr (mapCase f)) bs))
-mapCase f (Let bs e)
+mapCase f (Let bs e)
= Let (map (\ (n,e') -> (n,mapCase f e')) bs) (mapCase f e)
--- map all let expressions in given expression
@@ -672,16 +697,16 @@
mapLet f (Comb ct name args) = Comb ct name (map (mapLet f) args)
mapLet f (Free vs e) = Free vs (mapLet f e)
mapLet f (Or e1 e2) = Or (mapLet f e1) (mapLet f e2)
-mapLet f (Case ct e bs)
+mapLet f (Case ct e bs)
= Case ct (mapLet f e) (map (updBranchExpr (mapLet f)) bs)
-mapLet f (Let bs e)
+mapLet f (Let bs e)
= f (Let (map (\ (n,e') -> (n,mapLet f e')) bs) (mapLet f e))
--- update all qualified names in expression
updQNames :: (QName -> QName) -> Expr -> Expr
-updQNames f
+updQNames f
= mapComb (\ (Comb ct name args) -> Comb ct (f name) args)
- . mapCase (\ (Case ct e bs)
+ . mapCase (\ (Case ct e bs)
-> Case ct e (map (updBranchPattern (updPatCons f)) bs))
-- CombType ------------------------------------------------------------------
@@ -714,7 +739,11 @@
-- BranchExpr ----------------------------------------------------------------
-updBranch fp fe (Branch pat exp) = Branch (fp pat) (fe exp)
+updBranch :: (Pattern -> Pattern)
+ -> (Expr -> Expr)
+ -> BranchExpr
+ -> BranchExpr
+updBranch fp fe (Branch pat expr) = Branch (fp pat) (fe expr)
--- get pattern from branch expression
branchPattern :: BranchExpr -> Pattern
@@ -737,6 +766,11 @@
isConsPattern (Pattern _ _) = True
isConsPattern (LPattern _) = False
+updPattern :: (QName -> QName)
+ -> ([VarIndex] -> [VarIndex])
+ -> (Literal -> Literal)
+ -> Pattern
+ -> Pattern
updPattern fn fa _ (Pattern name args) = Pattern (fn name) (fa args)
updPattern _ _ f (LPattern l) = LPattern (f l)
@@ -757,7 +791,7 @@
updPatArgs :: ([Int] -> [Int]) -> Pattern -> Pattern
updPatArgs f = updPattern id f id
---- get literal if pattern is a literal pattern
+--- get literal if pattern is a literal pattern
patLiteral :: Pattern -> Maybe Literal
patLiteral (Pattern _ _) = Nothing
patLiteral (LPattern l) = Just l
@@ -775,7 +809,7 @@
--- rename all variables in branch expression
rnmAllVarsBranch :: (Int -> Int) -> BranchExpr -> BranchExpr
-rnmAllVarsBranch f (Branch pat e)
+rnmAllVarsBranch f (Branch pat e)
= Branch (rnmAllVarsPat f pat) (rnmAllVars f e)
--- flatten all variables in branch expression
@@ -793,4 +827,5 @@
-- opDecls ------------------------------
+opName :: OpDecl -> QName
opName (Op name _ _) = name
diff --git a/Curry/FlatCurry/Type.hs b/Curry/FlatCurry/Type.hs
--- a/Curry/FlatCurry/Type.hs
+++ b/Curry/FlatCurry/Type.hs
@@ -1,361 +1,351 @@
-------------------------------------------------------------------------------
---- 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
-------------------------------------------------------------------------------
+{- |
+ Library to support meta-programming in Curry.
-module Curry.FlatCurry.Type (Prog(..), QName, Visibility(..),
- TVarIndex, TypeDecl(..), ConsDecl(..), TypeExpr(..),
- OpDecl(..), Fixity(..),
- VarIndex,
- FuncDecl(..), Rule(..),
- CaseType(..), CombType(..), Expr(..), BranchExpr(..),
- Pattern(..), Literal(..),
- readFlatCurry, readFlatInterface, readFlat,
- writeFlatCurry) where
+ This library contains a definition for representing FlatCurry programs
+ in Haskell (type "Prog").
-import Curry.Files.PathUtils (writeModule,maybeReadModule)
+ @author Michael Hanus
+ @version September 2003
-import Data.List (intersperse)
+ Version for Haskell (slightly modified):
+ December 2004, Martin Engelke (men@informatik.uni-kiel.de)
+
+ Added part calls for constructors, Bernd Brassel, August 2005
+-}
+
+module Curry.FlatCurry.Type
+ (
+ -- * Data types for flat curry
+ Prog (..), QName, Visibility (..), TVarIndex, TypeDecl (..), ConsDecl (..)
+ , TypeExpr (..), OpDecl (..), Fixity (..), VarIndex, FuncDecl (..)
+ , Rule (..), CaseType (..), CombType (..), Expr (..), BranchExpr (..)
+ , Pattern (..), Literal (..)
+
+ -- * Functions for reading and writing flat curry terms
+ , readFlatCurry, readFlatInterface, readFlat, writeFlatCurry
+ ) where
+
+import Curry.Files.PathUtils (writeModule, maybeReadModule)
+
+import Data.List (intercalate)
import Data.Char (isSpace)
import Control.Monad (liftM)
-------------------------------------------------------------------------------
--- Definition of data types for representing FlatCurry programs:
--- =============================================================
+{- ---------------------------------------------------------------------------
+ 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 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 Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]
- deriving (Read, Show, Eq)
+{- |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.
+-}
+type QName = (String, String)
+-- |Data type to specify the visibility of various entities.
+data Visibility = Public -- ^ public (exported) entity
+ | Private -- ^ private entity
+ deriving (Read, Show, Eq)
---- 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 data type for representing type variables.
+ They are represented by (TVar i) where i is a type variable index.
+-}
+type TVarIndex = Int
-type QName = (String,String)
+{- |Data type for representing definitions of algebraic data types.
+
+ A data type definition of the form
---- Data type to specify the visibility of various entities.
+ data t x1...xn = ...| c t1....tkc |...
-data Visibility = Public -- public (exported) entity
- | Private -- private entity
- deriving (Read, Show, Eq)
+ is represented by the FlatCurry term
---- The data type for representing type variables.
---- They are represented by (TVar i) where i is a type variable index.
+ (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])
-type TVarIndex = Int
+ where each ij is the index of the type variable xj
---- 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.
----
+ 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)
-
---- A constructor declaration consists of the name and arity of the
---- constructor and a list of the argument types of the constructor.
+ deriving (Read, Show, Eq)
+{- |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)
+ deriving (Read, Show, Eq)
+{- |Data type for type expressions.
+ A type expression is either a type variable, a function type,
+ or a type constructor application.
---- 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)
+ 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 TypeExpr =
- TVar TVarIndex -- type variable
- | FuncType TypeExpr TypeExpr -- function type t1->t2
- | TCons QName [TypeExpr] -- type constructor application
- deriving (Read, Show, Eq) -- 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 Int deriving (Read, Show, Eq)
---- 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 types for the different choices for the fixity of an operator.
+data Fixity
+ = InfixOp -- ^ non-associative infix operator
+ | InfixlOp -- ^ left-associative infix operator
+ | InfixrOp -- ^ right-associative infix operator
+ deriving (Read, Show, Eq)
-data OpDecl = Op QName Fixity Int deriving (Read, Show, Eq)
---- Data types for the different choices for the fixity of an operator.
+{- |Data type for representing object variables.
+ Object variables occurring in expressions are represented by (Var i)
+ where i is a variable index.
+-}
+type VarIndex = Int
-data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Read, Show, Eq)
+{- |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))
---- Data type for representing object variables.
---- Object variables occurring in expressions are represented by (Var i)
---- where i is a variable index.
+ and represents the function "name" with definition
-type VarIndex = Int
+ name :: type
+ name x_1...x_arity = e
+ where each i_j is the index of the variable x_j
---- 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.
----
+ 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)
+ deriving (Read, Show, Eq)
---- A rule is either a list of formal parameters together with an expression
---- or an "External" tag.
-
+{- |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 type for classifying case expressions.
---- Case expressions can be either flexible or rigid in Curry.
+ deriving (Read, Show, Eq)
+{- |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 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 type for classifying combinations
+ (i.e., a function/constructor applied to some arguments).
+-}
+data CombType
+ -- |a call to a function where all arguments are provided
+ = FuncCall
+ -- |a call with a constructor at the top, all arguments are provided
+ | ConsCall
+ {- |a partial call to a function (i.e., not all arguments are provided)
+ where the parameter is the number of missing arguments -}
+ | FuncPartCall Int
+ -- ^ a partial call to a constructor along with number of missing arguments
+ | ConsPartCall Int
+ deriving (Read, Show, Eq)
-data CombType = FuncCall
- | ConsCall
- | FuncPartCall Int
- | ConsPartCall Int deriving (Read, Show, Eq)
+{- |Data type for representing expressions.
---- 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)
+ 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])
-data Expr = Var VarIndex
- | Lit Literal
- | Comb CombType QName [Expr]
- | Free [VarIndex] Expr
- | Let [(VarIndex,Expr)] Expr
- | Or Expr Expr
- | Case CaseType Expr [BranchExpr]
- deriving (Read, Show, Eq)
+ 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") []]))
---- 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).
----
+ 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:
-data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq)
+ m eval choice
+ m [] y = y
+ m x [] = x
---- Data type for representing patterns in case expressions.
+ 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
+
+-}
+data Expr
+ -- |variable (represented by unique index)
+ = Var VarIndex
+ -- |literal (Integer/Float/Char constant)
+ | Lit Literal
+ -- |application (f e1 ... en) of function/constructor f with n<=arity(f)
+ | Comb CombType QName [Expr]
+ -- |introduction of free local variables
+ | Free [VarIndex] Expr
+ | Let [(VarIndex, Expr)] Expr
+ {- |disjunction of two expressions (used to translate rules with overlapping
+ left-hand sides) -}
+ | Or Expr Expr
+ -- |case distinction (rigid or flex)
+ | Case CaseType Expr [BranchExpr]
+ deriving (Read, Show, Eq)
+
+
+{- |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 type for representing patterns in case expressions.
data Pattern = Pattern QName [VarIndex]
| LPattern Literal
- deriving (Read, Show, Eq)
-
---- 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'.
+ deriving (Read, Show, Eq)
+{- |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 Integer
| Floatc Double
| Charc Char
- deriving (Read, Show, Eq)
+ deriving (Read, Show, Eq)
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
--- Reads a FlatCurry file (extension ".fcy") and returns the corresponding
--- FlatCurry program term (type 'Prog') as a value of type 'Maybe'.
+{- |Reads a FlatCurry file (extension ".fcy") and returns the corresponding
+ FlatCurry program term (type 'Prog') as a value of type 'Maybe'.
+-}
readFlatCurry :: FilePath -> IO (Maybe Prog)
-readFlatCurry fn
- = do let filename = genFlatFilename ".fcy" fn
- readFlat filename
+readFlatCurry fn = readFlat $ genFlatFilename ".fcy" fn
--- Reads a FlatInterface file (extension ".fint") and returns the
--- corresponding term (type 'Prog') as a value of type 'Maybe'.
+{- |Reads a FlatInterface file (extension ".fint") and returns the
+ corresponding term (type 'Prog') as a value of type 'Maybe'.
+-}
readFlatInterface :: String -> IO (Maybe Prog)
-readFlatInterface fn
- = do let filename = genFlatFilename ".fint" fn
- readFlat filename
+readFlatInterface fn = readFlat $ genFlatFilename ".fint" fn
--- Reads a Flat file and returns the corresponding term (type 'Prog') as
--- a value of type 'Maybe'.
--- Due to compatibility with PAKCS it is allowed to have a commentary
--- at the beginning of the file enclose in {- ... -}.
+{- |Reads a Flat file and returns the corresponding term (type 'Prog') as
+ a value of type 'Maybe'.
+ Due to compatibility with PAKCS it is allowed to have a commentary
+ at the beginning of the file enclosed in {- ... -}.
+-}
readFlat :: FilePath -> IO (Maybe Prog)
readFlat = liftM (fmap (read . skipComment)) . maybeReadModule
where
skipComment s = case dropWhile isSpace s of
'{':'-':s' -> dropComment s'
- s' -> s'
+ s' -> s'
dropComment ('-':'}':xs) = xs
dropComment (_:xs) = dropComment xs
dropComment [] = []
--- Writes a FlatCurry program term into a file.
--- If the flag is set, it will be the hidden .curry sub directory.
+{- |Writes a FlatCurry program term into a file.
+ If the flag is set, it will be in the hidden curry sub-directory.
+-}
writeFlatCurry :: Bool -> String -> Prog -> IO ()
writeFlatCurry inHiddenSubdir filename prog
- = writeModule inHiddenSubdir filename (showFlatCurry prog)
+ = writeModule inHiddenSubdir filename (showFlatCurry prog)
--- Shows FlatCurry program in a more nicely way.
+-- |Shows FlatCurry program in a more nicely way.
showFlatCurry :: Prog -> String
showFlatCurry (Prog mname imps types funcs ops) =
- "Prog "++show mname++"\n "++
- show imps ++"\n ["++
- concat (intersperse ",\n " (map show types)) ++"]\n ["++
- concat (intersperse ",\n " (map show funcs)) ++"]\n "++
- show ops ++"\n"
-
+ "Prog " ++ show mname ++ "\n " ++
+ show imps ++ "\n [" ++
+ intercalate ",\n " (map show types) ++ "]\n [" ++
+ intercalate ",\n " (map show funcs) ++ "]\n " ++
+ show ops ++ "\n"
--- Add the extension 'ext' to the filename 'fn' if it doesn't
--- already exist.
+-- TODO: Use replaceExtension instead?
+
+-- |Add the extension 'ext' to the filename 'fn' if it doesn't already exist.
genFlatFilename :: String -> FilePath -> FilePath
genFlatFilename ext fn
| drop (length fn - length ext) fn == ext
= fn
| otherwise
= fn ++ ext
-
-
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
diff --git a/curry-base.cabal b/curry-base.cabal
--- a/curry-base.cabal
+++ b/curry-base.cabal
@@ -1,38 +1,54 @@
Name: curry-base
-Version: 0.2.8
+Version: 0.2.9
Cabal-Version: >= 1.6
Synopsis: Functions for manipulating Curry programs
-Description: This package serves as a foundation for Curry compilers. it defines the intermediate
- formats FlatCurry and ExtendedFlat. Additionally, it provides functionality
+Description: This package serves as a foundation for Curry compilers.
+ It defines the intermediate language formats FlatCurry and
+ ExtendedFlat. Additionally, it provides functionality
for the smooth integration of compiler frontends and backends.
Category: Language
License: OtherLicense
License-File: LICENSE
-Author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel
-Maintainer: Holger Siegel
-Bug-Reports: mailto:hsi@informatik.uni-kiel.de
-Homepage: http://curry-language.org
+Author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel,
+ Björn Peemöller
+Maintainer: Björn Peemöller
+Bug-Reports: http://www-ps.informatik.uni-kiel.de/redmine/projects/curry-base
+Homepage: http://www.curry-language.org
Build-Type: Simple
Stability: experimental
+Flag split-syb
+ Description: Has the syb functionality been split into the package syb?
+ Default: True
+
Library
- Build-Depends: base >= 3 && < 4, mtl, old-time, directory, filepath, containers, pretty
- ghc-options:
- Exposed-Modules:
- Curry.Base.Position
+ if flag(split-syb)
+ Build-Depends: base == 4.*, syb
+ else
+ Build-Depends: base == 3.*
+ Build-Depends:
+ mtl
+ , containers
+ , filepath
+ , pretty
+ , old-time
+ , directory
+ ghc-options: -Wall
+ Exposed-Modules:
+ Curry.AbstractCurry
Curry.Base.Ident
Curry.Base.MessageMonad
- Curry.ExtendedFlat.Type
+ Curry.Base.Position
+ Curry.ExtendedFlat.CurryArithmetics
+ Curry.ExtendedFlat.EraseTypes
Curry.ExtendedFlat.Goodies
- Curry.ExtendedFlat.TypeInference
+ Curry.ExtendedFlat.LiftLetrec
Curry.ExtendedFlat.MonadicGoodies
+ Curry.ExtendedFlat.Type
+ Curry.ExtendedFlat.TypeInference
Curry.ExtendedFlat.UnMutual
- Curry.ExtendedFlat.LiftLetrec
- Curry.ExtendedFlat.EraseTypes
- Curry.ExtendedFlat.CurryArithmetics
- Curry.FlatCurry.Type
Curry.FlatCurry.Goodies
Curry.FlatCurry.Tools
+ Curry.FlatCurry.Type
Curry.Files.Filenames
Curry.Files.PathUtils
- Curry.AbstractCurry