diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,199 @@
+Change log for curry-base
+=========================
+
+Version (1.0.0)
+===============
+
+ * Add support for typeclasses as known from Haskell.
+
+Version (0.4.2)
+===============
+
+ * Licenses made more specific.
+ * Introduced a new annotated variant of FlatCurry.
+
+Version (0.4.1)
+===============
+
+ * Added new operator `@>` to return the left operand with the source code
+ position obtained from the right operand.
+ * Parenthesized type expressions are now represented accordingly in the
+ abstract syntax tree
+ * Derive `Show` and `Read` instances also for identifiers to facilitate
+ debugging and reading/writing from/to files
+ * Emitted FlatCurry files now contain newlines to improve readability
+ for humans
+ * Implemented pretty printer for extended FlatCurry
+ * Added syntax extension `ExistentialQuantification` that allows the use
+ of existentially quantified types in data and newtype constructors
+ * Representation for spans (start and end position) added
+
+Version 0.4.0
+=============
+
+ * Introduced new representation of AbstractCurry
+
+ - AbstractCurry files now contain version information
+ - support for new record syntax
+ - support for newtype declarations
+ - evaluation annotations removed
+ - arity of constructor declarations removed
+ - simplified representation of function rules
+ - String literals added
+
+ * Removed support for Curry's record syntax and introduced Haskell's record
+ syntax instead
+
+ * Lexer is now capable of lexing binary integer literals, for instance
+ `0b101010` or `0B101010` can now be lexed and are converted to `42`.
+
+ * Removed record type extensions
+
+ * Moved `CYT` monads to `curry-base` (`Curry.Base.Monad`)
+ and removed `MessageM` monad
+
+ * Adapted Curry syntax and parser: Now declaration of operator precendence
+ in declarations of infix operators is optional
+
+ * Moved module `InterfaceEquivalence` (curry-frontend) to
+ `Curry.Syntax.InterfaceEquivalence` (curry-base)
+
+ * Removed module `Curry.Base.Equiv`
+
+ * Replaced module `Curry.ExtendedFlat.Interface.Equality` by
+ `Curry.ExtendedFlat.InterfaceEquivalence` using a type class to
+ implement equivalence of FlatCurry interfaces
+
+ * Removed file name extensions for FlatCurry XML files.
+
+ * Added syntax extension `NegativeLiterals` to translate negated literals
+ into negative literals instead of a call to `Prelude.negate` and
+ `Prelude.negateFloat`, respectively.
+
+ * Added `CYMAKE` to the list of recognized tools when parsing an options
+ pragma (`{-# OPTIONS_CYMAKE opt1 opt2 ... optN #-}`).
+
+Version 0.3.10
+==============
+
+ * Updated internal structure of `Curry.Base.Filenames` and
+ `Curry.Base.PathUtils`.
+
+ * Fixed bug in parser which complained `:-> expected` when it really
+ looked for `:>`.
+
+ * Make library compile under GHC 7.8 without warnings.
+
+ * Unliterating and lexing/parsing of source files are now decoupled
+ to support custom preprocessors.
+
+ * Split `Curry.AbstractCurry` and `Curry.FlatCurry` into two modules
+ `.Type` and `.Files`, where `.Type` now only contains the type definition
+ while `.Files` contains read/write functions.
+ Both are subsumed by the parent modules `Curry.AbstractCurry`
+ and `Curry.FlatCurry` for convenience.
+
+Version 0.3.9
+=============
+
+ * Implementation of module pragmas added. Module pragmas of the following
+ types are now parsed and represented in the abstract syntax tree:
+
+ ~~~ {.curry}
+ {-# LANGUAGE LANG_EXT+ #-}
+ {-# OPTIONS "string" #-}
+ {-# OPTIONS_TOOL "string" #-}
+ module Main where
+ ~~~
+
+ where
+
+ - `LANGEXT+` is a non-empty, comma-separated list of the following
+ language extensions: `AnonFreeVars`, `FunctionalPatterns`,
+ `NoImplicitPrelude`, `Records`
+ - `TOOL` is either `KICS2`, `PAKCS`, or some other tool, represented
+ as `Unknown String`.
+
+ Note that, naturally, the curry-base library only recognizes the above
+ mentioned pragmas, while the processing is up to the respective tool.
+
+ All other texts given in the pragma braces is ignored and treated as
+ a nested comment.
+
+ * Reactivation of Curry interface files.
+ During adaption of the MCC frontend to FlatCurry the Curry interface
+ files have been deactivated and replaced by FlatCurry's interface
+ files. To allow the later addition of type classes to Curry,
+ they have now been reactivated.
+
+Version 0.3.8
+=============
+
+ * The parser now takes the layout into respect when parsing the import
+ list. This fixes issue #494 where a module with imports without
+ restrictions, directly followed by an operator definition,
+ could not be parsed.
+
+ * Various internal improvements.
+
+Version 0.3.7
+=============
+
+ * Support for typed FlatCurry expressions added. Now additional type
+ information given by the programmer as in
+
+ ~~~ {.curry}
+ null (unknown :: [()])
+ ~~~
+
+ is represented in FlatCurry and cann therefore be processed by other
+ programs like PAKCS or KICS2.
+
+Version 0.3.6
+=============
+
+ * Fixed a bug where character constants not contained in the ASCII alphabet
+ were translated incorrectly.
+
+Version 0.3.5
+=============
+
+ * Fixed a bug w.r.t. pretty-printing of records.
+
+Version 0.3.4
+=============
+
+ * Made compiler messages comparable to allow later sorting of compiler
+ errors and warnings to present them in the order of their occurence.
+
+Version 0.3.3
+=============
+
+ * Improved pretty printing of Curry modules.
+
+Version 0.3.2
+=============
+
+ * Improved pretty-printing of warnings and errors.
+
+ * Improved error message for missing precendence after fixity declaration.
+
+ * Changed syntax of records to allow disambiguation of record selection
+ and case branches.
+
+ * Various improvements.
+
+Version 0.3.1
+=============
+
+ * Improved support for anonymous identifiers (test predicate, parser
+ also returns source code position).
+
+Version 0.3.0
+=============
+
+ * Massive refactoring of the previous version.
+
+ * All compiler warnings removed.
+
+ * Fixed various implementation bugs.
diff --git a/Curry/AbstractCurry.hs b/Curry/AbstractCurry.hs
deleted file mode 100644
--- a/Curry/AbstractCurry.hs
+++ /dev/null
@@ -1,279 +0,0 @@
-{- |Library to support meta-programming in Curry.
-
- This library contains a definition for representing Curry programs
- in Curry (type "CurryProg") and an I/O action to read Curry programs and
- transform them into this abstract representation (function "readCurry").
-
- Note this defines a slightly new format for AbstractCurry
- in comparison to the first proposal of 2003.
-
- Assumption: an abstract Curry program is stored in file prog.acy
- and translated with the parser by "parsecurry -acy prog".
-
- @author Michael Hanus
- @version April 2004
-
- Version for Haskell (slightly modified):
- July 2005, Martin Engelke (men@informatik.uni-kiel.de)
--}
-
-module Curry.AbstractCurry
- ( -- * Data types
- CurryProg (..), QName, CLabel, CVisibility (..), CTVarIName
- , CTypeDecl (..), CConsDecl (..), CTypeExpr (..), COpDecl (..), CFixity (..)
- , CVarIName, CFuncDecl (..), CRules (..), CEvalAnnot (..), CRule (..)
- , CLocalDecl (..), CExpr (..), CStatement (..), CPattern (..)
- , CBranchExpr (..), CLiteral (..), CField
- -- * Functions for reading and writing abstract curry terms
- , readCurry, writeCurry
- ) where
-
-import Control.Monad (liftM)
-import Data.List (intercalate)
-
-import Curry.Files.PathUtils (writeModule, readModule)
-
-{- ---------------------------------------------------------------------------
- Definition of data types for representing abstract Curry programs
---------------------------------------------------------------------------- -}
-
-{- |Data type for representing a Curry module in the intermediate form.
- A value of this data type has the form
-
- (CProg modname imports typedecls functions opdecls)
-
- where modname: name of this module,
- imports: list of modules names that are imported,
- typedecls, opdecls, functions: see below
--}
-data CurryProg = CurryProg String [String] [CTypeDecl] [CFuncDecl] [COpDecl]
- deriving (Read, Show)
-
-{- |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 CLabel = String
-
--- |Data type to specify the visibility of various entities.
-data CVisibility = Public -- ^ exported entity
- | Private -- ^ private entity
- deriving (Read, Show, Eq)
-
-{- |The type for representing type variables.
- They are represented by (i,n) where i is a type variable index
- which is unique inside a function and n is a name (if possible,
- the name written in the source program).
--}
-type CTVarIName = (Int, String)
-
-{- |Data type for representing definitions of algebraic data types and type
- synonyms.
-
- A data type definition of the form
-
- 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.
-
--}
-data CTypeDecl = CType QName CVisibility [CTVarIName] [CConsDecl]
- | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr
- deriving (Read, Show)
-
-{- |A constructor declaration consists of the name and arity of the
- constructor and a list of the argument types of the constructor.
--}
-data CConsDecl = CCons QName Int CVisibility [CTypeExpr]
- deriving (Read, Show)
-
-{- |Data type for type expressions.
- A type expression is either a type variable, a function type,
- or a type constructor application.
-
- Note: the names of the predefined type constructors are
- "Int", "Float", "Bool", "Char", "IO", "Success",
- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
--}
-data CTypeExpr
- = CTVar CTVarIName -- ^ type variable
- | CFuncType CTypeExpr CTypeExpr -- ^ function type t1->t2
- | CTCons QName [CTypeExpr] -- ^ type constructor application
- | CRecordType [CField CTypeExpr] -- ^ record type (extended Curry)
- (Maybe CTVarIName)
- deriving (Read, Show)
-
-{- |Data type for operator declarations.
- An operator declaration "fix p n" in Curry corresponds to the
- AbstractCurry term (COp n fix p).
--}
-data COpDecl = COp QName CFixity Int deriving (Read, Show)
-
--- |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 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 type for representing function declarations.
-
- A function declaration in FlatCurry is a term of the form
-
- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))
-
- and represents the function "name" with definition
-
- name :: type
- rule1
- ...
- rulek
-
- Note: the variable indices are unique inside each rule
-
- External functions are represented as (CFunc name arity type (CExternal s))
- where s is the external name associated to this function.
-
- Thus, a function declaration consists of the name, arity, type, and
- a list of rules.
-
--}
-data CFuncDecl = CFunc QName Int CVisibility CTypeExpr CRules
- deriving (Read, Show)
-
-
-{- |A rule is either a list of formal parameters together with an expression
- (i.e., a rule in flat form), a list of general program rules with
- an evaluation annotation, or it is externally defined
--}
-data CRules = CRules CEvalAnnot [CRule]
- | CExternal String
- deriving (Read, Show)
-
-{- |Data type for classifying evaluation annotations for functions.
- They can be either flexible (default), rigid, or choice.
--}
-data CEvalAnnot = CFlex | CRigid | CChoice deriving (Read, Show, Eq)
-
-{- |The most general form of a rule. It consists of a list of patterns
- (left-hand side), a list of guards ("success" if not present in the
- source text) with their corresponding right-hand sides, and
- a list of local declarations.
--}
-data CRule = CRule [CPattern] [(CExpr, CExpr)] [CLocalDecl]
- deriving (Read, Show)
-
--- | Data type for representing local (let/where) declarations
-data CLocalDecl
- = CLocalFunc CFuncDecl -- ^ local function declaration
- | CLocalPat CPattern CExpr [CLocalDecl] -- ^ local pattern declaration
- | CLocalVar CVarIName -- ^ local free variable declaration
- deriving (Read, Show)
-
--- |Data type for representing Curry expressions.
-data CExpr
- = CVar CVarIName -- ^ variable (unique index / name)
- | CLit CLiteral -- ^ literal (Integer/Float/Char constant)
- | CSymbol QName -- ^ a defined symbol with module and name
- | CApply CExpr CExpr -- ^ application (e1 e2)
- | CLambda [CPattern] CExpr -- ^ lambda abstraction
- | CLetDecl [CLocalDecl] CExpr -- ^ local let declarations
- | CDoExpr [CStatement] -- ^ do expression
- | CListComp CExpr [CStatement] -- ^ list comprehension
- | CCase CExpr [CBranchExpr] -- ^ case expression
- | CRecConstr [CField CExpr] -- ^ record construction (extended Curry)
- | CRecSelect CExpr CLabel -- ^ field selection (extended Curry)
- | CRecUpdate [CField CExpr] CExpr -- ^ record update (extended Curry)
- deriving (Read, Show)
-
-{- |Data type for representing statements in do expressions and
- list comprehensions.
--}
-data CStatement
- = CSExpr CExpr -- ^ an expression (I/O action or boolean)
- | CSPat CPattern CExpr -- ^ a pattern definition
- | CSLet [CLocalDecl] -- ^ a local let declaration
- deriving (Read, Show)
-
--- |Data type for representing pattern expressions.
-data CPattern
- -- |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 CLiteral = CIntc Integer
- | CFloatc Double
- | CCharc Char
- deriving (Read, Show, Eq)
-
--- |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')
--}
-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.
--}
-writeCurry :: Bool -> String -> CurryProg -> IO ()
-writeCurry inHiddenSubdir filename prog
- = catch (writeModule inHiddenSubdir filename $ showCurry prog) ioError
-
--- |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 [" ++
- intercalate ",\n " (map show types) ++ "]\n [" ++
- intercalate ",\n " (map show funcs) ++ "]\n " ++
- show ops ++ "\n"
diff --git a/Curry/Base/Ident.lhs b/Curry/Base/Ident.lhs
deleted file mode 100644
--- a/Curry/Base/Ident.lhs
+++ /dev/null
@@ -1,530 +0,0 @@
-> {-# LANGUAGE DeriveDataTypeable #-}
-
-% $Id: Ident.lhs,v 1.21 2004/10/29 13:08:09 wlux Exp $
-%
-% Copyright (c) 1999-2004, Wolfgang Lux
-% See LICENSE for the full license.
-%
-\nwfilename{Ident.lhs}
-\section{Identifiers}
-This module provides the implementation of identifiers and some
-utility functions for identifiers, which are used at various places in
-the compiler.
-
-Identifiers comprise the name of the denoted entity and an \emph{id},
-which can be used for renaming identifiers, e.g., in order to resolve
-name conflicts between identifiers from different scopes. An
-identifier with an \emph{id} $0$ is considered as not being renamed
-and, hence, its \emph{id} will not be shown.
-
-\ToDo{Probably we should use \texttt{Integer} for the \emph{id}s.}
-
-Qualified identifiers may optionally be prefixed by a module
-name. \textbf{The order of the cases \texttt{UnqualIdent} and
-\texttt{QualIdent} is important. Some parts of the compiler rely on
-the fact that all qualified identifiers are greater than any
-unqualified identifier.}
-\begin{verbatim}
-
-> module Curry.Base.Ident
-> ( -- * 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
-> import Data.Maybe
-> import Data.Generics
-> import Data.Function(on)
-
-> import Curry.Base.Position
-
-
-> -- | Simple identifiers
-> data Ident = Ident
-> { positionOfIdent :: Position -- ^ Source code 'Position'
-> , name :: String -- ^ name
-> , uniqueId :: Int -- ^ unique number of the identifier
-> } 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)
-
-> instance Ord Ident where
-> Ident _ m i `compare` Ident _ n j = (m,i) `compare` (n, j)
-
-> instance Show Ident where
-> 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 -- ^ optional module identifier
-> , qualidId:: Ident -- ^ identifier itself
-> } deriving (Eq, Ord, Read, Data, Typeable)
-
-> instance SrcRefOf QualIdent where
-> srcRefOf = srcRefOf . unqualify
-
-> instance Show QualIdent where
-> show = qualName
-
-> -- | show function for qualified identifiers
-> qualName :: QualIdent -> String
-> qualName (QualIdent Nothing x) = name x
-> qualName (QualIdent (Just m) x) = moduleName m ++ "." ++ name x
-
-
-> -- | Module identifiers
-> data ModuleIdent = ModuleIdent
-> { positionOfModuleIdent :: Position -- ^ source code position
-> , moduleQualifiers :: [String] -- ^ hierarchical idenfiers
-> } deriving (Read, Data, Typeable)
-
-> instance Eq ModuleIdent where
-> (==) = (==) `on` moduleQualifiers
-
-> instance Ord ModuleIdent where
-> compare = compare `on` moduleQualifiers
-
-> -- | Retrieve the hierarchical name of a module
-> moduleName :: ModuleIdent -> String
-> moduleName = concat . intersperse "." . moduleQualifiers
-
-> instance Show ModuleIdent where
-> 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 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 ident n = ident { uniqueId = n }
-
-> -- | Revert the renaming of an 'Ident' by resetting its unique number
-> unRenameIdent :: Ident -> Ident
-> 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) _) =
-> last (c:cs) /= '>' || not (isAlphaNum c) && c `notElem` "_(["
-> 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 = isInfixOp . qualidId
-
-\end{verbatim}
-The functions \texttt{qualify} and \texttt{qualifyWith} convert an
-unqualified identifier into a qualified identifier (without and with a
-given module prefix, respectively).
-\begin{verbatim}
-
-> -- | 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 = isJust . qualidMod
-
-> -- | Remove the qualification of an 'QualIdent'
-> unqualify :: QualIdent -> Ident
-> 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'
-
-> -- | 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)
-
-> -- | 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
-
-
-\end{verbatim}
-A few identifiers a predefined here.
-\begin{verbatim}
-
-> -- | '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 = mkIdent "_"
-
--- Identifiers for types
-
-> -- | '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
-
--- Identifiers for functions
-
-> -- | 'Ident' for the main function
-> mainId :: Ident
-> mainId = mkIdent "main"
-
-> -- | 'Ident' for the minus function
-> minusId :: Ident
-> minusId = mkIdent "-"
-
-> -- | '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 = 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
-
-\end{verbatim}
-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
-
-> -- | 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)
-
-> -- | 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))
-
-> -- | 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
-
-> -- | 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
-> | 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
-> | 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)
-
-> -- | Annotation string for function pattern identifiers
-> fpSelExt :: String
-> fpSelExt = "_#selFP"
-
-> -- | Annotation string for record selection identifiers
-> recSelExt :: String
-> recSelExt = "_#selR@"
-
-> -- | Annotation string for record update identifiers
-> recUpdExt :: String
-> recUpdExt = "_#updR@"
-
-> -- | Annotation string for record identifiers
-> recordExt :: String
-> recordExt = "_#Rec:"
-
-> -- | Annotation string for record label identifiers
-> labelExt :: String
-> labelExt = "_#Lab:"
diff --git a/Curry/Base/MessageMonad.hs b/Curry/Base/MessageMonad.hs
deleted file mode 100644
--- a/Curry/Base/MessageMonad.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-# 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.
--}
-
-module Curry.Base.MessageMonad where
-
-import Control.Monad.Error
-import Control.Monad.Writer
-import Control.Monad.Identity
-
-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 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
-
-instance Show WarnMsg where
- 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 ++ ": "
-
--- | 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 ++ ": "
-
--- | 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')
-
--- | 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]
diff --git a/Curry/Base/Position.lhs b/Curry/Base/Position.lhs
deleted file mode 100644
--- a/Curry/Base/Position.lhs
+++ /dev/null
@@ -1,126 +0,0 @@
-> {-# LANGUAGE DeriveDataTypeable #-}
-
-% -*- LaTeX -*-
-% $Id: Position.lhs,v 1.2 2000/10/08 09:55:43 lux Exp $
-%
-% $Log: Position.lhs,v $
-% Revision 1.2 2000/10/08 09:55:43 lux
-% Column numbers now start at 1. If the column number is less than 1 it
-% will not be shown.
-%
-% Revision 1.1 2000/07/23 11:03:37 lux
-% Positions now implemented in a separate module.
-%
-%
-\nwfilename{Position.lhs}
-\section{Positions}
-A source file position consists of a filename, a line number, and a
-column number. A tab stop is assumed at every eighth column.
-\begin{verbatim}
-
-> module Curry.Base.Position where
-> import Data.Generics
-
-> -- | A pointer to the origin
-> newtype SrcRef = SrcRef [Int] deriving (Data,Typeable)
-
--- the instances for standard classes or such that SrcRefs are invisible
-
-> instance Show SrcRef where show _ = ""
-> instance Read SrcRef where readsPrec _ s = [(noRef,s)]
-> instance Eq SrcRef where _ == _ = True
-> instance Ord SrcRef where compare _ _ = EQ
-
-> -- | 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
-
-> -- | 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 }
-
-> instance Read Position where
-> 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} =
-> (if null fn then id else shows fn . showString ", ") .
-> showString "line " . shows l .
-> (if c > 0 then showChar '.' . shows c else id)
-> showsPrec _ AST{} = id
-> showsPrec _ NoPos = id
-
-> -- | 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 ++ ") "
-
-> -- | 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
-
-\end{verbatim}
diff --git a/Curry/ExtendedFlat/CurryArithmetics.hs b/Curry/ExtendedFlat/CurryArithmetics.hs
deleted file mode 100644
--- a/Curry/ExtendedFlat/CurryArithmetics.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-
- In Curry, Integers are encoded as binary values,
- being represented by constructor terms.
-
- (c) Holger Siegel 2009
--}
-module Curry.ExtendedFlat.CurryArithmetics
- (CurryInt(..), CurryNat(..),
- trNat, trInt,
- toCurryInt, toIntExpression,
- ) where
-
-import Curry.ExtendedFlat.Type
-
-
-data CurryInt = Neg CurryNat | Zero | Pos CurryNat
-data CurryNat = IHi | O CurryNat | I CurryNat
-
-
-trNat :: Integral n =>
- a -> (a -> a) -> (a -> a) ->
- n -> a
-trNat h o i = go
- where go n | n `mod` 2 == 0 = o (go m)
- | m == 0 = h
- | otherwise = i (go m)
- where m = n `div` 2
-
-
-trInt :: Integral n =>
- (nat -> t) -> t -> (nat -> t) ->
- nat -> (nat -> nat) -> (nat -> nat) ->
- n -> t
-trInt n z p h o i = go
- where go x = case compare x 0 of
- LT -> n (trNat h o i (negate x))
- EQ -> z
- GT -> p (trNat h o i x)
-
-
-toCurryInt :: Integral a => a -> CurryInt
-toCurryInt = trInt Neg Zero Pos IHi O I
-
-
-toIntExpression :: Integral a => a -> Expr
-toIntExpression = trInt neg_ zero_ pos_ iHi_ o_ i_
-
-
-zero_, iHi_ :: Expr
-pos_, neg_, o_, i_ :: Expr -> Expr
-
-zero_ = prelCons tInt0 "Zero" []
-pos_ n = prelCons tInt1 "Pos" [n]
-neg_ n = prelCons tInt1 "Neg" [n]
-
-iHi_ = prelCons tNat0 "IHi" []
-o_ n = prelCons tNat1 "O" [n]
-i_ n = prelCons tNat1 "I" [n]
-
-
-tInt0, tInt1, tNat0, tNat1 :: TypeExpr
-tInt0 = prelType "Int"
-tInt1 = FuncType tInt0 tInt0
-
-tNat0 = prelType "Nat"
-tNat1 = FuncType tNat0 tNat0
-
-
-prelType :: String -> TypeExpr
-prelType s = TCons (mkQName ("Prelude", s)) []
-
-
-prelCons :: TypeExpr -> String -> [Expr] -> Expr
-prelCons t = Comb ConsCall . QName Nothing (Just t) "Prelude"
diff --git a/Curry/ExtendedFlat/EraseTypes.hs b/Curry/ExtendedFlat/EraseTypes.hs
deleted file mode 100644
--- a/Curry/ExtendedFlat/EraseTypes.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-{- |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 ().
-
- (c) 2009, Holger Siegel.
--}
-
-module Curry.ExtendedFlat.EraseTypes (eraseTypes) where
-
-import Curry.ExtendedFlat.Type
-import Curry.ExtendedFlat.Goodies
-
--- 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 _ 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)
-
-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
-
-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
-
-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
-
-replaceFreeTypesWithEmptyTuple :: TVarSet -> TypeExpr -> TypeExpr
-replaceFreeTypesWithEmptyTuple usedtvars = updTVars foo where
- foo tidx | tidx `elem` usedtvars = TVar tidx
- | otherwise = TCons (mkQName ("Prelude", "()")) []
diff --git a/Curry/ExtendedFlat/Goodies.hs b/Curry/ExtendedFlat/Goodies.hs
deleted file mode 100644
--- a/Curry/ExtendedFlat/Goodies.hs
+++ /dev/null
@@ -1,999 +0,0 @@
-----------------------------------------------------------------------------
---- 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
---- functions. For recursive datatypes the transformations are defined
---- inductively over the term structure. This is quite usual for
---- 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 -
---- is abstracted away, which hopefully makes the code more clear and brief.
----
---- @author Sebastian Fischer
---- @version January 2006
-----------------------------------------------------------------------------
-
-module Curry.ExtendedFlat.Goodies where
-
-import Control.Arrow(first, second)
-import Control.Monad(mplus, msum)
-import Data.List
-
-import Curry.ExtendedFlat.Type
-
---------------------------------
--- adjustments for haskell (bbr)
---------------------------------
-failed :: a
-failed = undefined
-
---------------------------------
-
-type Update a b = (b -> b) -> a -> a
-
--- Prog ----------------------------------------------------------------------
-
---- transform program
-trProg :: (String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> a)
- -> Prog -> a
-trProg prog (Prog name imps types funcs ops) = prog name imps types funcs ops
-
--- Selectors
-
---- get name from program
-progName :: Prog -> String
-progName = trProg (\name _ _ _ _ -> name)
-
---- get imports from program
-progImports :: Prog -> [String]
-progImports = trProg (\_ imps _ _ _ -> imps)
-
---- get type declarations from program
-progTypes :: Prog -> [TypeDecl]
-progTypes = trProg (\_ _ types _ _ -> types)
-
---- get functions from program
-progFuncs :: Prog -> [FuncDecl]
-progFuncs = trProg (\_ _ _ funcs _ -> funcs)
-
---- get infix operators from program
-progOps :: Prog -> [OpDecl]
-progOps = trProg (\_ _ _ _ ops -> ops)
-
--- Update Operations
-
---- update program
-updProg :: (String -> String) ->
- ([String] -> [String]) ->
- ([TypeDecl] -> [TypeDecl]) ->
- ([FuncDecl] -> [FuncDecl]) ->
- ([OpDecl] -> [OpDecl]) -> Prog -> Prog
-updProg fn fi ft ff fo = trProg prog
- where
- prog name imps types funcs ops
- = Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops)
-
---- update name of program
-updProgName :: Update Prog String
-updProgName f = updProg f id id id id
-
---- update imports of program
-updProgImports :: Update Prog [String]
-updProgImports f = updProg id f id id id
-
---- update type declarations of program
-updProgTypes :: Update Prog [TypeDecl]
-updProgTypes f = updProg id id f id id
-
---- update functions of program
-updProgFuncs :: Update Prog [FuncDecl]
-updProgFuncs f = updProg id id id f id
-
---- update infix operators of program
-updProgOps :: Update Prog [OpDecl]
-updProgOps = updProg id id id id
-
--- Auxiliary Functions
-
---- get all program variables (also from patterns)
-allVarsInProg :: Prog -> [VarIndex]
-allVarsInProg = concatMap allVarsInFunc . progFuncs
-
---- lift transformation on expressions to program
-updProgExps :: Update Prog Expr
-updProgExps = updProgFuncs . map . updFuncBody
-
---- rename programs variables
-rnmAllVarsInProg :: Update Prog VarIndex
-rnmAllVarsInProg = updProgFuncs . map . rnmAllVarsInFunc
-
---- update all qualified names in program
-updQNamesInProg :: Update Prog QName
-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
- then qn { modName = name }
- else qn
-
--- TypeDecl ------------------------------------------------------------------
-
--- Selectors
-
---- transform type declaration
-trType :: (QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> a) ->
- (QName -> Visibility -> [TVarIndex] -> TypeExpr -> a) -> TypeDecl -> a
-trType typ _ (Type name vis params cs) = typ name vis params cs
-trType _ typesyn (TypeSyn name vis params syn) = typesyn name vis params syn
-
---- get name of type declaration
-typeName :: TypeDecl -> QName
-typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name)
-
---- get visibility of type declaration
-typeVisibility :: TypeDecl -> Visibility
-typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis)
-
---- get type parameters of type declaration
-typeParams :: TypeDecl -> [TVarIndex]
-typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params)
-
---- get constructor declarations from type declaration
-typeConsDecls :: TypeDecl -> [ConsDecl]
-typeConsDecls = trType (\_ _ _ cs -> cs) failed
-
---- get synonym of type declaration
-typeSyn :: TypeDecl -> TypeExpr
-typeSyn = trType failed (\_ _ _ syn -> syn)
-
---- is type declaration a type synonym?
-isTypeSyn :: TypeDecl -> Bool
-isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True)
-
--- is type declaration declaring a regular type?
-isDataTypeDecl :: TypeDecl -> Bool
-isDataTypeDecl = trType (\_ _ _ cs -> not (null cs)) (\_ _ _ _ -> False)
-
--- is type declaration declaring an external type?
-isExternalType :: TypeDecl -> Bool
-isExternalType = trType (\_ _ _ cs -> null cs) (\_ _ _ _ -> False)
-
--- Update Operations
-
---- update type declaration
-updType :: (QName -> QName) ->
- (Visibility -> Visibility) ->
- ([TVarIndex] -> [TVarIndex]) ->
- ([ConsDecl] -> [ConsDecl]) ->
- (TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl
-updType fn fv fp fc fs = trType typ typesyn
- where
- typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs)
- typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn)
-
---- update name of type declaration
-updTypeName :: Update TypeDecl QName
-updTypeName f = updType f id id id id
-
---- update visibility of type declaration
-updTypeVisibility :: Update TypeDecl Visibility
-updTypeVisibility f = updType id f id id id
-
---- update type parameters of type declaration
-updTypeParams :: Update TypeDecl [TVarIndex]
-updTypeParams f = updType id id f id id
-
---- update constructor declarations of type declaration
-updTypeConsDecls :: Update TypeDecl [ConsDecl]
-updTypeConsDecls f = updType id id id f id
-
---- update synonym of type declaration
-updTypeSynonym :: Update TypeDecl TypeExpr
-updTypeSynonym = updType id id id id
-
--- Auxiliary Functions
-
---- update all qualified names in type declaration
-updQNamesInType :: Update TypeDecl QName
-updQNamesInType f
- = updType f id id (map (updQNamesInConsDecl f)) (updQNamesInTypeExpr f)
-
--- ConsDecl ------------------------------------------------------------------
-
--- Selectors
-
---- transform constructor declaration
-trCons :: (QName -> Int -> Visibility -> [TypeExpr] -> a) -> ConsDecl -> a
-trCons cons (Cons name arity vis args) = cons name arity vis args
-
---- get name of constructor declaration
-consName :: ConsDecl -> QName
-consName = trCons (\name _ _ _ -> name)
-
---- get arity of constructor declaration
-consArity :: ConsDecl -> Int
-consArity = trCons (\_ arity _ _ -> arity)
-
---- get visibility of constructor declaration
-consVisibility :: ConsDecl -> Visibility
-consVisibility = trCons (\_ _ vis _ -> vis)
-
---- get arguments of constructor declaration
-consArgs :: ConsDecl -> [TypeExpr]
-consArgs = trCons (\_ _ _ args -> args)
-
--- Update Operations
-
---- update constructor declaration
-updCons :: (QName -> QName) ->
- (Int -> Int) ->
- (Visibility -> Visibility) ->
- ([TypeExpr] -> [TypeExpr]) -> ConsDecl -> ConsDecl
-updCons fn fa fv fas = trCons cons
- where
- cons name arity vis args = Cons (fn name) (fa arity) (fv vis) (fas args)
-
---- update name of constructor declaration
-updConsName :: Update ConsDecl QName
-updConsName f = updCons f id id id
-
---- update arity of constructor declaration
-updConsArity :: Update ConsDecl Int
-updConsArity f = updCons id f id id
-
---- update visibility of constructor declaration
-updConsVisibility :: Update ConsDecl Visibility
-updConsVisibility f = updCons id id f id
-
---- update arguments of constructor declaration
-updConsArgs :: Update ConsDecl [TypeExpr]
-updConsArgs = updCons id id id
-
--- Auxiliary Functions
-
---- update all qualified names in constructor declaration
-updQNamesInConsDecl :: Update ConsDecl QName
-updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f))
-
--- TypeExpr ------------------------------------------------------------------
-
--- Selectors
-
---- 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)
- = tcons name (map (trTypeExpr tvar tcons functype) args)
-trTypeExpr tvar tcons functype (FuncType from to) = functype (f from) (f to)
- where
- f = trTypeExpr tvar tcons functype
-
--- Test Operations
-
---- is type expression a type variable?
-isTVar :: TypeExpr -> Bool
-isTVar = trTypeExpr (const True) (\_ _ -> False) (\_ _ -> False)
-
---- is type declaration a constructed type?
-isTCons :: TypeExpr -> Bool
-isTCons = trTypeExpr (const False) (\_ _ -> True) (\_ _ -> False)
-
---- is type declaration a functional type?
-isFuncType :: TypeExpr -> Bool
-isFuncType = trTypeExpr (const False) (\_ _ -> False) (\_ _ -> True)
-
--- Update Operations
-
---- update all type variables
-updTVars :: (TVarIndex -> TypeExpr) -> TypeExpr -> TypeExpr
-updTVars tvar = trTypeExpr tvar TCons FuncType
-
---- update all type constructors
-updTCons :: (QName -> [TypeExpr] -> TypeExpr) -> TypeExpr -> TypeExpr
-updTCons tcons = trTypeExpr TVar tcons FuncType
-
---- update all functional types
-updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
-updFuncTypes = trTypeExpr TVar TCons
-
--- Auxiliary Functions
-
---- get argument types from functional type
-argTypes :: TypeExpr -> [TypeExpr]
-argTypes (TVar _) = []
-argTypes (TCons _ _) = []
-argTypes (FuncType dom ran) = dom : argTypes ran
-
---- get result type from (nested) functional type
-resultType :: TypeExpr -> TypeExpr
-resultType (TVar n) = TVar n
-resultType (TCons name args) = TCons name args
-resultType (FuncType _ ran) = resultType ran
-
---- get indexes of all type variables
-allVarsInTypeExpr :: TypeExpr -> [TVarIndex]
-allVarsInTypeExpr = trTypeExpr (:[]) (const concat) (++)
-
---- rename variables in type expression
-rnmAllVarsInTypeExpr :: (TVarIndex -> TVarIndex) -> TypeExpr -> TypeExpr
-rnmAllVarsInTypeExpr = updTVars . (TVar .)
-
---- update all qualified names in type expression
-updQNamesInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr
-updQNamesInTypeExpr f = updTCons (TCons . f)
-
--- OpDecl --------------------------------------------------------------------
-
---- transform operator declaration
-trOp :: (QName -> Fixity -> Integer -> a) -> OpDecl -> a
-trOp op (Op name fix prec) = op name fix prec
-
--- Selectors
-
---- get name from operator declaration
-opName :: OpDecl -> QName
-opName = trOp (\name _ _ -> name)
-
---- get fixity of operator declaration
-opFixity :: OpDecl -> Fixity
-opFixity = trOp (\_ fix _ -> fix)
-
---- get precedence of operator declaration
-opPrecedence :: OpDecl -> Integer
-opPrecedence = trOp (\_ _ prec -> prec)
-
--- Update Operations
-
---- update operator declaration
-updOp :: (QName -> QName) ->
- (Fixity -> Fixity) ->
- (Integer -> Integer) -> OpDecl -> OpDecl
-updOp fn ff fp = trOp op
- where
- op name fix prec = Op (fn name) (ff fix) (fp prec)
-
---- update name of operator declaration
-updOpName :: Update OpDecl QName
-updOpName f = updOp f id id
-
---- update fixity of operator declaration
-updOpFixity :: Update OpDecl Fixity
-updOpFixity f = updOp id f id
-
---- update precedence of operator declaration
-updOpPrecedence :: Update OpDecl Integer
-updOpPrecedence = updOp id id
-
--- FuncDecl ------------------------------------------------------------------
-
---- transform function
-trFunc :: (QName -> Int -> Visibility -> TypeExpr -> Rule -> a) -> FuncDecl -> a
-trFunc func (Func name arity vis t rule) = func name arity vis t rule
-
--- Selectors
-
---- get name of function
-funcName :: FuncDecl -> QName
-funcName = trFunc (\name _ _ _ _ -> name)
-
---- get arity of function
-funcArity :: FuncDecl -> Int
-funcArity = trFunc (\_ arity _ _ _ -> arity)
-
---- get visibility of function
-funcVisibility :: FuncDecl -> Visibility
-funcVisibility = trFunc (\_ _ vis _ _ -> vis)
-
---- get type of function
-funcType :: FuncDecl -> TypeExpr
-funcType = trFunc (\_ _ _ t _ -> t)
-
---- get rule of function
-funcRule :: FuncDecl -> Rule
-funcRule = trFunc (\_ _ _ _ rule -> rule)
-
--- Update Operations
-
---- update function
-updFunc :: (QName -> QName) ->
- (Int -> Int) ->
- (Visibility -> Visibility) ->
- (TypeExpr -> TypeExpr) ->
- (Rule -> Rule) -> FuncDecl -> FuncDecl
-updFunc fn fa fv ft fr = trFunc func
- where
- func name arity vis t rule
- = Func (fn name) (fa arity) (fv vis) (ft t) (fr rule)
-
---- update name of function
-updFuncName :: Update FuncDecl QName
-updFuncName f = updFunc f id id id id
-
---- update arity of function
-updFuncArity :: Update FuncDecl Int
-updFuncArity f = updFunc id f id id id
-
---- update visibility of function
-updFuncVisibility :: Update FuncDecl Visibility
-updFuncVisibility f = updFunc id id f id id
-
---- update type of function
-updFuncType :: Update FuncDecl TypeExpr
-updFuncType f = updFunc id id id f id
-
---- update rule of function
-updFuncRule :: Update FuncDecl Rule
-updFuncRule = updFunc id id id id
-
--- Auxiliary Functions
-
---- is function externally defined?
-isExternal :: FuncDecl -> Bool
-isExternal = isRuleExternal . funcRule
-
---- get variable names in a function declaration
-allVarsInFunc :: FuncDecl -> [VarIndex]
-allVarsInFunc = allVarsInRule . funcRule
-
---- get arguments of function, if not externally defined
-funcArgs :: FuncDecl -> [VarIndex]
-funcArgs = ruleArgs . funcRule
-
---- get body of function, if not externally defined
-funcBody :: FuncDecl -> Expr
-funcBody = ruleBody . funcRule
-
-funcRHS :: FuncDecl -> [Expr]
-funcRHS f | not (isExternal f) = orCase (funcBody f)
- | otherwise = []
- where
- orCase e
- | isOr e = concatMap orCase (orExps e)
- | isCase e = concatMap orCase (map branchExpr (caseBranches e))
- | otherwise = [e]
-
---- rename all variables in function
-rnmAllVarsInFunc :: Update FuncDecl VarIndex
-rnmAllVarsInFunc = updFunc id id id id . rnmAllVarsInRule
-
---- update all qualified names in function
-updQNamesInFunc :: Update FuncDecl QName
-updQNamesInFunc f = updFunc f id id (updQNamesInTypeExpr f) (updQNamesInRule f)
-
---- update arguments of function, if not externally defined
-updFuncArgs :: Update FuncDecl [VarIndex]
-updFuncArgs = updFuncRule . updRuleArgs
-
---- update body of function, if not externally defined
-updFuncBody :: Update FuncDecl Expr
-updFuncBody = updFuncRule . updRuleBody
-
--- Rule ----------------------------------------------------------------------
-
---- transform rule
-trRule :: ([VarIndex] -> Expr -> a) -> (String -> a) -> Rule -> a
-trRule rule _ (Rule args e) = rule args e
-trRule _ ext (External s) = ext s
-
--- Selectors
-
---- get rules arguments if it's not external
-ruleArgs :: Rule -> [VarIndex]
-ruleArgs = trRule (\args _ -> args) failed
-
---- get rules body if it's not external
-ruleBody :: Rule -> Expr
-ruleBody = trRule (\_ e -> e) failed
-
---- get rules external declaration
-ruleExtDecl :: Rule -> String
-ruleExtDecl = trRule failed id
-
--- Test Operations
-
---- is rule external?
-isRuleExternal :: Rule -> Bool
-isRuleExternal = trRule (\_ _ -> False) (const True)
-
--- Update Operations
-
---- update rule
-updRule :: ([VarIndex] -> [VarIndex]) ->
- (Expr -> Expr) ->
- (String -> String) -> Rule -> Rule
-updRule fa fe fs = trRule rule ext
- where
- rule as e = Rule (fa as) (fe e)
- ext = External . fs
-
---- update rules arguments
-updRuleArgs :: Update Rule [VarIndex]
-updRuleArgs f = updRule f id id
-
---- update rules body
-updRuleBody :: Update Rule Expr
-updRuleBody f = updRule id f id
-
---- update rules external declaration
-updRuleExtDecl :: Update Rule String
-updRuleExtDecl = updRule id id
-
--- Auxiliary Functions
-
---- get variable names in a functions rule
-allVarsInRule :: Rule -> [VarIndex]
-allVarsInRule = trRule (\args body -> args ++ allVars body) (const [])
-
---- rename all variables in rule
-rnmAllVarsInRule :: Update Rule VarIndex
-rnmAllVarsInRule f = updRule (map f) (rnmAllVars f) id
-
---- update all qualified names in rule
-updQNamesInRule :: Update Rule QName
-updQNamesInRule = updRuleBody . updQNames
-
--- CombType ------------------------------------------------------------------
-
---- transform combination type
-trCombType :: a -> (Int -> a) -> a -> (Int -> a) -> CombType -> a
-trCombType fc _ _ _ FuncCall = fc
-trCombType _ fpc _ _ (FuncPartCall n) = fpc n
-trCombType _ _ cc _ ConsCall = cc
-trCombType _ _ _ cpc (ConsPartCall n) = cpc n
-
--- Test Operations
-
---- is type of combination FuncCall?
-isCombTypeFuncCall :: CombType -> Bool
-isCombTypeFuncCall = trCombType True (const False) False (const False)
-
---- is type of combination FuncPartCall?
-isCombTypeFuncPartCall :: CombType -> Bool
-isCombTypeFuncPartCall = trCombType False (const True) False (const False)
-
---- is type of combination ConsCall?
-isCombTypeConsCall :: CombType -> Bool
-isCombTypeConsCall = trCombType False (const False) True (const False)
-
---- is type of combination ConsPartCall?
-isCombTypeConsPartCall :: CombType -> Bool
-isCombTypeConsPartCall = trCombType False (const False) False (const True)
-
--- Auxiliary Functions
-
-missingArgs :: CombType -> Int
-missingArgs = trCombType 0 id 0 id
-
--- Expr ----------------------------------------------------------------------
-
--- Selectors
-
---- 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
-missingCombArgs = missingArgs . combType
-
---- 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
- Var _ -> True
- _ -> False
-
---- is expression a literal expression?
-isLit :: Expr -> Bool
-isLit e = case e of
- Lit _ -> True
- _ -> False
-
---- is expression combined?
-isComb :: Expr -> Bool
-isComb e = case e of
- Comb _ _ _ -> True
- _ -> False
-
---- is expression a let expression?
-isLet :: Expr -> Bool
-isLet e = case e of
- Let _ _ -> True
- _ -> False
-
---- is expression a declaration of free variables?
-isFree :: Expr -> Bool
-isFree e = case e of
- Free _ _ -> True
- _ -> False
-
---- is expression an or-expression?
-isOr :: Expr -> Bool
-isOr e = case e of
- Or _ _ -> True
- _ -> False
-
---- is expression a case expression?
-isCase :: Expr -> Bool
-isCase e = case e of
- Case _ _ _ _ -> True
- _ -> False
-
---- transform expression
-trExpr :: (VarIndex -> a) ->
- (Literal -> a) ->
- (CombType -> QName -> [a] -> a) ->
- ([(VarIndex,a)] -> a -> a) ->
- ([VarIndex] -> a -> a) ->
- (a -> a -> a) ->
- (SrcRef -> CaseType -> a -> [b] -> a) ->
- (Pattern -> a -> b) -> Expr -> a
-trExpr var _ _ _ _ _ _ _ (Var n) = var n
-
-trExpr _ lit _ _ _ _ _ _ (Lit l) = lit l
-
-trExpr var lit comb lt fr oR cas branch (Comb ct name args)
- = 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 (second f) bs) (f e)
- where
- f = trExpr var lit comb lt fr oR cas branch
-
-trExpr var lit comb lt fr oR cas branch (Free vs e)
- = fr vs (trExpr var lit comb lt fr oR cas branch e)
-
-trExpr var lit comb lt fr oR cas branch (Or e1 e2) = oR (f e1) (f e2)
- where
- 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)
- where
- f = trExpr var lit comb lt fr oR cas branch
-
--- Update Operations
-
---- update all variables in given expression
-updVars :: (VarIndex -> Expr) -> Expr -> Expr
-updVars var = trExpr var Lit Comb Let Free Or Case Branch
-
---- update all literals in given expression
-updLiterals :: (Literal -> Expr) -> Expr -> Expr
-updLiterals lit = trExpr Var lit Comb Let Free Or Case Branch
-
---- update all combined expressions in given expression
-updCombs :: (CombType -> QName -> [Expr] -> Expr) -> Expr -> Expr
-updCombs comb = trExpr Var Lit comb Let Free Or Case Branch
-
---- update all let expressions in given expression
-updLets :: ([(VarIndex,Expr)] -> Expr -> Expr) -> Expr -> Expr
-updLets lt = trExpr Var Lit Comb lt Free Or Case Branch
-
---- update all free declarations in given expression
-updFrees :: ([VarIndex] -> Expr -> Expr) -> Expr -> Expr
-updFrees fr = trExpr Var Lit Comb Let fr Or Case Branch
-
---- update all or expressions in given expression
-updOrs :: (Expr -> Expr -> Expr) -> Expr -> Expr
-updOrs oR = trExpr Var Lit Comb Let Free oR Case Branch
-
---- update all case expressions in given expression
-updCases :: (SrcRef -> CaseType -> Expr -> [BranchExpr] -> Expr) -> Expr -> Expr
-updCases cas = trExpr Var Lit Comb Let Free Or cas Branch
-
---- update all case branches in given expression
-updBranches :: (Pattern -> Expr -> BranchExpr) -> Expr -> Expr
-updBranches = trExpr Var Lit Comb Let Free Or Case
-
--- Auxiliary Functions
-
---- is expression a call of a function where all arguments are provided?
-isFuncCall :: Expr -> Bool
-isFuncCall e = isComb e && isCombTypeFuncCall (combType e)
-
---- is expression a partial function call?
-isFuncPartCall :: Expr -> Bool
-isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e)
-
---- is expression a call of a constructor?
-isConsCall :: Expr -> Bool
-isConsCall e = isComb e && isCombTypeConsCall (combType e)
-
---- is expression a partial constructor call?
-isConsPartCall :: Expr -> Bool
-isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e)
-
---- is expression fully evaluated?
-isGround :: Expr -> Bool
-isGround e
- = case e of
- Comb ConsCall _ args -> all isGround args
- _ -> isLit e
-
---- get all variables (also pattern variables) in expression
-allVars :: Expr -> [VarIndex]
-allVars expr = trExpr (:) (const id) comb lt fr (.) cas branch expr []
- where
- comb _ _ = foldr (.) id
- lt bs = (. foldr (.) id (map (\ (n,ns) -> (n:) . ns) bs))
- fr = (.) . (++)
- cas _ _ e bs = e . foldr (.) id bs
- branch = (.) . (++) . args
- args pat | isConsPattern pat = patArgs pat
- | otherwise = []
-
---- rename all variables (also in patterns) in expression
-rnmAllVars :: Update Expr VarIndex
-rnmAllVars f = trExpr (Var . f) Lit Comb lt (Free . map f) Or Case branch
- where
- lt = Let . map (first f)
- branch = Branch . updPatArgs (map f)
-
---- update all qualified names in expression
-updQNames :: Update Expr QName
-updQNames f = trExpr Var Lit comb Let Free Or Case (Branch . updPatCons f)
- where
- comb ct = Comb ct . f
-
--- BranchExpr ----------------------------------------------------------------
-
---- transform branch expression
-trBranch :: (Pattern -> Expr -> a) -> BranchExpr -> a
-trBranch branch (Branch p e) = branch p e
-
--- Selectors
-
---- get pattern from branch expression
-branchPattern :: BranchExpr -> Pattern
-branchPattern = trBranch (\p _ -> p)
-
---- get expression from branch expression
-branchExpr :: BranchExpr -> Expr
-branchExpr = trBranch (\_ e -> e)
-
--- Update Operations
-
---- update branch expression
-updBranch :: (Pattern -> Pattern) -> (Expr -> Expr) -> BranchExpr -> BranchExpr
-updBranch fp fe = trBranch branch
- where
- branch pat e = Branch (fp pat) (fe e)
-
---- update pattern of branch expression
-updBranchPattern :: Update BranchExpr Pattern
-updBranchPattern f = updBranch f id
-
---- update expression of branch expression
-updBranchExpr :: Update BranchExpr Expr
-updBranchExpr = updBranch id
-
--- Pattern -------------------------------------------------------------------
-
---- transform pattern
-trPattern :: (QName -> [VarIndex] -> a) -> (Literal -> a) -> Pattern -> a
-trPattern pattern _ (Pattern name args) = pattern name args
-trPattern _ lpattern (LPattern l) = lpattern l
-
--- Selectors
-
---- get name from constructor pattern
-patCons :: Pattern -> QName
-patCons = trPattern (\name _ -> name) failed
-
---- get arguments from constructor pattern
-patArgs :: Pattern -> [VarIndex]
-patArgs = trPattern (\_ args -> args) failed
-
---- get literal from literal pattern
-patLiteral :: Pattern -> Literal
-patLiteral = trPattern failed id
-
--- Test Operations
-
---- is pattern a constructor pattern?
-isConsPattern :: Pattern -> Bool
-isConsPattern = trPattern (\_ _ -> True) (const False)
-
--- Update Operations
-
---- update pattern
-updPattern :: (QName -> QName) ->
- ([VarIndex] -> [VarIndex]) ->
- (Literal -> Literal) -> Pattern -> Pattern
-updPattern fn fa fl = trPattern pattern lpattern
- where
- pattern name args = Pattern (fn name) (fa args)
- lpattern = LPattern . fl
-
---- update constructors name of pattern
-updPatCons :: (QName -> QName) -> Pattern -> Pattern
-updPatCons f = updPattern f id id
-
---- update arguments of constructor pattern
-updPatArgs :: ([VarIndex] -> [VarIndex]) -> Pattern -> Pattern
-updPatArgs f = updPattern id f id
-
---- update literal of pattern
-updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern
-updPatLiteral = updPattern id id
-
--- Auxiliary Functions
-
---- build expression from pattern
-patExpr :: Pattern -> Expr
-patExpr = trPattern (\ name -> Comb ConsCall name . map Var) Lit
-
-
--- | Get the type of an expression.
--- (Will only succeed if all VarIndices and QNames contain the
--- required type information. Make sure that the expression is processed by
--- Curry.ExtendedFlat.TypeInference.adjustTypeInfo.)
-typeofExpr :: Expr -> Maybe TypeExpr
-typeofExpr expr
- = case expr of
- Var vi -> typeofVar vi
- Lit l -> Just (typeofLiteral l)
- Comb _ qn as -> typeofQName qn >>= typeofApp as
- Free _ e -> typeofExpr e
- Let _ e -> typeofExpr e
- Or e1 e2 -> typeofExpr e1 `mplus` typeofExpr e2
- Case _ _ _ bs -> msum (map (typeofExpr . branchExpr) bs)
- where
- typeofApp :: [a] -> TypeExpr -> Maybe TypeExpr
- typeofApp [] t = Just t
- typeofApp (_:as) (FuncType _ t) = typeofApp as t
- typeofApp (_:_) (TVar _) = Nothing
- typeofApp (_:_) (TCons _ _) = Nothing
- -- ierr = error "internal error in typeofExpr: FuncType expected"
-
-
-typeofLiteral :: Literal -> TypeExpr
-typeofLiteral l
- = case l of
- Intc _ _ -> preludeType "Int"
- Floatc _ _ -> preludeType "Float"
- Charc _ _ -> preludeType "Char"
- where
- preludeType s = TCons (mkQName ("Prelude", s)) []
-
-
-
--- Function |fvs| returns a list containing the identifiers that
--- occur free in an expression. (Not to confuse with Curry's free
--- variables..)
-fvs :: Expr -> [VarIndex]
-fvs expr = case expr of
- Var v -> [v]
- Lit _ -> []
- Comb _ _ es -> foldr union [] (map fvs es)
- Let bs e -> foldr letFvs (fvs e) bs \\ map fst bs
- Free vs e -> fvs e \\ vs
- Or l r -> fvs l `union` fvs r
- Case _ _ e bs -> foldr branchFvs (fvs e) bs
- where
- letFvs (_,e) = union (fvs e)
- branchFvs (Branch p e) vs = (fvs e \\ pvars p) `union` vs
- pvars (Pattern _ vs) = vs
- pvars (LPattern _) = []
-
-
-
--- Is an expression in weak head normal form? Yes for literals,
--- constructor terms and unsaturated combinations.
-whnf :: Expr -> Bool
-whnf (Lit _) = True
-whnf (Comb t _ _) = not (isCombTypeFuncCall t)
-whnf _ = False
diff --git a/Curry/ExtendedFlat/LiftLetrec.hs b/Curry/ExtendedFlat/LiftLetrec.hs
deleted file mode 100644
--- a/Curry/ExtendedFlat/LiftLetrec.hs
+++ /dev/null
@@ -1,97 +0,0 @@
-{-
- Turn recursive data declarations into recursive
- function calls.
-
- Only single recursive declarations are transformed.
- Mutually recursive declarations are left unchanged.
- You should use transformation UnMutual first.
-
- (c) 2009, Holger Siegel.
--}
-
-module Curry.ExtendedFlat.LiftLetrec(liftLetrecProg) where
-
-import Data.List
-import Control.Monad.State
-import Data.Maybe
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-import Curry.ExtendedFlat.Type
-import Curry.ExtendedFlat.Goodies
-import Curry.ExtendedFlat.MonadicGoodies
-
-
-
-data LifterState = LifterState { modname :: String,
- currentFunc :: String,
- globals :: Set.Set QName,
- globalCounter :: Map.Map QName Int,
- localCounter :: Int,
- lifted :: Map.Map QName FuncDecl }
-
-
-type Bind = (VarIndex, Expr) -- (name, value)
-type LiftMonad = State LifterState
-
-
-liftLetrecProg :: Prog -> Prog
-liftLetrecProg prog = updProg id id id (++ fdecls) id prog'
- where state = LifterState {
- modname = progName prog,
- currentFunc = "anonymous",
- globals = Set.fromList g,
- globalCounter = Map.fromList $ zip g (repeat 1),
- localCounter = 0,
- lifted = Map.empty
- }
- g = allGlobals prog
- (prog', state') = runState (updProgFuncsM run prog) state
- fdecls = Map.elems (lifted state')
- run fdecl = do
- let fname = localName (funcName fdecl)
- modify (\st -> st { currentFunc = fname,
- localCounter = (maximum . map idxOf . allVarsInFunc) fdecl
- })
- fdecl' <- updFuncLetsM liftRecursion fdecl
- modify (\st -> st {currentFunc = "anonymous"})
- return fdecl'
-
-
-
-liftRecursion :: [Bind] -> Expr -> LiftMonad Expr
-liftRecursion [(b, rhs)] body
- | b `elem` fv = do globalcall <- mkLiftedFunction (typeofVar b) b rhs (fv \\ [b])
- return (Let [(b, globalcall)] body)
- | otherwise = return (Let [(b, rhs)] body)
- where fv = fvs rhs
-liftRecursion bs body = return (Let bs body)
-
-
-mkLiftedFunction :: Maybe TypeExpr -> VarIndex -> Expr -> [VarIndex] -> LiftMonad Expr
-mkLiftedFunction t v rhs fv
- = do name <- newGlobalName t
- st <- get
- let fcall = (Comb FuncCall name (map Var fv))
- let fdecl = Func name (length fv) Private (fromMaybe (TVar 0) t) (Rule fv (Let [(v,fcall)] rhs))
- put st { lifted = Map.insert name fdecl (lifted st),
- globals = Set.insert name (globals st)
- }
- return fcall
-
-
-newGlobalName :: Maybe TypeExpr -> LiftMonad QName
-newGlobalName t
- = do st <- get
- let qn = QName Nothing t (modname st) (currentFunc st)
- let counter = Map.findWithDefault 1 qn (globalCounter st)
- put st { globalCounter = Map.insert qn (counter + 1) (globalCounter st) }
- let qn' = QName Nothing t (modname st) (localName qn ++ "_" ++ show counter)
- if qn' `Set.member` globals st
- then newGlobalName t
- else return qn'
-
-
-allGlobals :: Prog -> [QName]
-allGlobals prog = [n | Func n _ _ _ _ <- fs]
- where fs = progFuncs prog
diff --git a/Curry/ExtendedFlat/MonadicGoodies.hs b/Curry/ExtendedFlat/MonadicGoodies.hs
deleted file mode 100644
--- a/Curry/ExtendedFlat/MonadicGoodies.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-
- Monadic transformations of ExtendedFlat programs.
-
- (c) 2009, Holger Siegel.
--}
-
-module Curry.ExtendedFlat.MonadicGoodies
- (UpdateM, postOrderM,
- updFuncExpsM, updProgFuncsM, updFuncLetsM) where
-
-import Control.Monad
-import Curry.ExtendedFlat.Type
-
-
-type UpdateM m a b = (b -> m b) -> a -> m a
-
-
-postOrderM :: Monad m => UpdateM m Expr Expr
-postOrderM f = po
- where po e@(Var _) = f e
- po e@(Lit _) = f e
- po (Comb t n es) = do es' <- mapM po es
- f (Comb t n es')
- po (Free vs e) = do e' <- po e
- f (Free vs e')
- po (Let bs e) = do bs' <- mapM poBind bs
- e' <- po e
- f (Let bs' e')
- po (Or l r) = liftM2 Or (po l) (po r) >>= f
- po (Case p t e bs) = do e' <- po e
- bs' <- mapM poBranch bs
- f (Case p t e' bs')
- poBind (v, rhs) = do rhs' <- po rhs
- return (v, rhs')
- poBranch (Branch p rhs) = do rhs' <- po rhs
- return (Branch p rhs')
-
-
-
-
-updFuncExpsM :: Monad m => UpdateM m FuncDecl Expr
-updFuncExpsM f (Func name arity visibility ftype (Rule vs e))
- = do e' <- postOrderM f e
- return (Func name arity visibility ftype (Rule vs e'))
-updFuncExpsM _ func@(Func _ _ _ _ (External _))
- = return func
-
-
-updProgFuncsM :: Monad m => UpdateM m Prog FuncDecl
-updProgFuncsM f (Prog name imps types funcs ops)
- = do funcs' <- mapM f funcs
- return (Prog name imps types funcs' ops)
-
-updFuncLetsM :: Monad m => ([(VarIndex, Expr)] -> Expr -> m Expr)
- -> FuncDecl -> m FuncDecl
-updFuncLetsM = updFuncExpsM . updExprLetsM
- where
- updExprLetsM f (Let bs e) = f bs e
- updExprLetsM _ e = return e
-
diff --git a/Curry/ExtendedFlat/Type.hs b/Curry/ExtendedFlat/Type.hs
deleted file mode 100644
--- a/Curry/ExtendedFlat/Type.hs
+++ /dev/null
@@ -1,484 +0,0 @@
-------------------------------------------------------------------------------
---- Library to support meta-programming in Curry.
----
---- This library contains a definition for representing FlatCurry programs
---- in Haskell (type "Prog").
----
---- @author Michael Hanus
---- @version September 2003
----
---- Version for Haskell (slightly modified):
---- December 2004, Martin Engelke (men@informatik.uni-kiel.de)
----
---- Added part calls for constructors, Bernd Brassel, August 2005
---- Added source references, Bernd Brassel, May 2009
-------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}
-
-module Curry.ExtendedFlat.Type(SrcRef,Prog(..),
- QName(..), qnOf,mkQName,
- Visibility(..),
- TVarIndex, TypeDecl(..), ConsDecl(..), TypeExpr(..),
- OpDecl(..), Fixity(..),
- VarIndex(..), mkIdx, incVarIndex,
- FuncDecl(..), Rule(..),
- CaseType(..), CombType(..), Expr(..), BranchExpr(..),
- Pattern(..), Literal(..),
- readFlatCurry, readFlatInterface, readFlat,
- writeFlatCurry,writeExtendedFlat,gshowsPrec
- ) where
-
-import Data.List(intersperse)
-import Control.Monad (liftM)
-import Data.Generics
- (Data (..), Typeable (..), Typeable2 (..), extQ, ext1Q, showConstr)
-import Data.Function(on)
-import System.FilePath
-
-import Curry.Base.Position (SrcRef)
-
-import Curry.Files.Filenames(flatName, extFlatName)
-import Curry.Files.PathUtils (writeModule, maybeReadModule)
-
-
-
-------------------------------------------------------------------------------
--- Definition of data types for representing FlatCurry programs:
--- =============================================================
-
---- Data type for representing a Curry module in the intermediate form.
---- A value of this data type has the form
----
---- (Prog modname imports typedecls functions opdecls translation_table)
----
---- where modname: name of this module,
---- imports: list of modules names that are imported,
---- typedecls, opdecls, functions, translation of type names
---- and constructor/function names: see below
-
-data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]
- deriving (Read, Show, Eq,Data,Typeable)
-
-
--------------------------------------------------------------------------
---- The data type for representing qualified names.
---- In FlatCurry all names are qualified to avoid name clashes.
---- The first component is the module name and the second component the
---- unqualified name as it occurs in the source program.
---- The additional information about source references and types should
---- be invisible for the normal usage of QName.
--------------------------------------------------------------------------
-
-data QName = QName {srcRef :: Maybe SrcRef,
- typeofQName :: Maybe TypeExpr,
- modName :: String,
- localName :: String} deriving (Data,Typeable)
-
-
-instance Read QName where
- readsPrec d r =
- [ (QName r' t m n, s) | ((r', t, m, n),s) <- readsPrec d r ]
- ++ [ (mkQName nm,s) | (nm,s) <- readsPrec d r ]
-
-
-instance Show QName where
- showsPrec d (QName r t m n)
- = showsPrec d (r,t,m,n)
-
-instance Eq QName where (==) = (==) `on` qnOf
-
-instance Ord QName where compare = compare `on` qnOf
-
-mkQName :: (String,String) -> QName
-mkQName = uncurry (QName Nothing Nothing)
-
-qnOf :: QName -> (String,String)
-qnOf QName{modName=m,localName=n} = (m,n)
-
-
--------------------------------------------------------------------------
---- The data type for representing variable names.
---- The additional information should
---- be invisible for the normal usage of VarIndex.
--------------------------------------------------------------------------
-
-data VarIndex = VarIndex {
- typeofVar :: Maybe TypeExpr,
- idxOf :: Int
- } deriving (Data,Typeable)
-
-onIndex :: (Int -> Int) -> VarIndex -> VarIndex
-onIndex f (VarIndex{ typeofVar = t, idxOf = x})
- = VarIndex t (f x)
-
-onIndexes :: (Int ->Int -> Int) -> VarIndex -> VarIndex -> VarIndex
-onIndexes g x = VarIndex (typeofVar x) . (g `on` idxOf) x
-
-mkIdx :: Int -> VarIndex
-mkIdx = VarIndex Nothing
-
-
-instance Read VarIndex where
- readsPrec d r =
- [ (mkIdx i,s) | (i,s) <- readsPrec d r ]
- ++ [ (VarIndex t i,s) | ((t,i),s) <- readsPrec d r ]
-
-instance Show VarIndex where
- showsPrec d (VarIndex t i)= showsPrec d (t,i)
-
-instance Eq VarIndex where
- (==) = (==) `on` idxOf
-
-instance Ord VarIndex where
- compare = compare `on` idxOf
-
-instance Num VarIndex where
- (+) = onIndexes (+)
- (*) = onIndexes (*)
- (-) = onIndexes (-)
- abs = onIndex abs
- signum = onIndex signum
- fromInteger = mkIdx . fromInteger
-
-incVarIndex :: VarIndex -> Int -> VarIndex
-incVarIndex vi n = vi { idxOf = n + idxOf vi }
-
-------------------------------------------------------------
---- Data type to specify the visibility of various entities.
-------------------------------------------------------------
-
-data Visibility = Public -- public (exported) entity
- | Private -- private entity
- deriving (Read, Show, Eq,Data,Typeable)
-
---- The data type for representing type variables.
---- They are represented by (TVar i) where i is a type variable index.
-
-type TVarIndex = Int
-
---- Data type for representing definitions of algebraic data types.
----
---- A data type definition of the form
----
---- data t x1...xn = ...| c t1....tkc |...
----
---- is represented by the FlatCurry term
----
---- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])
----
---- where each ij is the index of the type variable xj
----
---- Note: the type variable indices are unique inside each type declaration
---- and are usually numbered from 0
----
---- Thus, a data type declaration consists of the name of the data type,
---- a list of type parameters and a list of constructor declarations.
----
-
-data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl]
- | TypeSyn QName Visibility [TVarIndex] TypeExpr
- deriving (Read, Show, Eq,Data,Typeable)
-
---- A constructor declaration consists of the name and arity of the
---- constructor and a list of the argument types of the constructor.
-
-data ConsDecl = Cons QName Int Visibility [TypeExpr]
- deriving (Read, Show, Eq,Data,Typeable)
-
-
---- Data type for type expressions.
---- A type expression is either a type variable, a function type,
---- or a type constructor application.
----
---- Note: the names of the predefined type constructors are
---- "Int", "Float", "Bool", "Char", "IO", "Success",
---- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
-
-data TypeExpr =
- TVar !TVarIndex -- type variable
- | FuncType TypeExpr TypeExpr -- function type t1->t2
- | TCons QName [TypeExpr] -- type constructor application
- deriving (Read, Show, Eq,Data,Typeable) -- TCons module name typeargs
-
-
---- Data type for operator declarations.
---- An operator declaration "fix p n" in Curry corresponds to the
---- FlatCurry term (Op n fix p).
---- Note: the constructor definition of 'Op' differs from the original
---- PAKCS definition using Haskell type 'Integer' instead of 'Int'
---- for representing the precedence.
-
-data OpDecl = Op QName Fixity Integer deriving (Read, Show, Eq,Data,Typeable)
-
---- Data types for the different choices for the fixity of an operator.
-
-data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Read, Show, Eq,Data,Typeable)
-
-
---- Data type for representing object variables.
---- Object variables occurring in expressions are represented by (Var i)
---- where i is a variable index.
-
---- Data type for representing function declarations.
----
---- A function declaration in FlatCurry is a term of the form
----
---- (Func name arity type (Rule [i_1,...,i_arity] e))
----
---- and represents the function "name" with definition
----
---- name :: type
---- name x_1...x_arity = e
----
---- where each i_j is the index of the variable x_j
----
---- Note: the variable indices are unique inside each function declaration
---- and are usually numbered from 0
----
---- External functions are represented as (Func name arity type (External s))
---- where s is the external name associated to this function.
----
---- Thus, a function declaration consists of the name, arity, type, and rule.
----
-
-data FuncDecl = Func QName Int Visibility TypeExpr Rule
- deriving (Read, Show, Eq,Data,Typeable)
-
-
---- A rule is either a list of formal parameters together with an expression
---- or an "External" tag.
-
-data Rule = Rule [VarIndex] Expr
- | External String
- deriving (Read, Show, Eq,Data,Typeable)
-
---- Data type for classifying case expressions.
---- Case expressions can be either flexible or rigid in Curry.
-
-data CaseType = Rigid | Flex deriving (Read, Show, Eq,Data,Typeable)
-
---- Data type for classifying combinations
---- (i.e., a function/constructor applied to some arguments).
---- @cons FuncCall - a call to a function all arguments are provided
---- @cons ConsCall - a call with a constructor at the top,
---- all arguments are provided
---- @cons FuncPartCall - a partial call to a function
---- (i.e., not all arguments are provided)
---- where the parameter is the number of
---- missing arguments
---- @cons ConsPartCall - a partial call to a constructor along with
---- number of missing arguments
-
-data CombType = FuncCall
- | ConsCall
- | FuncPartCall Int
- | ConsPartCall Int deriving (Read, Show, Eq,Data,Typeable)
-
---- Data type for representing expressions.
----
---- Remarks:
----
---- 1. if-then-else expressions are represented as function calls:
---- (if e1 then e2 else e3)
---- is represented as
---- (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])
----
---- 2. Higher order applications are represented as calls to the (external)
---- function "apply". For instance, the rule
---- app f x = f x
---- is represented as
---- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))
----
---- 3. A conditional rule is represented as a call to an external function
---- "cond" where the first argument is the condition (a constraint).
---- For instance, the rule
---- equal2 x | x=:=2 = success
---- is represented as
---- (Rule [0]
---- (Comb FuncCall ("Prelude","cond")
---- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],
---- Comb FuncCall ("Prelude","success") []]))
----
---- 4. Functions with evaluation annotation "choice" are represented
---- by a rule whose right-hand side is enclosed in a call to the
---- external function "Prelude.commit".
---- Furthermore, all rules of the original definition must be
---- represented by conditional expressions (i.e., (cond [c,e]))
---- after pattern matching.
---- Example:
----
---- m eval choice
---- m [] y = y
---- m x [] = x
----
---- is translated into (note that the conditional branches can be also
---- wrapped with Free declarations in general):
----
---- Rule [0,1]
---- (Comb FuncCall ("Prelude","commit")
---- [Or (Case Rigid (Var 0)
---- [(Pattern ("Prelude","[]") []
---- (Comb FuncCall ("Prelude","cond")
---- [Comb FuncCall ("Prelude","success") [],
---- Var 1]))] )
---- (Case Rigid (Var 1)
---- [(Pattern ("Prelude","[]") []
---- (Comb FuncCall ("Prelude","cond")
---- [Comb FuncCall ("Prelude","success") [],
---- Var 0]))] )])
----
---- Operational meaning of (Prelude.commit e):
---- evaluate e with local search spaces and commit to the first
---- (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c
---- is satisfied
----
---- @cons Var - variable (represented by unique index)
---- @cons Lit - literal (Integer/Float/Char constant)
---- @cons Comb - application (f e1 ... en) of function/constructor f
---- with n<=arity(f)
---- @cons Free - introduction of free local variables
---- @cons Or - disjunction of two expressions (used to translate rules
---- with overlapping left-hand sides)
---- @cons Case - case distinction (rigid or flex)
-
-data Expr = Var VarIndex
- | Lit Literal
- | Comb CombType QName [Expr]
- | Free [VarIndex] Expr
- | Let [(VarIndex,Expr)] Expr
- | Or Expr Expr
- | Case SrcRef CaseType Expr [BranchExpr]
- deriving (Read, Show, Eq,Data,Typeable)
-
-
---- Data type for representing branches in a case expression.
----
---- Branches "(m.c x1...xn) -> e" in case expressions are represented as
----
---- (Branch (Pattern (m,c) [i1,...,in]) e)
----
---- where each ij is the index of the pattern variable xj, or as
----
---- (Branch (LPattern (Intc i)) e)
----
---- for integers as branch patterns (similarly for other literals
---- like float or character constants).
----
-
-data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq,Data,Typeable)
-
---- Data type for representing patterns in case expressions.
-
-data Pattern = Pattern QName [VarIndex]
- | LPattern Literal
- deriving (Read, Show, Eq,Data,Typeable)
-
---- Data type for representing literals occurring in an expression
---- or case branch. It is either an integer, a float, or a character constant.
---- Note: the constructor definition of 'Intc' differs from the original
---- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'
---- to provide an unlimited range of integer numbers. Furthermore
---- float values are represented with Haskell type 'Double' instead of
---- 'Float'.
-
-data Literal = Intc SrcRef Integer
- | Floatc SrcRef Double
- | Charc SrcRef Char
- deriving (Read, Show, Eq,Data,Typeable)
-
-
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
--- Reads an ExtendedFlat file (extension ".efc") and returns the corresponding
--- FlatCurry program term (type 'Prog') as a value of type 'Maybe'.
-readFlatCurry :: FilePath -> IO (Maybe Prog)
-readFlatCurry fn
- = do let filename = flatName fn
- readFlat filename
-
--- Reads a FlatInterface file (extension ".fint") and returns the
--- corresponding term (type 'Prog') as a value of type 'Maybe'.
-readFlatInterface :: String -> IO (Maybe Prog)
-readFlatInterface fn
- = do let filename = replaceExtension fn ".fint"
- readFlat filename
-
--- Reads a Flat file and returns the corresponding term (type 'Prog') as
--- a value of type 'Maybe'.
-readFlat :: FilePath -> IO (Maybe Prog)
-readFlat = liftM (fmap read) . maybeReadModule
-
--- Writes a FlatCurry program term into a file.
--- If the flag is set, it will be the hidden .curry sub directory.
-writeFlatCurry :: Bool -> String -> Prog -> IO ()
-writeFlatCurry inHiddenSubdir filename prog
- = writeModule inHiddenSubdir filename (showFlatCurry' False prog)
-
--- Writes a FlatCurry program term with source references into a file.
--- If the flag is set, it will be the hidden .curry sub directory.
-writeExtendedFlat :: Bool -> String -> Prog -> IO ()
-writeExtendedFlat inHiddenSubdir filename prog =
- writeModule inHiddenSubdir (extFlatName filename) (showFlatCurry' True prog)
-
-showFlatCurry' :: Bool -> Prog -> String
-showFlatCurry' b x = gshowsPrec b False x ""
-
-gshowsPrec :: Data a => Bool -> Bool -> a -> ShowS
-gshowsPrec showType d =
- genericShowsPrec d `ext1Q` showsList
- `ext2Q` showsTuple
- `extQ` (const id :: SrcRef -> ShowS)
- `extQ` (const id :: [SrcRef] -> ShowS)
- `extQ` (shows :: String -> ShowS)
- `extQ` (shows :: Char -> ShowS)
- `extQ` showsQName d
- `extQ` showsVarIndex d
-
- where
- showsQName :: Bool -> QName -> ShowS
- showsQName d' qn@QName{modName=m,localName=n} =
- if showType then showParen d' (shows qn{srcRef=Nothing})
- else shows (m,n)
-
- showsVarIndex :: Bool -> VarIndex -> ShowS
- showsVarIndex d'
- | showType = showParen d' . shows
- | otherwise = shows . idxOf
-
- genericShowsPrec :: Data a => Bool -> a -> ShowS
- genericShowsPrec d' t = let args = intersperse (showChar ' ') $
- gmapQ (gshowsPrec showType True) t in
- showParen (d' && not (null args)) $
- showString (showConstr (toConstr t)) .
- (if null args then id else showChar ' ') .
- foldr (.) id args
-
- showsList :: Data a => [a] -> ShowS
- showsList xs = showChar '[' .
- foldr (.) (showChar ']')
- (intersperse (showChar ',') $
- map (gshowsPrec showType False) xs)
-
-
- showsTuple :: (Data a,Data b) => (a,b) -> ShowS
- showsTuple (x,y) = showChar '(' .
- gshowsPrec showType False x .
- showChar ',' .
- gshowsPrec showType False y .
- showChar ')'
-
-
-newtype Q r a = Q (a -> r)
-
-ext2Q :: (Data d, Typeable2 t) => (d -> q) ->
- (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
-ext2Q def ext arg =
- case dataCast2 (Q ext) of
- Just (Q ext') -> ext' arg
- Nothing -> def arg
-
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
diff --git a/Curry/ExtendedFlat/TypeInference.hs b/Curry/ExtendedFlat/TypeInference.hs
deleted file mode 100644
--- a/Curry/ExtendedFlat/TypeInference.hs
+++ /dev/null
@@ -1,410 +0,0 @@
-{- |The 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.
-
- (c) 2009, Holger Siegel.
--}
-
-{-# LANGUAGE FlexibleContexts, PatternGuards #-}
-
-module Curry.ExtendedFlat.TypeInference
- ( dispType, adjustTypeInfo, labelVarsWithTypes,uniqueTypeIndices
- , genEquations
- ) where
-
-
-import Control.Monad.State
-import Control.Monad.Reader
-import qualified Data.IntMap as IntMap
-import Data.Maybe
-import Text.PrettyPrint.HughesPJ
-
-import Curry.ExtendedFlat.Type
-import Curry.ExtendedFlat.Goodies
-
--- import Debug.Trace
-
-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. -}
-adjustTypeInfo :: Prog -> Prog
-adjustTypeInfo = genEquations . uniqueTypeIndices . labelVarsWithTypes
-
--- |Displays a 'TypeExpr' as a 'String'
-dispType :: TypeExpr -> String
-dispType = render . prettyType
-
-prettyType :: TypeExpr -> Doc
-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 :: ((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
- where po e@(Var _) = f e
- po e@(Lit _) = f e
- po (Comb t n es) = do es' <- mapM po es
- f (Comb t n es')
- po (Free vs e) = do e' <- po e
- f (Free vs e')
- po (Let bs e) = do bs' <- mapM poBind bs
- e' <- po e
- f (Let bs' e')
- po (Or l r) = liftM2 Or (po l) (po r) >>= f
- po (Case p t e bs) = do e' <- po e
- bs' <- mapM poBranch bs
- f (Case p t e' bs')
- poBind (v, rhs) = do rhs' <- po rhs
- return (v, rhs')
- 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
- po (FuncType t1 t2) = do t1' <- po t1
- t2' <- po t2
- f (FuncType t1' t2')
- 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
-
--- ----------------------------------------------------------------------
--- ----------------------------------------------------------------------
-
-type TDictM = ReaderT TypeMap (State Int)
-
--- | All identifiers that do not have type annotations are
--- labelled with new type variables
-labelVarsWithTypes :: Prog -> Prog
-labelVarsWithTypes = updProgFuncs updateFunc
- where
- updateFunc = map (\func -> let maxtvi = maxFuncTV func + 1
- in trFunc (foo maxtvi) func)
- 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 ]
- in Func qn arity visty te (Rule vs expr')
-
- po :: Expr -> TDictM Expr
- -- type information from vi is superseded by type information
- -- from the map. This is okay in the current context, but for
- -- general type inference this would result in loss of information.
- -- (Fix by unifying both types in a later version)
- po e@(Var vi)
- = do vt <- asks (IntMap.lookup $ idxOf vi)
- trace' ("labelVarsWithTypes " ++ show e ++" :: "++ show vt)(
- case vt of
- Just t -> return (Var vi { typeofVar = Just t })
- Nothing -> case typeofVar vi of
- Nothing -> error $ "no type for var " ++ show e
- _ -> liftM Var (poVarIndex vi))
- po e@(Lit _)
- = return e
- po (Comb t n es)
- = do es' <- mapM po es
- n' <- poQName n
- return (Comb t n' es')
- po (Free vs e)
- = do vs' <- mapM poVarIndex vs
- e' <- po e
- return (Free vs' e')
- po (Let bs e)
- = do let (vs, es) = unzip bs
- vs' <- mapM poVarIndex vs
- withVS vs' (do es' <- mapM po es
- e' <- po e
- return (Let (zip vs' es') e'))
- po (Or l r)
- = liftM2 Or (po l) (po r)
- po (Case p t e bs)
- = do e' <- po e
- bs' <- mapM poBranch bs
- return (Case p t e' bs')
-
- poBranch :: BranchExpr -> TDictM BranchExpr
- 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)
- = do rhs' <- po e
- return (Branch (LPattern l) rhs')
-
- poVarIndex :: VarIndex -> TDictM VarIndex
- poVarIndex vi
- = do t <- maybe (lift$freshTVar) return . typeofVar $ vi
- return vi{typeofVar = Just t }
-
- poQName :: QName -> TDictM QName
- poQName qn
- = do t <- maybe (lift$freshTVar)
- return . typeofQName $ qn
- return qn{typeofQName = Just t }
-
- withVS :: MonadReader TypeMap m => [VarIndex] -> m a -> m a
- withVS vs = local (\ m -> foldr (\ v -> IntMap.insert (idxOf v) (fromJust $ typeofVar v)) m vs)
-
--- ----------------------------------------------------------------------
--- ----------------------------------------------------------------------
-
--- | Type variables that occur in the type annotations of QNames
--- are replaced by newly introduced type variables, so that further
--- unification steps will not interfere with parametric polymorphism
-uniqueTypeIndices :: Prog -> Prog
-uniqueTypeIndices = updProgFuncs (map updateFunc)
- where
- updateFunc func = let firstfree = maxFuncTV func + 1
- in updFuncRule (trRule (ruleFoo firstfree) External) func
- ruleFoo firstfree args expr
- = let expr' = evalState (postOrderExpr relabelTypes expr) firstfree
- in Rule args expr'
-
-relabelTypes :: Expr -> State TVarIndex Expr
-relabelTypes (Comb ct qname args)
- = do t' <- case typeofQName qname of
- Just lt -> relabelType lt
- Nothing -> freshTVar
- return (Comb ct qname {typeofQName = Just t'} args)
-relabelTypes (Var v)
- | typeofVar v == Nothing
- = do t <- freshTVar
- return (Var v{typeofVar = Just t})
-relabelTypes (Case p t e bs)
- = do bs' <- mapM relabelPatType bs
- return (Case p t e bs')
- 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')
- relabelPatType be = return be
-relabelTypes t = return t
-
-relabelType :: TypeExpr -> State TVarIndex TypeExpr
-relabelType t = evalStateT (visitTVars typeFoo t) IntMap.empty
- where typeFoo i = do m <- get
- case IntMap.lookup i m of
- Just v -> return v
- Nothing -> do v <- lift freshTVar
- modify (IntMap.insert i v)
- return v
-
-
--- ----------------------------------------------------------------------
--- ----------------------------------------------------------------------
-
-type TypeMap = IntMap.IntMap TypeExpr
-
-type EqnMonad = StateT TypeMap (State TVarIndex)
-
-
--- | Specialises all type variables (part of adjustTypeInfo)
-genEquations :: Prog -> Prog
-genEquations = updProgFuncs updateFunc
- where
- updateFunc = map (\func -> let maxtvi = maxFuncTV func + 1
- in trFunc (foo maxtvi) func)
- 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'
- 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
- tqn <- qnType qn
- _ <- tqn =:= foldr FuncType resultType' argTypes'
- return resultType'
-
- letEqn :: ([(VarIndex, EqnMonad TypeExpr)] -> EqnMonad TypeExpr -> EqnMonad TypeExpr)
- letEqn bs = (mapM_ bindEqn bs >>)
-
- frEqn _ e = e
-
- orEqn l r = do l' <- l
- r' <- r
- l' =:= r'
-
- casEqn :: SrcRef -> CaseType -> EqnMonad TypeExpr -> [EqnMonad (Pattern, TypeExpr)] -> EqnMonad TypeExpr
- casEqn _ _ scr [] = scr >> (lift$freshTVar)
- casEqn _ _ scr ps = do scrt <- scr
- -- unify patterns with scrutinee
- branches <- sequence ps
- let pats = map fst branches
- let (p:ps') = map snd branches
- mapM_ (unifLhs scrt) pats
- -- foldM (\l r -> unifLhs scrt r >>= (=:= l)) scrt pats
- -- unify right hand sides
- foldM (=:=) p ps'
-
- unifLhs scrt (LPattern lit)
- = typeofLiteral lit =:= scrt
- unifLhs scrt (Pattern qn vs)
- = do qnt <- qnType qn
- -- FIXME: Variablentypen in Map eintragen!!!
- argTypes' <- mapM varIndexType vs
- qnt =:= foldr FuncType scrt argTypes'
-
-
- branchEqn :: Pattern -> EqnMonad TypeExpr -> EqnMonad (Pattern, TypeExpr)
- branchEqn p e = do trhs <- e
- return (p, trhs)
-
- bindEqn :: (VarIndex, EqnMonad TypeExpr) -> EqnMonad TypeExpr
- bindEqn (vi, rhs) = do vit <- varIndexType vi
- rvi <- rhs
- vit =:= rvi
-
-
-unify :: TypeExpr -> TypeExpr -> TypeMap -> TypeMap
--- t =:= u = return t
-
-unify (TVar i) t tm
- | Just s <- IntMap.lookup i tm
- = unify s t tm
-unify s (TVar j) tm
- | Just t <- IntMap.lookup j tm
- = unify s t tm
-unify s@(TVar i) t@(TVar j) tm
- | i == j = tm
- | i < j = IntMap.insert j s tm
- | i > j = IntMap.insert i t tm
-unify (TVar i) t tm
- = IntMap.insert i t tm
-unify s (TVar j) tm
- = IntMap.insert j s tm
-
-unify (FuncType f x) (FuncType g y) tm
- = unify x y (unify f g tm)
-unify (TCons m as) (TCons n bs) tm
- | m == n = foldr ($) tm (zipWith unify as bs)
-unify s t _
- = error . render $
- text "Types differ: " <+> prettyType s <+> text "/=" <+> prettyType t
-
-
-(=:=) :: TypeExpr -> TypeExpr -> EqnMonad TypeExpr
-a =:= b = modify (unify a b) >> return a
-
-
-varIndexType :: VarIndex -> EqnMonad TypeExpr
-varIndexType = maybe (lift$freshTVar) return . typeofVar
-
-
-qnType :: QName -> EqnMonad TypeExpr
-qnType = maybe (lift$freshTVar) return . typeofQName
-
-
-freshTVar :: MonadState Int m => m TypeExpr
-freshTVar = do nextIdx <- get
- modify succ
- return (TVar nextIdx)
-
-
----------------------------------------------------------------------
-
-maxFuncTV :: FuncDecl -> TVarIndex
-maxFuncTV = trFunc (\qn _ _ te r -> max (maxQNameTV qn) (max (maxTypeTV te) (maxRuleTV r)))
- where
- maxRuleTV = trRule (\vis e -> maximum (maxExprTV e : map maxVarIndexTV vis)) (const (-1))
-
- maxExprTV :: Expr -> Int
- maxExprTV = trExpr var lit comb lt fr max cas branch
- where var = maxVarIndexTV
- lit = const (-1)
- comb _ qn ms = maximum (maxQNameTV qn : ms)
- lt bs e = maximum (e : map maxBindTV bs)
- fr vs e = maximum (e : map maxVarIndexTV vs)
- cas _ _ e ps = maximum (e : ps)
- branch p e = max e (maxPatternTV p)
-
- maxQNameTV = maybe (-1) maxTypeTV . typeofQName
-
- maxVarIndexTV = maybe (-1) maxTypeTV . typeofVar
-
- maxBindTV (vi, e) = max e (maxVarIndexTV vi)
-
- maxPatternTV (Pattern qn vis) = maximum (maxQNameTV qn : map maxVarIndexTV vis)
- maxPatternTV (LPattern _) = -1
-
- maxTypeTV = trTypeExpr id tapp max
- where tapp _ args = maximum (-1:args)
-
---------------------
-
-
-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')
-
-
--- boilerplate
-specInRule :: TypeMap -> Rule -> Rule
-specInRule = modifyType . specialiseType
-
-
-
--- boilerplate
-modifyType :: (TypeExpr -> TypeExpr) -> Rule -> Rule
-modifyType f = updRule (map specInVarIndex) specInExpr id
- where specInExpr
- = trExpr var Lit comb letexp free Or Case alt
- var = Var . specInVarIndex
- comb ct
- = Comb ct . specInQName
- letexp
- = Let . map specInBind
- free
- = Free . map specInVarIndex
- alt
- = Branch . specInPattern
-
- specInBind (vi, e)
- = (specInVarIndex vi, e)
-
- specInPattern (Pattern qn vis)
- = Pattern (specInQName qn) (map specInVarIndex vis)
- specInPattern p = p
-
- specInVarIndex vi
- = vi { typeofVar = fmap f (typeofVar vi)}
-
- specInQName qn
- = qn { typeofQName = fmap f (typeofQName qn)}
-
-
-
diff --git a/Curry/ExtendedFlat/UnMutual.hs b/Curry/ExtendedFlat/UnMutual.hs
deleted file mode 100644
--- a/Curry/ExtendedFlat/UnMutual.hs
+++ /dev/null
@@ -1,236 +0,0 @@
-{-# LANGUAGE DoRec #-}
-
-{-
- Turns mutually recursive declarations into a single recursive
- declaration, of a tuple value, trying to minimize the number
- of the tuple. This is an implementation of the algorithm described in
- http://www.informatik.uni-kiel.de/~mh/lehre/diplomarbeiten/siegel.pdf
-
- (c) 2009, Holger Siegel.
--}
-module Curry.ExtendedFlat.UnMutual(unMutualProg) where
-
-import Data.Graph
--- import Data.Function(on)
-import Data.Maybe
-import Data.List
-import Control.Monad.State
-
-import Curry.Base.Position(noRef)
-import Curry.ExtendedFlat.Type
-import Curry.ExtendedFlat.Goodies
-import Curry.ExtendedFlat.MonadicGoodies
-
-
-type Bind = (VarIndex, Expr) -- (name, value)
-
-newtype UnMutualState = UnMutualState { localCounter :: Int }
-
-
-type UnMutualMonad = State UnMutualState
-
-
-unMutualProg :: Prog -> Prog
-unMutualProg p = evalState (updProgFuncsM
- (\fdecl -> do
- modify (\st -> st { localCounter = (maximum . map idxOf . allVarsInFunc) fdecl})
- updFuncLetsM rmMutualRecursion fdecl)
- p) (UnMutualState 1000)
-
-rmMutualRecursion :: [Bind] -> Expr -> UnMutualMonad Expr
-rmMutualRecursion bs body
- | allWhnf bs || length bs <= 1
- = return (Let bs body)
- | otherwise
- = do
- rec (body', bound, fbs) <- partitionBinds (fvs body) sccs (body, mkTuple fbs, [])
- mkSingleLet body' bound fbs
- where fvsGraph = depGraph bs
- sccs = sortSccs fvsGraph
-
-
-mkSingleLet :: Expr -> Expr -> [VarIndex] -> UnMutualMonad Expr
-mkSingleLet e2 e1 [v]
- = return (Let [(v, e1)] e2)
-mkSingleLet body bound fbs
- = do recname <- newLocalName (Just fbsType)
- bound' <- mkFbSelectors recname bound
- body' <- mkFbSelectors recname body
-
- return (Let [(recname, bound')] body')
- where
- fbsType = TCons (mkQName tuplecon) (map (fromJust . typeofVar) fbs)
- tuplecon = ("Prelude", "(" ++ replicate (length fbs -1 ) ',' ++ ")")
- mkFbSelectors recname b = foldM (mkSelector recname)b fbs
- mkSelector recname b v = nonrecLet v (mkSel (Var recname) v fbs) b
-
-
--- Some self-explaining helper functions:
-
-
-nonrecLet :: VarIndex -> Expr -> Expr -> UnMutualMonad Expr
-nonrecLet x e1 e2
- | x `elem` allVars e1
- = do vi <- newLocalName (typeofVar x)
- let e2' = subst x (Var vi) e2
- return (Let [(vi,e1)] e2')
- | otherwise = return (Let [(x,e1)] e2)
-
-
-mkTuple :: [VarIndex] -> Expr
-mkTuple [e] = Var e
-mkTuple es = Comb ConsCall (mkTupleConstr es) $ map Var es
-
-
-mkTupleConstr :: [a] -> QName
-mkTupleConstr arity = curry mkQName "Prelude" ("(" ++ replicate (length arity-1) ',' ++ ")")
-
-mkSel :: Expr -> VarIndex -> [VarIndex] -> Expr
-mkSel e v vs = Case noRef Rigid e [Branch pat (Var v)]
- where pat = Pattern tcon vs
- tcon = mkTupleConstr vs
-
-
-allWhnf :: [Bind] -> Bool
-allWhnf = all (whnf . snd)
-
-{-
-The type |FvsNode| stands for a single node in a dependency graph.
-It contains the binding, i.e. the identifier and the right hand side, as well
-as a list of the identifiers the right hand side refers to.
-
-Function |depGraph| turns a list of bindings into a dependency graph.
-
-Function |sortSccs| calculates a list of strongly connected components
-with the help of the library function |stronglyConnCompR|.
-In contrast to the list of SCCs returned from this function,
-the list of SCCs returned by |sortSccs| is in reversed order.
-This is required, beacuase we start to process nested
-declarations at the innermost binding.
--}
-
-type FvsNode = (Bind, VarIndex, [VarIndex])
-
-depGraph :: [Bind] -> [FvsNode]
-depGraph = map (\(x, e) -> ((x, e), x, fvs e))
-
-
-sortSccs :: [FvsNode] -> [SCC FvsNode]
-sortSccs = reverse . stronglyConnCompR
-
-
-{-
-Function |partitionBinds| takes the following arguments: A list of identifier that occur
-in the body of the declaration, a sorted list of strongy connected components,
-a 3-tuple consising of the body of the declaration, a tuple expression that contains the
-feedback variables, and the list of identifiers that are already added to the feedback set.
-It returns an updated version of that 3-tuple, in which the body expression is 'surrounded'
-by declarations of identifiers that the body refers to, the tuple expression is 'surrounded'
-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]
- -> (Expr, Expr, [VarIndex])
- -> UnMutualMonad (Expr, Expr, [VarIndex])
-
--- When there is no binding left in a strongly connected component,
--- then move to the next SCC:
-partitionBinds pull (CyclicSCC []:ds) part
- = partitionBinds pull ds part
-
-{- If the next SCC is cyclic, then pick the best candidate for the feedback set
-and remove it from the SCC. The rest of the SCC breaks into smaller SCCs that are sorted
-and added to the remaining list of SCCs. The selected candidate is added to the feedback set,
-and its declaration is added to the tuple expression: -}
-partitionBinds pull (CyclicSCC d:ds) (body, bound, fbs)
- = let (b@(v,e), d') = pickFbNode pull d
- sccs = sortSccs d' ++ ds
- in do l <- nonrecLet v e bound
- partitionBinds pull sccs (body, l, fst b:fbs)
-
--- If the next SCC is acyclic, then it is not added to the feedback set. Instead,
--- its declaration is added to the tuple expression. Depending on whether it
--- is needed in the body expression, its declaration is also added to the body expression:
-partitionBinds pull (AcyclicSCC ((x,e),_,r):ds) (body, bound, fbs)
- = do l <- nonrecLet x e bound
- (body', pull') <- if x `elem` pull
- then do l' <- nonrecLet x e body
- return (l', r `union` pull)
- else return (body, pull)
- partitionBinds pull' ds (body', l, fbs)
-
--- When there are no more declarations to be processed, the 3-tuple is returned as
--- result:
-partitionBinds _pull [] part
- = return part
-
-
-
--- Function |pickFbNode| picks the best candidate from a SCC. Irs choice depends
--- not only on the SCC, but also on whether the candidate is referred to by the body expression:
-
-pickFbNode :: [VarIndex] -> [FvsNode] -> (Bind, [FvsNode])
-pickFbNode pull defs = (b, d)
- where
- ds = [x | (_, x, _) <- defs]
- (b, y, _) = maximumBy (compare `on` weight pull ds) defs
- d = [ n | n@(_, x, _) <- defs, x /= y]
-
--- not in ghc 6.8.2:
-on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
-on (.*.) f x y = f x .*. f y
-
-{-
-Function |weight| estimates the usefulness of adding an identifier to the feedback set.
-It uses the fact, that tuples are sorted in exicographic order by default. An identifier is
-rated on whether it
-\begin{enumerate}
- \item has a recursive reference to itself,
- \item has a high number of references to other identifiers in the same SCC, or
- \item is referred to by the body expression.
-\end{enumerate}
--}
-
-weight :: [VarIndex] -> [VarIndex] -> FvsNode -> (Bool, Int, Bool)
-weight pull defs (_,x,fv) = (recursive, length incoming, pulled)
- where recursive = x `elem` fv
- incoming = fv `intersect` defs
- pulled = x `elem` pull
-
-
-
-newLocalName :: Maybe TypeExpr -> UnMutualMonad VarIndex
-newLocalName t
- = do st <- get
- let counter = 1 + localCounter st
- put st { localCounter = counter }
- return (VarIndex t counter)
-
-
-subst :: VarIndex -> Expr -> Expr -> Expr
-subst v x = po
- where po e@(Var v')
- | v==v' = x
- | otherwise = e
- po e@(Lit _)
- = e
- po (Comb t n es)
- = Comb t n (map po es)
- po e@(Free vs e')
- | v `elem` vs = e
- | otherwise = Free vs (po e')
- 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)
- po (Case p t e bs) = Case p t (po e) (map poBranch bs)
- poBind (w, rhs) = (w, po rhs)
- poBranch e@(Branch p rhs)
- | v `elem` trPattern (\_ args -> args) (const []) p
- = e
- | otherwise
- = Branch p (po rhs)
-
-
-
diff --git a/Curry/Files/Filenames.hs b/Curry/Files/Filenames.hs
deleted file mode 100644
--- a/Curry/Files/Filenames.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-{-
- Filename mangling for several intermediate file formats.
-
- The functions in this module were collected from several
- compiler modules in order to provide a unique accessing
- point for this functionality.
-
- (c) 2009, Holger Siegel.
--}
-
-module Curry.Files.Filenames
- (
- -- * Special directories
- currySubdir
-
- -- * Common file name extensions
- , curryExt, lcurryExt, icurryExt
- , flatExt, extFlatExt, flatIntExt, xmlExt
- , acyExt, uacyExt
- , sourceRepExt, oExt, debugExt
- , sourceExts, moduleExts, objectExts
-
- -- * 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"
-
--- |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"
-
--- |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]
-
-{- ---------------------------------------------------------------------------
- Computation of file names for a given source file
---------------------------------------------------------------------------- -}
-
--- |Compute the filename of the interface file for a source file
-interfName :: FilePath -> FilePath
-interfName = replaceWithExtension icurryExt
-
--- |Compute the filename of the flat curry file for a source file
-flatName :: FilePath -> FilePath
-flatName = replaceWithExtension flatExt
-
--- |Compute the filename of the extended flat curry file for a source file
-extFlatName :: FilePath -> FilePath
-extFlatName = replaceWithExtension extFlatExt
-
--- |Compute the filename of the flat curry interface file for a source file
-flatIntName :: FilePath -> FilePath
-flatIntName = replaceWithExtension flatIntExt
-
--- |Compute the filename of the flat curry xml file for a source file
-xmlName :: FilePath -> FilePath
-xmlName = replaceWithExtension xmlExt
-
--- |Compute the filename of the abstract curry file for a source file
-acyName :: FilePath -> FilePath
-acyName = replaceWithExtension acyExt
-
--- |Compute the filename of the untyped abstract curry file for a source file
-uacyName :: FilePath -> FilePath
-uacyName = replaceWithExtension uacyExt
-
--- |Compute the filename of the source representation file for a source file
-sourceRepName :: FilePath -> FilePath
-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 = replaceWithExtension (if debug then debugExt else oExt)
-
--- |Replace a filename extension with a new extension
-replaceWithExtension :: String -> FilePath -> FilePath
-replaceWithExtension = flip replaceExtension
diff --git a/Curry/Files/PathUtils.hs b/Curry/Files/PathUtils.hs
deleted file mode 100644
--- a/Curry/Files/PathUtils.hs
+++ /dev/null
@@ -1,161 +0,0 @@
-{-
- $Id: PathUtils.lhs,v 1.5 2003/05/04 16:12:35 wlux Exp $
-
- Copyright (c) 1999-2003, Wolfgang Lux
- See LICENSE for the full license.
--}
-
-module Curry.Files.PathUtils
- ( -- * Re-exports from 'System.FilePath'
- takeBaseName, dropExtension, takeExtension, takeFileName
-
- -- * 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 Curry.Base.Ident
-import Curry.Files.Filenames
-
-
-{- |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)
-
-
-{- |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)
-
-
--- |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
-
-
--- Writing and reading files
-
-{- | 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
-
-
-{- | 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)
-
-
-{- | 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
-
-
--- 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.
--}
-ensureCurrySubdir :: FilePath -> FilePath
-ensureCurrySubdir = ensureSubdir currySubdir
-
-
-{- | Ensure that the given sub-directory is the last component of the
- directory structure of the given 'FilePath'. If the 'FilePath' already
- contains the sub-directory it remains unchanged.
--}
-ensureSubdir :: String -- ^ sub-directory to add
- -> FilePath -- ^ original 'FilePath'
- -> FilePath -- ^ original 'FilePath'
-ensureSubdir subdir file
- = replaceDirectory file
- $ addSub (splitDirectories $ takeDirectory file) subdir where
- addSub :: [String] -> String -> String
- addSub [] sub = sub
- addSub ds sub
- | last ds == sub = joinPath ds
- | otherwise = joinPath ds sub
-
-
-{- | Perform an action on a file either in the given directory or else in the
- 'currySubdir' sub-directory.
--}
-onExistingFileDo :: (FilePath -> IO a) -> FilePath -> IO a
-onExistingFileDo act filename = do
- ex <- doesFileExist filename
- if ex then act filename
- else act $ ensureCurrySubdir filename
diff --git a/Curry/FlatCurry/Goodies.hs b/Curry/FlatCurry/Goodies.hs
deleted file mode 100644
--- a/Curry/FlatCurry/Goodies.hs
+++ /dev/null
@@ -1,933 +0,0 @@
-----------------------------------------------------------------------------
---- 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
---- functions. For recursive datatypes the transformations are defined
---- inductively over the term structure. This is quite usual for
---- 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 -
---- is abstracted away, which hopefully makes the code more clear and brief.
----
---- @author Sebastian Fischer
---- @version January 2006
-----------------------------------------------------------------------------
-
-module Curry.FlatCurry.Goodies where
-
-import Curry.FlatCurry.Type
-
---------------------------------
--- adjustments for haskell (bbr)
---------------------------------
-failed :: a
-failed = undefined
-
---------------------------------
-
-type Update a b = (b -> b) -> a -> a
-
--- Prog ----------------------------------------------------------------------
-
---- transform program
-trProg :: (String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> a)
- -> Prog -> a
-trProg prog (Prog name imps types funcs ops) = prog name imps types funcs ops
-
--- Selectors
-
---- get name from program
-progName :: Prog -> String
-progName = trProg (\name _ _ _ _ -> name)
-
---- get imports from program
-progImports :: Prog -> [String]
-progImports = trProg (\_ imps _ _ _ -> imps)
-
---- get type declarations from program
-progTypes :: Prog -> [TypeDecl]
-progTypes = trProg (\_ _ types _ _ -> types)
-
---- get functions from program
-progFuncs :: Prog -> [FuncDecl]
-progFuncs = trProg (\_ _ _ funcs _ -> funcs)
-
---- get infix operators from program
-progOps :: Prog -> [OpDecl]
-progOps = trProg (\_ _ _ _ ops -> ops)
-
--- Update Operations
-
---- update program
-updProg :: (String -> String) ->
- ([String] -> [String]) ->
- ([TypeDecl] -> [TypeDecl]) ->
- ([FuncDecl] -> [FuncDecl]) ->
- ([OpDecl] -> [OpDecl]) -> Prog -> Prog
-updProg fn fi ft ff fo = trProg prog
- where
- prog name imps types funcs ops
- = Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops)
-
---- update name of program
-updProgName :: Update Prog String
-updProgName f = updProg f id id id id
-
---- update imports of program
-updProgImports :: Update Prog [String]
-updProgImports f = updProg id f id id id
-
---- update type declarations of program
-updProgTypes :: Update Prog [TypeDecl]
-updProgTypes f = updProg id id f id id
-
---- update functions of program
-updProgFuncs :: Update Prog [FuncDecl]
-updProgFuncs f = updProg id id id f id
-
---- update infix operators of program
-updProgOps :: Update Prog [OpDecl]
-updProgOps = updProg id id id id
-
--- Auxiliary Functions
-
---- get all program variables (also from patterns)
-allVarsInProg :: Prog -> [VarIndex]
-allVarsInProg = concatMap allVarsInFunc . progFuncs
-
---- lift transformation on expressions to program
-updProgExps :: Update Prog Expr
-updProgExps = updProgFuncs . map . updFuncBody
-
---- rename programs variables
-rnmAllVarsInProg :: Update Prog VarIndex
-rnmAllVarsInProg = updProgFuncs . map . rnmAllVarsInFunc
-
---- update all qualified names in program
-updQNamesInProg :: Update Prog QName
-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 (m,n) | m==progName p = (name,n)
- | otherwise = (m,n)
-
--- TypeDecl ------------------------------------------------------------------
-
--- Selectors
-
---- transform type declaration
-trType :: (QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> a) ->
- (QName -> Visibility -> [TVarIndex] -> TypeExpr -> a) -> TypeDecl -> a
-trType typ _ (Type name vis params cs) = typ name vis params cs
-trType _ typesyn (TypeSyn name vis params syn) = typesyn name vis params syn
-
---- get name of type declaration
-typeName :: TypeDecl -> QName
-typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name)
-
---- get visibility of type declaration
-typeVisibility :: TypeDecl -> Visibility
-typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis)
-
---- get type parameters of type declaration
-typeParams :: TypeDecl -> [TVarIndex]
-typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params)
-
---- get constructor declarations from type declaration
-typeConsDecls :: TypeDecl -> [ConsDecl]
-typeConsDecls = trType (\_ _ _ cs -> cs) failed
-
---- get synonym of type declaration
-typeSyn :: TypeDecl -> TypeExpr
-typeSyn = trType failed (\_ _ _ syn -> syn)
-
---- is type declaration a type synonym?
-isTypeSyn :: TypeDecl -> Bool
-isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True)
-
--- is type declaration declaring a regular type?
-isDataTypeDecl :: TypeDecl -> Bool
-isDataTypeDecl = trType (\_ _ _ cs -> not (null cs)) (\_ _ _ _ -> False)
-
--- is type declaration declaring an external type?
-isExternalType :: TypeDecl -> Bool
-isExternalType = trType (\_ _ _ cs -> null cs) (\_ _ _ _ -> False)
-
--- Update Operations
-
---- update type declaration
-updType :: (QName -> QName) ->
- (Visibility -> Visibility) ->
- ([TVarIndex] -> [TVarIndex]) ->
- ([ConsDecl] -> [ConsDecl]) ->
- (TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl
-updType fn fv fp fc fs = trType typ typesyn
- where
- typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs)
- typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn)
-
---- update name of type declaration
-updTypeName :: Update TypeDecl QName
-updTypeName f = updType f id id id id
-
---- update visibility of type declaration
-updTypeVisibility :: Update TypeDecl Visibility
-updTypeVisibility f = updType id f id id id
-
---- update type parameters of type declaration
-updTypeParams :: Update TypeDecl [TVarIndex]
-updTypeParams f = updType id id f id id
-
---- update constructor declarations of type declaration
-updTypeConsDecls :: Update TypeDecl [ConsDecl]
-updTypeConsDecls f = updType id id id f id
-
---- update synonym of type declaration
-updTypeSynonym :: Update TypeDecl TypeExpr
-updTypeSynonym = updType id id id id
-
--- Auxiliary Functions
-
---- update all qualified names in type declaration
-updQNamesInType :: Update TypeDecl QName
-updQNamesInType f
- = updType f id id (map (updQNamesInConsDecl f)) (updQNamesInTypeExpr f)
-
--- ConsDecl ------------------------------------------------------------------
-
--- Selectors
-
---- transform constructor declaration
-trCons :: (QName -> Int -> Visibility -> [TypeExpr] -> a) -> ConsDecl -> a
-trCons cons (Cons name arity vis args) = cons name arity vis args
-
---- get name of constructor declaration
-consName :: ConsDecl -> QName
-consName = trCons (\name _ _ _ -> name)
-
---- get arity of constructor declaration
-consArity :: ConsDecl -> Int
-consArity = trCons (\_ arity _ _ -> arity)
-
---- get visibility of constructor declaration
-consVisibility :: ConsDecl -> Visibility
-consVisibility = trCons (\_ _ vis _ -> vis)
-
---- get arguments of constructor declaration
-consArgs :: ConsDecl -> [TypeExpr]
-consArgs = trCons (\_ _ _ args -> args)
-
--- Update Operations
-
---- update constructor declaration
-updCons :: (QName -> QName) ->
- (Int -> Int) ->
- (Visibility -> Visibility) ->
- ([TypeExpr] -> [TypeExpr]) -> ConsDecl -> ConsDecl
-updCons fn fa fv fas = trCons cons
- where
- cons name arity vis args = Cons (fn name) (fa arity) (fv vis) (fas args)
-
---- update name of constructor declaration
-updConsName :: Update ConsDecl QName
-updConsName f = updCons f id id id
-
---- update arity of constructor declaration
-updConsArity :: Update ConsDecl Int
-updConsArity f = updCons id f id id
-
---- update visibility of constructor declaration
-updConsVisibility :: Update ConsDecl Visibility
-updConsVisibility f = updCons id id f id
-
---- update arguments of constructor declaration
-updConsArgs :: Update ConsDecl [TypeExpr]
-updConsArgs = updCons id id id
-
--- Auxiliary Functions
-
---- update all qualified names in constructor declaration
-updQNamesInConsDecl :: Update ConsDecl QName
-updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f))
-
--- TypeExpr ------------------------------------------------------------------
-
--- Selectors
-
---- 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)
- = tcons name (map (trTypeExpr tvar tcons functype) args)
-trTypeExpr tvar tcons functype (FuncType from to) = functype (f from) (f to)
- where
- f = trTypeExpr tvar tcons functype
-
--- Test Operations
-
---- is type expression a type variable?
-isTVar :: TypeExpr -> Bool
-isTVar = trTypeExpr (\_ -> True) (\_ _ -> False) (\_ _ -> False)
-
---- is type declaration a constructed type?
-isTCons :: TypeExpr -> Bool
-isTCons = trTypeExpr (\_ -> False) (\_ _ -> True) (\_ _ -> False)
-
---- is type declaration a functional type?
-isFuncType :: TypeExpr -> Bool
-isFuncType = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> True)
-
--- Update Operations
-
---- update all type variables
-updTVars :: (TVarIndex -> TypeExpr) -> TypeExpr -> TypeExpr
-updTVars tvar = trTypeExpr tvar TCons FuncType
-
---- update all type constructors
-updTCons :: (QName -> [TypeExpr] -> TypeExpr) -> TypeExpr -> TypeExpr
-updTCons tcons = trTypeExpr TVar tcons FuncType
-
---- update all functional types
-updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
-updFuncTypes = trTypeExpr TVar TCons
-
--- Auxiliary Functions
-
---- get argument types from functional type
-argTypes :: TypeExpr -> [TypeExpr]
-argTypes (TVar _) = []
-argTypes (TCons _ _) = []
-argTypes (FuncType dom ran) = dom : argTypes ran
-
---- get result type from (nested) functional type
-resultType :: TypeExpr -> TypeExpr
-resultType (TVar n) = TVar n
-resultType (TCons name args) = TCons name args
-resultType (FuncType _ ran) = resultType ran
-
---- get indexes of all type variables
-allVarsInTypeExpr :: TypeExpr -> [TVarIndex]
-allVarsInTypeExpr = trTypeExpr (:[]) (const concat) (++)
-
---- rename variables in type expression
-rnmAllVarsInTypeExpr :: (TVarIndex -> TVarIndex) -> TypeExpr -> TypeExpr
-rnmAllVarsInTypeExpr f = updTVars (TVar . f)
-
---- update all qualified names in type expression
-updQNamesInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr
-updQNamesInTypeExpr f = updTCons (\name args -> TCons (f name) args)
-
--- OpDecl --------------------------------------------------------------------
-
---- transform operator declaration
-trOp :: (QName -> Fixity -> Int -> a) -> OpDecl -> a
-trOp op (Op name fix prec) = op name fix prec
-
--- Selectors
-
---- get name from operator declaration
-opName :: OpDecl -> QName
-opName = trOp (\name _ _ -> name)
-
---- get fixity of operator declaration
-opFixity :: OpDecl -> Fixity
-opFixity = trOp (\_ fix _ -> fix)
-
---- get precedence of operator declaration
-opPrecedence :: OpDecl -> Int
-opPrecedence = trOp (\_ _ prec -> prec)
-
--- Update Operations
-
---- update operator declaration
-updOp :: (QName -> QName) ->
- (Fixity -> Fixity) ->
- (Int -> Int) -> OpDecl -> OpDecl
-updOp fn ff fp = trOp op
- where
- op name fix prec = Op (fn name) (ff fix) (fp prec)
-
---- update name of operator declaration
-updOpName :: Update OpDecl QName
-updOpName f = updOp f id id
-
---- update fixity of operator declaration
-updOpFixity :: Update OpDecl Fixity
-updOpFixity f = updOp id f id
-
---- update precedence of operator declaration
-updOpPrecedence :: Update OpDecl Int
-updOpPrecedence = updOp id id
-
--- FuncDecl ------------------------------------------------------------------
-
---- transform function
-trFunc :: (QName -> Int -> Visibility -> TypeExpr -> Rule -> a) -> FuncDecl -> a
-trFunc func (Func name arity vis t rule) = func name arity vis t rule
-
--- Selectors
-
---- get name of function
-funcName :: FuncDecl -> QName
-funcName = trFunc (\name _ _ _ _ -> name)
-
---- get arity of function
-funcArity :: FuncDecl -> Int
-funcArity = trFunc (\_ arity _ _ _ -> arity)
-
---- get visibility of function
-funcVisibility :: FuncDecl -> Visibility
-funcVisibility = trFunc (\_ _ vis _ _ -> vis)
-
---- get type of function
-funcType :: FuncDecl -> TypeExpr
-funcType = trFunc (\_ _ _ t _ -> t)
-
---- get rule of function
-funcRule :: FuncDecl -> Rule
-funcRule = trFunc (\_ _ _ _ rule -> rule)
-
--- Update Operations
-
---- update function
-updFunc :: (QName -> QName) ->
- (Int -> Int) ->
- (Visibility -> Visibility) ->
- (TypeExpr -> TypeExpr) ->
- (Rule -> Rule) -> FuncDecl -> FuncDecl
-updFunc fn fa fv ft fr = trFunc func
- where
- func name arity vis t rule
- = Func (fn name) (fa arity) (fv vis) (ft t) (fr rule)
-
---- update name of function
-updFuncName :: Update FuncDecl QName
-updFuncName f = updFunc f id id id id
-
---- update arity of function
-updFuncArity :: Update FuncDecl Int
-updFuncArity f = updFunc id f id id id
-
---- update visibility of function
-updFuncVisibility :: Update FuncDecl Visibility
-updFuncVisibility f = updFunc id id f id id
-
---- update type of function
-updFuncType :: Update FuncDecl TypeExpr
-updFuncType f = updFunc id id id f id
-
---- update rule of function
-updFuncRule :: Update FuncDecl Rule
-updFuncRule = updFunc id id id id
-
--- Auxiliary Functions
-
---- is function externally defined?
-isExternal :: FuncDecl -> Bool
-isExternal = isRuleExternal . funcRule
-
---- get variable names in a function declaration
-allVarsInFunc :: FuncDecl -> [VarIndex]
-allVarsInFunc = allVarsInRule . funcRule
-
---- get arguments of function, if not externally defined
-funcArgs :: FuncDecl -> [VarIndex]
-funcArgs = ruleArgs . funcRule
-
---- get body of function, if not externally defined
-funcBody :: FuncDecl -> Expr
-funcBody = ruleBody . funcRule
-
-funcRHS :: FuncDecl -> [Expr]
-funcRHS f | not (isExternal f) = orCase (funcBody f)
- | otherwise = []
- where
- orCase e
- | isOr e = concatMap orCase (orExps e)
- | isCase e = concatMap orCase (map branchExpr (caseBranches e))
- | otherwise = [e]
-
---- rename all variables in function
-rnmAllVarsInFunc :: Update FuncDecl VarIndex
-rnmAllVarsInFunc = updFunc id id id id . rnmAllVarsInRule
-
---- update all qualified names in function
-updQNamesInFunc :: Update FuncDecl QName
-updQNamesInFunc f = updFunc f id id (updQNamesInTypeExpr f) (updQNamesInRule f)
-
---- update arguments of function, if not externally defined
-updFuncArgs :: Update FuncDecl [VarIndex]
-updFuncArgs = updFuncRule . updRuleArgs
-
---- update body of function, if not externally defined
-updFuncBody :: Update FuncDecl Expr
-updFuncBody = updFuncRule . updRuleBody
-
--- Rule ----------------------------------------------------------------------
-
---- transform rule
-trRule :: ([VarIndex] -> Expr -> a) -> (String -> a) -> Rule -> a
-trRule rule _ (Rule args e) = rule args e
-trRule _ ext (External s) = ext s
-
--- Selectors
-
---- get rules arguments if it's not external
-ruleArgs :: Rule -> [VarIndex]
-ruleArgs = trRule (\args _ -> args) failed
-
---- get rules body if it's not external
-ruleBody :: Rule -> Expr
-ruleBody = trRule (\_ e -> e) failed
-
---- get rules external declaration
-ruleExtDecl :: Rule -> String
-ruleExtDecl = trRule failed id
-
--- Test Operations
-
---- is rule external?
-isRuleExternal :: Rule -> Bool
-isRuleExternal = trRule (\_ _ -> False) (\_ -> True)
-
--- Update Operations
-
---- update rule
-updRule :: ([VarIndex] -> [VarIndex]) ->
- (Expr -> Expr) ->
- (String -> String) -> Rule -> Rule
-updRule fa fe fs = trRule rule ext
- where
- rule args e = Rule (fa args) (fe e)
- ext s = External (fs s)
-
---- update rules arguments
-updRuleArgs :: Update Rule [VarIndex]
-updRuleArgs f = updRule f id id
-
---- update rules body
-updRuleBody :: Update Rule Expr
-updRuleBody f = updRule id f id
-
---- update rules external declaration
-updRuleExtDecl :: Update Rule String
-updRuleExtDecl f = updRule id id f
-
--- Auxiliary Functions
-
---- get variable names in a functions rule
-allVarsInRule :: Rule -> [VarIndex]
-allVarsInRule = trRule (\args body -> args ++ allVars body) (\_ -> [])
-
---- rename all variables in rule
-rnmAllVarsInRule :: Update Rule VarIndex
-rnmAllVarsInRule f = updRule (map f) (rnmAllVars f) id
-
---- update all qualified names in rule
-updQNamesInRule :: Update Rule QName
-updQNamesInRule = updRuleBody . updQNames
-
--- CombType ------------------------------------------------------------------
-
---- transform combination type
-trCombType :: a -> (Int -> a) -> a -> (Int -> a) -> CombType -> a
-trCombType fc _ _ _ FuncCall = fc
-trCombType _ fpc _ _ (FuncPartCall n) = fpc n
-trCombType _ _ cc _ ConsCall = cc
-trCombType _ _ _ cpc (ConsPartCall n) = cpc n
-
--- Test Operations
-
---- is type of combination FuncCall?
-isCombTypeFuncCall :: CombType -> Bool
-isCombTypeFuncCall = trCombType True (\_ -> False) False (\_ -> False)
-
---- is type of combination FuncPartCall?
-isCombTypeFuncPartCall :: CombType -> Bool
-isCombTypeFuncPartCall = trCombType False (\_ -> True) False (\_ -> False)
-
---- is type of combination ConsCall?
-isCombTypeConsCall :: CombType -> Bool
-isCombTypeConsCall = trCombType False (\_ -> False) True (\_ -> False)
-
---- is type of combination ConsPartCall?
-isCombTypeConsPartCall :: CombType -> Bool
-isCombTypeConsPartCall = trCombType False (\_ -> False) False (\_ -> True)
-
--- Auxiliary Functions
-
-missingArgs :: CombType -> Int
-missingArgs = trCombType 0 id 0 id
-
--- Expr ----------------------------------------------------------------------
-
--- Selectors
-
---- 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
-missingCombArgs = missingArgs . combType
-
---- 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
- Var _ -> True
- _ -> False
-
---- is expression a literal expression?
-isLit :: Expr -> Bool
-isLit e = case e of
- Lit _ -> True
- _ -> False
-
---- is expression combined?
-isComb :: Expr -> Bool
-isComb e = case e of
- Comb _ _ _ -> True
- _ -> False
-
---- is expression a let expression?
-isLet :: Expr -> Bool
-isLet e = case e of
- Let _ _ -> True
- _ -> False
-
---- is expression a declaration of free variables?
-isFree :: Expr -> Bool
-isFree e = case e of
- Free _ _ -> True
- _ -> False
-
---- is expression an or-expression?
-isOr :: Expr -> Bool
-isOr e = case e of
- Or _ _ -> True
- _ -> False
-
---- is expression a case expression?
-isCase :: Expr -> Bool
-isCase e = case e of
- Case _ _ _ -> True
- _ -> False
-
---- transform expression
-trExpr :: (VarIndex -> a) ->
- (Literal -> a) ->
- (CombType -> QName -> [a] -> a) ->
- ([(VarIndex,a)] -> a -> a) ->
- ([VarIndex] -> a -> a) ->
- (a -> a -> a) ->
- (CaseType -> a -> [b] -> a) ->
- (Pattern -> a -> b) -> Expr -> a
-trExpr var _ _ _ _ _ _ _ (Var n) = var n
-
-trExpr _ lit _ _ _ _ _ _ (Lit l) = lit l
-
-trExpr var lit comb lt fr oR cas branch (Comb ct name args)
- = 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)
- where
- f = trExpr var lit comb lt fr oR cas branch
-
-trExpr var lit comb lt fr oR cas branch (Free vs e)
- = fr vs (trExpr var lit comb lt fr oR cas branch e)
-
-trExpr var lit comb lt fr oR cas branch (Or e1 e2) = oR (f e1) (f e2)
- where
- 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)
- where
- f = trExpr var lit comb lt fr oR cas branch
-
--- Update Operations
-
---- update all variables in given expression
-updVars :: (VarIndex -> Expr) -> Expr -> Expr
-updVars var = trExpr var Lit Comb Let Free Or Case Branch
-
---- update all literals in given expression
-updLiterals :: (Literal -> Expr) -> Expr -> Expr
-updLiterals lit = trExpr Var lit Comb Let Free Or Case Branch
-
---- update all combined expressions in given expression
-updCombs :: (CombType -> QName -> [Expr] -> Expr) -> Expr -> Expr
-updCombs comb = trExpr Var Lit comb Let Free Or Case Branch
-
---- update all let expressions in given expression
-updLets :: ([(VarIndex,Expr)] -> Expr -> Expr) -> Expr -> Expr
-updLets lt = trExpr Var Lit Comb lt Free Or Case Branch
-
---- update all free declarations in given expression
-updFrees :: ([VarIndex] -> Expr -> Expr) -> Expr -> Expr
-updFrees fr = trExpr Var Lit Comb Let fr Or Case Branch
-
---- update all or expressions in given expression
-updOrs :: (Expr -> Expr -> Expr) -> Expr -> Expr
-updOrs oR = trExpr Var Lit Comb Let Free oR Case Branch
-
---- update all case expressions in given expression
-updCases :: (CaseType -> Expr -> [BranchExpr] -> Expr) -> Expr -> Expr
-updCases cas = trExpr Var Lit Comb Let Free Or cas Branch
-
---- update all case branches in given expression
-updBranches :: (Pattern -> Expr -> BranchExpr) -> Expr -> Expr
-updBranches branch = trExpr Var Lit Comb Let Free Or Case branch
-
--- Auxiliary Functions
-
---- is expression a call of a function where all arguments are provided?
-isFuncCall :: Expr -> Bool
-isFuncCall e = isComb e && isCombTypeFuncCall (combType e)
-
---- is expression a partial function call?
-isFuncPartCall :: Expr -> Bool
-isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e)
-
---- is expression a call of a constructor?
-isConsCall :: Expr -> Bool
-isConsCall e = isComb e && isCombTypeConsCall (combType e)
-
---- is expression a partial constructor call?
-isConsPartCall :: Expr -> Bool
-isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e)
-
---- is expression fully evaluated?
-isGround :: Expr -> Bool
-isGround e
- = case e of
- Comb ConsCall _ args -> all isGround args
- _ -> isLit e
-
---- get all variables (also pattern variables) in expression
-allVars :: Expr -> [VarIndex]
-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'
- args pat | isConsPattern pat = patArgs pat
- | otherwise = []
-
---- rename all variables (also in patterns) in expression
-rnmAllVars :: Update Expr VarIndex
-rnmAllVars f = trExpr (Var . f) Lit Comb lt (Free . map f) Or Case branch
- where
- lt = Let . map (\ (n,e) -> (f n,e))
- branch = Branch . updPatArgs (map f)
-
---- update all qualified names in expression
-updQNames :: Update Expr QName
-updQNames f = trExpr Var Lit comb Let Free Or Case (Branch . updPatCons f)
- where
- comb ct name args = Comb ct (f name) args
-
--- BranchExpr ----------------------------------------------------------------
-
---- transform branch expression
-trBranch :: (Pattern -> Expr -> a) -> BranchExpr -> a
-trBranch branch (Branch pat e) = branch pat e
-
--- Selectors
-
---- get pattern from branch expression
-branchPattern :: BranchExpr -> Pattern
-branchPattern = trBranch (\pat _ -> pat)
-
---- get expression from branch expression
-branchExpr :: BranchExpr -> Expr
-branchExpr = trBranch (\_ e -> e)
-
--- Update Operations
-
---- update branch expression
-updBranch :: (Pattern -> Pattern) -> (Expr -> Expr) -> BranchExpr -> BranchExpr
-updBranch fp fe = trBranch branch
- where
- branch pat e = Branch (fp pat) (fe e)
-
---- update pattern of branch expression
-updBranchPattern :: Update BranchExpr Pattern
-updBranchPattern f = updBranch f id
-
---- update expression of branch expression
-updBranchExpr :: Update BranchExpr Expr
-updBranchExpr = updBranch id
-
--- Pattern -------------------------------------------------------------------
-
---- transform pattern
-trPattern :: (QName -> [VarIndex] -> a) -> (Literal -> a) -> Pattern -> a
-trPattern pattern _ (Pattern name args) = pattern name args
-trPattern _ lpattern (LPattern l) = lpattern l
-
--- Selectors
-
---- get name from constructor pattern
-patCons :: Pattern -> QName
-patCons = trPattern (\name _ -> name) failed
-
---- get arguments from constructor pattern
-patArgs :: Pattern -> [VarIndex]
-patArgs = trPattern (\_ args -> args) failed
-
---- get literal from literal pattern
-patLiteral :: Pattern -> Literal
-patLiteral = trPattern failed id
-
--- Test Operations
-
---- is pattern a constructor pattern?
-isConsPattern :: Pattern -> Bool
-isConsPattern = trPattern (\_ _ -> True) (\_ -> False)
-
--- Update Operations
-
---- update pattern
-updPattern :: (QName -> QName) ->
- ([VarIndex] -> [VarIndex]) ->
- (Literal -> Literal) -> Pattern -> Pattern
-updPattern fn fa fl = trPattern pattern lpattern
- where
- pattern name args = Pattern (fn name) (fa args)
- lpattern l = LPattern (fl l)
-
---- update constructors name of pattern
-updPatCons :: (QName -> QName) -> Pattern -> Pattern
-updPatCons f = updPattern f id id
-
---- update arguments of constructor pattern
-updPatArgs :: ([VarIndex] -> [VarIndex]) -> Pattern -> Pattern
-updPatArgs f = updPattern id f id
-
---- update literal of pattern
-updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern
-updPatLiteral f = updPattern id id f
-
--- Auxiliary Functions
-
---- build expression from pattern
-patExpr :: Pattern -> Expr
-patExpr = trPattern (\ name -> Comb ConsCall name . map Var) Lit
-
diff --git a/Curry/FlatCurry/Tools.hs b/Curry/FlatCurry/Tools.hs
deleted file mode 100644
--- a/Curry/FlatCurry/Tools.hs
+++ /dev/null
@@ -1,831 +0,0 @@
-module Curry.FlatCurry.Tools (
-
- -- operations on programs:
- progName, progImports, progTypes, progFuncs, progOps,
-
- updProg, updProgName, updProgImports, updProgTypes, updProgFuncs, updProgOps,
-
- updProgExps, rnmAllVarsProg, allVarsProg, updQNamesProg,
-
- rnmProg,
-
- -- operations on type declarations:
- updQNamesType,allConstructors,consQName, consArity, isTypeSyn, isDataTypeDecl,
- isPublicType, isPublicCons,typeQName,isExternalType,
-
- -- operations on functions:
- funcName, funcArity, funcVisibility, funcType, funcRule, isPublicFunc,
-
- updFunc, updFuncName, updFuncArity, updFuncVisibility, updFuncType,
- updFuncRule,
-
- funcArgs, funcBody, funcRHS, isExternal, isCombFunc,
-
- updFuncArgs, updFuncBody,
-
- incVarsFunc, rnmAllVarsFunc, allVarsFunc, updQNamesFunc,
-
- -- operations on function-rules:
- isRuleExternal, ruleArgs, ruleBody,
-
- updRule, updRuleArgs, updRuleBody, ruleExtDecl, updRuleExtDecl,
-
- rnmAllVarsRule, allVarsRule, updQNamesRule,
-
- -- operations on type-expressions:
- isTypeVar, isFuncType, isTypeCons, typeConsName, argTypes, resultType,
- isIOType,typeArity, allTVars,
- rnmAllVarsTypeExpr, allTypeCons,
-
- -- operations on expressions:
- isVar, varNr, isLit, isComb, isFree, isOr, isCase, isLet, isGround,
- literal, combType, exprFromFreeDecl, orExps,
-
- isFuncCall, isPartCall, isConsCall, combFunc, combCons, combArgs,
- missingFuncArgs, hasName, caseBranches,
-
- rnmAllVars, allVars,
-
- mapVar, mapLit, mapComb, mapFree, mapOr, mapCase, mapLet,
-
- -- operations on combination-types
- isCombFuncCall, isCombPartCall, isCombConsCall, missingArgs,
-
- -- operations on branch-expressions
- branchPattern, branchExpr, isConsPattern,
-
- updBranch, updBranchPattern, updBranchExpr,
-
- patCons, patArgs, patLiteral, patExpr, updPatArgs, updPatLiteral,
-
- rnmAllVarsBranch, allVarsBranch,
- rnmAllVarsPat, allVarsPat,
-
- -- operations on OpDecls
- opName
-
- ) where
-
-
-import Data.Maybe
-
-import Curry.FlatCurry.Type
-
--- auxiliary functions -------------------------------------------------------
-
--- infixr 5 -:-
-
--- (-:-) :: 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)
-
---- get name from program
-progName :: Prog -> String
-progName (Prog name _ _ _ _) = name
-
---- update name of program
-updProgName :: (String -> String) -> Prog -> Prog
-updProgName f = updProg f id id id id
-
---- get imports from program
-progImports :: Prog -> [String]
-progImports (Prog _ imps _ _ _) = imps
-
---- update imports of program
-updProgImports :: ([String] -> [String]) -> Prog -> Prog
-updProgImports f = updProg id f id id id
-
---- get type declarations from program
-progTypes :: Prog -> [TypeDecl]
-progTypes (Prog _ _ types _ _) = types
-
---- update type declarations of program
-updProgTypes :: ([TypeDecl] -> [TypeDecl]) -> Prog -> Prog
-updProgTypes f = updProg id id f id id
-
---- get functions from program
-progFuncs :: Prog -> [FuncDecl]
-progFuncs (Prog _ _ _ funcs _) = funcs
-
---- update functions of program
-updProgFuncs :: ([FuncDecl] -> [FuncDecl]) -> Prog -> Prog
-updProgFuncs f = updProg id id id f id
-
---- get infix operators from program
-progOps :: Prog -> [OpDecl]
-progOps (Prog _ _ _ _ ops) = ops
-
---- update infix operators of program
-updProgOps :: ([OpDecl] -> [OpDecl]) -> Prog -> Prog
-updProgOps f = updProg id id id id f
-
---- lift transformation on expressions to program
-updProgExps :: (Expr -> Expr) -> Prog -> Prog
-updProgExps = updProgFuncs . map . updFuncBody
-
---- rename programs variables
-rnmAllVarsProg :: (Int -> Int) -> Prog -> Prog
-rnmAllVarsProg = updProgFuncs . map . rnmAllVarsFunc
-
---- get all program variables (also from patterns)
-allVarsProg :: Prog -> [Int]
-allVarsProg = concatMap allVarsFunc . progFuncs
-
---- update all qualified names in program
-updQNamesProg :: (QName -> QName) -> Prog -> Prog
-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 (modul,n) | modul == progName p = (name,n)
- | otherwise = (modul,n)
-
-
--- TypeDecl ------------------------------------------------------------------
-
---- select all constructors in a type declaration
-allConstructors :: TypeDecl -> [ConsDecl]
-allConstructors (TypeSyn _ _ _ _) = []
-allConstructors (Type _ _ _ cs) = cs
-
---- select name of constructor
-consQName :: ConsDecl -> QName
-consQName (Cons n _ _ _) = n
-
-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)
- = TypeSyn (f name) vis vars (updQNamesTypeExpr f t)
-
---- update all qualified names in constructor declaration
-updQNamesConsDecl :: (QName -> QName) -> ConsDecl -> ConsDecl
-updQNamesConsDecl f (Cons name arity vis args)
- = Cons (f name) arity vis (map (updQNamesTypeExpr f) args)
-
-isDataTypeDecl :: TypeDecl -> Bool
-isDataTypeDecl (TypeSyn _ _ _ _) = False
-isDataTypeDecl (Type _ _ _ cs) = not (null cs)
-
-isExternalType :: TypeDecl -> Bool
-isExternalType (TypeSyn _ _ _ _) = False
-isExternalType (Type _ _ _ cs) = null cs
-
-isTypeSyn :: TypeDecl -> Bool
-isTypeSyn (Type _ _ _ _) = False
-isTypeSyn (TypeSyn _ _ _ _) = True
-
-isPublicType :: TypeDecl -> Bool
-isPublicType (Type _ vis _ _) = vis==Public
-isPublicType (TypeSyn _ vis _ _) = vis==Public
-
-isPublicCons :: ConsDecl -> Bool
-isPublicCons (Cons _ _ vis _) = vis==Public
-
-typeQName :: TypeDecl -> QName
-typeQName (TypeSyn n _ _ _) = n
-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)
-
---- get name of function
-funcName :: FuncDecl -> QName
-funcName (Func name _ _ _ _) = name
-
---- update name of function
-updFuncName :: (QName -> QName) -> FuncDecl -> FuncDecl
-updFuncName f = updFunc f id id id id
-
---- get arity of function
-funcArity :: FuncDecl -> Int
-funcArity (Func _ arity _ _ _) = arity
-
---- update arity of function
-updFuncArity :: (Int -> Int) -> FuncDecl -> FuncDecl
-updFuncArity f = updFunc id f id id id
-
---- get visibility of function
-funcVisibility :: FuncDecl -> Visibility
-funcVisibility (Func _ _ vis _ _) = vis
-
---- is function public?
-isPublicFunc :: FuncDecl -> Bool
-isPublicFunc (Func _ _ vis _ _) = vis == Public
-
---- update visibility of function
-updFuncVisibility :: (Visibility -> Visibility) -> FuncDecl -> FuncDecl
-updFuncVisibility f = updFunc id id f id id
-
---- get type of function
-funcType :: FuncDecl -> TypeExpr
-funcType (Func _ _ _ t _) = t
-
---- update type of function
-updFuncType :: (TypeExpr -> TypeExpr) -> FuncDecl -> FuncDecl
-updFuncType f = updFunc id id id f id
-
---- get rule of function
-funcRule :: FuncDecl -> Rule
-funcRule (Func _ _ _ _ rule) = rule
-
---- update rule of function
-updFuncRule :: (Rule -> Rule) -> FuncDecl -> FuncDecl
-updFuncRule f = updFunc id id id id f
-
---- update all qualified names in function
-updQNamesFunc :: (QName -> QName) -> FuncDecl -> FuncDecl
-updQNamesFunc f = updFunc f id id (updQNamesTypeExpr f) (updQNamesRule f)
-
--- shortcuts
-
---- get arguments of function, if not externally defined
-funcArgs :: FuncDecl -> Maybe [Int]
-funcArgs = ruleArgs . funcRule
-
---- update arguments of function, if not externally defined
-updFuncArgs :: ([Int] -> [Int]) -> FuncDecl -> FuncDecl
-updFuncArgs = updFuncRule . updRuleArgs
-
---- get body of function, if not externally defined
-funcBody :: FuncDecl -> Maybe Expr
-funcBody = ruleBody . funcRule
-
---- update body of function, if not externally defined
-updFuncBody :: (Expr -> Expr) -> FuncDecl -> FuncDecl
-updFuncBody = updFuncRule . updRuleBody
-
---- get right-hand-sides of function (body without leading case and or nodes)
-funcRHS :: FuncDecl -> Maybe [Expr]
-funcRHS = maybe Nothing (Just . unwrapCaseOr) . funcBody
- where
- unwrapCaseOr e
- | isCase e
- = concatMap unwrapCaseOr (map branchExpr (caseBranches e))
- | isOr e = concatMap unwrapCaseOr (orExps e)
- | otherwise = [e]
-
---- is function externally defined?
-isExternal :: FuncDecl -> Bool
-isExternal = isRuleExternal . funcRule
-
---- is expression e an application of function f?
---- @*param f - function declaration
---- @*param e - expression
-isCombFunc :: FuncDecl -> Expr -> Bool
-isCombFunc = hasName . funcName
-
--- auxiliary functions -------------------------------------------------------
-
---- increment all variable names in function
-incVarsFunc :: Int -> FuncDecl -> FuncDecl
-incVarsFunc m = rnmAllVarsFunc (m+)
-
---- rename all variables in function
-rnmAllVarsFunc :: (Int -> Int) -> FuncDecl -> FuncDecl
-rnmAllVarsFunc f (Func name arity vis t rule)
- = Func name arity vis t (rnmAllVarsRule f rule)
-
---- get variable names in a function declaration
-allVarsFunc :: FuncDecl -> [Int]
-allVarsFunc = allVarsRule . funcRule
-
--- Rule ----------------------------------------------------------------------
-
-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?
-isRuleExternal :: Rule -> Bool
-isRuleExternal (Rule _ _) = False
-isRuleExternal (External _) = True
-
---- get rules arguments if it's not external
-ruleArgs :: Rule -> Maybe [Int]
-ruleArgs (Rule args _) = Just args
-ruleArgs (External _) = Nothing
-
---- update rules arguments
-updRuleArgs :: ([Int] -> [Int]) -> Rule -> Rule
-updRuleArgs f = updRule f id id
-
---- get rules body if it's not external
-ruleBody :: Rule -> Maybe Expr
-ruleBody (Rule _ expr) = Just expr
-ruleBody (External _) = Nothing
-
---- update rules body
-updRuleBody :: (Expr -> Expr) -> Rule -> Rule
-updRuleBody f = updRule id f id
-
---- get rules external declaration
-ruleExtDecl :: Rule -> Maybe String
-ruleExtDecl (Rule _ _ ) = Nothing
-ruleExtDecl (External s) = Just s
-
---- update rules external declaration
-updRuleExtDecl :: (String -> String) -> Rule -> Rule
-updRuleExtDecl f = updRule id id f
-
---- update all qualified names in rule
-updQNamesRule :: (QName -> QName) -> Rule -> Rule
-updQNamesRule = updRuleBody . updQNames
-
--- auxiliary functions -------------------------------------------------------
-
---- rename all variables in rule
-rnmAllVarsRule :: (Int -> Int) -> Rule -> Rule
-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 ------------------------------------------------------------------
-
---- is type expression a type variable?
-isTypeVar :: TypeExpr -> Bool
-isTypeVar t = case t of
- TVar _ -> True
- _ -> False
-
---- is type expression a functional type?
-isFuncType :: TypeExpr -> Bool
-isFuncType t = case t of
- FuncType _ _ -> True
- _ -> False
-
---- compute number of arguments by function type
-typeArity :: TypeExpr -> Int
-typeArity (TVar _) = 0
-typeArity (TCons _ _) = 0
-typeArity (FuncType _ t2) = 1+typeArity t2
-
---- is type expression a type constructor?
-isTypeCons :: TypeExpr -> Bool
-isTypeCons t = case t of
- TCons _ _ -> True
- _ -> False
-
---- is root type constructor IO?
-isIOType :: TypeExpr -> Bool
-isIOType t = typeConsName t==Just ("Prelude","IO")
-
---- get name if type expression is type constructor
-typeConsName :: TypeExpr -> Maybe QName
-typeConsName t | isTypeCons t = let TCons name _ = t in Just name
- | otherwise = Nothing
-
---- get argument types from functional type
-argTypes :: TypeExpr -> [TypeExpr]
-argTypes t = case t of
- FuncType dom ran -> dom : argTypes ran
- _ -> []
-
---- get result type from (nested) functional type
-resultType :: TypeExpr -> TypeExpr
-resultType t = case t of
- FuncType _ ran -> resultType ran
- _ -> t
-
---- rename variables in type declaration
-rnmAllVarsTypeExpr :: (Int -> Int) -> TypeExpr -> TypeExpr
-rnmAllVarsTypeExpr f (TVar n) = TVar (f n)
-rnmAllVarsTypeExpr f (TCons name args)
- = TCons name (map (rnmAllVarsTypeExpr f) args)
-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]
-
---- yield the list of all contained type constructors
-allTypeCons :: TypeExpr -> [QName]
-allTypeCons (TVar _) = []
-allTypeCons (TCons name args) = name : concatMap allTypeCons args
-allTypeCons (FuncType t1 t2) = allTypeCons t1 ++ allTypeCons t2
-
---- update all qualified names in type expression
-updQNamesTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr
-updQNamesTypeExpr _ (TVar n) = TVar n
-updQNamesTypeExpr f (FuncType dom ran)
- = FuncType (updQNamesTypeExpr f dom) (updQNamesTypeExpr f ran)
-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
- 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
-isLit e = case e of
- Lit _ -> True
- _ -> False
-
---- is expression combined?
-isComb :: Expr -> Bool
-isComb e = case e of
- Comb _ _ _ -> True
- _ -> False
-
---- is expression a declaration of free variables?
-isFree :: Expr -> Bool
-isFree e = case e of
- Free _ _ -> True
- _ -> False
-
---- is expression an or-expression?
-isOr :: Expr -> Bool
-isOr e = case e of
- Or _ _ -> True
- _ -> False
-
---- is expression a case expression?
-isCase :: Expr -> Bool
-isCase e = case e of
- Case _ _ _ -> True
- _ -> False
-
---- is expression a let expression?
-isLet :: Expr -> Bool
-isLet e = case e of
- Let _ _ -> True
- _ -> False
-
---- is expression fully evaluated?
-isGround :: Expr -> Bool
-isGround expr
- = case expr of
- Comb ConsCall _ args -> all isGround args
- _ -> isLit expr
-
---- get literal if expression is literal expression
-literal :: Expr -> Maybe Literal
-literal e = case e of
- Lit l -> Just l
- _ -> Nothing
-
---- get combination type if expression is a combined expression
-combType :: Expr -> Maybe CombType
-combType e = case e of
- Comb ct _ _ -> Just ct
- _ -> Nothing
-
---- 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
-
---- is expression a call of a function where all arguments are provided?
-isFuncCall :: Expr -> Bool
-isFuncCall e = maybe False isCombFuncCall (combType e)
-
---- is expression a partial call?
-isPartCall :: Expr -> Bool
-isPartCall e = maybe False isCombPartCall (combType e)
-
---- is expression a call of a constructor?
-isConsCall :: Expr -> Bool
-isConsCall e = maybe False isCombConsCall (combType e)
-
---- get name of function if expression is a (maybe partial) function call
-combFunc :: Expr -> Maybe QName
-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
- | isConsCall e = let Comb _ name _ = e in Just name
- | otherwise = Nothing
-
---- get arguments if expression is combined
-combArgs :: Expr -> Maybe [Expr]
-combArgs e | isComb e = let Comb _ _ args = e in Just args
- | otherwise = Nothing
-
---- get number of missing function arguments if expression is combined
-missingFuncArgs :: Expr -> Maybe Int
-missingFuncArgs e = combType e >>= Just . missingArgs
-
---- is expression a combined expression with given name?
-hasName :: QName -> Expr -> Bool
-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
-
---- rename all variables (even in patterns) in expression
-rnmAllVars :: (Int -> Int) -> Expr -> Expr
-rnmAllVars f (Var n) = Var (f n)
-rnmAllVars _ (Lit l) = Lit l
-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)
- = Case ct (rnmAllVars f e) (map (rnmAllVarsBranch f) bs)
-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
-allVars :: Expr -> [Int]
-allVars (Var n) = [n]
-allVars (Lit _) = []
-allVars (Comb _ _ args) = concatMap allVars args
-allVars (Free vs e) = vs ++ allVars e
-allVars (Or e1 e2) = allVars e1 ++ allVars e2
-allVars (Case _ e bs) = allVars e ++ concatMap allVarsBranch bs
-allVars (Let bs e) = concatMap (\ (n,e') -> n:allVars e') bs ++ allVars e
-
---- map all variables in given expression
-mapVar :: (Expr -> Expr) -> Expr -> Expr
-mapVar f (Var n) = f (Var n)
-mapVar _ (Lit l) = Lit l
-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)
- = 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)
-
---- map all literals in given expression
-mapLit :: (Expr -> Expr) -> Expr -> Expr
-mapLit _ (Var n) = Var n
-mapLit f (Lit l) = f (Lit l)
-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)
- = 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)
-
---- map all combined expressions in given expression
-mapComb :: (Expr -> Expr) -> Expr -> Expr
-mapComb _ (Var n) = Var n
-mapComb _ (Lit l) = Lit l
-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)
- = Case ct (mapComb f e) (map (updBranchExpr (mapComb f)) bs)
-mapComb f (Let bs e)
- = Let (map (\ (n,e') -> (n,mapComb f e')) bs) (mapComb f e)
-
---- map all free declarations in given expression
-mapFree :: (Expr -> Expr) -> Expr -> Expr
-mapFree _ (Var n) = Var n
-mapFree _ (Lit l) = Lit l
-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)
- = Case ct (mapFree f e) (map (updBranchExpr (mapFree f)) bs)
-mapFree f (Let bs e)
- = Let (map (\ (n,e') -> (n,mapFree f e')) bs) (mapFree f e)
-
---- map all or expressions in given expression
-mapOr :: (Expr -> Expr) -> Expr -> Expr
-mapOr _ (Var n) = Var n
-mapOr _ (Lit l) = Lit l
-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)
- = 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)
-
---- map all case expressions in given expression
-mapCase :: (Expr -> Expr) -> Expr -> Expr
-mapCase _ (Var n) = Var n
-mapCase _ (Lit l) = Lit l
-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)
- = f (Case ct (mapCase f e) (map (updBranchExpr (mapCase f)) bs))
-mapCase f (Let bs e)
- = Let (map (\ (n,e') -> (n,mapCase f e')) bs) (mapCase f e)
-
---- map all let expressions in given expression
-mapLet :: (Expr -> Expr) -> Expr -> Expr
-mapLet _ (Var n) = Var n
-mapLet _ (Lit l) = Lit l
-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)
- = Case ct (mapLet f e) (map (updBranchExpr (mapLet f)) bs)
-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
- = mapComb (\ (Comb ct name args) -> Comb ct (f name) args)
- . mapCase (\ (Case ct e bs)
- -> Case ct e (map (updBranchPattern (updPatCons f)) bs))
-
--- CombType ------------------------------------------------------------------
-
---- is combination type FuncCall?
-isCombFuncCall :: CombType -> Bool
-isCombFuncCall ct = case ct of
- FuncCall -> True
- _ -> False
-
---- is combination type PartCall?
-isCombPartCall :: CombType -> Bool
-isCombPartCall ct = case ct of
- FuncPartCall _ -> True
- ConsPartCall _ -> True
- _ -> False
-
---- is combination type ConsCall?
-isCombConsCall :: CombType -> Bool
-isCombConsCall ct = case ct of
- ConsCall -> True
- _ -> False
-
---- get number of missing args from combination type
-missingArgs :: CombType -> Int
-missingArgs FuncCall = 0
-missingArgs (FuncPartCall n) = n
-missingArgs (ConsPartCall n) = n
-missingArgs ConsCall = 0 -- ConsCalls need not be fully applied (?)
-
--- BranchExpr ----------------------------------------------------------------
-
-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
-branchPattern (Branch pat _) = pat
-
---- update pattern of branch expression
-updBranchPattern :: (Pattern -> Pattern) -> BranchExpr -> BranchExpr
-updBranchPattern f = updBranch f id
-
---- get expression from branch expression
-branchExpr :: BranchExpr -> Expr
-branchExpr (Branch _ e) = e
-
---- update expression of branch expression
-updBranchExpr :: (Expr -> Expr) -> BranchExpr -> BranchExpr
-updBranchExpr f = updBranch id f
-
---- is pattern a constructor pattern?
-isConsPattern :: Pattern -> Bool
-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)
-
---- get name if pattern is a constructor pattern
-patCons :: Pattern -> Maybe QName
-patCons (Pattern name _) = Just name
-patCons (LPattern _) = Nothing
-
---- update constructors name of pattern
-updPatCons :: (QName -> QName) -> Pattern -> Pattern
-updPatCons f = updPattern f id id
-
---- get arguments if pattern is a constructor pattern
-patArgs :: Pattern -> Maybe [Int]
-patArgs (Pattern _ args) = Just args
-patArgs (LPattern _) = Nothing
-
-updPatArgs :: ([Int] -> [Int]) -> Pattern -> Pattern
-updPatArgs f = updPattern id f id
-
---- get literal if pattern is a literal pattern
-patLiteral :: Pattern -> Maybe Literal
-patLiteral (Pattern _ _) = Nothing
-patLiteral (LPattern l) = Just l
-
---- update literal of pattern
-updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern
-updPatLiteral f = updPattern id id f
-
---- build expression from pattern
-patExpr :: Pattern -> Expr
-patExpr (Pattern name args) = Comb ConsCall name (map Var args)
-patExpr (LPattern l) = Lit l
-
--- auxiliary functions -------------------------------------------------------
-
---- rename all variables in branch expression
-rnmAllVarsBranch :: (Int -> Int) -> BranchExpr -> BranchExpr
-rnmAllVarsBranch f (Branch pat e)
- = Branch (rnmAllVarsPat f pat) (rnmAllVars f e)
-
---- flatten all variables in branch expression
-allVarsBranch :: BranchExpr -> [Int]
-allVarsBranch (Branch pat e) = allVarsPat pat ++ allVars e
-
---- rename variables in pattern
-rnmAllVarsPat :: (Int -> Int) -> Pattern -> Pattern
-rnmAllVarsPat f (Pattern name args) = Pattern name (map f args)
-rnmAllVarsPat _ (LPattern l) = LPattern l
-
---- flatten pattern variables
-allVarsPat :: Pattern -> [Int]
-allVarsPat = fromMaybe [] . patArgs
-
--- opDecls ------------------------------
-
-opName :: OpDecl -> QName
-opName (Op name _ _) = name
diff --git a/Curry/FlatCurry/Type.hs b/Curry/FlatCurry/Type.hs
deleted file mode 100644
--- a/Curry/FlatCurry/Type.hs
+++ /dev/null
@@ -1,351 +0,0 @@
-{- |
- Library to support meta-programming in Curry.
-
- This library contains a definition for representing FlatCurry programs
- in Haskell (type "Prog").
-
- @author Michael Hanus
- @version September 2003
-
- Version for Haskell (slightly modified):
- December 2004, Martin Engelke (men@informatik.uni-kiel.de)
-
- Added part calls for constructors, Bernd Brassel, August 2005
--}
-
-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
---------------------------------------------------------------------------- -}
-
-{- |Data type for representing a Curry module in the intermediate form.
- A value of this data type has the form
-
- (Prog modname imports typedecls functions opdecls translation_table)
-
- where modname: name of this module,
- imports: list of modules names that are imported,
- typedecls, opdecls, functions, translation of type names
- and constructor/function names: see below
--}
-data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]
- deriving (Read, Show, Eq)
-
-{- |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 type variables.
- They are represented by (TVar i) where i is a type variable index.
--}
-type TVarIndex = Int
-
-{- |Data type for representing definitions of algebraic data types.
-
- A data type definition of the form
-
- data t x1...xn = ...| c t1....tkc |...
-
- is represented by the FlatCurry term
-
- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])
-
- where each ij is the index of the type variable xj
-
- Note: the type variable indices are unique inside each type declaration
- and are usually numbered from 0
-
- Thus, a data type declaration consists of the name of the data type,
- a list of type parameters and a list of constructor declarations.
-
--}
-data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl]
- | TypeSyn QName Visibility [TVarIndex] TypeExpr
- deriving (Read, Show, Eq)
-
-{- |A constructor declaration consists of the name and arity of the
- constructor and a list of the argument types of the constructor.
--}
-data ConsDecl = Cons QName Int Visibility [TypeExpr]
- deriving (Read, Show, Eq)
-
-{- |Data type for type expressions.
- A type expression is either a type variable, a function type,
- or a type constructor application.
-
- Note: the names of the predefined type constructors are
- "Int", "Float", "Bool", "Char", "IO", "Success",
- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
--}
-data TypeExpr
- = TVar TVarIndex -- ^ type variable
- | FuncType TypeExpr TypeExpr -- ^ function type t1->t2
- | TCons QName [TypeExpr] -- ^ type constructor application
- deriving (Read, Show, Eq)
-
-
-{- |Data 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 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 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 type for representing function declarations.
-
- A function declaration in FlatCurry is a term of the form
-
- (Func name arity type (Rule [i_1,...,i_arity] e))
-
- and represents the function "name" with definition
-
- name :: type
- name x_1...x_arity = e
-
- where each i_j is the index of the variable x_j
-
- Note: the variable indices are unique inside each function declaration
- and are usually numbered from 0
-
- External functions are represented as (Func name arity type (External s))
- where s is the external name associated to this function.
-
- Thus, a function declaration consists of the name, arity, type, and rule.
-
--}
-data FuncDecl = Func QName Int Visibility TypeExpr Rule
- deriving (Read, Show, Eq)
-
-
-{- |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.
--}
-data CaseType = Rigid | Flex deriving (Read, Show, Eq)
-
-{- |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 type for representing expressions.
-
- Remarks:
-
- 1. if-then-else expressions are represented as function calls:
- (if e1 then e2 else e3)
- is represented as
- (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])
-
- 2. Higher order applications are represented as calls to the (external)
- function "apply". For instance, the rule
- app f x = f x
- is represented as
- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))
-
- 3. A conditional rule is represented as a call to an external function
- "cond" where the first argument is the condition (a constraint).
- For instance, the rule
- equal2 x | x=:=2 = success
- is represented as
- (Rule [0]
- (Comb FuncCall ("Prelude","cond")
- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],
- Comb FuncCall ("Prelude","success") []]))
-
- 4. Functions with evaluation annotation "choice" are represented
- by a rule whose right-hand side is enclosed in a call to the
- external function "Prelude.commit".
- Furthermore, all rules of the original definition must be
- represented by conditional expressions (i.e., (cond [c,e]))
- after pattern matching.
- Example:
-
- m eval choice
- m [] y = y
- m x [] = x
-
- is translated into (note that the conditional branches can be also
- wrapped with Free declarations in general):
-
- Rule [0,1]
- (Comb FuncCall ("Prelude","commit")
- [Or (Case Rigid (Var 0)
- [(Pattern ("Prelude","[]") []
- (Comb FuncCall ("Prelude","cond")
- [Comb FuncCall ("Prelude","success") [],
- Var 1]))] )
- (Case Rigid (Var 1)
- [(Pattern ("Prelude","[]") []
- (Comb FuncCall ("Prelude","cond")
- [Comb FuncCall ("Prelude","success") [],
- Var 0]))] )])
-
- Operational meaning of (Prelude.commit e):
- evaluate e with local search spaces and commit to the first
- (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c
- is satisfied
-
--}
-data Expr
- -- |variable (represented by unique index)
- = Var VarIndex
- -- |literal (Integer/Float/Char constant)
- | Lit Literal
- -- |application (f e1 ... en) of function/constructor f with n<=arity(f)
- | Comb CombType QName [Expr]
- -- |introduction of free local variables
- | Free [VarIndex] Expr
- | Let [(VarIndex, Expr)] Expr
- {- |disjunction of two expressions (used to translate rules with overlapping
- left-hand sides) -}
- | Or Expr Expr
- -- |case distinction (rigid or flex)
- | Case CaseType Expr [BranchExpr]
- deriving (Read, Show, Eq)
-
-
-{- |Data type for representing branches in a case expression.
-
- Branches "(m.c x1...xn) -> e" in case expressions are represented as
-
- (Branch (Pattern (m,c) [i1,...,in]) e)
-
- where each ij is the index of the pattern variable xj, or as
-
- (Branch (LPattern (Intc i)) e)
-
- for integers as branch patterns (similarly for other literals
- like float or character constants).
-
--}
-data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq)
-
--- |Data type for representing patterns in case expressions.
-data Pattern = Pattern QName [VarIndex]
- | LPattern Literal
- deriving (Read, Show, Eq)
-
-{- |Data type for representing literals occurring in an expression
- or case branch. It is either an integer, a float, or a character constant.
- Note: the constructor definition of 'Intc' differs from the original
- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'
- to provide an unlimited range of integer numbers. Furthermore
- float values are represented with Haskell type 'Double' instead of
- 'Float'.
--}
-data Literal = Intc Integer
- | Floatc Double
- | Charc Char
- 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'.
--}
-readFlatCurry :: FilePath -> IO (Maybe Prog)
-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'.
--}
-readFlatInterface :: String -> IO (Maybe Prog)
-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 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'
- dropComment ('-':'}':xs) = xs
- dropComment (_:xs) = dropComment xs
- dropComment [] = []
-
-{- |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)
-
--- |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 [" ++
- intercalate ",\n " (map show types) ++ "]\n [" ++
- intercalate ",\n " (map show funcs) ++ "]\n " ++
- show ops ++ "\n"
-
--- TODO: Use replaceExtension instead?
-
--- |Add the extension 'ext' to the filename 'fn' if it doesn't already exist.
-genFlatFilename :: String -> FilePath -> FilePath
-genFlatFilename ext fn
- | drop (length fn - length ext) fn == ext
- = fn
- | otherwise
- = fn ++ ext
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,5 @@
Copyright (c) 1998-2004, Wolfgang Lux
+Copyright (c) 2005-2016, Michael Hanus
All rights reserved.
Redistribution and use in source and binary forms, with or without
diff --git a/curry-base.cabal b/curry-base.cabal
--- a/curry-base.cabal
+++ b/curry-base.cabal
@@ -1,54 +1,97 @@
Name: curry-base
-Version: 0.2.9
-Cabal-Version: >= 1.6
+Version: 1.0.0
+Cabal-Version: >= 1.10
Synopsis: Functions for manipulating Curry programs
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.
+ It defines the intermediate language formats FlatCurry.
+ Additionally, it provides functionality for the smooth
+ integration of compiler frontends and backends.
Category: Language
-License: OtherLicense
+License: BSD3
License-File: LICENSE
-Author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel,
- Björn Peemöller
-Maintainer: Björn Peemöller
-Bug-Reports: http://www-ps.informatik.uni-kiel.de/redmine/projects/curry-base
-Homepage: http://www.curry-language.org
+Author: Wolfgang Lux, Martin Engelke, Bernd Braßel, Holger Siegel,
+ Björn Peemöller, Finn Teegen
+Maintainer: fte@informatik.uni-kiel.de
+Homepage: http://curry-language.org
Build-Type: Simple
Stability: experimental
-Flag split-syb
- Description: Has the syb functionality been split into the package syb?
- Default: True
+Extra-Source-Files: CHANGELOG.md
+source-repository head
+ type: git
+ location: git://git-ps.informatik.uni-kiel.de/curry/curry-base.git
+
+Flag broken-directory
+ Description: Is the cabal configuration of directory incomplete?
+ Default: False
+
+Flag old-time
+ Description: Does the directory package use the old time implementation?
+ Default: False
+
Library
- if flag(split-syb)
- Build-Depends: base == 4.*, syb
- else
- Build-Depends: base == 3.*
+ hs-source-dirs: src
+ default-language: Haskell2010
+ Build-Depends: base == 4.*, transformers
+ if impl(ghc < 7.4)
+ Build-Depends: either < 4, contravariant < 0.5, semigroupoids < 3.0.3
+ if flag(broken-directory) {
+ Build-Depends: time, directory == 1.2.0.0, base >= 4.6
+ } else { if flag(old-time) {
+ Build-Depends: old-time, directory
+ } else {
+ Build-Depends: time, directory >= 1.2.0.1
+ }
+ }
Build-Depends:
mtl
, containers
, filepath
+ , extra >= 1.4.6
+ , parsec
, pretty
- , old-time
- , directory
ghc-options: -Wall
Exposed-Modules:
Curry.AbstractCurry
+ Curry.AbstractCurry.Files
+ Curry.AbstractCurry.Type
Curry.Base.Ident
- Curry.Base.MessageMonad
+ Curry.Base.LexComb
+ Curry.Base.LLParseComb
+ Curry.Base.Message
+ Curry.Base.Monad
Curry.Base.Position
- Curry.ExtendedFlat.CurryArithmetics
- Curry.ExtendedFlat.EraseTypes
- Curry.ExtendedFlat.Goodies
- Curry.ExtendedFlat.LiftLetrec
- Curry.ExtendedFlat.MonadicGoodies
- Curry.ExtendedFlat.Type
- Curry.ExtendedFlat.TypeInference
- Curry.ExtendedFlat.UnMutual
- Curry.FlatCurry.Goodies
- Curry.FlatCurry.Tools
- Curry.FlatCurry.Type
+ Curry.Base.Pretty
+ Curry.Base.Span
+ Curry.CondCompile.Parser
+ Curry.CondCompile.Transform
+ Curry.CondCompile.Type
Curry.Files.Filenames
Curry.Files.PathUtils
+ Curry.Files.Unlit
+ Curry.FlatCurry
+ Curry.FlatCurry.Files
+ Curry.FlatCurry.Goodies
+ Curry.FlatCurry.InterfaceEquivalence
+ Curry.FlatCurry.Pretty
+ Curry.FlatCurry.Type
+ Curry.FlatCurry.Annotated.Goodies
+ Curry.FlatCurry.Annotated.Type
+ Curry.FlatCurry.Annotated.Typing
+ Curry.Syntax
+ Curry.Syntax.Extension
+ Curry.Syntax.InterfaceEquivalence
+ Curry.Syntax.Lexer
+ Curry.Syntax.Parser
+ Curry.Syntax.Pretty
+ Curry.Syntax.ShowModule
+ Curry.Syntax.Type
+ Curry.Syntax.Utils
+
+Test-Suite test-base
+ type: detailed-0.9
+ hs-source-dirs: test
+ default-language: Haskell2010
+ test-module: TestBase
+ build-depends: base == 4.*, Cabal >= 1.20, curry-base, filepath, mtl
diff --git a/src/Curry/AbstractCurry.hs b/src/Curry/AbstractCurry.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/AbstractCurry.hs
@@ -0,0 +1,30 @@
+{- |
+ Module : $Header$
+ Description : Library to support meta-programming in Curry
+ Copyright : Michael Hanus , 2004
+ Martin Engelke , 2005
+ Björn Peemöller, 2013
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This library contains a definition for representing Curry programs
+ in Haskell by the type 'CurryProg' and I/O actions to read Curry programs
+ and transform them into this abstract representation as well as
+ write them to a file.
+
+ Note that this defines a slightly new format for AbstractCurry
+ in comparison to the first proposal of 2003.
+
+ /Assumption:/ An AbstractCurry program @Prog@ is stored in a file with
+ the file extension @acy@, i.e. in a file @Prog.acy@.
+-}
+module Curry.AbstractCurry
+ ( module Curry.AbstractCurry.Type
+ , module Curry.AbstractCurry.Files
+ ) where
+
+import Curry.AbstractCurry.Type
+import Curry.AbstractCurry.Files
diff --git a/src/Curry/AbstractCurry/Files.hs b/src/Curry/AbstractCurry/Files.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/AbstractCurry/Files.hs
@@ -0,0 +1,61 @@
+{- |
+ Module : $Header$
+ Description : Library to support meta-programming in Curry
+ Copyright : (c) Michael Hanus , 2004
+ Martin Engelke , 2005
+ Björn Peemöller, 2014
+ Finn Teegen , 2016
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This library contains I/O actions to read Curry programs
+ and transform them into this abstract representation as well as
+ write them to a file.
+-}
+module Curry.AbstractCurry.Files
+ ( readCurry, writeCurry, showCurry
+ ) where
+
+import qualified Control.Exception as C (catch)
+import Data.List (intercalate)
+
+import Curry.Files.PathUtils ( writeModule, readModule
+ , addVersion, checkVersion)
+
+import Curry.AbstractCurry.Type
+
+-- ---------------------------------------------------------------------------
+-- Reading and writing AbstractCurry terms
+-- ---------------------------------------------------------------------------
+
+-- |Read an AbstractCurry file and return the corresponding AbstractCurry
+-- program term of type 'CurryProg'
+readCurry :: FilePath -> IO (Maybe CurryProg)
+readCurry fn = do
+ mbSrc <- readModule fn
+ return $ case mbSrc of
+ Nothing -> Nothing
+ Just src -> case checkVersion version src of
+ Left _ -> Nothing
+ Right ac -> Just (read ac)
+
+-- |Write an AbstractCurry program term into a file.
+writeCurry :: FilePath -> CurryProg -> IO ()
+writeCurry fn p = C.catch (writeModule fn $ addVersion version $ showCurry p)
+ ioError
+
+-- |Show an AbstractCurry program in a nicer way
+showCurry :: CurryProg -> String
+showCurry (CurryProg mname imps dflt clss insts types funcs ops)
+ = "CurryProg " ++ show mname ++ "\n"
+ ++ show imps ++ "\n"
+ ++ showsPrec 11 dflt "\n"
+ ++ wrapList clss
+ ++ wrapList insts
+ ++ wrapList types
+ ++ wrapList funcs
+ ++ wrapList ops
+ where wrapList xs = " [" ++ intercalate ",\n " (map show xs) ++ "]\n"
diff --git a/src/Curry/AbstractCurry/Type.hs b/src/Curry/AbstractCurry/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/AbstractCurry/Type.hs
@@ -0,0 +1,330 @@
+{- |
+ Module : $Header$
+ Description : Library to support meta-programming in Curry
+ Copyright : Michael Hanus , 2004
+ Martin Engelke , 2005
+ Björn Peemöller, 2015
+ Finn Teegen , 2016
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This library contains a definition for representing Curry programs
+ in Haskell by the type 'CurryProg' and I/O actions to read Curry programs
+ and transform them into this abstract representation as well as
+ write them to a file.
+
+ Note that this defines a slightly new format for AbstractCurry
+ in comparison to the first proposal of 2003.
+-}
+module Curry.AbstractCurry.Type
+ ( CurryProg (..), MName, QName, CVisibility (..), CTVarIName
+ , CDefaultDecl (..), CClassDecl (..), CInstanceDecl (..)
+ , CTypeDecl (..), CConsDecl (..), CFieldDecl (..)
+ , CConstraint, CContext (..), CTypeExpr (..), CQualTypeExpr (..)
+ , COpDecl (..), CFixity (..), Arity, CFuncDecl (..), CRhs (..), CRule (..)
+ , CLocalDecl (..), CVarIName, CExpr (..), CCaseType (..), CStatement (..)
+ , CPattern (..), CLiteral (..), CField, version
+ ) where
+
+-- ---------------------------------------------------------------------------
+-- Abstract syntax
+-- ---------------------------------------------------------------------------
+
+-- |Current version of AbstractCurry
+version :: String
+version = "AbstractCurry 2.0"
+
+-- |A module name.
+type MName = String
+
+-- |A qualified name.
+-- 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 = (MName, String)
+
+-- |Data type to specify the visibility of various entities.
+data CVisibility
+ = Public -- ^ exported entity
+ | Private -- ^ private entity
+ deriving (Eq, Read, Show)
+
+-- |A Curry module in the intermediate form. A value of this type has the form
+-- @
+-- CurryProg modname imports dfltdecl clsdecls instdecls typedecls funcdecls opdecls
+-- @
+-- where
+-- [@modname@] Name of this module
+-- [@imports@] List of modules names that are imported
+-- [@dfltdecl@] Optional default declaration
+-- [@clsdecls@] Class declarations
+-- [@instdecls@] Instance declarations
+-- [@typedecls@] Type declarations
+-- [@funcdecls@] Function declarations
+-- [@opdecls@] Operator precedence declarations
+data CurryProg = CurryProg MName [MName] (Maybe CDefaultDecl) [CClassDecl]
+ [CInstanceDecl] [CTypeDecl] [CFuncDecl] [COpDecl]
+ deriving (Eq, Read, Show)
+
+-- |Default declaration.
+data CDefaultDecl = CDefaultDecl [CTypeExpr]
+ deriving (Eq, Read, Show)
+
+-- |Definitions of type classes.
+-- A type class definition of the form
+-- @
+-- class cx => c a where { ...;f :: t;... }
+-- @
+-- is represented by the Curry term
+-- @
+-- (CClass c v cx tv [...(CFunc f ar v t [...,CRule r,...])...])
+-- @
+-- where @tv@ is the index of the type variable @a@ and @v@ is the
+-- visibility of the type class resp. method.
+-- /Note:/ The type variable indices are unique inside each class
+-- declaration and are usually numbered from 0.
+-- The methods' types share the type class' type variable index
+-- as the class variable has to occur in a method's type signature.
+-- The list of rules for a method's declaration may be empty if
+-- no default implementation is provided. The arity @ar@ is
+-- determined by a given default implementation or 0.
+-- Regardless of whether typed or untyped abstract curry is generated,
+-- the methods' declarations are always typed.
+data CClassDecl = CClass QName CVisibility CContext CTVarIName [CFuncDecl]
+ deriving (Eq, Read, Show)
+
+-- |Definitions of instances.
+-- An instance definition of the form
+-- @
+-- instance cx => c ty where { ...;fundecl;... }
+-- @
+-- is represented by the Curry term
+-- @
+-- (CInstance c cx ty [...fundecl...])
+-- @
+-- /Note:/ The type variable indices are unique inside each instance
+-- declaration and are usually numbered from 0.
+-- The methods' types use the instance's type variable indices
+-- (if typed abstract curry is generated).
+data CInstanceDecl = CInstance QName CContext CTypeExpr [CFuncDecl]
+ deriving (Eq, Read, Show)
+
+-- |Definitions of algebraic data types and type synonyms.
+-- A data type definition of the form
+-- @
+-- data t x1...xn = ...| forall y1...ym . cx => c t1....tkc |...
+-- deriving (d1,...,dp)
+-- @
+-- is represented by the Curry term
+-- @
+-- (CType t v [i1,...,in] [...(CCons [l1,...,lm] cx c kc v [t1,...,tkc])...]
+-- [d1,...,dp])
+-- @
+-- where each @ij@ is the index of the type variable @xj@, each @lj@ is the
+-- index of the existentially quantified type variable @yj@ and @v@ is the
+-- visibility of the type resp. constructor.
+-- /Note:/ The type variable indices are unique inside each type declaration
+-- and are usually numbered from 0.
+-- Thus, a data type declaration consists of the name of the data type,
+-- a list of type parameters and a list of constructor declarations.
+data CTypeDecl
+ -- |algebraic data type
+ = CType QName CVisibility [CTVarIName] [CConsDecl] [QName]
+ -- |type synonym
+ | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr
+ -- |renaming type, may have only exactly one type expression
+ -- in the constructor declaration and no existentially type variables and
+ -- no context
+ | CNewType QName CVisibility [CTVarIName] CConsDecl [QName]
+ deriving (Eq, Read, Show)
+
+-- |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)
+
+-- |A constructor declaration consists of a list of existentially
+-- quantified type variables, a context, the name of the constructor
+-- and a list of the argument types of the constructor.
+-- The arity equals the number of types.
+data CConsDecl
+ = CCons [CTVarIName] CContext QName CVisibility [CTypeExpr]
+ | CRecord [CTVarIName] CContext QName CVisibility [CFieldDecl]
+ deriving (Eq, Read, Show)
+
+-- |A record field declaration consists of the name of the
+-- the label, the visibility and its corresponding type.
+data CFieldDecl = CField QName CVisibility CTypeExpr
+ deriving (Eq, Read, Show)
+
+-- |The type for representing a class constraint.
+type CConstraint = (QName, CTypeExpr)
+
+-- |The type for representing a context.
+data CContext = CContext [CConstraint]
+ deriving (Eq, Read, Show)
+
+-- |Type expression.
+-- A type expression is either a type variable, a function type,
+-- a type constructor or a type application.
+data CTypeExpr
+ -- |Type variable
+ = CTVar CTVarIName
+ -- |Function type @t1 -> t2@
+ | CFuncType CTypeExpr CTypeExpr
+ -- |Type constructor
+ | CTCons QName
+ -- |Type application
+ | CTApply CTypeExpr CTypeExpr
+ deriving (Eq, Read, Show)
+
+-- |Qualified type expression.
+data CQualTypeExpr = CQualType CContext CTypeExpr
+ deriving (Eq, Read, Show)
+
+-- |Labeled record fields
+type CField a = (QName, a)
+
+-- |Operator precedence declaration.
+-- An operator precedence declaration @fix p n@ in Curry corresponds to the
+-- AbstractCurry term @(COp n fix p)@.
+data COpDecl = COp QName CFixity Int
+ deriving (Eq, Read, Show)
+
+-- |Fixity declarations of infix operators
+data CFixity
+ = CInfixOp -- ^ non-associative infix operator
+ | CInfixlOp -- ^ left-associative infix operator
+ | CInfixrOp -- ^ right-associative infix operator
+ deriving (Eq, Read, Show)
+
+-- |Function arity
+type Arity = Int
+
+-- |Data type for representing function declarations.
+-- A function declaration in FlatCurry is a term of the form
+-- @
+-- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))
+-- @
+-- and represents the function @name@ with definition
+-- @
+-- name :: type
+-- rule1
+-- ...
+-- rulek
+-- @
+-- /Note:/ The variable indices are unique inside each rule.
+-- External functions are represented as
+-- @
+-- (CFunc name arity type (CExternal s))
+-- @
+-- where s is the external name associated to this function.
+-- Thus, a function declaration consists of the name, arity, type, and
+-- a list of rules.
+-- If the list of rules is empty, the function is considered
+-- to be externally defined.
+data CFuncDecl = CFunc QName Arity CVisibility CQualTypeExpr [CRule]
+ deriving (Eq, Read, Show)
+
+-- |The general form of a function 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] CRhs
+ deriving (Eq, Read, Show)
+
+-- |Right-hand-side of a 'CRule' or an @case@ expression
+data CRhs
+ = CSimpleRhs CExpr [CLocalDecl] -- @expr where decls@
+ | CGuardedRhs [(CExpr, CExpr)] [CLocalDecl] -- @| cond = expr where decls@
+ deriving (Eq, Read, Show)
+
+-- | Local (let/where) declarations
+data CLocalDecl
+ = CLocalFunc CFuncDecl -- ^ local function declaration
+ | CLocalPat CPattern CRhs -- ^ local pattern declaration
+ | CLocalVars [CVarIName] -- ^ local free variable declarations
+ deriving (Eq, Read, Show)
+
+-- |Variable names.
+-- Object variables occurring in expressions are represented by @(Var i)@
+-- where @i@ is a variable index.
+type CVarIName = (Int, String)
+
+-- |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
+ -- |functional pattern (extended Curry)
+ | CPFuncComb QName [CPattern]
+ -- |lazy pattern (extended Curry)
+ | CPLazy CPattern
+ -- |record pattern (extended curry)
+ | CPRecord QName [CField CPattern]
+ deriving (Eq, Read, Show)
+
+-- | Curry expressions.
+data CExpr
+ -- |variable (unique index / name)
+ = CVar CVarIName
+ -- |literal (Integer/Float/Char/String constant)
+ | CLit CLiteral
+ -- |a defined symbol with module and name, i.e., a function or a constructor
+ | CSymbol QName
+ -- |application (e1 e2)
+ | CApply CExpr CExpr
+ -- |lambda abstraction
+ | CLambda [CPattern] CExpr
+ -- |local let declarations
+ | CLetDecl [CLocalDecl] CExpr
+ -- |do block
+ | CDoExpr [CStatement]
+ -- |list comprehension
+ | CListComp CExpr [CStatement]
+ -- |case expression
+ | CCase CCaseType CExpr [(CPattern, CRhs)]
+ -- |typed expression
+ | CTyped CExpr CQualTypeExpr
+ -- |record construction (extended Curry)
+ | CRecConstr QName [CField CExpr]
+ -- |record update (extended Curry)
+ | CRecUpdate CExpr [CField CExpr]
+ deriving (Eq, Read, Show)
+
+-- |Literals occurring in an expression or a pattern,
+-- either an integer, a float, a character, or a string 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' to gain double precision.
+data CLiteral
+ = CIntc Integer -- ^ Int literal
+ | CFloatc Double -- ^ Float literal
+ | CCharc Char -- ^ Char literal
+ | CStringc String -- ^ String literal
+ deriving (Eq, Read, Show)
+
+-- |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 (Eq, Read, Show)
+
+-- |Type of case expressions
+data CCaseType
+ = CRigid -- ^ rigid case expression
+ | CFlex -- ^ flexible case expression
+ deriving (Eq, Read, Show)
diff --git a/src/Curry/Base/Ident.hs b/src/Curry/Base/Ident.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Base/Ident.hs
@@ -0,0 +1,952 @@
+{- |
+ Module : $Header$
+ Description : Identifiers
+ Copyright : (c) 1999 - 2004, Wolfgang Lux
+ 2011 - 2013, Björn Peemöller
+ 2016 , Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module provides the implementation of identifiers and some
+ utility functions for identifiers.
+
+ Identifiers comprise the name of the denoted entity and an /id/,
+ which can be used for renaming identifiers, e.g., in order to resolve
+ name conflicts between identifiers from different scopes. An
+ identifier with an /id/ @0@ is considered as not being renamed
+ and, hence, its /id/ will not be shown.
+
+ Qualified identifiers may optionally be prefixed by a module name.
+-}
+
+module Curry.Base.Ident
+ ( -- * Module identifiers
+ ModuleIdent (..), mkMIdent, moduleName, escModuleName
+ , fromModuleName, isValidModuleName, addPositionModuleIdent
+
+ -- * Local identifiers
+ , Ident (..), mkIdent, showIdent, escName, identSupply
+ , globalScope, hasGlobalScope, isRenamed, renameIdent, unRenameIdent
+ , updIdentName, addPositionIdent, isInfixOp
+
+ -- * Qualified identifiers
+ , QualIdent (..), qualName, escQualName, qidPosition, isQInfixOp, qualify
+ , qualifyWith, qualQualify, qualifyLike, isQualified, unqualify, qualUnqualify
+ , localIdent, isLocalIdent, updQualIdent
+
+ -- * Predefined simple identifiers
+ -- ** Identifiers for modules
+ , emptyMIdent, mainMIdent, preludeMIdent
+ -- ** Identifiers for types
+ , arrowId, unitId, boolId, charId, intId, floatId, listId, ioId, successId
+ -- ** Identifiers for type classes
+ , eqId, ordId, enumId, boundedId, readId, showId
+ , numId, fractionalId
+ , monadId
+ -- ** Identifiers for constructors
+ , trueId, falseId, nilId, consId, tupleId, isTupleId, tupleArity
+ -- ** Identifiers for values
+ , mainId, minusId, fminusId, applyId, errorId, failedId, idId
+ , succId, predId, toEnumId, fromEnumId, enumFromId, enumFromThenId
+ , enumFromToId, enumFromThenToId
+ , maxBoundId, minBoundId
+ , lexId, readsPrecId, readParenId
+ , showsPrecId, showParenId, showStringId
+ , andOpId, eqOpId, leqOpId, ltOpId, orOpId, appendOpId, dotOpId
+ , anonId, isAnonId
+
+ -- * Predefined qualified identifiers
+ -- ** Identifiers for types
+ , qArrowId, qUnitId, qBoolId, qCharId, qIntId, qFloatId, qListId, qIOId
+ , qSuccessId, isPrimTypeId
+ -- ** Identifiers for type classes
+ , qEqId, qOrdId, qEnumId, qBoundedId, qReadId, qShowId
+ , qNumId, qFractionalId
+ , qMonadId
+ -- ** Identifiers for constructors
+ , qTrueId, qFalseId, qNilId, qConsId, qTupleId, isQTupleId, qTupleArity
+ -- ** Identifiers for values
+ , qApplyId, qErrorId, qFailedId, qIdId
+ , qFromEnumId, qEnumFromId, qEnumFromThenId, qEnumFromToId, qEnumFromThenToId
+ , qMaxBoundId, qMinBoundId
+ , qLexId, qReadsPrecId, qReadParenId
+ , qShowsPrecId, qShowParenId, qShowStringId
+ , qAndOpId, qEqOpId, qLeqOpId, qLtOpId, qOrOpId, qAppendOpId, qDotOpId
+
+ -- * Extended functionality
+ -- ** Functional patterns
+ , fpSelectorId, isFpSelectorId, isQualFpSelectorId
+ -- ** Records
+ , recSelectorId, qualRecSelectorId, recUpdateId, qualRecUpdateId
+ , recordExt, recordExtId, isRecordExtId, fromRecordExtId
+ , labelExt, labelExtId, isLabelExtId, fromLabelExtId
+ , renameLabel, mkLabelIdent
+ ) where
+
+import Data.Char (isAlpha, isAlphaNum)
+import Data.Function (on)
+import Data.List (intercalate, isInfixOf, isPrefixOf)
+import Data.Maybe (isJust, fromMaybe)
+
+import Curry.Base.Position
+import Curry.Base.Pretty
+
+-- ---------------------------------------------------------------------------
+-- Module identifier
+-- ---------------------------------------------------------------------------
+
+-- | Module identifier
+data ModuleIdent = ModuleIdent
+ { midPosition :: Position -- ^ source code 'Position'
+ , midQualifiers :: [String] -- ^ hierarchical idenfiers
+ } deriving (Read, Show)
+
+instance Eq ModuleIdent where
+ (==) = (==) `on` midQualifiers
+
+instance Ord ModuleIdent where
+ compare = compare `on` midQualifiers
+
+instance HasPosition ModuleIdent where
+ getPosition = midPosition
+ setPosition = addPositionModuleIdent
+
+instance Pretty ModuleIdent where
+ pPrint = hcat . punctuate dot . map text . midQualifiers
+
+-- |Construct a 'ModuleIdent' from a list of 'String's forming the
+-- the hierarchical module name.
+mkMIdent :: [String] -> ModuleIdent
+mkMIdent = ModuleIdent NoPos
+
+-- |Retrieve the hierarchical name of a module
+moduleName :: ModuleIdent -> String
+moduleName = intercalate "." . midQualifiers
+
+-- |Show the name of an 'ModuleIdent' escaped by ticks
+escModuleName :: ModuleIdent -> String
+escModuleName m = '`' : moduleName m ++ "'"
+
+-- |Add a source code 'Position' to a 'ModuleIdent'
+addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent
+addPositionModuleIdent pos mi = mi { midPosition = pos }
+
+-- |Check whether a 'String' is a valid module name.
+--
+-- Valid module names must satisfy the following conditions:
+--
+-- * The name must not be empty
+-- * The name must consist of one or more single identifiers,
+-- seperated by dots
+-- * Each single identifier must be non-empty, start with a letter and
+-- consist of letter, digits, single quotes or underscores only
+isValidModuleName :: String -> Bool
+isValidModuleName [] = False -- Module names may not be empty
+isValidModuleName qs = all isModuleIdentifier $ splitIdentifiers qs
+ where
+ -- components of a module identifier may not be null
+ isModuleIdentifier [] = False
+ -- components of a module identifier must start with a letter and consist
+ -- of letter, digits, underscores or single quotes
+ isModuleIdentifier (c:cs) = isAlpha c && all isIdent cs
+ isIdent c = isAlphaNum c || c `elem` "'_"
+
+-- |Resemble the hierarchical module name from a 'String' by splitting
+-- the 'String' at inner dots.
+--
+-- /Note:/ This function does not check the 'String' to be a valid module
+-- identifier, use isValidModuleName for this purpose.
+fromModuleName :: String -> ModuleIdent
+fromModuleName = mkMIdent . splitIdentifiers
+
+-- Auxiliary function to split a hierarchical module identifier at the dots
+splitIdentifiers :: String -> [String]
+splitIdentifiers s = let (pref, rest) = break (== '.') s in
+ pref : case rest of
+ [] -> []
+ (_:s') -> splitIdentifiers s'
+
+-- ---------------------------------------------------------------------------
+-- Simple identifier
+-- ---------------------------------------------------------------------------
+
+-- |Simple identifier
+data Ident = Ident
+ { idPosition :: Position -- ^ Source code 'Position'
+ , idName :: String -- ^ Name of the identifier
+ , idUnique :: Integer -- ^ Unique number of the identifier
+ } deriving (Read, Show)
+
+instance Eq Ident where
+ Ident _ m i == Ident _ n j = (m, i) == (n, j)
+
+instance Ord Ident where
+ Ident _ m i `compare` Ident _ n j = (m, i) `compare` (n, j)
+
+instance HasPosition Ident where
+ getPosition = idPosition
+ setPosition = addPositionIdent
+
+instance Pretty Ident where
+ pPrint (Ident _ x n) | n == globalScope = text x
+ | otherwise = text x <> dot <> integer n
+
+-- |Global scope for renaming
+globalScope :: Integer
+globalScope = 0
+
+-- |Construct an 'Ident' from a 'String'
+mkIdent :: String -> Ident
+mkIdent x = Ident NoPos x globalScope
+
+-- |Infinite list of different 'Ident's
+identSupply :: [Ident]
+identSupply = [ mkNewIdent c i | i <- [0 ..] :: [Integer], c <- ['a'..'z'] ]
+ where mkNewIdent c 0 = mkIdent [c]
+ mkNewIdent c n = mkIdent $ c : show n
+
+-- |Show function for an 'Ident'
+showIdent :: Ident -> String
+showIdent (Ident _ x n) | n == globalScope = x
+ | otherwise = x ++ '.' : show n
+
+-- |Show the name of an 'Ident' escaped by ticks
+escName :: Ident -> String
+escName i = '`' : idName i ++ "'"
+
+-- |Has the identifier global scope?
+hasGlobalScope :: Ident -> Bool
+hasGlobalScope = (== globalScope) . idUnique
+
+-- |Is the 'Ident' renamed?
+isRenamed :: Ident -> Bool
+isRenamed = (/= globalScope) . idUnique
+
+-- |Rename an 'Ident' by changing its unique number
+renameIdent :: Ident -> Integer -> Ident
+renameIdent ident n = ident { idUnique = n }
+
+-- |Revert the renaming of an 'Ident' by resetting its unique number
+unRenameIdent :: Ident -> Ident
+unRenameIdent ident = renameIdent ident globalScope
+
+-- |Change the name of an 'Ident' using a renaming function
+updIdentName :: (String -> String) -> Ident -> Ident
+updIdentName f (Ident p n i) = Ident p (f n) i
+
+-- |Add a 'Position' to an 'Ident'
+addPositionIdent :: Position -> Ident -> Ident
+addPositionIdent pos (Ident NoPos x n) = Ident pos x n
+addPositionIdent pos (Ident _ x n) = Ident pos x n
+
+-- |Check whether an 'Ident' identifies an infix operation
+isInfixOp :: Ident -> Bool
+isInfixOp (Ident _ ('<' : c : cs) _) =
+ last (c : cs) /= '>' || not (isAlphaNum c) && c `notElem` "_(["
+isInfixOp (Ident _ (c : _) _) = not (isAlphaNum c) && c `notElem` "_(["
+isInfixOp (Ident _ _ _) = False -- error "Zero-length identifier"
+
+-- ---------------------------------------------------------------------------
+-- Qualified identifier
+-- ---------------------------------------------------------------------------
+
+-- |Qualified identifier
+data QualIdent = QualIdent
+ { qidModule :: Maybe ModuleIdent -- ^ optional module identifier
+ , qidIdent :: Ident -- ^ identifier itself
+ } deriving (Eq, Ord, Read, Show)
+
+instance HasPosition QualIdent where
+ getPosition = getPosition . qidIdent
+ setPosition p q = q { qidIdent = setPosition p $ qidIdent q }
+
+instance Pretty QualIdent where
+ pPrint = text . qualName
+
+-- |show function for qualified identifiers
+qualName :: QualIdent -> String
+qualName (QualIdent Nothing x) = idName x
+qualName (QualIdent (Just m) x) = moduleName m ++ "." ++ idName x
+
+-- |Show the name of an 'QualIdent' escaped by ticks
+escQualName :: QualIdent -> String
+escQualName qn = '`' : qualName qn ++ "'"
+
+-- |Retrieve the 'Position' of a 'QualIdent'
+qidPosition :: QualIdent -> Position
+qidPosition = idPosition . qidIdent
+
+-- |Check whether an 'QualIdent' identifies an infix operation
+isQInfixOp :: QualIdent -> Bool
+isQInfixOp = isInfixOp . qidIdent
+
+-- ---------------------------------------------------------------------------
+-- The functions \texttt{qualify} and \texttt{qualifyWith} convert an
+-- unqualified identifier into a qualified identifier (without and with a
+-- given module prefix, respectively).
+-- ---------------------------------------------------------------------------
+
+-- | 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
+
+-- |Qualify an 'Ident' with the 'ModuleIdent' of the given 'QualIdent',
+-- if present.
+qualifyLike :: QualIdent -> Ident -> QualIdent
+qualifyLike (QualIdent Nothing _) x = qualify x
+qualifyLike (QualIdent (Just m) _) x = qualifyWith m x
+
+-- | Check whether a 'QualIdent' contains a 'ModuleIdent'
+isQualified :: QualIdent -> Bool
+isQualified = isJust . qidModule
+
+-- | Remove the qualification of an 'QualIdent'
+unqualify :: QualIdent -> Ident
+unqualify = qidIdent
+
+-- | 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'
+
+-- | Extract the 'Ident' of an 'QualIdent' if it is local to the
+-- 'ModuleIdent', i.e. if the 'Ident' is either unqualified or qualified
+-- with the given 'ModuleIdent'.
+localIdent :: ModuleIdent -> QualIdent -> Maybe Ident
+localIdent _ (QualIdent Nothing x) = Just x
+localIdent m (QualIdent (Just m') x)
+ | m == m' = Just x
+ | otherwise = Nothing
+
+-- |Check whether the given 'QualIdent' is local to the given 'ModuleIdent'.
+isLocalIdent :: ModuleIdent -> QualIdent -> Bool
+isLocalIdent mid qid = isJust (localIdent mid qid)
+
+-- | Update a 'QualIdent' by applying functions to its components
+updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident)
+ -> QualIdent -> QualIdent
+updQualIdent f g (QualIdent m x) = QualIdent (fmap f m) (g x)
+
+-- ---------------------------------------------------------------------------
+-- A few identifiers are predefined here.
+-- ---------------------------------------------------------------------------
+
+-- | 'ModuleIdent' for the empty module
+emptyMIdent :: ModuleIdent
+emptyMIdent = ModuleIdent NoPos []
+
+-- | 'ModuleIdent' for the main module
+mainMIdent :: ModuleIdent
+mainMIdent = ModuleIdent NoPos ["main"]
+
+-- | 'ModuleIdent' for the Prelude
+preludeMIdent :: ModuleIdent
+preludeMIdent = ModuleIdent NoPos ["Prelude"]
+
+-- ---------------------------------------------------------------------------
+-- Identifiers for types
+-- ---------------------------------------------------------------------------
+
+-- | 'Ident' for the type '(->)'
+arrowId :: Ident
+arrowId = mkIdent "(->)"
+
+-- | '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"
+
+-- | Construct an 'Ident' for an n-ary tuple where n > 1
+tupleId :: Int -> Ident
+tupleId n
+ | n > 1 = mkIdent $ '(' : replicate (n - 1) ',' ++ ")"
+ | otherwise = error $ "Curry.Base.Ident.tupleId: wrong arity " ++ show n
+
+-- | Check whether an 'Ident' is an identifier for an tuple type
+isTupleId :: Ident -> Bool
+isTupleId (Ident _ x _) = n > 1 && x == idName (tupleId n)
+ where n = length x - 1
+
+-- | Compute the arity of a tuple identifier
+tupleArity :: Ident -> Int
+tupleArity i@(Ident _ x _)
+ | n > 1 && x == idName (tupleId n) = n
+ | otherwise = error $
+ "Curry.Base.Ident.tupleArity: no tuple identifier: " ++ showIdent i
+ where n = length x - 1
+
+-- ---------------------------------------------------------------------------
+-- Identifiers for type classes
+-- ---------------------------------------------------------------------------
+
+-- | 'Ident' for the 'Eq' class
+eqId :: Ident
+eqId = mkIdent "Eq"
+
+-- | 'Ident' for the 'Ord' class
+ordId :: Ident
+ordId = mkIdent "Ord"
+
+-- | 'Ident' for the 'Enum' class
+enumId :: Ident
+enumId = mkIdent "Enum"
+
+-- | 'Ident' for the 'Bounded' class
+boundedId :: Ident
+boundedId = mkIdent "Bounded"
+
+-- | 'Ident' for the 'Read' class
+readId :: Ident
+readId = mkIdent "Read"
+
+-- | 'Ident' for the 'Show' class
+showId :: Ident
+showId = mkIdent "Show"
+
+-- | 'Ident' for the 'Num' class
+numId :: Ident
+numId = mkIdent "Num"
+
+-- | 'Ident' for the 'Fractional' class
+fractionalId :: Ident
+fractionalId = mkIdent "Fractional"
+
+-- | 'Ident' for the 'Monad' class
+monadId :: Ident
+monadId = mkIdent "Monad"
+
+-- ---------------------------------------------------------------------------
+-- 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 ":"
+
+-- ---------------------------------------------------------------------------
+-- Identifiers for values
+-- ---------------------------------------------------------------------------
+
+-- | 'Ident' for the main function
+mainId :: Ident
+mainId = mkIdent "main"
+
+-- | 'Ident' for the minus function
+minusId :: Ident
+minusId = mkIdent "-"
+
+-- | 'Ident' for the minus function for Floats
+fminusId :: Ident
+fminusId = mkIdent "-."
+
+-- | 'Ident' for the apply function
+applyId :: Ident
+applyId = mkIdent "apply"
+
+-- | 'Ident' for the error function
+errorId :: Ident
+errorId = mkIdent "error"
+
+-- | 'Ident' for the failed function
+failedId :: Ident
+failedId = mkIdent "failed"
+
+-- | 'Ident' for the id function
+idId :: Ident
+idId = mkIdent "id"
+
+-- | 'Ident' for the maxBound function
+maxBoundId :: Ident
+maxBoundId = mkIdent "maxBound"
+
+-- | 'Ident' for the minBound function
+minBoundId :: Ident
+minBoundId = mkIdent "minBound"
+
+-- | 'Ident' for the pred function
+predId :: Ident
+predId = mkIdent "pred"
+
+-- | 'Ident' for the succ function
+succId :: Ident
+succId = mkIdent "succ"
+
+-- | 'Ident' for the toEnum function
+toEnumId :: Ident
+toEnumId = mkIdent "toEnum"
+
+-- | 'Ident' for the fromEnum function
+fromEnumId :: Ident
+fromEnumId = mkIdent "fromEnum"
+
+-- | 'Ident' for the enumFrom function
+enumFromId :: Ident
+enumFromId = mkIdent "enumFrom"
+
+-- | 'Ident' for the enumFromThen function
+enumFromThenId :: Ident
+enumFromThenId = mkIdent "enumFromThen"
+
+-- | 'Ident' for the enumFromTo function
+enumFromToId :: Ident
+enumFromToId = mkIdent "enumFromTo"
+
+-- | 'Ident' for the enumFromThenTo function
+enumFromThenToId :: Ident
+enumFromThenToId = mkIdent "enumFromThenTo"
+
+-- | 'Ident' for the lex function
+lexId :: Ident
+lexId = mkIdent "lex"
+
+-- | 'Ident' for the readsPrec function
+readsPrecId :: Ident
+readsPrecId = mkIdent "readsPrec"
+
+-- | 'Ident' for the readParen function
+readParenId :: Ident
+readParenId = mkIdent "readParen"
+
+-- | 'Ident' for the showsPrec function
+showsPrecId :: Ident
+showsPrecId = mkIdent "showsPrec"
+
+-- | 'Ident' for the showParen function
+showParenId :: Ident
+showParenId = mkIdent "showParen"
+
+-- | 'Ident' for the showString function
+showStringId :: Ident
+showStringId = mkIdent "showString"
+
+-- | 'Ident' for the '&&' operator
+andOpId :: Ident
+andOpId = mkIdent "&&"
+
+-- | 'Ident' for the '==' operator
+eqOpId :: Ident
+eqOpId = mkIdent "=="
+
+-- | 'Ident' for the '<=' operator
+leqOpId :: Ident
+leqOpId = mkIdent "<="
+
+-- | 'Ident' for the '<' operator
+ltOpId :: Ident
+ltOpId = mkIdent "<"
+
+-- | 'Ident' for the '||' operator
+orOpId :: Ident
+orOpId = mkIdent "||"
+
+-- | 'Ident' for the '++' operator
+appendOpId :: Ident
+appendOpId = mkIdent "++"
+
+-- | 'Ident' for the '.' operator
+dotOpId :: Ident
+dotOpId = mkIdent "."
+
+-- | 'Ident' for anonymous variable
+anonId :: Ident
+anonId = mkIdent "_"
+
+-- |Check whether an 'Ident' represents an anonymous identifier ('anonId')
+isAnonId :: Ident -> Bool
+isAnonId = (== anonId) . unRenameIdent
+
+-- ---------------------------------------------------------------------------
+-- Qualified Identifiers for types
+-- ---------------------------------------------------------------------------
+
+-- | Construct a 'QualIdent' for an 'Ident' using the module prelude
+qPreludeIdent :: Ident -> QualIdent
+qPreludeIdent = qualifyWith preludeMIdent
+
+-- | 'QualIdent' for the type '(->)'
+qArrowId :: QualIdent
+qArrowId = qualify arrowId
+
+-- | 'QualIdent' for the type/value unit ('()')
+qUnitId :: QualIdent
+qUnitId = qualify unitId
+
+-- | 'QualIdent' for the type '[]'
+qListId :: QualIdent
+qListId = qualify listId
+
+-- | '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 'IO'
+qIOId :: QualIdent
+qIOId = qPreludeIdent ioId
+
+-- | 'QualIdent' for the type 'Success'
+qSuccessId :: QualIdent
+qSuccessId = qPreludeIdent successId
+
+-- | Check whether an 'QualIdent' is an primary type constructor
+isPrimTypeId :: QualIdent -> Bool
+isPrimTypeId tc = tc `elem` [qArrowId, qUnitId, qListId] || isQTupleId tc
+
+-- ---------------------------------------------------------------------------
+-- Qualified Identifiers for type classes
+-- ---------------------------------------------------------------------------
+
+-- | 'QualIdent' for the 'Eq' class
+qEqId :: QualIdent
+qEqId = qPreludeIdent eqId
+
+-- | 'QualIdent' for the 'Ord' class
+qOrdId :: QualIdent
+qOrdId = qPreludeIdent ordId
+
+-- | 'QualIdent' for the 'Enum' class
+qEnumId :: QualIdent
+qEnumId = qPreludeIdent enumId
+
+-- | 'QualIdent' for the 'Bounded' class
+qBoundedId :: QualIdent
+qBoundedId = qPreludeIdent boundedId
+
+-- | 'QualIdent' for the 'Read' class
+qReadId :: QualIdent
+qReadId = qPreludeIdent readId
+
+-- | 'QualIdent' for the 'Show' class
+qShowId :: QualIdent
+qShowId = qPreludeIdent showId
+
+-- | 'QualIdent' for the 'Num' class
+qNumId :: QualIdent
+qNumId = qPreludeIdent numId
+
+-- | 'QualIdent' for the 'Fractional' class
+qFractionalId :: QualIdent
+qFractionalId = qPreludeIdent fractionalId
+
+-- | 'QualIdent' for the 'Monad' class
+qMonadId :: QualIdent
+qMonadId = qPreludeIdent monadId
+
+-- ---------------------------------------------------------------------------
+-- 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 = 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
+
+-- ---------------------------------------------------------------------------
+-- Qualified Identifiers for values
+-- ---------------------------------------------------------------------------
+
+-- | 'QualIdent' for the apply function
+qApplyId :: QualIdent
+qApplyId = qPreludeIdent applyId
+
+-- | 'QualIdent' for the error function
+qErrorId :: QualIdent
+qErrorId = qPreludeIdent errorId
+
+-- | 'QualIdent' for the failed function
+qFailedId :: QualIdent
+qFailedId = qPreludeIdent failedId
+
+-- | 'QualIdent' for the id function
+qIdId :: QualIdent
+qIdId = qPreludeIdent idId
+
+-- | 'QualIdent' for the maxBound function
+qMaxBoundId :: QualIdent
+qMaxBoundId = qPreludeIdent maxBoundId
+
+-- | 'QualIdent' for the minBound function
+qMinBoundId :: QualIdent
+qMinBoundId = qPreludeIdent minBoundId
+
+-- | 'QualIdent' for the fromEnum function
+qFromEnumId :: QualIdent
+qFromEnumId = qPreludeIdent fromEnumId
+
+-- | 'QualIdent' for the enumFrom function
+qEnumFromId :: QualIdent
+qEnumFromId = qPreludeIdent enumFromId
+
+-- | 'QualIdent' for the enumFromThen function
+qEnumFromThenId :: QualIdent
+qEnumFromThenId = qPreludeIdent enumFromThenId
+
+-- | 'QualIdent' for the enumFromTo function
+qEnumFromToId :: QualIdent
+qEnumFromToId = qPreludeIdent enumFromToId
+
+-- | 'QualIdent' for the enumFromThenTo function
+qEnumFromThenToId :: QualIdent
+qEnumFromThenToId = qPreludeIdent enumFromThenToId
+
+-- | 'QualIdent' for the lex function
+qLexId :: QualIdent
+qLexId = qPreludeIdent lexId
+
+-- | 'QualIdent' for the readsPrec function
+qReadsPrecId :: QualIdent
+qReadsPrecId = qPreludeIdent readsPrecId
+
+-- | 'QualIdent' for the readParen function
+qReadParenId :: QualIdent
+qReadParenId = qPreludeIdent readParenId
+
+-- | 'QualIdent' for the showsPrec function
+qShowsPrecId :: QualIdent
+qShowsPrecId = qPreludeIdent showsPrecId
+
+-- | 'QualIdent' for the showParen function
+qShowParenId :: QualIdent
+qShowParenId = qPreludeIdent showParenId
+
+-- | 'QualIdent' for the showString function
+qShowStringId :: QualIdent
+qShowStringId = qPreludeIdent showStringId
+
+-- | 'QualIdent' for the '&&' operator
+qAndOpId :: QualIdent
+qAndOpId = qPreludeIdent andOpId
+
+-- | 'QualIdent' for the '==' operator
+qEqOpId :: QualIdent
+qEqOpId = qPreludeIdent eqOpId
+
+-- | 'QualIdent' for the '<=' operator
+qLeqOpId :: QualIdent
+qLeqOpId = qPreludeIdent leqOpId
+
+-- | 'QualIdent' for the '<' operator
+qLtOpId :: QualIdent
+qLtOpId = qPreludeIdent ltOpId
+
+-- | 'QualIdent' for the '||' operator
+qOrOpId :: QualIdent
+qOrOpId = qPreludeIdent orOpId
+
+-- | 'QualIdent' for the '.' operator
+qDotOpId :: QualIdent
+qDotOpId = qPreludeIdent dotOpId
+
+-- | 'QualIdent' for the '++' operator
+qAppendOpId :: QualIdent
+qAppendOpId = qPreludeIdent appendOpId
+
+-- ---------------------------------------------------------------------------
+-- Micellaneous functions for generating and testing extended identifiers
+-- ---------------------------------------------------------------------------
+
+-- Functional patterns
+
+-- | Annotation for function pattern identifiers
+fpSelExt :: String
+fpSelExt = "_#selFP"
+
+-- | Construct an 'Ident' for a functional pattern
+fpSelectorId :: Int -> Ident
+fpSelectorId n = mkIdent $ fpSelExt ++ show n
+
+-- | Check whether an 'Ident' is an identifier for a functional pattern
+isFpSelectorId :: Ident -> Bool
+isFpSelectorId = (fpSelExt `isInfixOf`) . idName
+
+-- | Check whether an 'QualIdent' is an identifier for a function pattern
+isQualFpSelectorId :: QualIdent -> Bool
+isQualFpSelectorId = isFpSelectorId . unqualify
+
+-- Record selection
+
+-- | Annotation for record selection identifiers
+recSelExt :: String
+recSelExt = "_#selR@"
+
+-- | Construct an 'Ident' for a record selection pattern
+recSelectorId :: QualIdent -- ^ identifier of the record
+ -> Ident -- ^ identifier of the label
+ -> Ident
+recSelectorId = mkRecordId recSelExt
+
+-- | Construct a 'QualIdent' for a record selection pattern
+qualRecSelectorId :: ModuleIdent -- ^ default module
+ -> QualIdent -- ^ record identifier
+ -> Ident -- ^ label identifier
+ -> QualIdent
+qualRecSelectorId m r l = qualRecordId m r $ recSelectorId r l
+
+-- Record update
+
+-- | Annotation for record update identifiers
+recUpdExt :: String
+recUpdExt = "_#updR@"
+
+-- | Construct an 'Ident' for a record update pattern
+recUpdateId :: QualIdent -- ^ record identifier
+ -> Ident -- ^ label identifier
+ -> Ident
+recUpdateId = mkRecordId recUpdExt
+
+-- | Construct a 'QualIdent' for a record update pattern
+qualRecUpdateId :: ModuleIdent -- ^ default module
+ -> QualIdent -- ^ record identifier
+ -> Ident -- ^ label identifier
+ -> QualIdent
+qualRecUpdateId m r l = qualRecordId m r $ recUpdateId r l
+
+-- Auxiliary function to construct a selector/update identifier
+mkRecordId :: String -> QualIdent -> Ident -> Ident
+mkRecordId ann r l = mkIdent $ concat
+ [ann, idName (unqualify r), ".", idName l]
+
+-- Auxiliary function to qualify a selector/update identifier
+qualRecordId :: ModuleIdent -> QualIdent -> Ident -> QualIdent
+qualRecordId m r = qualifyWith (fromMaybe m $ qidModule r)
+
+-- Record tyes
+
+-- | Annotation for record identifiers
+recordExt :: String
+recordExt = "_#Rec:"
+
+-- | Construct an 'Ident' for a record
+recordExtId :: Ident -> Ident
+recordExtId r = mkIdent $ recordExt ++ idName r
+
+-- | Check whether an 'Ident' is an identifier for a record
+isRecordExtId :: Ident -> Bool
+isRecordExtId = (recordExt `isPrefixOf`) . idName
+
+-- | Retrieve the 'Ident' from a record identifier
+fromRecordExtId :: Ident -> Ident
+fromRecordExtId r
+ | p == recordExt = mkIdent r'
+ | otherwise = r
+ where (p, r') = splitAt (length recordExt) (idName r)
+
+-- Record labels
+
+-- | Annotation for record label identifiers
+labelExt :: String
+labelExt = "_#Lab:"
+
+-- | Construct an 'Ident' for a record label
+labelExtId :: Ident -> Ident
+labelExtId l = mkIdent $ labelExt ++ idName l
+
+-- | Check whether an 'Ident' is an identifier for a record label
+isLabelExtId :: Ident -> Bool
+isLabelExtId = (labelExt `isPrefixOf`) . idName
+
+-- | Retrieve the 'Ident' from a record label identifier
+fromLabelExtId :: Ident -> Ident
+fromLabelExtId l
+ | p == labelExt = mkIdent l'
+ | otherwise = l
+ where (p, l') = splitAt (length labelExt) (idName 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)
diff --git a/src/Curry/Base/LLParseComb.hs b/src/Curry/Base/LLParseComb.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Base/LLParseComb.hs
@@ -0,0 +1,366 @@
+{- |
+ Module : $Header$
+ Description : Parser combinators
+ Copyright : (c) 1999-2004, Wolfgang Lux
+ 2016 , Jan Tikovsky
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ The parsing combinators implemented in this module are based on the
+ LL(1) parsing combinators developed by Swierstra and Duponcheel.
+ They have been adapted to using continuation passing style in order to
+ work with the lexing combinators described in the previous section.
+ In addition, the facilities for error correction are omitted
+ in this implementation.
+
+ The two functions 'applyParser' and 'prefixParser' use the specified
+ parser for parsing a string. When 'applyParser' is used, an error is
+ reported if the parser does not consume the whole string,
+ whereas 'prefixParser' discards the rest of the input string in this case.
+-}
+{-# LANGUAGE CPP #-}
+
+module Curry.Base.LLParseComb
+ ( -- * Data types
+ Parser
+
+ -- * Parser application
+ , fullParser, prefixParser
+
+ -- * Basic parsers
+ , position, succeed, failure, symbol
+
+ -- * parser combinators
+ , (), (<|>), (<|?>), (<*>), (<\>), (<\\>)
+ , (<$>), (<$->), (<*->), (<-*>), (<**>), (), (<.>)
+ , opt, choice, flag, optional, option, many, many1, sepBy, sepBy1
+ , chainr, chainr1, chainl, chainl1, between, ops
+
+ -- * Layout combinators
+ , layoutOn, layoutOff, layoutEnd
+ ) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative (Applicative, (<*>), (<$>), pure)
+#endif
+import Control.Monad
+import qualified Data.Map as Map
+import Data.Maybe
+import qualified Data.Set as Set
+
+import Curry.Base.LexComb
+import Curry.Base.Position
+import Curry.Base.Span (span2Pos)
+
+infixl 5 <\>, <\\>
+infixl 4 <$->, <*->, <-*>, <**>, , <.>
+infixl 3 <|>, <|?>
+infixl 2 , `opt`
+
+-- ---------------------------------------------------------------------------
+-- Parser types
+-- ---------------------------------------------------------------------------
+
+-- |Parsing function
+type ParseFun a s b = (b -> SuccessP s a) -> FailP a -> SuccessP s a
+
+-- |CPS-Parser type
+data Parser a s b = Parser
+ -- Parsing function for empty word
+ (Maybe (ParseFun a s b))
+ -- Lookup table (continuations for 'Symbol's recognized by the parser)
+ (Map.Map s (Lexer s a -> ParseFun a s b))
+
+instance Symbol s => Functor (Parser a s) where
+ fmap f p = succeed f <*> p
+
+instance Symbol s => Applicative (Parser a s) where
+ pure = succeed
+
+ -- |Apply the result function of the first parser to the result of the
+ -- second parser.
+ Parser Nothing ps1 <*> p2 = Parser Nothing
+ (fmap (flip seqPP p2) ps1)
+ Parser (Just p1) ps1 <*> ~p2@(Parser e2 ps2) = Parser (fmap (seqEE p1) e2)
+ (Map.union (fmap (flip seqPP p2) ps1) (fmap (seqEP p1) ps2))
+
+instance Show s => Show (Parser a s b) where
+ showsPrec p (Parser e ps) = showParen (p >= 10) $
+ showString "Parser " . shows (isJust e) .
+ showChar ' ' . shows (Map.keysSet ps)
+
+-- ---------------------------------------------------------------------------
+-- Parser application
+-- ---------------------------------------------------------------------------
+
+-- |Apply a parser and lexer to a 'String', whereas the 'FilePath' is used
+-- to identify the origin of the 'String' in case of parsing errors.
+fullParser :: Symbol s => Parser a s a -> Lexer s a -> FilePath -> String
+ -> CYM a
+fullParser p lexer = parse (lexer (choose p lexer successP failP) failP)
+ where successP x pos s
+ | isEOF s = returnP x
+ | otherwise = failP pos (unexpected s)
+
+-- |Apply a parser and lexer to parse the beginning of a 'String'.
+-- The 'FilePath' is used to identify the origin of the 'String' in case of
+-- parsing errors.
+prefixParser :: Symbol s => Parser a s a -> Lexer s a -> FilePath -> String
+ -> CYM a
+prefixParser p lexer = parse (lexer (choose p lexer discardP failP) failP)
+ where discardP x _ _ = returnP x
+
+-- |Choose the appropriate parsing function w.r.t. to the next 'Symbol'.
+choose :: Symbol s => Parser a s b -> Lexer s a -> ParseFun a s b
+choose (Parser e ps) lexer success failp pos s = case Map.lookup s ps of
+ Just p -> p lexer success failp pos s
+ Nothing -> case e of
+ Just p -> p success failp pos s
+ Nothing -> failp pos (unexpected s)
+
+-- |Fail on an unexpected 'Symbol'
+unexpected :: Symbol s => s -> String
+unexpected s
+ | isEOF s = "Unexpected end-of-file"
+ | otherwise = "Unexpected token " ++ show s
+
+-- ---------------------------------------------------------------------------
+-- Basic parsers
+-- ---------------------------------------------------------------------------
+
+-- |Return the current position without consuming the input
+position :: Parser a s Position
+position = Parser (Just p) Map.empty
+ where p success _ sp = success (span2Pos sp) sp
+
+-- |Always succeeding parser
+succeed :: b -> Parser a s b
+succeed x = Parser (Just p) Map.empty
+ where p success _ = success x
+
+-- |Always failing parser with a given message
+failure :: String -> Parser a s b
+failure msg = Parser (Just p) Map.empty
+ where p _ failp pos _ = failp pos msg
+
+-- |Create a parser accepting the given 'Symbol'
+symbol :: s -> Parser a s s
+symbol s = Parser Nothing (Map.singleton s p)
+ where p lexer success failp _ s' = lexer (success s') failp
+
+-- ---------------------------------------------------------------------------
+-- Parser combinators
+-- ---------------------------------------------------------------------------
+
+-- |Behave like the given parser, but use the given 'String' as the error
+-- message if the parser fails
+() :: Symbol s => Parser a s b -> String -> Parser a s b
+p msg = p <|> failure msg
+
+-- |Deterministic choice between two parsers.
+-- The appropriate parser is chosen based on the next 'Symbol'
+(<|>) :: Symbol s => Parser a s b -> Parser a s b -> Parser a s b
+Parser e1 ps1 <|> Parser e2 ps2
+ | isJust e1 && isJust e2 = failure "Ambiguous parser for empty word"
+ | not (Set.null common) = failure $ "Ambiguous parser for " ++ show common
+ | otherwise = Parser (e1 `mplus` e2) (Map.union ps1 ps2)
+ where common = Map.keysSet ps1 `Set.intersection` Map.keysSet ps2
+
+-- |Non-deterministic choice between two parsers.
+--
+-- The other parsing combinators require that the grammar being parsed
+-- is LL(1). In some cases it may be difficult or even
+-- impossible to transform a grammar into LL(1) form. As a remedy, we
+-- include a non-deterministic version of the choice combinator in
+-- addition to the deterministic combinator adapted from the paper. For
+-- every symbol from the intersection of the parser's first sets, the
+-- combinator '(<|?>)' applies both parsing functions to the input
+-- stream and uses that one which processes the longer prefix of the
+-- input stream irrespective of whether it succeeds or fails. If both
+-- functions recognize the same prefix, we choose the one that succeeds
+-- and report an ambiguous parse error if both succeed.
+(<|?>) :: Symbol s => Parser a s b -> Parser a s b -> Parser a s b
+Parser e1 ps1 <|?> Parser e2 ps2
+ | isJust e1 && isJust e2 = failure "Ambiguous parser for empty word"
+ | otherwise = Parser (e1 `mplus` e2) (Map.union ps1' ps2)
+ where
+ ps1' = Map.fromList [ (s, maybe p (try p) (Map.lookup s ps2))
+ | (s, p) <- Map.toList ps1
+ ]
+ try p1 p2 lexer success failp pos s =
+ closeP1 p2s `thenP` \p2s' ->
+ closeP1 p2f `thenP` \p2f' ->
+ parse' p1 (retry p2s') (retry p2f')
+ where p2s r1 = parse' p2 (select True r1) (select False r1)
+ p2f r1 = parse' p2 (flip (select False) r1) (select False r1)
+ parse' p psucc pfail =
+ p lexer (successK psucc) (failK pfail) pos s
+ successK k x pos' s' = k (pos', success x pos' s')
+ failK k pos' msg = k (pos', failp pos' msg)
+ retry k (pos',p) = closeP0 p `thenP` curry k pos'
+ select suc (pos1, p1) (pos2, p2) = case pos1 `compare` pos2 of
+ GT -> p1
+ EQ | suc -> failP pos1 $ "Ambiguous parse before " ++ showPosition (span2Pos pos1)
+ | otherwise -> p1
+ LT -> p2
+
+seqEE :: ParseFun a s (b -> c) -> ParseFun a s b -> ParseFun a s c
+seqEE p1 p2 success failp = p1 (\f -> p2 (success . f) failp) failp
+
+seqEP :: ParseFun a s (b -> c) -> (Lexer s a -> ParseFun a s b)
+ -> Lexer s a -> ParseFun a s c
+seqEP p1 p2 lexer success failp = p1 (\f -> p2 lexer (success . f) failp) failp
+
+seqPP :: Symbol s => (Lexer s a -> ParseFun a s (b -> c)) -> Parser a s b
+ -> Lexer s a -> ParseFun a s c
+seqPP p1 p2 lexer success failp =
+ p1 lexer (\f -> choose p2 lexer (success . f) failp) failp
+
+-- ---------------------------------------------------------------------------
+-- The combinators \verb|<\\>| and \verb|<\>| can be used to restrict
+-- the first set of a parser. This is useful for combining two parsers
+-- with an overlapping first set with the deterministic combinator <|>.
+-- ---------------------------------------------------------------------------
+
+-- |Restrict the first parser by the first 'Symbol's of the second
+(<\>) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b
+p <\> Parser _ ps = p <\\> Map.keys ps
+
+-- |Restrict a parser by a list of first 'Symbol's
+(<\\>) :: Symbol s => Parser a s b -> [s] -> Parser a s b
+Parser e ps <\\> xs = Parser e (foldr Map.delete ps xs)
+
+-- ---------------------------------------------------------------------------
+-- Other combinators
+-- Note that some of these combinators have not been published in the
+-- paper, but were taken from the implementation found on the web.
+-- ---------------------------------------------------------------------------
+
+-- |Replace the result of the parser with the first argument
+(<$->) :: Symbol s => a -> Parser b s c -> Parser b s a
+f <$-> p = const f <$> p
+
+-- |Apply two parsers in sequence, but return only the result of the first
+-- parser
+(<*->) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b
+p <*-> q = const <$> p <*> q
+
+-- |Apply two parsers in sequence, but return only the result of the second
+-- parser
+(<-*>) :: Symbol s => Parser a s b -> Parser a s c -> Parser a s c
+p <-*> q = const id <$> p <*> q
+
+-- |Apply the parsers in sequence and apply the result function of the second
+-- parse to the result of the first
+(<**>) :: Symbol s => Parser a s b -> Parser a s (b -> c) -> Parser a s c
+p <**> q = flip ($) <$> p <*> q
+
+-- |Same as (<**>), but only applies the function if the second parser
+-- succeeded.
+() :: Symbol s => Parser a s b -> Parser a s (b -> b) -> Parser a s b
+p q = p <**> (q `opt` id)
+
+-- |Flipped function composition on parsers
+(<.>) :: Symbol s => Parser a s (b -> c) -> Parser a s (c -> d)
+ -> Parser a s (b -> d)
+p1 <.> p2 = p1 <**> ((.) <$> p2)
+
+-- |Try the first parser, but return the second argument if it didn't succeed
+opt :: Symbol s => Parser a s b -> b -> Parser a s b
+p `opt` x = p <|> succeed x
+
+-- |Choose the first succeeding parser from a non-empty list of parsers
+choice :: Symbol s => [Parser a s b] -> Parser a s b
+choice = foldr1 (<|>)
+
+-- |Try to apply a given parser and return a boolean value if the parser
+-- succeeded.
+flag :: Symbol s => Parser a s b -> Parser a s Bool
+flag p = True <$-> p `opt` False
+
+-- |Try to apply a parser but forget if it succeeded
+optional :: Symbol s => Parser a s b -> Parser a s ()
+optional p = const () <$> p `opt` ()
+
+-- |Try to apply a parser and return its result in a 'Maybe' type
+option :: Symbol s => Parser a s b -> Parser a s (Maybe b)
+option p = Just <$> p `opt` Nothing
+
+-- |Repeatedly apply a parser for 0 or more occurences
+many :: Symbol s => Parser a s b -> Parser a s [b]
+many p = many1 p `opt` []
+
+-- |Repeatedly apply a parser for 1 or more occurences
+many1 :: Symbol s => Parser a s b -> Parser a s [b]
+many1 p = (:) <$> p <*> many p
+
+-- |Parse a list with is separated by a seperator
+sepBy :: Symbol s => Parser a s b -> Parser a s c -> Parser a s [b]
+p `sepBy` q = p `sepBy1` q `opt` []
+
+-- |Parse a non-empty list with is separated by a seperator
+sepBy1 :: Symbol s => Parser a s b -> Parser a s c -> Parser a s [b]
+p `sepBy1` q = (:) <$> p <*> many (q <-*> p)
+
+-- |@chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
+-- Returns a value produced by a *right* associative application of all
+-- functions returned by op. If there are no occurrences of @p@, @x@ is
+-- returned.
+chainr :: Symbol s
+ => Parser a s b -> Parser a s (b -> b -> b) -> b -> Parser a s b
+chainr p op x = chainr1 p op `opt` x
+
+-- |Like 'chainr', but parses one or more occurrences of p.
+chainr1 :: Symbol s => Parser a s b -> Parser a s (b -> b -> b) -> Parser a s b
+chainr1 p op = r where r = p <**> (flip <$> op <*> r `opt` id)
+
+-- |@chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
+-- Returns a value produced by a *left* associative application of all
+-- functions returned by op. If there are no occurrences of @p@, @x@ is
+-- returned.
+chainl :: Symbol s
+ => Parser a s b -> Parser a s (b -> b -> b) -> b -> Parser a s b
+chainl p op x = chainl1 p op `opt` x
+
+-- |Like 'chainl', but parses one or more occurrences of p.
+chainl1 :: Symbol s => Parser a s b -> Parser a s (b -> b -> b) -> Parser a s b
+chainl1 p op = foldF <$> p <*> many (flip <$> op <*> p)
+ where foldF x [] = x
+ foldF x (f:fs) = foldF (f x) fs
+
+-- |Parse an expression between an opening and a closing part.
+between :: Symbol s => Parser a s b -> Parser a s c -> Parser a s b
+ -> Parser a s c
+between open p close = open <-*> p <*-> close
+
+-- |Parse one of the given operators
+ops :: Symbol s => [(s, b)] -> Parser a s b
+ops [] = failure "Curry.Base.LLParseComb.ops: empty list"
+ops [(s, x)] = x <$-> symbol s
+ops ((s, x) : rest) = x <$-> symbol s <|> ops rest
+
+-- ---------------------------------------------------------------------------
+-- Layout combinators
+-- Note that the layout functions grab the next token (and its position).
+-- After modifying the layout context, the continuation is called with
+-- the same token and an undefined result.
+-- ---------------------------------------------------------------------------
+
+-- |Disable layout-awareness for the following
+layoutOff :: Symbol s => Parser a s b
+layoutOff = Parser (Just off) Map.empty
+ where off success _ pos = pushContext (-1) . success undefined pos
+
+-- |Add a new scope for layout
+layoutOn :: Symbol s => Parser a s b
+layoutOn = Parser (Just on) Map.empty
+ where on success _ pos = pushContext (column (span2Pos pos)) . success undefined pos
+
+-- |End the current layout scope (or re-enable layout-awareness if it is
+-- currently disabled
+layoutEnd :: Symbol s => Parser a s b
+layoutEnd = Parser (Just end) Map.empty
+ where end success _ pos = popContext . success undefined pos
diff --git a/src/Curry/Base/LexComb.hs b/src/Curry/Base/LexComb.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Base/LexComb.hs
@@ -0,0 +1,179 @@
+{- |
+ Module : $Header$
+ Description : Lexer combinators
+ Copyright : (c) 1999 - 2004, Wolfgang Lux
+ 2012 - 2013, Björn Peemöller
+ 2016 , Jan Tikovsky
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module provides the basic types and combinators to implement the
+ lexers. The combinators use continuation passing code in a monadic style.
+
+ The first argument of the continuation function is the current span,
+ and the second is the string to be parsed. The third argument is a flag
+ which signals the lexer that it is lexing the beginning of a line and
+ therefore has to check for layout tokens. The fourth argument is a stack
+ of indentations that is used to handle nested layout groups.
+-}
+module Curry.Base.LexComb
+ ( -- * Types
+ Symbol (..), Indent, Context, P, CYM, SuccessP, FailP, Lexer
+
+ -- * Monadic functions
+ , parse, applyLexer, returnP, thenP, thenP_, failP, warnP
+ , liftP, closeP0, closeP1
+
+ -- * Combinators for layout handling
+ , pushContext, popContext
+
+ -- * Conversion of numbers
+ , convertSignedIntegral, convertSignedFloating
+ , convertIntegral, convertFloating
+ ) where
+
+import Data.Char (digitToInt)
+
+import Curry.Base.Monad (CYM, failMessageAt, warnMessageAt)
+import Curry.Base.Span ( Distance, Span (..), startCol, fstSpan, span2Pos
+ , setDistance)
+
+
+infixl 1 `thenP`, `thenP_`
+
+-- |Type class for symbols
+class (Ord s, Show s) => Symbol s where
+ -- |Does the 'Symbol' represent the end of the input?
+ isEOF :: s -> Bool
+ -- |Compute the distance of a 'Symbol'
+ dist :: Int -> s -> Distance
+
+-- |Type for indentations, necessary for the layout rule
+type Indent = Int
+
+-- |Type of context for representing layout grouping
+type Context = [Indent]
+
+-- |Basic lexer function
+type P a = Span -- ^ Current source code span
+ -> String -- ^ 'String' to be parsed
+ -> Bool -- ^ Flag whether the beginning of a line should be
+ -- parsed, which requires layout checking
+ -> Context -- ^ context as a stack of 'Indent's
+ -> CYM a
+
+-- |Apply a lexer on a 'String' to lex the content. The second parameter
+-- requires a 'FilePath' to use in the 'Span'
+parse :: P a -> FilePath -> String -> CYM a
+parse p fn s = p (fstSpan fn) s True []
+
+-- ---------------------------------------------------------------------------
+-- CPS lexer
+-- ---------------------------------------------------------------------------
+
+-- |success continuation
+type SuccessP s a = Span -> s -> P a
+
+-- |failure continuation
+type FailP a = Span -> String -> P a
+
+-- |A CPS lexer
+type Lexer s a = SuccessP s a -> FailP a -> P a
+
+-- |Apply a lexer
+applyLexer :: Symbol s => Lexer s [(Span, s)] -> P [(Span, s)]
+applyLexer lexer = lexer successP failP
+ where successP sp t | isEOF t = returnP [(sp', t)]
+ | otherwise = ((sp', t) :) `liftP` lexer successP failP
+ where sp' = setDistance sp (dist (startCol sp) t)
+
+-- ---------------------------------------------------------------------------
+-- Monadic functions for the lexer.
+-- ---------------------------------------------------------------------------
+
+-- |Lift a value into the lexer type
+returnP :: a -> P a
+returnP x _ _ _ _ = return x
+
+-- |Apply the first lexer and then apply the second one, based on the result
+-- of the first lexer.
+thenP :: P a -> (a -> P b) -> P b
+thenP lexer k sp s bol ctxt
+ = lexer sp s bol ctxt >>= \x -> k x sp s bol ctxt
+
+-- |Apply the first lexer and then apply the second one, ignoring the first
+-- result.
+thenP_ :: P a -> P b -> P b
+p1 `thenP_` p2 = p1 `thenP` \_ -> p2
+
+-- |Fail to lex on a 'Span', given an error message
+failP :: Span -> String -> P a
+failP sp msg _ _ _ _ = failMessageAt (span2Pos sp) msg
+
+-- |Warn on a 'Span', given a warning message
+warnP :: Span -> String -> P a -> P a
+warnP warnSpan msg lexer sp s bol ctxt
+ = warnMessageAt (span2Pos warnSpan) msg >> lexer sp s bol ctxt
+
+-- |Apply a pure function to the lexers result
+liftP :: (a -> b) -> P a -> P b
+liftP f p = p `thenP` returnP . f
+
+-- |Lift a lexer into the 'P' monad, returning the lexer when evaluated.
+closeP0 :: P a -> P (P a)
+closeP0 lexer sp s bol ctxt = return (\_ _ _ _ -> lexer sp s bol ctxt)
+
+-- |Lift a lexer-generating function into the 'P' monad, returning the
+-- function when evaluated.
+closeP1 :: (a -> P b) -> P (a -> P b)
+closeP1 f sp s bol ctxt = return (\x _ _ _ _ -> f x sp s bol ctxt)
+
+-- ---------------------------------------------------------------------------
+-- Combinators for handling layout.
+-- ---------------------------------------------------------------------------
+
+-- |Push an 'Indent' to the context, increasing the levels of indentation
+pushContext :: Indent -> P a -> P a
+pushContext col cont sp s bol ctxt = cont sp s bol (col : ctxt)
+
+-- |Pop an 'Indent' from the context, decreasing the levels of indentation
+popContext :: P a -> P a
+popContext cont sp s bol (_ : ctxt) = cont sp s bol ctxt
+popContext _ sp _ _ [] = failMessageAt (span2Pos sp) $
+ "Parse error: popping layout from empty context stack. " ++
+ "Perhaps you have inserted too many '}'?"
+
+-- ---------------------------------------------------------------------------
+-- Conversions from 'String's into numbers.
+-- ---------------------------------------------------------------------------
+
+-- |Convert a String into a signed intergral using a given base
+convertSignedIntegral :: Num a => a -> String -> a
+convertSignedIntegral b ('+':s) = convertIntegral b s
+convertSignedIntegral b ('-':s) = - convertIntegral b s
+convertSignedIntegral b s = convertIntegral b s
+
+-- |Convert a String into an unsigned intergral using a given base
+convertIntegral :: Num a => a -> String -> a
+convertIntegral b = foldl op 0
+ where m `op` n = b * m + fromIntegral (digitToInt n)
+
+-- |Convert a mantissa, a fraction part and an exponent into a signed
+-- floating value
+convertSignedFloating :: Fractional a => String -> String -> Int -> a
+convertSignedFloating ('+':m) f e = convertFloating m f e
+convertSignedFloating ('-':m) f e = - convertFloating m f e
+convertSignedFloating m f e = convertFloating m f e
+
+-- |Convert a mantissa, a fraction part and an exponent into an unsigned
+-- floating value
+convertFloating :: Fractional a => String -> String -> Int -> a
+convertFloating m f e
+ | e' == 0 = m'
+ | e' > 0 = m' * 10 ^ e'
+ | otherwise = m' / 10 ^ (- e')
+ where m' = convertIntegral 10 (m ++ f)
+ e' = e - length f
diff --git a/src/Curry/Base/Message.hs b/src/Curry/Base/Message.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Base/Message.hs
@@ -0,0 +1,89 @@
+{- |
+ Module : $Header$
+ Description : Monads for message handling
+ Copyright : 2009 Holger Siegel
+ 2012 - 2015 Björn Peemöller
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ The type message represents a compiler message with an optional source
+ code position.
+-}
+
+module Curry.Base.Message
+ ( Message (..), message, posMessage, showWarning, showError
+ , ppMessage, ppWarning, ppError, ppMessages
+ ) where
+
+import Data.Maybe (fromMaybe)
+
+import Curry.Base.Position
+import Curry.Base.Pretty
+
+-- ---------------------------------------------------------------------------
+-- Message
+-- ---------------------------------------------------------------------------
+
+-- |Compiler message
+data Message = Message
+ { msgPos :: Maybe Position -- ^ optional source code position
+ , msgTxt :: Doc -- ^ the message itself
+ }
+
+instance Eq Message where
+ Message p1 t1 == Message p2 t2 = (p1, show t1) == (p2, show t2)
+
+instance Ord Message where
+ Message p1 t1 `compare` Message p2 t2 = compare (p1, show t1) (p2, show t2)
+
+instance Show Message where
+ showsPrec _ = shows . ppMessage
+
+instance HasPosition Message where
+ getPosition = fromMaybe NoPos . msgPos
+ setPosition p m = m { msgPos = Just p }
+
+instance Pretty Message where
+ pPrint = ppMessage
+
+-- |Construct a 'Message' without a 'Position'
+message :: Doc -> Message
+message = Message Nothing
+
+-- |Construct a message from an entity with a 'Position' and a text
+posMessage :: HasPosition p => p -> Doc -> Message
+posMessage p msg = Message (Just $ getPosition p) msg
+
+-- |Show a 'Message' as a warning
+showWarning :: Message -> String
+showWarning = show . ppWarning
+
+-- |Show a 'Message' as an error
+showError :: Message -> String
+showError = show . ppError
+
+-- |Pretty print a 'Message'
+ppMessage :: Message -> Doc
+ppMessage = ppAs ""
+
+-- |Pretty print a 'Message' as a warning
+ppWarning :: Message -> Doc
+ppWarning = ppAs "Warning"
+
+-- |Pretty print a 'Message' as an error
+ppError :: Message -> Doc
+ppError = ppAs "Error"
+
+-- |Pretty print a 'Message' with a given key
+ppAs :: String -> Message -> Doc
+ppAs key (Message mbPos txt) = posPP <+> keyPP $$ nest 4 txt
+ where
+ posPP = maybe empty ((<> colon) . ppPosition) mbPos
+ keyPP = if null key then empty else text key <> colon
+
+-- |Pretty print a list of 'Message's by vertical concatenation
+ppMessages :: (Message -> Doc) -> [Message] -> Doc
+ppMessages ppFun = foldr (\m ms -> text "" $+$ m $+$ ms) empty . map ppFun
diff --git a/src/Curry/Base/Monad.hs b/src/Curry/Base/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Base/Monad.hs
@@ -0,0 +1,95 @@
+{- |
+ Module : $Header$
+ Description : Monads for message handling
+ Copyright : 2014 - 2016 Björn Peemöller
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+
+ The monads defined in this module provide a common way to stop execution
+ when some errors occur. They are used to integrate different compiler passes
+ smoothly.
+-}
+
+module Curry.Base.Monad
+ ( CYIO, CYM, CYT, failMessages, failMessageAt, warnMessages, warnMessageAt
+ , ok, runCYIO, runCYM, runCYIOIgnWarn, runCYMIgnWarn, liftCYM, silent
+ ) where
+
+import Control.Monad.Identity
+import Control.Monad.Trans.Except (ExceptT, mapExceptT, runExceptT, throwE)
+import Control.Monad.Writer
+
+import Curry.Base.Message (Message, posMessage)
+import Curry.Base.Position
+import Curry.Base.Pretty (text)
+
+-- |Curry compiler monad transformer
+type CYT m a = WriterT [Message] (ExceptT [Message] m) a
+
+-- |Curry compiler monad based on the `IO` monad
+type CYIO a = CYT IO a
+
+-- |Pure Curry compiler monad
+type CYM a = CYT Identity a
+
+-- |Run an `IO`-based Curry compiler action in the `IO` monad,
+-- yielding either a list of errors or a result in case of success
+-- consisting of the actual result and a (possibly empty) list of warnings
+runCYIO :: CYIO a -> IO (Either [Message] (a, [Message]))
+runCYIO = runExceptT . runWriterT
+
+-- |Run an pure Curry compiler action,
+-- yielding either a list of errors or a result in case of success
+-- consisting of the actual result and a (possibly empty) list of warnings
+runCYM :: CYM a -> Either [Message] (a, [Message])
+runCYM = runIdentity . runExceptT . runWriterT
+
+-- |Run an `IO`-based Curry compiler action in the `IO` monad,
+-- yielding either a list of errors or a result in case of success.
+runCYIOIgnWarn :: CYIO a -> IO (Either [Message] a)
+runCYIOIgnWarn = runExceptT . (liftM fst) . runWriterT
+
+-- |Run an pure Curry compiler action,
+-- yielding either a list of errors or a result in case of success.
+runCYMIgnWarn :: CYM a -> Either [Message] a
+runCYMIgnWarn = runIdentity . runExceptT . (liftM fst) . runWriterT
+
+-- |Failing action with a message describing the cause of failure.
+failMessage :: Monad m => Message -> CYT m a
+failMessage msg = failMessages [msg]
+
+-- |Failing action with a list of messages describing the cause(s) of failure.
+failMessages :: Monad m => [Message] -> CYT m a
+failMessages = lift . throwE
+
+-- |Failing action with a source code position and a `String` indicating
+-- the cause of failure.
+failMessageAt :: Monad m => Position -> String -> CYT m a
+failMessageAt pos s = failMessage $ posMessage pos $ text s
+
+-- |Warning with a message describing the cause of the warning.
+warnMessage :: Monad m => Message -> CYT m ()
+warnMessage msg = warnMessages [msg]
+
+-- |Warning with a list of messages describing the cause(s) of the warnings.
+warnMessages :: Monad m => [Message] -> CYT m ()
+warnMessages msgs = tell msgs
+
+-- |Execute a monadic action, but ignore any warnings it issues
+silent :: Monad m => CYT m a -> CYT m a
+silent act = censor (const []) act
+
+-- |Warning with a source code position and a `String` indicating
+-- the cause of the warning.
+warnMessageAt :: Monad m => Position -> String -> CYT m ()
+warnMessageAt pos s = warnMessage $ posMessage pos $ text s
+
+-- |Lift a value into the `CYT m` monad, same as `return`.
+ok :: Monad m => a -> CYT m a
+ok = return
+
+-- |Lift a pure action into an action based on another monad.
+liftCYM :: Monad m => CYM a -> CYT m a
+liftCYM = mapWriterT (mapExceptT (return . runIdentity))
diff --git a/src/Curry/Base/Position.hs b/src/Curry/Base/Position.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Base/Position.hs
@@ -0,0 +1,109 @@
+{- |
+ Module : $Header$
+ Description : Positions in a source file
+ Copyright : (c) Wolfgang Lux
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module implements a data type for positions in a source file and
+ respective functions to operate on them. A source file position consists
+ of a filename, a line number, and a column number. A tab stop is assumed
+ at every eighth column.
+-}
+
+module Curry.Base.Position
+ ( -- * Source code position
+ HasPosition (..), Position (..), (@>)
+ , showPosition, ppPosition, ppLine, showLine
+ , first, next, incr, tab, tabWidth, nl
+ ) where
+
+import System.FilePath
+
+import Curry.Base.Pretty
+
+-- |Type class for entities which have a source code 'Position'
+class HasPosition a where
+ -- |Get the 'Position'
+ getPosition :: a -> Position
+ getPosition _ = NoPos
+
+ -- |Set the 'Position'
+ setPosition :: Position -> a -> a
+ setPosition _ = id
+
+-- | @x \@> y@ returns @x@ with the position obtained from @y@
+(@>) :: (HasPosition a, HasPosition b) => a -> b -> a
+x @> y = setPosition (getPosition y) x
+
+-- |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
+ }
+ -- |no position
+ | NoPos
+ deriving (Eq, Ord, Read, Show)
+
+instance HasPosition Position where
+ getPosition = id
+ setPosition = const
+
+instance Pretty Position where
+ pPrint = ppPosition
+
+-- |Show a 'Position' as a 'String'
+showPosition :: Position -> String
+showPosition = show . ppPosition
+
+-- |Pretty print a 'Position'
+ppPosition :: Position -> Doc
+ppPosition p@(Position f _ _)
+ | null f = lineCol
+ | otherwise = text (normalise f) <> comma <+> lineCol
+ where lineCol = ppLine p
+ppPosition _ = empty
+
+-- |Pretty print the line and column of a 'Position'
+ppLine :: Position -> Doc
+ppLine (Position _ l c) = text "line" <+> text (show l)
+ <> if c == 0 then empty else text ('.' : show c)
+ppLine _ = empty
+
+-- |Show the line and column of a 'Position'
+showLine :: Position -> String
+showLine = show . ppLine
+
+-- | Absolute first position of a file
+first :: FilePath -> Position
+first fn = Position fn 1 1
+
+-- |Next position to the right
+next :: Position -> Position
+next = flip incr 1
+
+-- |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
+
+-- |Number of spaces for a tabulator
+tabWidth :: Int
+tabWidth = 8
+
+-- |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
diff --git a/src/Curry/Base/Pretty.hs b/src/Curry/Base/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Base/Pretty.hs
@@ -0,0 +1,207 @@
+{- |
+ Module : $Header$
+ Description : Pretty printing
+ Copyright : (c) 2013 - 2014 Björn Peemöller
+ 2016 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : stable
+ Portability : portable
+
+ This module re-exports the well known pretty printing combinators
+ from Hughes and Peyton-Jones. In addition, it re-exports the type class
+ 'Pretty' for pretty printing arbitrary types.
+-}
+{-# LANGUAGE CPP #-}
+module Curry.Base.Pretty
+ ( module Curry.Base.Pretty
+ , module Text.PrettyPrint
+ ) where
+
+import Text.PrettyPrint
+
+-- | Pretty printing class.
+-- The precedence level is used in a similar way as in the 'Show' class.
+-- Minimal complete definition is either 'pPrintPrec' or 'pPrint'.
+class Pretty a where
+ -- | Pretty-print something in isolation.
+ pPrint :: a -> Doc
+ pPrint = pPrintPrec 0
+
+ -- | Pretty-print something in a precedence context.
+ pPrintPrec :: Int -> a -> Doc
+ pPrintPrec _ = pPrint
+
+ -- |Pretty-print a list.
+ pPrintList :: [a] -> Doc
+ pPrintList = brackets . fsep . punctuate comma . map (pPrintPrec 0)
+
+#if __GLASGOW_HASKELL__ >= 707
+ {-# MINIMAL pPrintPrec | pPrint #-}
+#endif
+
+-- | Pretty print a value to a 'String'.
+prettyShow :: Pretty a => a -> String
+prettyShow = render . pPrint
+
+-- | Parenthesize an value if the boolean is true.
+parenIf :: Bool -> Doc -> Doc
+parenIf False = id
+parenIf True = parens
+
+-- | Pretty print a value if the boolean is true
+ppIf :: Bool -> Doc -> Doc
+ppIf True = id
+ppIf False = const empty
+
+-- | Pretty print a 'Maybe' value for the 'Just' constructor only
+maybePP :: (a -> Doc) -> Maybe a -> Doc
+maybePP pp = maybe empty pp
+
+-- | A blank line.
+blankLine :: Doc
+blankLine = text ""
+
+-- |Above with a blank line in between. If one of the documents is empty,
+-- then the other document is returned.
+($++$) :: Doc -> Doc -> Doc
+d1 $++$ d2 | isEmpty d1 = d2
+ | isEmpty d2 = d1
+ | otherwise = d1 $+$ blankLine $+$ d2
+
+-- |Above with overlapping, but with a space in between. If one of the
+-- documents is empty, then the other document is returned.
+($-$) :: Doc -> Doc -> Doc
+d1 $-$ d2 | isEmpty d1 = d2
+ | isEmpty d2 = d1
+ | otherwise = d1 $$ space $$ d2
+
+-- | Seperate a list of 'Doc's by a 'blankLine'.
+sepByBlankLine :: [Doc] -> Doc
+sepByBlankLine = foldr ($++$) empty
+
+-- |A '.' character.
+dot :: Doc
+dot = char '.'
+
+-- |Precedence of function application
+appPrec :: Int
+appPrec = 10
+
+-- |A left arrow @<-@.
+larrow :: Doc
+larrow = text "<-"
+
+-- |A right arrow @->@.
+rarrow :: Doc
+rarrow = text "->"
+
+-- |A double arrow @=>@.
+darrow :: Doc
+darrow = text "=>"
+
+-- |A back quote @`@.
+backQuote :: Doc
+backQuote = char '`'
+
+-- |A backslash @\@.
+backsl :: Doc
+backsl = char '\\'
+
+-- |A vertical bar @|@.
+vbar :: Doc
+vbar = char '|'
+
+-- |Set a document in backquotes.
+bquotes :: Doc -> Doc
+bquotes doc = backQuote <> doc <> backQuote
+
+-- |Set a document in backquotes if the condition is @True@.
+bquotesIf :: Bool -> Doc -> Doc
+bquotesIf b doc = if b then bquotes doc else doc
+
+-- |Seperate a list of documents by commas
+list :: [Doc] -> Doc
+list = fsep . punctuate comma . filter (not . isEmpty)
+
+-- | Instance for 'Int'
+instance Pretty Int where pPrint = int
+
+-- | Instance for 'Integer'
+instance Pretty Integer where pPrint = integer
+
+-- | Instance for 'Float'
+instance Pretty Float where pPrint = float
+
+-- | Instance for 'Double'
+instance Pretty Double where pPrint = double
+
+-- | Instance for '()'
+instance Pretty () where pPrint _ = text "()"
+
+-- | Instance for 'Bool'
+instance Pretty Bool where pPrint = text . show
+
+-- | Instance for 'Ordering'
+instance Pretty Ordering where pPrint = text . show
+
+-- | Instance for 'Char'
+instance Pretty Char where
+ pPrint = char
+ pPrintList = text . show
+
+-- | Instance for 'Maybe'
+instance (Pretty a) => Pretty (Maybe a) where
+ pPrintPrec _ Nothing = text "Nothing"
+ pPrintPrec p (Just x) = parenIf (p > appPrec)
+ $ text "Just" <+> pPrintPrec (appPrec + 1) x
+
+-- | Instance for 'Either'
+instance (Pretty a, Pretty b) => Pretty (Either a b) where
+ pPrintPrec p (Left x) = parenIf (p > appPrec)
+ $ text "Left" <+> pPrintPrec (appPrec + 1) x
+ pPrintPrec p (Right x) = parenIf (p > appPrec)
+ $ text "Right" <+> pPrintPrec (appPrec + 1) x
+
+-- | Instance for '[]'
+instance (Pretty a) => Pretty [a] where
+ pPrintPrec _ xs = pPrintList xs
+
+-- | Instance for '(,)'
+instance (Pretty a, Pretty b) => Pretty (a, b) where
+ pPrintPrec _ (a, b) = parens $ fsep $ punctuate comma [pPrint a, pPrint b]
+
+-- | Instance for '(,,)'
+instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where
+ pPrintPrec _ (a, b, c) = parens $ fsep $ punctuate comma
+ [pPrint a, pPrint b, pPrint c]
+
+-- | Instance for '(,,,)'
+instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where
+ pPrintPrec _ (a, b, c, d) = parens $ fsep $ punctuate comma
+ [pPrint a, pPrint b, pPrint c, pPrint d]
+
+-- | Instance for '(,,,,)'
+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e)
+ => Pretty (a, b, c, d, e) where
+ pPrintPrec _ (a, b, c, d, e) = parens $ fsep $ punctuate comma
+ [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e]
+
+-- | Instance for '(,,,,,)'
+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f)
+ => Pretty (a, b, c, d, e, f) where
+ pPrintPrec _ (a, b, c, d, e, f) = parens $ fsep $ punctuate comma
+ [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f]
+
+-- | Instance for '(,,,,,,)'
+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g)
+ => Pretty (a, b, c, d, e, f, g) where
+ pPrintPrec _ (a, b, c, d, e, f, g) = parens $ fsep $ punctuate comma
+ [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f, pPrint g]
+
+-- | Instance for '(,,,,,,,)'
+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h)
+ => Pretty (a, b, c, d, e, f, g, h) where
+ pPrintPrec _ (a, b, c, d, e, f, g, h) = parens $ fsep $ punctuate comma
+ [pPrint a, pPrint b, pPrint c, pPrint d, pPrint e, pPrint f, pPrint g, pPrint h]
diff --git a/src/Curry/Base/Span.hs b/src/Curry/Base/Span.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Base/Span.hs
@@ -0,0 +1,106 @@
+{- |
+ Module : $Header$
+ Description : Spans in a source file
+ Copyright : (c) 2016 Jan Tikovsky
+ 2016 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : jrt@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module implements a data type for span information in a source file and
+ respective functions to operate on them. A source file span consists
+ of a filename, a start position and an end position.
+
+ In addition, the type 'SrcRef' identifies the path to an expression in
+ the abstract syntax tree by argument positions, which is used for
+ debugging purposes.
+-}
+
+module Curry.Base.Span where
+
+import System.FilePath
+
+import Curry.Base.Position
+import Curry.Base.Pretty
+
+data Span
+ -- |Normal source code span
+ = Span
+ { file :: FilePath -- ^ 'FilePath' of the source file
+ , start :: Position -- ^ start position
+ , end :: Position -- ^ end position
+ }
+ -- |no span
+ | NoSpan
+ deriving (Eq, Ord, Read, Show)
+
+instance Pretty Span where
+ pPrint = ppSpan
+
+-- |Show a 'Span' as a 'String'
+showSpan :: Span -> String
+showSpan = show . ppSpan
+
+-- |Pretty print a 'Span'
+ppSpan :: Span -> Doc
+ppSpan s@(Span f _ _)
+ | null f = startEnd
+ | otherwise = text (normalise f) <> comma <+> startEnd
+ where startEnd = ppPositions s
+ppSpan _ = empty
+
+-- |Pretty print the start and end position of a 'Span'
+ppPositions :: Span -> Doc
+ppPositions (Span _ s e) = text "startPos:" <+> ppLine s <> comma
+ <+> text "endPos:" <+> ppLine e
+ppPositions _ = empty
+
+fstSpan :: FilePath -> Span
+fstSpan fn = Span fn (first fn) (first fn)
+
+-- |Compute the column of the start position of a 'Span'
+startCol :: Span -> Int
+startCol (Span _ p _) = column p
+startCol _ = 0
+
+nextSpan :: Span -> Span
+nextSpan sp = incrSpan sp 1
+
+incrSpan :: Span -> Int -> Span
+incrSpan (Span fn s e) n = Span fn (incr s n) (incr e n)
+incrSpan sp _ = sp
+
+-- TODO: Rename to tab and nl as soon as positions are completely replaced by spans
+
+-- |Convert a span to a (start) position
+-- TODO: This function should be removed as soon as positions are completely replaced by spans
+-- in the frontend
+span2Pos :: Span -> Position
+span2Pos (Span _ p _) = p
+span2Pos NoSpan = NoPos
+
+-- |First position after the next tabulator
+tabSpan :: Span -> Span
+tabSpan (Span fn s e) = Span fn (tab s) (tab e)
+tabSpan sp = sp
+
+-- |First position of the next line
+nlSpan :: Span -> Span
+nlSpan (Span fn s e) = Span fn (nl s) (nl e)
+nlSpan sp = sp
+
+-- |Distance of a span, i.e. the line and column distance between start
+-- and end position
+type Distance = (Int, Int)
+
+-- |Set the distance of a span, i.e. update its end position
+setDistance :: Span -> Distance -> Span
+setDistance (Span fn p _) d = Span fn p (p `moveBy` d)
+setDistance s _ = s
+
+-- |Move position by given distance
+moveBy :: Position -> Distance -> Position
+moveBy (Position fn l c) (ld, cd) = Position fn (l + ld) (c + cd)
+moveBy p _ = p
diff --git a/src/Curry/CondCompile/Parser.hs b/src/Curry/CondCompile/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/CondCompile/Parser.hs
@@ -0,0 +1,90 @@
+{- |
+ Module : $Header$
+ Description : Parser for conditional compiling
+ Copyright : (c) 2017 Kai-Oliver Prott
+ 2017 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : fte@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ TODO
+-}
+{-# LANGUAGE CPP #-}
+module Curry.CondCompile.Parser where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative ((<$>), (<*>), (*>), (<*))
+#endif
+
+import Text.Parsec
+
+import Curry.CondCompile.Type
+
+type Parser a = Parsec String () a
+
+program :: Parser Program
+program = statement `sepBy` eol <* eof
+
+statement :: Parser Stmt
+statement = ifElse "if" condition If
+ <|> ifElse "ifdef" identifier IfDef
+ <|> ifElse "ifndef" identifier IfNDef
+ <|> define
+ <|> undef
+ <|> line
+
+ifElse :: String -> Parser a -> (a -> [Stmt] -> [Elif] -> Else -> Stmt)
+ -> Parser Stmt
+ifElse k p c = c <$> (try (many sp *> keyword k *> many1 sp) *> p <* many sp <* eol)
+ <*> many (statement <* eol)
+ <*> many (Elif <$> ((,) <$> (try (many sp *> keyword "elif" *> many1 sp) *> condition <* many sp <* eol)
+ <*> many (statement <* eol)))
+ <*> (Else <$> optionMaybe
+ (try (many sp *> keyword "else" *> many sp) *> eol *> many (statement <* eol)))
+ <* try (many sp <* keyword "endif" <* many sp)
+
+define :: Parser Stmt
+define = Define <$> (try (many sp *> keyword "define" *> many1 sp) *> identifier <* many1 sp)
+ <*> value <* many sp
+
+undef :: Parser Stmt
+undef = Undef <$> (try (many sp *> keyword "undef" *> many1 sp) *> identifier <* many sp)
+
+line :: Parser Stmt
+line = do
+ sps <- many sp
+ try $ ((char '#' "") *> fail "unknown directive")
+ <|> ((Line . (sps ++)) <$> manyTill anyChar (try (lookAhead (eol <|> eof))))
+
+keyword :: String -> Parser String
+keyword = string . ('#' :)
+
+condition :: Parser Cond
+condition = (Defined <$> (try (string "defined(") *> many sp *> identifier <* many sp <* char ')'))
+ <|> (NDefined <$> (try (string "!defined(") *> many sp *> identifier <* many sp <* char ')'))
+ <|> (Comp <$> (identifier <* many sp) <*> operator <*> (many sp *> value) "condition")
+
+identifier :: Parser String
+identifier = (:) <$> firstChar <*> many (firstChar <|> digit) "identifier"
+ where firstChar = letter <|> char '_'
+
+operator :: Parser Op
+operator = choice [ Leq <$ try (string "<=")
+ , Lt <$ try (string "<")
+ , Geq <$ try (string ">=")
+ , Gt <$ try (string ">")
+ , Neq <$ try (string "!=")
+ , Eq <$ string "=="
+ ] "operator"
+
+value :: Parser Int
+value = fmap read (many1 digit)
+
+eol :: Parser ()
+eol = endOfLine *> return ()
+
+sp :: Parser Char
+sp = try $ lookAhead (eol *> unexpected "end of line" "")
+ <|> space
diff --git a/src/Curry/CondCompile/Transform.hs b/src/Curry/CondCompile/Transform.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/CondCompile/Transform.hs
@@ -0,0 +1,116 @@
+{- |
+ Module : $Header$
+ Description : Conditional compiling transformation
+ Copyright : (c) 2017 Kai-Oliver Prott
+ 2017 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : fte@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ TODO
+-}
+module Curry.CondCompile.Transform (condTransform) where
+
+import Control.Monad.State
+import Control.Monad.Extra (concatMapM)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+import Text.Parsec hiding (State)
+import Text.Parsec.Error ()
+
+import Curry.Base.Message
+import Curry.Base.Position
+import Curry.Base.Pretty
+
+import Curry.CondCompile.Parser
+import Curry.CondCompile.Type
+
+type CCState = Map.Map String Int
+
+type CCM = State CCState
+
+condTransform :: CCState -> FilePath -> String -> Either Message String
+condTransform s fn p = either (Left . convertError)
+ (Right . transformWith s)
+ (parse program fn p)
+
+transformWith :: CCState -> Program -> String
+transformWith s p = show $ pPrint $ evalState (transform p) s
+
+convertError :: ParseError -> Message
+convertError err = posMessage pos $
+ foldr ($+$) empty $ map text $ tail $ lines $ show err
+ where pos = Position (sourceName src) (sourceLine src) (sourceColumn src)
+ src = errorPos err
+
+class CCTransform a where
+ transform :: a -> CCM [Stmt]
+
+instance CCTransform Stmt where
+ transform (Line s) = return [Line s]
+ transform (If c stmts is e) = do
+ s <- get
+ if checkCond c s
+ then do stmts' <- transform stmts
+ return (blank : stmts' ++ fill is ++ fill e ++ [blank])
+ else case is of
+ [] -> do
+ stmts' <- transform e
+ return (blank : fill stmts ++ stmts' ++ [blank])
+ (Elif (c', stmts') : is') -> do
+ stmts'' <- transform (If c' stmts' is' e)
+ return (blank : fill stmts ++ stmts'')
+ transform (IfDef v stmts is e) = transform (If (Defined v) stmts is e)
+ transform (IfNDef v stmts is e) = transform (If (NDefined v) stmts is e)
+ transform (Define v i) = modify (Map.insert v i) >> return [blank]
+ transform (Undef v ) = modify (Map.delete v) >> return [blank]
+
+instance CCTransform a => CCTransform [a] where
+ transform = concatMapM transform
+
+instance CCTransform Else where
+ transform (Else (Just p)) = (blank :) <$> transform p
+ transform (Else Nothing ) = return []
+
+checkCond :: Cond -> CCState -> Bool
+checkCond (Comp v op i) = flip (compareOp op) i . fromMaybe 0 . Map.lookup v
+checkCond (Defined v) = Map.member v
+checkCond (NDefined v) = Map.notMember v
+
+compareOp :: Ord a => Op -> a -> a -> Bool
+compareOp Eq = (==)
+compareOp Neq = (/=)
+compareOp Lt = (<)
+compareOp Leq = (<=)
+compareOp Gt = (>)
+compareOp Geq = (>=)
+
+class FillLength a where
+ fillLength :: a -> Int
+
+instance FillLength Stmt where
+ fillLength (Line _ ) = 1
+ fillLength (Define _ _ ) = 1
+ fillLength (Undef _ ) = 1
+ fillLength (If _ stmts is e) =
+ 3 + fillLength stmts + fillLength e + fillLength is
+ fillLength (IfDef v stmts is e) = fillLength (If (Defined v) stmts is e)
+ fillLength (IfNDef v stmts is e) = fillLength (If (NDefined v) stmts is e)
+
+instance FillLength a => FillLength [a] where
+ fillLength = foldr ((+) . fillLength) 0
+
+instance FillLength Else where
+ fillLength (Else (Just stmts)) = 1 + fillLength stmts
+ fillLength (Else Nothing ) = 0
+
+instance FillLength Elif where
+ fillLength (Elif (_, stmts)) = 1 + fillLength stmts
+
+fill :: FillLength a => a -> [Stmt]
+fill p = replicate (fillLength p) blank
+
+blank :: Stmt
+blank = Line ""
diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/CondCompile/Type.hs
@@ -0,0 +1,83 @@
+{- |
+ Module : $Header$
+ Description : Abstract syntax for conditional compiling
+ Copyright : (c) 2017 Kai-Oliver Prott
+ 2017 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : fte@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ TODO
+-}
+module Curry.CondCompile.Type
+ ( Program, Stmt (..), Else (..), Elif (..), Cond (..), Op (..)
+ ) where
+
+import Curry.Base.Pretty
+
+type Program = [Stmt]
+
+data Stmt = If Cond [Stmt] [Elif] Else
+ | IfDef String [Stmt] [Elif] Else
+ | IfNDef String [Stmt] [Elif] Else
+ | Define String Int
+ | Undef String
+ | Line String
+ deriving Show
+
+newtype Else = Else (Maybe [Stmt])
+ deriving Show
+
+newtype Elif = Elif (Cond, [Stmt])
+ deriving Show
+
+data Cond = Comp String Op Int
+ | Defined String
+ | NDefined String
+ deriving Show
+
+data Op = Eq
+ | Neq
+ | Lt
+ | Leq
+ | Gt
+ | Geq
+ deriving Show
+
+instance Pretty Stmt where
+ pPrint (If c stmts is e) = prettyIf "#if" (pPrint c) stmts is e
+ pPrint (IfDef v stmts is e) = prettyIf "#ifdef" (text v) stmts is e
+ pPrint (IfNDef v stmts is e) = prettyIf "#ifndef" (text v) stmts is e
+ pPrint (Define v i ) = text "#define" <+> text v <+> int i
+ pPrint (Undef v ) = text "#undef" <+> text v
+ pPrint (Line s ) = text s
+
+ pPrintList = foldr (($+$) . pPrint) empty
+
+instance Pretty Elif where
+ pPrint (Elif (c, stmts)) = text "#elif" <+> pPrint c $+$ pPrint stmts
+
+ pPrintList = foldr (($+$) . pPrint) empty
+
+instance Pretty Else where
+ pPrint (Else (Just stmts)) = text "#else" $+$ pPrint stmts
+ pPrint (Else Nothing) = empty
+
+prettyIf :: String -> Doc -> [Stmt] -> [Elif] -> Else -> Doc
+prettyIf k doc stmts is e = foldr ($+$) empty
+ [text k <+> doc, pPrint stmts, pPrint is, pPrint e, text "#endif"]
+
+instance Pretty Cond where
+ pPrint (Comp v op i) = text v <+> pPrint op <+> int i
+ pPrint (Defined v ) = text "defined(" <> text v <> char ')'
+ pPrint (NDefined v ) = text "!defined(" <> text v <> char ')'
+
+instance Pretty Op where
+ pPrint Eq = text "=="
+ pPrint Neq = text "/="
+ pPrint Lt = text "<"
+ pPrint Leq = text "<="
+ pPrint Gt = text ">"
+ pPrint Geq = text ">="
diff --git a/src/Curry/Files/Filenames.hs b/src/Curry/Files/Filenames.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Files/Filenames.hs
@@ -0,0 +1,221 @@
+{- |
+ Module : $Header$
+ Description : File names for several intermediate file formats.
+ Copyright : (c) 2009 Holger Siegel
+ 2013 - 2014 Björn Peemöller
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ The functions in this module were collected from several compiler modules
+ in order to provide a unique accessing point for this functionality.
+-}
+module Curry.Files.Filenames
+ ( -- * Re-exports from 'System.FilePath'
+ FilePath, takeBaseName, dropExtension, takeExtension, takeFileName
+
+ -- * Conversion between 'ModuleIdent' and 'FilePath'
+ , moduleNameToFile, fileNameToModule, splitModuleFileName, isCurryFilePath
+
+ -- * Curry sub-directory
+ , currySubdir, hasCurrySubdir, addCurrySubdir, addCurrySubdirModule
+ , ensureCurrySubdir
+
+ -- * File name extensions
+ -- ** Curry files
+ , curryExt, lcurryExt, icurryExt
+
+ -- ** FlatCurry files
+ , typedFlatExt, flatExt, flatIntExt
+
+ -- ** AbstractCurry files
+ , acyExt, uacyExt
+
+ -- ** Source and object files
+ , sourceRepExt, sourceExts, moduleExts
+
+ -- * Functions for computing file names
+ , interfName, typedFlatName, flatName, flatIntName
+ , acyName, uacyName, sourceRepName, tokensName, htmlName
+ ) where
+
+import System.FilePath
+
+import Curry.Base.Ident
+
+-- -----------------------------------------------------------------------------
+-- Conversion between ModuleIdent and FilePath
+-- -----------------------------------------------------------------------------
+
+-- |Create a 'FilePath' from a 'ModuleIdent' using the hierarchical module
+-- system
+moduleNameToFile :: ModuleIdent -> FilePath
+moduleNameToFile = foldr1 () . midQualifiers
+
+-- |Extract the 'ModuleIdent' from a 'FilePath'
+fileNameToModule :: FilePath -> ModuleIdent
+fileNameToModule = mkMIdent . splitDirectories . dropExtension . dropDrive
+
+-- |Split a 'FilePath' into a prefix directory part and those part that
+-- corresponds to the 'ModuleIdent'. This is especially useful for
+-- hierarchically module names.
+splitModuleFileName :: ModuleIdent -> FilePath -> (FilePath, FilePath)
+splitModuleFileName m fn = case midQualifiers m of
+ [_] -> splitFileName fn
+ ms -> let (base, ext) = splitExtension fn
+ dirs = splitDirectories base
+ (pre, suf) = splitAt (length dirs - length ms) dirs
+ path = if null pre then ""
+ else addTrailingPathSeparator (joinPath pre)
+ in (path, joinPath suf <.> ext)
+
+-- |Checks whether a 'String' represents a 'FilePath' to a Curry module
+isCurryFilePath :: String -> Bool
+isCurryFilePath str = isValid str
+ && takeExtension str `elem` ("" : moduleExts)
+
+-- -----------------------------------------------------------------------------
+-- Curry sub-directory
+-- -----------------------------------------------------------------------------
+
+-- |The standard hidden subdirectory for curry files
+currySubdir :: String
+currySubdir = ".curry"
+
+-- |Does the given 'FilePath' contain the 'currySubdir'
+-- as its last directory component?
+hasCurrySubdir :: FilePath -> Bool
+hasCurrySubdir f = not (null dirs) && last dirs == currySubdir
+ where dirs = splitDirectories $ takeDirectory f
+
+-- |Add the 'currySubdir' to the given 'FilePath' if the flag is 'True' and
+-- the path does not already contain it, otherwise leave the path untouched.
+addCurrySubdir :: Bool -> FilePath -> FilePath
+addCurrySubdir b fn = if b then ensureCurrySubdir fn else fn
+
+-- |Add the 'currySubdir' to the given 'FilePath' if the flag is 'True' and
+-- the path does not already contain it, otherwise leave the path untouched.
+addCurrySubdirModule :: Bool -> ModuleIdent -> FilePath -> FilePath
+addCurrySubdirModule b m fn
+ | b = let (pre, file) = splitModuleFileName m fn
+ in ensureCurrySubdir pre file
+ | otherwise = fn
+
+-- | Ensure that the 'currySubdir' is the last component of the
+-- directory structure of the given 'FilePath'. If the 'FilePath' already
+-- contains the sub-directory, it remains unchanged.
+ensureCurrySubdir :: FilePath -- ^ original 'FilePath'
+ -> FilePath -- ^ new 'FilePath'
+ensureCurrySubdir fn = normalise $ addSub (splitDirectories d) f
+ where
+ (d, f) = splitFileName fn
+ addSub dirs | null dirs = currySubdir
+ | last dirs == currySubdir = joinPath dirs
+ | otherwise = joinPath dirs currySubdir
+
+-- -----------------------------------------------------------------------------
+-- File name extensions
+-- -----------------------------------------------------------------------------
+
+-- |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 curry source files.
+--
+-- /Note:/ The order of the extensions defines the order in which source files
+-- should be searched for, i.e. given a module name @M@, the search order
+-- should be the following:
+--
+-- 1. @M.curry@
+-- 2. @M.lcurry@
+--
+sourceExts :: [String]
+sourceExts = [curryExt, lcurryExt]
+
+-- |Filename extension for curry module files
+-- TODO: Is the order correct?
+moduleExts :: [String]
+moduleExts = sourceExts ++ [icurryExt]
+
+-- |Filename extension for typed flat-curry files
+typedFlatExt :: String
+typedFlatExt = ".tfcy"
+
+-- |Filename extension for flat-curry files
+flatExt :: String
+flatExt = ".fcy"
+
+-- |Filename extension for extended-flat-curry interface files
+flatIntExt :: String
+flatIntExt = ".fint"
+
+-- |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 token files
+tokensExt :: String
+tokensExt = ".tokens"
+
+-- ---------------------------------------------------------------------------
+-- Computation of file names for a given source file
+-- ---------------------------------------------------------------------------
+
+-- |Compute the filename of the interface file for a source file
+interfName :: FilePath -> FilePath
+interfName = replaceExtensionWith icurryExt
+
+-- |Compute the filename of the typed flat curry file for a source file
+typedFlatName :: FilePath -> FilePath
+typedFlatName = replaceExtensionWith typedFlatExt
+
+-- |Compute the filename of the flat curry file for a source file
+flatName :: FilePath -> FilePath
+flatName = replaceExtensionWith flatExt
+
+-- |Compute the filename of the flat curry interface file for a source file
+flatIntName :: FilePath -> FilePath
+flatIntName = replaceExtensionWith flatIntExt
+
+-- |Compute the filename of the abstract curry file for a source file
+acyName :: FilePath -> FilePath
+acyName = replaceExtensionWith acyExt
+
+-- |Compute the filename of the untyped abstract curry file for a source file
+uacyName :: FilePath -> FilePath
+uacyName = replaceExtensionWith uacyExt
+
+-- |Compute the filename of the source representation file for a source file
+sourceRepName :: FilePath -> FilePath
+sourceRepName = replaceExtensionWith sourceRepExt
+
+-- |Compute the filename of the tokens file for a source file
+tokensName :: FilePath -> FilePath
+tokensName = replaceExtensionWith tokensExt
+
+-- |Compute the filename of the HTML file for a source file
+htmlName :: ModuleIdent -> String
+htmlName m = moduleName m ++ "_curry.html"
+
+-- |Replace a filename extension with a new extension
+replaceExtensionWith :: String -> FilePath -> FilePath
+replaceExtensionWith = flip replaceExtension
diff --git a/src/Curry/Files/PathUtils.hs b/src/Curry/Files/PathUtils.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Files/PathUtils.hs
@@ -0,0 +1,181 @@
+{- |
+ Module : $Header$
+ Description : Utility functions for reading and writing files
+ Copyright : (c) 1999 - 2003, Wolfgang Lux
+ 2011 - 2014, Björn Peemöller (bjp@informatik.uni-kiel.de)
+ 2017 , Finn Teegen (fte@informatik.uni-kiel.de)
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+-}
+
+{-# LANGUAGE CPP #-}
+
+module Curry.Files.PathUtils
+ ( -- * Retrieving curry files
+ lookupCurryFile
+ , lookupCurryModule
+ , lookupCurryInterface
+ , lookupFile
+
+ -- * Reading and writing modules from files
+ , getModuleModTime
+ , writeModule
+ , readModule
+ , addVersion
+ , checkVersion
+ ) where
+
+import qualified Control.Exception as C (IOException, handle)
+import Control.Monad (liftM)
+import Data.List (isPrefixOf, isSuffixOf)
+import System.FilePath
+import System.Directory
+import System.IO
+
+#if MIN_VERSION_directory(1,2,0)
+import Data.Time (UTCTime)
+#else
+import System.Time (ClockTime)
+#endif
+
+import Curry.Base.Ident
+import Curry.Files.Filenames
+
+-- ---------------------------------------------------------------------------
+-- Searching for files
+-- ---------------------------------------------------------------------------
+
+-- |Search in the given list of paths for the given 'FilePath' and eventually
+-- return the file name of the found file.
+--
+-- - If the file name already contains a directory, then the paths to search
+-- in are ignored.
+-- - If the file name has no extension, then a source file extension is
+-- assumed.
+lookupCurryFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)
+lookupCurryFile paths fn = lookupFile paths exts fn
+ where
+ exts | null fnExt = sourceExts
+ | otherwise = [fnExt]
+ fnExt = takeExtension fn
+
+-- |Search for a given curry module in the given source file and
+-- library paths. Note that the current directory is always searched first.
+-- Returns the path of the found file.
+lookupCurryModule :: [FilePath] -- ^ list of paths to source files
+ -> [FilePath] -- ^ list of paths to library files
+ -> ModuleIdent -- ^ module identifier
+ -> IO (Maybe FilePath)
+lookupCurryModule paths libPaths m =
+ lookupFile (paths ++ libPaths) moduleExts (moduleNameToFile m)
+
+-- |Search for an interface file in the import search path using the
+-- interface extension 'icurryExt'. Note that the current directory is
+-- always searched first.
+lookupCurryInterface :: [FilePath] -- ^ list of paths to search in
+ -> ModuleIdent -- ^ module identifier
+ -> IO (Maybe FilePath) -- ^ the file path if found
+lookupCurryInterface paths m = lookupFile paths [icurryExt] (moduleNameToFile m)
+
+-- |Search in the given directories for the file with the specified file
+-- extensions and eventually return the 'FilePath' of the file.
+lookupFile :: [FilePath] -- ^ Directories to search in
+ -> [String] -- ^ Accepted file extensions
+ -> FilePath -- ^ Initial file name
+ -> IO (Maybe FilePath) -- ^ 'FilePath' of the file if found
+lookupFile paths exts file = lookup' files
+ where
+ files = [ normalise (p f) | p <- paths, f <- baseNames ]
+ baseNames = map (replaceExtension file) exts
+
+ lookup' [] = return Nothing
+ lookup' (f : fs) = do
+ exists <- doesFileExist f
+ if exists then return (Just f) else lookup' fs
+
+-- ---------------------------------------------------------------------------
+-- Reading and writing files
+-- ---------------------------------------------------------------------------
+
+-- | Write the content to a file in the given directory.
+writeModule :: FilePath -- ^ original path
+ -> String -- ^ file content
+ -> IO ()
+writeModule fn contents = do
+ createDirectoryIfMissing True $ takeDirectory fn
+ tryWriteFile fn contents
+
+
+-- | Read the specified module and returns either 'Just String' if
+-- reading was successful or 'Nothing' otherwise.
+readModule :: FilePath -> IO (Maybe String)
+readModule = tryOnExistingFile readFileUTF8
+ where
+ readFileUTF8 :: FilePath -> IO String
+ readFileUTF8 fn = do
+ hdl <- openFile fn ReadMode
+ hSetEncoding hdl utf8
+ hGetContents hdl
+
+-- | Get the modification time of a file, if existent
+#if MIN_VERSION_directory(1,2,0)
+getModuleModTime :: FilePath -> IO (Maybe UTCTime)
+#else
+getModuleModTime :: FilePath -> IO (Maybe ClockTime)
+#endif
+getModuleModTime = tryOnExistingFile getModificationTime
+
+-- |Add the given version string to the file content
+addVersion :: String -> String -> String
+addVersion v content = "{- " ++ v ++ " -}\n" ++ content
+
+-- |Check a source file for the given version string
+checkVersion :: String -> String -> Either String String
+checkVersion expected src = case lines src of
+ [] -> Left "empty file"
+ (l:ls) -> case getVersion l of
+ Just v | v == expected -> Right (unlines ls)
+ | otherwise -> Left $ "Expected version `" ++ expected
+ ++ "', but found version `" ++ v ++ "'"
+ _ -> Left $ "No version found"
+
+ where
+ getVersion s | "{- " `isPrefixOf` s && " -}" `isSuffixOf` s
+ = Just (reverse $ drop 3 $ reverse $ drop 3 s)
+ | otherwise
+ = Nothing
+
+-- ---------------------------------------------------------------------------
+-- Helper functions
+-- ---------------------------------------------------------------------------
+
+tryOnExistingFile :: (FilePath -> IO a) -> FilePath -> IO (Maybe a)
+tryOnExistingFile action fn = C.handle ignoreIOException $ do
+ exists <- doesFileExist fn
+ if exists then Just `liftM` action fn
+ else return Nothing
+
+ignoreIOException :: C.IOException -> IO (Maybe a)
+ignoreIOException _ = return Nothing
+
+-- | Try to write a file. If it already exists and is not writable,
+-- a warning is issued. This solves some file dependency problems
+-- in global installations.
+tryWriteFile :: FilePath -- ^ original path
+ -> String -- ^ file content
+ -> IO ()
+tryWriteFile fn contents = do
+ exists <- doesFileExist fn
+ if exists then C.handle issueWarning (writeFileUTF8 fn contents)
+ else writeFileUTF8 fn contents
+ where
+ issueWarning :: C.IOException -> IO ()
+ issueWarning _ = do
+ putStrLn $ "*** Warning: cannot update file `" ++ fn ++ "' (update ignored)"
+ return ()
+ writeFileUTF8 :: FilePath -> String -> IO ()
+ writeFileUTF8 fn' str =
+ withFile fn' WriteMode (\hdl -> hSetEncoding hdl utf8 >> hPutStr hdl str)
diff --git a/src/Curry/Files/Unlit.hs b/src/Curry/Files/Unlit.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Files/Unlit.hs
@@ -0,0 +1,70 @@
+{- |
+ Module : $Header$
+ Description : Handling of literate Curry files
+ Copyright : (c) 2009 Holger Siegel
+ 2012 - 2014 Björn Peemöller
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ Since version 0.7 of the language report, Curry accepts literate
+ source programs. In a literate source, all program lines must begin
+ with a greater sign in the first column. All other lines are assumed
+ to be documentation. In order to avoid some common errors with
+ literate programs, Curry requires at least one program line to be
+ present in the file. In addition, every block of program code must be
+ preceded by a blank line and followed by a blank line.
+-}
+
+module Curry.Files.Unlit (isLiterate, unlit) where
+
+import Control.Monad (when, zipWithM)
+import Data.Char (isSpace)
+
+import Curry.Base.Monad (CYM, failMessageAt)
+import Curry.Base.Position (Position (..), first)
+import Curry.Files.Filenames (lcurryExt, takeExtension)
+
+-- |Check whether a 'FilePath' represents a literate Curry module
+isLiterate :: FilePath -> Bool
+isLiterate = (== lcurryExt) . takeExtension
+
+-- |Data type representing different kind of lines in a literate source
+data Line
+ = Program !Int String -- ^ program line with a line number and content
+ | Blank -- ^ blank line
+ | Comment -- ^ comment line
+
+-- |Process a curry program into error messages (if any) and the
+-- corresponding non-literate program.
+unlit :: FilePath -> String -> CYM String
+unlit fn cy
+ | isLiterate fn = do
+ ls <- progLines fn $ zipWith classify [1 .. ] $ lines cy
+ when (all null ls) $ failMessageAt (first fn) "No code in literate script"
+ return (unlines ls)
+ | otherwise = return cy
+
+-- |Classification of a single program line
+classify :: Int -> String -> Line
+classify l ('>' : cs) = Program l cs
+classify _ cs | all isSpace cs = Blank
+ | otherwise = Comment
+
+-- |Check that each program line is not adjacent to a comment line and there
+-- is at least one program line.
+progLines :: FilePath -> [Line] -> CYM [String]
+progLines fn cs = zipWithM checkAdjacency (Blank : cs) cs where
+ checkAdjacency (Program p _) Comment = report fn p "followed"
+ checkAdjacency Comment (Program p _) = report fn p "preceded"
+ checkAdjacency _ (Program _ s) = return s
+ checkAdjacency _ _ = return ""
+
+-- |Compute an appropiate error message
+report :: String -> Int -> String -> CYM a
+report f l cause = failMessageAt (Position f l 1) msg
+ where msg = concat [ "When reading literate source: "
+ , "Program line is " ++ cause ++ " by comment line."
+ ]
diff --git a/src/Curry/FlatCurry.hs b/src/Curry/FlatCurry.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/FlatCurry.hs
@@ -0,0 +1,19 @@
+{- |
+ Module : $Header$
+ Description : Interface for reading and manipulating FlatCurry source code
+ Copyright : (c) 2014 Björn Peemöller
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+-}
+module Curry.FlatCurry
+ ( module Curry.FlatCurry.Type
+ , module Curry.FlatCurry.Pretty
+ , module Curry.FlatCurry.Files
+ ) where
+
+import Curry.FlatCurry.Files
+import Curry.FlatCurry.Pretty
+import Curry.FlatCurry.Type
diff --git a/src/Curry/FlatCurry/Annotated/Goodies.hs b/src/Curry/FlatCurry/Annotated/Goodies.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/FlatCurry/Annotated/Goodies.hs
@@ -0,0 +1,670 @@
+{- |
+ Module : $Header$
+ Description : Utility functions for working with annotated FlatCurry.
+ Copyright : (c) 2016 - 2017 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ TODO
+-}
+
+module Curry.FlatCurry.Annotated.Goodies
+ ( module Curry.FlatCurry.Annotated.Goodies
+ , module Curry.FlatCurry.Goodies
+ ) where
+
+import Curry.FlatCurry.Goodies ( Update
+ , trType, typeName, typeVisibility, typeParams
+ , typeConsDecls, typeSyn, isTypeSyn
+ , isDataTypeDecl, isExternalType, isPublicType
+ , updType, updTypeName, updTypeVisibility
+ , updTypeParams, updTypeConsDecls, updTypeSynonym
+ , updQNamesInType
+ , trCons, consName, consArity, consVisibility
+ , isPublicCons, consArgs, updCons, updConsName
+ , updConsArity, updConsVisibility, updConsArgs
+ , updQNamesInConsDecl
+ , tVarIndex, domain, range, tConsName, tConsArgs
+ , trTypeExpr, isTVar, isTCons, isFuncType
+ , updTVars, updTCons, updFuncTypes, argTypes
+ , typeArity, resultType, allVarsInTypeExpr
+ , allTypeCons, rnmAllVarsInTypeExpr
+ , updQNamesInTypeExpr
+ , trOp, opName, opFixity, opPrecedence, updOp
+ , updOpName, updOpFixity, updOpPrecedence
+ , trCombType, isCombTypeFuncCall
+ , isCombTypeFuncPartCall, isCombTypeConsCall
+ , isCombTypeConsPartCall
+ , isPublic
+ )
+
+import Curry.FlatCurry.Annotated.Type
+
+-- AProg ----------------------------------------------------------------------
+
+-- |transform program
+trAProg :: (String -> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> b)
+ -> AProg a -> b
+trAProg prog (AProg name imps types funcs ops) = prog name imps types funcs ops
+
+-- Selectors
+
+-- |get name from program
+aProgName :: AProg a -> String
+aProgName = trAProg (\name _ _ _ _ -> name)
+
+-- |get imports from program
+aProgImports :: AProg a -> [String]
+aProgImports = trAProg (\_ imps _ _ _ -> imps)
+
+-- |get type declarations from program
+aProgTypes :: AProg a -> [TypeDecl]
+aProgTypes = trAProg (\_ _ types _ _ -> types)
+
+-- |get functions from program
+aProgAFuncs :: AProg a -> [AFuncDecl a]
+aProgAFuncs = trAProg (\_ _ _ funcs _ -> funcs)
+
+-- |get infix operators from program
+aProgOps :: AProg a -> [OpDecl]
+aProgOps = trAProg (\_ _ _ _ ops -> ops)
+
+-- Update Operations
+
+-- |update program
+updAProg :: (String -> String) ->
+ ([String] -> [String]) ->
+ ([TypeDecl] -> [TypeDecl]) ->
+ ([AFuncDecl a] -> [AFuncDecl a]) ->
+ ([OpDecl] -> [OpDecl]) -> AProg a -> AProg a
+updAProg fn fi ft ff fo = trAProg prog
+ where
+ prog name imps types funcs ops
+ = AProg (fn name) (fi imps) (ft types) (ff funcs) (fo ops)
+
+-- |update name of program
+updAProgName :: Update (AProg a) String
+updAProgName f = updAProg f id id id id
+
+-- |update imports of program
+updAProgImports :: Update (AProg a) [String]
+updAProgImports f = updAProg id f id id id
+
+-- |update type declarations of program
+updAProgTypes :: Update (AProg a) [TypeDecl]
+updAProgTypes f = updAProg id id f id id
+
+-- |update functions of program
+updAProgAFuncs :: Update (AProg a) [AFuncDecl a]
+updAProgAFuncs f = updAProg id id id f id
+
+-- |update infix operators of program
+updAProgOps :: Update (AProg a) [OpDecl]
+updAProgOps = updAProg id id id id
+
+-- Auxiliary Functions
+
+-- |get all program variables (also from patterns)
+allVarsInAProg :: AProg a -> [(VarIndex, a)]
+allVarsInAProg = concatMap allVarsInAFunc . aProgAFuncs
+
+-- |lift transformation on expressions to program
+updAProgAExps :: Update (AProg a) (AExpr a)
+updAProgAExps = updAProgAFuncs . map . updAFuncBody
+
+-- |rename programs variables
+rnmAllVarsInAProg :: Update (AProg a) VarIndex
+rnmAllVarsInAProg = updAProgAFuncs . map . rnmAllVarsInAFunc
+
+-- |update all qualified names in program
+updQNamesInAProg :: Update (AProg a) QName
+updQNamesInAProg f = updAProg id id
+ (map (updQNamesInType f)) (map (updQNamesInAFunc f)) (map (updOpName f))
+
+-- |rename program (update name of and all qualified names in program)
+rnmAProg :: String -> AProg a -> AProg a
+rnmAProg name p = updAProgName (const name) (updQNamesInAProg rnm p)
+ where
+ rnm (m, n) | m == aProgName p = (name, n)
+ | otherwise = (m, n)
+
+-- AFuncDecl ------------------------------------------------------------------
+
+-- |transform function
+trAFunc :: (QName -> Int -> Visibility -> TypeExpr -> ARule a -> b) -> AFuncDecl a -> b
+trAFunc func (AFunc name arity vis t rule) = func name arity vis t rule
+
+-- Selectors
+
+-- |get name of function
+aFuncName :: AFuncDecl a -> QName
+aFuncName = trAFunc (\name _ _ _ _ -> name)
+
+-- |get arity of function
+aFuncArity :: AFuncDecl a -> Int
+aFuncArity = trAFunc (\_ arity _ _ _ -> arity)
+
+-- |get visibility of function
+aFuncVisibility :: AFuncDecl a -> Visibility
+aFuncVisibility = trAFunc (\_ _ vis _ _ -> vis)
+
+-- |get type of function
+aFuncType :: AFuncDecl a -> TypeExpr
+aFuncType = trAFunc (\_ _ _ t _ -> t)
+
+-- |get rule of function
+aFuncARule :: AFuncDecl a -> ARule a
+aFuncARule = trAFunc (\_ _ _ _ rule -> rule)
+
+-- Update Operations
+
+-- |update function
+updAFunc :: (QName -> QName) ->
+ (Int -> Int) ->
+ (Visibility -> Visibility) ->
+ (TypeExpr -> TypeExpr) ->
+ (ARule a -> ARule a) -> AFuncDecl a -> AFuncDecl a
+updAFunc fn fa fv ft fr = trAFunc func
+ where
+ func name arity vis t rule
+ = AFunc (fn name) (fa arity) (fv vis) (ft t) (fr rule)
+
+-- |update name of function
+updAFuncName :: Update (AFuncDecl a) QName
+updAFuncName f = updAFunc f id id id id
+
+-- |update arity of function
+updAFuncArity :: Update (AFuncDecl a) Int
+updAFuncArity f = updAFunc id f id id id
+
+-- |update visibility of function
+updAFuncVisibility :: Update (AFuncDecl a) Visibility
+updAFuncVisibility f = updAFunc id id f id id
+
+-- |update type of function
+updFuncType :: Update (AFuncDecl a) TypeExpr
+updFuncType f = updAFunc id id id f id
+
+-- |update rule of function
+updAFuncARule :: Update (AFuncDecl a) (ARule a)
+updAFuncARule = updAFunc id id id id
+
+-- Auxiliary Functions
+
+-- |is function public?
+isPublicAFunc :: AFuncDecl a -> Bool
+isPublicAFunc = isPublic . aFuncVisibility
+
+-- |is function externally defined?
+isExternal :: AFuncDecl a -> Bool
+isExternal = isARuleExternal . aFuncARule
+
+-- |get variable names in a function declaration
+allVarsInAFunc :: AFuncDecl a -> [(VarIndex, a)]
+allVarsInAFunc = allVarsInARule . aFuncARule
+
+-- |get arguments of function, if not externally defined
+aFuncArgs :: AFuncDecl a -> [(VarIndex, a)]
+aFuncArgs = aRuleArgs . aFuncARule
+
+-- |get body of function, if not externally defined
+aFuncBody :: AFuncDecl a -> AExpr a
+aFuncBody = aRuleBody . aFuncARule
+
+-- |get the right-hand-sides of a 'FuncDecl'
+aFuncRHS :: AFuncDecl a -> [AExpr a]
+aFuncRHS f | not (isExternal f) = orCase (aFuncBody f)
+ | otherwise = []
+ where
+ orCase e
+ | isAOr e = concatMap orCase (orExps e)
+ | isACase e = concatMap orCase (map aBranchAExpr (caseBranches e))
+ | otherwise = [e]
+
+-- |rename all variables in function
+rnmAllVarsInAFunc :: Update (AFuncDecl a) VarIndex
+rnmAllVarsInAFunc = updAFunc id id id id . rnmAllVarsInARule
+
+-- |update all qualified names in function
+updQNamesInAFunc :: Update (AFuncDecl a) QName
+updQNamesInAFunc f = updAFunc f id id (updQNamesInTypeExpr f) (updQNamesInARule f)
+
+-- |update arguments of function, if not externally defined
+updAFuncArgs :: Update (AFuncDecl a) [(VarIndex, a)]
+updAFuncArgs = updAFuncARule . updARuleArgs
+
+-- |update body of function, if not externally defined
+updAFuncBody :: Update (AFuncDecl a) (AExpr a)
+updAFuncBody = updAFuncARule . updARuleBody
+
+-- ARule ----------------------------------------------------------------------
+
+-- |transform rule
+trARule :: (a -> [(VarIndex, a)] -> AExpr a -> b) -> (a -> String -> b) -> ARule a -> b
+trARule rule _ (ARule a args e) = rule a args e
+trARule _ ext (AExternal a s) = ext a s
+
+-- Selectors
+
+-- |get rules annotation
+aRuleAnnot :: ARule a -> a
+aRuleAnnot = trARule (\a _ _ -> a) (\a _ -> a)
+
+-- |get rules arguments if it's not external
+aRuleArgs :: ARule a -> [(VarIndex, a)]
+aRuleArgs = trARule (\_ args _ -> args) undefined
+
+-- |get rules body if it's not external
+aRuleBody :: ARule a -> AExpr a
+aRuleBody = trARule (\_ _ e -> e) undefined
+
+-- |get rules external declaration
+aRuleExtDecl :: ARule a -> String
+aRuleExtDecl = trARule undefined (\_ s -> s)
+
+-- Test Operations
+
+-- |is rule external?
+isARuleExternal :: ARule a -> Bool
+isARuleExternal = trARule (\_ _ _ -> False) (\_ _ -> True)
+
+-- Update Operations
+
+-- |update rule
+updARule :: (a -> b) ->
+ ([(VarIndex, a)] -> [(VarIndex, b)]) ->
+ (AExpr a -> AExpr b) ->
+ (String -> String) -> ARule a -> ARule b
+updARule fannot fa fe fs = trARule rule ext
+ where
+ rule a args e = ARule (fannot a) (fa args) (fe e)
+ ext a s = AExternal (fannot a) (fs s)
+
+-- |update rules annotation
+updARuleAnnot :: Update (ARule a) a
+updARuleAnnot f = updARule f id id id
+
+-- |update rules arguments
+updARuleArgs :: Update (ARule a) [(VarIndex, a)]
+updARuleArgs f = updARule id f id id
+
+-- |update rules body
+updARuleBody :: Update (ARule a) (AExpr a)
+updARuleBody f = updARule id id f id
+
+-- |update rules external declaration
+updARuleExtDecl :: Update (ARule a) String
+updARuleExtDecl f = updARule id id id f
+
+-- Auxiliary Functions
+
+-- |get variable names in a functions rule
+allVarsInARule :: ARule a -> [(VarIndex, a)]
+allVarsInARule = trARule (\_ args body -> args ++ allVars body) (\_ _ -> [])
+
+-- |rename all variables in rule
+rnmAllVarsInARule :: Update (ARule a) VarIndex
+rnmAllVarsInARule f = updARule id (map (\(a, b) -> (f a, b))) (rnmAllVars f) id
+
+-- |update all qualified names in rule
+updQNamesInARule :: Update (ARule a) QName
+updQNamesInARule = updARuleBody . updQNames
+
+-- AExpr ----------------------------------------------------------------------
+
+-- Selectors
+
+-- |get annoation of an expression
+annot :: AExpr a -> a
+annot (AVar a _ ) = a
+annot (ALit a _ ) = a
+annot (AComb a _ _ _) = a
+annot (ALet a _ _ ) = a
+annot (AFree a _ _ ) = a
+annot (AOr a _ _ ) = a
+annot (ACase a _ _ _) = a
+annot (ATyped a _ _ ) = a
+
+-- |get internal number of variable
+varNr :: AExpr a -> VarIndex
+varNr (AVar _ n) = n
+varNr _ = error "Curry.FlatCurry.Annotated.Goodies.varNr: no variable"
+
+-- |get literal if expression is literal expression
+literal :: AExpr a -> Literal
+literal (ALit _ l) = l
+literal _ = error "Curry.FlatCurry.Annotated.Goodies.literal: no literal"
+
+-- |get combination type of a combined expression
+combType :: AExpr a -> CombType
+combType (AComb _ ct _ _) = ct
+combType _ = error $ "Curry.FlatCurry.Annotated.Goodies.combType: " ++
+ "no combined expression"
+
+-- |get name of a combined expression
+combName :: AExpr a -> (QName, a)
+combName (AComb _ _ name _) = name
+combName _ = error $ "Curry.FlatCurry.Annotated.Goodies.combName: " ++
+ "no combined expression"
+
+-- |get arguments of a combined expression
+combArgs :: AExpr a -> [AExpr a]
+combArgs (AComb _ _ _ args) = args
+combArgs _ = error $ "Curry.FlatCurry.Annotated.Goodies.combArgs: " ++
+ "no combined expression"
+
+-- |get number of missing arguments if expression is combined
+missingCombArgs :: AExpr a -> Int
+missingCombArgs = missingArgs . combType
+ where
+ missingArgs :: CombType -> Int
+ missingArgs = trCombType 0 id 0 id
+
+-- |get indices of varoables in let declaration
+letBinds :: AExpr a -> [((VarIndex, a), AExpr a)]
+letBinds (ALet _ vs _) = vs
+letBinds _ = error $ "Curry.FlatCurry.Annotated.Goodies.letBinds: " ++
+ "no let expression"
+
+-- |get body of let declaration
+letBody :: AExpr a -> AExpr a
+letBody (ALet _ _ e) = e
+letBody _ = error $ "Curry.FlatCurry.Annotated.Goodies.letBody: " ++
+ "no let expression"
+
+-- |get variable indices from declaration of free variables
+freeVars :: AExpr a -> [(VarIndex, a)]
+freeVars (AFree _ vs _) = vs
+freeVars _ = error $ "Curry.FlatCurry.Annotated.Goodies.freeVars: " ++
+ "no declaration of free variables"
+
+-- |get expression from declaration of free variables
+freeExpr :: AExpr a -> AExpr a
+freeExpr (AFree _ _ e) = e
+freeExpr _ = error $ "Curry.FlatCurry.Annotated.Goodies.freeExpr: " ++
+ "no declaration of free variables"
+
+-- |get expressions from or-expression
+orExps :: AExpr a -> [AExpr a]
+orExps (AOr _ e1 e2) = [e1, e2]
+orExps _ = error $ "Curry.FlatCurry.Annotated.Goodies.orExps: " ++
+ "no or expression"
+
+-- |get case-type of case expression
+caseType :: AExpr a -> CaseType
+caseType (ACase _ ct _ _) = ct
+caseType _ = error $ "Curry.FlatCurry.Annotated.Goodies.caseType: " ++
+ "no case expression"
+
+-- |get scrutinee of case expression
+caseExpr :: AExpr a -> AExpr a
+caseExpr (ACase _ _ e _) = e
+caseExpr _ = error $ "Curry.FlatCurry.Annotated.Goodies.caseExpr: " ++
+ "no case expression"
+
+
+-- |get branch expressions from case expression
+caseBranches :: AExpr a -> [ABranchExpr a]
+caseBranches (ACase _ _ _ bs) = bs
+caseBranches _ = error
+ "Curry.FlatCurry.Annotated.Goodies.caseBranches: no case expression"
+
+-- Test Operations
+
+-- |is expression a variable?
+isAVar :: AExpr a -> Bool
+isAVar e = case e of
+ AVar _ _ -> True
+ _ -> False
+
+-- |is expression a literal expression?
+isALit :: AExpr a -> Bool
+isALit e = case e of
+ ALit _ _ -> True
+ _ -> False
+
+-- |is expression combined?
+isAComb :: AExpr a -> Bool
+isAComb e = case e of
+ AComb _ _ _ _ -> True
+ _ -> False
+
+-- |is expression a let expression?
+isALet :: AExpr a -> Bool
+isALet e = case e of
+ ALet _ _ _ -> True
+ _ -> False
+
+-- |is expression a declaration of free variables?
+isAFree :: AExpr a -> Bool
+isAFree e = case e of
+ AFree _ _ _ -> True
+ _ -> False
+
+-- |is expression an or-expression?
+isAOr :: AExpr a -> Bool
+isAOr e = case e of
+ AOr _ _ _ -> True
+ _ -> False
+
+-- |is expression a case expression?
+isACase :: AExpr a -> Bool
+isACase e = case e of
+ ACase _ _ _ _ -> True
+ _ -> False
+
+-- |transform expression
+trAExpr :: (a -> VarIndex -> b)
+ -> (a -> Literal -> b)
+ -> (a -> CombType -> (QName, a) -> [b] -> b)
+ -> (a -> [((VarIndex, a), b)] -> b -> b)
+ -> (a -> [(VarIndex, a)] -> b -> b)
+ -> (a -> b -> b -> b)
+ -> (a -> CaseType -> b -> [c] -> b)
+ -> (APattern a -> b -> c)
+ -> (a -> b -> TypeExpr -> b)
+ -> AExpr a
+ -> b
+trAExpr var lit comb lt fr oR cas branch typed expr = case expr of
+ AVar a n -> var a n
+ ALit a l -> lit a l
+ AComb a ct name args -> comb a ct name (map f args)
+ ALet a bs e -> lt a (map (\(v, x) -> (v, f x)) bs) (f e)
+ AFree a vs e -> fr a vs (f e)
+ AOr a e1 e2 -> oR a (f e1) (f e2)
+ ACase a ct e bs -> cas a ct (f e) (map (\ (ABranch p e') -> branch p (f e')) bs)
+ ATyped a e ty -> typed a (f e) ty
+ where
+ f = trAExpr var lit comb lt fr oR cas branch typed
+
+-- |update all variables in given expression
+updVars :: (a -> VarIndex -> AExpr a) -> AExpr a -> AExpr a
+updVars var = trAExpr var ALit AComb ALet AFree AOr ACase ABranch ATyped
+
+-- |update all literals in given expression
+updLiterals :: (a -> Literal -> AExpr a) -> AExpr a -> AExpr a
+updLiterals lit = trAExpr AVar lit AComb ALet AFree AOr ACase ABranch ATyped
+
+-- |update all combined expressions in given expression
+updCombs :: (a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a) -> AExpr a -> AExpr a
+updCombs comb = trAExpr AVar ALit comb ALet AFree AOr ACase ABranch ATyped
+
+-- |update all let expressions in given expression
+updLets :: (a -> [((VarIndex, a), AExpr a)] -> AExpr a -> AExpr a) -> AExpr a -> AExpr a
+updLets lt = trAExpr AVar ALit AComb lt AFree AOr ACase ABranch ATyped
+
+-- |update all free declarations in given expression
+updFrees :: (a -> [(VarIndex, a)] -> AExpr a -> AExpr a) -> AExpr a -> AExpr a
+updFrees fr = trAExpr AVar ALit AComb ALet fr AOr ACase ABranch ATyped
+
+-- |update all or expressions in given expression
+updOrs :: (a -> AExpr a -> AExpr a -> AExpr a) -> AExpr a -> AExpr a
+updOrs oR = trAExpr AVar ALit AComb ALet AFree oR ACase ABranch ATyped
+
+-- |update all case expressions in given expression
+updCases :: (a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a) -> AExpr a -> AExpr a
+updCases cas = trAExpr AVar ALit AComb ALet AFree AOr cas ABranch ATyped
+
+-- |update all case branches in given expression
+updBranches :: (APattern a -> AExpr a -> ABranchExpr a) -> AExpr a -> AExpr a
+updBranches branch = trAExpr AVar ALit AComb ALet AFree AOr ACase branch ATyped
+
+-- |update all typed expressions in given expression
+updTypeds :: (a -> AExpr a -> TypeExpr -> AExpr a) -> AExpr a -> AExpr a
+updTypeds = trAExpr AVar ALit AComb ALet AFree AOr ACase ABranch
+
+-- Auxiliary Functions
+
+-- |is expression a call of a function where all arguments are provided?
+isFuncCall :: AExpr a -> Bool
+isFuncCall e = isAComb e && isCombTypeFuncCall (combType e)
+
+-- |is expression a partial function call?
+isFuncPartCall :: AExpr a -> Bool
+isFuncPartCall e = isAComb e && isCombTypeFuncPartCall (combType e)
+
+-- |is expression a call of a constructor?
+isConsCall :: AExpr a -> Bool
+isConsCall e = isAComb e && isCombTypeConsCall (combType e)
+
+-- |is expression a partial constructor call?
+isConsPartCall :: AExpr a -> Bool
+isConsPartCall e = isAComb e && isCombTypeConsPartCall (combType e)
+
+-- |is expression fully evaluated?
+isGround :: AExpr a -> Bool
+isGround e
+ = case e of
+ AComb _ ConsCall _ args -> all isGround args
+ _ -> isALit e
+
+-- |get all variables (also pattern variables) in expression
+allVars :: AExpr a -> [(VarIndex, a)]
+allVars e = trAExpr var lit comb lt fr (const (.)) cas branch typ e []
+ where
+ var a v = (:) (v, a)
+ lit = const (const id)
+ 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'
+ typ _ = const
+ args pat | isConsPattern pat = aPatArgs pat
+ | otherwise = []
+
+-- |rename all variables (also in patterns) in expression
+rnmAllVars :: Update (AExpr a) VarIndex
+rnmAllVars f = trAExpr var ALit AComb lt fr AOr ACase branch ATyped
+ where
+ var a = AVar a . f
+ lt a = ALet a . map (\((n, b), e) -> ((f n, b), e))
+ fr a = AFree a . map (\(b, c) -> (f b, c))
+ branch = ABranch . updAPatArgs (map (\(a, b) -> (f a, b)))
+
+-- |update all qualified names in expression
+updQNames :: Update (AExpr a) QName
+updQNames f = trAExpr AVar ALit comb ALet AFree AOr ACase branch ATyped
+ where
+ comb a ct (name, a') args = AComb a ct (f name, a') args
+ branch = ABranch . updAPatCons (\(q, a) -> (f q, a))
+
+-- ABranchExpr ----------------------------------------------------------------
+
+-- |transform branch expression
+trABranch :: (APattern a -> AExpr a -> b) -> ABranchExpr a -> b
+trABranch branch (ABranch pat e) = branch pat e
+
+-- Selectors
+
+-- |get pattern from branch expression
+aBranchAPattern :: ABranchExpr a -> APattern a
+aBranchAPattern = trABranch (\pat _ -> pat)
+
+-- |get expression from branch expression
+aBranchAExpr :: ABranchExpr a -> AExpr a
+aBranchAExpr = trABranch (\_ e -> e)
+
+-- Update Operations
+
+-- |update branch expression
+updABranch :: (APattern a -> APattern a) -> (AExpr a -> AExpr a) -> ABranchExpr a -> ABranchExpr a
+updABranch fp fe = trABranch branch
+ where
+ branch pat e = ABranch (fp pat) (fe e)
+
+-- |update pattern of branch expression
+updABranchAPattern :: Update (ABranchExpr a) (APattern a)
+updABranchAPattern f = updABranch f id
+
+-- |update expression of branch expression
+updABranchAExpr :: Update (ABranchExpr a) (AExpr a)
+updABranchAExpr = updABranch id
+
+-- APattern -------------------------------------------------------------------
+
+-- |transform pattern
+trAPattern :: (a -> (QName, a) -> [(VarIndex, a)] -> b) -> (a -> Literal -> b) -> APattern a -> b
+trAPattern pattern _ (APattern a name args) = pattern a name args
+trAPattern _ lpattern (ALPattern a l) = lpattern a l
+
+-- Selectors
+
+-- |get annotation from pattern
+aPatAnnot :: APattern a -> a
+aPatAnnot = trAPattern (\a _ _ -> a) (\a _ -> a)
+
+-- |get name from constructor pattern
+aPatCons :: APattern a -> (QName, a)
+aPatCons = trAPattern (\_ name _ -> name) undefined
+
+-- |get arguments from constructor pattern
+aPatArgs :: APattern a -> [(VarIndex, a)]
+aPatArgs = trAPattern (\_ _ args -> args) undefined
+
+-- |get literal from literal pattern
+aPatLiteral :: APattern a -> Literal
+aPatLiteral = trAPattern undefined (const id)
+
+-- Test Operations
+
+-- |is pattern a constructor pattern?
+isConsPattern :: APattern a -> Bool
+isConsPattern = trAPattern (\_ _ _ -> True) (\_ _ -> False)
+
+-- Update Operations
+
+-- |update pattern
+updAPattern :: (a -> a) ->
+ ((QName, a) -> (QName, a)) ->
+ ([(VarIndex, a)] -> [(VarIndex, a)]) ->
+ (Literal -> Literal) -> APattern a -> APattern a
+updAPattern fannot fn fa fl = trAPattern pattern lpattern
+ where
+ pattern a name args = APattern (fannot a) (fn name) (fa args)
+ lpattern a l = ALPattern (fannot a) (fl l)
+
+-- |update annotation of pattern
+updAPatAnnot :: (a -> a) -> APattern a -> APattern a
+updAPatAnnot f = updAPattern f id id id
+
+-- |update constructors name of pattern
+updAPatCons :: ((QName, a) -> (QName, a)) -> APattern a -> APattern a
+updAPatCons f = updAPattern id f id id
+
+-- |update arguments of constructor pattern
+updAPatArgs :: ([(VarIndex, a)] -> [(VarIndex, a)]) -> APattern a -> APattern a
+updAPatArgs f = updAPattern id id f id
+
+-- |update literal of pattern
+updAPatLiteral :: (Literal -> Literal) -> APattern a -> APattern a
+updAPatLiteral f = updAPattern id id id f
+
+-- Auxiliary Functions
+
+-- |build expression from pattern
+aPatExpr :: APattern a -> AExpr a
+aPatExpr = trAPattern (\a name -> AComb a ConsCall name . map (uncurry (flip AVar))) ALit
diff --git a/src/Curry/FlatCurry/Annotated/Type.hs b/src/Curry/FlatCurry/Annotated/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/FlatCurry/Annotated/Type.hs
@@ -0,0 +1,53 @@
+{- |
+ Module : $Header$
+ Description : Representation of annotated FlatCurry.
+ Copyright : (c) 2016 - 2017 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ TODO
+-}
+
+module Curry.FlatCurry.Annotated.Type
+ ( module Curry.FlatCurry.Annotated.Type
+ , module Curry.FlatCurry.Type
+ ) where
+
+import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex
+ , TypeDecl (..), OpDecl (..), Fixity (..)
+ , TypeExpr (..), ConsDecl (..)
+ , Literal (..), CombType (..), CaseType (..)
+ )
+
+data AProg a = AProg String [String] [TypeDecl] [AFuncDecl a] [OpDecl]
+ deriving (Eq, Read, Show)
+
+data AFuncDecl a = AFunc QName Int Visibility TypeExpr (ARule a)
+ deriving (Eq, Read, Show)
+
+data ARule a
+ = ARule a [(VarIndex, a)] (AExpr a)
+ | AExternal a String
+ deriving (Eq, Read, Show)
+
+data AExpr a
+ = AVar a VarIndex
+ | ALit a Literal
+ | AComb a CombType (QName, a) [AExpr a]
+ | ALet a [((VarIndex, a), AExpr a)] (AExpr a)
+ | AFree a [(VarIndex, a)] (AExpr a)
+ | AOr a (AExpr a) (AExpr a)
+ | ACase a CaseType (AExpr a) [ABranchExpr a]
+ | ATyped a (AExpr a) TypeExpr
+ deriving (Eq, Read, Show)
+
+data ABranchExpr a = ABranch (APattern a) (AExpr a)
+ deriving (Eq, Read, Show)
+
+data APattern a
+ = APattern a (QName, a) [(VarIndex, a)]
+ | ALPattern a Literal
+ deriving (Eq, Read, Show)
diff --git a/src/Curry/FlatCurry/Annotated/Typing.hs b/src/Curry/FlatCurry/Annotated/Typing.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/FlatCurry/Annotated/Typing.hs
@@ -0,0 +1,36 @@
+{- |
+ Module : $Header$
+ Description : TODO
+ Copyright : (c) 2017 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ TODO
+-}
+
+module Curry.FlatCurry.Annotated.Typing (Typeable(..)) where
+
+import Curry.FlatCurry.Annotated.Type
+
+class Typeable a where
+ typeOf :: a -> TypeExpr
+
+instance Typeable TypeExpr where
+ typeOf = id
+
+instance Typeable a => Typeable (AExpr a) where
+ typeOf (AVar a _) = typeOf a
+ typeOf (ALit a _) = typeOf a
+ typeOf (AComb a _ _ _) = typeOf a
+ typeOf (ALet a _ _) = typeOf a
+ typeOf (AFree a _ _) = typeOf a
+ typeOf (AOr a _ _) = typeOf a
+ typeOf (ACase a _ _ _) = typeOf a
+ typeOf (ATyped a _ _) = typeOf a
+
+instance Typeable a => Typeable (APattern a) where
+ typeOf (APattern a _ _) = typeOf a
+ typeOf (ALPattern a _) = typeOf a
diff --git a/src/Curry/FlatCurry/Files.hs b/src/Curry/FlatCurry/Files.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/FlatCurry/Files.hs
@@ -0,0 +1,63 @@
+{- |
+ Module : $Header$
+ Description : Functions for reading and writing FlatCurry files
+ Copyright : (c) 2014 Björn Peemöller
+ 2017 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module contains functions for reading and writing FlatCurry files.
+-}
+
+module Curry.FlatCurry.Files
+ ( readTypedFlatCurry, readFlatCurry, readFlatInterface, writeFlatCurry
+ ) where
+
+import Control.Monad (liftM)
+import Data.Char (isSpace)
+
+import Curry.Files.Filenames (typedFlatName, flatName, flatIntName)
+import Curry.Files.PathUtils (writeModule, readModule)
+
+import Curry.FlatCurry.Type (Prog)
+import Curry.FlatCurry.Annotated.Type (AProg, TypeExpr)
+
+
+-- ---------------------------------------------------------------------------
+-- Functions for reading and writing FlatCurry terms
+-- ---------------------------------------------------------------------------
+
+-- |Reads an typed FlatCurry file (extension ".tfcy") and eventually
+-- returns the corresponding FlatCurry program term (type 'AProg').
+readTypedFlatCurry :: FilePath -> IO (Maybe (AProg TypeExpr))
+readTypedFlatCurry = readFlat . typedFlatName
+
+-- |Reads a FlatCurry file (extension ".fcy") and eventually returns the
+-- corresponding FlatCurry program term (type 'Prog').
+readFlatCurry :: FilePath -> IO (Maybe Prog)
+readFlatCurry = readFlat . flatName
+
+-- |Reads a FlatInterface file (extension @.fint@) and returns the
+-- corresponding term (type 'Prog') as a value of type 'Maybe'.
+readFlatInterface :: FilePath -> IO (Maybe Prog)
+readFlatInterface = readFlat . flatIntName
+
+-- |Reads a Flat file and returns the corresponding term (type 'Prog' or
+-- 'AProg') 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 :: Read a => FilePath -> IO (Maybe a)
+readFlat = liftM (liftM (read . skipComment)) . readModule where
+ skipComment s = case dropWhile isSpace s of
+ '{' : '-' : s' -> dropComment s'
+ s' -> s'
+ dropComment ('-' : '}' : xs) = xs
+ dropComment (_ : xs) = dropComment xs
+ dropComment [] = []
+
+-- |Writes a FlatCurry program term into a file.
+writeFlatCurry :: Show a => FilePath -> a -> IO ()
+writeFlatCurry fn = writeModule fn . show
diff --git a/src/Curry/FlatCurry/Goodies.hs b/src/Curry/FlatCurry/Goodies.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/FlatCurry/Goodies.hs
@@ -0,0 +1,970 @@
+{- |
+ Module : $Header$
+ Description : Utility functions for working with FlatCurry.
+ Copyright : (c) Sebastian Fischer 2006
+ Björn Peemöller 2011
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ 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 functions. For
+ recursive datatypes the transformations are defined inductively over the
+ term structure. This is quite usual for 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 - is abstracted away, which hopefully makes the
+ code more clear and brief.
+-}
+
+module Curry.FlatCurry.Goodies where
+
+import Curry.FlatCurry.Type
+
+-- |Update of a type's component
+type Update a b = (b -> b) -> a -> a
+
+-- Prog ----------------------------------------------------------------------
+
+-- |transform program
+trProg :: (String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> a)
+ -> Prog -> a
+trProg prog (Prog name imps types funcs ops) = prog name imps types funcs ops
+
+-- Selectors
+
+-- |get name from program
+progName :: Prog -> String
+progName = trProg (\name _ _ _ _ -> name)
+
+-- |get imports from program
+progImports :: Prog -> [String]
+progImports = trProg (\_ imps _ _ _ -> imps)
+
+-- |get type declarations from program
+progTypes :: Prog -> [TypeDecl]
+progTypes = trProg (\_ _ types _ _ -> types)
+
+-- |get functions from program
+progFuncs :: Prog -> [FuncDecl]
+progFuncs = trProg (\_ _ _ funcs _ -> funcs)
+
+-- |get infix operators from program
+progOps :: Prog -> [OpDecl]
+progOps = trProg (\_ _ _ _ ops -> ops)
+
+-- Update Operations
+
+-- |update program
+updProg :: (String -> String) ->
+ ([String] -> [String]) ->
+ ([TypeDecl] -> [TypeDecl]) ->
+ ([FuncDecl] -> [FuncDecl]) ->
+ ([OpDecl] -> [OpDecl]) -> Prog -> Prog
+updProg fn fi ft ff fo = trProg prog
+ where
+ prog name imps types funcs ops
+ = Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops)
+
+-- |update name of program
+updProgName :: Update Prog String
+updProgName f = updProg f id id id id
+
+-- |update imports of program
+updProgImports :: Update Prog [String]
+updProgImports f = updProg id f id id id
+
+-- |update type declarations of program
+updProgTypes :: Update Prog [TypeDecl]
+updProgTypes f = updProg id id f id id
+
+-- |update functions of program
+updProgFuncs :: Update Prog [FuncDecl]
+updProgFuncs f = updProg id id id f id
+
+-- |update infix operators of program
+updProgOps :: Update Prog [OpDecl]
+updProgOps = updProg id id id id
+
+-- Auxiliary Functions
+
+-- |get all program variables (also from patterns)
+allVarsInProg :: Prog -> [VarIndex]
+allVarsInProg = concatMap allVarsInFunc . progFuncs
+
+-- |lift transformation on expressions to program
+updProgExps :: Update Prog Expr
+updProgExps = updProgFuncs . map . updFuncBody
+
+-- |rename programs variables
+rnmAllVarsInProg :: Update Prog VarIndex
+rnmAllVarsInProg = updProgFuncs . map . rnmAllVarsInFunc
+
+-- |update all qualified names in program
+updQNamesInProg :: Update Prog QName
+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 (m,n) | m==progName p = (name,n)
+ | otherwise = (m,n)
+
+-- TypeDecl ------------------------------------------------------------------
+
+-- Selectors
+
+-- |transform type declaration
+trType :: (QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> a) ->
+ (QName -> Visibility -> [TVarIndex] -> TypeExpr -> a) -> TypeDecl -> a
+trType typ _ (Type name vis params cs) = typ name vis params cs
+trType _ typesyn (TypeSyn name vis params syn) = typesyn name vis params syn
+
+-- |get name of type declaration
+typeName :: TypeDecl -> QName
+typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name)
+
+-- |get visibility of type declaration
+typeVisibility :: TypeDecl -> Visibility
+typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis)
+
+-- |get type parameters of type declaration
+typeParams :: TypeDecl -> [TVarIndex]
+typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params)
+
+-- |get constructor declarations from type declaration
+typeConsDecls :: TypeDecl -> [ConsDecl]
+typeConsDecls = trType (\_ _ _ cs -> cs)
+ (error "Curry.FlatCurry.Goodies: type synonym")
+
+-- |get synonym of type declaration
+typeSyn :: TypeDecl -> TypeExpr
+typeSyn = trType undefined (\_ _ _ syn -> syn)
+
+-- |is type declaration a type synonym?
+isTypeSyn :: TypeDecl -> Bool
+isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True)
+
+-- | is type declaration declaring a regular type?
+isDataTypeDecl :: TypeDecl -> Bool
+isDataTypeDecl = trType (\_ _ _ cs -> not (null cs)) (\_ _ _ _ -> False)
+
+-- | is type declaration declaring an external type?
+isExternalType :: TypeDecl -> Bool
+isExternalType = trType (\_ _ _ cs -> null cs) (\_ _ _ _ -> False)
+
+-- |Is the 'TypeDecl' public?
+isPublicType :: TypeDecl -> Bool
+isPublicType = (== Public) . typeVisibility
+
+-- Update Operations
+
+-- |update type declaration
+updType :: (QName -> QName) ->
+ (Visibility -> Visibility) ->
+ ([TVarIndex] -> [TVarIndex]) ->
+ ([ConsDecl] -> [ConsDecl]) ->
+ (TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl
+updType fn fv fp fc fs = trType typ typesyn
+ where
+ typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs)
+ typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn)
+
+-- |update name of type declaration
+updTypeName :: Update TypeDecl QName
+updTypeName f = updType f id id id id
+
+-- |update visibility of type declaration
+updTypeVisibility :: Update TypeDecl Visibility
+updTypeVisibility f = updType id f id id id
+
+-- |update type parameters of type declaration
+updTypeParams :: Update TypeDecl [TVarIndex]
+updTypeParams f = updType id id f id id
+
+-- |update constructor declarations of type declaration
+updTypeConsDecls :: Update TypeDecl [ConsDecl]
+updTypeConsDecls f = updType id id id f id
+
+-- |update synonym of type declaration
+updTypeSynonym :: Update TypeDecl TypeExpr
+updTypeSynonym = updType id id id id
+
+-- Auxiliary Functions
+
+-- |update all qualified names in type declaration
+updQNamesInType :: Update TypeDecl QName
+updQNamesInType f
+ = updType f id id (map (updQNamesInConsDecl f)) (updQNamesInTypeExpr f)
+
+-- ConsDecl ------------------------------------------------------------------
+
+-- Selectors
+
+-- |transform constructor declaration
+trCons :: (QName -> Int -> Visibility -> [TypeExpr] -> a) -> ConsDecl -> a
+trCons cons (Cons name arity vis args) = cons name arity vis args
+
+-- |get name of constructor declaration
+consName :: ConsDecl -> QName
+consName = trCons (\name _ _ _ -> name)
+
+-- |get arity of constructor declaration
+consArity :: ConsDecl -> Int
+consArity = trCons (\_ arity _ _ -> arity)
+
+-- |get visibility of constructor declaration
+consVisibility :: ConsDecl -> Visibility
+consVisibility = trCons (\_ _ vis _ -> vis)
+
+-- |Is the constructor declaration public?
+isPublicCons :: ConsDecl -> Bool
+isPublicCons = isPublic . consVisibility
+
+-- |get arguments of constructor declaration
+consArgs :: ConsDecl -> [TypeExpr]
+consArgs = trCons (\_ _ _ args -> args)
+
+-- Update Operations
+
+-- |update constructor declaration
+updCons :: (QName -> QName) ->
+ (Int -> Int) ->
+ (Visibility -> Visibility) ->
+ ([TypeExpr] -> [TypeExpr]) -> ConsDecl -> ConsDecl
+updCons fn fa fv fas = trCons cons
+ where
+ cons name arity vis args = Cons (fn name) (fa arity) (fv vis) (fas args)
+
+-- |update name of constructor declaration
+updConsName :: Update ConsDecl QName
+updConsName f = updCons f id id id
+
+-- |update arity of constructor declaration
+updConsArity :: Update ConsDecl Int
+updConsArity f = updCons id f id id
+
+-- |update visibility of constructor declaration
+updConsVisibility :: Update ConsDecl Visibility
+updConsVisibility f = updCons id id f id
+
+-- |update arguments of constructor declaration
+updConsArgs :: Update ConsDecl [TypeExpr]
+updConsArgs = updCons id id id
+
+-- Auxiliary Functions
+
+-- |update all qualified names in constructor declaration
+updQNamesInConsDecl :: Update ConsDecl QName
+updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f))
+
+-- TypeExpr ------------------------------------------------------------------
+
+-- Selectors
+
+-- |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) ->
+ ([TVarIndex] -> a -> a) -> TypeExpr -> a
+trTypeExpr tvar _ _ _ (TVar n) = tvar n
+trTypeExpr tvar tcons functype foralltype (TCons name args)
+ = tcons name (map (trTypeExpr tvar tcons functype foralltype) args)
+trTypeExpr tvar tcons functype foralltype (FuncType from to)
+ = functype (f from) (f to)
+ where
+ f = trTypeExpr tvar tcons functype foralltype
+trTypeExpr tvar tcons functype foralltype (ForallType ns t)
+ = foralltype ns (trTypeExpr tvar tcons functype foralltype t)
+
+-- Test Operations
+
+-- |is type expression a type variable?
+isTVar :: TypeExpr -> Bool
+isTVar = trTypeExpr (\_ -> True) (\_ _ -> False) (\_ _ -> False) (\_ _ -> False)
+
+-- |is type declaration a constructed type?
+isTCons :: TypeExpr -> Bool
+isTCons
+ = trTypeExpr (\_ -> False) (\_ _ -> True) (\_ _ -> False) (\_ _ -> False)
+
+-- |is type declaration a functional type?
+isFuncType :: TypeExpr -> Bool
+isFuncType
+ = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> True) (\_ _ -> False)
+
+-- |is type declaration a forall type?
+isForallType :: TypeExpr -> Bool
+isForallType
+ = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> False) (\_ _ -> True)
+
+-- Update Operations
+
+-- |update all type variables
+updTVars :: (TVarIndex -> TypeExpr) -> TypeExpr -> TypeExpr
+updTVars tvar = trTypeExpr tvar TCons FuncType ForallType
+
+-- |update all type constructors
+updTCons :: (QName -> [TypeExpr] -> TypeExpr) -> TypeExpr -> TypeExpr
+updTCons tcons = trTypeExpr TVar tcons FuncType ForallType
+
+-- |update all functional types
+updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
+updFuncTypes functype = trTypeExpr TVar TCons functype ForallType
+
+-- |update all forall types
+updForallTypes :: ([TVarIndex] -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
+updForallTypes = trTypeExpr TVar TCons FuncType
+
+-- Auxiliary Functions
+
+-- |get argument types from functional type
+argTypes :: TypeExpr -> [TypeExpr]
+argTypes (TVar _) = []
+argTypes (TCons _ _) = []
+argTypes (FuncType dom ran) = dom : argTypes ran
+argTypes (ForallType _ _) = []
+
+-- |Compute the arity of a 'TypeExpr'
+typeArity :: TypeExpr -> Int
+typeArity = length . argTypes
+
+-- |get result type from (nested) functional type
+resultType :: TypeExpr -> TypeExpr
+resultType (TVar n) = TVar n
+resultType (TCons name args) = TCons name args
+resultType (FuncType _ ran) = resultType ran
+resultType (ForallType ns t) = ForallType ns t
+
+-- |get indexes of all type variables
+allVarsInTypeExpr :: TypeExpr -> [TVarIndex]
+allVarsInTypeExpr = trTypeExpr (:[]) (const concat) (++) (++)
+
+-- |yield the list of all contained type constructors
+allTypeCons :: TypeExpr -> [QName]
+allTypeCons (TVar _) = []
+allTypeCons (TCons name args) = name : concatMap allTypeCons args
+allTypeCons (FuncType t1 t2) = allTypeCons t1 ++ allTypeCons t2
+allTypeCons (ForallType _ t) = allTypeCons t
+
+-- |rename variables in type expression
+rnmAllVarsInTypeExpr :: (TVarIndex -> TVarIndex) -> TypeExpr -> TypeExpr
+rnmAllVarsInTypeExpr f = updTVars (TVar . f)
+
+-- |update all qualified names in type expression
+updQNamesInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr
+updQNamesInTypeExpr f = updTCons (\name args -> TCons (f name) args)
+
+-- OpDecl --------------------------------------------------------------------
+
+-- |transform operator declaration
+trOp :: (QName -> Fixity -> Integer -> a) -> OpDecl -> a
+trOp op (Op name fix prec) = op name fix prec
+
+-- Selectors
+
+-- |get name from operator declaration
+opName :: OpDecl -> QName
+opName = trOp (\name _ _ -> name)
+
+-- |get fixity of operator declaration
+opFixity :: OpDecl -> Fixity
+opFixity = trOp (\_ fix _ -> fix)
+
+-- |get precedence of operator declaration
+opPrecedence :: OpDecl -> Integer
+opPrecedence = trOp (\_ _ prec -> prec)
+
+-- Update Operations
+
+-- |update operator declaration
+updOp :: (QName -> QName) ->
+ (Fixity -> Fixity) ->
+ (Integer -> Integer) -> OpDecl -> OpDecl
+updOp fn ff fp = trOp op
+ where op name fix prec = Op (fn name) (ff fix) (fp prec)
+
+-- |update name of operator declaration
+updOpName :: Update OpDecl QName
+updOpName f = updOp f id id
+
+-- |update fixity of operator declaration
+updOpFixity :: Update OpDecl Fixity
+updOpFixity f = updOp id f id
+
+-- |update precedence of operator declaration
+updOpPrecedence :: Update OpDecl Integer
+updOpPrecedence = updOp id id
+
+-- FuncDecl ------------------------------------------------------------------
+
+-- |transform function
+trFunc :: (QName -> Int -> Visibility -> TypeExpr -> Rule -> a) -> FuncDecl -> a
+trFunc func (Func name arity vis t rule) = func name arity vis t rule
+
+-- Selectors
+
+-- |get name of function
+funcName :: FuncDecl -> QName
+funcName = trFunc (\name _ _ _ _ -> name)
+
+-- |get arity of function
+funcArity :: FuncDecl -> Int
+funcArity = trFunc (\_ arity _ _ _ -> arity)
+
+-- |get visibility of function
+funcVisibility :: FuncDecl -> Visibility
+funcVisibility = trFunc (\_ _ vis _ _ -> vis)
+
+-- |get type of function
+funcType :: FuncDecl -> TypeExpr
+funcType = trFunc (\_ _ _ t _ -> t)
+
+-- |get rule of function
+funcRule :: FuncDecl -> Rule
+funcRule = trFunc (\_ _ _ _ rule -> rule)
+
+-- Update Operations
+
+-- |update function
+updFunc :: (QName -> QName) ->
+ (Int -> Int) ->
+ (Visibility -> Visibility) ->
+ (TypeExpr -> TypeExpr) ->
+ (Rule -> Rule) -> FuncDecl -> FuncDecl
+updFunc fn fa fv ft fr = trFunc func
+ where
+ func name arity vis t rule
+ = Func (fn name) (fa arity) (fv vis) (ft t) (fr rule)
+
+-- |update name of function
+updFuncName :: Update FuncDecl QName
+updFuncName f = updFunc f id id id id
+
+-- |update arity of function
+updFuncArity :: Update FuncDecl Int
+updFuncArity f = updFunc id f id id id
+
+-- |update visibility of function
+updFuncVisibility :: Update FuncDecl Visibility
+updFuncVisibility f = updFunc id id f id id
+
+-- |update type of function
+updFuncType :: Update FuncDecl TypeExpr
+updFuncType f = updFunc id id id f id
+
+-- |update rule of function
+updFuncRule :: Update FuncDecl Rule
+updFuncRule = updFunc id id id id
+
+-- Auxiliary Functions
+
+-- |is function public?
+isPublicFunc :: FuncDecl -> Bool
+isPublicFunc = isPublic . funcVisibility
+
+-- |is function externally defined?
+isExternal :: FuncDecl -> Bool
+isExternal = isRuleExternal . funcRule
+
+-- |get variable names in a function declaration
+allVarsInFunc :: FuncDecl -> [VarIndex]
+allVarsInFunc = allVarsInRule . funcRule
+
+-- |get arguments of function, if not externally defined
+funcArgs :: FuncDecl -> [VarIndex]
+funcArgs = ruleArgs . funcRule
+
+-- |get body of function, if not externally defined
+funcBody :: FuncDecl -> Expr
+funcBody = ruleBody . funcRule
+
+-- |get the right-hand-sides of a 'FuncDecl'
+funcRHS :: FuncDecl -> [Expr]
+funcRHS f | not (isExternal f) = orCase (funcBody f)
+ | otherwise = []
+ where
+ orCase e
+ | isOr e = concatMap orCase (orExps e)
+ | isCase e = concatMap orCase (map branchExpr (caseBranches e))
+ | otherwise = [e]
+
+-- |rename all variables in function
+rnmAllVarsInFunc :: Update FuncDecl VarIndex
+rnmAllVarsInFunc = updFunc id id id id . rnmAllVarsInRule
+
+-- |update all qualified names in function
+updQNamesInFunc :: Update FuncDecl QName
+updQNamesInFunc f = updFunc f id id (updQNamesInTypeExpr f) (updQNamesInRule f)
+
+-- |update arguments of function, if not externally defined
+updFuncArgs :: Update FuncDecl [VarIndex]
+updFuncArgs = updFuncRule . updRuleArgs
+
+-- |update body of function, if not externally defined
+updFuncBody :: Update FuncDecl Expr
+updFuncBody = updFuncRule . updRuleBody
+
+-- Rule ----------------------------------------------------------------------
+
+-- |transform rule
+trRule :: ([VarIndex] -> Expr -> a) -> (String -> a) -> Rule -> a
+trRule rule _ (Rule args e) = rule args e
+trRule _ ext (External s) = ext s
+
+-- Selectors
+
+-- |get rules arguments if it's not external
+ruleArgs :: Rule -> [VarIndex]
+ruleArgs = trRule (\args _ -> args) undefined
+
+-- |get rules body if it's not external
+ruleBody :: Rule -> Expr
+ruleBody = trRule (\_ e -> e) undefined
+
+-- |get rules external declaration
+ruleExtDecl :: Rule -> String
+ruleExtDecl = trRule undefined id
+
+-- Test Operations
+
+-- |is rule external?
+isRuleExternal :: Rule -> Bool
+isRuleExternal = trRule (\_ _ -> False) (\_ -> True)
+
+-- Update Operations
+
+-- |update rule
+updRule :: ([VarIndex] -> [VarIndex]) ->
+ (Expr -> Expr) ->
+ (String -> String) -> Rule -> Rule
+updRule fa fe fs = trRule rule ext
+ where
+ rule args e = Rule (fa args) (fe e)
+ ext s = External (fs s)
+
+-- |update rules arguments
+updRuleArgs :: Update Rule [VarIndex]
+updRuleArgs f = updRule f id id
+
+-- |update rules body
+updRuleBody :: Update Rule Expr
+updRuleBody f = updRule id f id
+
+-- |update rules external declaration
+updRuleExtDecl :: Update Rule String
+updRuleExtDecl f = updRule id id f
+
+-- Auxiliary Functions
+
+-- |get variable names in a functions rule
+allVarsInRule :: Rule -> [VarIndex]
+allVarsInRule = trRule (\args body -> args ++ allVars body) (\_ -> [])
+
+-- |rename all variables in rule
+rnmAllVarsInRule :: Update Rule VarIndex
+rnmAllVarsInRule f = updRule (map f) (rnmAllVars f) id
+
+-- |update all qualified names in rule
+updQNamesInRule :: Update Rule QName
+updQNamesInRule = updRuleBody . updQNames
+
+-- CombType ------------------------------------------------------------------
+
+-- |transform combination type
+trCombType :: a -> (Int -> a) -> a -> (Int -> a) -> CombType -> a
+trCombType fc _ _ _ FuncCall = fc
+trCombType _ fpc _ _ (FuncPartCall n) = fpc n
+trCombType _ _ cc _ ConsCall = cc
+trCombType _ _ _ cpc (ConsPartCall n) = cpc n
+
+-- Test Operations
+
+-- |is type of combination FuncCall?
+isCombTypeFuncCall :: CombType -> Bool
+isCombTypeFuncCall = trCombType True (\_ -> False) False (\_ -> False)
+
+-- |is type of combination FuncPartCall?
+isCombTypeFuncPartCall :: CombType -> Bool
+isCombTypeFuncPartCall = trCombType False (\_ -> True) False (\_ -> False)
+
+-- |is type of combination ConsCall?
+isCombTypeConsCall :: CombType -> Bool
+isCombTypeConsCall = trCombType False (\_ -> False) True (\_ -> False)
+
+-- |is type of combination ConsPartCall?
+isCombTypeConsPartCall :: CombType -> Bool
+isCombTypeConsPartCall = trCombType False (\_ -> False) False (\_ -> True)
+
+-- Expr ----------------------------------------------------------------------
+
+-- Selectors
+
+-- |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
+missingCombArgs = missingArgs . combType
+ where
+ missingArgs :: CombType -> Int
+ missingArgs = trCombType 0 id 0 id
+
+-- |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
+ Var _ -> True
+ _ -> False
+
+-- |is expression a literal expression?
+isLit :: Expr -> Bool
+isLit e = case e of
+ Lit _ -> True
+ _ -> False
+
+-- |is expression combined?
+isComb :: Expr -> Bool
+isComb e = case e of
+ Comb _ _ _ -> True
+ _ -> False
+
+-- |is expression a let expression?
+isLet :: Expr -> Bool
+isLet e = case e of
+ Let _ _ -> True
+ _ -> False
+
+-- |is expression a declaration of free variables?
+isFree :: Expr -> Bool
+isFree e = case e of
+ Free _ _ -> True
+ _ -> False
+
+-- |is expression an or-expression?
+isOr :: Expr -> Bool
+isOr e = case e of
+ Or _ _ -> True
+ _ -> False
+
+-- |is expression a case expression?
+isCase :: Expr -> Bool
+isCase e = case e of
+ Case _ _ _ -> True
+ _ -> False
+
+-- |transform expression
+trExpr :: (VarIndex -> a)
+ -> (Literal -> a)
+ -> (CombType -> QName -> [a] -> a)
+ -> ([(VarIndex, a)] -> a -> a)
+ -> ([VarIndex] -> a -> a)
+ -> (a -> a -> a)
+ -> (CaseType -> a -> [b] -> a)
+ -> (Pattern -> a -> b)
+ -> (a -> TypeExpr -> a)
+ -> Expr
+ -> a
+trExpr var lit comb lt fr oR cas branch typed expr = case expr of
+ Var n -> var n
+ Lit l -> lit l
+ Comb ct name args -> comb ct name (map f args)
+ Let bs e -> lt (map (\(v, x) -> (v, f x)) bs) (f e)
+ Free vs e -> fr vs (f e)
+ Or e1 e2 -> oR (f e1) (f e2)
+ Case ct e bs -> cas ct (f e) (map (\ (Branch p e') -> branch p (f e')) bs)
+ Typed e ty -> typed (f e) ty
+ where
+ f = trExpr var lit comb lt fr oR cas branch typed
+
+-- Update Operations
+
+-- |update all variables in given expression
+updVars :: (VarIndex -> Expr) -> Expr -> Expr
+updVars var = trExpr var Lit Comb Let Free Or Case Branch Typed
+
+-- |update all literals in given expression
+updLiterals :: (Literal -> Expr) -> Expr -> Expr
+updLiterals lit = trExpr Var lit Comb Let Free Or Case Branch Typed
+
+-- |update all combined expressions in given expression
+updCombs :: (CombType -> QName -> [Expr] -> Expr) -> Expr -> Expr
+updCombs comb = trExpr Var Lit comb Let Free Or Case Branch Typed
+
+-- |update all let expressions in given expression
+updLets :: ([(VarIndex,Expr)] -> Expr -> Expr) -> Expr -> Expr
+updLets lt = trExpr Var Lit Comb lt Free Or Case Branch Typed
+
+-- |update all free declarations in given expression
+updFrees :: ([VarIndex] -> Expr -> Expr) -> Expr -> Expr
+updFrees fr = trExpr Var Lit Comb Let fr Or Case Branch Typed
+
+-- |update all or expressions in given expression
+updOrs :: (Expr -> Expr -> Expr) -> Expr -> Expr
+updOrs oR = trExpr Var Lit Comb Let Free oR Case Branch Typed
+
+-- |update all case expressions in given expression
+updCases :: (CaseType -> Expr -> [BranchExpr] -> Expr) -> Expr -> Expr
+updCases cas = trExpr Var Lit Comb Let Free Or cas Branch Typed
+
+-- |update all case branches in given expression
+updBranches :: (Pattern -> Expr -> BranchExpr) -> Expr -> Expr
+updBranches branch = trExpr Var Lit Comb Let Free Or Case branch Typed
+
+-- |update all typed expressions in given expression
+updTypeds :: (Expr -> TypeExpr -> Expr) -> Expr -> Expr
+updTypeds = trExpr Var Lit Comb Let Free Or Case Branch
+
+-- Auxiliary Functions
+
+-- |is expression a call of a function where all arguments are provided?
+isFuncCall :: Expr -> Bool
+isFuncCall e = isComb e && isCombTypeFuncCall (combType e)
+
+-- |is expression a partial function call?
+isFuncPartCall :: Expr -> Bool
+isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e)
+
+-- |is expression a call of a constructor?
+isConsCall :: Expr -> Bool
+isConsCall e = isComb e && isCombTypeConsCall (combType e)
+
+-- |is expression a partial constructor call?
+isConsPartCall :: Expr -> Bool
+isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e)
+
+-- |is expression fully evaluated?
+isGround :: Expr -> Bool
+isGround e
+ = case e of
+ Comb ConsCall _ args -> all isGround args
+ _ -> isLit e
+
+-- |get all variables (also pattern variables) in expression
+allVars :: Expr -> [VarIndex]
+allVars e = trExpr (:) (const id) comb lt fr (.) cas branch const 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'
+ args pat | isConsPattern pat = patArgs pat
+ | otherwise = []
+
+-- |rename all variables (also in patterns) in expression
+rnmAllVars :: Update Expr VarIndex
+rnmAllVars f = trExpr (Var . f) Lit Comb lt (Free . map f) Or Case branch Typed
+ where
+ lt = Let . map (\ (n,e) -> (f n,e))
+ branch = Branch . updPatArgs (map f)
+
+-- |update all qualified names in expression
+updQNames :: Update Expr QName
+updQNames f = trExpr Var Lit comb Let Free Or Case (Branch . updPatCons f) Typed
+ where
+ comb ct name args = Comb ct (f name) args
+
+-- BranchExpr ----------------------------------------------------------------
+
+-- |transform branch expression
+trBranch :: (Pattern -> Expr -> a) -> BranchExpr -> a
+trBranch branch (Branch pat e) = branch pat e
+
+-- Selectors
+
+-- |get pattern from branch expression
+branchPattern :: BranchExpr -> Pattern
+branchPattern = trBranch (\pat _ -> pat)
+
+-- |get expression from branch expression
+branchExpr :: BranchExpr -> Expr
+branchExpr = trBranch (\_ e -> e)
+
+-- Update Operations
+
+-- |update branch expression
+updBranch :: (Pattern -> Pattern) -> (Expr -> Expr) -> BranchExpr -> BranchExpr
+updBranch fp fe = trBranch branch
+ where
+ branch pat e = Branch (fp pat) (fe e)
+
+-- |update pattern of branch expression
+updBranchPattern :: Update BranchExpr Pattern
+updBranchPattern f = updBranch f id
+
+-- |update expression of branch expression
+updBranchExpr :: Update BranchExpr Expr
+updBranchExpr = updBranch id
+
+-- Pattern -------------------------------------------------------------------
+
+-- |transform pattern
+trPattern :: (QName -> [VarIndex] -> a) -> (Literal -> a) -> Pattern -> a
+trPattern pattern _ (Pattern name args) = pattern name args
+trPattern _ lpattern (LPattern l) = lpattern l
+
+-- Selectors
+
+-- |get name from constructor pattern
+patCons :: Pattern -> QName
+patCons = trPattern (\name _ -> name) undefined
+
+-- |get arguments from constructor pattern
+patArgs :: Pattern -> [VarIndex]
+patArgs = trPattern (\_ args -> args) undefined
+
+-- |get literal from literal pattern
+patLiteral :: Pattern -> Literal
+patLiteral = trPattern undefined id
+
+-- Test Operations
+
+-- |is pattern a constructor pattern?
+isConsPattern :: Pattern -> Bool
+isConsPattern = trPattern (\_ _ -> True) (\_ -> False)
+
+-- Update Operations
+
+-- |update pattern
+updPattern :: (QName -> QName) ->
+ ([VarIndex] -> [VarIndex]) ->
+ (Literal -> Literal) -> Pattern -> Pattern
+updPattern fn fa fl = trPattern pattern lpattern
+ where
+ pattern name args = Pattern (fn name) (fa args)
+ lpattern l = LPattern (fl l)
+
+-- |update constructors name of pattern
+updPatCons :: (QName -> QName) -> Pattern -> Pattern
+updPatCons f = updPattern f id id
+
+-- |update arguments of constructor pattern
+updPatArgs :: ([VarIndex] -> [VarIndex]) -> Pattern -> Pattern
+updPatArgs f = updPattern id f id
+
+-- |update literal of pattern
+updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern
+updPatLiteral f = updPattern id id f
+
+-- Auxiliary Functions
+
+-- |build expression from pattern
+patExpr :: Pattern -> Expr
+patExpr = trPattern (\ name -> Comb ConsCall name . map Var) Lit
+
+-- |Is this a public 'Visibility'?
+isPublic :: Visibility -> Bool
+isPublic = (== Public)
diff --git a/src/Curry/FlatCurry/InterfaceEquivalence.hs b/src/Curry/FlatCurry/InterfaceEquivalence.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/FlatCurry/InterfaceEquivalence.hs
@@ -0,0 +1,58 @@
+{- |
+ Module : $Header$
+ Description : Check the equality of two FlatCurry interfaces
+ Copyright : (c) 2006 , Martin Engelke
+ 2011 - 2014, Björn Peemöller
+ 2014 , Jan Tikovsky
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+-}
+
+module Curry.FlatCurry.InterfaceEquivalence (eqInterface) where
+
+import Data.List (deleteFirstsBy)
+
+import Curry.FlatCurry.Type
+
+infix 4 =~=, `eqvSet`
+
+-- |Check whether the interfaces of two FlatCurry programs are equivalent.
+eqInterface :: Prog -> Prog -> Bool
+eqInterface = (=~=)
+
+-- |Type class to express the equivalence of two values
+class Equiv a where
+ (=~=) :: a -> a -> Bool
+
+instance Equiv a => Equiv [a] where
+ [] =~= [] = True
+ (x:xs) =~= (y:ys) = x =~= y && xs =~= ys
+ _ =~= _ = False
+
+instance Equiv Char where (=~=) = (==)
+
+-- |Equivalence of lists independent of the order.
+eqvSet :: Equiv a => [a] -> [a] -> Bool
+xs `eqvSet` ys = null (deleteFirstsBy (=~=) xs ys ++ deleteFirstsBy (=~=) ys xs)
+
+instance Equiv Prog where
+ Prog m1 is1 ts1 fs1 os1 =~= Prog m2 is2 ts2 fs2 os2
+ = m1 == m2 && is1 `eqvSet` is2 && ts1 `eqvSet` ts2
+ && fs1 `eqvSet` fs2 && os1 `eqvSet` os2
+
+instance Equiv TypeDecl where (=~=) = (==)
+
+instance Equiv FuncDecl where
+ Func qn1 ar1 vis1 ty1 r1 =~= Func qn2 ar2 vis2 ty2 r2
+ = qn1 == qn2 && ar1 == ar2 && vis1 == vis2 && ty1 == ty2 && r1 =~= r2
+
+-- TODO: Check why arguments of rules are not checked for equivalence
+instance Equiv Rule where
+ Rule _ _ =~= Rule _ _ = True
+ External _ =~= External _ = True
+ _ =~= _ = False
+
+instance Equiv OpDecl where (=~=) = (==)
diff --git a/src/Curry/FlatCurry/Pretty.hs b/src/Curry/FlatCurry/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/FlatCurry/Pretty.hs
@@ -0,0 +1,220 @@
+{- |
+ Module : $Header$
+ Description : A pretty printer for FlatCurry
+ Copyright : (c) 2015 Björn Peemöller
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module implements a pretty printer for FlatCurry modules.
+-}
+module Curry.FlatCurry.Pretty
+ ( ppProg, ppHeader, ppExports, ppImport, ppTypeDecl, ppTypeExpr
+ , ppFuncDecl, ppExpr, ppLiteral, ppOpDecl
+ ) where
+
+import Data.Char (ord)
+
+import Curry.Base.Pretty
+import Curry.FlatCurry.Type
+
+-- |pretty-print a FlatCurry module
+ppProg :: Prog -> Doc
+ppProg (Prog m is ts fs os) = sepByBlankLine
+ [ ppHeader m ts fs
+ , vcat (map ppImport is)
+ , vcat (map ppOpDecl os)
+ , sepByBlankLine (map ppTypeDecl ts)
+ , sepByBlankLine (map ppFuncDecl fs)
+ ]
+-- |pretty-print the module header
+ppHeader :: String -> [TypeDecl] -> [FuncDecl] -> Doc
+ppHeader m ts fs = sep
+ [text "module" <+> text m, ppExports ts fs, text "where"]
+
+-- |pretty-print the export list
+ppExports :: [TypeDecl] -> [FuncDecl] -> Doc
+ppExports ts fs = parens $ list (map ppTypeExport ts ++ ppFuncExports fs)
+
+-- |pretty-print a type export
+ppTypeExport :: TypeDecl -> Doc
+ppTypeExport (Type qn vis _ cs)
+ | vis == Private = empty
+ | all isPublicCons cs = ppPrefixOp qn <+> text "(..)"
+ | otherwise = ppPrefixOp qn <+> parens (list (ppConsExports cs))
+ where isPublicCons (Cons _ _ v _) = v == Public
+ppTypeExport (TypeSyn qn vis _ _ )
+ | vis == Private = empty
+ | otherwise = ppPrefixOp qn
+
+-- |pretty-print the export list of constructors
+ppConsExports :: [ConsDecl] -> [Doc]
+ppConsExports cs = [ ppPrefixOp qn | Cons qn _ Public _ <- cs]
+
+-- |pretty-print the export list of functions
+ppFuncExports :: [FuncDecl] -> [Doc]
+ppFuncExports fs = [ ppPrefixOp qn | Func qn _ Public _ _ <- fs]
+
+-- |pretty-print an import statement
+ppImport :: String -> Doc
+ppImport m = text "import" <+> text m
+
+-- |pretty-print a operator fixity declaration
+ppOpDecl :: OpDecl -> Doc
+ppOpDecl (Op qn fix n) = ppFixity fix <+> integer n <+> ppInfixOp qn
+
+-- |pretty-print the associativity keyword
+ppFixity :: Fixity -> Doc
+ppFixity InfixOp = text "infix"
+ppFixity InfixlOp = text "infixl"
+ppFixity InfixrOp = text "infixr"
+
+-- |pretty-print a type declaration
+ppTypeDecl :: TypeDecl -> Doc
+ppTypeDecl (Type qn _ vs cs) = text "data" <+> ppQName qn
+ <+> hsep (map ppTVarIndex vs) $+$ ppConsDecls cs
+ppTypeDecl (TypeSyn qn _ vs ty) = text "type" <+> ppQName qn
+ <+> hsep (map ppTVarIndex vs) <+> equals <+> ppTypeExpr 0 ty
+
+-- |pretty-print the constructor declarations
+ppConsDecls :: [ConsDecl] -> Doc
+ppConsDecls cs = indent $ vcat $
+ zipWith (<+>) (equals : repeat (char '|')) (map ppConsDecl cs)
+
+-- |pretty print a single constructor
+ppConsDecl :: ConsDecl -> Doc
+ppConsDecl (Cons qn _ _ tys) = fsep $ ppPrefixOp qn : map (ppTypeExpr 2) tys
+
+-- |pretty-print a type expression
+ppTypeExpr :: Int -> TypeExpr -> Doc
+ppTypeExpr _ (TVar v) = ppTVarIndex v
+ppTypeExpr p (FuncType ty1 ty2) = parenIf (p > 0) $ fsep
+ [ppTypeExpr 1 ty1, rarrow, ppTypeExpr 0 ty2]
+ppTypeExpr p (TCons qn tys) = parenIf (p > 1 && not (null tys)) $ fsep
+ (ppPrefixOp qn : map (ppTypeExpr 2) tys)
+ppTypeExpr p (ForallType vs ty)
+ | null vs = ppTypeExpr p ty
+ | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr 0 ty
+
+-- |pretty-print explicitly quantified type variables
+ppQuantifiedVars :: [TVarIndex] -> Doc
+ppQuantifiedVars vs
+ | null vs = empty
+ | otherwise = text "forall" <+> hsep (map ppTVarIndex vs) <+> char '.'
+
+-- |pretty-print a type variable
+ppTVarIndex :: TVarIndex -> Doc
+ppTVarIndex i = text $ vars !! i
+ where vars = [ if n == 0 then [c] else c : show n
+ | n <- [0 :: Int ..], c <- ['a' .. 'z']
+ ]
+
+-- |pretty-print a function declaration
+ppFuncDecl :: FuncDecl -> Doc
+ppFuncDecl (Func qn _ _ ty r)
+ = hsep [ppPrefixOp qn, text "::", ppTypeExpr 0 ty]
+ $+$ ppPrefixOp qn <+> ppRule r
+
+-- |pretty-print a function rule
+ppRule :: Rule -> Doc
+ppRule (Rule vs e) = fsep (map ppVarIndex vs) <+> equals
+ <+> indent (ppExpr 0 e)
+ppRule (External _) = text "external"
+
+-- |pretty-print an expression
+ppExpr :: Int -> Expr -> Doc
+ppExpr _ (Var v) = ppVarIndex v
+ppExpr _ (Lit l) = ppLiteral l
+ppExpr p (Comb _ qn es) = ppComb p qn es
+ppExpr p (Free vs e)
+ | null vs = ppExpr p e
+ | otherwise = parenIf (p > 0) $ sep
+ [ text "let" <+> list (map ppVarIndex vs)
+ <+> text "free"
+ , text "in" <+> ppExpr 0 e
+ ]
+ppExpr p (Let ds e) = parenIf (p > 0) $ sep
+ [text "let" <+> ppDecls ds, text "in" <+> ppExpr 0 e]
+ppExpr p (Or e1 e2) = parenIf (p > 0)
+ $ ppExpr 1 e1 <+> text "?" <+> ppExpr 1 e2
+ppExpr p (Case ct e bs) = parenIf (p > 0)
+ $ ppCaseType ct <+> ppExpr 0 e <+> text "of"
+ $$ indent (vcat (map ppBranch bs))
+ppExpr p (Typed e ty) = parenIf (p > 0)
+ $ ppExpr 0 e <+> text "::" <+> ppTypeExpr 0 ty
+
+-- |pretty-print a variable
+ppVarIndex :: VarIndex -> Doc
+ppVarIndex i = text $ 'v' : show i
+
+-- |pretty-print a literal
+ppLiteral :: Literal -> Doc
+ppLiteral (Intc i) = integer i
+ppLiteral (Floatc f) = double f
+ppLiteral (Charc c) = text (showEscape c)
+
+-- |Escape character literal
+showEscape :: Char -> String
+showEscape c
+ | o < 10 = "'\\00" ++ show o ++ "'"
+ | o < 32 = "'\\0" ++ show o ++ "'"
+ | o == 127 = "'\\127'"
+ | otherwise = show c
+ where o = ord c
+
+-- |Pretty print a constructor or function call
+ppComb :: Int -> QName -> [Expr] -> Doc
+ppComb _ qn [] = ppPrefixOp qn
+ppComb p qn [e1,e2]
+ | isInfixOp qn = parenIf (p > 0)
+ $ hsep [ppExpr 1 e1, ppInfixOp qn, ppExpr 1 e2]
+ppComb p qn es = parenIf (p > 0)
+ $ hsep (ppPrefixOp qn : map (ppExpr 1) es)
+
+-- |pretty-print a list of declarations
+ppDecls :: [(VarIndex, Expr)] -> Doc
+ppDecls = vcat . map ppDecl
+
+-- |pretty-print a single declaration
+ppDecl :: (VarIndex, Expr) -> Doc
+ppDecl (v, e) = ppVarIndex v <+> equals <+> ppExpr 0 e
+
+-- |pretty-print the type of a case expression
+ppCaseType :: CaseType -> Doc
+ppCaseType Rigid = text "case"
+ppCaseType Flex = text "fcase"
+
+-- |pretty-print a case branch
+ppBranch :: BranchExpr -> Doc
+ppBranch (Branch p e) = ppPattern p <+> rarrow <+> ppExpr 0 e
+
+-- |pretty-print a pattern
+ppPattern :: Pattern -> Doc
+ppPattern (Pattern c [v1,v2])
+ | isInfixOp c = ppVarIndex v1 <+> ppInfixOp c <+> ppVarIndex v2
+ppPattern (Pattern c vs) = fsep (ppPrefixOp c : map ppVarIndex vs)
+ppPattern (LPattern l) = ppLiteral l
+
+-- Names
+
+-- |pretty-print a prefix operator
+ppPrefixOp :: QName -> Doc
+ppPrefixOp qn = parenIf (isInfixOp qn) (ppQName qn)
+
+-- |pretty-print a name in infix manner
+ppInfixOp :: QName -> Doc
+ppInfixOp qn = if isInfixOp qn then ppQName qn else bquotes (ppQName qn)
+
+-- |pretty-print a qualified name
+ppQName :: QName -> Doc
+ppQName (m, i) = text $ m ++ '.' : i
+
+-- |Check whether an operator is an infix operator
+isInfixOp :: QName -> Bool
+isInfixOp = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd
+
+-- Indentation
+indent :: Doc -> Doc
+indent = nest 2
diff --git a/src/Curry/FlatCurry/Type.hs b/src/Curry/FlatCurry/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/FlatCurry/Type.hs
@@ -0,0 +1,319 @@
+{- |
+ Module : $Header$
+ Description : Representation of FlatCurry.
+ Copyright : (c) Michael Hanus 2003
+ Martin Engelke 2004
+ Bernd Brassel 2005
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module contains a definition for representing FlatCurry programs
+ in Haskell in type 'Prog'.
+-}
+
+module Curry.FlatCurry.Type
+ ( -- * Representation of qualified names and (type) variables
+ QName, VarIndex, TVarIndex
+ -- * Data types for FlatCurry
+ , Visibility (..), Prog (..), TypeDecl (..), TypeExpr (..)
+ , ConsDecl (..), OpDecl (..), Fixity (..)
+ , FuncDecl (..), Rule (..), Expr (..), Literal (..)
+ , CombType (..), CaseType (..), BranchExpr (..), Pattern (..)
+ ) where
+
+-- ---------------------------------------------------------------------------
+-- Qualified names
+-- ---------------------------------------------------------------------------
+
+-- |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)
+
+-- ---------------------------------------------------------------------------
+-- Variable representation
+-- ---------------------------------------------------------------------------
+
+-- |Representation of variables.
+type VarIndex = Int
+
+-- ---------------------------------------------------------------------------
+-- FlatCurry representation
+-- ---------------------------------------------------------------------------
+
+-- |Visibility of various entities.
+data Visibility
+ = Public -- ^ public (exported) entity
+ | Private -- ^ private entity
+ deriving (Eq, Read, Show)
+
+-- |A FlatCurry module.
+--
+-- A value of this data type has the form
+--
+-- @Prog modname imports typedecls functions opdecls@
+--
+-- where
+--
+-- [@modname@] Name of this module
+-- [@imports@] List of modules names that are imported
+-- [@typedecls@] Type declarations
+-- [@funcdecls@] Function declarations
+-- [@ opdecls@] Operator declarations
+data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]
+ deriving (Eq, Read, Show)
+
+-- |Declaration of algebraic data type or type synonym.
+--
+-- A data type declaration of the form
+--
+-- @data t x1...xn = ...| c t1....tkc |...@
+--
+-- is represented by the FlatCurry term
+--
+-- @Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...]@
+--
+-- where each @ij@ is the index of the type variable @xj@
+--
+-- /Note:/ The type variable indices are unique inside each type declaration
+-- and are usually numbered from 0.
+--
+-- Thus, a data type declaration consists of the name of the data type,
+-- a list of type parameters and a list of constructor declarations.
+data TypeDecl
+ = Type QName Visibility [TVarIndex] [ConsDecl]
+ | TypeSyn QName Visibility [TVarIndex] TypeExpr
+ deriving (Eq, Read, Show)
+
+-- |Type variables are represented by @(TVar i)@ where @i@ is a
+-- type variable index.
+type TVarIndex = Int
+
+-- |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 (Eq, Read, Show)
+
+-- |Type expressions.
+--
+-- A type expression is either a type variable, a function type,
+-- or a type constructor application.
+--
+-- /Note:/ the names of the predefined type constructors are
+-- @Int@, @Float@, @Bool@, @Char@, @IO@, @Success@,
+-- @()@ (unit type), @(,...,)@ (tuple types), @[]@ (list type)
+data TypeExpr
+ = TVar TVarIndex -- ^ type variable
+ | FuncType TypeExpr TypeExpr -- ^ function type @t1 -> t2@
+ | TCons QName [TypeExpr] -- ^ type constructor application
+ | ForallType [TVarIndex] TypeExpr -- ^ forall type
+ deriving (Eq, Read, Show)
+
+-- |Operator declarations.
+--
+-- An operator declaration @fix p n@ in Curry corresponds to the
+-- FlatCurry term @(Op n fix p)@.
+--
+-- /Note:/ the constructor definition of 'Op' differs from the original
+-- PAKCS definition using Haskell type 'Integer' instead of 'Int'
+-- for representing the precedence.
+data OpDecl = Op QName Fixity Integer
+ deriving (Eq, Read, Show)
+
+-- |Fixity of an operator.
+data Fixity
+ = InfixOp -- ^ non-associative infix operator
+ | InfixlOp -- ^ left-associative infix operator
+ | InfixrOp -- ^ right-associative infix operator
+ deriving (Eq, Read, Show)
+
+-- |Data type for representing function declarations.
+--
+-- A function declaration in FlatCurry is a term of the form
+--
+-- @(Func name arity type (Rule [i_1,...,i_arity] e))@
+--
+-- and represents the function "name" with definition
+--
+-- @
+-- name :: type
+-- name x_1...x_arity = e
+-- @
+--
+-- where each @i_j@ is the index of the variable @x_j@
+--
+-- /Note:/ The variable indices are unique inside each function declaration
+-- and are usually numbered from 0.
+--
+-- External functions are represented as
+--
+-- @Func name arity type (External s)@
+--
+-- where s is the external name associated to this function.
+--
+-- Thus, a function declaration consists of the name, arity, type, and rule.
+data FuncDecl = Func QName Int Visibility TypeExpr Rule
+ deriving (Eq, Read, Show)
+
+-- |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 (Eq, Read, Show)
+
+-- |Data type for representing expressions.
+--
+-- Remarks:
+--
+-- 1.if-then-else expressions are represented as function calls:
+--
+-- @(if e1 then e2 else e3)@
+--
+-- is represented as
+--
+-- @(Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])@
+--
+-- 2.Higher order applications are represented as calls to the (external)
+-- function @apply@. For instance, the rule
+--
+-- @app f x = f x@
+--
+-- is represented as
+--
+-- @(Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))@
+--
+-- 3.A conditional rule is represented as a call to an external function
+-- @cond@ where the first argument is the condition (a constraint).
+--
+-- For instance, the rule
+--
+-- @equal2 x | x=:=2 = success@
+--
+-- is represented as
+--
+-- @
+-- (Rule [0]
+-- (Comb FuncCall ("Prelude","cond")
+-- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],
+-- Comb FuncCall ("Prelude","success") []]))
+-- @
+--
+-- 4.Functions with evaluation annotation @choice@ are represented
+-- by a rule whose right-hand side is enclosed in a call to the
+-- external function @Prelude.commit@.
+-- Furthermore, all rules of the original definition must be
+-- represented by conditional expressions (i.e., (cond [c,e]))
+-- after pattern matching.
+--
+-- Example:
+--
+-- @
+-- m eval choice
+-- m [] y = y
+-- m x [] = x
+-- @
+--
+-- is translated into (note that the conditional branches can be also
+-- wrapped with Free declarations in general):
+--
+-- @
+-- Rule [0,1]
+-- (Comb FuncCall ("Prelude","commit")
+-- [Or (Case Rigid (Var 0)
+-- [(Pattern ("Prelude","[]") []
+-- (Comb FuncCall ("Prelude","cond")
+-- [Comb FuncCall ("Prelude","success") [],
+-- Var 1]))] )
+-- (Case Rigid (Var 1)
+-- [(Pattern ("Prelude","[]") []
+-- (Comb FuncCall ("Prelude","cond")
+-- [Comb FuncCall ("Prelude","success") [],
+-- Var 0]))] )])
+-- @
+--
+-- Operational meaning of @(Prelude.commit e)@:
+-- evaluate @e@ with local search spaces and commit to the first
+-- @(Comb FuncCall ("Prelude","cond") [c,ge])@ in @e@ whose constraint @c@
+-- is satisfied
+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 for an expression
+ | Free [VarIndex] Expr
+ -- |Local let-declarations
+ | Let [(VarIndex, Expr)] Expr
+ -- |Disjunction of two expressions
+ -- (resulting from overlapping left-hand sides)
+ | Or Expr Expr
+ -- |case expression
+ | Case CaseType Expr [BranchExpr]
+ -- |typed expression
+ | Typed Expr TypeExpr
+ deriving (Eq, Read, Show)
+
+-- |Data type for representing literals.
+--
+-- A literal 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 (Eq, Read, Show)
+
+-- |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 (Eq, Read, Show)
+
+-- |Classification of case expressions, either flexible or rigid.
+data CaseType
+ = Rigid
+ | Flex
+ deriving (Eq, Read, Show)
+
+-- |Branches in a case expression.
+--
+-- Branches @(m.c x1...xn) -> e@ in case expressions are represented as
+--
+-- @(Branch (Pattern (m,c) [i1,...,in]) e)@
+--
+-- where each @ij@ is the index of the pattern variable @xj@, or as
+--
+-- @(Branch (LPattern (Intc i)) e)@
+--
+-- for integers as branch patterns (similarly for other literals
+-- like float or character constants).
+data BranchExpr = Branch Pattern Expr
+ deriving (Eq, Read, Show)
+
+-- |Patterns in case expressions.
+data Pattern
+ = Pattern QName [VarIndex]
+ | LPattern Literal
+ deriving (Eq, Read, Show)
diff --git a/src/Curry/Syntax.hs b/src/Curry/Syntax.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Syntax.hs
@@ -0,0 +1,80 @@
+{- |
+ Module : $Header$
+ Description : Interface for reading and manipulating Curry source code
+ Copyright : (c) 2009 Holger Siegel
+ 2011 - 2013 Björn Peemöller
+ 2016 Finn Teegen
+ 2016 Jan Tikovsky
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+-}
+module Curry.Syntax
+ ( module Curry.Syntax.Type
+ , module Curry.Syntax.Utils
+ , L.Token (..), L.Category (..), L.Attributes (..)
+ , unlit, unlitLexSource, unlitParseHeader, unlitParsePragmas, unlitParseModule
+ , lexSource, parseInterface, parseHeader, parsePragmas, parseModule, parseGoal
+ , ppModule, ppInterface, ppIDecl
+ , showModule
+ ) where
+
+import Curry.Base.Monad (CYM)
+import Curry.Base.Span (Span)
+import qualified Curry.Files.Unlit as U (unlit)
+
+import qualified Curry.Syntax.Lexer as L
+import qualified Curry.Syntax.Parser as P
+import Curry.Syntax.Pretty (ppModule, ppInterface, ppIDecl)
+import Curry.Syntax.ShowModule (showModule)
+import Curry.Syntax.Type
+import Curry.Syntax.Utils
+
+-- |Unliterate a LiterateCurry file, identity on normal Curry file.
+unlit :: FilePath -> String -> CYM String
+unlit = U.unlit
+
+-- |Unliterate and return the result of a lexical analysis of the source
+-- program @src@.
+-- The result is a list of tuples consisting of a 'Span' and a 'Token'.
+unlitLexSource :: FilePath -> String -> CYM [(Span, L.Token)]
+unlitLexSource fn src = U.unlit fn src >>= L.lexSource fn
+
+-- |Unliterate and parse only pragmas of a Curry 'Module'
+unlitParsePragmas :: FilePath -> String -> CYM (Module ())
+unlitParsePragmas fn src = U.unlit fn src >>= P.parsePragmas fn
+
+-- |Unliterate and parse a Curry 'Module' header
+unlitParseHeader :: FilePath -> String -> CYM (Module ())
+unlitParseHeader fn src = U.unlit fn src >>= P.parseHeader fn
+
+-- |Unliterate and parse a Curry 'Module'
+unlitParseModule :: FilePath -> String -> CYM (Module ())
+unlitParseModule fn src = U.unlit fn src >>= P.parseSource fn
+
+-- |Return the result of a lexical analysis of the source program @src@.
+-- The result is a list of tuples consisting of a 'Span' and a 'Token'.
+lexSource :: FilePath -> String -> CYM [(Span, L.Token)]
+lexSource = L.lexSource
+
+-- |Parse a Curry 'Interface'
+parseInterface :: FilePath -> String -> CYM Interface
+parseInterface = P.parseInterface
+
+-- |Parse only pragmas of a Curry 'Module'
+parsePragmas :: FilePath -> String -> CYM (Module ())
+parsePragmas = P.parsePragmas
+
+-- |Parse a Curry 'Module' header
+parseHeader :: FilePath -> String -> CYM (Module ())
+parseHeader = P.parseHeader
+
+-- |Parse a Curry 'Module'
+parseModule :: FilePath -> String -> CYM (Module ())
+parseModule = P.parseSource
+
+-- |Parse a 'Goal', i.e. an expression with (optional) local declarations
+parseGoal :: String -> CYM (Goal ())
+parseGoal = P.parseGoal
diff --git a/src/Curry/Syntax/Extension.hs b/src/Curry/Syntax/Extension.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Syntax/Extension.hs
@@ -0,0 +1,69 @@
+{- |
+ Module : $Header$
+ Description : Curry language extensions
+ Copyright : (c) 2013 - 2014 Björn Peemöller
+ 2016 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module provides the data structures for Curry language extensions.
+-}
+
+module Curry.Syntax.Extension
+ ( -- * Extensions
+ Extension (..), KnownExtension (..), classifyExtension, kielExtensions
+ -- * Tools
+ , Tool (..), classifyTool
+ ) where
+
+import Data.Char (toUpper)
+
+import Curry.Base.Ident (Ident (..))
+import Curry.Base.Position
+
+-- |Specified language extensions, either known or unknown.
+data Extension
+ = KnownExtension Position KnownExtension -- ^ a known extension
+ | UnknownExtension Position String -- ^ an unknown extension
+ deriving (Eq, Read, Show)
+
+instance HasPosition Extension where
+ getPosition (KnownExtension p _) = p
+ getPosition (UnknownExtension p _) = p
+
+ setPosition p (KnownExtension _ e) = KnownExtension p e
+ setPosition p (UnknownExtension _ e) = UnknownExtension p e
+
+-- |Known language extensions of Curry.
+data KnownExtension
+ = AnonFreeVars -- ^ anonymous free variables
+ | CPP -- ^ C preprocessor
+ | ExistentialQuantification -- ^ existential quantification
+ | FunctionalPatterns -- ^ functional patterns
+ | NegativeLiterals -- ^ negative literals
+ | NoImplicitPrelude -- ^ no implicit import of the prelude
+ deriving (Eq, Read, Show, Enum, Bounded)
+
+-- |Classifies a 'String' as an 'Extension'
+classifyExtension :: Ident -> Extension
+classifyExtension i = case reads extName of
+ [(e, "")] -> KnownExtension (idPosition i) e
+ _ -> UnknownExtension (idPosition i) extName
+ where extName = idName i
+
+-- |'Extension's available by Kiel's Curry compilers.
+kielExtensions :: [KnownExtension]
+kielExtensions = [AnonFreeVars, FunctionalPatterns]
+
+-- |Different Curry tools which may accept compiler options.
+data Tool = KICS2 | PAKCS | CYMAKE | FRONTEND | UnknownTool String
+ deriving (Eq, Read, Show)
+
+-- |Classifies a 'String' as a 'Tool'
+classifyTool :: String -> Tool
+classifyTool str = case reads (map toUpper str) of
+ [(t, "")] -> t
+ _ -> UnknownTool str
diff --git a/src/Curry/Syntax/InterfaceEquivalence.hs b/src/Curry/Syntax/InterfaceEquivalence.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Syntax/InterfaceEquivalence.hs
@@ -0,0 +1,209 @@
+{- |
+ Module : $Header$
+ Description : Comparison of Curry Interfaces
+ Copyright : (c) 2000 - 2007 Wolfgang Lux
+ 2014 - 2015 Björn Peemöller
+ 2014 Jan Tikovsky
+ 2016 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ If a module is recompiled, the compiler has to check whether the
+ interface file must be updated. This must be done if any exported
+ entity has been changed, or an export was removed or added. The
+ function 'intfEquiv' checks whether two interfaces are
+ equivalent, i.e., whether they define the same entities.
+-}
+module Curry.Syntax.InterfaceEquivalence (fixInterface, intfEquiv) where
+
+import Data.List (deleteFirstsBy, sort)
+import qualified Data.Set as Set
+
+import Curry.Base.Ident
+import Curry.Syntax
+
+infix 4 =~=, `eqvSet`
+
+-- |Are two given interfaces equivalent?
+intfEquiv :: Interface -> Interface -> Bool
+intfEquiv = (=~=)
+
+-- |Type class to express the equivalence of two values
+class Equiv a where
+ (=~=) :: a -> a -> Bool
+
+instance Equiv a => Equiv (Maybe a) where
+ Nothing =~= Nothing = True
+ Nothing =~= Just _ = False
+ Just _ =~= Nothing = False
+ Just x =~= Just y = x =~= y
+
+instance Equiv a => Equiv [a] where
+ [] =~= [] = True
+ (x:xs) =~= (y:ys) = x =~= y && xs =~= ys
+ _ =~= _ = False
+
+eqvList, eqvSet :: Equiv a => [a] -> [a] -> Bool
+xs `eqvList` ys = length xs == length ys && and (zipWith (=~=) xs ys)
+xs `eqvSet` ys = null (deleteFirstsBy (=~=) xs ys ++ deleteFirstsBy (=~=) ys xs)
+
+instance Equiv Interface where
+ Interface m1 is1 ds1 =~= Interface m2 is2 ds2
+ = m1 == m2 && is1 `eqvSet` is2 && ds1 `eqvSet` ds2
+
+instance Equiv IImportDecl where
+ IImportDecl _ m1 =~= IImportDecl _ m2 = m1 == m2
+
+-- Since the kind of type constructors or type classes can be omitted
+-- in the interface when the kind is simple, i.e., it is either * or of
+-- the form * -> ... -> *, a non given kind has to be considered equivalent
+-- to a given one if the latter is simple.
+
+eqvKindExpr :: Maybe KindExpr -> Maybe KindExpr -> Bool
+Nothing `eqvKindExpr` (Just k) = isSimpleKindExpr k
+(Just k) `eqvKindExpr` Nothing = isSimpleKindExpr k
+k1 `eqvKindExpr` k2 = k1 == k2
+
+isSimpleKindExpr :: KindExpr -> Bool
+isSimpleKindExpr Star = True
+isSimpleKindExpr (ArrowKind Star k) = isSimpleKindExpr k
+isSimpleKindExpr _ = False
+
+
+instance Equiv IDecl where
+ IInfixDecl _ fix1 p1 op1 =~= IInfixDecl _ fix2 p2 op2
+ = fix1 == fix2 && p1 == p2 && op1 == op2
+ HidingDataDecl _ tc1 k1 tvs1 =~= HidingDataDecl _ tc2 k2 tvs2
+ = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2
+ IDataDecl _ tc1 k1 tvs1 cs1 hs1 =~= IDataDecl _ tc2 k2 tvs2 cs2 hs2
+ = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && cs1 =~= cs2 &&
+ hs1 `eqvSet` hs2
+ INewtypeDecl _ tc1 k1 tvs1 nc1 hs1 =~= INewtypeDecl _ tc2 k2 tvs2 nc2 hs2
+ = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && nc1 =~= nc2 &&
+ hs1 `eqvSet` hs2
+ ITypeDecl _ tc1 k1 tvs1 ty1 =~= ITypeDecl _ tc2 k2 tvs2 ty2
+ = tc1 == tc2 && k1 `eqvKindExpr` k2 && tvs1 == tvs2 && ty1 == ty2
+ IFunctionDecl _ f1 cm1 n1 qty1 =~= IFunctionDecl _ f2 cm2 n2 qty2
+ = f1 == f2 && cm1 == cm2 && n1 == n2 && qty1 == qty2
+ HidingClassDecl _ cx1 cls1 k1 _ =~= HidingClassDecl _ cx2 cls2 k2 _
+ = cx1 == cx2 && cls1 == cls2 && k1 `eqvKindExpr` k2
+ IClassDecl _ cx1 cls1 k1 _ ms1 hs1 =~= IClassDecl _ cx2 cls2 k2 _ ms2 hs2
+ = cx1 == cx2 && cls1 == cls2 && k1 `eqvKindExpr` k2 &&
+ ms1 `eqvList` ms2 && hs1 `eqvSet` hs2
+ IInstanceDecl _ cx1 cls1 ty1 is1 m1 =~= IInstanceDecl _ cx2 cls2 ty2 is2 m2
+ = cx1 == cx2 && cls1 == cls2 && ty1 == ty2 && sort is1 == sort is2 &&
+ m1 == m2
+ _ =~= _ = False
+
+instance Equiv ConstrDecl where
+ ConstrDecl _ evs1 cx1 c1 tys1 =~= ConstrDecl _ evs2 cx2 c2 tys2
+ = c1 == c2 && evs1 == evs2 && cx1 == cx2 && tys1 == tys2
+ ConOpDecl _ evs1 cx1 ty11 op1 ty12 =~= ConOpDecl _ evs2 cx2 ty21 op2 ty22
+ = op1 == op2 && evs1 == evs2 && cx1 == cx2 && ty11 == ty21 && ty12 == ty22
+ RecordDecl _ evs1 cx1 c1 fs1 =~= RecordDecl _ evs2 cx2 c2 fs2
+ = c1 == c2 && evs1 == evs2 && cx1 == cx2 && fs1 `eqvList` fs2
+ _ =~= _ = False
+
+instance Equiv FieldDecl where
+ FieldDecl _ ls1 ty1 =~= FieldDecl _ ls2 ty2 = ls1 == ls2 && ty1 == ty2
+
+instance Equiv NewConstrDecl where
+ NewConstrDecl _ c1 ty1 =~= NewConstrDecl _ c2 ty2 = c1 == c2 && ty1 == ty2
+ NewRecordDecl _ c1 fld1 =~= NewRecordDecl _ c2 fld2 = c1 == c2 && fld1 == fld2
+ _ =~= _ = False
+
+instance Equiv IMethodDecl where
+ IMethodDecl _ f1 a1 qty1 =~= IMethodDecl _ f2 a2 qty2
+ = f1 == f2 && a1 == a2 && qty1 == qty2
+
+instance Equiv Ident where
+ (=~=) = (==)
+
+-- If we check for a change in the interface, we do not need to check the
+-- interface declarations, but still must disambiguate (nullary) type
+-- constructors and type variables in type expressions. This is handled
+-- by function 'fixInterface' and the associated type class 'FixInterface'.
+
+-- |Disambiguate nullary type constructors and type variables.
+fixInterface :: Interface -> Interface
+fixInterface (Interface m is ds) = Interface m is $
+ fix (Set.fromList (typeConstructors ds)) ds
+
+class FixInterface a where
+ fix :: Set.Set Ident -> a -> a
+
+instance FixInterface a => FixInterface (Maybe a) where
+ fix tcs = fmap (fix tcs)
+
+instance FixInterface a => FixInterface [a] where
+ fix tcs = map (fix tcs)
+
+instance FixInterface IDecl where
+ fix tcs (IDataDecl p tc k vs cs hs) =
+ IDataDecl p tc k vs (fix tcs cs) hs
+ fix tcs (INewtypeDecl p tc k vs nc hs) =
+ INewtypeDecl p tc k vs (fix tcs nc) hs
+ fix tcs (ITypeDecl p tc k vs ty) =
+ ITypeDecl p tc k vs (fix tcs ty)
+ fix tcs (IFunctionDecl p f cm n qty) =
+ IFunctionDecl p f cm n (fix tcs qty)
+ fix tcs (HidingClassDecl p cx cls k tv) =
+ HidingClassDecl p (fix tcs cx) cls k tv
+ fix tcs (IClassDecl p cx cls k tv ms hs) =
+ IClassDecl p (fix tcs cx) cls k tv (fix tcs ms) hs
+ fix tcs (IInstanceDecl p cx cls inst is m) =
+ IInstanceDecl p (fix tcs cx) cls (fix tcs inst) is m
+ fix _ d = d
+
+instance FixInterface ConstrDecl where
+ fix tcs (ConstrDecl p evs cx c tys) = ConstrDecl p evs cx c (fix tcs tys)
+ fix tcs (ConOpDecl p evs cx ty1 op ty2) = ConOpDecl p evs cx (fix tcs ty1)
+ op (fix tcs ty2)
+ fix tcs (RecordDecl p evs cx c fs) = RecordDecl p evs cx c (fix tcs fs)
+
+instance FixInterface FieldDecl where
+ fix tcs (FieldDecl p ls ty) = FieldDecl p ls (fix tcs ty)
+
+instance FixInterface NewConstrDecl where
+ fix tcs (NewConstrDecl p c ty ) = NewConstrDecl p c (fix tcs ty)
+ fix tcs (NewRecordDecl p c (i,ty)) = NewRecordDecl p c (i, fix tcs ty)
+
+instance FixInterface IMethodDecl where
+ fix tcs (IMethodDecl p f a qty) = IMethodDecl p f a (fix tcs qty)
+
+instance FixInterface QualTypeExpr where
+ fix tcs (QualTypeExpr cx ty) = QualTypeExpr (fix tcs cx) (fix tcs ty)
+
+instance FixInterface Constraint where
+ fix tcs (Constraint qcls ty) = Constraint qcls (fix tcs ty)
+
+instance FixInterface TypeExpr where
+ fix tcs (ConstructorType tc)
+ | not (isQualified tc) && not (isPrimTypeId tc) && tc' `Set.notMember` tcs
+ = VariableType tc'
+ | otherwise = ConstructorType tc
+ where tc' = unqualify tc
+ fix tcs (ApplyType ty1 ty2) = ApplyType (fix tcs ty1) (fix tcs ty2)
+ fix tcs (VariableType tv)
+ | tv `Set.member` tcs = ConstructorType (qualify tv)
+ | otherwise = VariableType tv
+ fix tcs (TupleType tys) = TupleType (fix tcs tys)
+ fix tcs (ListType ty) = ListType (fix tcs ty)
+ fix tcs (ArrowType ty1 ty2) = ArrowType (fix tcs ty1) (fix tcs ty2)
+ fix tcs (ParenType ty) = ParenType (fix tcs ty)
+ fix tcs (ForallType vs ty) = ForallType vs (fix tcs ty)
+
+typeConstructors :: [IDecl] -> [Ident]
+typeConstructors ds = [tc | (QualIdent Nothing tc) <- foldr tyCons [] ds]
+ where tyCons (IInfixDecl _ _ _ _) tcs = tcs
+ tyCons (HidingDataDecl _ tc _ _) tcs = tc : tcs
+ tyCons (IDataDecl _ tc _ _ _ _) tcs = tc : tcs
+ tyCons (INewtypeDecl _ tc _ _ _ _) tcs = tc : tcs
+ tyCons (ITypeDecl _ tc _ _ _) tcs = tc : tcs
+ tyCons (IFunctionDecl _ _ _ _ _) tcs = tcs
+ tyCons (HidingClassDecl _ _ _ _ _) tcs = tcs
+ tyCons (IClassDecl _ _ _ _ _ _ _) tcs = tcs
+ tyCons (IInstanceDecl _ _ _ _ _ _) tcs = tcs
diff --git a/src/Curry/Syntax/Lexer.hs b/src/Curry/Syntax/Lexer.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Syntax/Lexer.hs
@@ -0,0 +1,877 @@
+{- |
+ Module : $Header$
+ Description : A lexer for Curry
+ Copyright : (c) 1999 - 2004 Wolfgang Lux
+ 2005 Martin Engelke
+ 2011 - 2013 Björn Peemöller
+ 2016 Finn Teegen
+ 2016 Jan Tikovsky
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+-}
+module Curry.Syntax.Lexer
+ ( -- * Data types for tokens
+ Token (..), Category (..), Attributes (..)
+
+ -- * lexing functions
+ , lexSource, lexer, fullLexer
+ ) where
+
+import Prelude hiding (fail)
+import Data.Char
+ ( chr, ord, isAlpha, isAlphaNum, isDigit, isHexDigit, isOctDigit
+ , isSpace, isUpper, toLower
+ )
+import Data.List (intercalate)
+import qualified Data.Map as Map
+ (Map, union, lookup, findWithDefault, fromList)
+
+import Curry.Base.LexComb
+import Curry.Base.Position
+import Curry.Base.Span
+
+-- ---------------------------------------------------------------------------
+-- Tokens. Note that the equality and ordering instances of Token disregard
+-- the attributes, as so that the parser decides about accepting a token
+-- just by its category.
+-- ---------------------------------------------------------------------------
+
+-- |Data type for curry lexer tokens
+data Token = Token Category Attributes
+
+instance Eq Token where
+ Token c1 _ == Token c2 _ = c1 == c2
+
+instance Ord Token where
+ Token c1 _ `compare` Token c2 _ = c1 `compare` c2
+
+instance Symbol Token where
+ isEOF (Token c _) = c == EOF
+
+ dist _ (Token VSemicolon _) = (0, 0)
+ dist _ (Token VRightBrace _) = (0, 0)
+ dist _ (Token EOF _) = (0, 0)
+ dist _ (Token DotDot _) = (0, 1)
+ dist _ (Token DoubleColon _) = (0, 1)
+ dist _ (Token LeftArrow _) = (0, 1)
+ dist _ (Token RightArrow _) = (0, 1)
+ dist _ (Token DoubleArrow _) = (0, 1)
+ dist _ (Token KW_do _) = (0, 1)
+ dist _ (Token KW_if _) = (0, 1)
+ dist _ (Token KW_in _) = (0, 1)
+ dist _ (Token KW_of _) = (0, 1)
+ dist _ (Token Id_as _) = (0, 1)
+ dist _ (Token KW_let _) = (0, 2)
+ dist _ (Token PragmaEnd _) = (0, 2)
+ dist _ (Token KW_case _) = (0, 3)
+ dist _ (Token KW_class _) = (0, 4)
+ dist _ (Token KW_data _) = (0, 3)
+ dist _ (Token KW_default _) = (0, 6)
+ dist _ (Token KW_deriving _) = (0, 7)
+ dist _ (Token KW_else _) = (0, 3)
+ dist _ (Token KW_free _) = (0, 3)
+ dist _ (Token KW_then _) = (0, 3)
+ dist _ (Token KW_type _) = (0, 3)
+ dist _ (Token KW_fcase _) = (0, 4)
+ dist _ (Token KW_infix _) = (0, 4)
+ dist _ (Token KW_instance _) = (0, 7)
+ dist _ (Token KW_where _) = (0, 4)
+ dist _ (Token Id_ccall _) = (0, 4)
+ dist _ (Token KW_import _) = (0, 5)
+ dist _ (Token KW_infixl _) = (0, 5)
+ dist _ (Token KW_infixr _) = (0, 5)
+ dist _ (Token KW_module _) = (0, 5)
+ dist _ (Token Id_forall _) = (0, 5)
+ dist _ (Token Id_hiding _) = (0, 5)
+ dist _ (Token KW_newtype _) = (0, 6)
+ dist _ (Token KW_external _) = (0, 7)
+ dist _ (Token Id_interface _) = (0, 8)
+ dist _ (Token Id_primitive _) = (0, 8)
+ dist _ (Token Id_qualified _) = (0, 8)
+ dist _ (Token PragmaHiding _) = (0, 9)
+ dist _ (Token PragmaLanguage _) = (0, 11)
+ dist _ (Token Id a) = distAttr False a
+ dist _ (Token QId a) = distAttr False a
+ dist _ (Token Sym a) = distAttr False a
+ dist _ (Token QSym a) = distAttr False a
+ dist _ (Token IntTok a) = distAttr False a
+ dist _ (Token FloatTok a) = distAttr False a
+ dist _ (Token CharTok a) = distAttr False a
+ dist c (Token StringTok a) = updColDist c (distAttr False a)
+ dist _ (Token LineComment a) = distAttr True a
+ dist c (Token NestedComment a) = updColDist c (distAttr True a)
+ dist _ (Token PragmaOptions a) = let (ld, cd) = distAttr False a
+ in (ld, cd + 11)
+ dist _ _ = (0, 0)
+
+-- TODO: Comment
+updColDist :: Int -> Distance -> Distance
+updColDist c (ld, cd) = (ld, if ld == 0 then cd else cd - c + 1)
+
+distAttr :: Bool -> Attributes -> Distance
+distAttr isComment attr = case attr of
+ NoAttributes -> (0, 0)
+ CharAttributes _ orig -> (0, length orig + 1)
+ IntAttributes _ orig -> (0, length orig - 1)
+ FloatAttributes _ orig -> (0, length orig - 1)
+ StringAttributes _ orig
+ -- comment without surrounding quotes
+ | isComment -> (ld, cd)
+ -- string with one ending double quote or two surrounding double quotes
+ -- (column distance + 1 / + 2)
+ | '\n' `elem` orig -> (ld, cd + 1)
+ | otherwise -> (ld, cd + 2)
+ where ld = length (filter (== '\n') orig)
+ cd = length (takeWhile (/= '\n') (reverse orig)) - 1
+ IdentAttributes mid i -> (0, length (intercalate "." (mid ++ [i])) - 1)
+ OptionsAttributes mt args -> case mt of
+ Nothing -> (0, distArgs + 1)
+ Just t -> (0, length t + distArgs + 2)
+ where distArgs = length args
+
+-- |Category of curry tokens
+data Category
+ -- literals
+ = CharTok
+ | IntTok
+ | FloatTok
+ | StringTok
+
+ -- identifiers
+ | Id -- identifier
+ | QId -- qualified identifier
+ | Sym -- symbol
+ | QSym -- qualified symbol
+
+ -- punctuation symbols
+ | LeftParen -- (
+ | RightParen -- )
+ | Semicolon -- ;
+ | LeftBrace -- {
+ | RightBrace -- }
+ | LeftBracket -- [
+ | RightBracket -- ]
+ | Comma -- ,
+ | Underscore -- _
+ | Backquote -- `
+
+ -- layout
+ | VSemicolon -- virtual ;
+ | VRightBrace -- virtual }
+
+ -- reserved keywords
+ | KW_case
+ | KW_class
+ | KW_data
+ | KW_default
+ | KW_deriving
+ | KW_do
+ | KW_else
+ | KW_external
+ | KW_fcase
+ | KW_free
+ | KW_if
+ | KW_import
+ | KW_in
+ | KW_infix
+ | KW_infixl
+ | KW_infixr
+ | KW_instance
+ | KW_let
+ | KW_module
+ | KW_newtype
+ | KW_of
+ | KW_then
+ | KW_type
+ | KW_where
+
+ -- reserved operators
+ | At -- @
+ | Colon -- :
+ | DotDot -- ..
+ | DoubleColon -- ::
+ | Equals -- =
+ | Backslash -- \
+ | Bar -- |
+ | LeftArrow -- <-
+ | RightArrow -- ->
+ | Tilde -- ~
+ | DoubleArrow -- =>
+
+ -- special identifiers
+ | Id_as
+ | Id_ccall
+ | Id_forall
+ | Id_hiding
+ | Id_interface
+ | Id_primitive
+ | Id_qualified
+
+ -- special operators
+ | SymDot -- .
+ | SymMinus -- -
+
+ -- special symbols
+ | SymStar -- kind star (*)
+
+ -- pragmas
+ | PragmaLanguage -- {-# LANGUAGE
+ | PragmaOptions -- {-# OPTIONS
+ | PragmaHiding -- {-# HIDING
+ | PragmaMethod -- {-# METHOD
+ | PragmaModule -- {-# MODULE
+ | PragmaEnd -- #-}
+
+
+ -- comments (only for full lexer) inserted by men & bbr
+ | LineComment
+ | NestedComment
+
+ -- end-of-file token
+ | EOF
+ deriving (Eq, Ord)
+
+-- There are different kinds of attributes associated with the tokens.
+-- Most attributes simply save the string corresponding to the token.
+-- However, for qualified identifiers, we also record the list of module
+-- qualifiers. The values corresponding to a literal token are properly
+-- converted already. To simplify the creation and extraction of
+-- attribute values, we make use of records.
+
+-- |Attributes associated to a token
+data Attributes
+ = NoAttributes
+ | CharAttributes { cval :: Char , original :: String }
+ | IntAttributes { ival :: Integer , original :: String }
+ | FloatAttributes { fval :: Double , original :: String }
+ | StringAttributes { sval :: String , original :: String }
+ | IdentAttributes { modulVal :: [String] , sval :: String }
+ | OptionsAttributes { toolVal :: Maybe String, toolArgs :: String }
+
+instance Show Attributes where
+ showsPrec _ NoAttributes = showChar '_'
+ showsPrec _ (CharAttributes cv _) = shows cv
+ showsPrec _ (IntAttributes iv _) = shows iv
+ showsPrec _ (FloatAttributes fv _) = shows fv
+ showsPrec _ (StringAttributes sv _) = shows sv
+ showsPrec _ (IdentAttributes mid i) = showsEscaped
+ $ intercalate "." $ mid ++ [i]
+ showsPrec _ (OptionsAttributes mt s) = showsTool mt
+ . showChar ' ' . showString s
+ where showsTool = maybe id (\t -> showChar '_' . showString t)
+
+
+-- ---------------------------------------------------------------------------
+-- The 'Show' instance of 'Token' is designed to display all tokens in their
+-- source representation.
+-- ---------------------------------------------------------------------------
+
+showsEscaped :: String -> ShowS
+showsEscaped s = showChar '`' . showString s . showChar '\''
+
+showsIdent :: Attributes -> ShowS
+showsIdent a = showString "identifier " . shows a
+
+showsSpecialIdent :: String -> ShowS
+showsSpecialIdent s = showString "identifier " . showsEscaped s
+
+showsOperator :: Attributes -> ShowS
+showsOperator a = showString "operator " . shows a
+
+showsSpecialOperator :: String -> ShowS
+showsSpecialOperator s = showString "operator " . showsEscaped s
+
+instance Show Token where
+ showsPrec _ (Token Id a) = showsIdent a
+ showsPrec _ (Token QId a) = showString "qualified "
+ . showsIdent a
+ showsPrec _ (Token Sym a) = showsOperator a
+ showsPrec _ (Token QSym a) = showString "qualified "
+ . showsOperator a
+ showsPrec _ (Token IntTok a) = showString "integer " . shows a
+ showsPrec _ (Token FloatTok a) = showString "float " . shows a
+ showsPrec _ (Token CharTok a) = showString "character " . shows a
+ showsPrec _ (Token StringTok a) = showString "string " . shows a
+ showsPrec _ (Token LeftParen _) = showsEscaped "("
+ showsPrec _ (Token RightParen _) = showsEscaped ")"
+ showsPrec _ (Token Semicolon _) = showsEscaped ";"
+ showsPrec _ (Token LeftBrace _) = showsEscaped "{"
+ showsPrec _ (Token RightBrace _) = showsEscaped "}"
+ showsPrec _ (Token LeftBracket _) = showsEscaped "["
+ showsPrec _ (Token RightBracket _) = showsEscaped "]"
+ showsPrec _ (Token Comma _) = showsEscaped ","
+ showsPrec _ (Token Underscore _) = showsEscaped "_"
+ showsPrec _ (Token Backquote _) = showsEscaped "`"
+ showsPrec _ (Token VSemicolon _)
+ = showsEscaped ";" . showString " (inserted due to layout)"
+ showsPrec _ (Token VRightBrace _)
+ = showsEscaped "}" . showString " (inserted due to layout)"
+ showsPrec _ (Token At _) = showsEscaped "@"
+ showsPrec _ (Token Colon _) = showsEscaped ":"
+ showsPrec _ (Token DotDot _) = showsEscaped ".."
+ showsPrec _ (Token DoubleArrow _) = showsEscaped "=>"
+ showsPrec _ (Token DoubleColon _) = showsEscaped "::"
+ showsPrec _ (Token Equals _) = showsEscaped "="
+ showsPrec _ (Token Backslash _) = showsEscaped "\\"
+ showsPrec _ (Token Bar _) = showsEscaped "|"
+ showsPrec _ (Token LeftArrow _) = showsEscaped "<-"
+ showsPrec _ (Token RightArrow _) = showsEscaped "->"
+ showsPrec _ (Token Tilde _) = showsEscaped "~"
+ showsPrec _ (Token SymDot _) = showsSpecialOperator "."
+ showsPrec _ (Token SymMinus _) = showsSpecialOperator "-"
+ showsPrec _ (Token SymStar _) = showsEscaped "*"
+ showsPrec _ (Token KW_case _) = showsEscaped "case"
+ showsPrec _ (Token KW_class _) = showsEscaped "class"
+ showsPrec _ (Token KW_data _) = showsEscaped "data"
+ showsPrec _ (Token KW_default _) = showsEscaped "default"
+ showsPrec _ (Token KW_deriving _) = showsEscaped "deriving"
+ showsPrec _ (Token KW_do _) = showsEscaped "do"
+ showsPrec _ (Token KW_else _) = showsEscaped "else"
+ showsPrec _ (Token KW_external _) = showsEscaped "external"
+ showsPrec _ (Token KW_fcase _) = showsEscaped "fcase"
+ showsPrec _ (Token KW_free _) = showsEscaped "free"
+ showsPrec _ (Token KW_if _) = showsEscaped "if"
+ showsPrec _ (Token KW_import _) = showsEscaped "import"
+ showsPrec _ (Token KW_in _) = showsEscaped "in"
+ showsPrec _ (Token KW_infix _) = showsEscaped "infix"
+ showsPrec _ (Token KW_infixl _) = showsEscaped "infixl"
+ showsPrec _ (Token KW_infixr _) = showsEscaped "infixr"
+ showsPrec _ (Token KW_instance _) = showsEscaped "instance"
+ showsPrec _ (Token KW_let _) = showsEscaped "let"
+ showsPrec _ (Token KW_module _) = showsEscaped "module"
+ showsPrec _ (Token KW_newtype _) = showsEscaped "newtype"
+ showsPrec _ (Token KW_of _) = showsEscaped "of"
+ showsPrec _ (Token KW_then _) = showsEscaped "then"
+ showsPrec _ (Token KW_type _) = showsEscaped "type"
+ showsPrec _ (Token KW_where _) = showsEscaped "where"
+ showsPrec _ (Token Id_as _) = showsSpecialIdent "as"
+ showsPrec _ (Token Id_ccall _) = showsSpecialIdent "ccall"
+ showsPrec _ (Token Id_forall _) = showsSpecialIdent "forall"
+ showsPrec _ (Token Id_hiding _) = showsSpecialIdent "hiding"
+ showsPrec _ (Token Id_interface _) = showsSpecialIdent "interface"
+ showsPrec _ (Token Id_primitive _) = showsSpecialIdent "primitive"
+ showsPrec _ (Token Id_qualified _) = showsSpecialIdent "qualified"
+ showsPrec _ (Token PragmaLanguage _) = showString "{-# LANGUAGE"
+ showsPrec _ (Token PragmaOptions a) = showString "{-# OPTIONS"
+ . shows a
+ showsPrec _ (Token PragmaHiding _) = showString "{-# HIDING"
+ showsPrec _ (Token PragmaMethod _) = showString "{-# METHOD"
+ showsPrec _ (Token PragmaModule _) = showString "{-# MODULE"
+ showsPrec _ (Token PragmaEnd _) = showString "#-}"
+ showsPrec _ (Token LineComment a) = shows a
+ showsPrec _ (Token NestedComment a) = shows a
+ showsPrec _ (Token EOF _) = showString ""
+
+-- ---------------------------------------------------------------------------
+-- The following functions can be used to construct tokens with
+-- specific attributes.
+-- ---------------------------------------------------------------------------
+
+-- |Construct a simple 'Token' without 'Attributes'
+tok :: Category -> Token
+tok t = Token t NoAttributes
+
+-- |Construct a 'Token' for a single 'Char'
+charTok :: Char -> String -> Token
+charTok c o = Token CharTok CharAttributes { cval = c, original = o }
+
+-- |Construct a 'Token' for an int value
+intTok :: Integer -> String -> Token
+intTok base digits = Token IntTok IntAttributes
+ { ival = convertIntegral base digits, original = digits }
+
+-- |Construct a 'Token' for a float value
+floatTok :: String -> String -> Int -> String -> Token
+floatTok mant frac expo rest = Token FloatTok FloatAttributes
+ { fval = convertFloating mant frac expo
+ , original = mant ++ "." ++ frac ++ rest }
+
+-- |Construct a 'Token' for a string value
+stringTok :: String -> String -> Token
+stringTok cs s = Token StringTok StringAttributes { sval = cs, original = s }
+
+-- |Construct a 'Token' for identifiers
+idTok :: Category -> [String] -> String -> Token
+idTok t mIdent ident = Token t
+ IdentAttributes { modulVal = mIdent, sval = ident }
+
+-- TODO
+pragmaOptionsTok :: Maybe String -> String -> Token
+pragmaOptionsTok mbTool s = Token PragmaOptions
+ OptionsAttributes { toolVal = mbTool, toolArgs = s }
+
+-- |Construct a 'Token' for a line comment
+lineCommentTok :: String -> Token
+lineCommentTok s = Token LineComment
+ StringAttributes { sval = s, original = s }
+
+-- |Construct a 'Token' for a nested comment
+nestedCommentTok :: String -> Token
+nestedCommentTok s = Token NestedComment
+ StringAttributes { sval = s, original = s }
+
+-- ---------------------------------------------------------------------------
+-- Tables for reserved operators and identifiers
+-- ---------------------------------------------------------------------------
+
+-- |Map of reserved operators
+reservedOps:: Map.Map String Category
+reservedOps = Map.fromList
+ [ ("@" , At )
+ , (":" , Colon )
+ , ("=>", DoubleArrow)
+ , ("::", DoubleColon)
+ , ("..", DotDot )
+ , ("=" , Equals )
+ , ("\\", Backslash )
+ , ("|" , Bar )
+ , ("<-", LeftArrow )
+ , ("->", RightArrow )
+ , ("~" , Tilde )
+ ]
+
+-- |Map of reserved and special operators
+reservedSpecialOps :: Map.Map String Category
+reservedSpecialOps = Map.union reservedOps $ Map.fromList
+ [ ("." , SymDot )
+ , ("-" , SymMinus )
+ , ("*" , SymStar )
+ ]
+
+-- |Map of keywords
+keywords :: Map.Map String Category
+keywords = Map.fromList
+ [ ("case" , KW_case )
+ , ("class" , KW_class )
+ , ("data" , KW_data )
+ , ("default" , KW_default )
+ , ("deriving", KW_deriving)
+ , ("do" , KW_do )
+ , ("else" , KW_else )
+ , ("external", KW_external)
+ , ("fcase" , KW_fcase )
+ , ("free" , KW_free )
+ , ("if" , KW_if )
+ , ("import" , KW_import )
+ , ("in" , KW_in )
+ , ("infix" , KW_infix )
+ , ("infixl" , KW_infixl )
+ , ("infixr" , KW_infixr )
+ , ("instance", KW_instance)
+ , ("let" , KW_let )
+ , ("module" , KW_module )
+ , ("newtype" , KW_newtype )
+ , ("of" , KW_of )
+ , ("then" , KW_then )
+ , ("type" , KW_type )
+ , ("where" , KW_where )
+ ]
+
+-- |Map of keywords and special identifiers
+keywordsSpecialIds :: Map.Map String Category
+keywordsSpecialIds = Map.union keywords $ Map.fromList
+ [ ("as" , Id_as )
+ , ("ccall" , Id_ccall )
+ , ("forall" , Id_forall )
+ , ("hiding" , Id_hiding )
+ , ("interface", Id_interface)
+ , ("primitive", Id_primitive)
+ , ("qualified", Id_qualified)
+ ]
+
+pragmas :: Map.Map String Category
+pragmas = Map.fromList
+ [ ("language", PragmaLanguage)
+ , ("options" , PragmaOptions )
+ , ("hiding" , PragmaHiding )
+ , ("method" , PragmaMethod )
+ , ("module" , PragmaModule )
+ ]
+
+
+-- ---------------------------------------------------------------------------
+-- Character classes
+-- ---------------------------------------------------------------------------
+
+-- |Check whether a 'Char' is allowed for identifiers
+isIdentChar :: Char -> Bool
+isIdentChar c = isAlphaNum c || c `elem` "'_"
+
+-- |Check whether a 'Char' is allowed for symbols
+isSymbolChar :: Char -> Bool
+isSymbolChar c = c `elem` "~!@#$%^&*+-=<>:?./|\\"
+
+-- ---------------------------------------------------------------------------
+-- Lexing functions
+-- ---------------------------------------------------------------------------
+
+-- |Lex source code
+lexSource :: FilePath -> String -> CYM [(Span, Token)]
+lexSource = parse (applyLexer fullLexer)
+
+-- |CPS-Lexer for Curry
+lexer :: Lexer Token a
+lexer = skipWhiteSpace True -- skip comments
+
+-- |CPS-Lexer for Curry which also lexes comments.
+-- This lexer is useful for documentation tools.
+fullLexer :: Lexer Token a
+fullLexer = skipWhiteSpace False -- lex comments
+
+-- |Lex the source code and skip whitespaces
+skipWhiteSpace :: Bool -> Lexer Token a
+skipWhiteSpace skipComments suc fail = skip
+ where
+ skip sp [] bol = suc sp (tok EOF) sp [] bol
+ skip sp c@('-':'-':_) _ = lexLineComment sucComment fail sp c True
+ skip sp c@('{':'-':'#':_) bol = lexPragma noPragma suc fail sp c bol
+ skip sp c@('{':'-':_) bol = lexNestedComment sucComment fail sp c bol
+ skip sp cs@(c:s) bol
+ | c == '\t' = warnP sp "Tab character" skip (tabSpan sp) s bol
+ | c == '\n' = skip (nlSpan sp) s True
+ | isSpace c = skip (nextSpan sp) s bol
+ | bol = lexBOL suc fail sp cs bol
+ | otherwise = lexToken suc fail sp cs bol
+ sucComment = if skipComments then (\ _suc _fail -> skip) else suc
+ noPragma = lexNestedComment sucComment fail
+
+-- Lex a line comment
+lexLineComment :: Lexer Token a
+lexLineComment suc _ sp str = case break (== '\n') str of
+-- (_, []) -> fail p "Unterminated line comment" p []
+ (c, s ) -> suc sp (lineCommentTok c) (incrSpan sp $ length c) s
+
+lexPragma :: P a -> Lexer Token a
+lexPragma noPragma suc fail sp0 str = pragma (incrSpan sp0 3) (drop 3 str)
+ where
+ skip = noPragma sp0 str
+ pragma sp [] = fail sp0 "Unterminated pragma" sp []
+ pragma sp cs@(c : s)
+ | c == '\t' = pragma (tabSpan sp) s
+ | c == '\n' = pragma (nlSpan sp) s
+ | isSpace c = pragma (nextSpan sp) s
+ | isAlpha c = case Map.lookup (map toLower prag) pragmas of
+ Nothing -> skip
+ Just PragmaOptions -> lexOptionsPragma sp0 suc fail sp1 rest
+ Just t -> suc sp0 (tok t) sp1 rest
+ | otherwise = skip
+ where
+ (prag, rest) = span isAlphaNum cs
+ sp1 = incrSpan sp (length prag)
+
+lexOptionsPragma :: Span -> Lexer Token a
+lexOptionsPragma sp0 _ fail sp [] = fail sp0 "Unterminated Options pragma" sp []
+lexOptionsPragma sp0 suc fail sp (c : s)
+ | c == '\t' = lexArgs Nothing (tabSpan sp) s
+ | c == '\n' = lexArgs Nothing (nlSpan sp) s
+ | isSpace c = lexArgs Nothing (nextSpan sp) s
+ | c == '_' = let (tool, s1) = span isIdentChar s
+ in lexArgs (Just tool) (incrSpan sp (length tool + 1)) s1
+ | otherwise = fail sp0 "Malformed Options pragma" sp s
+ where
+ lexArgs mbTool = lexRaw ""
+ where
+ lexRaw s0 sp1 r = case hash of
+ [] -> fail sp0 "End-of-file inside pragma" (incrSpan sp1 len) []
+ '#':'-':'}':_ -> token (trim $ s0 ++ opts) (incrSpan sp1 len) hash
+ _ -> lexRaw (s0 ++ opts ++ "#") (incrSpan sp1 (len + 1)) (drop 1 hash)
+ where
+ (opts, hash) = span (/= '#') r
+ len = length opts
+ token = suc sp0 . pragmaOptionsTok mbTool
+ trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+-- Lex a nested comment
+lexNestedComment :: Lexer Token a
+lexNestedComment suc fail sp0 = lnc (0 :: Integer) id sp0
+ where
+ -- d : nesting depth
+ -- comm: comment already lexed as functional list
+ lnc d comm sp str = case (d, str) of
+ (_, []) -> fail sp0 "Unterminated nested comment" sp []
+ (1, '-':'}':s) -> suc sp0 (nestedCommentTok (comm "-}")) (incrSpan sp 2) s
+ (_, '{':'-':s) -> cont (d+1) ("{-" ++) (incrSpan sp 2) s
+ (_, '-':'}':s) -> cont (d-1) ("-}" ++) (incrSpan sp 2) s
+ (_, c@'\t' :s) -> cont d (c:) (tabSpan sp) s
+ (_, c@'\n' :s) -> cont d (c:) (nlSpan sp) s
+ (_, c :s) -> cont d (c:) (nextSpan sp) s
+ where cont d' comm' = lnc d' (comm . comm')
+
+-- Lex tokens at the beginning of a line, managing layout.
+lexBOL :: Lexer Token a
+lexBOL suc fail sp s _ [] = lexToken suc fail sp s False []
+lexBOL suc fail sp s _ ctxt@(n:rest)
+ | col < n = suc sp (tok VRightBrace) sp s True rest
+ | col == n = suc sp (tok VSemicolon) sp s False ctxt
+ | otherwise = lexToken suc fail sp s False ctxt
+ where col = column (span2Pos sp)
+
+-- Lex a single 'Token'
+lexToken :: Lexer Token a
+lexToken suc _ sp [] = suc sp (tok EOF) sp []
+lexToken suc fail sp cs@(c:s)
+ | take 3 cs == "#-}" = suc sp (tok PragmaEnd) (incrSpan sp 3) (drop 3 cs)
+ | c == '(' = token LeftParen
+ | c == ')' = token RightParen
+ | c == ',' = token Comma
+ | c == ';' = token Semicolon
+ | c == '[' = token LeftBracket
+ | c == ']' = token RightBracket
+ | c == '_' = token Underscore
+ | c == '`' = token Backquote
+ | c == '{' = token LeftBrace
+ | c == '}' = lexRightBrace (suc sp) (nextSpan sp) s
+ | c == '\'' = lexChar sp suc fail (nextSpan sp) s
+ | c == '\"' = lexString sp suc fail (nextSpan sp) s
+ | isAlpha c = lexIdent (suc sp) sp cs
+ | isSymbolChar c = lexSymbol (suc sp) sp cs
+ | isDigit c = lexNumber (suc sp) sp cs
+ | otherwise = fail sp ("Illegal character " ++ show c) sp s
+ where token t = suc sp (tok t) (nextSpan sp) s
+
+-- Lex a right brace and pop from the context stack
+lexRightBrace :: (Token -> P a) -> P a
+lexRightBrace cont sp s bol ctxt = cont (tok RightBrace) sp s bol (drop 1 ctxt)
+
+-- Lex an identifier
+lexIdent :: (Token -> P a) -> P a
+lexIdent cont sp s = maybe (lexOptQual cont (token Id) [ident]) (cont . token)
+ (Map.lookup ident keywordsSpecialIds)
+ (incrSpan sp $ length ident) rest
+ where (ident, rest) = span isIdentChar s
+ token t = idTok t [] ident
+
+-- Lex a symbol
+lexSymbol :: (Token -> P a) -> P a
+lexSymbol cont sp s = cont
+ (idTok (Map.findWithDefault Sym sym reservedSpecialOps) [] sym)
+ (incrSpan sp $ length sym) rest
+ where (sym, rest) = span isSymbolChar s
+
+-- Lex an optionally qualified entity (identifier or symbol).
+lexOptQual :: (Token -> P a) -> Token -> [String] -> P a
+lexOptQual cont token mIdent sp cs@('.':c:s)
+ | isAlpha c = lexQualIdent cont identCont mIdent (nextSpan sp) (c:s)
+ | isSymbolChar c = lexQualSymbol cont identCont mIdent (nextSpan sp) (c:s)
+-- | c `elem` ":[(" = lexQualPrimitive cont token mIdent (nextSpan sp) (c:s)
+ where identCont _ _ = cont token sp cs
+lexOptQual cont token _ sp cs = cont token sp cs
+
+-- Lex a qualified identifier.
+lexQualIdent :: (Token -> P a) -> P a -> [String] -> P a
+lexQualIdent cont identCont mIdent sp s =
+ maybe (lexOptQual cont (idTok QId mIdent ident) (mIdent ++ [ident]))
+ (const identCont)
+ (Map.lookup ident keywords)
+ (incrSpan sp (length ident)) rest
+ where (ident, rest) = span isIdentChar s
+
+-- Lex a qualified symbol.
+lexQualSymbol :: (Token -> P a) -> P a -> [String] -> P a
+lexQualSymbol cont identCont mIdent sp s =
+ maybe (cont (idTok QSym mIdent sym)) (const identCont)
+ (Map.lookup sym reservedOps)
+ (incrSpan sp (length sym)) rest
+ where (sym, rest) = span isSymbolChar s
+
+-- ---------------------------------------------------------------------------
+-- /Note:/ since Curry allows an unlimited range of integer numbers,
+-- read numbers must be converted to Haskell type 'Integer'.
+-- ---------------------------------------------------------------------------
+
+-- Lex a numeric literal.
+lexNumber :: (Token -> P a) -> P a
+lexNumber cont sp ('0':c:s)
+ | c `elem` "bB" = lexBinary cont nullCont (incrSpan sp 2) s
+ | c `elem` "oO" = lexOctal cont nullCont (incrSpan sp 2) s
+ | c `elem` "xX" = lexHexadecimal cont nullCont (incrSpan sp 2) s
+ where nullCont _ _ = cont (intTok 10 "0") (nextSpan sp) (c:s)
+lexNumber cont sp s = lexOptFraction cont (intTok 10 digits) digits
+ (incrSpan sp $ length digits) rest
+ where (digits, rest) = span isDigit s
+
+-- Lex a binary literal.
+lexBinary :: (Token -> P a) -> P a -> P a
+lexBinary cont nullCont sp s
+ | null digits = nullCont undefined undefined
+ | otherwise = cont (intTok 2 digits) (incrSpan sp $ length digits) rest
+ where (digits, rest) = span isBinDigit s
+ isBinDigit c = c >= '0' && c <= '1'
+
+-- Lex an octal literal.
+lexOctal :: (Token -> P a) -> P a -> P a
+lexOctal cont nullCont sp s
+ | null digits = nullCont undefined undefined
+ | otherwise = cont (intTok 8 digits) (incrSpan sp $ length digits) rest
+ where (digits, rest) = span isOctDigit s
+
+-- Lex a hexadecimal literal.
+lexHexadecimal :: (Token -> P a) -> P a -> P a
+lexHexadecimal cont nullCont sp s
+ | null digits = nullCont undefined undefined
+ | otherwise = cont (intTok 16 digits) (incrSpan sp $ length digits) rest
+ where (digits, rest) = span isHexDigit s
+
+-- Lex an optional fractional part (float literal).
+lexOptFraction :: (Token -> P a) -> Token -> String -> P a
+lexOptFraction cont _ mant sp ('.':c:s)
+ | isDigit c = lexOptExponent cont (floatTok mant frac 0 "") mant frac
+ (incrSpan sp (length frac+1)) rest
+ where (frac,rest) = span isDigit (c:s)
+lexOptFraction cont token mant sp (c:s)
+ | c `elem` "eE" = lexSignedExponent cont intCont mant "" [c] (nextSpan sp) s
+ where intCont _ _ = cont token sp (c:s)
+lexOptFraction cont token _ sp s = cont token sp s
+
+-- Lex an optional exponent (float literal).
+lexOptExponent :: (Token -> P a) -> Token -> String -> String -> P a
+lexOptExponent cont token mant frac sp (c:s)
+ | c `elem` "eE" = lexSignedExponent cont floatCont mant frac [c] (nextSpan sp) s
+ where floatCont _ _ = cont token sp (c:s)
+lexOptExponent cont token _ _ sp s = cont token sp s
+
+-- Lex an exponent with sign (float literal).
+lexSignedExponent :: (Token -> P a) -> P a -> String -> String -> String
+ -> P a
+lexSignedExponent cont floatCont mant frac e sp str = case str of
+ ('+':c:s) | isDigit c -> lexExpo (e ++ "+") id (nextSpan sp) (c:s)
+ ('-':c:s) | isDigit c -> lexExpo (e ++ "-") negate (nextSpan sp) (c:s)
+ (c:_) | isDigit c -> lexExpo e id sp str
+ _ -> floatCont sp str
+ where lexExpo = lexExponent cont mant frac
+
+-- Lex an exponent without sign (float literal).
+lexExponent :: (Token -> P a) -> String -> String -> String -> (Int -> Int)
+ -> P a
+lexExponent cont mant frac e expSign sp s =
+ cont (floatTok mant frac expo (e ++ digits)) (incrSpan sp $ length digits) rest
+ where (digits, rest) = span isDigit s
+ expo = expSign (convertIntegral 10 digits)
+
+-- Lex a character literal.
+lexChar :: Span -> Lexer Token a
+lexChar sp0 _ fail sp [] = fail sp0 "Illegal character constant" sp []
+lexChar sp0 success fail sp (c:s)
+ | c == '\\' = lexEscape sp (\d o -> lexCharEnd d o sp0 success fail)
+ fail (nextSpan sp) s
+ | c == '\n' = fail sp0 "Illegal character constant" sp (c:s)
+ | c == '\t' = lexCharEnd c "\t" sp0 success fail (tabSpan sp) s
+ | otherwise = lexCharEnd c [c] sp0 success fail (nextSpan sp) s
+
+-- Lex the end of a character literal.
+lexCharEnd :: Char -> String -> Span -> Lexer Token a
+lexCharEnd c o sp0 suc _ sp ('\'':s) = suc sp0 (charTok c o) (nextSpan sp) s
+lexCharEnd _ _ sp0 _ fail sp s =
+ fail sp0 "Improperly terminated character constant" sp s
+
+-- Lex a String literal.
+lexString :: Span -> Lexer Token a
+lexString sp0 suc fail = lexStringRest "" id
+ where
+ lexStringRest _ _ sp [] = improperTermination sp
+ lexStringRest s0 so sp (c:s)
+ | c == '\n' = improperTermination sp
+ | c == '\"' = suc sp0 (stringTok (reverse s0) (so "")) (nextSpan sp) s
+ | c == '\\' = lexStringEscape sp s0 so lexStringRest fail (nextSpan sp) s
+ | c == '\t' = lexStringRest (c:s0) (so . (c:)) (tabSpan sp) s
+ | otherwise = lexStringRest (c:s0) (so . (c:)) (nextSpan sp) s
+ improperTermination sp = fail sp0 "Improperly terminated string constant" sp []
+
+-- Lex an escaped character inside a string.
+lexStringEscape :: Span -> String -> (String -> String)
+ -> (String -> (String -> String) -> P a)
+ -> FailP a -> P a
+lexStringEscape sp0 _ _ _ fail sp [] = lexEscape sp0 undefined fail sp []
+lexStringEscape sp0 s0 so suc fail sp cs@(c:s)
+ -- The escape sequence represents an empty character of length zero
+ | c == '&' = suc s0 (so . ("\\&" ++)) (nextSpan sp) s
+ | isSpace c = lexStringGap so (suc s0) fail sp cs
+ | otherwise = lexEscape sp0 (\ c' s' -> suc (c': s0) (so . (s' ++))) fail sp cs
+
+-- Lex a string gap.
+lexStringGap :: (String -> String) -> ((String -> String) -> P a)
+ -> FailP a -> P a
+lexStringGap _ _ fail sp [] = fail sp "End-of-file in string gap" sp []
+lexStringGap so suc fail sp (c:s)
+ | c == '\\' = suc (so . (c:)) (nextSpan sp) s
+ | c == '\t' = lexStringGap (so . (c:)) suc fail (tabSpan sp) s
+ | c == '\n' = lexStringGap (so . (c:)) suc fail (nlSpan sp) s
+ | isSpace c = lexStringGap (so . (c:)) suc fail (nextSpan sp) s
+ | otherwise = fail sp ("Illegal character in string gap: " ++ show c) sp s
+
+-- Lex an escaped character.
+lexEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a
+lexEscape sp0 suc fail sp str = case str of
+ -- character escape
+ ('a' :s) -> suc '\a' "\\a" (nextSpan sp) s
+ ('b' :s) -> suc '\b' "\\b" (nextSpan sp) s
+ ('f' :s) -> suc '\f' "\\f" (nextSpan sp) s
+ ('n' :s) -> suc '\n' "\\n" (nextSpan sp) s
+ ('r' :s) -> suc '\r' "\\r" (nextSpan sp) s
+ ('t' :s) -> suc '\t' "\\t" (nextSpan sp) s
+ ('v' :s) -> suc '\v' "\\v" (nextSpan sp) s
+ ('\\':s) -> suc '\\' "\\\\" (nextSpan sp) s
+ ('"' :s) -> suc '\"' "\\\"" (nextSpan sp) s
+ ('\'':s) -> suc '\'' "\\\'" (nextSpan sp) s
+ -- control characters
+ ('^':c:s) | isControlEsc c -> controlEsc c (incrSpan sp 2) s
+ -- numeric escape
+ ('o':c:s) | isOctDigit c -> numEsc 8 isOctDigit ("\\o" ++) (nextSpan sp) (c:s)
+ ('x':c:s) | isHexDigit c -> numEsc 16 isHexDigit ("\\x" ++) (nextSpan sp) (c:s)
+ (c:s) | isDigit c -> numEsc 10 isDigit ("\\" ++) sp (c:s)
+ -- ascii escape
+ _ -> asciiEscape sp0 suc fail sp str
+ where numEsc = numEscape sp0 suc fail
+ controlEsc c = suc (chr (ord c `mod` 32)) ("\\^" ++ [c])
+ isControlEsc c = isUpper c || c `elem` "@[\\]^_"
+
+numEscape :: Span -> (Char -> String -> P a) -> FailP a -> Int
+ -> (Char -> Bool) -> (String -> String) -> P a
+numEscape sp0 suc fail b isDigit' so sp s
+ | n >= ord minBound && n <= ord maxBound
+ = suc (chr n) (so digits) (incrSpan sp $ length digits) rest
+ | otherwise
+ = fail sp0 "Numeric escape out-of-range" sp s
+ where (digits, rest) = span isDigit' s
+ n = convertIntegral b digits
+
+asciiEscape :: Span -> (Char -> String -> P a) -> FailP a -> P a
+asciiEscape sp0 suc fail sp str = case str of
+ ('N':'U':'L':s) -> suc '\NUL' "\\NUL" (incrSpan sp 3) s
+ ('S':'O':'H':s) -> suc '\SOH' "\\SOH" (incrSpan sp 3) s
+ ('S':'T':'X':s) -> suc '\STX' "\\STX" (incrSpan sp 3) s
+ ('E':'T':'X':s) -> suc '\ETX' "\\ETX" (incrSpan sp 3) s
+ ('E':'O':'T':s) -> suc '\EOT' "\\EOT" (incrSpan sp 3) s
+ ('E':'N':'Q':s) -> suc '\ENQ' "\\ENQ" (incrSpan sp 3) s
+ ('A':'C':'K':s) -> suc '\ACK' "\\ACK" (incrSpan sp 3) s
+ ('B':'E':'L':s) -> suc '\BEL' "\\BEL" (incrSpan sp 3) s
+ ('B':'S' :s) -> suc '\BS' "\\BS" (incrSpan sp 2) s
+ ('H':'T' :s) -> suc '\HT' "\\HT" (incrSpan sp 2) s
+ ('L':'F' :s) -> suc '\LF' "\\LF" (incrSpan sp 2) s
+ ('V':'T' :s) -> suc '\VT' "\\VT" (incrSpan sp 2) s
+ ('F':'F' :s) -> suc '\FF' "\\FF" (incrSpan sp 2) s
+ ('C':'R' :s) -> suc '\CR' "\\CR" (incrSpan sp 2) s
+ ('S':'O' :s) -> suc '\SO' "\\SO" (incrSpan sp 2) s
+ ('S':'I' :s) -> suc '\SI' "\\SI" (incrSpan sp 2) s
+ ('D':'L':'E':s) -> suc '\DLE' "\\DLE" (incrSpan sp 3) s
+ ('D':'C':'1':s) -> suc '\DC1' "\\DC1" (incrSpan sp 3) s
+ ('D':'C':'2':s) -> suc '\DC2' "\\DC2" (incrSpan sp 3) s
+ ('D':'C':'3':s) -> suc '\DC3' "\\DC3" (incrSpan sp 3) s
+ ('D':'C':'4':s) -> suc '\DC4' "\\DC4" (incrSpan sp 3) s
+ ('N':'A':'K':s) -> suc '\NAK' "\\NAK" (incrSpan sp 3) s
+ ('S':'Y':'N':s) -> suc '\SYN' "\\SYN" (incrSpan sp 3) s
+ ('E':'T':'B':s) -> suc '\ETB' "\\ETB" (incrSpan sp 3) s
+ ('C':'A':'N':s) -> suc '\CAN' "\\CAN" (incrSpan sp 3) s
+ ('E':'M' :s) -> suc '\EM' "\\EM" (incrSpan sp 2) s
+ ('S':'U':'B':s) -> suc '\SUB' "\\SUB" (incrSpan sp 3) s
+ ('E':'S':'C':s) -> suc '\ESC' "\\ESC" (incrSpan sp 3) s
+ ('F':'S' :s) -> suc '\FS' "\\FS" (incrSpan sp 2) s
+ ('G':'S' :s) -> suc '\GS' "\\GS" (incrSpan sp 2) s
+ ('R':'S' :s) -> suc '\RS' "\\RS" (incrSpan sp 2) s
+ ('U':'S' :s) -> suc '\US' "\\US" (incrSpan sp 2) s
+ ('S':'P' :s) -> suc '\SP' "\\SP" (incrSpan sp 2) s
+ ('D':'E':'L':s) -> suc '\DEL' "\\DEL" (incrSpan sp 3) s
+ s -> fail sp0 "Illegal escape sequence" sp s
diff --git a/src/Curry/Syntax/Parser.hs b/src/Curry/Syntax/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Syntax/Parser.hs
@@ -0,0 +1,1073 @@
+{- |
+ Module : $Header$
+ Description : A Parser for Curry
+ Copyright : (c) 1999 - 2004 Wolfgang Lux
+ 2005 Martin Engelke
+ 2011 - 2015 Björn Peemöller
+ 2016 - 2017 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ The Curry parser is implemented using the (mostly) LL(1) parsing
+ combinators implemented in 'Curry.Base.LLParseComb'.
+-}
+module Curry.Syntax.Parser
+ ( parseSource, parseHeader, parsePragmas, parseInterface, parseGoal
+ ) where
+
+import Curry.Base.Ident
+import Curry.Base.Monad (CYM)
+import Curry.Base.Position (Position)
+import Curry.Base.LLParseComb
+
+import Curry.Syntax.Extension
+import Curry.Syntax.Lexer (Token (..), Category (..), Attributes (..), lexer)
+import Curry.Syntax.Type
+
+-- |Parse a 'Module'
+parseSource :: FilePath -> String -> CYM (Module ())
+parseSource fn
+ = fullParser (uncurry <$> moduleHeader <*> layout moduleDecls) lexer fn
+
+-- |Parse only pragmas of a 'Module'
+parsePragmas :: FilePath -> String -> CYM (Module ())
+parsePragmas
+ = prefixParser ((\ps -> Module ps mainMIdent Nothing [] []) <$> modulePragmas)
+ lexer
+
+-- |Parse a 'Module' header
+parseHeader :: FilePath -> String -> CYM (Module ())
+parseHeader
+ = prefixParser (moduleHeader <*> startLayout importDecls <*> succeed []) lexer
+ where importDecls = many (importDecl <*-> many semicolon)
+
+-- |Parse an 'Interface'
+parseInterface :: FilePath -> String -> CYM Interface
+parseInterface = fullParser interface lexer
+
+-- |Parse a 'Goal'
+parseGoal :: String -> CYM (Goal ())
+parseGoal = fullParser goal lexer ""
+
+-- ---------------------------------------------------------------------------
+-- Module header
+-- ---------------------------------------------------------------------------
+
+-- |Parser for a module header
+moduleHeader :: Parser a Token ([ImportDecl] -> [Decl b] -> Module b)
+moduleHeader = (\ps (m, es) -> Module ps m es)
+ <$> modulePragmas
+ <*> header
+ where header = (,) <$-> token KW_module <*> modIdent
+ <*> option exportSpec
+ <*-> expectWhere
+ `opt` (mainMIdent, Nothing)
+
+modulePragmas :: Parser a Token [ModulePragma]
+modulePragmas = many (languagePragma <|> optionsPragma)
+
+languagePragma :: Parser a Token ModulePragma
+languagePragma = LanguagePragma
+ <$> tokenPos PragmaLanguage
+ <*> (languageExtension `sepBy1` comma)
+ <*-> token PragmaEnd
+ where languageExtension = classifyExtension <$> ident
+
+optionsPragma :: Parser a Token ModulePragma
+optionsPragma = (\pos a -> OptionsPragma pos (fmap classifyTool $ toolVal a)
+ (toolArgs a))
+ <$> position
+ <*> token PragmaOptions
+ <*-> token PragmaEnd
+
+-- |Parser for an export specification
+exportSpec :: Parser a Token ExportSpec
+exportSpec = Exporting <$> position <*> parens (export `sepBy` comma)
+
+-- |Parser for an export item
+export :: Parser a Token Export
+export = qtycon <**> (parens spec `opt` Export) -- type constructor
+ <|> Export <$> qfun <\> qtycon -- fun
+ <|> ExportModule <$-> token KW_module <*> modIdent -- module
+ where spec = ExportTypeAll <$-> token DotDot
+ <|> flip ExportTypeWith <$> con `sepBy` comma
+
+moduleDecls :: Parser a Token ([ImportDecl], [Decl ()])
+moduleDecls = impDecl <$> importDecl
+ <*> (semicolon <-*> moduleDecls `opt` ([], []))
+ <|> (,) [] <$> topDecls
+ where impDecl i (is, ds) = (i:is ,ds)
+
+-- |Parser for a single import declaration
+importDecl :: Parser a Token ImportDecl
+importDecl = flip . ImportDecl
+ <$> tokenPos KW_import
+ <*> flag (token Id_qualified)
+ <*> modIdent
+ <*> option (token Id_as <-*> modIdent)
+ <*> option importSpec
+
+-- |Parser for an import specification
+importSpec :: Parser a Token ImportSpec
+importSpec = position
+ <**> (Hiding <$-> token Id_hiding `opt` Importing)
+ <*> parens (spec `sepBy` comma)
+ where
+ spec = tycon <**> (parens constrs `opt` Import)
+ <|> Import <$> fun <\> tycon
+ constrs = ImportTypeAll <$-> token DotDot
+ <|> flip ImportTypeWith <$> con `sepBy` comma
+
+-- ---------------------------------------------------------------------------
+-- Interfaces
+-- ---------------------------------------------------------------------------
+
+-- |Parser for an interface
+interface :: Parser a Token Interface
+interface = uncurry <$> intfHeader <*> braces intfDecls
+
+intfHeader :: Parser a Token ([IImportDecl] -> [IDecl] -> Interface)
+intfHeader = Interface <$-> token Id_interface <*> modIdent <*-> expectWhere
+
+intfDecls :: Parser a Token ([IImportDecl], [IDecl])
+intfDecls = impDecl <$> iImportDecl
+ <*> (semicolon <-*> intfDecls `opt` ([], []))
+ <|> (,) [] <$> intfDecl `sepBy` semicolon
+ where impDecl i (is, ds) = (i:is, ds)
+
+-- |Parser for a single interface import declaration
+iImportDecl :: Parser a Token IImportDecl
+iImportDecl = IImportDecl <$> tokenPos KW_import <*> modIdent
+
+-- |Parser for a single interface declaration
+intfDecl :: Parser a Token IDecl
+intfDecl = choice [ iInfixDecl, iHidingDecl, iDataDecl, iNewtypeDecl
+ , iTypeDecl , iFunctionDecl <\> token Id_hiding
+ , iClassDecl, iInstanceDecl ]
+
+-- |Parser for an interface infix declaration
+iInfixDecl :: Parser a Token IDecl
+iInfixDecl = infixDeclLhs IInfixDecl <*> integer <*> qfunop
+
+-- |Parser for an interface hiding declaration
+iHidingDecl :: Parser a Token IDecl
+iHidingDecl = tokenPos Id_hiding <**> (hDataDecl <|> hClassDecl)
+ where
+ hDataDecl = hiddenData <$-> token KW_data <*> withKind qtycon <*> many tyvar
+ hClassDecl = hiddenClass <$> classInstHead KW_class (withKind qtycls) clsvar
+ hiddenData (tc, k) tvs p = HidingDataDecl p tc k tvs
+ hiddenClass (_, cx, (qcls, k), tv) p = HidingClassDecl p cx qcls k tv
+
+-- |Parser for an interface data declaration
+iDataDecl :: Parser a Token IDecl
+iDataDecl = iTypeDeclLhs IDataDecl KW_data <*> constrs <*> iHiddenPragma
+ where constrs = equals <-*> constrDecl `sepBy1` bar `opt` []
+
+-- |Parser for an interface newtype declaration
+iNewtypeDecl :: Parser a Token IDecl
+iNewtypeDecl = iTypeDeclLhs INewtypeDecl KW_newtype
+ <*-> equals <*> newConstrDecl <*> iHiddenPragma
+
+-- |Parser for an interface type synonym declaration
+iTypeDecl :: Parser a Token IDecl
+iTypeDecl = iTypeDeclLhs ITypeDecl KW_type
+ <*-> equals <*> type0
+
+-- |Parser for an interface hiding pragma
+iHiddenPragma :: Parser a Token [Ident]
+iHiddenPragma = token PragmaHiding
+ <-*> (con `sepBy` comma)
+ <*-> token PragmaEnd
+ `opt` []
+
+
+-- |Parser for an interface function declaration
+iFunctionDecl :: Parser a Token IDecl
+iFunctionDecl = IFunctionDecl <$> position <*> qfun <*> option iMethodPragma
+ <*> arity <*-> token DoubleColon <*> qualType
+
+-- |Parser for an interface method pragma
+iMethodPragma :: Parser a Token Ident
+iMethodPragma = token PragmaMethod <-*> clsvar <*-> token PragmaEnd
+
+-- |Parser for function's arity
+arity :: Parser a Token Int
+arity = int `opt` 0
+
+iTypeDeclLhs :: (Position -> QualIdent -> Maybe KindExpr -> [Ident] -> a)
+ -> Category -> Parser b Token a
+iTypeDeclLhs f kw = f' <$> tokenPos kw <*> withKind qtycon <*> many tyvar
+ where f' p (tc, k) = f p tc k
+
+-- |Parser for an interface class declaration
+iClassDecl :: Parser a Token IDecl
+iClassDecl = (\(p, cx, (qcls, k), tv) -> IClassDecl p cx qcls k tv)
+ <$> classInstHead KW_class (withKind qtycls) clsvar
+ <*> braces (iMethod `sepBy` semicolon)
+ <*> iClassHidden
+
+-- |Parser for an interface method declaration
+iMethod :: Parser a Token IMethodDecl
+iMethod = IMethodDecl <$> position
+ <*> fun <*> option int <*-> token DoubleColon <*> qualType
+
+-- |Parser for an interface hiding pragma
+iClassHidden :: Parser a Token [Ident]
+iClassHidden = token PragmaHiding
+ <-*> (fun `sepBy` comma)
+ <*-> token PragmaEnd
+ `opt` []
+
+-- |Parser for an interface instance declaration
+iInstanceDecl :: Parser a Token IDecl
+iInstanceDecl = (\(p, cx, qcls, inst) -> IInstanceDecl p cx qcls inst)
+ <$> classInstHead KW_instance qtycls type2
+ <*> braces (iImpl `sepBy` semicolon)
+ <*> option iModulePragma
+
+-- |Parser for an interface method implementation
+iImpl :: Parser a Token IMethodImpl
+iImpl = (,) <$> fun <*> arity
+
+iModulePragma :: Parser a Token ModuleIdent
+iModulePragma = token PragmaModule <-*> modIdent <*-> token PragmaEnd
+
+-- ---------------------------------------------------------------------------
+-- Top-Level Declarations
+-- ---------------------------------------------------------------------------
+
+topDecls :: Parser a Token [Decl ()]
+topDecls = topDecl `sepBy` semicolon
+
+topDecl :: Parser a Token (Decl ())
+topDecl = choice [ dataDecl, externalDataDecl, newtypeDecl, typeDecl
+ , classDecl, instanceDecl, defaultDecl
+ , infixDecl, functionDecl ]
+
+dataDecl :: Parser a Token (Decl ())
+dataDecl = typeDeclLhs DataDecl KW_data <*> constrs <*> deriv
+ where constrs = equals <-*> constrDecl `sepBy1` bar `opt` []
+
+externalDataDecl :: Parser a Token (Decl ())
+externalDataDecl = decl <$> tokenPos KW_external <*> typeDeclLhs (,,) KW_data
+ where decl p (_, tc, tvs) = ExternalDataDecl p tc tvs
+
+newtypeDecl :: Parser a Token (Decl ())
+newtypeDecl = typeDeclLhs NewtypeDecl KW_newtype <*-> equals <*> newConstrDecl
+ <*> deriv
+
+typeDecl :: Parser a Token (Decl ())
+typeDecl = typeDeclLhs TypeDecl KW_type <*-> equals <*> type0
+
+typeDeclLhs :: (Position -> Ident -> [Ident] -> a) -> Category
+ -> Parser b Token a
+typeDeclLhs f kw = f <$> tokenPos kw <*> tycon <*> many anonOrTyvar
+
+constrDecl :: Parser a Token ConstrDecl
+constrDecl = position <**> (existVars <**> optContext (flip ($)) constr)
+ where
+ constr = conId <**> identDecl
+ <|> leftParen <-*> parenDecl
+ <|> type1 <\> conId <\> leftParen <**> opDecl
+ identDecl = many type2 <**> (conType <$> opDecl `opt` conDecl)
+ <|> recDecl <$> recFields
+ parenDecl = conOpDeclPrefix
+ <$> conSym <*-> rightParen <*> type2 <*> type2
+ <|> tupleType <*-> rightParen <**> opDecl
+ opDecl = conOpDecl <$> conop <*> type1
+ recFields = layoutOff <-*> braces
+ (fieldDecl `sepBy` comma)
+ conType f tys c = f $ apply (ConstructorType $ qualify c) tys
+ apply = foldl ApplyType
+ conDecl tys c cx tvs p = ConstrDecl p tvs cx c tys
+ conOpDecl op ty2 ty1 cx tvs p = ConOpDecl p tvs cx ty1 op ty2
+ conOpDeclPrefix op ty1 ty2 cx tvs p = ConOpDecl p tvs cx ty1 op ty2
+ recDecl fs c cx tvs p = RecordDecl p tvs cx c fs
+
+fieldDecl :: Parser a Token FieldDecl
+fieldDecl = FieldDecl <$> position <*> labels <*-> token DoubleColon <*> type0
+ where labels = fun `sepBy1` comma
+
+newConstrDecl :: Parser a Token NewConstrDecl
+newConstrDecl = position <**> (con <**> newConstr)
+ where newConstr = newConDecl <$> type2
+ <|> newRecDecl <$> newFieldDecl
+ newConDecl ty c p = NewConstrDecl p c ty
+ newRecDecl fld c p = NewRecordDecl p c fld
+
+newFieldDecl :: Parser a Token (Ident, TypeExpr)
+newFieldDecl = layoutOff <-*> braces labelDecl
+ where labelDecl = (,) <$> fun <*-> token DoubleColon <*> type0
+
+deriv :: Parser a Token [QualIdent]
+deriv = token KW_deriving <-*> classes `opt` []
+ where classes = return <$> qtycls
+ <|> parens (qtycls `sepBy` comma)
+
+-- Parsing of existential variables
+existVars :: Parser a Token [Ident]
+existVars = token Id_forall <-*> many1 tyvar <*-> dot `opt` []
+
+functionDecl :: Parser a Token (Decl ())
+functionDecl = position <**> decl
+ where decl = fun `sepBy1` comma <**> funListDecl <|?> funRule
+
+funRule :: Parser a Token (Position -> Decl ())
+funRule = mkFunDecl <$> lhs <*> declRhs
+ where lhs = (\f -> (f, FunLhs f [])) <$> fun <|?> funLhs
+
+funListDecl :: Parser a Token ([Ident] -> Position -> Decl ())
+funListDecl = typeSig
+ <|> flip ExternalDecl . map (Var ()) <$-> token KW_external
+
+typeSig :: Parser a Token ([Ident] -> Position -> Decl ())
+typeSig = sig <$-> token DoubleColon <*> qualType
+ where sig qty vs p = TypeSig p vs qty
+
+mkFunDecl :: (Ident, Lhs ()) -> Rhs () -> Position -> Decl ()
+mkFunDecl (f, lhs) rhs' p = FunctionDecl p () f [Equation p lhs rhs']
+
+funLhs :: Parser a Token (Ident, Lhs ())
+funLhs = mkFunLhs <$> fun <*> many1 pattern2
+ <|?> flip ($ id) <$> pattern1 <*> opLhs
+ <|?> curriedLhs
+ where
+ opLhs = opLHS funSym (gConSym <\> funSym)
+ <|> backquote <-*> opLHS (funId <*-> expectBackquote)
+ (qConId <\> funId <*-> expectBackquote)
+ opLHS funP consP = mkOpLhs <$> funP <*> pattern0
+ <|> mkInfixPat <$> consP <*> pattern1 <*> opLhs
+ mkFunLhs f ts = (f , FunLhs f ts)
+ mkOpLhs op t2 f t1 = (op, OpLhs (f t1) op t2)
+ mkInfixPat op t2 f g t1 = f (g . InfixPattern () t1 op) t2
+
+curriedLhs :: Parser a Token (Ident, Lhs ())
+curriedLhs = apLhs <$> parens funLhs <*> many1 pattern2
+ where apLhs (f, lhs) ts = (f, ApLhs lhs ts)
+
+declRhs :: Parser a Token (Rhs ())
+declRhs = rhs equals
+
+rhs :: Parser a Token b -> Parser a Token (Rhs ())
+rhs eq = rhsExpr <*> localDecls
+ where rhsExpr = SimpleRhs <$-> eq <*> position <*> expr
+ <|> GuardedRhs <$> many1 (condExpr eq)
+
+whereClause :: Parser a Token [b] -> Parser a Token [b]
+whereClause decls = token KW_where <-*> layout decls `opt` []
+
+localDecls :: Parser a Token [Decl ()]
+localDecls = whereClause valueDecls
+
+valueDecls :: Parser a Token [Decl ()]
+valueDecls = choice [infixDecl, valueDecl] `sepBy` semicolon
+
+infixDecl :: Parser a Token (Decl ())
+infixDecl = infixDeclLhs InfixDecl <*> option integer <*> funop `sepBy1` comma
+
+infixDeclLhs :: (Position -> Infix -> a) -> Parser b Token a
+infixDeclLhs f = f <$> position <*> tokenOps infixKW
+ where infixKW = [(KW_infix, Infix), (KW_infixl, InfixL), (KW_infixr, InfixR)]
+
+valueDecl :: Parser a Token (Decl ())
+valueDecl = position <**> decl
+ where
+ decl = var `sepBy1` comma <**> valListDecl
+ <|?> patOrFunDecl <$> pattern0 <*> declRhs
+ <|?> mkFunDecl <$> curriedLhs <*> declRhs
+
+ valListDecl = funListDecl
+ <|> (flip FreeDecl . map (Var ())) <$-> token KW_free
+
+ patOrFunDecl (ConstructorPattern _ c ts)
+ | not (isConstrId c) = mkFunDecl (f, FunLhs f ts)
+ where f = unqualify c
+ patOrFunDecl t = patOrOpDecl id t
+
+ patOrOpDecl f (InfixPattern a t1 op t2)
+ | isConstrId op = patOrOpDecl (f . InfixPattern a t1 op) t2
+ | otherwise = mkFunDecl (op', OpLhs (f t1) op' t2)
+ where op' = unqualify op
+ patOrOpDecl f t = mkPatDecl (f t)
+
+ mkPatDecl t rhs' p = PatternDecl p t rhs'
+
+ isConstrId c = c == qConsId || isQualified c || isQTupleId c
+
+defaultDecl :: Parser a Token (Decl ())
+defaultDecl = DefaultDecl <$> position <*-> token KW_default
+ <*> parens (type0 `sepBy` comma)
+
+classInstHead :: Category -> Parser a Token b -> Parser a Token c
+ -> Parser a Token (Position, Context, b, c)
+classInstHead kw cls ty = f <$> tokenPos kw
+ <*> optContext (,) ((,) <$> cls <*> ty)
+ where f p (cx, (cls', ty')) = (p, cx, cls', ty')
+
+classDecl :: Parser a Token (Decl ())
+classDecl = (\(p, cx, cls, tv) -> ClassDecl p cx cls tv)
+ <$> classInstHead KW_class tycls clsvar
+ <*> whereClause innerDecls
+ where
+ innerDecls = innerDecl `sepBy` semicolon
+ --TODO: Refactor by left-factorization
+ --TODO: Support infixDecl
+ innerDecl = foldr1 (<|?>) [ position <**> (fun `sepBy1` comma <**> typeSig)
+ , position <**> funRule
+ {-, infixDecl-} ]
+
+instanceDecl :: Parser a Token (Decl ())
+instanceDecl = (\(p, cx, qcls, inst) -> InstanceDecl p cx qcls inst)
+ <$> classInstHead KW_instance qtycls type2
+ <*> whereClause innerDecls
+ where
+ innerDecls = (position <**> funRule) `sepBy` semicolon
+
+-- ---------------------------------------------------------------------------
+-- Type classes
+-- ---------------------------------------------------------------------------
+
+optContext :: (Context -> a -> b) -> Parser c Token a -> Parser c Token b
+optContext f p = f <$> context <*-> token DoubleArrow <*> p
+ <|?> f [] <$> p
+
+context :: Parser a Token Context
+context = return <$> constraint
+ <|> parens (constraint `sepBy` comma)
+
+constraint :: Parser a Token Constraint
+constraint = Constraint <$> qtycls <*> conType
+ where varType = VariableType <$> clsvar
+ conType = varType
+ <|> parens (foldl ApplyType <$> varType <*> many1 type2)
+
+-- ---------------------------------------------------------------------------
+-- Kinds
+-- ---------------------------------------------------------------------------
+
+withKind :: Parser a Token b -> Parser a Token (b, Maybe KindExpr)
+withKind p = implicitKind <$> p
+ <|?> parens (explicitKind <$> p <*-> token DoubleColon <*> kind0)
+ where implicitKind x = (x, Nothing)
+ explicitKind x k = (x, Just k)
+
+-- kind0 ::= kind1 ['->' kind0]
+kind0 :: Parser a Token KindExpr
+kind0 = kind1 `chainr1` (ArrowKind <$-> token RightArrow)
+
+-- kind1 ::= * | '(' kind0 ')'
+kind1 :: Parser a Token KindExpr
+kind1 = Star <$-> token SymStar
+ <|> parens kind0
+
+-- ---------------------------------------------------------------------------
+-- Types
+-- ---------------------------------------------------------------------------
+
+-- qualType ::= [context '=>'] type0
+qualType :: Parser a Token QualTypeExpr
+qualType = optContext QualTypeExpr type0
+
+-- type0 ::= type1 ['->' type0]
+type0 :: Parser a Token TypeExpr
+type0 = type1 `chainr1` (ArrowType <$-> token RightArrow)
+
+-- type1 ::= [type1] type2
+type1 :: Parser a Token TypeExpr
+type1 = foldl1 ApplyType <$> many1 type2
+
+-- type2 ::= anonType | identType | parenType | bracketType
+type2 :: Parser a Token TypeExpr
+type2 = anonType <|> identType <|> parenType <|> bracketType
+
+-- anonType ::= '_'
+anonType :: Parser a Token TypeExpr
+anonType = VariableType <$> anonIdent
+
+-- identType ::=
+identType :: Parser a Token TypeExpr
+identType = VariableType <$> tyvar
+ <|> ConstructorType <$> qtycon <\> tyvar
+
+-- parenType ::= '(' tupleType ')'
+parenType :: Parser a Token TypeExpr
+parenType = parens tupleType
+
+-- tupleType ::= type0 (parenthesized type)
+-- | type0 ',' type0 { ',' type0 } (tuple type)
+-- | '->' (function type constructor)
+-- | ',' { ',' } (tuple type constructor)
+-- | (unit type)
+tupleType :: Parser a Token TypeExpr
+tupleType = type0 <**> (tuple <$> many1 (comma <-*> type0) `opt` ParenType)
+ <|> token RightArrow <-*> succeed (ConstructorType qArrowId)
+ <|> ConstructorType . qTupleId . (+1) . length <$> many1 comma
+ <|> succeed (ConstructorType qUnitId)
+ where tuple tys ty = TupleType (ty : tys)
+
+-- bracketType ::= '[' listType ']'
+bracketType :: Parser a Token TypeExpr
+bracketType = brackets listType
+
+-- listType ::= type0 (list type)
+-- | (list type constructor)
+listType :: Parser a Token TypeExpr
+listType = ListType <$> type0 `opt` (ConstructorType qListId)
+
+-- ---------------------------------------------------------------------------
+-- Literals
+-- ---------------------------------------------------------------------------
+
+-- literal ::= '\'' '\''
+-- |
+-- |
+-- | '"' '"'
+literal :: Parser a Token Literal
+literal = Char <$> char
+ <|> Int <$> integer
+ <|> Float <$> float
+ <|> String <$> string
+
+-- ---------------------------------------------------------------------------
+-- Patterns
+-- ---------------------------------------------------------------------------
+
+-- pattern0 ::= pattern1 [ gconop pattern0 ]
+pattern0 :: Parser a Token (Pattern ())
+pattern0 = pattern1 `chainr1` (flip (InfixPattern ()) <$> gconop)
+
+-- pattern1 ::= varId
+-- | QConId { pattern2 }
+-- | '-' Integer
+-- | '-.' Float
+-- | '(' parenPattern'
+-- | pattern2
+pattern1 :: Parser a Token (Pattern ())
+pattern1 = varId <**> identPattern' -- unqualified
+ <|> qConId <\> varId <**> constrPattern -- qualified
+ <|> minus <-*> negNum
+ <|> leftParen <-*> parenPattern'
+ <|> pattern2 <\> qConId <\> leftParen
+ where
+ identPattern' = optAsRecPattern
+ <|> mkConsPattern qualify <$> many1 pattern2
+
+ constrPattern = mkConsPattern id <$> many1 pattern2
+ <|> optRecPattern
+
+ mkConsPattern f ts c = ConstructorPattern () (f c) ts
+
+ parenPattern' = minus <**> minusPattern
+ <|> gconPattern
+ <|> funSym <\> minus <*-> rightParen <**> identPattern'
+ <|> parenTuplePattern <\> minus <*-> rightParen
+ minusPattern = rightParen <-*> identPattern'
+ <|> parenMinusPattern <*-> rightParen
+ gconPattern = ConstructorPattern () <$> gconId <*-> rightParen
+ <*> many pattern2
+
+pattern2 :: Parser a Token (Pattern ())
+pattern2 = literalPattern <|> anonPattern <|> identPattern
+ <|> parenPattern <|> listPattern <|> lazyPattern
+
+-- literalPattern ::= | | |
+literalPattern :: Parser a Token (Pattern ())
+literalPattern = LiteralPattern () <$> literal
+
+-- anonPattern ::= '_'
+anonPattern :: Parser a Token (Pattern ())
+anonPattern = VariablePattern () <$> anonIdent
+
+-- identPattern ::= Variable [ '@' pattern2 | '{' fields '}'
+-- | qConId [ '{' fields '}' ]
+identPattern :: Parser a Token (Pattern ())
+identPattern = varId <**> optAsRecPattern -- unqualified
+ <|> qConId <\> varId <**> optRecPattern -- qualified
+
+-- TODO: document me!
+parenPattern :: Parser a Token (Pattern ())
+parenPattern = leftParen <-*> parenPattern'
+ where
+ parenPattern' = minus <**> minusPattern
+ <|> flip (ConstructorPattern ()) [] <$> gconId <*-> rightParen
+ <|> funSym <\> minus <*-> rightParen <**> optAsRecPattern
+ <|> parenTuplePattern <\> minus <*-> rightParen
+ minusPattern = rightParen <-*> optAsRecPattern
+ <|> parenMinusPattern <*-> rightParen
+
+-- listPattern ::= '[' pattern0s ']'
+-- pattern0s ::= {- empty -}
+-- | pattern0 ',' pattern0s
+listPattern :: Parser a Token (Pattern ())
+listPattern = ListPattern () <$> brackets (pattern0 `sepBy` comma)
+
+-- lazyPattern ::= '~' pattern2
+lazyPattern :: Parser a Token (Pattern ())
+lazyPattern = LazyPattern <$-> token Tilde <*> pattern2
+
+-- optRecPattern ::= [ '{' fields '}' ]
+optRecPattern :: Parser a Token (QualIdent -> Pattern ())
+optRecPattern = mkRecPattern <$> fields pattern0 `opt` mkConPattern
+ where
+ mkRecPattern fs c = RecordPattern () c fs
+ mkConPattern c = ConstructorPattern () c []
+
+-- ---------------------------------------------------------------------------
+-- Partial patterns used in the combinators above, but also for parsing
+-- the left-hand side of a declaration.
+-- ---------------------------------------------------------------------------
+
+gconId :: Parser a Token QualIdent
+gconId = colon <|> tupleCommas
+
+negNum :: Parser a Token (Pattern ())
+negNum = NegativePattern ()
+ <$> (Int <$> integer <|> Float <$> float)
+
+optAsRecPattern :: Parser a Token (Ident -> Pattern ())
+optAsRecPattern = flip AsPattern <$-> token At <*> pattern2
+ <|> recPattern <$> fields pattern0
+ `opt` VariablePattern ()
+ where recPattern fs v = RecordPattern () (qualify v) fs
+
+optInfixPattern :: Parser a Token (Pattern () -> Pattern ())
+optInfixPattern = mkInfixPat <$> gconop <*> pattern0
+ `opt` id
+ where mkInfixPat op t2 t1 = InfixPattern () t1 op t2
+
+optTuplePattern :: Parser a Token (Pattern () -> Pattern ())
+optTuplePattern = tuple <$> many1 (comma <-*> pattern0)
+ `opt` ParenPattern
+ where tuple ts t = TuplePattern (t:ts)
+
+parenMinusPattern :: Parser a Token (Ident -> Pattern ())
+parenMinusPattern = const <$> negNum <.> optInfixPattern <.> optTuplePattern
+
+parenTuplePattern :: Parser a Token (Pattern ())
+parenTuplePattern = pattern0 <**> optTuplePattern
+ `opt` ConstructorPattern () qUnitId []
+
+-- ---------------------------------------------------------------------------
+-- Expressions
+-- ---------------------------------------------------------------------------
+
+-- condExpr ::= '|' expr0 eq expr
+--
+-- Note: The guard is an `expr0` instead of `expr` since conditional expressions
+-- may also occur in case expressions, and an expression like
+-- @
+-- case a of { _ -> True :: Bool -> a }
+-- @
+-- can not be parsed with a limited parser lookahead.
+condExpr :: Parser a Token b -> Parser a Token (CondExpr ())
+condExpr eq = CondExpr <$> position <*-> bar <*> expr0 <*-> eq <*> expr
+
+-- expr ::= expr0 [ '::' type0 ]
+expr :: Parser a Token (Expression ())
+expr = expr0 (flip Typed <$-> token DoubleColon <*> qualType)
+
+-- expr0 ::= expr1 { infixOp expr1 }
+expr0 :: Parser a Token (Expression ())
+expr0 = expr1 `chainr1` (flip InfixApply <$> infixOp)
+
+-- expr1 ::= - expr2 | -. expr2 | expr2
+expr1 :: Parser a Token (Expression ())
+expr1 = UnaryMinus <$-> minus <*> expr2
+ <|> expr2
+
+-- expr2 ::= lambdaExpr | letExpr | doExpr | ifExpr | caseExpr | expr3
+expr2 :: Parser a Token (Expression ())
+expr2 = choice [ lambdaExpr, letExpr, doExpr, ifExpr, caseExpr
+ , foldl1 Apply <$> many1 expr3
+ ]
+
+expr3 :: Parser a Token (Expression ())
+expr3 = foldl RecordUpdate <$> expr4 <*> many recUpdate
+ where recUpdate = layoutOff <-*> braces (field expr0 `sepBy1` comma)
+
+expr4 :: Parser a Token (Expression ())
+expr4 = choice
+ [constant, anonFreeVariable, variable, parenExpr, listExpr]
+
+constant :: Parser a Token (Expression ())
+constant = Literal () <$> literal
+
+anonFreeVariable :: Parser a Token (Expression ())
+anonFreeVariable = (\ p v -> Variable () $ qualify $ addPositionIdent p v)
+ <$> position <*> anonIdent
+
+variable :: Parser a Token (Expression ())
+variable = qFunId <**> optRecord
+ where optRecord = flip (Record ()) <$> fields expr0 `opt` Variable ()
+
+parenExpr :: Parser a Token (Expression ())
+parenExpr = parens pExpr
+ where
+ pExpr = minus <**> minusOrTuple
+ <|> Constructor () <$> tupleCommas
+ <|> leftSectionOrTuple <\> minus
+ <|> opOrRightSection <\> minus
+ `opt` Constructor () qUnitId
+ minusOrTuple = const . UnaryMinus <$> expr1 <.> infixOrTuple
+ `opt` Variable () . qualify
+ leftSectionOrTuple = expr1 <**> infixOrTuple
+ infixOrTuple = ($ id) <$> infixOrTuple'
+ infixOrTuple' = infixOp <**> leftSectionOrExp
+ <|> (.) <$> (optType <.> tupleExpr)
+ leftSectionOrExp = expr1 <**> (infixApp <$> infixOrTuple')
+ `opt` leftSection
+ optType = flip Typed <$-> token DoubleColon <*> qualType `opt` id
+ tupleExpr = tuple <$> many1 (comma <-*> expr) `opt` Paren
+ opOrRightSection = qFunSym <**> optRightSection
+ <|> colon <**> optCRightSection
+ <|> infixOp <\> colon <\> qFunSym <**> rightSection
+ optRightSection = (. InfixOp () ) <$> rightSection `opt` Variable ()
+ optCRightSection = (. InfixConstr ()) <$> rightSection `opt` Constructor ()
+ rightSection = flip RightSection <$> expr0
+ infixApp f e2 op g e1 = f (g . InfixApply e1 op) e2
+ leftSection op f e = LeftSection (f e) op
+ tuple es e = Tuple (e:es)
+
+infixOp :: Parser a Token (InfixOp ())
+infixOp = InfixOp () <$> qfunop <|> InfixConstr () <$> colon
+
+listExpr :: Parser a Token (Expression ())
+listExpr = brackets (elements `opt` List () [])
+ where
+ elements = expr <**> rest
+ rest = comprehension
+ <|> enumeration (flip EnumFromTo) EnumFrom
+ <|> comma <-*> expr <**>
+ (enumeration (flip3 EnumFromThenTo) (flip EnumFromThen)
+ <|> list <$> many (comma <-*> expr))
+ `opt` (\e -> List () [e])
+ comprehension = flip ListCompr <$-> bar <*> quals
+ enumeration enumTo enum =
+ token DotDot <-*> (enumTo <$> expr `opt` enum)
+ list es e2 e1 = List () (e1:e2:es)
+ flip3 f x y z = f z y x
+
+lambdaExpr :: Parser a Token (Expression ())
+lambdaExpr = Lambda <$-> token Backslash <*> many1 pattern2
+ <*-> expectRightArrow <*> expr
+
+letExpr :: Parser a Token (Expression ())
+letExpr = Let <$-> token KW_let <*> layout valueDecls
+ <*-> (token KW_in "in expected") <*> expr
+
+doExpr :: Parser a Token (Expression ())
+doExpr = uncurry Do <$-> token KW_do <*> layout stmts
+
+ifExpr :: Parser a Token (Expression ())
+ifExpr = IfThenElse
+ <$-> token KW_if <*> expr
+ <*-> (token KW_then "then expected") <*> expr
+ <*-> (token KW_else "else expected") <*> expr
+
+caseExpr :: Parser a Token (Expression ())
+caseExpr = keyword <*> expr
+ <*-> (token KW_of "of expected") <*> layout (alt `sepBy1` semicolon)
+ where keyword = Case Flex <$-> token KW_fcase
+ <|> Case Rigid <$-> token KW_case
+
+alt :: Parser a Token (Alt ())
+alt = Alt <$> position <*> pattern0 <*> rhs expectRightArrow
+
+fields :: Parser a Token b -> Parser a Token [Field b]
+fields p = layoutOff <-*> braces (field p `sepBy` comma)
+
+field :: Parser a Token b -> Parser a Token (Field b)
+field p = Field <$> position <*> qfun <*-> expectEquals <*> p
+
+-- ---------------------------------------------------------------------------
+-- \paragraph{Statements in list comprehensions and \texttt{do} expressions}
+-- Parsing statements is a bit difficult because the syntax of patterns
+-- and expressions largely overlaps. The parser will first try to
+-- recognize the prefix \emph{Pattern}~\texttt{<-} of a binding statement
+-- and if this fails fall back into parsing an expression statement. In
+-- addition, we have to be prepared that the sequence
+-- \texttt{let}~\emph{LocalDefs} can be either a let-statement or the
+-- prefix of a let expression.
+-- ---------------------------------------------------------------------------
+
+stmts :: Parser a Token ([Statement ()], Expression ())
+stmts = stmt reqStmts optStmts
+
+reqStmts :: Parser a Token (Statement () -> ([Statement ()], Expression ()))
+reqStmts = (\ (sts, e) st -> (st : sts, e)) <$-> semicolon <*> stmts
+
+optStmts :: Parser a Token (Expression () -> ([Statement ()], Expression ()))
+optStmts = succeed StmtExpr <.> reqStmts `opt` (,) []
+
+quals :: Parser a Token [Statement ()]
+quals = stmt (succeed id) (succeed StmtExpr) `sepBy1` comma
+
+stmt :: Parser a Token (Statement () -> b)
+ -> Parser a Token (Expression () -> b) -> Parser a Token b
+stmt stmtCont exprCont = letStmt stmtCont exprCont
+ <|> exprOrBindStmt stmtCont exprCont
+
+letStmt :: Parser a Token (Statement () -> b)
+ -> Parser a Token (Expression () -> b) -> Parser a Token b
+letStmt stmtCont exprCont = token KW_let <-*> layout valueDecls <**> optExpr
+ where optExpr = flip Let <$-> token KW_in <*> expr <.> exprCont
+ <|> succeed StmtDecl <.> stmtCont
+
+exprOrBindStmt :: Parser a Token (Statement () -> b)
+ -> Parser a Token (Expression () -> b)
+ -> Parser a Token b
+exprOrBindStmt stmtCont exprCont =
+ StmtBind <$> pattern0 <*-> leftArrow <*> expr <**> stmtCont
+ <|?> expr <\> token KW_let <**> exprCont
+
+-- ---------------------------------------------------------------------------
+-- Goals
+-- ---------------------------------------------------------------------------
+
+goal :: Parser a Token (Goal ())
+goal = Goal <$> position <*> expr <*> localDecls
+
+-- ---------------------------------------------------------------------------
+-- Literals, identifiers, and (infix) operators
+-- ---------------------------------------------------------------------------
+
+char :: Parser a Token Char
+char = cval <$> token CharTok
+
+float :: Parser a Token Double
+float = fval <$> token FloatTok
+
+int :: Parser a Token Int
+int = fromInteger <$> integer
+
+integer :: Parser a Token Integer
+integer = ival <$> token IntTok
+
+string :: Parser a Token String
+string = sval <$> token StringTok
+
+tycon :: Parser a Token Ident
+tycon = conId
+
+anonOrTyvar :: Parser a Token Ident
+anonOrTyvar = anonIdent <|> tyvar
+
+tyvar :: Parser a Token Ident
+tyvar = varId
+
+clsvar :: Parser a Token Ident
+clsvar = tyvar
+
+tycls :: Parser a Token Ident
+tycls = conId
+
+qtycls :: Parser a Token QualIdent
+qtycls = qConId
+
+qtycon :: Parser a Token QualIdent
+qtycon = qConId
+
+varId :: Parser a Token Ident
+varId = ident
+
+funId :: Parser a Token Ident
+funId = ident
+
+conId :: Parser a Token Ident
+conId = ident
+
+funSym :: Parser a Token Ident
+funSym = sym
+
+conSym :: Parser a Token Ident
+conSym = sym
+
+modIdent :: Parser a Token ModuleIdent
+modIdent = mIdent "module name expected"
+
+var :: Parser a Token Ident
+var = varId <|> parens (funSym "operator symbol expected")
+
+fun :: Parser a Token Ident
+fun = funId <|> parens (funSym "operator symbol expected")
+
+con :: Parser a Token Ident
+con = conId <|> parens (conSym "operator symbol expected")
+
+funop :: Parser a Token Ident
+funop = funSym <|> backquotes (funId "operator name expected")
+
+conop :: Parser a Token Ident
+conop = conSym <|> backquotes (conId "operator name expected")
+
+qFunId :: Parser a Token QualIdent
+qFunId = qIdent
+
+qConId :: Parser a Token QualIdent
+qConId = qIdent
+
+qFunSym :: Parser a Token QualIdent
+qFunSym = qSym
+
+qConSym :: Parser a Token QualIdent
+qConSym = qSym
+
+gConSym :: Parser a Token QualIdent
+gConSym = qConSym <|> colon
+
+qfun :: Parser a Token QualIdent
+qfun = qFunId <|> parens (qFunSym "operator symbol expected")
+
+qfunop :: Parser a Token QualIdent
+qfunop = qFunSym <|> backquotes (qFunId "operator name expected")
+
+gconop :: Parser a Token QualIdent
+gconop = gConSym <|> backquotes (qConId "operator name expected")
+
+anonIdent :: Parser a Token Ident
+anonIdent = (\ p -> addPositionIdent p anonId) <$> tokenPos Underscore
+
+mIdent :: Parser a Token ModuleIdent
+mIdent = mIdent' <$> position <*>
+ tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding,
+ Id_interface,Id_primitive,Id_qualified]
+ where mIdent' p a = addPositionModuleIdent p $
+ mkMIdent (modulVal a ++ [sval a])
+
+ident :: Parser a Token Ident
+ident = (\ pos -> mkIdentPosition pos . sval) <$> position <*>
+ tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,
+ Id_interface,Id_primitive,Id_qualified]
+
+qIdent :: Parser a Token QualIdent
+qIdent = qualify <$> ident
+ <|> mkQIdent <$> position <*> token QId
+ where mkQIdent p a = qualifyWith (mkMIdent (modulVal a))
+ (mkIdentPosition p (sval a))
+
+sym :: Parser a Token Ident
+sym = (\ pos -> mkIdentPosition pos . sval) <$> position <*>
+ tokens [Sym, SymDot, SymMinus, SymStar]
+
+qSym :: Parser a Token QualIdent
+qSym = qualify <$> sym <|> mkQIdent <$> position <*> token QSym
+ where mkQIdent p a = qualifyWith (mkMIdent (modulVal a))
+ (mkIdentPosition p (sval a))
+
+colon :: Parser a Token QualIdent
+colon = (\ p -> qualify $ addPositionIdent p consId) <$> tokenPos Colon
+
+minus :: Parser a Token Ident
+minus = (\ p -> addPositionIdent p minusId) <$> tokenPos SymMinus
+
+tupleCommas :: Parser a Token QualIdent
+tupleCommas = (\ p -> qualify . addPositionIdent p . tupleId . succ . length)
+ <$> position <*> many1 comma
+
+-- ---------------------------------------------------------------------------
+-- Layout
+-- ---------------------------------------------------------------------------
+
+-- |This function starts a new layout block but does not wait for its end.
+-- This is only used for parsing the module header.
+startLayout :: Parser a Token b -> Parser a Token b
+startLayout p = layoutOff <-*> leftBrace <-*> p
+ <|> layoutOn <-*> p
+
+layout :: Parser a Token b -> Parser a Token b
+layout p = layoutOff <-*> braces p
+ <|> layoutOn <-*> p <*-> (token VRightBrace <|> layoutEnd)
+
+-- ---------------------------------------------------------------------------
+-- Bracket combinators
+-- ---------------------------------------------------------------------------
+
+braces :: Parser a Token b -> Parser a Token b
+braces p = between leftBrace p rightBrace
+
+brackets :: Parser a Token b -> Parser a Token b
+brackets p = between leftBracket p rightBracket
+
+parens :: Parser a Token b -> Parser a Token b
+parens p = between leftParen p rightParen
+
+backquotes :: Parser a Token b -> Parser a Token b
+backquotes p = between backquote p expectBackquote
+
+-- ---------------------------------------------------------------------------
+-- Simple token parsers
+-- ---------------------------------------------------------------------------
+
+token :: Category -> Parser a Token Attributes
+token c = attr <$> symbol (Token c NoAttributes)
+ where attr (Token _ a) = a
+
+tokens :: [Category] -> Parser a Token Attributes
+tokens = foldr1 (<|>) . map token
+
+tokenPos :: Category -> Parser a Token Position
+tokenPos c = position <*-> token c
+
+tokenOps :: [(Category, b)] -> Parser a Token b
+tokenOps cs = ops [(Token c NoAttributes, x) | (c, x) <- cs]
+
+comma :: Parser a Token Attributes
+comma = token Comma
+
+dot :: Parser a Token Attributes
+dot = token SymDot
+
+semicolon :: Parser a Token Attributes
+semicolon = token Semicolon <|> token VSemicolon
+
+bar :: Parser a Token Attributes
+bar = token Bar
+
+equals :: Parser a Token Attributes
+equals = token Equals
+
+expectEquals :: Parser a Token Attributes
+expectEquals = equals "= expected"
+
+expectWhere :: Parser a Token Attributes
+expectWhere = token KW_where "where expected"
+
+expectRightArrow :: Parser a Token Attributes
+expectRightArrow = token RightArrow "-> expected"
+
+backquote :: Parser a Token Attributes
+backquote = token Backquote
+
+expectBackquote :: Parser a Token Attributes
+expectBackquote = backquote "backquote (`) expected"
+
+leftParen :: Parser a Token Attributes
+leftParen = token LeftParen
+
+rightParen :: Parser a Token Attributes
+rightParen = token RightParen
+
+leftBracket :: Parser a Token Attributes
+leftBracket = token LeftBracket
+
+rightBracket :: Parser a Token Attributes
+rightBracket = token RightBracket
+
+leftBrace :: Parser a Token Attributes
+leftBrace = token LeftBrace
+
+rightBrace :: Parser a Token Attributes
+rightBrace = token RightBrace
+
+leftArrow :: Parser a Token Attributes
+leftArrow = token LeftArrow
+
+-- ---------------------------------------------------------------------------
+-- Ident
+-- ---------------------------------------------------------------------------
+
+mkIdentPosition :: Position -> String -> Ident
+mkIdentPosition pos = addPositionIdent pos . mkIdent
diff --git a/src/Curry/Syntax/Pretty.hs b/src/Curry/Syntax/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Syntax/Pretty.hs
@@ -0,0 +1,466 @@
+{- |
+ Module : $Header$
+ Description : A pretty printer for Curry
+ Copyright : (c) 1999 - 2004 Wolfgang Lux
+ 2005 Martin Engelke
+ 2011 - 2015 Björn Peemöller
+ 2016 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module implements a pretty printer for Curry expressions. It was
+ derived from the Haskell pretty printer provided in Simon Marlow's
+ Haskell parser.
+-}
+module Curry.Syntax.Pretty
+ ( ppModule, ppInterface, ppIDecl, ppDecl, ppIdent, ppPattern, ppFieldPatt
+ , ppExpr, ppOp, ppStmt, ppFieldExpr, ppQualTypeExpr, ppTypeExpr, ppKindExpr
+ , ppAlt, ppQIdent, ppConstraint, ppInstanceType, ppConstr, ppNewConstr
+ , ppFieldDecl, ppEquation, ppMIdent
+ ) where
+
+import Curry.Base.Ident
+import Curry.Base.Pretty
+
+import Curry.Syntax.Type
+import Curry.Syntax.Utils (opName)
+
+-- |Pretty print a module
+ppModule :: Module a -> Doc
+ppModule (Module ps m es is ds) = ppModuleHeader ps m es is $$ ppSepBlock ds
+
+ppModuleHeader :: [ModulePragma] -> ModuleIdent -> Maybe ExportSpec
+ -> [ImportDecl] -> Doc
+ppModuleHeader ps m es is
+ | null is = header
+ | otherwise = header $+$ text "" $+$ (vcat $ map ppImportDecl is)
+ where header = (vcat $ map ppModulePragma ps)
+ $+$ text "module" <+> ppMIdent m
+ <+> maybePP ppExportSpec es <+> text "where"
+
+ppModulePragma :: ModulePragma -> Doc
+ppModulePragma (LanguagePragma _ exts) =
+ ppPragma "LANGUAGE" $ list $ map ppExtension exts
+ppModulePragma (OptionsPragma _ tool args) =
+ ppPragma "OPTIONS" $ maybe empty ((text "_" <>) . ppTool) tool <+> text args
+
+ppPragma :: String -> Doc -> Doc
+ppPragma kw doc = text "{-#" <+> text kw <+> doc <+> text "#-}"
+
+ppExtension :: Extension -> Doc
+ppExtension (KnownExtension _ e) = text (show e)
+ppExtension (UnknownExtension _ e) = text e
+
+ppTool :: Tool -> Doc
+ppTool (UnknownTool t) = text t
+ppTool t = text (show t)
+
+ppExportSpec :: ExportSpec -> Doc
+ppExportSpec (Exporting _ es) = parenList (map ppExport es)
+
+ppExport :: Export -> Doc
+ppExport (Export x) = ppQIdent x
+ppExport (ExportTypeWith tc cs) = ppQIdent tc <> parenList (map ppIdent cs)
+ppExport (ExportTypeAll tc) = ppQIdent tc <> text "(..)"
+ppExport (ExportModule m) = text "module" <+> ppMIdent m
+
+ppImportDecl :: ImportDecl -> Doc
+ppImportDecl (ImportDecl _ m q asM is) =
+ text "import" <+> ppQualified q <+> ppMIdent m <+> maybePP ppAs asM
+ <+> maybePP ppImportSpec is
+ where ppQualified q' = if q' then text "qualified" else empty
+ ppAs m' = text "as" <+> ppMIdent m'
+
+ppImportSpec :: ImportSpec -> Doc
+ppImportSpec (Importing _ is) = parenList (map ppImport is)
+ppImportSpec (Hiding _ is) = text "hiding" <+> parenList (map ppImport is)
+
+ppImport :: Import -> Doc
+ppImport (Import x) = ppIdent x
+ppImport (ImportTypeWith tc cs) = ppIdent tc <> parenList (map ppIdent cs)
+ppImport (ImportTypeAll tc) = ppIdent tc <> text "(..)"
+
+ppBlock :: [Decl a] -> Doc
+ppBlock = vcat . map ppDecl
+
+ppSepBlock :: [Decl a] -> Doc
+ppSepBlock = vcat . map (\d -> text "" $+$ ppDecl d)
+
+-- |Pretty print a declaration
+ppDecl :: Decl a -> Doc
+ppDecl (InfixDecl _ fix p ops) = ppPrec fix p <+> list (map ppInfixOp ops)
+ppDecl (DataDecl _ tc tvs cs clss) =
+ sep (ppTypeDeclLhs "data" tc tvs :
+ map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs) ++
+ [ppDeriving clss]))
+ppDecl (ExternalDataDecl _ tc tvs) = ppTypeDeclLhs "external data" tc tvs
+ppDecl (NewtypeDecl _ tc tvs nc clss) =
+ sep (ppTypeDeclLhs "newtype" tc tvs <+> equals :
+ map indent [ppNewConstr nc, ppDeriving clss])
+ppDecl (TypeDecl _ tc tvs ty) =
+ sep [ppTypeDeclLhs "type" tc tvs <+> equals,indent (ppTypeExpr 0 ty)]
+ppDecl (TypeSig _ fs qty) =
+ list (map ppIdent fs) <+> text "::" <+> ppQualTypeExpr qty
+ppDecl (FunctionDecl _ _ _ eqs) = vcat (map ppEquation eqs)
+ppDecl (ExternalDecl _ vs) = list (map ppVar vs) <+> text "external"
+ppDecl (PatternDecl _ t rhs) = ppRule (ppPattern 0 t) equals rhs
+ppDecl (FreeDecl _ vs) = list (map ppVar vs) <+> text "free"
+ppDecl (DefaultDecl _ tys) =
+ text "default" <+> parenList (map (ppTypeExpr 0) tys)
+ppDecl (ClassDecl _ cx cls clsvar ds) =
+ ppClassInstHead "class" cx (ppIdent cls) (ppIdent clsvar) <+>
+ ppIf (not $ null ds) (text "where") $$
+ ppIf (not $ null ds) (indent $ ppBlock ds)
+ppDecl (InstanceDecl _ cx qcls inst ds) =
+ ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+>
+ ppIf (not $ null ds) (text "where") $$
+ ppIf (not $ null ds) (indent $ ppBlock ds)
+
+ppClassInstHead :: String -> Context -> Doc -> Doc -> Doc
+ppClassInstHead kw cx cls ty = text kw <+> ppContext cx <+> cls <+> ty
+
+ppContext :: Context -> Doc
+ppContext [] = empty
+ppContext [c] = ppConstraint c <+> darrow
+ppContext cs = parenList (map ppConstraint cs) <+> darrow
+
+ppConstraint :: Constraint -> Doc
+ppConstraint (Constraint qcls ty) = ppQIdent qcls <+> ppTypeExpr 2 ty
+
+ppInstanceType :: InstanceType -> Doc
+ppInstanceType = ppTypeExpr 2
+
+ppDeriving :: [QualIdent] -> Doc
+ppDeriving [] = empty
+ppDeriving [qcls] = text "deriving" <+> ppQIdent qcls
+ppDeriving qclss = text "deriving" <+> parenList (map ppQIdent qclss)
+
+ppPrec :: Infix -> Maybe Precedence -> Doc
+ppPrec fix p = pPrint fix <+> ppPrio p
+ where
+ ppPrio Nothing = empty
+ ppPrio (Just p') = integer p'
+
+ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc
+ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs)
+
+ppConstr :: ConstrDecl -> Doc
+ppConstr (ConstrDecl _ tvs cx c tys) =
+ sep [ ppQuantifiedVars tvs <+> ppContext cx
+ , ppIdent c <+> fsep (map (ppTypeExpr 2) tys)
+ ]
+ppConstr (ConOpDecl _ tvs cx ty1 op ty2) =
+ sep [ ppQuantifiedVars tvs <+> ppContext cx
+ , ppTypeExpr 1 ty1, ppInfixOp op <+> ppTypeExpr 1 ty2
+ ]
+ppConstr (RecordDecl _ tvs cx c fs) =
+ sep [ ppQuantifiedVars tvs <+> ppContext cx
+ , ppIdent c <+> record (list (map ppFieldDecl fs))
+ ]
+
+ppFieldDecl :: FieldDecl -> Doc
+ppFieldDecl (FieldDecl _ ls ty) = list (map ppIdent ls)
+ <+> text "::" <+> ppTypeExpr 0 ty
+
+ppNewConstr :: NewConstrDecl -> Doc
+ppNewConstr (NewConstrDecl _ c ty) = sep [ppIdent c <+> ppTypeExpr 2 ty]
+ppNewConstr (NewRecordDecl _ c (i,ty)) =
+ sep [ppIdent c <+> record (ppIdent i <+> text "::" <+> ppTypeExpr 0 ty)]
+
+ppQuantifiedVars :: [Ident] -> Doc
+ppQuantifiedVars tvs
+ | null tvs = empty
+ | otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.'
+
+ppEquation :: Equation a -> Doc
+ppEquation (Equation _ lhs rhs) = ppRule (ppLhs lhs) equals rhs
+
+ppLhs :: Lhs a -> Doc
+ppLhs (FunLhs f ts) = ppIdent f <+> fsep (map (ppPattern 2) ts)
+ppLhs (OpLhs t1 f t2) = ppPattern 1 t1 <+> ppInfixOp f <+> ppPattern 1 t2
+ppLhs (ApLhs lhs ts) = parens (ppLhs lhs) <+> fsep (map (ppPattern 2) ts)
+
+ppRule :: Doc -> Doc -> Rhs a -> Doc
+ppRule lhs eq (SimpleRhs _ e ds) =
+ sep [lhs <+> eq, indent (ppExpr 0 e)] $$ ppLocalDefs ds
+ppRule lhs eq (GuardedRhs es ds) =
+ sep [lhs, indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds
+
+ppLocalDefs :: [Decl a] -> Doc
+ppLocalDefs ds
+ | null ds = empty
+ | otherwise = indent (text "where" <+> ppBlock ds)
+
+-- ---------------------------------------------------------------------------
+-- Interfaces
+-- ---------------------------------------------------------------------------
+
+-- |Pretty print an interface
+ppInterface :: Interface -> Doc
+ppInterface (Interface m is ds)
+ = text "interface" <+> ppMIdent m <+> text "where" <+> lbrace
+ $$ vcat (punctuate semi $ map ppIImportDecl is ++ map ppIDecl ds)
+ $$ rbrace
+
+ppIImportDecl :: IImportDecl -> Doc
+ppIImportDecl (IImportDecl _ m) = text "import" <+> ppMIdent m
+
+-- |Pretty print an interface declaration
+ppIDecl :: IDecl -> Doc
+ppIDecl (IInfixDecl _ fix p op) = ppPrec fix (Just p) <+> ppQInfixOp op
+ppIDecl (HidingDataDecl _ tc k tvs) =
+ text "hiding" <+> ppITypeDeclLhs "data" tc k tvs
+ppIDecl (IDataDecl _ tc k tvs cs hs) =
+ sep (ppITypeDeclLhs "data" tc k tvs :
+ map indent (zipWith (<+>) (equals : repeat vbar) (map ppConstr cs)) ++
+ [indent (ppHiding hs)])
+ppIDecl (INewtypeDecl _ tc k tvs nc hs) =
+ sep [ ppITypeDeclLhs "newtype" tc k tvs <+> equals
+ , indent (ppNewConstr nc)
+ , indent (ppHiding hs)
+ ]
+ppIDecl (ITypeDecl _ tc k tvs ty) =
+ sep [ppITypeDeclLhs "type" tc k tvs <+> equals,indent (ppTypeExpr 0 ty)]
+ppIDecl (IFunctionDecl _ f cm a qty) =
+ sep [ ppQIdent f, maybePP (ppPragma "METHOD" . ppIdent) cm
+ , int a, text "::", ppQualTypeExpr qty ]
+ppIDecl (HidingClassDecl _ cx qcls k clsvar) = text "hiding" <+>
+ ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar)
+ppIDecl (IClassDecl _ cx qcls k clsvar ms hs) =
+ ppClassInstHead "class" cx (ppQIdentWithKind qcls k) (ppIdent clsvar) <+>
+ lbrace $$
+ vcat (punctuate semi $ map (indent . ppIMethodDecl) ms) $$
+ rbrace <+> ppHiding hs
+ppIDecl (IInstanceDecl _ cx qcls inst impls m) =
+ ppClassInstHead "instance" cx (ppQIdent qcls) (ppInstanceType inst) <+>
+ lbrace $$
+ vcat (punctuate semi $ map (indent . ppIMethodImpl) impls) $$
+ rbrace <+> maybePP (ppPragma "MODULE" . ppMIdent) m
+
+ppITypeDeclLhs :: String -> QualIdent -> Maybe KindExpr -> [Ident] -> Doc
+ppITypeDeclLhs kw tc k tvs =
+ text kw <+> ppQIdentWithKind tc k <+> hsep (map ppIdent tvs)
+
+ppIMethodDecl :: IMethodDecl -> Doc
+ppIMethodDecl (IMethodDecl _ f a qty) =
+ ppIdent f <+> maybePP int a <+> text "::" <+> ppQualTypeExpr qty
+
+ppIMethodImpl :: IMethodImpl -> Doc
+ppIMethodImpl (f, a) = ppIdent f <+> int a
+
+ppQIdentWithKind :: QualIdent -> Maybe KindExpr -> Doc
+ppQIdentWithKind tc (Just k) = parens $ ppQIdent tc <+> text "::" <+> ppKindExpr 0 k
+ppQIdentWithKind tc Nothing = ppQIdent tc
+
+ppHiding :: [Ident] -> Doc
+ppHiding hs
+ | null hs = empty
+ | otherwise = ppPragma "HIDING" $ list $ map ppIdent hs
+
+-- ---------------------------------------------------------------------------
+-- Kinds
+-- ---------------------------------------------------------------------------
+
+ppKindExpr :: Int -> KindExpr -> Doc
+ppKindExpr _ Star = char '*'
+ppKindExpr p (ArrowKind k1 k2) =
+ parenIf (p > 0) (fsep (ppArrowKind (ArrowKind k1 k2)))
+ where
+ ppArrowKind (ArrowKind k1' k2') = ppKindExpr 1 k1' <+> rarrow : ppArrowKind k2'
+ ppArrowKind k = [ppKindExpr 0 k]
+
+-- ---------------------------------------------------------------------------
+-- Types
+-- ---------------------------------------------------------------------------
+
+-- |Pretty print a qualified type expression
+ppQualTypeExpr :: QualTypeExpr -> Doc
+ppQualTypeExpr (QualTypeExpr cx ty) = ppContext cx <+> ppTypeExpr 0 ty
+
+-- |Pretty print a type expression
+ppTypeExpr :: Int -> TypeExpr -> Doc
+ppTypeExpr _ (ConstructorType tc) = ppQIdent tc
+ppTypeExpr p (ApplyType ty1 ty2) = parenIf (p > 1) (ppApplyType ty1 [ty2])
+ where ppApplyType (ApplyType ty1' ty2') tys = ppApplyType ty1' (ty2' : tys)
+ ppApplyType ty tys =
+ ppTypeExpr 1 ty <+> fsep (map (ppTypeExpr 2) tys)
+ppTypeExpr _ (VariableType tv) = ppIdent tv
+ppTypeExpr _ (TupleType tys) = parenList (map (ppTypeExpr 0) tys)
+ppTypeExpr _ (ListType ty) = brackets (ppTypeExpr 0 ty)
+ppTypeExpr p (ArrowType ty1 ty2) = parenIf (p > 0)
+ (fsep (ppArrowType (ArrowType ty1 ty2)))
+ where
+ ppArrowType (ArrowType ty1' ty2') =
+ ppTypeExpr 1 ty1' <+> rarrow : ppArrowType ty2'
+ ppArrowType ty = [ppTypeExpr 0 ty]
+ppTypeExpr _ (ParenType ty) = parens (ppTypeExpr 0 ty)
+ppTypeExpr p (ForallType vs ty)
+ | null vs = ppTypeExpr p ty
+ | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr 0 ty
+
+-- ---------------------------------------------------------------------------
+-- Literals
+-- ---------------------------------------------------------------------------
+
+ppLiteral :: Literal -> Doc
+ppLiteral (Char c) = text (show c)
+ppLiteral (Int i) = integer i
+ppLiteral (Float f) = double f
+ppLiteral (String s) = text (show s)
+
+-- ---------------------------------------------------------------------------
+-- Patterns
+-- ---------------------------------------------------------------------------
+
+-- |Pretty print a constructor term
+ppPattern :: Int -> Pattern a -> Doc
+ppPattern p (LiteralPattern _ l) = parenIf (p > 1 && isNegative l) (ppLiteral l)
+ where isNegative (Char _) = False
+ isNegative (Int i) = i < 0
+ isNegative (Float f) = f < 0.0
+ isNegative (String _) = False
+ppPattern p (NegativePattern _ l) = parenIf (p > 1)
+ (ppInfixOp minusId <> ppLiteral l)
+ppPattern _ (VariablePattern _ v) = ppIdent v
+ppPattern p (ConstructorPattern _ c ts) = parenIf (p > 1 && not (null ts))
+ (ppQIdent c <+> fsep (map (ppPattern 2) ts))
+ppPattern p (InfixPattern _ t1 c t2) = parenIf (p > 0)
+ (sep [ppPattern 1 t1 <+> ppQInfixOp c, indent (ppPattern 0 t2)])
+ppPattern _ (ParenPattern t) = parens (ppPattern 0 t)
+ppPattern _ (TuplePattern ts) = parenList (map (ppPattern 0) ts)
+ppPattern _ (ListPattern _ ts) = bracketList (map (ppPattern 0) ts)
+ppPattern _ (AsPattern v t) = ppIdent v <> char '@' <> ppPattern 2 t
+ppPattern _ (LazyPattern t) = char '~' <> ppPattern 2 t
+ppPattern p (FunctionPattern _ f ts) = parenIf (p > 1 && not (null ts))
+ (ppQIdent f <+> fsep (map (ppPattern 2) ts))
+ppPattern p (InfixFuncPattern _ t1 f t2) = parenIf (p > 0)
+ (sep [ppPattern 1 t1 <+> ppQInfixOp f, indent (ppPattern 0 t2)])
+ppPattern p (RecordPattern _ c fs) = parenIf (p > 1)
+ (ppQIdent c <+> record (list (map ppFieldPatt fs)))
+
+-- |Pretty print a record field pattern
+ppFieldPatt :: Field (Pattern a) -> Doc
+ppFieldPatt (Field _ l t) = ppQIdent l <+> equals <+> ppPattern 0 t
+
+-- ---------------------------------------------------------------------------
+-- Expressions
+-- ---------------------------------------------------------------------------
+
+ppCondExpr :: Doc -> CondExpr a -> Doc
+ppCondExpr eq (CondExpr _ g e) =
+ vbar <+> sep [ppExpr 0 g <+> eq,indent (ppExpr 0 e)]
+
+-- |Pretty print an expression
+ppExpr :: Int -> Expression a -> Doc
+ppExpr _ (Literal _ l) = ppLiteral l
+ppExpr _ (Variable _ v) = ppQIdent v
+ppExpr _ (Constructor _ c) = ppQIdent c
+ppExpr _ (Paren e) = parens (ppExpr 0 e)
+ppExpr p (Typed e qty) =
+ parenIf (p > 0) (ppExpr 0 e <+> text "::" <+> ppQualTypeExpr qty)
+ppExpr _ (Tuple es) = parenList (map (ppExpr 0) es)
+ppExpr _ (List _ es) = bracketList (map (ppExpr 0) es)
+ppExpr _ (ListCompr e qs) =
+ brackets (ppExpr 0 e <+> vbar <+> list (map ppStmt qs))
+ppExpr _ (EnumFrom e) = brackets (ppExpr 0 e <+> text "..")
+ppExpr _ (EnumFromThen e1 e2) =
+ brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2 <+> text "..")
+ppExpr _ (EnumFromTo e1 e2) =
+ brackets (ppExpr 0 e1 <+> text ".." <+> ppExpr 0 e2)
+ppExpr _ (EnumFromThenTo e1 e2 e3) =
+ brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2
+ <+> text ".." <+> ppExpr 0 e3)
+ppExpr p (UnaryMinus e) =
+ parenIf (p > 1) (ppInfixOp minusId <> ppExpr 1 e)
+ppExpr p (Apply e1 e2) =
+ parenIf (p > 1) (sep [ppExpr 1 e1,indent (ppExpr 2 e2)])
+ppExpr p (InfixApply e1 op e2) =
+ parenIf (p > 0) (sep [ppExpr 1 e1 <+> ppQInfixOp (opName op),
+ indent (ppExpr 1 e2)])
+ppExpr _ (LeftSection e op) = parens (ppExpr 1 e <+> ppQInfixOp (opName op))
+ppExpr _ (RightSection op e) = parens (ppQInfixOp (opName op) <+> ppExpr 1 e)
+ppExpr p (Lambda t e) = parenIf (p > 0)
+ (sep [backsl <> fsep (map (ppPattern 2) t) <+> rarrow, indent (ppExpr 0 e)])
+ppExpr p (Let ds e) = parenIf (p > 0)
+ (sep [text "let" <+> ppBlock ds, text "in" <+> ppExpr 0 e])
+ppExpr p (Do sts e) = parenIf (p > 0)
+ (text "do" <+> (vcat (map ppStmt sts) $$ ppExpr 0 e))
+ppExpr p (IfThenElse e1 e2 e3) = parenIf (p > 0)
+ (text "if" <+>
+ sep [ppExpr 0 e1,
+ text "then" <+> ppExpr 0 e2,
+ text "else" <+> ppExpr 0 e3])
+ppExpr p (Case ct e alts) = parenIf (p > 0)
+ (ppCaseType ct <+> ppExpr 0 e <+> text "of" $$
+ indent (vcat (map ppAlt alts)))
+ppExpr p (Record _ c fs) = parenIf (p > 0)
+ (ppQIdent c <+> record (list (map ppFieldExpr fs)))
+ppExpr _ (RecordUpdate e fs) =
+ ppExpr 0 e <+> record (list (map ppFieldExpr fs))
+
+-- |Pretty print a statement
+ppStmt :: Statement a -> Doc
+ppStmt (StmtExpr e) = ppExpr 0 e
+ppStmt (StmtBind t e) = sep [ppPattern 0 t <+> larrow,indent (ppExpr 0 e)]
+ppStmt (StmtDecl ds) = text "let" <+> ppBlock ds
+
+ppCaseType :: CaseType -> Doc
+ppCaseType Rigid = text "case"
+ppCaseType Flex = text "fcase"
+
+-- |Pretty print an alternative in a case expression
+ppAlt :: Alt a -> Doc
+ppAlt (Alt _ t rhs) = ppRule (ppPattern 0 t) rarrow rhs
+
+-- |Pretty print a free variable
+ppVar :: Var a -> Doc
+ppVar (Var _ ident) = ppIdent ident
+
+-- |Pretty print a record field expression (Haskell syntax)
+ppFieldExpr :: Field (Expression a) -> Doc
+ppFieldExpr (Field _ l e) = ppQIdent l <+> equals <+> ppExpr 0 e
+
+-- |Pretty print an operator
+ppOp :: InfixOp a -> Doc
+ppOp (InfixOp _ op) = ppQInfixOp op
+ppOp (InfixConstr _ op) = ppQInfixOp op
+
+-- ---------------------------------------------------------------------------
+-- Names
+-- ---------------------------------------------------------------------------
+
+-- |Pretty print an identifier
+ppIdent :: Ident -> Doc
+ppIdent x = parenIf (isInfixOp x) (text (idName x))
+
+ppQIdent :: QualIdent -> Doc
+ppQIdent x = parenIf (isQInfixOp x) (text (qualName x))
+
+ppInfixOp :: Ident -> Doc
+ppInfixOp x = bquotesIf (not (isInfixOp x)) (text (idName x))
+
+ppQInfixOp :: QualIdent -> Doc
+ppQInfixOp x = bquotesIf (not (isQInfixOp x)) (text (qualName x))
+
+ppMIdent :: ModuleIdent -> Doc
+ppMIdent m = text (moduleName m)
+
+-- ---------------------------------------------------------------------------
+-- Print printing utilities
+-- ---------------------------------------------------------------------------
+
+indent :: Doc -> Doc
+indent = nest 2
+
+parenList :: [Doc] -> Doc
+parenList = parens . list
+
+record :: Doc -> Doc
+record doc | isEmpty doc = braces empty
+ | otherwise = braces $ space <> doc <> space
+
+bracketList :: [Doc] -> Doc
+bracketList = brackets . list
diff --git a/src/Curry/Syntax/ShowModule.hs b/src/Curry/Syntax/ShowModule.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Syntax/ShowModule.hs
@@ -0,0 +1,689 @@
+{- |
+ Module : $Header$
+ Copyright : (c) 2008 Sebastian Fischer
+ 2011 - 2015 Björn Peemöller
+ 2016 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ Transform a CurrySyntax module into a string representation without any
+ pretty printing.
+
+ Behaves like a derived Show instance even on parts with a specific one.
+-}
+module Curry.Syntax.ShowModule (showModule) where
+
+import Curry.Base.Ident
+import Curry.Base.Position
+
+import Curry.Syntax.Type
+
+-- |Show a Curry module like by an devired 'Show' instance
+showModule :: Show a => Module a -> String
+showModule m = showsModule m "\n"
+
+showsModule :: Show a => Module a -> ShowS
+showsModule (Module ps mident espec imps decls)
+ = showsString "Module "
+ . showsList (\p -> showsPragma p . newline) ps . space
+ . showsModuleIdent mident . newline
+ . showsMaybe showsExportSpec espec . newline
+ . showsList (\i -> showsImportDecl i . newline) imps
+ . showsList (\d -> showsDecl d . newline) decls
+
+showsPragma :: ModulePragma -> ShowS
+showsPragma (LanguagePragma pos exts)
+ = showsString "(LanguagePragma "
+ . showsPosition pos . space
+ . showsList showsExtension exts
+ . showsString ")"
+showsPragma (OptionsPragma pos mbTool args)
+ = showsString "(OptionsPragma "
+ . showsPosition pos . space
+ . showsMaybe shows mbTool
+ . shows args
+ . showsString ")"
+
+showsExtension :: Extension -> ShowS
+showsExtension (KnownExtension p e)
+ = showsString "(KnownExtension "
+ . showsPosition p . space
+ . shows e
+ . showString ")"
+showsExtension (UnknownExtension p s)
+ = showsString "(UnknownExtension "
+ . showsPosition p . space
+ . shows s
+ . showString ")"
+
+showsExportSpec :: ExportSpec -> ShowS
+showsExportSpec (Exporting pos exports)
+ = showsString "(Exporting "
+ . showsPosition pos . space
+ . showsList showsExport exports
+ . showsString ")"
+
+showsExport :: Export -> ShowS
+showsExport (Export qident)
+ = showsString "(Export "
+ . showsQualIdent qident
+ . showsString ")"
+showsExport (ExportTypeWith qident ids)
+ = showsString "(ExportTypeWith "
+ . showsQualIdent qident . space
+ . showsList showsIdent ids
+ . showsString ")"
+showsExport (ExportTypeAll qident)
+ = showsString "(ExportTypeAll "
+ . showsQualIdent qident
+ . showsString ")"
+showsExport (ExportModule m)
+ = showsString "(ExportModule "
+ . showsModuleIdent m
+ . showsString ")"
+
+showsImportDecl :: ImportDecl -> ShowS
+showsImportDecl (ImportDecl pos mident quali mmident mimpspec)
+ = showsString "(ImportDecl "
+ . showsPosition pos . space
+ . showsModuleIdent mident . space
+ . shows quali . space
+ . showsMaybe showsModuleIdent mmident . space
+ . showsMaybe showsImportSpec mimpspec
+ . showsString ")"
+
+showsImportSpec :: ImportSpec -> ShowS
+showsImportSpec (Importing pos imports)
+ = showsString "(Importing "
+ . showsPosition pos . space
+ . showsList showsImport imports
+ . showsString ")"
+showsImportSpec (Hiding pos imports)
+ = showsString "(Hiding "
+ . showsPosition pos . space
+ . showsList showsImport imports
+ . showsString ")"
+
+showsImport :: Import -> ShowS
+showsImport (Import ident)
+ = showsString "(Import "
+ . showsIdent ident
+ . showsString ")"
+showsImport (ImportTypeWith ident idents)
+ = showsString "(ImportTypeWith "
+ . showsIdent ident . space
+ . showsList showsIdent idents
+ . showsString ")"
+showsImport (ImportTypeAll ident)
+ = showsString "(ImportTypeAll "
+ . showsIdent ident
+ . showsString ")"
+
+showsDecl :: Show a => Decl a -> ShowS
+showsDecl (InfixDecl pos infx prec idents)
+ = showsString "(InfixDecl "
+ . showsPosition pos . space
+ . shows infx . space
+ . showsMaybe shows prec . space
+ . showsList showsIdent idents
+ . showsString ")"
+showsDecl (DataDecl pos ident idents consdecls classes)
+ = showsString "(DataDecl "
+ . showsPosition pos . space
+ . showsIdent ident . space
+ . showsList showsIdent idents . space
+ . showsList showsConsDecl consdecls . space
+ . showsList showsQualIdent classes
+ . showsString ")"
+showsDecl (ExternalDataDecl pos ident idents)
+ = showsString "(ExternalDataDecl "
+ . showsPosition pos . space
+ . showsIdent ident . space
+ . showsList showsIdent idents
+ . showsString ")"
+showsDecl (NewtypeDecl pos ident idents newconsdecl classes)
+ = showsString "(NewtypeDecl "
+ . showsPosition pos . space
+ . showsIdent ident . space
+ . showsList showsIdent idents . space
+ . showsNewConsDecl newconsdecl . space
+ . showsList showsQualIdent classes
+ . showsString ")"
+showsDecl (TypeDecl pos ident idents typ)
+ = showsString "(TypeDecl "
+ . showsPosition pos . space
+ . showsIdent ident . space
+ . showsList showsIdent idents . space
+ . showsTypeExpr typ
+ . showsString ")"
+showsDecl (TypeSig pos idents qtype)
+ = showsString "(TypeSig "
+ . showsPosition pos . space
+ . showsList showsIdent idents . space
+ . showsQualTypeExpr qtype
+ . showsString ")"
+showsDecl (FunctionDecl pos a ident eqs)
+ = showsString "(FunctionDecl "
+ . showsPosition pos . space
+ . showsPrec 11 a . space
+ . showsIdent ident . space
+ . showsList showsEquation eqs
+ . showsString ")"
+showsDecl (ExternalDecl pos vars)
+ = showsString "(ExternalDecl "
+ . showsPosition pos . space
+ . showsList showsVar vars
+ . showsString ")"
+showsDecl (PatternDecl pos cons rhs)
+ = showsString "(PatternDecl "
+ . showsPosition pos . space
+ . showsConsTerm cons . space
+ . showsRhs rhs
+ . showsString ")"
+showsDecl (FreeDecl pos vars)
+ = showsString "(FreeDecl "
+ . showsPosition pos . space
+ . showsList showsVar vars
+ . showsString ")"
+showsDecl (DefaultDecl pos types)
+ = showsString "(DefaultDecl "
+ . showsPosition pos . space
+ . showsList showsTypeExpr types
+ . showsString ")"
+showsDecl (ClassDecl pos context cls clsvar decls)
+ = showsString "(ClassDecl "
+ . showsPosition pos . space
+ . showsContext context . space
+ . showsIdent cls . space
+ . showsIdent clsvar . space
+ . showsList showsDecl decls
+ . showsString ")"
+showsDecl (InstanceDecl pos context qcls inst decls)
+ = showsString "(InstanceDecl "
+ . showsPosition pos . space
+ . showsContext context . space
+ . showsQualIdent qcls . space
+ . showsInstanceType inst . space
+ . showsList showsDecl decls
+ . showsString ")"
+
+showsContext :: Context -> ShowS
+showsContext constraints
+ = showsList showsConstraint constraints
+
+showsConstraint :: Constraint -> ShowS
+showsConstraint (Constraint qcls ty)
+ = showsString "(Constraint "
+ . showsQualIdent qcls . space
+ . showsTypeExpr ty
+ . showsString ")"
+
+showsInstanceType :: InstanceType -> ShowS
+showsInstanceType = showsTypeExpr
+
+showsConsDecl :: ConstrDecl -> ShowS
+showsConsDecl (ConstrDecl pos idents context ident types)
+ = showsString "(ConstrDecl "
+ . showsPosition pos . space
+ . showsList showsIdent idents . space
+ . showsContext context . space
+ . showsIdent ident . space
+ . showsList showsTypeExpr types
+ . showsString ")"
+showsConsDecl (ConOpDecl pos idents context ty1 ident ty2)
+ = showsString "(ConOpDecl "
+ . showsPosition pos . space
+ . showsList showsIdent idents . space
+ . showsContext context . space
+ . showsTypeExpr ty1 . space
+ . showsIdent ident . space
+ . showsTypeExpr ty2
+ . showsString ")"
+showsConsDecl (RecordDecl pos idents context ident fs)
+ = showsString "(RecordDecl "
+ . showsPosition pos . space
+ . showsList showsIdent idents . space
+ . showsContext context . space
+ . showsIdent ident . space
+ . showsList showsFieldDecl fs
+ . showsString ")"
+
+showsFieldDecl :: FieldDecl -> ShowS
+showsFieldDecl (FieldDecl pos labels ty)
+ = showsString "(FieldDecl "
+ . showsPosition pos . space
+ . showsList showsIdent labels . space
+ . showsTypeExpr ty
+ . showsString ")"
+
+showsNewConsDecl :: NewConstrDecl -> ShowS
+showsNewConsDecl (NewConstrDecl pos ident typ)
+ = showsString "(NewConstrDecl "
+ . showsPosition pos . space
+ . showsIdent ident . space
+ . showsTypeExpr typ
+ . showsString ")"
+showsNewConsDecl (NewRecordDecl pos ident fld)
+ = showsString "(NewRecordDecl "
+ . showsPosition pos . space
+ . showsIdent ident . space
+ . showsPair showsIdent showsTypeExpr fld
+ . showsString ")"
+
+showsQualTypeExpr :: QualTypeExpr -> ShowS
+showsQualTypeExpr (QualTypeExpr context typ)
+ = showsString "(QualTypeExpr "
+ . showsContext context . space
+ . showsTypeExpr typ
+ . showsString ")"
+
+showsTypeExpr :: TypeExpr -> ShowS
+showsTypeExpr (ConstructorType qident)
+ = showsString "(ConstructorType "
+ . showsQualIdent qident . space
+ . showsString ")"
+showsTypeExpr (ApplyType type1 type2)
+ = showsString "(ApplyType "
+ . showsTypeExpr type1 . space
+ . showsTypeExpr type2 . space
+ . showsString ")"
+showsTypeExpr (VariableType ident)
+ = showsString "(VariableType "
+ . showsIdent ident
+ . showsString ")"
+showsTypeExpr (TupleType types)
+ = showsString "(TupleType "
+ . showsList showsTypeExpr types
+ . showsString ")"
+showsTypeExpr (ListType typ)
+ = showsString "(ListType "
+ . showsTypeExpr typ
+ . showsString ")"
+showsTypeExpr (ArrowType dom ran)
+ = showsString "(ArrowType "
+ . showsTypeExpr dom . space
+ . showsTypeExpr ran
+ . showsString ")"
+showsTypeExpr (ParenType ty)
+ = showsString "(ParenType "
+ . showsTypeExpr ty
+ . showsString ")"
+showsTypeExpr (ForallType vars ty)
+ = showsString "(ForallType "
+ . showsList showsIdent vars
+ . showsTypeExpr ty
+ . showsString ")"
+
+showsEquation :: Show a => Equation a -> ShowS
+showsEquation (Equation pos lhs rhs)
+ = showsString "(Equation "
+ . showsPosition pos . space
+ . showsLhs lhs . space
+ . showsRhs rhs
+ . showsString ")"
+
+showsLhs :: Show a => Lhs a -> ShowS
+showsLhs (FunLhs ident conss)
+ = showsString "(FunLhs "
+ . showsIdent ident . space
+ . showsList showsConsTerm conss
+ . showsString ")"
+showsLhs (OpLhs cons1 ident cons2)
+ = showsString "(OpLhs "
+ . showsConsTerm cons1 . space
+ . showsIdent ident . space
+ . showsConsTerm cons2
+ . showsString ")"
+showsLhs (ApLhs lhs conss)
+ = showsString "(ApLhs "
+ . showsLhs lhs . space
+ . showsList showsConsTerm conss
+ . showsString ")"
+
+showsRhs :: Show a => Rhs a -> ShowS
+showsRhs (SimpleRhs pos expr decls)
+ = showsString "(SimpleRhs "
+ . showsPosition pos . space
+ . showsExpression expr . space
+ . showsList showsDecl decls
+ . showsString ")"
+showsRhs (GuardedRhs cexps decls)
+ = showsString "(GuardedRhs "
+ . showsList showsCondExpr cexps . space
+ . showsList showsDecl decls
+ . showsString ")"
+
+showsCondExpr :: Show a => CondExpr a -> ShowS
+showsCondExpr (CondExpr pos exp1 exp2)
+ = showsString "(CondExpr "
+ . showsPosition pos . space
+ . showsExpression exp1 . space
+ . showsExpression exp2
+ . showsString ")"
+
+showsLiteral :: Literal -> ShowS
+showsLiteral (Char c)
+ = showsString "(Char "
+ . shows c
+ . showsString ")"
+showsLiteral (Int n)
+ = showsString "(Int "
+ . shows n
+ . showsString ")"
+showsLiteral (Float x)
+ = showsString "(Float "
+ . shows x
+ . showsString ")"
+showsLiteral (String s)
+ = showsString "(String "
+ . shows s
+ . showsString ")"
+
+showsConsTerm :: Show a => Pattern a -> ShowS
+showsConsTerm (LiteralPattern a lit)
+ = showsString "(LiteralPattern "
+ . showsPrec 11 a . space
+ . showsLiteral lit
+ . showsString ")"
+showsConsTerm (NegativePattern a lit)
+ = showsString "(NegativePattern "
+ . showsPrec 11 a . space
+ . showsLiteral lit
+ . showsString ")"
+showsConsTerm (VariablePattern a ident)
+ = showsString "(VariablePattern "
+ . showsPrec 11 a . space
+ . showsIdent ident
+ . showsString ")"
+showsConsTerm (ConstructorPattern a qident conss)
+ = showsString "(ConstructorPattern "
+ . showsPrec 11 a . space
+ . showsQualIdent qident . space
+ . showsList showsConsTerm conss
+ . showsString ")"
+showsConsTerm (InfixPattern a cons1 qident cons2)
+ = showsString "(InfixPattern "
+ . showsPrec 11 a . space
+ . showsConsTerm cons1 . space
+ . showsQualIdent qident . space
+ . showsConsTerm cons2
+ . showsString ")"
+showsConsTerm (ParenPattern cons)
+ = showsString "(ParenPattern "
+ . showsConsTerm cons
+ . showsString ")"
+showsConsTerm (TuplePattern conss)
+ = showsString "(TuplePattern "
+ . showsList showsConsTerm conss
+ . showsString ")"
+showsConsTerm (ListPattern a conss)
+ = showsString "(ListPattern "
+ . showsPrec 11 a . space
+ . showsList showsConsTerm conss
+ . showsString ")"
+showsConsTerm (AsPattern ident cons)
+ = showsString "(AsPattern "
+ . showsIdent ident . space
+ . showsConsTerm cons
+ . showsString ")"
+showsConsTerm (LazyPattern cons)
+ = showsString "(LazyPattern "
+ . showsConsTerm cons
+ . showsString ")"
+showsConsTerm (FunctionPattern a qident conss)
+ = showsString "(FunctionPattern "
+ . showsPrec 11 a . space
+ . showsQualIdent qident . space
+ . showsList showsConsTerm conss
+ . showsString ")"
+showsConsTerm (InfixFuncPattern a cons1 qident cons2)
+ = showsString "(InfixFuncPattern "
+ . showsPrec 11 a . space
+ . showsConsTerm cons1 . space
+ . showsQualIdent qident . space
+ . showsConsTerm cons2
+ . showsString ")"
+showsConsTerm (RecordPattern a qident cfields)
+ = showsString "(RecordPattern "
+ . showsPrec 11 a . space
+ . showsQualIdent qident . space
+ . showsList (showsField showsConsTerm) cfields . space
+ . showsString ")"
+
+showsExpression :: Show a => Expression a -> ShowS
+showsExpression (Literal a lit)
+ = showsString "(Literal "
+ . showsPrec 11 a . space
+ . showsLiteral lit
+ . showsString ")"
+showsExpression (Variable a qident)
+ = showsString "(Variable "
+ . showsPrec 11 a . space
+ . showsQualIdent qident
+ . showsString ")"
+showsExpression (Constructor a qident)
+ = showsString "(Constructor "
+ . showsPrec 11 a . space
+ . showsQualIdent qident
+ . showsString ")"
+showsExpression (Paren expr)
+ = showsString "(Paren "
+ . showsExpression expr
+ . showsString ")"
+showsExpression (Typed expr qtype)
+ = showsString "(Typed "
+ . showsExpression expr . space
+ . showsQualTypeExpr qtype
+ . showsString ")"
+showsExpression (Tuple exps)
+ = showsString "(Tuple "
+ . showsList showsExpression exps
+ . showsString ")"
+showsExpression (List a exps)
+ = showsString "(List "
+ . showsPrec 11 a . space
+ . showsList showsExpression exps
+ . showsString ")"
+showsExpression (ListCompr expr stmts)
+ = showsString "(ListCompr "
+ . showsExpression expr . space
+ . showsList showsStatement stmts
+ . showsString ")"
+showsExpression (EnumFrom expr)
+ = showsString "(EnumFrom "
+ . showsExpression expr
+ . showsString ")"
+showsExpression (EnumFromThen exp1 exp2)
+ = showsString "(EnumFromThen "
+ . showsExpression exp1 . space
+ . showsExpression exp2
+ . showsString ")"
+showsExpression (EnumFromTo exp1 exp2)
+ = showsString "(EnumFromTo "
+ . showsExpression exp1 . space
+ . showsExpression exp2
+ . showsString ")"
+showsExpression (EnumFromThenTo exp1 exp2 exp3)
+ = showsString "(EnumFromThenTo "
+ . showsExpression exp1 . space
+ . showsExpression exp2 . space
+ . showsExpression exp3
+ . showsString ")"
+showsExpression (UnaryMinus expr)
+ = showsString "(UnaryMinus "
+ . showsExpression expr
+ . showsString ")"
+showsExpression (Apply exp1 exp2)
+ = showsString "(Apply "
+ . showsExpression exp1 . space
+ . showsExpression exp2
+ . showsString ")"
+showsExpression (InfixApply exp1 op exp2)
+ = showsString "(InfixApply "
+ . showsExpression exp1 . space
+ . showsInfixOp op . space
+ . showsExpression exp2
+ . showsString ")"
+showsExpression (LeftSection expr op)
+ = showsString "(LeftSection "
+ . showsExpression expr . space
+ . showsInfixOp op
+ . showsString ")"
+showsExpression (RightSection op expr)
+ = showsString "(RightSection "
+ . showsInfixOp op . space
+ . showsExpression expr
+ . showsString ")"
+showsExpression (Lambda conss expr)
+ = showsString "(Lambda "
+ . showsList showsConsTerm conss . space
+ . showsExpression expr
+ . showsString ")"
+showsExpression (Let decls expr)
+ = showsString "(Let "
+ . showsList showsDecl decls . space
+ . showsExpression expr
+ . showsString ")"
+showsExpression (Do stmts expr)
+ = showsString "(Do "
+ . showsList showsStatement stmts . space
+ . showsExpression expr
+ . showsString ")"
+showsExpression (IfThenElse exp1 exp2 exp3)
+ = showsString "(IfThenElse "
+ . showsExpression exp1 . space
+ . showsExpression exp2 . space
+ . showsExpression exp3
+ . showsString ")"
+showsExpression (Case ct expr alts)
+ = showsString "(Case "
+ . showsCaseType ct . space
+ . showsExpression expr . space
+ . showsList showsAlt alts
+ . showsString ")"
+showsExpression (RecordUpdate expr efields)
+ = showsString "(RecordUpdate "
+ . showsExpression expr . space
+ . showsList (showsField showsExpression) efields
+ . showsString ")"
+showsExpression (Record a qident efields)
+ = showsString "(Record "
+ . showsPrec 11 a . space
+ . showsQualIdent qident . space
+ . showsList (showsField showsExpression) efields
+ . showsString ")"
+
+showsInfixOp :: Show a => InfixOp a -> ShowS
+showsInfixOp (InfixOp a qident)
+ = showsString "(InfixOp "
+ . showsPrec 11 a . space
+ . showsQualIdent qident
+ . showsString ")"
+showsInfixOp (InfixConstr a qident)
+ = showsString "(InfixConstr "
+ . showsPrec 11 a . space
+ . showsQualIdent qident
+ . showsString ")"
+
+showsStatement :: Show a => Statement a -> ShowS
+showsStatement (StmtExpr expr)
+ = showsString "(StmtExpr "
+ . showsExpression expr
+ . showsString ")"
+showsStatement (StmtDecl decls)
+ = showsString "(StmtDecl "
+ . showsList showsDecl decls
+ . showsString ")"
+showsStatement (StmtBind cons expr)
+ = showsString "(StmtBind "
+ . showsConsTerm cons . space
+ . showsExpression expr
+ . showsString ")"
+
+showsCaseType :: CaseType -> ShowS
+showsCaseType Rigid = showsString "Rigid"
+showsCaseType Flex = showsString "Flex"
+
+showsAlt :: Show a => Alt a -> ShowS
+showsAlt (Alt pos cons rhs)
+ = showsString "(Alt "
+ . showsPosition pos . space
+ . showsConsTerm cons . space
+ . showsRhs rhs
+ . showsString ")"
+
+showsField :: (a -> ShowS) -> Field a -> ShowS
+showsField sa (Field pos ident a)
+ = showsString "(Field "
+ . showsPosition pos . space
+ . showsQualIdent ident . space
+ . sa a
+ . showsString ")"
+
+showsVar :: Show a => Var a -> ShowS
+showsVar (Var a ident)
+ = showsString "(Var "
+ . showsPrec 11 a . space
+ . showsIdent ident
+ . showsString ")"
+
+showsPosition :: Position -> ShowS
+showsPosition Position { line = l, column = c } = showsPair shows shows (l, c)
+showsPosition _ = showsString "(0,0)"
+-- showsPosition (Position file row col)
+-- = showsString "(Position "
+-- . shows file . space
+-- . shows row . space
+-- . shows col
+-- . showsString ")"
+
+showsString :: String -> ShowS
+showsString = (++)
+
+space :: ShowS
+space = showsString " "
+
+newline :: ShowS
+newline = showsString "\n"
+
+showsMaybe :: (a -> ShowS) -> Maybe a -> ShowS
+showsMaybe shs = maybe (showsString "Nothing")
+ (\x -> showsString "(Just " . shs x . showsString ")")
+
+showsList :: (a -> ShowS) -> [a] -> ShowS
+showsList _ [] = showsString "[]"
+showsList shs (x:xs)
+ = showsString "["
+ . foldl (\sys y -> sys . showsString "," . shs y) (shs x) xs
+ . showsString "]"
+
+showsPair :: (a -> ShowS) -> (b -> ShowS) -> (a,b) -> ShowS
+showsPair sa sb (a,b)
+ = showsString "(" . sa a . showsString "," . sb b . showsString ")"
+
+showsIdent :: Ident -> ShowS
+showsIdent (Ident p x n)
+ = showsString "(Ident " . showsPosition p . space
+ . shows x . space . shows n . showsString ")"
+
+showsQualIdent :: QualIdent -> ShowS
+showsQualIdent (QualIdent mident ident)
+ = showsString "(QualIdent "
+ . showsMaybe showsModuleIdent mident
+ . space
+ . showsIdent ident
+ . showsString ")"
+
+showsModuleIdent :: ModuleIdent -> ShowS
+showsModuleIdent (ModuleIdent pos ss)
+ = showsString "(ModuleIdent "
+ . showsPosition pos . space
+ . showsList (showsQuotes showsString) ss
+ . showsString ")"
+
+showsQuotes :: (a -> ShowS) -> a -> ShowS
+showsQuotes sa a
+ = showsString "\"" . sa a . showsString "\""
diff --git a/src/Curry/Syntax/Type.hs b/src/Curry/Syntax/Type.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Syntax/Type.hs
@@ -0,0 +1,460 @@
+{- |
+ Module : $Header$
+ Description : Abstract syntax for Curry
+ Copyright : (c) 1999 - 2004 Wolfgang Lux
+ 2005 Martin Engelke
+ 2011 - 2015 Björn Peemöller
+ 2014 Jan Rasmus Tikovsky
+ 2016 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module provides the necessary data structures to maintain the
+ parsed representation of a Curry program.
+-}
+
+module Curry.Syntax.Type
+ ( -- * Module header
+ Module (..)
+ -- ** Module pragmas
+ , ModulePragma (..), Extension (..), KnownExtension (..), Tool (..)
+ -- ** Export specification
+ , ExportSpec (..), Export (..)
+ -- ** Import declarations
+ , ImportDecl (..), ImportSpec (..), Import (..), Qualified
+ -- * Interface
+ , Interface (..), IImportDecl (..), Arity, IDecl (..), KindExpr (..)
+ , IMethodDecl (..), IMethodImpl
+ -- * Declarations
+ , Decl (..), Precedence, Infix (..), ConstrDecl (..), NewConstrDecl (..)
+ , FieldDecl (..)
+ , CallConv (..), TypeExpr (..), QualTypeExpr (..)
+ , Equation (..), Lhs (..), Rhs (..), CondExpr (..)
+ , Literal (..), Pattern (..), Expression (..), InfixOp (..)
+ , Statement (..), CaseType (..), Alt (..), Field (..), Var (..)
+ -- * Type classes
+ , Context, Constraint (..), InstanceType
+ -- * Goals
+ , Goal (..)
+ ) where
+
+import Curry.Base.Ident
+import Curry.Base.Position
+import Curry.Base.Pretty (Pretty(..))
+
+import Curry.Syntax.Extension
+
+import Text.PrettyPrint
+
+-- ---------------------------------------------------------------------------
+-- Modules
+-- ---------------------------------------------------------------------------
+
+-- |Curry module
+data Module a = Module [ModulePragma] ModuleIdent (Maybe ExportSpec)
+ [ImportDecl] [Decl a]
+ deriving (Eq, Read, Show)
+
+-- |Module pragma
+data ModulePragma
+ = LanguagePragma Position [Extension] -- ^ language pragma
+ | OptionsPragma Position (Maybe Tool) String -- ^ options pragma
+ deriving (Eq, Read, Show)
+
+-- |Export specification
+data ExportSpec = Exporting Position [Export]
+ deriving (Eq, Read, Show)
+
+-- |Single exported entity
+data Export
+ = Export QualIdent -- f/T
+ | ExportTypeWith QualIdent [Ident] -- T (C1,...,Cn)
+ | ExportTypeAll QualIdent -- T (..)
+ | ExportModule ModuleIdent -- module M
+ deriving (Eq, Read, Show)
+
+-- |Import declaration
+data ImportDecl = ImportDecl Position ModuleIdent Qualified
+ (Maybe ModuleIdent) (Maybe ImportSpec)
+ deriving (Eq, Read, Show)
+
+-- |Flag to signal qualified import
+type Qualified = Bool
+
+-- |Import specification
+data ImportSpec
+ = Importing Position [Import]
+ | Hiding Position [Import]
+ deriving (Eq, Read, Show)
+
+-- |Single imported entity
+data Import
+ = Import Ident -- f/T
+ | ImportTypeWith Ident [Ident] -- T (C1,...,Cn)
+ | ImportTypeAll Ident -- T (..)
+ deriving (Eq, Read, Show)
+
+-- ---------------------------------------------------------------------------
+-- Module interfaces
+-- ---------------------------------------------------------------------------
+
+-- | Module interface
+--
+-- Interface declarations are restricted to type declarations and signatures.
+-- Note that an interface function declaration additionaly contains the
+-- function arity (= number of parameters) in order to generate
+-- correct FlatCurry function applications.
+data Interface = Interface ModuleIdent [IImportDecl] [IDecl]
+ deriving (Eq, Read, Show)
+
+-- |Interface import declaration
+data IImportDecl = IImportDecl Position ModuleIdent
+ deriving (Eq, Read, Show)
+
+-- |Arity of a function
+type Arity = Int
+
+-- |Interface declaration
+data IDecl
+ = IInfixDecl Position Infix Precedence QualIdent
+ | HidingDataDecl Position QualIdent (Maybe KindExpr) [Ident]
+ | IDataDecl Position QualIdent (Maybe KindExpr) [Ident] [ConstrDecl] [Ident]
+ | INewtypeDecl Position QualIdent (Maybe KindExpr) [Ident] NewConstrDecl [Ident]
+ | ITypeDecl Position QualIdent (Maybe KindExpr) [Ident] TypeExpr
+ | IFunctionDecl Position QualIdent (Maybe Ident) Arity QualTypeExpr
+ | HidingClassDecl Position Context QualIdent (Maybe KindExpr) Ident
+ | IClassDecl Position Context QualIdent (Maybe KindExpr) Ident [IMethodDecl] [Ident]
+ | IInstanceDecl Position Context QualIdent InstanceType [IMethodImpl] (Maybe ModuleIdent)
+ deriving (Eq, Read, Show)
+
+-- |Class methods
+data IMethodDecl = IMethodDecl Position Ident (Maybe Arity) QualTypeExpr
+ deriving (Eq, Read, Show)
+
+-- |Class method implementations
+type IMethodImpl = (Ident, Arity)
+
+-- |Kind expressions
+data KindExpr
+ = Star
+ | ArrowKind KindExpr KindExpr
+ deriving (Eq, Read, Show)
+
+-- ---------------------------------------------------------------------------
+-- Declarations (local or top-level)
+-- ---------------------------------------------------------------------------
+
+-- |Declaration in a module
+data Decl a
+ = InfixDecl Position Infix (Maybe Precedence) [Ident] -- infixl 5 (op), `fun`
+ | DataDecl Position Ident [Ident] [ConstrDecl] [QualIdent] -- data C a b = C1 a | C2 b deriving (D, ...)
+ | ExternalDataDecl Position Ident [Ident]
+ | NewtypeDecl Position Ident [Ident] NewConstrDecl [QualIdent] -- newtype C a b = C a b deriving (D, ...)
+ | TypeDecl Position Ident [Ident] TypeExpr -- type C a b = D a b
+ | TypeSig Position [Ident] QualTypeExpr -- f, g :: Bool
+ | FunctionDecl Position a Ident [Equation a] -- f True = 1 ; f False = 0
+ | ExternalDecl Position [Var a] -- f, g external
+ | PatternDecl Position (Pattern a) (Rhs a) -- Just x = ...
+ | FreeDecl Position [Var a] -- x, y free
+ | DefaultDecl Position [TypeExpr] -- default (Int, Float)
+ | ClassDecl Position Context Ident Ident [Decl a] -- class C a => D a where {TypeSig|InfixDecl|FunctionDecl}
+ | InstanceDecl Position Context QualIdent InstanceType [Decl a] -- instance C a => M.D (N.T a b c) where {FunctionDecl}
+ deriving (Eq, Read, Show)
+
+-- ---------------------------------------------------------------------------
+-- Infix declaration
+-- ---------------------------------------------------------------------------
+
+-- |Operator precedence
+type Precedence = Integer
+
+-- |Fixity of operators
+data Infix
+ = InfixL -- ^ left-associative
+ | InfixR -- ^ right-associative
+ | Infix -- ^ no associativity
+ deriving (Eq, Read, Show)
+
+-- |Constructor declaration for algebraic data types
+data ConstrDecl
+ = ConstrDecl Position [Ident] Context Ident [TypeExpr]
+ | ConOpDecl Position [Ident] Context TypeExpr Ident TypeExpr
+ | RecordDecl Position [Ident] Context Ident [FieldDecl]
+ deriving (Eq, Read, Show)
+
+-- |Constructor declaration for renaming types (newtypes)
+data NewConstrDecl
+ = NewConstrDecl Position Ident TypeExpr
+ | NewRecordDecl Position Ident (Ident, TypeExpr)
+ deriving (Eq, Read, Show)
+
+-- |Declaration for labelled fields
+data FieldDecl = FieldDecl Position [Ident] TypeExpr
+ deriving (Eq, Read, Show)
+
+-- |Calling convention for C code
+data CallConv
+ = CallConvPrimitive
+ | CallConvCCall
+ deriving (Eq, Read, Show)
+
+-- |Type expressions
+data TypeExpr
+ = ConstructorType QualIdent
+ | ApplyType TypeExpr TypeExpr
+ | VariableType Ident
+ | TupleType [TypeExpr]
+ | ListType TypeExpr
+ | ArrowType TypeExpr TypeExpr
+ | ParenType TypeExpr
+ | ForallType [Ident] TypeExpr
+ deriving (Eq, Read, Show)
+
+-- |Qualified type expressions
+data QualTypeExpr = QualTypeExpr Context TypeExpr
+ deriving (Eq, Read, Show)
+
+-- ---------------------------------------------------------------------------
+-- Type classes
+-- ---------------------------------------------------------------------------
+
+type Context = [Constraint]
+
+data Constraint = Constraint QualIdent TypeExpr
+ deriving (Eq, Read, Show)
+
+type InstanceType = TypeExpr
+
+-- ---------------------------------------------------------------------------
+-- Functions
+-- ---------------------------------------------------------------------------
+
+-- |Function defining equation
+data Equation a = Equation Position (Lhs a) (Rhs a)
+ deriving (Eq, Read, Show)
+
+-- |Left-hand-side of an 'Equation' (function identifier and patterns)
+data Lhs a
+ = FunLhs Ident [Pattern a] -- f x y
+ | OpLhs (Pattern a) Ident (Pattern a) -- x $ y
+ | ApLhs (Lhs a) [Pattern a] -- ($) x y
+ deriving (Eq, Read, Show)
+
+-- |Right-hand-side of an 'Equation'
+data Rhs a
+ = SimpleRhs Position (Expression a) [Decl a] -- @expr where decls@
+ | GuardedRhs [CondExpr a] [Decl a] -- @| cond = expr where decls@
+ deriving (Eq, Read, Show)
+
+-- |Conditional expression (expression conditioned by a guard)
+data CondExpr a = CondExpr Position (Expression a) (Expression a)
+ deriving (Eq, Read, Show)
+
+-- |Literal
+data Literal
+ = Char Char
+ | Int Integer
+ | Float Double
+ | String String
+ deriving (Eq, Read, Show)
+
+-- |Constructor term (used for patterns)
+data Pattern a
+ = LiteralPattern a Literal
+ | NegativePattern a Literal
+ | VariablePattern a Ident
+ | ConstructorPattern a QualIdent [Pattern a]
+ | InfixPattern a (Pattern a) QualIdent (Pattern a)
+ | ParenPattern (Pattern a)
+ | RecordPattern a QualIdent [Field (Pattern a)] -- C { l1 = p1, ..., ln = pn }
+ | TuplePattern [Pattern a]
+ | ListPattern a [Pattern a]
+ | AsPattern Ident (Pattern a)
+ | LazyPattern (Pattern a)
+ | FunctionPattern a QualIdent [Pattern a]
+ | InfixFuncPattern a (Pattern a) QualIdent (Pattern a)
+ deriving (Eq, Read, Show)
+
+-- |Expression
+data Expression a
+ = Literal a Literal
+ | Variable a QualIdent
+ | Constructor a QualIdent
+ | Paren (Expression a)
+ | Typed (Expression a) QualTypeExpr
+ | Record a QualIdent [Field (Expression a)] -- C {l1 = e1,..., ln = en}
+ | RecordUpdate (Expression a) [Field (Expression a)] -- e {l1 = e1,..., ln = en}
+ | Tuple [Expression a]
+ | List a [Expression a]
+ | ListCompr (Expression a) [Statement a] -- the ref corresponds to the main list
+ | EnumFrom (Expression a)
+ | EnumFromThen (Expression a) (Expression a)
+ | EnumFromTo (Expression a) (Expression a)
+ | EnumFromThenTo (Expression a) (Expression a) (Expression a)
+ | UnaryMinus (Expression a)
+ | Apply (Expression a) (Expression a)
+ | InfixApply (Expression a) (InfixOp a) (Expression a)
+ | LeftSection (Expression a) (InfixOp a)
+ | RightSection (InfixOp a) (Expression a)
+ | Lambda [Pattern a] (Expression a)
+ | Let [Decl a] (Expression a)
+ | Do [Statement a] (Expression a)
+ | IfThenElse (Expression a) (Expression a) (Expression a)
+ | Case CaseType (Expression a) [Alt a]
+ deriving (Eq, Read, Show)
+
+-- |Infix operation
+data InfixOp a
+ = InfixOp a QualIdent
+ | InfixConstr a QualIdent
+ deriving (Eq, Read, Show)
+
+-- |Statement (used for do-sequence and list comprehensions)
+data Statement a
+ = StmtExpr (Expression a)
+ | StmtDecl [Decl a]
+ | StmtBind (Pattern a) (Expression a)
+ deriving (Eq, Read, Show)
+
+-- |Type of case expressions
+data CaseType
+ = Rigid
+ | Flex
+ deriving (Eq, Read, Show)
+
+-- |Single case alternative
+data Alt a = Alt Position (Pattern a) (Rhs a)
+ deriving (Eq, Read, Show)
+
+-- |Record field
+data Field a = Field Position QualIdent a
+ deriving (Eq, Read, Show)
+
+-- |Annotated identifier
+data Var a = Var a Ident
+ deriving (Eq, Read, Show)
+
+-- ---------------------------------------------------------------------------
+-- Goals
+-- ---------------------------------------------------------------------------
+
+-- |Goal in REPL (expression to evaluate)
+data Goal a = Goal Position (Expression a) [Decl a]
+ deriving (Eq, Read, Show)
+
+-- ---------------------------------------------------------------------------
+-- instances
+-- ---------------------------------------------------------------------------
+
+instance Functor Module where
+ fmap f (Module ps m es is ds) = Module ps m es is (map (fmap f) ds)
+
+instance Functor Decl where
+ fmap _ (InfixDecl p fix prec ops) = InfixDecl p fix prec ops
+ fmap _ (DataDecl p tc tvs cs clss) = DataDecl p tc tvs cs clss
+ fmap _ (ExternalDataDecl p tc tvs) = ExternalDataDecl p tc tvs
+ fmap _ (NewtypeDecl p tc tvs nc clss) = NewtypeDecl p tc tvs nc clss
+ fmap _ (TypeDecl p tc tvs ty) = TypeDecl p tc tvs ty
+ fmap _ (TypeSig p fs qty) = TypeSig p fs qty
+ fmap f (FunctionDecl p a f' eqs) = FunctionDecl p (f a) f' (map (fmap f) eqs)
+ fmap f (ExternalDecl p vs) = ExternalDecl p (map (fmap f) vs)
+ fmap f (PatternDecl p t rhs) = PatternDecl p (fmap f t) (fmap f rhs)
+ fmap f (FreeDecl p vs) = FreeDecl p (map (fmap f) vs)
+ fmap _ (DefaultDecl p tys) = DefaultDecl p tys
+ fmap f (ClassDecl p cx cls clsvar ds) =
+ ClassDecl p cx cls clsvar (map (fmap f) ds)
+ fmap f (InstanceDecl p cx qcls inst ds) =
+ InstanceDecl p cx qcls inst (map (fmap f) ds)
+
+instance Functor Equation where
+ fmap f (Equation p lhs rhs) = Equation p (fmap f lhs) (fmap f rhs)
+
+instance Functor Lhs where
+ fmap f (FunLhs f' ts) = FunLhs f' (map (fmap f) ts)
+ fmap f (OpLhs t1 op t2) = OpLhs (fmap f t1) op (fmap f t2)
+ fmap f (ApLhs lhs ts) = ApLhs (fmap f lhs) (map (fmap f) ts)
+
+instance Functor Rhs where
+ fmap f (SimpleRhs p e ds) = SimpleRhs p (fmap f e) (map (fmap f) ds)
+ fmap f (GuardedRhs cs ds) = GuardedRhs (map (fmap f) cs) (map (fmap f) ds)
+
+instance Functor CondExpr where
+ fmap f (CondExpr p g e) = CondExpr p (fmap f g) (fmap f e)
+
+instance Functor Pattern where
+ fmap f (LiteralPattern a l) = LiteralPattern (f a) l
+ fmap f (NegativePattern a l) = NegativePattern (f a) l
+ fmap f (VariablePattern a v) = VariablePattern (f a) v
+ fmap f (ConstructorPattern a c ts) =
+ ConstructorPattern (f a) c (map (fmap f) ts)
+ fmap f (InfixPattern a t1 op t2) =
+ InfixPattern (f a) (fmap f t1) op (fmap f t2)
+ fmap f (ParenPattern t) = ParenPattern (fmap f t)
+ fmap f (RecordPattern a c fs) =
+ RecordPattern (f a) c (map (fmap (fmap f)) fs)
+ fmap f (TuplePattern ts) = TuplePattern (map (fmap f) ts)
+ fmap f (ListPattern a ts) = ListPattern (f a) (map (fmap f) ts)
+ fmap f (AsPattern v t) = AsPattern v (fmap f t)
+ fmap f (LazyPattern t) = LazyPattern (fmap f t)
+ fmap f (FunctionPattern a f' ts) =
+ FunctionPattern (f a) f' (map (fmap f) ts)
+ fmap f (InfixFuncPattern a t1 op t2) =
+ InfixFuncPattern (f a) (fmap f t1) op (fmap f t2)
+
+instance Functor Expression where
+ fmap f (Literal a l) = Literal (f a) l
+ fmap f (Variable a v) = Variable (f a) v
+ fmap f (Constructor a c) = Constructor (f a) c
+ fmap f (Paren e) = Paren (fmap f e)
+ fmap f (Typed e qty) = Typed (fmap f e) qty
+ fmap f (Record a c fs) = Record (f a) c (map (fmap (fmap f)) fs)
+ fmap f (RecordUpdate e fs) = RecordUpdate (fmap f e) (map (fmap (fmap f)) fs)
+ fmap f (Tuple es) = Tuple (map (fmap f) es)
+ fmap f (List a es) = List (f a) (map (fmap f) es)
+ fmap f (ListCompr e stms) = ListCompr (fmap f e) (map (fmap f) stms)
+ fmap f (EnumFrom e) = EnumFrom (fmap f e)
+ fmap f (EnumFromThen e1 e2) = EnumFromThen (fmap f e1) (fmap f e2)
+ fmap f (EnumFromTo e1 e2) = EnumFromTo (fmap f e1) (fmap f e2)
+ fmap f (EnumFromThenTo e1 e2 e3) =
+ EnumFromThenTo (fmap f e1) (fmap f e2) (fmap f e3)
+ fmap f (UnaryMinus e) = UnaryMinus (fmap f e)
+ fmap f (Apply e1 e2) = Apply (fmap f e1) (fmap f e2)
+ fmap f (InfixApply e1 op e2) =
+ InfixApply (fmap f e1) (fmap f op) (fmap f e2)
+ fmap f (LeftSection e op) = LeftSection (fmap f e) (fmap f op)
+ fmap f (RightSection op e) = RightSection (fmap f op) (fmap f e)
+ fmap f (Lambda ts e) = Lambda (map (fmap f) ts) (fmap f e)
+ fmap f (Let ds e) = Let (map (fmap f) ds) (fmap f e)
+ fmap f (Do stms e) = Do (map (fmap f) stms) (fmap f e)
+ fmap f (IfThenElse e1 e2 e3) =
+ IfThenElse (fmap f e1) (fmap f e2) (fmap f e3)
+ fmap f (Case ct e as) = Case ct (fmap f e) (map (fmap f) as)
+
+instance Functor InfixOp where
+ fmap f (InfixOp a op) = InfixOp (f a) op
+ fmap f (InfixConstr a op) = InfixConstr (f a) op
+
+instance Functor Statement where
+ fmap f (StmtExpr e) = StmtExpr (fmap f e)
+ fmap f (StmtDecl ds) = StmtDecl (map (fmap f) ds)
+ fmap f (StmtBind t e) = StmtBind (fmap f t) (fmap f e)
+
+instance Functor Alt where
+ fmap f (Alt p t rhs) = Alt p (fmap f t) (fmap f rhs)
+
+instance Functor Field where
+ fmap f (Field p l x) = Field p l (f x)
+
+instance Functor Var where
+ fmap f (Var a v) = Var (f a) v
+
+instance Functor Goal where
+ fmap f (Goal p e ds) = Goal p (fmap f e) (map (fmap f) ds)
+
+instance Pretty Infix where
+ pPrint InfixL = text "infixl"
+ pPrint InfixR = text "infixr"
+ pPrint Infix = text "infix"
diff --git a/src/Curry/Syntax/Utils.hs b/src/Curry/Syntax/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Curry/Syntax/Utils.hs
@@ -0,0 +1,292 @@
+{- |
+ Module : $Header$
+ Description : Utility functions for Curry's abstract syntax
+ Copyright : (c) 1999 - 2004 Wolfgang Lux
+ 2005 Martin Engelke
+ 2011 - 2014 Björn Peemöller
+ 2015 Jan Tikovsky
+ 2016 Finn Teegen
+ License : BSD-3-clause
+
+ Maintainer : bjp@informatik.uni-kiel.de
+ Stability : experimental
+ Portability : portable
+
+ This module provides some utility functions for working with the
+ abstract syntax tree of Curry.
+-}
+
+module Curry.Syntax.Utils
+ ( hasLanguageExtension, knownExtensions
+ , isTopDecl, isBlockDecl
+ , isTypeSig, infixOp, isTypeDecl, isValueDecl, isInfixDecl
+ , isDefaultDecl, isClassDecl, isTypeOrClassDecl, isInstanceDecl
+ , isFunctionDecl, isExternalDecl, patchModuleId
+ , isVariablePattern
+ , isVariableType, isSimpleType
+ , typeConstr, typeVariables, varIdent
+ , flatLhs, eqnArity, fieldLabel, fieldTerm, field2Tuple, opName
+ , funDecl, mkEquation, simpleRhs, patDecl, varDecl, constrPattern, caseAlt
+ , mkLet, mkVar
+ , apply, unapply
+ , constrId, nconstrId
+ , nconstrType
+ , recordLabels, nrecordLabels
+ , methods, impls, imethod, imethodArity
+ ) where
+
+import Control.Monad.State
+
+import Curry.Base.Ident
+import Curry.Base.Position
+import Curry.Files.Filenames (takeBaseName)
+import Curry.Syntax.Extension
+import Curry.Syntax.Type
+
+-- |Check whether a 'Module' has a specific 'KnownExtension' enabled by a pragma
+hasLanguageExtension :: Module a -> KnownExtension -> Bool
+hasLanguageExtension mdl ext = ext `elem` knownExtensions mdl
+
+-- |Extract all known extensions from a 'Module'
+knownExtensions :: Module a -> [KnownExtension]
+knownExtensions (Module ps _ _ _ _) =
+ [ e | LanguagePragma _ exts <- ps, KnownExtension _ e <- exts]
+
+-- |Replace the generic module name @main@ with the module name derived
+-- from the 'FilePath' of the module.
+patchModuleId :: FilePath -> Module a -> Module a
+patchModuleId fn m@(Module ps mid es is ds)
+ | mid == mainMIdent = Module ps (mkMIdent [takeBaseName fn]) es is ds
+ | otherwise = m
+
+-- |Is the declaration a top declaration?
+isTopDecl :: Decl a -> Bool
+isTopDecl = not . isBlockDecl
+
+-- |Is the declaration a block declaration?
+isBlockDecl :: Decl a -> Bool
+isBlockDecl = liftM3 ((.) (||) . (||)) isInfixDecl isTypeSig isValueDecl
+
+-- |Is the declaration an infix declaration?
+isInfixDecl :: Decl a -> Bool
+isInfixDecl (InfixDecl _ _ _ _) = True
+isInfixDecl _ = False
+
+-- |Is the declaration a type declaration?
+isTypeDecl :: Decl a -> Bool
+isTypeDecl (DataDecl _ _ _ _ _) = True
+isTypeDecl (ExternalDataDecl _ _ _) = True
+isTypeDecl (NewtypeDecl _ _ _ _ _) = True
+isTypeDecl (TypeDecl _ _ _ _) = True
+isTypeDecl _ = False
+
+-- |Is the declaration a default declaration?
+isDefaultDecl :: Decl a -> Bool
+isDefaultDecl (DefaultDecl _ _) = True
+isDefaultDecl _ = False
+
+-- |Is the declaration a class declaration?
+isClassDecl :: Decl a -> Bool
+isClassDecl (ClassDecl _ _ _ _ _) = True
+isClassDecl _ = False
+
+-- |Is the declaration a type or a class declaration?
+isTypeOrClassDecl :: Decl a -> Bool
+isTypeOrClassDecl = liftM2 (||) isTypeDecl isClassDecl
+
+-- |Is the declaration an instance declaration?
+isInstanceDecl :: Decl a -> Bool
+isInstanceDecl (InstanceDecl _ _ _ _ _) = True
+isInstanceDecl _ = False
+
+-- |Is the declaration a type signature?
+isTypeSig :: Decl a -> Bool
+isTypeSig (TypeSig _ _ _) = True
+isTypeSig _ = False
+
+-- |Is the declaration a value declaration?
+isValueDecl :: Decl a -> Bool
+isValueDecl (FunctionDecl _ _ _ _) = True
+isValueDecl (ExternalDecl _ _) = True
+isValueDecl (PatternDecl _ _ _) = True
+isValueDecl (FreeDecl _ _) = True
+isValueDecl _ = False
+
+-- |Is the declaration a function declaration?
+isFunctionDecl :: Decl a -> Bool
+isFunctionDecl (FunctionDecl _ _ _ _) = True
+isFunctionDecl _ = False
+
+-- |Is the declaration an external declaration?
+isExternalDecl :: Decl a -> Bool
+isExternalDecl (ExternalDecl _ _) = True
+isExternalDecl _ = False
+
+-- |Is the pattern semantically equivalent to a variable pattern?
+isVariablePattern :: Pattern a -> Bool
+isVariablePattern (VariablePattern _ _) = True
+isVariablePattern (ParenPattern t) = isVariablePattern t
+isVariablePattern (AsPattern _ t) = isVariablePattern t
+isVariablePattern (LazyPattern _) = True
+isVariablePattern _ = False
+
+-- |Is a type expression a type variable?
+isVariableType :: TypeExpr -> Bool
+isVariableType (VariableType _) = True
+isVariableType _ = False
+
+-- |Is a type expression simple, i.e., is it of the form T u_1 ... u_n,
+-- where T is a type constructor and u_1 ... u_n are type variables?
+isSimpleType :: TypeExpr -> Bool
+isSimpleType (ConstructorType _) = True
+isSimpleType (ApplyType ty1 ty2) = isSimpleType ty1 && isVariableType ty2
+isSimpleType (VariableType _) = False
+isSimpleType (TupleType tys) = all isVariableType tys
+isSimpleType (ListType ty) = isVariableType ty
+isSimpleType (ArrowType ty1 ty2) = isVariableType ty1 && isVariableType ty2
+isSimpleType (ParenType ty) = isSimpleType ty
+isSimpleType (ForallType _ _) = False
+
+-- |Return the qualified type constructor of a type expression.
+typeConstr :: TypeExpr -> QualIdent
+typeConstr (ConstructorType tc) = tc
+typeConstr (ApplyType ty _) = typeConstr ty
+typeConstr (TupleType tys) = qTupleId (length tys)
+typeConstr (ListType _) = qListId
+typeConstr (ArrowType _ _) = qArrowId
+typeConstr (ParenType ty) = typeConstr ty
+typeConstr (VariableType _) =
+ error "Curry.Syntax.Utils.typeConstr: variable type"
+typeConstr (ForallType _ _) =
+ error "Curry.Syntax.Utils.typeConstr: forall type"
+
+-- |Return the list of variables occuring in a type expression.
+typeVariables :: TypeExpr -> [Ident]
+typeVariables (ConstructorType _) = []
+typeVariables (ApplyType ty1 ty2) = typeVariables ty1 ++ typeVariables ty2
+typeVariables (VariableType tv) = [tv]
+typeVariables (TupleType tys) = concatMap typeVariables tys
+typeVariables (ListType ty) = typeVariables ty
+typeVariables (ArrowType ty1 ty2) = typeVariables ty1 ++ typeVariables ty2
+typeVariables (ParenType ty) = typeVariables ty
+typeVariables (ForallType vs ty) = vs ++ typeVariables ty
+
+-- |Return the identifier of a variable.
+varIdent :: Var a -> Ident
+varIdent (Var _ v) = v
+
+-- |Convert an infix operator into an expression
+infixOp :: InfixOp a -> Expression a
+infixOp (InfixOp a op) = Variable a op
+infixOp (InfixConstr a op) = Constructor a op
+
+-- |flatten the left-hand-side to the identifier and all constructor terms
+flatLhs :: Lhs a -> (Ident, [Pattern a])
+flatLhs lhs = flat lhs []
+ where flat (FunLhs f ts) ts' = (f, ts ++ ts')
+ flat (OpLhs t1 op t2) ts' = (op, t1 : t2 : ts')
+ flat (ApLhs lhs' ts) ts' = flat lhs' (ts ++ ts')
+
+-- |Return the arity of an equation.
+eqnArity :: Equation a -> Int
+eqnArity (Equation _ lhs _) = length $ snd $ flatLhs lhs
+
+-- |Select the label of a field
+fieldLabel :: Field a -> QualIdent
+fieldLabel (Field _ l _) = l
+
+-- |Select the term of a field
+fieldTerm :: Field a -> a
+fieldTerm (Field _ _ t) = t
+
+-- |Select the label and term of a field
+field2Tuple :: Field a -> (QualIdent, a)
+field2Tuple (Field _ l t) = (l, t)
+
+-- |Get the operator name of an infix operator
+opName :: InfixOp a -> QualIdent
+opName (InfixOp _ op) = op
+opName (InfixConstr _ c ) = c
+
+-- | Get the identifier of a constructor declaration
+constrId :: ConstrDecl -> Ident
+constrId (ConstrDecl _ _ _ c _) = c
+constrId (ConOpDecl _ _ _ _ op _) = op
+constrId (RecordDecl _ _ _ c _) = c
+
+-- | Get the identifier of a newtype constructor declaration
+nconstrId :: NewConstrDecl -> Ident
+nconstrId (NewConstrDecl _ c _) = c
+nconstrId (NewRecordDecl _ c _) = c
+
+-- | Get the type of a newtype constructor declaration
+nconstrType :: NewConstrDecl -> TypeExpr
+nconstrType (NewConstrDecl _ _ ty) = ty
+nconstrType (NewRecordDecl _ _ (_, ty)) = ty
+
+-- | Get record label identifiers of a constructor declaration
+recordLabels :: ConstrDecl -> [Ident]
+recordLabels (ConstrDecl _ _ _ _ _) = []
+recordLabels (ConOpDecl _ _ _ _ _ _) = []
+recordLabels (RecordDecl _ _ _ _ fs) = [l | FieldDecl _ ls _ <- fs, l <- ls]
+
+-- | Get record label identifier of a newtype constructor declaration
+nrecordLabels :: NewConstrDecl -> [Ident]
+nrecordLabels (NewConstrDecl _ _ _ ) = []
+nrecordLabels (NewRecordDecl _ _ (l, _)) = [l]
+
+-- | Get the declared method identifiers of a type class method declaration
+methods :: Decl a -> [Ident]
+methods (TypeSig _ fs _) = fs
+methods _ = []
+
+-- | Get the method identifiers of a type class method implementations
+impls :: Decl a -> [Ident]
+impls (FunctionDecl _ _ f _) = [f]
+impls _ = []
+
+-- | Get the declared method identifier of an interface method declaration
+imethod :: IMethodDecl -> Ident
+imethod (IMethodDecl _ f _ _) = f
+
+-- | Get the arity of an interface method declaration
+imethodArity :: IMethodDecl -> Maybe Int
+imethodArity (IMethodDecl _ _ a _) = a
+
+--------------------------------------------------------
+-- constructing elements of the abstract syntax tree
+--------------------------------------------------------
+
+funDecl :: Position -> a -> Ident -> [Pattern a] -> Expression a -> Decl a
+funDecl p a f ts e = FunctionDecl p a f [mkEquation p f ts e]
+
+mkEquation :: Position -> Ident -> [Pattern a] -> Expression a -> Equation a
+mkEquation p f ts e = Equation p (FunLhs f ts) (simpleRhs p e)
+
+simpleRhs :: Position -> Expression a -> Rhs a
+simpleRhs p e = SimpleRhs p e []
+
+patDecl :: Position -> Pattern a -> Expression a -> Decl a
+patDecl p t e = PatternDecl p t (SimpleRhs p e [])
+
+varDecl :: Position -> a -> Ident -> Expression a -> Decl a
+varDecl p ty = patDecl p . VariablePattern ty
+
+constrPattern :: a -> QualIdent -> [(a, Ident)] -> Pattern a
+constrPattern ty c = ConstructorPattern ty c . map (uncurry VariablePattern)
+
+caseAlt :: Position -> Pattern a -> Expression a -> Alt a
+caseAlt p t e = Alt p t (SimpleRhs p e [])
+
+mkLet :: [Decl a] -> Expression a -> Expression a
+mkLet ds e = if null ds then e else Let ds e
+
+mkVar :: a -> Ident -> Expression a
+mkVar ty = Variable ty . qualify
+
+apply :: Expression a -> [Expression a] -> Expression a
+apply = foldl Apply
+
+unapply :: Expression a -> [Expression a] -> (Expression a, [Expression a])
+unapply (Apply e1 e2) es = unapply e1 (e2 : es)
+unapply e es = (e, es)
diff --git a/test/TestBase.hs b/test/TestBase.hs
new file mode 100644
--- /dev/null
+++ b/test/TestBase.hs
@@ -0,0 +1,153 @@
+--------------------------------------------------------------------------------
+-- Test Suite for Curry Base
+--------------------------------------------------------------------------------
+--
+-- This Test Suite supports three kinds of tests:
+--
+-- 1) tests which should pass
+-- 2) tests which should pass with a specific warning
+-- 3) tests which should fail yielding a specific error message
+--
+-- In order to add a test to this suite, proceed as follows:
+--
+-- 1) Store your test code in a file (please use descriptive names) and put it
+-- in the corresponding subfolder (i.e. test/pass for passing tests,
+-- test/fail for failing tests and test/warning for passing tests producing
+-- warnings)
+-- 2) Extend the corresponding test information list (there is one for each test
+-- group at the end of this file) with the required information (i.e. name of
+-- the Curry module to be tested and expected warning/failure message(s))
+-- 3) Run 'cabal test'
+
+{-# LANGUAGE CPP #-}
+module TestBase (tests) where
+
+#if __GLASGOW_HASKELL__ < 710
+import Control.Applicative ((<$>))
+#endif
+
+import Control.Monad.Trans (lift)
+import Data.List (isInfixOf, sort)
+import Distribution.TestSuite
+import System.FilePath (FilePath, (), (<.>))
+
+import Curry.Base.Message (Message, ppMessages, ppError)
+import Curry.Base.Monad (CYIO, runCYIO, liftCYM)
+import Curry.Files.PathUtils (readModule)
+import Curry.Syntax (parseModule, unlit)
+
+tests :: IO [Test]
+tests = return [passingTests, warningTests, failingTests]
+
+-- Call the Curry parser
+parseCurry :: FilePath -> CYIO ()
+parseCurry file = do
+ msrc <- lift $ lift $ readModule file
+ case msrc of Nothing -> error $ "Missing file " ++ file
+ Just src -> liftCYM $ do ul <- unlit file src
+ parseModule file ul
+ return ()
+
+-- Execute a test by calling cymake
+runTest :: String -> [String] -> IO Progress
+runTest test [] = runCYIO (parseCurry test) >>= passOrFail
+ where
+ passOrFail = (Finished <$>) . either fail pass
+ fail msgs
+ | null msgs = return Pass
+ | otherwise = let errorStr = showMessages msgs
+ in return $ Fail $ "An unexpected failure occurred: " ++ errorStr
+ pass _ = return Pass
+runTest test errorMsgs = runCYIO (parseCurry test) >>= catchE
+ where
+ catchE = (Finished <$>) . either pass fail
+ pass msgs = let errorStr = showMessages msgs
+ in if all (`isInfixOf` errorStr) errorMsgs
+ then return Pass
+ else return $ Fail $ "Expected warning/failure did not occur: " ++ errorStr
+ fail = pass . snd
+
+showMessages :: [Message] -> String
+showMessages = show . ppMessages ppError . sort
+
+-- group of tests which should pass
+passingTests :: Test
+passingTests = Group { groupName = "Passing Tests"
+ , concurrently = False
+ , groupTests = map (mkTest "test/pass/") passInfos
+ }
+
+-- group of test which should fail yielding a specific error message
+failingTests :: Test
+failingTests = Group { groupName = "Failing Tests"
+ , concurrently = False
+ , groupTests = map (mkTest "test/fail/") failInfos
+ }
+
+-- group of tests which should pass producing a specific warning message
+warningTests :: Test
+warningTests = Group { groupName = "Warning Tests"
+ , concurrently = False
+ , groupTests = map (mkTest "test/warning/") warnInfos
+ }
+
+-- create a new test
+mkTest :: FilePath -> TestInfo -> Test
+mkTest path (testName, testTags, testOpts, mSetOpts, errorMsgs) =
+ let file = path testName <.> "curry"
+ test = TestInstance
+ { run = runTest file errorMsgs
+ , name = testName
+ , tags = testTags
+ , options = testOpts
+ , setOption = maybe (\_ _ -> Right test) id mSetOpts
+ }
+ in Test test
+
+-- Information for a test instance:
+-- * name of test
+-- * tags to classify a test
+-- * options
+-- * function to set options
+-- * optional warning/error message which should be thrown on execution of test
+type TestInfo = (String, [String], [OptionDescr], Maybe SetOption, [String])
+
+type SetOption = String -> String -> Either String TestInstance
+
+--------------------------------------------------------------------------------
+-- Definition of passing tests
+--------------------------------------------------------------------------------
+
+-- generate a simple passing test
+mkPassTest :: String -> TestInfo
+mkPassTest name = (name, [], [], Nothing, [])
+
+-- To add a passing test to the test suite simply add the module name of the
+-- test code to the following list
+-- TODO: add test cases
+passInfos :: [TestInfo]
+passInfos = map mkPassTest []
+
+--------------------------------------------------------------------------------
+-- Definition of failing tests
+--------------------------------------------------------------------------------
+
+-- generate a simple failing test
+mkFailTest :: String -> [String] -> TestInfo
+mkFailTest name errorMsgs = (name, [], [], Nothing, errorMsgs)
+
+-- To add a failing test to the test suite simply add the module name of the
+-- test code and the expected error message(s) to the following list
+-- TODO: add test cases
+failInfos :: [TestInfo]
+failInfos = map (uncurry mkFailTest) []
+
+--------------------------------------------------------------------------------
+-- Definition of warning tests
+--------------------------------------------------------------------------------
+
+-- To add a warning test to the test suite simply add the module name of the
+-- test code and the expected warning message(s) to the following list
+-- TODO: add test cases
+warnInfos :: [TestInfo]
+warnInfos = map (uncurry mkFailTest) []