curry-base (empty) → 0.2.2
raw patch · 15 files changed
+4748/−0 lines, 15 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, filepath, mtl, old-time, pretty
Files
- Curry/Base/Ident.lhs +353/−0
- Curry/Base/MessageMonad.hs +81/−0
- Curry/Base/Position.lhs +99/−0
- Curry/ExtendedFlat/Goodies.hs +961/−0
- Curry/ExtendedFlat/MonadicGoodies.hs +54/−0
- Curry/ExtendedFlat/Type.hs +482/−0
- Curry/ExtendedFlat/TypeInference.hs +417/−0
- Curry/Files/Filenames.hs +72/−0
- Curry/Files/PathUtils.hs +132/−0
- Curry/FlatCurry/Goodies.hs +898/−0
- Curry/FlatCurry/Tools.hs +796/−0
- Curry/FlatCurry/Type.hs +350/−0
- LICENSE +27/−0
- Setup.hs +2/−0
- curry-base.cabal +24/−0
+ Curry/Base/Ident.lhs view
@@ -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)
+ Curry/Base/MessageMonad.hs view
@@ -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
+ Curry/Base/Position.lhs view
@@ -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
+ Curry/ExtendedFlat/Goodies.hs view
@@ -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
+ Curry/ExtendedFlat/MonadicGoodies.hs view
@@ -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+
+ Curry/ExtendedFlat/Type.hs view
@@ -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+--- <CODE>+--- (Prog modname imports typedecls functions opdecls translation_table)+--- </CODE>+--- where modname: name of this module,+--- imports: list of modules names that are imported,+--- typedecls, opdecls, functions, translation of type names+--- and constructor/function names: see below++data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl] + deriving (Read, Show, Eq,Data,Typeable)+++-------------------------------------------------------------------------+--- The data type for representing qualified names.+--- In FlatCurry all names are qualified to avoid name clashes.+--- The first component is the module name and the second component the+--- unqualified name as it occurs in the source program.+--- The additional information about source references and types should+--- be invisible for the normal usage of QName.+-------------------------------------------------------------------------++data QName = QName {srcRef :: Maybe SrcRef,+ typeofQName :: Maybe TypeExpr,+ modName :: String,+ localName :: String} deriving (Data,Typeable)+++instance Read QName where+ readsPrec d r = + [ (QName r' t m n, s) | ((r', t, m, n),s) <- readsPrec d r ]+ ++ [ (mkQName nm,s) | (nm,s) <- readsPrec d r ]+++instance Show QName where+ showsPrec d (QName r t m n)+ = showsPrec d (r,t,m,n)++instance Eq QName where (==) = (==) `on` qnOf++instance Ord QName where compare = compare `on` qnOf++mkQName :: (String,String) -> QName+mkQName = uncurry (QName Nothing Nothing)++qnOf :: QName -> (String,String) +qnOf QName{modName=m,localName=n} = (m,n)+++-------------------------------------------------------------------------+--- The data type for representing variable names.+--- The additional information should+--- be invisible for the normal usage of VarIndex.+-------------------------------------------------------------------------++data VarIndex = VarIndex {+ typeofVar :: Maybe TypeExpr,+ idxOf :: Int+ } deriving (Data,Typeable)++onIndex :: (Int -> Int) -> VarIndex -> VarIndex+onIndex f (VarIndex{ typeofVar = t, idxOf = x})+ = VarIndex t (f x)++onIndexes :: (Int ->Int -> Int) -> VarIndex -> VarIndex -> VarIndex+onIndexes g x = VarIndex (typeofVar x) . (g `on` idxOf) x++mkIdx :: Int -> VarIndex+mkIdx = VarIndex Nothing+++instance Read VarIndex where+ readsPrec d r = + [ (mkIdx i,s) | (i,s) <- readsPrec d r ]+ ++ [ (VarIndex t i,s) | ((t,i),s) <- readsPrec d r ]++instance Show VarIndex where+ showsPrec d (VarIndex t i)= showsPrec d (t,i)++instance Eq VarIndex where+ (==) = (==) `on` idxOf++instance Ord VarIndex where+ compare = compare `on` idxOf++instance Num VarIndex where+ (+) = onIndexes (+)+ (*) = onIndexes (*)+ (-) = onIndexes (-)+ abs = onIndex abs+ signum = onIndex signum+ fromInteger = mkIdx . fromInteger++incVarIndex :: VarIndex -> Int -> VarIndex+incVarIndex vi n = vi { idxOf = n + idxOf vi }++------------------------------------------------------------+--- Data type to specify the visibility of various entities.+------------------------------------------------------------++data Visibility = Public -- public (exported) entity+ | Private -- private entity+ deriving (Read, Show, Eq,Data,Typeable)++--- The data type for representing type variables.+--- They are represented by (TVar i) where i is a type variable index.++type TVarIndex = Int++--- Data type for representing definitions of algebraic data types.+--- <PRE>+--- A data type definition of the form+---+--- data t x1...xn = ...| c t1....tkc |...+---+--- is represented by the FlatCurry term+---+--- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])+---+--- where each ij is the index of the type variable xj+---+--- Note: the type variable indices are unique inside each type declaration+--- and are usually numbered from 0+---+--- Thus, a data type declaration consists of the name of the data type,+--- a list of type parameters and a list of constructor declarations.+--- </PRE>++data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl]+ | TypeSyn QName Visibility [TVarIndex] TypeExpr+ deriving (Read, Show, Eq,Data,Typeable)++--- A constructor declaration consists of the name and arity of the+--- constructor and a list of the argument types of the constructor.++data ConsDecl = Cons QName Int Visibility [TypeExpr]+ deriving (Read, Show, Eq,Data,Typeable)+++--- Data type for type expressions.+--- A type expression is either a type variable, a function type,+--- or a type constructor application.+---+--- Note: the names of the predefined type constructors are+--- "Int", "Float", "Bool", "Char", "IO", "Success",+--- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)++data TypeExpr =+ TVar !TVarIndex -- type variable+ | FuncType TypeExpr TypeExpr -- function type t1->t2+ | TCons QName [TypeExpr] -- type constructor application+ deriving (Read, Show, Eq,Data,Typeable) -- TCons module name typeargs+++--- Data type for operator declarations.+--- An operator declaration "fix p n" in Curry corresponds to the+--- FlatCurry term (Op n fix p).+--- Note: the constructor definition of 'Op' differs from the original+--- PAKCS definition using Haskell type 'Integer' instead of 'Int'+--- for representing the precedence. ++data OpDecl = Op QName Fixity Integer deriving (Read, Show, Eq,Data,Typeable)++--- Data types for the different choices for the fixity of an operator.++data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Read, Show, Eq,Data,Typeable)+++--- Data type for representing object variables.+--- Object variables occurring in expressions are represented by (Var i)+--- where i is a variable index.++--- Data type for representing function declarations.+--- <PRE>+--- A function declaration in FlatCurry is a term of the form+---+--- (Func name arity type (Rule [i_1,...,i_arity] e))+---+--- and represents the function "name" with definition+---+--- name :: type+--- name x_1...x_arity = e+---+--- where each i_j is the index of the variable x_j+---+--- Note: the variable indices are unique inside each function declaration+--- and are usually numbered from 0+---+--- External functions are represented as (Func name arity type (External s))+--- where s is the external name associated to this function.+---+--- Thus, a function declaration consists of the name, arity, type, and rule.+--- </PRE>++data FuncDecl = Func QName Int Visibility TypeExpr Rule+ deriving (Read, Show, Eq,Data,Typeable)+++--- A rule is either a list of formal parameters together with an expression+--- or an "External" tag.++data Rule = Rule [VarIndex] Expr+ | External String+ deriving (Read, Show, Eq,Data,Typeable)++--- Data type for classifying case expressions.+--- Case expressions can be either flexible or rigid in Curry.++data CaseType = Rigid | Flex deriving (Read, Show, Eq,Data,Typeable)++--- Data type for classifying combinations+--- (i.e., a function/constructor applied to some arguments).+--- @cons FuncCall - a call to a function all arguments are provided+--- @cons ConsCall - a call with a constructor at the top,+--- all arguments are provided+--- @cons FuncPartCall - a partial call to a function+--- (i.e., not all arguments are provided) +--- where the parameter is the number of+--- missing arguments+--- @cons ConsPartCall - a partial call to a constructor along with +--- number of missing arguments++data CombType = FuncCall + | ConsCall + | FuncPartCall Int + | ConsPartCall Int deriving (Read, Show, Eq,Data,Typeable)++--- Data type for representing expressions.+---+--- Remarks:+--- <PRE>+--- 1. if-then-else expressions are represented as function calls:+--- (if e1 then e2 else e3)+--- is represented as+--- (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])+--- +--- 2. Higher order applications are represented as calls to the (external)+--- function "apply". For instance, the rule+--- app f x = f x+--- is represented as+--- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))+--- +--- 3. A conditional rule is represented as a call to an external function+--- "cond" where the first argument is the condition (a constraint).+--- For instance, the rule+--- equal2 x | x=:=2 = success+--- is represented as+--- (Rule [0]+--- (Comb FuncCall ("Prelude","cond")+--- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],+--- Comb FuncCall ("Prelude","success") []]))+--- +--- 4. Functions with evaluation annotation "choice" are represented+--- by a rule whose right-hand side is enclosed in a call to the+--- external function "Prelude.commit".+--- Furthermore, all rules of the original definition must be+--- represented by conditional expressions (i.e., (cond [c,e]))+--- after pattern matching.+--- Example:+--- +--- m eval choice+--- m [] y = y+--- m x [] = x+--- +--- is translated into (note that the conditional branches can be also+--- wrapped with Free declarations in general):+--- +--- Rule [0,1]+--- (Comb FuncCall ("Prelude","commit")+--- [Or (Case Rigid (Var 0)+--- [(Pattern ("Prelude","[]") []+--- (Comb FuncCall ("Prelude","cond")+--- [Comb FuncCall ("Prelude","success") [],+--- Var 1]))] )+--- (Case Rigid (Var 1)+--- [(Pattern ("Prelude","[]") []+--- (Comb FuncCall ("Prelude","cond")+--- [Comb FuncCall ("Prelude","success") [],+--- Var 0]))] )])+--- +--- Operational meaning of (Prelude.commit e):+--- evaluate e with local search spaces and commit to the first+--- (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c+--- is satisfied+--- </PRE>+--- @cons Var - variable (represented by unique index)+--- @cons Lit - literal (Integer/Float/Char constant)+--- @cons Comb - application (f e1 ... en) of function/constructor f+--- with n<=arity(f)+--- @cons Free - introduction of free local variables+--- @cons Or - disjunction of two expressions (used to translate rules+--- with overlapping left-hand sides)+--- @cons Case - case distinction (rigid or flex)++data Expr = Var VarIndex + | Lit Literal+ | Comb CombType QName [Expr]+ | Free [VarIndex] Expr+ | Let [(VarIndex,Expr)] Expr+ | Or Expr Expr+ | Case SrcRef CaseType Expr [BranchExpr]+ deriving (Read, Show, Eq,Data,Typeable)+++--- Data type for representing branches in a case expression.+--- <PRE>+--- Branches "(m.c x1...xn) -> e" in case expressions are represented as+---+--- (Branch (Pattern (m,c) [i1,...,in]) e)+---+--- where each ij is the index of the pattern variable xj, or as+---+--- (Branch (LPattern (Intc i)) e)+---+--- for integers as branch patterns (similarly for other literals+--- like float or character constants).+--- </PRE>++data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq,Data,Typeable)++--- Data type for representing patterns in case expressions.++data Pattern = Pattern QName [VarIndex]+ | LPattern Literal+ deriving (Read, Show, Eq,Data,Typeable)++--- Data type for representing literals occurring in an expression+--- or case branch. It is either an integer, a float, or a character constant.+--- Note: the constructor definition of 'Intc' differs from the original+--- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'+--- to provide an unlimited range of integer numbers. Furthermore+--- float values are represented with Haskell type 'Double' instead of+--- 'Float'.++data Literal = Intc SrcRef Integer+ | Floatc SrcRef Double+ | Charc SrcRef Char+ deriving (Read, Show, Eq,Data,Typeable)+++------------------------------------------------------------------------------+------------------------------------------------------------------------------++-- Reads an ExtendedFlat file (extension ".efc") and returns the corresponding+-- FlatCurry program term (type 'Prog') as a value of type 'Maybe'.+readFlatCurry :: FilePath -> IO (Maybe Prog)+readFlatCurry fn + = do let filename = flatName fn+ readFlat filename++-- Reads a FlatInterface file (extension ".fint") and returns the+-- corresponding term (type 'Prog') as a value of type 'Maybe'.+readFlatInterface :: String -> IO (Maybe Prog)+readFlatInterface fn+ = do let filename = replaceExtension fn ".fint"+ readFlat filename++-- Reads a Flat file and returns the corresponding term (type 'Prog') as+-- a value of type 'Maybe'.+readFlat :: FilePath -> IO (Maybe Prog)+readFlat = liftM (fmap read) . maybeReadModule+ +-- Writes a FlatCurry program term into a file.+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++------------------------------------------------------------------------------+------------------------------------------------------------------------------+
+ Curry/ExtendedFlat/TypeInference.hs view
@@ -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)}+++
+ Curry/Files/Filenames.hs view
@@ -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
+ Curry/Files/PathUtils.hs view
@@ -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+
+ Curry/FlatCurry/Goodies.hs view
@@ -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+
+ Curry/FlatCurry/Tools.hs view
@@ -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
+ Curry/FlatCurry/Type.hs view
@@ -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+--- <CODE>+--- (Prog modname imports typedecls functions opdecls translation_table)+--- </CODE>+--- where modname: name of this module,+--- imports: list of modules names that are imported,+--- typedecls, opdecls, functions, translation of type names+--- and constructor/function names: see below++data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl] + deriving (Read, Show, Eq)+++--- The data type for representing qualified names.+--- In FlatCurry all names are qualified to avoid name clashes.+--- The first component is the module name and the second component the+--- unqualified name as it occurs in the source program.++type QName = (String,String)++--- Data type to specify the visibility of various entities.++data Visibility = Public -- public (exported) entity+ | Private -- private entity+ deriving (Read, Show, Eq)++--- The data type for representing type variables.+--- They are represented by (TVar i) where i is a type variable index.++type TVarIndex = Int++--- Data type for representing definitions of algebraic data types.+--- <PRE>+--- A data type definition of the form+---+--- data t x1...xn = ...| c t1....tkc |...+---+--- is represented by the FlatCurry term+---+--- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])+---+--- where each ij is the index of the type variable xj+---+--- Note: the type variable indices are unique inside each type declaration+--- and are usually numbered from 0+---+--- Thus, a data type declaration consists of the name of the data type,+--- a list of type parameters and a list of constructor declarations.+--- </PRE>++data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl]+ | TypeSyn QName Visibility [TVarIndex] TypeExpr+ deriving (Read, Show, Eq)++--- A constructor declaration consists of the name and arity of the+--- constructor and a list of the argument types of the constructor.++data ConsDecl = Cons QName Int Visibility [TypeExpr]+ deriving (Read, Show, Eq)+++--- Data type for type expressions.+--- A type expression is either a type variable, a function type,+--- or a type constructor application.+---+--- Note: the names of the predefined type constructors are+--- "Int", "Float", "Bool", "Char", "IO", "Success",+--- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)++data TypeExpr =+ TVar TVarIndex -- type variable+ | FuncType TypeExpr TypeExpr -- function type t1->t2+ | TCons QName [TypeExpr] -- type constructor application+ deriving (Read, Show, Eq) -- 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.+--- <PRE>+--- A function declaration in FlatCurry is a term of the form+---+--- (Func name arity type (Rule [i_1,...,i_arity] e))+---+--- and represents the function "name" with definition+---+--- name :: type+--- name x_1...x_arity = e+---+--- where each i_j is the index of the variable x_j+---+--- Note: the variable indices are unique inside each function declaration+--- and are usually numbered from 0+---+--- External functions are represented as (Func name arity type (External s))+--- where s is the external name associated to this function.+---+--- Thus, a function declaration consists of the name, arity, type, and rule.+--- </PRE>++data FuncDecl = Func QName Int Visibility TypeExpr Rule+ deriving (Read, Show, Eq)+++--- A rule is either a list of formal parameters together with an expression+--- or an "External" tag.++data Rule = Rule [VarIndex] Expr+ | External String+ deriving (Read, Show, Eq)++--- Data type for classifying case expressions.+--- Case expressions can be either flexible or rigid in Curry.++data CaseType = Rigid | Flex deriving (Read, Show, Eq)++--- Data type for classifying combinations+--- (i.e., a function/constructor applied to some arguments).+--- @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:+--- <PRE>+--- 1. if-then-else expressions are represented as function calls:+--- (if e1 then e2 else e3)+--- is represented as+--- (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])+--- +--- 2. Higher order applications are represented as calls to the (external)+--- function "apply". For instance, the rule+--- app f x = f x+--- is represented as+--- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))+--- +--- 3. A conditional rule is represented as a call to an external function+--- "cond" where the first argument is the condition (a constraint).+--- For instance, the rule+--- equal2 x | x=:=2 = success+--- is represented as+--- (Rule [0]+--- (Comb FuncCall ("Prelude","cond")+--- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],+--- Comb FuncCall ("Prelude","success") []]))+--- +--- 4. Functions with evaluation annotation "choice" are represented+--- by a rule whose right-hand side is enclosed in a call to the+--- external function "Prelude.commit".+--- Furthermore, all rules of the original definition must be+--- represented by conditional expressions (i.e., (cond [c,e]))+--- after pattern matching.+--- Example:+--- +--- m eval choice+--- m [] y = y+--- m x [] = x+--- +--- is translated into (note that the conditional branches can be also+--- wrapped with Free declarations in general):+--- +--- Rule [0,1]+--- (Comb FuncCall ("Prelude","commit")+--- [Or (Case Rigid (Var 0)+--- [(Pattern ("Prelude","[]") []+--- (Comb FuncCall ("Prelude","cond")+--- [Comb FuncCall ("Prelude","success") [],+--- Var 1]))] )+--- (Case Rigid (Var 1)+--- [(Pattern ("Prelude","[]") []+--- (Comb FuncCall ("Prelude","cond")+--- [Comb FuncCall ("Prelude","success") [],+--- Var 0]))] )])+--- +--- Operational meaning of (Prelude.commit e):+--- evaluate e with local search spaces and commit to the first+--- (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c+--- is satisfied+--- </PRE>+--- @cons Var - variable (represented by unique index)+--- @cons Lit - literal (Integer/Float/Char constant)+--- @cons Comb - application (f e1 ... en) of function/constructor f+--- with n<=arity(f)+--- @cons Free - introduction of free local variables+--- @cons Or - disjunction of two expressions (used to translate rules+--- with overlapping left-hand sides)+--- @cons Case - case distinction (rigid or flex)++data Expr = Var VarIndex + | Lit Literal+ | Comb CombType QName [Expr]+ | Free [VarIndex] Expr+ | Let [(VarIndex,Expr)] Expr+ | Or Expr Expr+ | Case CaseType Expr [BranchExpr]+ deriving (Read, Show, Eq)+++--- Data type for representing branches in a case expression.+--- <PRE>+--- Branches "(m.c x1...xn) -> e" in case expressions are represented as+---+--- (Branch (Pattern (m,c) [i1,...,in]) e)+---+--- where each ij is the index of the pattern variable xj, or as+---+--- (Branch (LPattern (Intc i)) e)+---+--- for integers as branch patterns (similarly for other literals+--- like float or character constants).+--- </PRE>++data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq)++--- Data type for representing patterns in case expressions.++data Pattern = Pattern QName [VarIndex]+ | LPattern Literal+ deriving (Read, Show, Eq)++--- Data type for representing literals occurring in an expression+--- or case branch. It is either an integer, a float, or a character constant.+--- Note: the constructor definition of 'Intc' differs from the original+--- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'+--- to provide an unlimited range of integer numbers. Furthermore+--- float values are represented with Haskell type 'Double' instead of+--- 'Float'.++data Literal = Intc Integer+ | Floatc Double+ | Charc Char+ deriving (Read, Show, Eq)+++------------------------------------------------------------------------------+------------------------------------------------------------------------------++-- Reads a FlatCurry file (extension ".fcy") and returns the corresponding+-- FlatCurry program term (type 'Prog') as a value of type 'Maybe'.+readFlatCurry :: FilePath -> IO (Maybe Prog)+readFlatCurry fn + = 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+++------------------------------------------------------------------------------+------------------------------------------------------------------------------+
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ curry-base.cabal view
@@ -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