packages feed

curry-base 0.2.9 → 1.0.0

raw patch · 56 files changed

+10336/−5902 lines, 56 filesdep +Cabaldep +contravariantdep +curry-basedep −sybdep ~basedep ~directorynew-uploader

Dependencies added: Cabal, contravariant, curry-base, either, extra, parsec, semigroupoids, time, transformers

Dependencies removed: syb

Dependency ranges changed: base, directory

Files

+ CHANGELOG.md view
@@ -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.
− Curry/AbstractCurry.hs 
@@ -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-    <CODE>-    (CProg modname imports typedecls functions opdecls)-    </CODE>-    where modname: name of this module,-          imports: list of modules names that are imported,-          typedecls, opdecls, functions: see below--}-data CurryProg = CurryProg String [String] [CTypeDecl] [CFuncDecl] [COpDecl]-                 deriving (Read, Show)--{- |The 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.-    <PRE>-    A data type definition of the form--    data t x1...xn = ...| c t1....tkc |...--    is represented by the Curry term--    (CType t v [i1,...,in] [...(CCons c kc v [t1,...,tkc])...])--    where each ij is the index of the type variable xj--    Note: the type variable indices are unique inside each type declaration-          and are usually numbered from 0--    Thus, a data type declaration consists of the name of the data type,-    a list of type parameters and a list of constructor declarations.-    </PRE>--}-data CTypeDecl = CType QName CVisibility [CTVarIName] [CConsDecl]-               | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr-                 deriving (Read, Show)--{- |A constructor declaration consists of the name and arity of the-    constructor and a list of the argument types of the constructor.--}-data CConsDecl = CCons QName Int CVisibility [CTypeExpr]-                 deriving (Read, Show)--{- |Data type for type expressions.-    A type expression is either a type variable, a function type,-    or a type constructor application.--    Note: the names of the predefined type constructors are-          "Int", "Float", "Bool", "Char", "IO", "Success",-          "()" (unit type), "(,...,)" (tuple types), "[]" (list type)--}-data CTypeExpr-  = CTVar CTVarIName               -- ^ type variable-  | CFuncType CTypeExpr CTypeExpr  -- ^ function type t1->t2-  | CTCons QName [CTypeExpr]       -- ^ type constructor application-  | CRecordType [CField CTypeExpr] -- ^ record type (extended Curry)-                (Maybe CTVarIName)-    deriving (Read, Show)--{- |Data type for operator declarations.-    An operator declaration "fix p n" in Curry corresponds to the-    AbstractCurry term (COp n fix p).--}-data COpDecl = COp QName CFixity 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.-    <PRE>-    A function declaration in FlatCurry is a term of the form--     (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek]))--    and represents the function "name" with definition--      name :: type-      rule1-      ...-      rulek--    Note: the variable indices are unique inside each rule--    External functions are represented as (CFunc name arity type (CExternal s))-    where s is the external name associated to this function.--    Thus, a function declaration consists of the name, arity, type, and-    a list of rules.-    </PRE>--}-data CFuncDecl = CFunc QName Int CVisibility CTypeExpr CRules-                 deriving (Read, Show)---{- |A rule is either a list of formal parameters together with an expression-    (i.e., a rule in flat form), a list of general program rules with-    an evaluation annotation, or it is externally defined--}-data CRules = CRules CEvalAnnot [CRule]-            | CExternal String-              deriving (Read, Show)--{- |Data type for classifying evaluation annotations for functions.-    They can be either flexible (default), rigid, or choice.--}-data CEvalAnnot = CFlex | CRigid | CChoice deriving (Read, Show, Eq)--{- |The most general form of a rule. It consists of a list of patterns-    (left-hand side), a list of guards ("success" if not present in the-    source text) with their corresponding right-hand sides, and-    a list of local declarations.--}-data CRule = CRule [CPattern] [(CExpr, CExpr)] [CLocalDecl]-             deriving (Read, Show)---- | Data type for representing local (let/where) declarations-data CLocalDecl-  = CLocalFunc CFuncDecl                  -- ^ local function declaration-  | CLocalPat CPattern CExpr [CLocalDecl] -- ^ local pattern declaration-  | CLocalVar CVarIName                   -- ^ local free variable declaration-    deriving (Read, Show)---- |Data type for representing Curry expressions.-data CExpr- = CVar       CVarIName            -- ^ variable (unique index / name)- | CLit       CLiteral             -- ^ literal (Integer/Float/Char constant)- | CSymbol    QName                -- ^ a defined symbol with module and name- | CApply     CExpr CExpr          -- ^ application (e1 e2)- | CLambda    [CPattern] CExpr     -- ^ lambda abstraction- | CLetDecl   [CLocalDecl] CExpr   -- ^ local let declarations- | CDoExpr    [CStatement]         -- ^ do expression- | CListComp  CExpr [CStatement]   -- ^ list comprehension- | CCase      CExpr [CBranchExpr]  -- ^ case expression- | CRecConstr [CField CExpr]       -- ^ record construction (extended Curry)- | CRecSelect CExpr CLabel         -- ^ field selection (extended Curry)- | CRecUpdate [CField CExpr] CExpr -- ^ record update (extended Curry)-   deriving (Read, Show)--{- |Data type for representing statements in do expressions and-    list comprehensions.--}-data CStatement-  = CSExpr CExpr         -- ^ an expression (I/O action or boolean)-  | CSPat CPattern CExpr -- ^ a pattern definition-  | CSLet [CLocalDecl]   -- ^ a local let declaration-    deriving (Read, Show)---- |Data type for representing pattern expressions.-data CPattern-    -- |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"
− Curry/Base/Ident.lhs 
@@ -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:"
− Curry/Base/MessageMonad.hs 
@@ -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]
− Curry/Base/Position.lhs 
@@ -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}
− Curry/ExtendedFlat/CurryArithmetics.hs 
@@ -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"
− Curry/ExtendedFlat/EraseTypes.hs 
@@ -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", "()")) []
− Curry/ExtendedFlat/Goodies.hs 
@@ -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
− Curry/ExtendedFlat/LiftLetrec.hs 
@@ -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
− Curry/ExtendedFlat/MonadicGoodies.hs 
@@ -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-
− Curry/ExtendedFlat/Type.hs 
@@ -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---- <CODE>----  (Prog modname imports typedecls functions opdecls translation_table)---- </CODE>---- where modname: name of this module,----       imports: list of modules names that are imported,----       typedecls, opdecls, functions, translation of type names----       and constructor/function names: see below--data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl] -	    deriving (Read, Show, Eq,Data,Typeable)-------------------------------------------------------------------------------- The data type for representing qualified names.---- In FlatCurry all names are qualified to avoid name clashes.---- The first component is the module name and the second component the---- unqualified name as it occurs in the source program.---- The additional information about source references and types should---- be invisible for the normal usage of QName.----------------------------------------------------------------------------data QName = QName {srcRef      :: Maybe SrcRef,-                    typeofQName :: Maybe TypeExpr,-                    modName     :: String,-                    localName   :: String} deriving (Data,Typeable)---instance Read QName where-  readsPrec d r = -      [ (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.---- <PRE>---- A data type definition of the form-------- data t x1...xn = ...| c t1....tkc |...-------- is represented by the FlatCurry term-------- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])-------- where each ij is the index of the type variable xj-------- Note: the type variable indices are unique inside each type declaration----       and are usually numbered from 0-------- Thus, a data type declaration consists of the name of the data type,---- a list of type parameters and a list of constructor declarations.---- </PRE>--data TypeDecl = Type    QName Visibility [TVarIndex] [ConsDecl]-              | TypeSyn QName Visibility [TVarIndex] TypeExpr-	      deriving (Read, Show, Eq,Data,Typeable)----- A constructor declaration consists of the name and arity of the---- constructor and a list of the argument types of the constructor.--data ConsDecl = Cons QName Int Visibility [TypeExpr]-	      deriving (Read, Show, Eq,Data,Typeable)------ Data type for type expressions.---- A type expression is either a type variable, a function type,---- or a type constructor application.-------- Note: the names of the predefined type constructors are----       "Int", "Float", "Bool", "Char", "IO", "Success",----       "()" (unit type), "(,...,)" (tuple types), "[]" (list type)--data TypeExpr =-     TVar !TVarIndex                 -- type variable-   | FuncType TypeExpr TypeExpr     -- function type t1->t2-   | TCons QName [TypeExpr]         -- type constructor application-   deriving (Read, Show, Eq,Data,Typeable)            --    TCons module name typeargs------ Data type for operator declarations.---- An operator declaration "fix p n" in Curry corresponds to the---- FlatCurry term (Op n fix p).---- Note: the constructor definition of 'Op' differs from the original---- PAKCS definition using Haskell type 'Integer' instead of 'Int'---- for representing the precedence. --data OpDecl = Op QName Fixity Integer deriving (Read, Show, Eq,Data,Typeable)----- Data types for the different choices for the fixity of an operator.--data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Read, Show, Eq,Data,Typeable)------ Data type for representing object variables.---- Object variables occurring in expressions are represented by (Var i)---- where i is a variable index.----- Data type for representing function declarations.---- <PRE>---- A function declaration in FlatCurry is a term of the form--------  (Func name arity type (Rule [i_1,...,i_arity] e))-------- and represents the function "name" with definition--------   name :: type----   name x_1...x_arity = e-------- where each i_j is the index of the variable x_j-------- Note: the variable indices are unique inside each function declaration----       and are usually numbered from 0-------- External functions are represented as (Func name arity type (External s))---- where s is the external name associated to this function.-------- Thus, a function declaration consists of the name, arity, type, and rule.---- </PRE>--data FuncDecl = Func QName Int Visibility TypeExpr Rule-	      deriving (Read, Show, Eq,Data,Typeable)------ A rule is either a list of formal parameters together with an expression---- or an "External" tag.--data Rule = Rule [VarIndex] Expr-          | External String-	  deriving (Read, Show, Eq,Data,Typeable)----- Data type for classifying case expressions.---- Case expressions can be either flexible or rigid in Curry.--data CaseType = Rigid | Flex deriving (Read, Show, Eq,Data,Typeable)----- Data type for classifying combinations---- (i.e., a function/constructor applied to some arguments).---- @cons FuncCall     - a call to a function all arguments are provided---- @cons ConsCall     - a call with a constructor at the top,----                      all arguments are provided---- @cons FuncPartCall - a partial call to a function----                      (i.e., not all arguments are provided) ----                      where the parameter is the number of----                      missing arguments---- @cons ConsPartCall - a partial call to a constructor along with ----                      number of missing arguments--data CombType = FuncCall -              | ConsCall -              | FuncPartCall Int -              | ConsPartCall Int deriving (Read, Show, Eq,Data,Typeable)----- Data type for representing expressions.-------- Remarks:---- <PRE>---- 1. if-then-else expressions are represented as function calls:----      (if e1 then e2 else e3)----    is represented as----      (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])---- ---- 2. Higher order applications are represented as calls to the (external)----    function "apply". For instance, the rule----      app f x = f x----    is represented as----      (Rule  [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))---- ---- 3. A conditional rule is represented as a call to an external function----    "cond" where the first argument is the condition (a constraint).----    For instance, the rule----      equal2 x | x=:=2 = success----    is represented as----      (Rule [0]----            (Comb FuncCall ("Prelude","cond")----                  [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],----                   Comb FuncCall ("Prelude","success") []]))---- ---- 4. Functions with evaluation annotation "choice" are represented----    by a rule whose right-hand side is enclosed in a call to the----    external function "Prelude.commit".----    Furthermore, all rules of the original definition must be----    represented by conditional expressions (i.e., (cond [c,e]))----    after pattern matching.----    Example:---- ----       m eval choice----       m [] y = y----       m x [] = x---- ----    is translated into (note that the conditional branches can be also----    wrapped with Free declarations in general):---- ----       Rule [0,1]----            (Comb FuncCall ("Prelude","commit")----              [Or (Case Rigid (Var 0)----                     [(Pattern ("Prelude","[]") []----                         (Comb FuncCall ("Prelude","cond")----                               [Comb FuncCall ("Prelude","success") [],----                                Var 1]))] )----                  (Case Rigid (Var 1)----                     [(Pattern ("Prelude","[]") []----                         (Comb FuncCall ("Prelude","cond")----                               [Comb FuncCall ("Prelude","success") [],----                                Var 0]))] )])---- ----    Operational meaning of (Prelude.commit e):----    evaluate e with local search spaces and commit to the first----    (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c----    is satisfied---- </PRE>---- @cons Var - variable (represented by unique index)---- @cons Lit - literal (Integer/Float/Char constant)---- @cons Comb - application (f e1 ... en) of function/constructor f----              with n<=arity(f)---- @cons Free - introduction of free local variables---- @cons Or - disjunction of two expressions (used to translate rules----            with overlapping left-hand sides)---- @cons Case - case distinction (rigid or flex)--data Expr = Var VarIndex -          | Lit Literal-          | Comb CombType QName [Expr]-          | Free [VarIndex] Expr-          | Let [(VarIndex,Expr)] Expr-          | Or Expr Expr-          | Case SrcRef CaseType Expr [BranchExpr]-	  deriving (Read, Show, Eq,Data,Typeable)------ Data type for representing branches in a case expression.---- <PRE>---- Branches "(m.c x1...xn) -> e" in case expressions are represented as--------   (Branch (Pattern (m,c) [i1,...,in]) e)-------- where each ij is the index of the pattern variable xj, or as--------   (Branch (LPattern (Intc i)) e)-------- for integers as branch patterns (similarly for other literals---- like float or character constants).---- </PRE>--data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq,Data,Typeable)----- Data type for representing patterns in case expressions.--data Pattern = Pattern QName [VarIndex]-             | LPattern Literal-	     deriving (Read, Show, Eq,Data,Typeable)----- Data type for representing literals occurring in an expression---- or case branch. It is either an integer, a float, or a character constant.---- Note: the constructor definition of 'Intc' differs from the original---- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'---- to provide an unlimited range of integer numbers. Furthermore---- float values are represented with Haskell type 'Double' instead of---- 'Float'.--data Literal = Intc   SrcRef Integer-             | Floatc SrcRef Double-             | Charc  SrcRef Char-	     deriving (Read, Show, Eq,Data,Typeable)-------------------------------------------------------------------------------------------------------------------------------------------------------------------- Reads 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----------------------------------------------------------------------------------------------------------------------------------------------------------------
− Curry/ExtendedFlat/TypeInference.hs 
@@ -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)}---
− Curry/ExtendedFlat/UnMutual.hs 
@@ -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)---
− Curry/Files/Filenames.hs 
@@ -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
− Curry/Files/PathUtils.hs 
@@ -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
− Curry/FlatCurry/Goodies.hs 
@@ -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-
− Curry/FlatCurry/Tools.hs 
@@ -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
− Curry/FlatCurry/Type.hs 
@@ -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-    <CODE>-      (Prog modname imports typedecls functions opdecls translation_table)-    </CODE>-    where modname: name of this module,-          imports: list of modules names that are imported,-          typedecls, opdecls, functions, translation of type names-          and constructor/function names: see below--}-data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]-            deriving (Read, Show, Eq)--{- |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.-    <PRE>-    A data type definition of the form--    data t x1...xn = ...| c t1....tkc |...--    is represented by the FlatCurry term--    (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])--    where each ij is the index of the type variable xj--    Note: the type variable indices are unique inside each type declaration-          and are usually numbered from 0--    Thus, a data type declaration consists of the name of the data type,-    a list of type parameters and a list of constructor declarations.-    </PRE>--}-data TypeDecl = Type    QName Visibility [TVarIndex] [ConsDecl]-              | TypeSyn QName Visibility [TVarIndex] TypeExpr-                deriving (Read, Show, Eq)--{- |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.-    <PRE>-    A function declaration in FlatCurry is a term of the form--      (Func name arity type (Rule [i_1,...,i_arity] e))--    and represents the function "name" with definition--      name :: type-      name x_1...x_arity = e--    where each i_j is the index of the variable x_j--    Note: the variable indices are unique inside each function declaration-          and are usually numbered from 0--    External functions are represented as (Func name arity type (External s))-    where s is the external name associated to this function.--    Thus, a function declaration consists of the name, arity, type, and rule.-    </PRE>--}-data FuncDecl = Func QName Int Visibility TypeExpr Rule-                deriving (Read, Show, Eq)---{- |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:-    <PRE>-    1. if-then-else expressions are represented as function calls:-          (if e1 then e2 else e3)-        is represented as-          (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])--    2. Higher order applications are represented as calls to the (external)-        function "apply". For instance, the rule-          app f x = f x-        is represented as-          (Rule  [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))--    3. A conditional rule is represented as a call to an external function-        "cond" where the first argument is the condition (a constraint).-        For instance, the rule-          equal2 x | x=:=2 = success-        is represented as-          (Rule [0]-                (Comb FuncCall ("Prelude","cond")-                      [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],-                      Comb FuncCall ("Prelude","success") []]))--    4. Functions with evaluation annotation "choice" are represented-        by a rule whose right-hand side is enclosed in a call to the-        external function "Prelude.commit".-        Furthermore, all rules of the original definition must be-        represented by conditional expressions (i.e., (cond [c,e]))-        after pattern matching.-        Example:--          m eval choice-          m [] y = y-          m x [] = x--        is translated into (note that the conditional branches can be also-        wrapped with Free declarations in general):--          Rule [0,1]-                (Comb FuncCall ("Prelude","commit")-                  [Or (Case Rigid (Var 0)-                        [(Pattern ("Prelude","[]") []-                            (Comb FuncCall ("Prelude","cond")-                                  [Comb FuncCall ("Prelude","success") [],-                                    Var 1]))] )-                      (Case Rigid (Var 1)-                        [(Pattern ("Prelude","[]") []-                            (Comb FuncCall ("Prelude","cond")-                                  [Comb FuncCall ("Prelude","success") [],-                                    Var 0]))] )])--        Operational meaning of (Prelude.commit e):-        evaluate e with local search spaces and commit to the first-        (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c-        is satisfied-    </PRE>--}-data Expr-  -- |variable (represented by unique index)-  = Var VarIndex-  -- |literal (Integer/Float/Char constant)-  | Lit Literal-  -- |application (f e1 ... en) of function/constructor f with n<=arity(f)-  | Comb CombType QName [Expr]-  -- |introduction of free local variables-  | Free [VarIndex] Expr-  | Let [(VarIndex, Expr)] Expr-  {- |disjunction of two expressions (used to translate rules with overlapping-      left-hand sides) -}-  | Or Expr Expr-  -- |case distinction (rigid or flex)-  | Case CaseType Expr [BranchExpr]-    deriving (Read, Show, Eq)---{- |Data type for representing branches in a case expression.-    <PRE>-    Branches "(m.c x1...xn) -> e" in case expressions are represented as--      (Branch (Pattern (m,c) [i1,...,in]) e)--    where each ij is the index of the pattern variable xj, or as--      (Branch (LPattern (Intc i)) e)--    for integers as branch patterns (similarly for other literals-    like float or character constants).-    </PRE>--}-data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq)---- |Data type for representing patterns in case expressions.-data Pattern = Pattern QName [VarIndex]-             | LPattern Literal-               deriving (Read, Show, Eq)--{- |Data type for representing literals occurring in an expression-    or case branch. It is either an integer, a float, or a character constant.-    Note: the constructor definition of 'Intc' differs from the original-    PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'-    to provide an unlimited range of integer numbers. Furthermore-    float values are represented with Haskell type 'Double' instead of-    'Float'.--}-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
LICENSE view
@@ -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
curry-base.cabal view
@@ -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 <bjp@informatik.uni-kiel.de>-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
+ src/Curry/AbstractCurry.hs view
@@ -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
+ src/Curry/AbstractCurry/Files.hs view
@@ -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"
+ src/Curry/AbstractCurry/Type.hs view
@@ -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)
+ src/Curry/Base/Ident.hs view
@@ -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)
+ src/Curry/Base/LLParseComb.hs view
@@ -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
+ src/Curry/Base/LexComb.hs view
@@ -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
+ src/Curry/Base/Message.hs view
@@ -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
+ src/Curry/Base/Monad.hs view
@@ -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))
+ src/Curry/Base/Position.hs view
@@ -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
+ src/Curry/Base/Pretty.hs view
@@ -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]
+ src/Curry/Base/Span.hs view
@@ -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
+ src/Curry/CondCompile/Parser.hs view
@@ -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
+ src/Curry/CondCompile/Transform.hs view
@@ -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 ""
+ src/Curry/CondCompile/Type.hs view
@@ -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 ">="
+ src/Curry/Files/Filenames.hs view
@@ -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
+ src/Curry/Files/PathUtils.hs view
@@ -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)
+ src/Curry/Files/Unlit.hs view
@@ -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."+                     ]
+ src/Curry/FlatCurry.hs view
@@ -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
+ src/Curry/FlatCurry/Annotated/Goodies.hs view
@@ -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
+ src/Curry/FlatCurry/Annotated/Type.hs view
@@ -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)
+ src/Curry/FlatCurry/Annotated/Typing.hs view
@@ -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
+ src/Curry/FlatCurry/Files.hs view
@@ -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
+ src/Curry/FlatCurry/Goodies.hs view
@@ -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)
+ src/Curry/FlatCurry/InterfaceEquivalence.hs view
@@ -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 (=~=) = (==)
+ src/Curry/FlatCurry/Pretty.hs view
@@ -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
+ src/Curry/FlatCurry/Type.hs view
@@ -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)
+ src/Curry/Syntax.hs view
@@ -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
+ src/Curry/Syntax/Extension.hs view
@@ -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
+ src/Curry/Syntax/InterfaceEquivalence.hs view
@@ -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
+ src/Curry/Syntax/Lexer.hs view
@@ -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 "<end-of-file>"++-- ---------------------------------------------------------------------------+-- 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
+ src/Curry/Syntax/Parser.hs view
@@ -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 ::= <identifier>+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 ::= '\'' <escaped character> '\''+--          |  <integer>+--          |  <float>+--          |  '"' <escaped string> '"'+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 ::= <integer> | <char> | <float> | <string>+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
+ src/Curry/Syntax/Pretty.hs view
@@ -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
+ src/Curry/Syntax/ShowModule.hs view
@@ -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 "\""
+ src/Curry/Syntax/Type.hs view
@@ -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"
+ src/Curry/Syntax/Utils.hs view
@@ -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)
+ test/TestBase.hs view
@@ -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) []