diff --git a/Curry/Base/Ident.lhs b/Curry/Base/Ident.lhs
new file mode 100644
--- /dev/null
+++ b/Curry/Base/Ident.lhs
@@ -0,0 +1,353 @@
+> {-# LANGUAGE DeriveDataTypeable #-}
+
+% $Id: Ident.lhs,v 1.21 2004/10/29 13:08:09 wlux Exp $
+%
+% Copyright (c) 1999-2004, Wolfgang Lux
+% See LICENSE for the full license.
+%
+\nwfilename{Ident.lhs}
+\section{Identifiers}
+This module provides the implementation of identifiers and some
+utility functions for identifiers, which are used at various places in
+the compiler.
+
+Identifiers comprise the name of the denoted entity and an \emph{id},
+which can be used for renaming identifiers, e.g., in order to resolve
+name conflicts between identifiers from different scopes. An
+identifier with an \emph{id} $0$ is considered as not being renamed
+and, hence, its \emph{id} will not be shown.
+
+\ToDo{Probably we should use \texttt{Integer} for the \emph{id}s.}
+
+Qualified identifiers may optionally be prefixed by a module
+name. \textbf{The order of the cases \texttt{UnqualIdent} and
+\texttt{QualIdent} is important. Some parts of the compiler rely on
+the fact that all qualified identifiers are greater than any
+unqualified identifier.}
+\begin{verbatim}
+
+> module Curry.Base.Ident(Ident(..), showIdent,
+> QualIdent(..),ModuleIdent(..),SrcRefOf(..),
+> mkIdent, qualName,
+> renameIdent, unRenameIdent,
+> mkMIdent, moduleName,
+> isInfixOp, isQInfixOp,
+> qualify, qualifyWith, qualQualify,
+> isQualified, unqualify, qualUnqualify,
+> localIdent, -- splitQualIdent,
+> emptyMIdent, mainMIdent,preludeMIdent,
+> anonId,unitId,boolId,charId,intId,floatId,listId,ioId,
+> successId,trueId,falseId,nilId,consId,mainId,
+> tupleId,isTupleId,tupleArity,
+> minusId,fminusId,updIdentName,
+> qUnitId,qBoolId,qCharId,qIntId,qFloatId,qListId,qIOId,
+> qSuccessId,qTrueId,qFalseId,qNilId,qConsId,
+> qTupleId,isQTupleId,qTupleArity,
+> fpSelectorId,isFpSelectorId,isQualFpSelectorId,
+> recSelectorId,qualRecSelectorId,
+> recUpdateId, qualRecUpdateId, recordExtId, labelExtId,
+> isRecordExtId, isLabelExtId, fromRecordExtId, fromLabelExtId,
+> renameLabel,
+> recordExt, labelExt, mkLabelIdent,-- hasPositionIdent,
+> addPositionIdent,
+> addPositionModuleIdent,addRef,addRefId,
+> positionOfQualIdent,updQualIdent ) where
+
+> import Control.Monad(liftM)
+> import Data.Char
+> import Data.List
+> import Data.Maybe
+> import Data.Generics
+> import Data.Function(on)
+
+> import Curry.Base.Position
+
+
+Simple identifiers
+
+> data Ident = Ident { positionOfIdent :: Position,
+> name :: String,
+> uniqueId :: Int }
+> deriving (Read, Data, Typeable)
+>
+> instance Eq Ident where
+> Ident _ m i == Ident _ n j = (m,i) == (n, j)
+>
+> instance Ord Ident where
+> Ident _ m i `compare` Ident _ n j = (m,i) `compare` (n, j)
+>
+> instance Show Ident where
+> show = showIdent
+>
+> showIdent :: Ident -> String
+> showIdent (Ident _ x 0) = x
+> showIdent (Ident _ x n) = x ++ '.' : show n
+
+
+Qualified identifiers
+
+> data QualIdent = QualIdent { qualidMod :: Maybe ModuleIdent,
+> qualidId:: Ident }
+> deriving (Eq, Ord, Read, Data,Typeable)
+
+> qualName :: QualIdent -> String
+> qualName (QualIdent Nothing x) = name x
+> qualName (QualIdent (Just m) x) = moduleName m ++ "." ++ name x
+
+> instance Show QualIdent where
+> show = qualName
+
+Module names
+
+> data ModuleIdent = ModuleIdent { positionOfModuleIdent :: Position,
+> moduleQualifiers :: [String] }
+> deriving (Read, Data,Typeable)
+
+> instance Eq ModuleIdent where
+> (==) = (==) `on` moduleQualifiers
+
+> instance Ord ModuleIdent where
+> compare = compare `on` moduleQualifiers
+
+> moduleName :: ModuleIdent -> String
+> moduleName = concat . intersperse "." . moduleQualifiers
+
+> instance Show ModuleIdent where
+> show = moduleName
+
+-- -----------------------------------------
+
+> addPositionIdent :: Position -> Ident -> Ident
+> addPositionIdent pos (Ident NoPos x n) = Ident pos x n
+> addPositionIdent AST{astRef=sr} (Ident pos x n)
+> = Ident pos{astRef=sr} x n
+> addPositionIdent pos (Ident _ x n) = Ident pos x n
+
+> addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent
+> addPositionModuleIdent pos (ModuleIdent _ x) = ModuleIdent pos x
+
+> positionOfQualIdent :: QualIdent -> Position
+> positionOfQualIdent = positionOfIdent . qualidId
+
+> mkIdent :: String -> Ident
+> mkIdent x = Ident NoPos x 0
+
+> renameIdent :: Ident -> Int -> Ident
+> renameIdent (Ident p x _) n = Ident p x n
+
+
+> unRenameIdent :: Ident -> Ident
+> unRenameIdent (Ident p x _) = Ident p x 0
+
+> mkMIdent :: [String] -> ModuleIdent
+> mkMIdent = ModuleIdent NoPos
+
+> isInfixOp :: Ident -> Bool
+> isInfixOp (Ident _ ('<':c:cs) _)=
+> last (c:cs) /= '>' || not (isAlphaNum c) && c `notElem` "_(["
+> isInfixOp (Ident _ (c:_) _) = not (isAlphaNum c) && c `notElem` "_(["
+> isInfixOp (Ident _ _ _) = False -- error "Zero-length identifier"
+
+> isQInfixOp :: QualIdent -> Bool
+> isQInfixOp (QualIdent _ x) = isInfixOp x
+
+\end{verbatim}
+The functions \texttt{qualify} and \texttt{qualifyWith} convert an
+unqualified identifier into a qualified identifier (without and with a
+given module prefix, respectively).
+\begin{verbatim}
+
+> qualify :: Ident -> QualIdent
+> qualify = QualIdent Nothing
+
+> qualifyWith :: ModuleIdent -> Ident -> QualIdent
+> qualifyWith = QualIdent . Just
+
+> qualQualify :: ModuleIdent -> QualIdent -> QualIdent
+> qualQualify m (QualIdent Nothing x) = QualIdent (Just m) x
+> qualQualify _ x = x
+
+> isQualified :: QualIdent -> Bool
+> isQualified (QualIdent m _) = isJust m
+
+> unqualify :: QualIdent -> Ident
+> unqualify (QualIdent _ x) = x
+
+> qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent
+> qualUnqualify _ qid@(QualIdent Nothing _) = qid
+> qualUnqualify m (QualIdent (Just m') x) = QualIdent m'' x
+> where m'' | m == m' = Nothing
+> | otherwise = Just m'
+
+> localIdent :: ModuleIdent -> QualIdent -> Maybe Ident
+> localIdent _ (QualIdent Nothing x) = Just x
+> localIdent m (QualIdent (Just m') x)
+> | m == m' = Just x
+> | otherwise = Nothing
+
+> splitQualIdent :: QualIdent -> (Maybe ModuleIdent,Ident)
+> splitQualIdent (QualIdent m x) = (m,x)
+
+> updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident) -> QualIdent -> QualIdent
+> updQualIdent f g (QualIdent m x) = QualIdent (liftM f m) (g x)
+
+> addRef :: SrcRef -> QualIdent -> QualIdent
+> addRef r = updQualIdent id (addRefId r)
+
+> addRefId :: SrcRef -> Ident -> Ident
+> addRefId = addPositionIdent . AST
+
+\end{verbatim}
+A few identifiers a predefined here.
+\begin{verbatim}
+
+> emptyMIdent, mainMIdent, preludeMIdent :: ModuleIdent
+> emptyMIdent = ModuleIdent NoPos []
+> mainMIdent = ModuleIdent NoPos ["main"]
+> preludeMIdent = ModuleIdent NoPos ["Prelude"]
+
+> anonId :: Ident
+> anonId = Ident NoPos "_" 0
+
+> unitId, boolId, charId, intId, floatId, listId, ioId, successId :: Ident
+> unitId = Ident NoPos "()" 0
+> boolId = Ident NoPos "Bool" 0
+> charId = Ident NoPos "Char" 0
+> intId = Ident NoPos "Int" 0
+> floatId = Ident NoPos "Float" 0
+> listId = Ident NoPos "[]" 0
+> ioId = Ident NoPos "IO" 0
+> successId = Ident NoPos "Success" 0
+
+> trueId, falseId, nilId, consId :: Ident
+> trueId = Ident NoPos "True" 0
+> falseId = Ident NoPos "False" 0
+> nilId = Ident NoPos "[]" 0
+> consId = Ident NoPos ":" 0
+
+> tupleId :: Int -> Ident
+> tupleId n
+> | n >= 2 = Ident NoPos ("(" ++ replicate (n - 1) ',' ++ ")") 0
+> | otherwise = error "internal error: tupleId"
+
+> isTupleId :: Ident -> Bool
+> isTupleId x = n > 1 && x == tupleId n
+> where n = length (name x) - 1
+
+> tupleArity :: Ident -> Int
+> tupleArity x
+> | n > 1 && x == tupleId n = n
+> | otherwise = error "internal error: tupleArity"
+> where n = length (name x) - 1
+
+> mainId, minusId, fminusId :: Ident
+> mainId = Ident NoPos "main" 0
+> minusId = Ident NoPos "-" 0
+> fminusId = Ident NoPos "-." 0
+
+> qUnitId, qNilId, qConsId, qListId :: QualIdent
+> qUnitId = QualIdent Nothing unitId
+> qListId = QualIdent Nothing listId
+> qNilId = QualIdent Nothing nilId
+> qConsId = QualIdent Nothing consId
+
+> qBoolId, qCharId, qIntId, qFloatId, qSuccessId, qIOId :: QualIdent
+> qBoolId = QualIdent (Just preludeMIdent) boolId
+> qCharId = QualIdent (Just preludeMIdent) charId
+> qIntId = QualIdent (Just preludeMIdent) intId
+> qFloatId = QualIdent (Just preludeMIdent) floatId
+> qSuccessId = QualIdent (Just preludeMIdent) successId
+> qIOId = QualIdent (Just preludeMIdent) ioId
+
+> qTrueId, qFalseId :: QualIdent
+> qTrueId = QualIdent (Just preludeMIdent) trueId
+> qFalseId = QualIdent (Just preludeMIdent) falseId
+
+> qTupleId :: Int -> QualIdent
+> qTupleId = QualIdent Nothing . tupleId
+
+> isQTupleId :: QualIdent -> Bool
+> isQTupleId = isTupleId . unqualify
+
+> qTupleArity :: QualIdent -> Int
+> qTupleArity = tupleArity . unqualify
+
+\end{verbatim}
+Micellaneous function for generating and testing extended identifiers.
+\begin{verbatim}
+
+> fpSelectorId :: Int -> Ident
+> fpSelectorId n = Ident NoPos (fpSelExt ++ show n) 0
+
+> isFpSelectorId :: Ident -> Bool
+> isFpSelectorId f = any (fpSelExt `isPrefixOf`) (tails (name f))
+
+> isQualFpSelectorId :: QualIdent -> Bool
+> isQualFpSelectorId = isFpSelectorId . unqualify
+
+> recSelectorId :: QualIdent -> Ident -> Ident
+> recSelectorId r l =
+> mkIdent (recSelExt ++ name (unqualify r) ++ "." ++ name l)
+
+> qualRecSelectorId :: ModuleIdent -> QualIdent -> Ident -> QualIdent
+> qualRecSelectorId m r l = qualifyWith m' (recSelectorId r l)
+> where m' = (fromMaybe m (fst (splitQualIdent r)))
+
+> recUpdateId :: QualIdent -> Ident -> Ident
+> recUpdateId r l =
+> mkIdent (recUpdExt ++ name (unqualify r) ++ "." ++ name l)
+
+> qualRecUpdateId :: ModuleIdent -> QualIdent -> Ident -> QualIdent
+> qualRecUpdateId m r l = qualifyWith m' (recUpdateId r l)
+> where m' = (fromMaybe m (fst (splitQualIdent r)))
+
+> recordExtId :: Ident -> Ident
+> recordExtId r = mkIdent (recordExt ++ name r)
+
+> labelExtId :: Ident -> Ident
+> labelExtId l = mkIdent (labelExt ++ name l)
+
+> fromRecordExtId :: Ident -> Ident
+> fromRecordExtId r
+> | p == recordExt = mkIdent r'
+> | otherwise = r
+> where (p,r') = splitAt (length recordExt) (name r)
+
+> fromLabelExtId :: Ident -> Ident
+> fromLabelExtId l
+> | p == labelExt = mkIdent l'
+> | otherwise = l
+> where (p,l') = splitAt (length labelExt) (name l)
+
+> isRecordExtId :: Ident -> Bool
+> isRecordExtId r = recordExt `isPrefixOf` name r
+
+> isLabelExtId :: Ident -> Bool
+> isLabelExtId l = labelExt `isPrefixOf` name l
+
+> mkLabelIdent :: String -> Ident
+> mkLabelIdent c = renameIdent (mkIdent c) (-1)
+
+> renameLabel :: Ident -> Ident
+> renameLabel l = renameIdent l (-1)
+
+
+> fpSelExt, recSelExt, recUpdExt, recordExt, labelExt :: String
+> fpSelExt = "_#selFP"
+> recSelExt = "_#selR@"
+> recUpdExt = "_#updR@"
+> recordExt = "_#Rec:"
+> labelExt = "_#Lab:"
+
+
+> instance SrcRefOf Ident where
+> srcRefOf = srcRefOf . positionOfIdent
+
+> instance SrcRefOf QualIdent where
+> srcRefOf = srcRefOf . unqualify
+
+> updIdentName :: (String -> String) -> Ident -> Ident
+> updIdentName f ident = let p=positionOfIdent ident
+> i=uniqueId ident
+> n=name ident in
+> addPositionIdent p $ flip renameIdent i $ mkIdent (f n)
diff --git a/Curry/Base/MessageMonad.hs b/Curry/Base/MessageMonad.hs
new file mode 100644
--- /dev/null
+++ b/Curry/Base/MessageMonad.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-
+ The \texttt{MsgMonad} type is used for describing the result of a
+ computation that can fail. In contrast to the standard \texttt{Maybe}
+ type, its \texttt{Error} case provides for an error message that
+ describes the failure.
+-}
+
+module Curry.Base.MessageMonad where
+
+import Control.Monad.Error
+import Control.Monad.Writer
+import Control.Monad.Identity
+
+import Curry.Base.Position
+
+
+type MsgMonadT m = ErrorT WarnMsg (WriterT [WarnMsg] m)
+
+type MsgMonad = MsgMonadT Identity
+
+type MsgMonadIO = MsgMonadT IO
+
+data WarnMsg = WarnMsg { warnPos :: Maybe Position,
+ warnTxt :: String
+ }
+instance Error WarnMsg where
+ noMsg = WarnMsg Nothing "Failure!"
+ strMsg = WarnMsg Nothing
+
+instance Show WarnMsg where
+ show = showWarning
+
+showWarning w = "Warning: " ++ pos ++ warnTxt w
+ where pos = case warnPos w of
+ Nothing -> ""
+ Just p -> show p ++": "
+
+showError w = "Error: " ++ pos ++ warnTxt w
+ where pos = case warnPos w of
+ Nothing -> ""
+ Just p -> show p ++": "
+
+ok :: MsgMonad a -> a
+ok = either (error . showError) id . fst . runMsg
+
+
+failWith :: (MonadError a m, Error a) => String -> m a1
+failWith = throwError . strMsg
+
+
+failWithAt :: (MonadError WarnMsg m) => Position -> String -> m a
+failWithAt p s = throwError (WarnMsg (Just p) s)
+
+
+warnMessage :: (MonadWriter [WarnMsg] m) => String -> m ()
+warnMessage s = tell [WarnMsg Nothing s]
+
+
+warnMessageAt :: (MonadWriter [WarnMsg] m) => Position -> String -> m ()
+warnMessageAt p s = tell [WarnMsg (Just p) s]
+
+runMsg :: MsgMonad a -> (Either WarnMsg a, [WarnMsg])
+runMsg = runIdentity . runWriterT . runErrorT
+
+-- returnIO :: MsgMonad a -> MsgMonadIO a
+-- returnIO x = return$ (runIdentity . runWriterT . runErrorT) x
+
+runMsgIO :: MsgMonad a -> (a -> IO (MsgMonad b)) -> IO (MsgMonad b)
+runMsgIO m f
+ = case runMsg m of
+ (Left e, msgs) -> return (tell msgs >> throwError e)
+ (Right x, msgs) -> do m' <- f x
+ case runMsg m' of
+ (Left _,_) -> return m'
+ (Right x', msgs') -> return (tell (msgs ++ msgs') >> return x')
+
+dropIO :: MsgMonad a -> MsgMonadIO a
+dropIO x = case runMsg x of
+ (Left e, m) -> tell m >> throwError e
+ (Right x, m) -> tell m >> return x
diff --git a/Curry/Base/Position.lhs b/Curry/Base/Position.lhs
new file mode 100644
--- /dev/null
+++ b/Curry/Base/Position.lhs
@@ -0,0 +1,99 @@
+> {-# LANGUAGE DeriveDataTypeable #-}
+
+% -*- LaTeX -*-
+% $Id: Position.lhs,v 1.2 2000/10/08 09:55:43 lux Exp $
+%
+% $Log: Position.lhs,v $
+% Revision 1.2 2000/10/08 09:55:43 lux
+% Column numbers now start at 1. If the column number is less than 1 it
+% will not be shown.
+%
+% Revision 1.1 2000/07/23 11:03:37 lux
+% Positions now implemented in a separate module.
+%
+%
+\nwfilename{Position.lhs}
+\section{Positions}
+A source file position consists of a filename, a line number, and a
+column number. A tab stop is assumed at every eighth column.
+\begin{verbatim}
+
+> module Curry.Base.Position where
+> import Data.Generics
+
+> newtype SrcRef = SrcRef [Int] deriving (Typeable,Data) -- a pointer to the origin
+
+-- the instances for standard classes or such that SrcRefs are invisible
+
+> instance Show SrcRef where show _ = ""
+> instance Read SrcRef where readsPrec _ s = [(noRef,s)]
+> instance Eq SrcRef where _ == _ = True
+> instance Ord SrcRef where compare _ _ = EQ
+
+> noRef :: SrcRef
+> noRef = SrcRef []
+>
+> incSrcRef :: SrcRef -> Int -> SrcRef
+> incSrcRef (SrcRef [i]) j = SrcRef [i+j]
+> incSrcRef is _ = error $ "internal error; increment source ref: " ++ show is
+
+> data Position
+> = Position{ file :: FilePath, line :: Int, column :: Int, astRef :: SrcRef }
+> | AST { astRef :: SrcRef }
+> | NoPos
+> deriving (Eq, Ord,Data,Typeable)
+
+> 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
+
+> tabWidth :: Int
+> tabWidth = 8
+
+> first :: FilePath -> Position
+> first fn = Position fn 1 1 noRef
+
+> incr :: Position -> Int -> Position
+> incr p@Position{column=c} n = p{column=c + n}
+> incr p _ = p
+
+> next :: Position -> Position
+> next = flip incr 1
+
+> tab :: Position -> Position
+> tab p@Position{column=c} = p{column=c + tabWidth - (c - 1) `mod` tabWidth}
+> tab p = p
+
+> nl :: Position -> Position
+> nl p@Position{line=l} = p{line=l + 1, column=1}
+> nl p = p
+
+> showLine :: Position -> String
+> showLine NoPos = ""
+> showLine AST{} = ""
+> showLine Position{line=l,column=c}
+> = "(line " ++ show l ++ "." ++ show c ++ ") "
+
+\end{verbatim}
+
+> class SrcRefOf a where
+> srcRefsOf :: a -> [SrcRef]
+> srcRefsOf = (:[]) . srcRefOf
+> srcRefOf :: a -> SrcRef
+> srcRefOf = head . srcRefsOf
+
+> instance SrcRefOf Position where
+> srcRefOf NoPos = noRef
+> srcRefOf x = astRef x
diff --git a/Curry/ExtendedFlat/Goodies.hs b/Curry/ExtendedFlat/Goodies.hs
new file mode 100644
--- /dev/null
+++ b/Curry/ExtendedFlat/Goodies.hs
@@ -0,0 +1,961 @@
+----------------------------------------------------------------------------
+--- 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.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
+
+--- get domain from functional type
+domain :: TypeExpr -> TypeExpr
+domain (FuncType dom _) = dom
+
+--- get range from functional type
+range :: TypeExpr -> TypeExpr
+range (FuncType _ ran) = ran
+
+--- get name from constructed type
+tConsName :: TypeExpr -> QName
+tConsName (TCons name _) = name
+
+--- get arguments from constructed type
+tConsArgs :: TypeExpr -> [TypeExpr]
+tConsArgs (TCons _ args) = args
+
+--- 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 -> 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) (\_ -> 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 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
+
+--- get literal if expression is literal expression
+literal :: Expr -> Literal
+literal (Lit l) = l
+
+--- get combination type of a combined expression
+combType :: Expr -> CombType
+combType (Comb ct _ _) = ct
+
+--- get name of a combined expression
+combName :: Expr -> QName
+combName (Comb _ name _) = name
+
+--- get arguments of a combined expression
+combArgs :: Expr -> [Expr]
+combArgs (Comb _ _ args) = args
+
+--- 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
+
+--- get body of let declaration
+letBody :: Expr -> Expr
+letBody (Let _ e) = e
+
+--- get variable indices from declaration of free variables
+freeVars :: Expr -> [VarIndex]
+freeVars (Free vs _) = vs
+
+--- get expression from declaration of free variables
+freeExpr :: Expr -> Expr
+freeExpr (Free _ e) = e
+
+--- get expressions from or-expression
+orExps :: Expr -> [Expr]
+orExps (Or e1 e2) = [e1,e2]
+
+--- get case-type of case expression
+caseType :: Expr -> CaseType
+caseType (Case _ ct _ _) = ct
+
+--- get scrutinee of case expression
+caseExpr :: Expr -> Expr
+caseExpr (Case _ _ e _) = e
+
+--- get branch expressions from case expression
+caseBranches :: Expr -> [BranchExpr]
+caseBranches (Case _ _ _ bs) = bs
+
+-- 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 (\ (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 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 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 expr = trExpr (:) (const id) comb lt fr (.) cas branch expr []
+ 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 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) (\_ -> 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
+
+
+-- get the type of an expression
+-- (Will only succeed if all VarIndices and QNames contain the
+-- required type information.)
+typeofExpr :: Expr -> Maybe TypeExpr
+typeofExpr expr
+ = case expr of
+ Var vi -> typeofVar vi
+ Lit l -> Just (typeofLiteral l)
+ Comb _ qn as -> fmap (typeofApp as) (typeofQName qn)
+ 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 [] t = t
+ typeofApp (_:as) (FuncType _ t) = typeofApp as t
+ typeofApp (_:_) (TVar _) = ierr
+ typeofApp (_:_) (TCons _ _) = ierr
+ ierr = error $ "internal error in typeofExpr: FuncType expected"
+
+
+typeofLiteral :: Literal -> TypeExpr
+typeofLiteral l
+ = case l of
+ Intc _ _ -> preludeType "Int"
+ Floatc _ _ -> preludeType "Float"
+ Charc _ _ -> preludeType "Char"
+ where
+ preludeType s = TCons (mkQName ("Prelude", s)) []
+
+
+
+-- Function |fvs| returns a list containing the identifiers that
+-- occur free in an expression. (Not to confuse with Curry's free
+-- variables..)
+fvs :: Expr -> [VarIndex]
+fvs expr = case expr of
+ Var v -> [v]
+ Lit _ -> []
+ Comb _ _ es -> foldr union [] (map fvs es)
+ Let bs e -> foldr letFvs (fvs e) bs \\ map fst bs
+ Free vs e -> fvs e \\ vs
+ Or l r -> fvs l `union` fvs r
+ Case _ _ e bs -> foldr branchFvs (fvs e) bs
+ where
+ letFvs (_,e) = union (fvs e)
+ branchFvs (Branch p e) vs = (fvs e \\ pvars p) `union` vs
+ pvars (Pattern _ vs) = vs
+ pvars (LPattern _) = []
+
+
+
+-- Is an expression in weak head normal form? Yes for literals,
+-- constructor terms and unsaturated combinations.
+whnf :: Expr -> Bool
+whnf (Lit _) = True
+whnf (Comb t _ _) = not (isCombTypeFuncCall t)
+whnf _ = False
diff --git a/Curry/ExtendedFlat/MonadicGoodies.hs b/Curry/ExtendedFlat/MonadicGoodies.hs
new file mode 100644
--- /dev/null
+++ b/Curry/ExtendedFlat/MonadicGoodies.hs
@@ -0,0 +1,54 @@
+module Curry.ExtendedFlat.MonadicGoodies
+ (UpdateM, postOrderM,
+ updFuncExpsM, updProgFuncsM, updFuncLetsM) where
+
+import Control.Monad
+import Curry.ExtendedFlat.Type
+
+
+type UpdateM m a b = (b -> m b) -> a -> m a
+
+
+postOrderM :: Monad m => UpdateM m Expr Expr
+postOrderM f = po
+ where po e@(Var _) = f e
+ po e@(Lit _) = f e
+ po (Comb t n es) = do es' <- mapM po es
+ f (Comb t n es')
+ po (Free vs e) = do e' <- po e
+ f (Free vs e')
+ po (Let bs e) = do bs' <- mapM poBind bs
+ e' <- po e
+ f (Let bs' e')
+ po (Or l r) = liftM2 Or (po l) (po r) >>= f
+ po (Case p t e bs) = do e' <- po e
+ bs' <- mapM poBranch bs
+ f (Case p t e' bs')
+ poBind (v, rhs) = do rhs' <- po rhs
+ return (v, rhs')
+ poBranch (Branch p rhs) = do rhs' <- po rhs
+ return (Branch p rhs')
+
+
+
+
+updFuncExpsM :: Monad m => UpdateM m FuncDecl Expr
+updFuncExpsM f (Func name arity visibility ftype (Rule vs e))
+ = do e' <- postOrderM f e
+ return (Func name arity visibility ftype (Rule vs e'))
+updFuncExpsM _ func@(Func _ _ _ _ (External _))
+ = return func
+
+
+updProgFuncsM :: Monad m => UpdateM m Prog FuncDecl
+updProgFuncsM f (Prog name imps types funcs ops)
+ = do funcs' <- mapM f funcs
+ return (Prog name imps types funcs' ops)
+
+updFuncLetsM :: Monad m => ([(VarIndex, Expr)] -> Expr -> m Expr)
+ -> FuncDecl -> m FuncDecl
+updFuncLetsM = updFuncExpsM . updExprLetsM
+ where
+ updExprLetsM f (Let bs e) = f bs e
+ updExprLetsM _ e = return e
+
diff --git a/Curry/ExtendedFlat/Type.hs b/Curry/ExtendedFlat/Type.hs
new file mode 100644
--- /dev/null
+++ b/Curry/ExtendedFlat/Type.hs
@@ -0,0 +1,482 @@
+------------------------------------------------------------------------------
+--- 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 hiding (Fixity)
+import Data.Function(on)
+import System.FilePath
+
+import Curry.Base.Position (SrcRef)
+
+import Curry.Files.Filenames(flatName, extFlatName)
+import Curry.Files.PathUtils (writeModule, maybeReadModule)
+
+
+
+------------------------------------------------------------------------------
+-- Definition of data types for representing FlatCurry programs:
+-- =============================================================
+
+--- Data type for representing a Curry module in the intermediate form.
+--- A value of this data type has the form
+---
+--- (Prog modname imports typedecls functions opdecls translation_table)
+---
+--- where modname: name of this module,
+--- imports: list of modules names that are imported,
+--- typedecls, opdecls, functions, translation of type names
+--- and constructor/function names: see below
+
+data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]
+ deriving (Read, Show, Eq,Data,Typeable)
+
+
+-------------------------------------------------------------------------
+--- The data type for representing qualified names.
+--- In FlatCurry all names are qualified to avoid name clashes.
+--- The first component is the module name and the second component the
+--- unqualified name as it occurs in the source program.
+--- The additional information about source references and types should
+--- be invisible for the normal usage of QName.
+-------------------------------------------------------------------------
+
+data QName = QName {srcRef :: Maybe SrcRef,
+ typeofQName :: Maybe TypeExpr,
+ modName :: String,
+ localName :: String} deriving (Data,Typeable)
+
+
+instance Read QName where
+ readsPrec d r =
+ [ (QName r' t m n, s) | ((r', t, m, n),s) <- readsPrec d r ]
+ ++ [ (mkQName nm,s) | (nm,s) <- readsPrec d r ]
+
+
+instance Show QName where
+ showsPrec d (QName r t m n)
+ = showsPrec d (r,t,m,n)
+
+instance Eq QName where (==) = (==) `on` qnOf
+
+instance Ord QName where compare = compare `on` qnOf
+
+mkQName :: (String,String) -> QName
+mkQName = uncurry (QName Nothing Nothing)
+
+qnOf :: QName -> (String,String)
+qnOf QName{modName=m,localName=n} = (m,n)
+
+
+-------------------------------------------------------------------------
+--- The data type for representing variable names.
+--- The additional information should
+--- be invisible for the normal usage of VarIndex.
+-------------------------------------------------------------------------
+
+data VarIndex = VarIndex {
+ typeofVar :: Maybe TypeExpr,
+ idxOf :: Int
+ } deriving (Data,Typeable)
+
+onIndex :: (Int -> Int) -> VarIndex -> VarIndex
+onIndex f (VarIndex{ typeofVar = t, idxOf = x})
+ = VarIndex t (f x)
+
+onIndexes :: (Int ->Int -> Int) -> VarIndex -> VarIndex -> VarIndex
+onIndexes g x = VarIndex (typeofVar x) . (g `on` idxOf) x
+
+mkIdx :: Int -> VarIndex
+mkIdx = VarIndex Nothing
+
+
+instance Read VarIndex where
+ readsPrec d r =
+ [ (mkIdx i,s) | (i,s) <- readsPrec d r ]
+ ++ [ (VarIndex t i,s) | ((t,i),s) <- readsPrec d r ]
+
+instance Show VarIndex where
+ showsPrec d (VarIndex t i)= showsPrec d (t,i)
+
+instance Eq VarIndex where
+ (==) = (==) `on` idxOf
+
+instance Ord VarIndex where
+ compare = compare `on` idxOf
+
+instance Num VarIndex where
+ (+) = onIndexes (+)
+ (*) = onIndexes (*)
+ (-) = onIndexes (-)
+ abs = onIndex abs
+ signum = onIndex signum
+ fromInteger = mkIdx . fromInteger
+
+incVarIndex :: VarIndex -> Int -> VarIndex
+incVarIndex vi n = vi { idxOf = n + idxOf vi }
+
+------------------------------------------------------------
+--- Data type to specify the visibility of various entities.
+------------------------------------------------------------
+
+data Visibility = Public -- public (exported) entity
+ | Private -- private entity
+ deriving (Read, Show, Eq,Data,Typeable)
+
+--- The data type for representing type variables.
+--- They are represented by (TVar i) where i is a type variable index.
+
+type TVarIndex = Int
+
+--- Data type for representing definitions of algebraic data types.
+---
+--- A data type definition of the form
+---
+--- data t x1...xn = ...| c t1....tkc |...
+---
+--- is represented by the FlatCurry term
+---
+--- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])
+---
+--- where each ij is the index of the type variable xj
+---
+--- Note: the type variable indices are unique inside each type declaration
+--- and are usually numbered from 0
+---
+--- Thus, a data type declaration consists of the name of the data type,
+--- a list of type parameters and a list of constructor declarations.
+---
+
+data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl]
+ | TypeSyn QName Visibility [TVarIndex] TypeExpr
+ deriving (Read, Show, Eq,Data,Typeable)
+
+--- A constructor declaration consists of the name and arity of the
+--- constructor and a list of the argument types of the constructor.
+
+data ConsDecl = Cons QName Int Visibility [TypeExpr]
+ deriving (Read, Show, Eq,Data,Typeable)
+
+
+--- Data type for type expressions.
+--- A type expression is either a type variable, a function type,
+--- or a type constructor application.
+---
+--- Note: the names of the predefined type constructors are
+--- "Int", "Float", "Bool", "Char", "IO", "Success",
+--- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
+
+data TypeExpr =
+ TVar !TVarIndex -- type variable
+ | FuncType TypeExpr TypeExpr -- function type t1->t2
+ | TCons QName [TypeExpr] -- type constructor application
+ deriving (Read, Show, Eq,Data,Typeable) -- TCons module name typeargs
+
+
+--- Data type for operator declarations.
+--- An operator declaration "fix p n" in Curry corresponds to the
+--- FlatCurry term (Op n fix p).
+--- Note: the constructor definition of 'Op' differs from the original
+--- PAKCS definition using Haskell type 'Integer' instead of 'Int'
+--- for representing the precedence.
+
+data OpDecl = Op QName Fixity Integer deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data types for the different choices for the fixity of an operator.
+
+data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Read, Show, Eq,Data,Typeable)
+
+
+--- Data type for representing object variables.
+--- Object variables occurring in expressions are represented by (Var i)
+--- where i is a variable index.
+
+--- Data type for representing function declarations.
+---
+--- A function declaration in FlatCurry is a term of the form
+---
+--- (Func name arity type (Rule [i_1,...,i_arity] e))
+---
+--- and represents the function "name" with definition
+---
+--- name :: type
+--- name x_1...x_arity = e
+---
+--- where each i_j is the index of the variable x_j
+---
+--- Note: the variable indices are unique inside each function declaration
+--- and are usually numbered from 0
+---
+--- External functions are represented as (Func name arity type (External s))
+--- where s is the external name associated to this function.
+---
+--- Thus, a function declaration consists of the name, arity, type, and rule.
+---
+
+data FuncDecl = Func QName Int Visibility TypeExpr Rule
+ deriving (Read, Show, Eq,Data,Typeable)
+
+
+--- A rule is either a list of formal parameters together with an expression
+--- or an "External" tag.
+
+data Rule = Rule [VarIndex] Expr
+ | External String
+ deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data type for classifying case expressions.
+--- Case expressions can be either flexible or rigid in Curry.
+
+data CaseType = Rigid | Flex deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data type for classifying combinations
+--- (i.e., a function/constructor applied to some arguments).
+--- @cons FuncCall - a call to a function all arguments are provided
+--- @cons ConsCall - a call with a constructor at the top,
+--- all arguments are provided
+--- @cons FuncPartCall - a partial call to a function
+--- (i.e., not all arguments are provided)
+--- where the parameter is the number of
+--- missing arguments
+--- @cons ConsPartCall - a partial call to a constructor along with
+--- number of missing arguments
+
+data CombType = FuncCall
+ | ConsCall
+ | FuncPartCall Int
+ | ConsPartCall Int deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data type for representing expressions.
+---
+--- Remarks:
+---
+--- 1. if-then-else expressions are represented as function calls:
+--- (if e1 then e2 else e3)
+--- is represented as
+--- (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])
+---
+--- 2. Higher order applications are represented as calls to the (external)
+--- function "apply". For instance, the rule
+--- app f x = f x
+--- is represented as
+--- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))
+---
+--- 3. A conditional rule is represented as a call to an external function
+--- "cond" where the first argument is the condition (a constraint).
+--- For instance, the rule
+--- equal2 x | x=:=2 = success
+--- is represented as
+--- (Rule [0]
+--- (Comb FuncCall ("Prelude","cond")
+--- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],
+--- Comb FuncCall ("Prelude","success") []]))
+---
+--- 4. Functions with evaluation annotation "choice" are represented
+--- by a rule whose right-hand side is enclosed in a call to the
+--- external function "Prelude.commit".
+--- Furthermore, all rules of the original definition must be
+--- represented by conditional expressions (i.e., (cond [c,e]))
+--- after pattern matching.
+--- Example:
+---
+--- m eval choice
+--- m [] y = y
+--- m x [] = x
+---
+--- is translated into (note that the conditional branches can be also
+--- wrapped with Free declarations in general):
+---
+--- Rule [0,1]
+--- (Comb FuncCall ("Prelude","commit")
+--- [Or (Case Rigid (Var 0)
+--- [(Pattern ("Prelude","[]") []
+--- (Comb FuncCall ("Prelude","cond")
+--- [Comb FuncCall ("Prelude","success") [],
+--- Var 1]))] )
+--- (Case Rigid (Var 1)
+--- [(Pattern ("Prelude","[]") []
+--- (Comb FuncCall ("Prelude","cond")
+--- [Comb FuncCall ("Prelude","success") [],
+--- Var 0]))] )])
+---
+--- Operational meaning of (Prelude.commit e):
+--- evaluate e with local search spaces and commit to the first
+--- (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c
+--- is satisfied
+---
+--- @cons Var - variable (represented by unique index)
+--- @cons Lit - literal (Integer/Float/Char constant)
+--- @cons Comb - application (f e1 ... en) of function/constructor f
+--- with n<=arity(f)
+--- @cons Free - introduction of free local variables
+--- @cons Or - disjunction of two expressions (used to translate rules
+--- with overlapping left-hand sides)
+--- @cons Case - case distinction (rigid or flex)
+
+data Expr = Var VarIndex
+ | Lit Literal
+ | Comb CombType QName [Expr]
+ | Free [VarIndex] Expr
+ | Let [(VarIndex,Expr)] Expr
+ | Or Expr Expr
+ | Case SrcRef CaseType Expr [BranchExpr]
+ deriving (Read, Show, Eq,Data,Typeable)
+
+
+--- Data type for representing branches in a case expression.
+---
+--- Branches "(m.c x1...xn) -> e" in case expressions are represented as
+---
+--- (Branch (Pattern (m,c) [i1,...,in]) e)
+---
+--- where each ij is the index of the pattern variable xj, or as
+---
+--- (Branch (LPattern (Intc i)) e)
+---
+--- for integers as branch patterns (similarly for other literals
+--- like float or character constants).
+---
+
+data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data type for representing patterns in case expressions.
+
+data Pattern = Pattern QName [VarIndex]
+ | LPattern Literal
+ deriving (Read, Show, Eq,Data,Typeable)
+
+--- Data type for representing literals occurring in an expression
+--- or case branch. It is either an integer, a float, or a character constant.
+--- Note: the constructor definition of 'Intc' differs from the original
+--- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'
+--- to provide an unlimited range of integer numbers. Furthermore
+--- float values are represented with Haskell type 'Double' instead of
+--- 'Float'.
+
+data Literal = Intc SrcRef Integer
+ | Floatc SrcRef Double
+ | Charc SrcRef Char
+ deriving (Read, Show, Eq,Data,Typeable)
+
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+-- Reads an ExtendedFlat file (extension ".efc") and returns the corresponding
+-- FlatCurry program term (type 'Prog') as a value of type 'Maybe'.
+readFlatCurry :: FilePath -> IO (Maybe Prog)
+readFlatCurry fn
+ = do let filename = flatName fn
+ readFlat filename
+
+-- Reads a FlatInterface file (extension ".fint") and returns the
+-- corresponding term (type 'Prog') as a value of type 'Maybe'.
+readFlatInterface :: String -> IO (Maybe Prog)
+readFlatInterface fn
+ = do let filename = replaceExtension fn ".fint"
+ readFlat filename
+
+-- Reads a Flat file and returns the corresponding term (type 'Prog') as
+-- a value of type 'Maybe'.
+readFlat :: FilePath -> IO (Maybe Prog)
+readFlat = liftM (fmap read) . maybeReadModule
+
+-- Writes a FlatCurry program term into a file.
+writeFlatCurry :: String -> Prog -> IO ()
+writeFlatCurry filename prog
+ = writeModule filename (showFlatCurry' False prog)
+
+-- Writes a FlatCurry program term with source references into a file.
+writeExtendedFlat :: String -> Prog -> IO ()
+writeExtendedFlat filename prog =
+ writeModule (extFlatName filename) (showFlatCurry' True prog)
+
+
+showFlatCurry' :: Bool -> Prog -> String
+showFlatCurry' b x = gshowsPrec b False x ""
+
+gshowsPrec :: Data a => Bool -> Bool -> a -> ShowS
+gshowsPrec showType d =
+ genericShowsPrec d `ext1Q` showsList
+ `ext2Q` showsTuple
+ `extQ` (const id :: SrcRef -> ShowS)
+ `extQ` (const id :: [SrcRef] -> ShowS)
+ `extQ` (shows :: String -> ShowS)
+ `extQ` (shows :: Char -> ShowS)
+ `extQ` showsQName d
+ `extQ` showsVarIndex d
+
+ where
+ showsQName :: Bool -> QName -> ShowS
+ showsQName d' qn@QName{modName=m,localName=n} =
+ if showType then showParen d' (shows qn{srcRef=Nothing})
+ else shows (m,n)
+
+ showsVarIndex :: Bool -> VarIndex -> ShowS
+ showsVarIndex d'
+ | showType = showParen d' . shows
+ | otherwise = shows . idxOf
+
+ genericShowsPrec :: Data a => Bool -> a -> ShowS
+ genericShowsPrec d' t = let args = intersperse (showChar ' ') $
+ gmapQ (gshowsPrec showType True) t in
+ showParen (d' && not (null args)) $
+ showString (showConstr (toConstr t)) .
+ (if null args then id else showChar ' ') .
+ foldr (.) id args
+
+ showsList :: Data a => [a] -> ShowS
+ showsList xs = showChar '[' .
+ foldr (.) (showChar ']')
+ (intersperse (showChar ',') $
+ map (gshowsPrec showType False) xs)
+
+
+ showsTuple :: (Data a,Data b) => (a,b) -> ShowS
+ showsTuple (x,y) = showChar '(' .
+ gshowsPrec showType False x .
+ showChar ',' .
+ gshowsPrec showType False y .
+ showChar ')'
+
+
+newtype Q r a = Q (a -> r)
+
+ext2Q :: (Data d, Typeable2 t) => (d -> q) ->
+ (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
+ext2Q def ext arg =
+ case dataCast2 (Q ext) of
+ Just (Q ext') -> ext' arg
+ Nothing -> def arg
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
diff --git a/Curry/ExtendedFlat/TypeInference.hs b/Curry/ExtendedFlat/TypeInference.hs
new file mode 100644
--- /dev/null
+++ b/Curry/ExtendedFlat/TypeInference.hs
@@ -0,0 +1,417 @@
+{-# LANGUAGE FlexibleContexts, PatternGuards #-}
+
+module Curry.ExtendedFlat.TypeInference
+ ( dispType,
+ adjustTypeInfo,
+ labelVarsWithTypes,
+ uniqueTypeIndices,
+ genEquations,
+ elimFreeTypes
+ ) where
+
+import Debug.Trace
+
+import Text.PrettyPrint.HughesPJ
+import Control.Monad.State
+import Control.Monad.Reader
+import Data.Maybe
+import qualified Data.IntMap as IntMap
+
+import Curry.ExtendedFlat.Type
+import Curry.ExtendedFlat.Goodies
+
+
+trace' msg x = x -- trace msg x
+
+-- | 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 = -- elimFreeTypes .
+ 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 = 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
+
+
+-- ----------------------------------------------------------------------
+-- ----------------------------------------------------------------------
+
+-- | 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 maxtv qn arity visty te r@(External _) = Func qn arity visty te r
+ foo maxtv qn arity visty te r@(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 -> ReaderT TypeMap (State Int) 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)
+ 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 (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) e)
+ poVarIndex vi
+ = do t <- maybe (lift$freshTVar) return . typeofVar $ vi
+ return vi{typeofVar = Just t }
+
+ 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 action = local (\ m -> foldr (\ v -> IntMap.insert (idxOf v) (fromJust $ typeofVar v)) m vs) action
+
+-- ----------------------------------------------------------------------
+-- ----------------------------------------------------------------------
+
+-- | 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 maxtv qn arity visty te r@(External _) = Func qn arity visty te r
+ foo maxtv qn arity visty te r@(Rule vs expr)
+ = let h = evalState (execStateT (do argTypes <- mapM varIndexType vs
+ 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 _ e = e
+
+ frEqn _ e = e
+
+ orEqn l r = do l' <- l
+ r' <- r
+ l' =:= r'
+
+ casEqn :: SrcRef -> CaseType -> EqnMonad TypeExpr -> [(Pattern, EqnMonad TypeExpr)] -> EqnMonad TypeExpr
+ casEqn _ _ scr [] = scr >> (lift$freshTVar)
+ casEqn _ _ scr ps = do scrt <- scr
+ -- unify patterns with scrutinee
+ mapM_ (unifLhs scrt) ps
+ -- unify right hand sides
+ (p:ps') <- sequence $ map snd ps
+ foldM (=:=) p ps'
+
+ unifLhs scrt (LPattern lit, _)
+ = typeofLiteral lit =:= scrt
+ unifLhs scrt (Pattern qn vs, _)
+ = do qnt <- qnType qn
+ argTypes <- mapM varIndexType vs
+ qnt =:= foldr FuncType scrt argTypes
+
+
+ branchEqn :: Pattern -> EqnMonad TypeExpr -> (Pattern, EqnMonad TypeExpr)
+ branchEqn p e = (p, e)
+
+
+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)
+
+---------------------------------------------------------------------
+
+-- | Type variables that occur in the right hand side of a declaration
+-- but not in its type signature are replaced by the unit type ().
+-- This function requires that proper type information has been made
+-- available by function @adjustTypeInfo@
+
+elimFreeTypes :: Prog -> Prog
+elimFreeTypes = updProgFuncs updateFunc
+ where
+ updateFunc = map (trFunc foo)
+ foo qn arity visty te r@(External _) = Func qn arity visty te r
+ foo qn arity visty te r@(Rule vs expr)
+ = let tvs = tvars te
+ tvars (TVar vi) = [vi]
+ tvars (FuncType t1 t2) = tvars t1 ++ tvars t2
+ tvars (TCons _ ts) = concatMap tvars ts
+ tfoo t@(TVar vi)
+ | vi `elem` tvs = t
+ | otherwise = TCons (mkQName ("Prelude", "()")) []
+ tfoo (FuncType t1 t2) = FuncType (tfoo t1) (tfoo t2)
+ tfoo (TCons qn ts) = TCons qn (map tfoo ts)
+ in Func qn arity visty te (modifyType tfoo (Rule vs expr))
+
+
+---------------------------------------------------------------------
+
+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 tm = modifyType (specialiseType tm)
+
+
+
+-- 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 vi
+ = Var (specInVarIndex vi)
+ comb ct qn as
+ = Comb ct (specInQName qn) as
+ letexp bs e
+ = Let (map specInBind bs) e
+ free vis e
+ = Free (map specInVarIndex vis) e
+ alt p e
+ = Branch (specInPattern p) e
+
+ specInBind (vi, e)
+ = (specInVarIndex vi, e)
+
+ specInPattern (Pattern qn vis)
+ = Pattern (specInQName qn) (map specInVarIndex vis)
+ specInPattern p = p
+
+ specInVarIndex vi
+ = vi { typeofVar = fmap f (typeofVar vi)}
+
+ specInQName qn
+ = qn { typeofQName = fmap f (typeofQName qn)}
+
+
+
diff --git a/Curry/Files/Filenames.hs b/Curry/Files/Filenames.hs
new file mode 100644
--- /dev/null
+++ b/Curry/Files/Filenames.hs
@@ -0,0 +1,72 @@
+module Curry.Files.Filenames where
+
+import System.FilePath
+
+-- Various filename extensions
+curryExt, lcurryExt, icurryExt, oExt :: String
+curryExt = ".curry"
+
+lcurryExt = ".lcurry"
+
+icurryExt = ".icurry"
+
+flatExt = ".fcy"
+
+extFlatExt = ".efc"
+
+flatIntExt = ".fint"
+-- fintExt = ".fint"
+
+xmlExt = "_flat.xml"
+
+acyExt = ".acy"
+
+uacyExt = ".uacy"
+
+sourceRepExt = ".cy"
+
+oExt = ".o"
+
+debugExt = ".d.o"
+
+sourceExts, moduleExts, objectExts :: [String]
+sourceExts = [curryExt,lcurryExt]
+moduleExts = sourceExts ++ [icurryExt]
+objectExts = [oExt]
+
+{-
+ The following functions compute the name of the target file (e.g.
+ interface file, flat curry file etc.)
+ for a source module. Note that
+ output files are always created in the same directory as the source
+ file.
+-}
+
+interfName :: FilePath -> FilePath
+interfName sfn = replaceExtension sfn icurryExt
+
+
+flatName :: FilePath -> FilePath
+flatName fn = replaceExtension fn flatExt
+
+extFlatName :: FilePath -> FilePath
+extFlatName fn = replaceExtension fn extFlatExt
+
+flatIntName :: FilePath -> FilePath
+flatIntName fn = replaceExtension fn flatIntExt
+
+xmlName :: FilePath -> FilePath
+xmlName fn = replaceExtension fn xmlExt
+
+acyName :: FilePath -> FilePath
+acyName fn = replaceExtension fn acyExt
+
+uacyName :: FilePath -> FilePath
+uacyName fn = replaceExtension fn uacyExt
+
+sourceRepName :: FilePath -> FilePath
+sourceRepName fn = replaceExtension fn sourceRepExt
+
+objectName :: Bool -> FilePath -> FilePath
+objectName debug = name (if debug then debugExt else oExt)
+ where name ext fn = replaceExtension fn ext
diff --git a/Curry/Files/PathUtils.hs b/Curry/Files/PathUtils.hs
new file mode 100644
--- /dev/null
+++ b/Curry/Files/PathUtils.hs
@@ -0,0 +1,132 @@
+{-
+ $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,
+
+ lookupModule, lookupFile, lookupInterface,
+ getCurryPath,
+ writeModule,readModule,
+ doesModuleExist,maybeReadModule,getModuleModTime) where
+
+import System.FilePath
+import System.Directory
+import System.Time (ClockTime)
+
+import Control.Monad (unless)
+
+import Curry.Base.Ident
+import Curry.Files.Filenames
+
+
+lookupModule :: [FilePath] -> [FilePath] -> ModuleIdent
+ -> IO (Maybe FilePath)
+lookupModule paths libraryPaths m
+ = lookupFile ("" : paths ++ libraryPaths) moduleExts fn
+ where fn = foldr1 catPath (moduleQualifiers m)
+
+catPath :: FilePath -> FilePath -> FilePath
+catPath = combine
+
+{-
+ The compiler searches for interface files in the import search path
+ using the extension \texttt{".fint"}. Note that the current
+ directory is always searched first.
+-}
+
+lookupInterface :: [FilePath] -> ModuleIdent -> IO (Maybe FilePath)
+lookupInterface ps m = lookupFile ("":ps) [flatIntExt] ifn
+ where ifn = foldr1 catPath (moduleQualifiers m)
+
+lookupFile :: [FilePath] -> [String] -> String -> IO (Maybe FilePath)
+lookupFile paths exts file = lookupFile' paths'
+ where
+ paths' = do p <- paths
+ e <- exts
+ let fn = p `combine` replaceExtension file e
+ [fn, inCurrySubdir fn]
+ lookupFile' [] = return Nothing
+ lookupFile' (fn:ps)
+ = do so <- doesFileExist fn
+ if so then return (Just fn) else lookupFile' ps
+
+
+
+-- add a subdirectory to a given filename
+-- if it is not already present
+--
+-- missing case: inSubdir ""
+
+inSubdir :: FilePath -> FilePath -> FilePath
+inSubdir sub fn = joinPath $ add (splitDirectories fn)
+ where
+ add ps@[_] = sub:ps
+ add ps@[p,_] | p==sub = ps
+ add (p:ps) = p:add ps
+ add [] = error "inSubdir: called with empty path"
+
+--The sub directory to hide files in:
+
+currySubdir :: String
+currySubdir = ".curry"
+
+inCurrySubdir :: FilePath -> FilePath
+inCurrySubdir = inSubdir currySubdir
+
+--write a file to curry subdirectory
+
+writeModule :: FilePath -> String -> IO ()
+writeModule filename contents = do
+ let filename' = inCurrySubdir filename
+ subdir = takeDirectory filename'
+ ensureDirectoryExists subdir
+ writeFile filename' contents
+
+ensureDirectoryExists :: FilePath -> IO ()
+ensureDirectoryExists dir
+ = do ex <- doesDirectoryExist dir
+ unless ex (createDirectory dir)
+
+-- do things with file in subdir
+
+onExistingFileDo :: (FilePath -> IO a) -> FilePath -> IO a
+onExistingFileDo act filename = do
+ ex <- doesFileExist filename
+ if ex then act filename
+ else act $ inCurrySubdir filename
+
+readModule :: FilePath -> IO String
+readModule = onExistingFileDo readFile
+
+maybeReadModule :: FilePath -> IO (Maybe String)
+maybeReadModule filename =
+ catch (readModule filename >>= return . Just) (\_ -> return Nothing)
+
+doesModuleExist :: FilePath -> IO Bool
+doesModuleExist = onExistingFileDo doesFileExist
+
+getModuleModTime :: FilePath -> IO ClockTime
+getModuleModTime = onExistingFileDo getModificationTime
+
+
+{-
+ The function \verb|getCurryPath| searches in predefined paths
+ for the corresponding \texttt{.curry} or \texttt{.lcurry} file,
+ if the given file name has no extension.
+-}
+getCurryPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
+getCurryPath paths fn = lookupFile filepaths exts fn
+ where
+ filepaths = "":paths'
+ fnext = takeExtension fn
+ exts | null fnext = sourceExts
+ | otherwise = [fnext]
+ paths' | pathSeparator `elem` fn = []
+ | otherwise = paths
+
diff --git a/Curry/FlatCurry/Goodies.hs b/Curry/FlatCurry/Goodies.hs
new file mode 100644
--- /dev/null
+++ b/Curry/FlatCurry/Goodies.hs
@@ -0,0 +1,898 @@
+----------------------------------------------------------------------------
+--- 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
+
+--- get domain from functional type
+domain :: TypeExpr -> TypeExpr
+domain (FuncType dom _) = dom
+
+--- get range from functional type
+range :: TypeExpr -> TypeExpr
+range (FuncType _ ran) = ran
+
+--- get name from constructed type
+tConsName :: TypeExpr -> QName
+tConsName (TCons name _) = name
+
+--- get arguments from constructed type
+tConsArgs :: TypeExpr -> [TypeExpr]
+tConsArgs (TCons _ args) = args
+
+--- 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 -> 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) (\_ -> 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
+
+--- get literal if expression is literal expression
+literal :: Expr -> Literal
+literal (Lit l) = l
+
+--- get combination type of a combined expression
+combType :: Expr -> CombType
+combType (Comb ct _ _) = ct
+
+--- get name of a combined expression
+combName :: Expr -> QName
+combName (Comb _ name _) = name
+
+--- get arguments of a combined expression
+combArgs :: Expr -> [Expr]
+combArgs (Comb _ _ args) = args
+
+--- 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
+
+--- get body of let declaration
+letBody :: Expr -> Expr
+letBody (Let _ e) = e
+
+--- get variable indices from declaration of free variables
+freeVars :: Expr -> [VarIndex]
+freeVars (Free vs _) = vs
+
+--- get expression from declaration of free variables
+freeExpr :: Expr -> Expr
+freeExpr (Free _ e) = e
+
+--- get expressions from or-expression
+orExps :: Expr -> [Expr]
+orExps (Or e1 e2) = [e1,e2]
+
+--- get case-type of case expression
+caseType :: Expr -> CaseType
+caseType (Case ct _ _) = ct
+
+--- get scrutinee of case expression
+caseExpr :: Expr -> Expr
+caseExpr (Case _ e _) = e
+
+--- get branch expressions from case expression
+caseBranches :: Expr -> [BranchExpr]
+caseBranches (Case _ _ bs) = bs
+
+-- Test Operations
+
+--- is expression a variable?
+isVar :: Expr -> Bool
+isVar e = case e of
+ Var _ -> True
+ _ -> False
+
+--- is expression a literal expression?
+isLit :: Expr -> Bool
+isLit e = case e of
+ Lit _ -> True
+ _ -> False
+
+--- is expression combined?
+isComb :: Expr -> Bool
+isComb e = case e of
+ Comb _ _ _ -> True
+ _ -> False
+
+--- is expression a let expression?
+isLet :: Expr -> Bool
+isLet e = case e of
+ Let _ _ -> True
+ _ -> False
+
+--- is expression a declaration of free variables?
+isFree :: Expr -> Bool
+isFree e = case e of
+ Free _ _ -> True
+ _ -> False
+
+--- is expression an or-expression?
+isOr :: Expr -> Bool
+isOr e = case e of
+ Or _ _ -> True
+ _ -> False
+
+--- is expression a case expression?
+isCase :: Expr -> Bool
+isCase e = case e of
+ Case _ _ _ -> True
+ _ -> False
+
+--- transform expression
+trExpr :: (VarIndex -> a) ->
+ (Literal -> a) ->
+ (CombType -> QName -> [a] -> a) ->
+ ([(VarIndex,a)] -> a -> a) ->
+ ([VarIndex] -> a -> a) ->
+ (a -> a -> a) ->
+ (CaseType -> a -> [b] -> a) ->
+ (Pattern -> a -> b) -> Expr -> a
+trExpr var _ _ _ _ _ _ _ (Var n) = var n
+
+trExpr _ lit _ _ _ _ _ _ (Lit l) = lit l
+
+trExpr var lit comb lt fr oR cas branch (Comb ct name args)
+ = comb ct name (map (trExpr var lit comb lt fr oR cas branch) args)
+
+trExpr var lit comb lt fr oR cas branch (Let bs e)
+ = lt (map (\ (n,e) -> (n,f e)) bs) (f e)
+ where
+ f = trExpr var lit comb lt fr oR cas branch
+
+trExpr var lit comb lt fr oR cas branch (Free vs e)
+ = fr vs (trExpr var lit comb lt fr oR cas branch e)
+
+trExpr var lit comb lt fr oR cas branch (Or e1 e2) = oR (f e1) (f e2)
+ where
+ f = trExpr var lit comb lt fr oR cas branch
+
+trExpr var lit comb lt fr oR cas branch (Case ct e bs)
+ = cas ct (f e) (map (\ (Branch pat e) -> branch pat (f e)) bs)
+ where
+ f = trExpr var lit comb lt fr oR cas branch
+
+-- Update Operations
+
+--- update all variables in given expression
+updVars :: (VarIndex -> Expr) -> Expr -> Expr
+updVars var = trExpr var Lit Comb Let Free Or Case Branch
+
+--- update all literals in given expression
+updLiterals :: (Literal -> Expr) -> Expr -> Expr
+updLiterals lit = trExpr Var lit Comb Let Free Or Case Branch
+
+--- update all combined expressions in given expression
+updCombs :: (CombType -> QName -> [Expr] -> Expr) -> Expr -> Expr
+updCombs comb = trExpr Var Lit comb Let Free Or Case Branch
+
+--- update all let expressions in given expression
+updLets :: ([(VarIndex,Expr)] -> Expr -> Expr) -> Expr -> Expr
+updLets lt = trExpr Var Lit Comb lt Free Or Case Branch
+
+--- update all free declarations in given expression
+updFrees :: ([VarIndex] -> Expr -> Expr) -> Expr -> Expr
+updFrees fr = trExpr Var Lit Comb Let fr Or Case Branch
+
+--- update all or expressions in given expression
+updOrs :: (Expr -> Expr -> Expr) -> Expr -> Expr
+updOrs oR = trExpr Var Lit Comb Let Free oR Case Branch
+
+--- update all case expressions in given expression
+updCases :: (CaseType -> Expr -> [BranchExpr] -> Expr) -> Expr -> Expr
+updCases cas = trExpr Var Lit Comb Let Free Or cas Branch
+
+--- update all case branches in given expression
+updBranches :: (Pattern -> Expr -> BranchExpr) -> Expr -> Expr
+updBranches branch = trExpr Var Lit Comb Let Free Or Case branch
+
+-- Auxiliary Functions
+
+--- is expression a call of a function where all arguments are provided?
+isFuncCall :: Expr -> Bool
+isFuncCall e = isComb e && isCombTypeFuncCall (combType e)
+
+--- is expression a partial function call?
+isFuncPartCall :: Expr -> Bool
+isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e)
+
+--- is expression a call of a constructor?
+isConsCall :: Expr -> Bool
+isConsCall e = isComb e && isCombTypeConsCall (combType e)
+
+--- is expression a partial constructor call?
+isConsPartCall :: Expr -> Bool
+isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e)
+
+--- is expression fully evaluated?
+isGround :: Expr -> Bool
+isGround e
+ = case e of
+ Comb ConsCall _ args -> all isGround args
+ _ -> isLit e
+
+--- get all variables (also pattern variables) in expression
+allVars :: Expr -> [VarIndex]
+allVars e = trExpr (:) (const id) comb lt fr (.) cas branch e []
+ where
+ comb _ _ = foldr (.) id
+ lt bs e = e . foldr (.) id (map (\ (n,ns) -> (n:) . ns) bs)
+ fr vs e = (vs++) . e
+ cas _ e bs = e . foldr (.) id bs
+ branch pat e = ((args pat)++) . e
+ args pat | isConsPattern pat = patArgs pat
+ | otherwise = []
+
+--- rename all variables (also in patterns) in expression
+rnmAllVars :: Update Expr VarIndex
+rnmAllVars f = trExpr (Var . f) Lit Comb lt (Free . map f) Or Case branch
+ where
+ lt = Let . map (\ (n,e) -> (f n,e))
+ branch = Branch . updPatArgs (map f)
+
+--- update all qualified names in expression
+updQNames :: Update Expr QName
+updQNames f = trExpr Var Lit comb Let Free Or Case (Branch . updPatCons f)
+ where
+ comb ct name args = Comb ct (f name) args
+
+-- BranchExpr ----------------------------------------------------------------
+
+--- transform branch expression
+trBranch :: (Pattern -> Expr -> a) -> BranchExpr -> a
+trBranch branch (Branch pat e) = branch pat e
+
+-- Selectors
+
+--- get pattern from branch expression
+branchPattern :: BranchExpr -> Pattern
+branchPattern = trBranch (\pat _ -> pat)
+
+--- get expression from branch expression
+branchExpr :: BranchExpr -> Expr
+branchExpr = trBranch (\_ e -> e)
+
+-- Update Operations
+
+--- update branch expression
+updBranch :: (Pattern -> Pattern) -> (Expr -> Expr) -> BranchExpr -> BranchExpr
+updBranch fp fe = trBranch branch
+ where
+ branch pat e = Branch (fp pat) (fe e)
+
+--- update pattern of branch expression
+updBranchPattern :: Update BranchExpr Pattern
+updBranchPattern f = updBranch f id
+
+--- update expression of branch expression
+updBranchExpr :: Update BranchExpr Expr
+updBranchExpr = updBranch id
+
+-- Pattern -------------------------------------------------------------------
+
+--- transform pattern
+trPattern :: (QName -> [VarIndex] -> a) -> (Literal -> a) -> Pattern -> a
+trPattern pattern _ (Pattern name args) = pattern name args
+trPattern _ lpattern (LPattern l) = lpattern l
+
+-- Selectors
+
+--- get name from constructor pattern
+patCons :: Pattern -> QName
+patCons = trPattern (\name _ -> name) failed
+
+--- get arguments from constructor pattern
+patArgs :: Pattern -> [VarIndex]
+patArgs = trPattern (\_ args -> args) failed
+
+--- get literal from literal pattern
+patLiteral :: Pattern -> Literal
+patLiteral = trPattern failed id
+
+-- Test Operations
+
+--- is pattern a constructor pattern?
+isConsPattern :: Pattern -> Bool
+isConsPattern = trPattern (\_ _ -> True) (\_ -> False)
+
+-- Update Operations
+
+--- update pattern
+updPattern :: (QName -> QName) ->
+ ([VarIndex] -> [VarIndex]) ->
+ (Literal -> Literal) -> Pattern -> Pattern
+updPattern fn fa fl = trPattern pattern lpattern
+ where
+ pattern name args = Pattern (fn name) (fa args)
+ lpattern l = LPattern (fl l)
+
+--- update constructors name of pattern
+updPatCons :: (QName -> QName) -> Pattern -> Pattern
+updPatCons f = updPattern f id id
+
+--- update arguments of constructor pattern
+updPatArgs :: ([VarIndex] -> [VarIndex]) -> Pattern -> Pattern
+updPatArgs f = updPattern id f id
+
+--- update literal of pattern
+updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern
+updPatLiteral f = updPattern id id f
+
+-- Auxiliary Functions
+
+--- build expression from pattern
+patExpr :: Pattern -> Expr
+patExpr = trPattern (\ name -> Comb ConsCall name . map Var) Lit
+
diff --git a/Curry/FlatCurry/Tools.hs b/Curry/FlatCurry/Tools.hs
new file mode 100644
--- /dev/null
+++ b/Curry/FlatCurry/Tools.hs
@@ -0,0 +1,796 @@
+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,
+
+ 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,
+
+ 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,
+
+ rnmAllVarsBranch, allVarsBranch,
+ rnmAllVarsPat, allVarsPat,
+
+ -- operations on OpDecls
+ opName
+
+ ) where
+
+
+import Data.Maybe
+import Data.Char
+import Data.List
+
+import Curry.FlatCurry.Type
+
+infixr 5 -:-
+
+-- variant of zipWith for lists of same length
+zipWith' _ [] [] = []
+zipWith' f (x:xs) (y:ys) = f x y : zipWith' f xs ys
+
+-- auxiliary functions -------------------------------------------------------
+
+x -:- xs = Comb ConsCall ("Prelude",":") [x,xs]
+nil = Comb ConsCall ("Prelude","[]") []
+
+char_ :: Char -> Expr
+char_ c = Lit (Charc c)
+
+int_ :: Integer -> Expr
+int_ n = Lit (Intc n)
+
+float_ :: Double -> Expr
+float_ f = Lit (Floatc f)
+
+list_ :: [Expr] -> Expr
+list_ [] = nil
+list_ (x:xs) = x -:- list_ xs
+
+string_ :: String -> Expr
+string_ = list_ . map char_
+
+-- 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 (mod,n) | mod==progName p = (name,n)
+ | otherwise = (mod,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 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 fa fe _ (Rule args exp) = Rule (fa args) (fe exp)
+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 _ exp) = Just exp
+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
+
+-- 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 (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
+
+--- 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 exp
+ = case exp of
+ Comb ConsCall _ args -> all isGround args
+ _ -> isLit exp
+
+--- 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
+
+--- get expressions from or-expression
+orExps :: Expr -> [Expr]
+orExps (Or e1 e2) = [e1,e2]
+
+-- 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'
+
+--- get branch expressions from case expression
+caseBranches :: Expr -> [BranchExpr]
+caseBranches (Case _ _ bs) = bs
+
+-- 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 fp fe (Branch pat exp) = Branch (fp pat) (fe exp)
+
+--- 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 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 = maybe [] id . patArgs
+
+-- opDecls ------------------------------
+
+opName (Op name _ _) = name
diff --git a/Curry/FlatCurry/Type.hs b/Curry/FlatCurry/Type.hs
new file mode 100644
--- /dev/null
+++ b/Curry/FlatCurry/Type.hs
@@ -0,0 +1,350 @@
+------------------------------------------------------------------------------
+--- 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 (Prog(..), QName, Visibility(..),
+ TVarIndex, TypeDecl(..), ConsDecl(..), TypeExpr(..),
+ OpDecl(..), Fixity(..),
+ VarIndex,
+ FuncDecl(..), Rule(..),
+ CaseType(..), CombType(..), Expr(..), BranchExpr(..),
+ Pattern(..), Literal(..),
+ readFlatCurry, readFlatInterface, readFlat,
+ writeFlatCurry) where
+
+import Curry.Files.PathUtils (writeModule,maybeReadModule)
+
+import Data.List(intersperse)
+import Control.Monad (liftM)
+
+------------------------------------------------------------------------------
+-- Definition of data types for representing FlatCurry programs:
+-- =============================================================
+
+--- Data type for representing a Curry module in the intermediate form.
+--- A value of this data type has the form
+---
+--- (Prog modname imports typedecls functions opdecls translation_table)
+---
+--- where modname: name of this module,
+--- imports: list of modules names that are imported,
+--- typedecls, opdecls, functions, translation of type names
+--- and constructor/function names: see below
+
+data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]
+ deriving (Read, Show, Eq)
+
+
+--- The data type for representing qualified names.
+--- In FlatCurry all names are qualified to avoid name clashes.
+--- The first component is the module name and the second component the
+--- unqualified name as it occurs in the source program.
+
+type QName = (String,String)
+
+--- Data type to specify the visibility of various entities.
+
+data Visibility = Public -- public (exported) entity
+ | Private -- private entity
+ deriving (Read, Show, Eq)
+
+--- The data type for representing type variables.
+--- They are represented by (TVar i) where i is a type variable index.
+
+type TVarIndex = Int
+
+--- Data type for representing definitions of algebraic data types.
+---
+--- A data type definition of the form
+---
+--- data t x1...xn = ...| c t1....tkc |...
+---
+--- is represented by the FlatCurry term
+---
+--- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])
+---
+--- where each ij is the index of the type variable xj
+---
+--- Note: the type variable indices are unique inside each type declaration
+--- and are usually numbered from 0
+---
+--- Thus, a data type declaration consists of the name of the data type,
+--- a list of type parameters and a list of constructor declarations.
+---
+
+data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl]
+ | TypeSyn QName Visibility [TVarIndex] TypeExpr
+ deriving (Read, Show, Eq)
+
+--- A constructor declaration consists of the name and arity of the
+--- constructor and a list of the argument types of the constructor.
+
+data ConsDecl = Cons QName Int Visibility [TypeExpr]
+ deriving (Read, Show, Eq)
+
+
+--- Data type for type expressions.
+--- A type expression is either a type variable, a function type,
+--- or a type constructor application.
+---
+--- Note: the names of the predefined type constructors are
+--- "Int", "Float", "Bool", "Char", "IO", "Success",
+--- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
+
+data TypeExpr =
+ TVar TVarIndex -- type variable
+ | FuncType TypeExpr TypeExpr -- function type t1->t2
+ | TCons QName [TypeExpr] -- type constructor application
+ deriving (Read, Show, Eq) -- 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 types for the different choices for the fixity of an operator.
+
+data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Read, Show, Eq)
+
+
+--- Data type for representing object variables.
+--- Object variables occurring in expressions are represented by (Var i)
+--- where i is a variable index.
+
+type VarIndex = Int
+
+
+--- Data type for representing function declarations.
+---
+--- A function declaration in FlatCurry is a term of the form
+---
+--- (Func name arity type (Rule [i_1,...,i_arity] e))
+---
+--- and represents the function "name" with definition
+---
+--- name :: type
+--- name x_1...x_arity = e
+---
+--- where each i_j is the index of the variable x_j
+---
+--- Note: the variable indices are unique inside each function declaration
+--- and are usually numbered from 0
+---
+--- External functions are represented as (Func name arity type (External s))
+--- where s is the external name associated to this function.
+---
+--- Thus, a function declaration consists of the name, arity, type, and rule.
+---
+
+data FuncDecl = Func QName Int Visibility TypeExpr Rule
+ deriving (Read, Show, Eq)
+
+
+--- A rule is either a list of formal parameters together with an expression
+--- or an "External" tag.
+
+data Rule = Rule [VarIndex] Expr
+ | External String
+ deriving (Read, Show, Eq)
+
+--- Data type for classifying case expressions.
+--- Case expressions can be either flexible or rigid in Curry.
+
+data CaseType = Rigid | Flex deriving (Read, Show, Eq)
+
+--- Data type for classifying combinations
+--- (i.e., a function/constructor applied to some arguments).
+--- @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 type for representing expressions.
+---
+--- Remarks:
+---
+--- 1. if-then-else expressions are represented as function calls:
+--- (if e1 then e2 else e3)
+--- is represented as
+--- (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])
+---
+--- 2. Higher order applications are represented as calls to the (external)
+--- function "apply". For instance, the rule
+--- app f x = f x
+--- is represented as
+--- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))
+---
+--- 3. A conditional rule is represented as a call to an external function
+--- "cond" where the first argument is the condition (a constraint).
+--- For instance, the rule
+--- equal2 x | x=:=2 = success
+--- is represented as
+--- (Rule [0]
+--- (Comb FuncCall ("Prelude","cond")
+--- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],
+--- Comb FuncCall ("Prelude","success") []]))
+---
+--- 4. Functions with evaluation annotation "choice" are represented
+--- by a rule whose right-hand side is enclosed in a call to the
+--- external function "Prelude.commit".
+--- Furthermore, all rules of the original definition must be
+--- represented by conditional expressions (i.e., (cond [c,e]))
+--- after pattern matching.
+--- Example:
+---
+--- m eval choice
+--- m [] y = y
+--- m x [] = x
+---
+--- is translated into (note that the conditional branches can be also
+--- wrapped with Free declarations in general):
+---
+--- Rule [0,1]
+--- (Comb FuncCall ("Prelude","commit")
+--- [Or (Case Rigid (Var 0)
+--- [(Pattern ("Prelude","[]") []
+--- (Comb FuncCall ("Prelude","cond")
+--- [Comb FuncCall ("Prelude","success") [],
+--- Var 1]))] )
+--- (Case Rigid (Var 1)
+--- [(Pattern ("Prelude","[]") []
+--- (Comb FuncCall ("Prelude","cond")
+--- [Comb FuncCall ("Prelude","success") [],
+--- Var 0]))] )])
+---
+--- Operational meaning of (Prelude.commit e):
+--- evaluate e with local search spaces and commit to the first
+--- (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c
+--- is satisfied
+---
+--- @cons Var - variable (represented by unique index)
+--- @cons Lit - literal (Integer/Float/Char constant)
+--- @cons Comb - application (f e1 ... en) of function/constructor f
+--- with n<=arity(f)
+--- @cons Free - introduction of free local variables
+--- @cons Or - disjunction of two expressions (used to translate rules
+--- with overlapping left-hand sides)
+--- @cons Case - case distinction (rigid or flex)
+
+data Expr = Var VarIndex
+ | Lit Literal
+ | Comb CombType QName [Expr]
+ | Free [VarIndex] Expr
+ | Let [(VarIndex,Expr)] Expr
+ | Or Expr Expr
+ | Case CaseType Expr [BranchExpr]
+ deriving (Read, Show, Eq)
+
+
+--- Data type for representing branches in a case expression.
+---
+--- Branches "(m.c x1...xn) -> e" in case expressions are represented as
+---
+--- (Branch (Pattern (m,c) [i1,...,in]) e)
+---
+--- where each ij is the index of the pattern variable xj, or as
+---
+--- (Branch (LPattern (Intc i)) e)
+---
+--- for integers as branch patterns (similarly for other literals
+--- like float or character constants).
+---
+
+data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq)
+
+--- Data type for representing patterns in case expressions.
+
+data Pattern = Pattern QName [VarIndex]
+ | LPattern Literal
+ deriving (Read, Show, Eq)
+
+--- Data type for representing literals occurring in an expression
+--- or case branch. It is either an integer, a float, or a character constant.
+--- Note: the constructor definition of 'Intc' differs from the original
+--- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'
+--- to provide an unlimited range of integer numbers. Furthermore
+--- float values are represented with Haskell type 'Double' instead of
+--- 'Float'.
+
+data Literal = Intc Integer
+ | Floatc Double
+ | Charc Char
+ deriving (Read, Show, Eq)
+
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+-- Reads a FlatCurry file (extension ".fcy") and returns the corresponding
+-- FlatCurry program term (type 'Prog') as a value of type 'Maybe'.
+readFlatCurry :: FilePath -> IO (Maybe Prog)
+readFlatCurry fn
+ = do let filename = genFlatFilename ".fcy" 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 = genFlatFilename ".fint" fn
+ readFlat filename
+
+-- Reads a Flat file and returns the corresponding term (type 'Prog') as
+-- a value of type 'Maybe'.
+readFlat :: FilePath -> IO (Maybe Prog)
+readFlat = liftM (fmap read) . maybeReadModule
+
+-- Writes a FlatCurry program term into a file.
+writeFlatCurry :: String -> Prog -> IO ()
+writeFlatCurry filename prog
+ = writeModule filename (showFlatCurry 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 ["++
+ concat (intersperse ",\n " (map (\t->show t) types)) ++"]\n ["++
+ concat (intersperse ",\n " (map (\f->show f) funcs)) ++"]\n "++
+ show ops ++"\n"
+
+
+-- Add the extension 'ext' to the filename 'fn' if it doesn't
+-- already exist.
+genFlatFilename :: String -> FilePath -> FilePath
+genFlatFilename ext fn
+ | drop (length fn - length ext) fn == ext
+ = fn
+ | otherwise
+ = fn ++ ext
+
+
+------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,27 @@
+Copyright (c) 1998-2004, Wolfgang Lux
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+3. None of the names of the copyright holders and contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/curry-base.cabal b/curry-base.cabal
new file mode 100644
--- /dev/null
+++ b/curry-base.cabal
@@ -0,0 +1,24 @@
+Name: curry-base
+Version: 0.2.2
+Cabal-Version: >= 1.6
+Synopsis: Functions for manipulating Curry programs
+Description: This package serves as a foundation for Curry compilers. it defines the intermediate
+ formats FlatCurry and ExtendedFlat. Additionally, it provides functionality
+ for the smooth integration of compiler frontends and backends.
+Category: Language
+License: OtherLicense
+License-File: LICENSE
+Author: Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel
+Maintainer: Holger Siegel
+Bug-Reports: mailto:hsi@informatik.uni-kiel.de
+Homepage: http://curry-language.org
+Build-Type: Simple
+Stability: experimental
+
+Library
+ Build-Depends: base >= 3 && < 4, mtl, old-time, directory, filepath, containers, pretty
+ ghc-options: -Wall -fwarn-unused-binds -fwarn-unused-imports -auto-all
+ Exposed-Modules: Curry.Base.Position, Curry.Base.Ident, Curry.Base.MessageMonad
+ Curry.ExtendedFlat.Type, Curry.ExtendedFlat.Goodies, Curry.ExtendedFlat.TypeInference, Curry.ExtendedFlat.MonadicGoodies
+ Curry.FlatCurry.Type, Curry.FlatCurry.Goodies, Curry.FlatCurry.Tools
+ Curry.Files.Filenames, Curry.Files.PathUtils