curry-base 0.2.8 → 0.2.9
raw patch · 15 files changed
+1451/−1074 lines, 15 filesdep +sybdep ~basenew-uploader
Dependencies added: syb
Dependency ranges changed: base
Files
- Curry/AbstractCurry.hs +216/−219
- Curry/Base/Ident.lhs +307/−130
- Curry/Base/MessageMonad.hs +55/−44
- Curry/Base/Position.lhs +41/−14
- Curry/ExtendedFlat/EraseTypes.hs +34/−57
- Curry/ExtendedFlat/Goodies.hs +52/−17
- Curry/ExtendedFlat/Type.hs +2/−1
- Curry/ExtendedFlat/TypeInference.hs +64/−74
- Curry/ExtendedFlat/UnMutual.hs +12/−11
- Curry/Files/Filenames.hs +82/−25
- Curry/Files/PathUtils.hs +118/−90
- Curry/FlatCurry/Goodies.hs +54/−19
- Curry/FlatCurry/Tools.hs +113/−78
- Curry/FlatCurry/Type.hs +267/−277
- curry-base.cabal +34/−18
Curry/AbstractCurry.hs view
@@ -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---- <CODE>---- (CProg modname imports typedecls functions opdecls)---- </CODE>---- where modname: name of this module,---- imports: list of modules names that are imported,---- typedecls, opdecls, functions: see below+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+ <CODE>+ (CProg modname imports typedecls functions opdecls)+ </CODE>+ where modname: name of this module,+ imports: list of modules names that are imported,+ typedecls, opdecls, functions: see below+-} data CurryProg = CurryProg String [String] [CTypeDecl] [CFuncDecl] [COpDecl]- deriving (Read, Show)+ 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.+ <PRE>+ 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.---- <PRE>---- A data type definition of the form-------- data t x1...xn = ...| c t1....tkc |...-------- is represented by the Curry term-------- (CType t v [i1,...,in] [...(CCons c kc v [t1,...,tkc])...])-------- where each ij is the index of the type variable xj-------- Note: the type variable indices are unique inside each type declaration---- and are usually numbered from 0-------- Thus, a data type declaration consists of the name of the data type,---- a list of type parameters and a list of constructor declarations.---- </PRE>+ 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.+ </PRE>+-}+data CTypeDecl = CType QName CVisibility [CTVarIName] [CConsDecl]+ | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr+ deriving (Read, Show) +{- |A constructor declaration consists of the name and arity of the+ constructor and a list of the argument types of the constructor.+-}+data CConsDecl = CCons QName Int CVisibility [CTypeExpr]+ deriving (Read, Show) ---- Data type for type expressions.---- A type expression is either a type variable, a function type,---- or a type constructor application.-------- Note: the names of the predefined type constructors are---- "Int", "Float", "Bool", "Char", "IO", "Success",---- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)+{- |Data 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.+ <PRE>+ 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.---- <PRE>---- A function declaration in FlatCurry is a term of the form-------- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))-------- and represents the function "name" with definition-------- name :: type---- rule1---- ...---- rulek-------- Note: the variable indices are unique inside each rule-------- External functions are represented as (CFunc name arity type (CExternal s))---- where s is the external name associated to this function.-------- Thus, a function declaration consists of the name, arity, type, and---- a list of rules.---- </PRE>+ External functions are represented as (CFunc name arity type (CExternal s))+ where s is the external name associated to this function. + Thus, a function declaration consists of the name, arity, type, and+ a list of rules.+ </PRE>+-} data CFuncDecl = CFunc QName Int CVisibility CTypeExpr CRules- deriving (Read, Show)+ 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"
Curry/Base/Ident.lhs view
@@ -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:"
Curry/Base/MessageMonad.hs view
@@ -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
Curry/Base/Position.lhs view
@@ -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}
Curry/ExtendedFlat/EraseTypes.hs view
@@ -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", "()")) []
Curry/ExtendedFlat/Goodies.hs view
@@ -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"
Curry/ExtendedFlat/Type.hs view
@@ -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
Curry/ExtendedFlat/TypeInference.hs view
@@ -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
Curry/ExtendedFlat/UnMutual.hs view
@@ -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)
Curry/Files/Filenames.hs view
@@ -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
Curry/Files/PathUtils.hs view
@@ -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
Curry/FlatCurry/Goodies.hs view
@@ -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
Curry/FlatCurry/Tools.hs view
@@ -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
Curry/FlatCurry/Type.hs view
@@ -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---- <CODE>---- (Prog modname imports typedecls functions opdecls translation_table)---- </CODE>---- where modname: name of this module,---- imports: list of modules names that are imported,---- typedecls, opdecls, functions, translation of type names---- and constructor/function names: see below+{- |Data type for representing a Curry module in the intermediate form.+ A value of this data type has the form+ <CODE>+ (Prog modname imports typedecls functions opdecls translation_table)+ </CODE>+ where modname: name of this module,+ imports: list of modules names that are imported,+ typedecls, opdecls, functions, translation of type names+ and constructor/function names: see below+-}+data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]+ deriving (Read, Show, Eq) -data 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.+ <PRE>+ 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.---- <PRE>---- A data type definition of the form-------- data t x1...xn = ...| c t1....tkc |...-------- is represented by the FlatCurry term-------- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])-------- where each ij is the index of the type variable xj-------- Note: the type variable indices are unique inside each type declaration---- and are usually numbered from 0-------- Thus, a data type declaration consists of the name of the data type,---- a list of type parameters and a list of constructor declarations.---- </PRE>+ Note: the type variable indices are unique inside each type declaration+ and are usually numbered from 0 + Thus, a data type declaration consists of the name of the data type,+ a list of type parameters and a list of constructor declarations.+ </PRE>+-} data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl] | TypeSyn QName Visibility [TVarIndex] TypeExpr- deriving (Read, Show, Eq)----- 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.+ <PRE>+ 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.---- <PRE>---- A function declaration in FlatCurry is a term of the form-------- (Func name arity type (Rule [i_1,...,i_arity] e))-------- and represents the function "name" with definition-------- name :: type---- name x_1...x_arity = e-------- where each i_j is the index of the variable x_j-------- Note: the variable indices are unique inside each function declaration---- and are usually numbered from 0-------- External functions are represented as (Func name arity type (External s))---- where s is the external name associated to this function.-------- Thus, a function declaration consists of the name, arity, type, and rule.---- </PRE>+ Note: the variable indices are unique inside each function declaration+ and are usually numbered from 0 + External functions are represented as (Func name arity type (External s))+ where s is the external name associated to this function.++ Thus, a function declaration consists of the name, arity, type, and rule.+ </PRE>+-} data FuncDecl = Func QName Int Visibility TypeExpr Rule- deriving (Read, Show, Eq)+ 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:---- <PRE>---- 1. if-then-else expressions are represented as function calls:---- (if e1 then e2 else e3)---- is represented as---- (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])---- ---- 2. Higher order applications are represented as calls to the (external)---- function "apply". For instance, the rule---- app f x = f x---- is represented as---- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))---- ---- 3. A conditional rule is represented as a call to an external function---- "cond" where the first argument is the condition (a constraint).---- For instance, the rule---- equal2 x | x=:=2 = success---- is represented as---- (Rule [0]---- (Comb FuncCall ("Prelude","cond")---- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],---- Comb FuncCall ("Prelude","success") []]))---- ---- 4. Functions with evaluation annotation "choice" are represented---- by a rule whose right-hand side is enclosed in a call to the---- external function "Prelude.commit".---- Furthermore, all rules of the original definition must be---- represented by conditional expressions (i.e., (cond [c,e]))---- after pattern matching.---- Example:---- ---- m eval choice---- m [] y = y---- m x [] = x---- ---- is translated into (note that the conditional branches can be also---- wrapped with Free declarations in general):---- ---- Rule [0,1]---- (Comb FuncCall ("Prelude","commit")---- [Or (Case Rigid (Var 0)---- [(Pattern ("Prelude","[]") []---- (Comb FuncCall ("Prelude","cond")---- [Comb FuncCall ("Prelude","success") [],---- Var 1]))] )---- (Case Rigid (Var 1)---- [(Pattern ("Prelude","[]") []---- (Comb FuncCall ("Prelude","cond")---- [Comb FuncCall ("Prelude","success") [],---- Var 0]))] )])---- ---- Operational meaning of (Prelude.commit e):---- evaluate e with local search spaces and commit to the first---- (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c---- is satisfied---- </PRE>---- @cons Var - variable (represented by unique index)---- @cons Lit - literal (Integer/Float/Char constant)---- @cons Comb - application (f e1 ... en) of function/constructor f---- with n<=arity(f)---- @cons Free - introduction of free local variables---- @cons Or - disjunction of two expressions (used to translate rules---- with overlapping left-hand sides)---- @cons Case - case distinction (rigid or flex)+ Remarks:+ <PRE>+ 1. if-then-else expressions are represented as function calls:+ (if e1 then e2 else e3)+ is represented as+ (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3]) -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.---- <PRE>---- Branches "(m.c x1...xn) -> e" in case expressions are represented as-------- (Branch (Pattern (m,c) [i1,...,in]) e)-------- where each ij is the index of the pattern variable xj, or as-------- (Branch (LPattern (Intc i)) e)-------- for integers as branch patterns (similarly for other literals---- like float or character constants).---- </PRE>+ 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+ </PRE>+-}+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.+ <PRE>+ Branches "(m.c x1...xn) -> e" in case expressions are represented as++ (Branch (Pattern (m,c) [i1,...,in]) e)++ where each ij is the index of the pattern variable xj, or as++ (Branch (LPattern (Intc i)) e)++ for integers as branch patterns (similarly for other literals+ like float or character constants).+ </PRE>+-}+data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq)++-- |Data 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-----------------------------------------------------------------------------------------------------------------------------------------------------------------
curry-base.cabal view
@@ -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 <bjp@informatik.uni-kiel.de>+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