Commit fc74ac62 authored by Michael Hanus's avatar Michael Hanus
Browse files

Contract wrapper improved to check all calls as default

parent c9cff272
----------------------------------------------------------------------
--- Operations to read the documentation comments in a Curry program.
---
--- @author Michael Hanus
----------------------------------------------------------------------
module AbstractCurryComments(readCurryWithComments,readComments) where
import Char
import AbstractCurry.Types
import AbstractCurry.Files
import Directory(doesFileExist)
import List(isSuffixOf)
--------------------------------------------------------------------------
--- I/O action which parses a Curry program and returns the corresponding
--- typed Abstract Curry program. In addition to the operation
--- <code>AbstractCurry.readCurry</code>, this I/O action also reads
--- the documentation comments in the source file and puts
--- the function comments into the function declarations of
--- the Abstract Curry program (i.e., it uses the constructor
--- <code>CmtFunc</code> instead of <code>CFunc</code> whenever possible).
readCurryWithComments :: String -> IO CurryProg
readCurryWithComments progname = do
prog <- readCurry progname
let sourceFileName = progname++".curry"
existsCurry <- doesFileExist sourceFileName
if not existsCurry
then return prog
else do (_,_,fcmts) <- readComments sourceFileName
return (addCommentsInProg fcmts prog)
where
addCommentsInProg fcmts (CurryProg mname imps types fdecls ops) =
CurryProg mname imps types (map (addCommentsInFunc fcmts) fdecls) ops
addCommentsInFunc fcmts fdecl@(CFunc fname ar vis ftype rules) =
let fcmt = fcmts (snd fname)
in if null fcmt
then fdecl
else CmtFunc fcmt fname ar vis ftype rules
addCommentsInFunc _ fdecl@(CmtFunc _ _ _ _ _ _) = fdecl
--------------------------------------------------------------------------
--- Reads all documentation comments of a source file.
--- This operation returns the module comment,
--- a mapping from type names into their documentation comments,
--- and a mapping from function names into their documentation comments.
readComments :: String -> IO (String,String->String,String->String)
readComments filename = do
(modcmts,cmtlines) <- readAllComments filename
return (modcmts,
\tname -> getDataComment tname cmtlines,
\fname -> getFuncComment fname cmtlines)
fst3 (x,_,_) = x
trd3 (_,_,x) = x
main f = do r <- readComments "SetFunctions.curry"
putStrLn (trd3 r f)
-- Reads all documentation comments of a source file.
readAllComments :: String -> IO (String,[(SourceLine,String)])
readAllComments filename = do
prog <- readFile filename
return (groupLines . filter (/=OtherLine) . map classifyLine . lines $ prog)
--- This datatype is used to classify all input lines.
--- @cons Comment - a comment for CurryDoc
--- @cons FuncDef - a definition of a function
--- @cons DataDef - a definition of a datatype
--- @cons ModDef - a line containing a module definition
--- @cons OtherLine - a line not relevant for CurryDoc
data SourceLine = Comment String -- a comment for CurryDoc
| FuncDef String -- a definition of a function
| DataDef String -- a definition of a datatype
| ModDef -- a line containing a module definition
| OtherLine -- a line not relevant for CurryDoc
--- This datatype is used to categorize Curry libraries
--- @cons General - a general library
--- @cons Algorithm - a library which provides data structures and algorithms
--- @cons Database - a library for database access
--- @cons Web - a library for web applications
--- @cons Meta - a library for meta-programming
data Category = General
| Algorithm
| Database
| Web
| Meta
type ModInfo = (Category, String, String)
--- Determine the category for a module
readCategory :: [String] -> Category
readCategory [] = General
readCategory (catcmt:_) = case cat of
"general" -> General
"algorithm" -> Algorithm
"database" -> Database
"web" -> Web
"meta" -> Meta
_ -> General
where
(cat,_) = span isIdChar catcmt
--- Show a category
showCategory :: Category -> String
showCategory General = "General libraries"
showCategory Algorithm = "Data structures and algorithms"
showCategory Database = "Database access and manipulation"
showCategory Web = "Libraries for web applications"
showCategory Meta = "Libraries for meta-programming"
--- ID for a category
getCategoryID :: Category -> String
getCategoryID General = "general"
getCategoryID Algorithm = "algorithm"
getCategoryID Database = "database"
getCategoryID Web = "web"
getCategoryID Meta = "meta"
-- classify a line of the source program:
-- here we replace blank line comments by a "breakline" tag
classifyLine :: String -> SourceLine
classifyLine line
| take 3 line == "---" && all isSpace (drop 3 line) = Comment "" --"<br/>"
| take 4 line == "--- " && head (drop 4 line) /= '-' = Comment (drop 4 line)
| take 7 line == "module " = ModDef
| take 7 line == "import " = ModDef
| otherwise = let id1 = getFirstId line
in if null id1
then OtherLine
else if id1 == "data" || id1 == "type" || id1 == "newtype"
then DataDef (getDatatypeName line)
else if "'default" `isSuffixOf` id1
then OtherLine -- ignore default rules
else FuncDef id1
where
getDatatypeName = takeWhile isIdChar . dropWhile (==' ') . dropWhile isIdChar
-- get the first identifier (name or operator in brackets) in a string:
getFirstId :: String -> String
getFirstId [] = ""
getFirstId (c:cs)
| isAlpha c = takeWhile isIdChar (c:cs)
| c == '(' = let bracketid = takeWhile (/=')') cs
in if all (`elem` infixIDs) bracketid
then bracketid
else ""
| otherwise = ""
-- is an alphanumeric character, underscore, or apostroph?
isIdChar :: Char -> Bool
isIdChar c = isAlphaNum c || c == '_' || c == '\''
-- All characters occurring in infix operators.
infixIDs :: String
infixIDs = "~!@#$%^&*+-=<>?./|\\:"
-- group the classified lines into module comment and list of
-- (Func/DataDef,comment) pairs:
groupLines :: [SourceLine] -> (String,[(SourceLine,String)])
groupLines sls =
let (modcmts,progcmts) = break (==ModDef) sls
in if progcmts == []
then ("", groupProgLines sls)
else (concatMap getComment modcmts,
groupProgLines (filter (/=ModDef) (tail progcmts)))
where
getComment src = case src of
Comment cmt -> cmt ++ "\n"
_ -> "" -- this case should usually not occur
groupProgLines :: [SourceLine] -> [(SourceLine,String)]
groupProgLines [] = []
groupProgLines (Comment cmt : sls) = groupComment cmt sls
groupProgLines (FuncDef f : sls) = (FuncDef f, "") : skipFuncDefs f sls
groupProgLines (DataDef d : sls) = (DataDef d, "") : skipDataDefs d sls
groupProgLines (ModDef : sls) = groupProgLines sls
groupProgLines (OtherLine : sls) = groupProgLines sls
groupComment :: String -> [SourceLine] -> [(SourceLine,String)]
groupComment _ [] = [] -- comment not followed by definition -> ignore
groupComment cmt (Comment cmt1 : sls) = groupComment (cmt++"\n"++cmt1) sls
groupComment cmt (FuncDef f : sls) = (FuncDef f, cmt) : skipFuncDefs f sls
groupComment cmt (DataDef d : sls) = (DataDef d, cmt) : skipDataDefs d sls
groupComment cmt (ModDef : sls) = groupComment cmt sls
groupComment cmt (OtherLine : sls) = groupComment cmt sls
skipFuncDefs :: String -> [SourceLine] -> [(SourceLine,String)]
skipFuncDefs _ [] = []
skipFuncDefs _ (Comment cmt : sls) = groupProgLines (Comment cmt : sls)
skipFuncDefs _ (DataDef d : sls) = groupProgLines (DataDef d : sls)
skipFuncDefs f (FuncDef f1 : sls) =
if f == f1 then skipFuncDefs f sls
else groupProgLines (FuncDef f1 : sls)
skipFuncDefs f (ModDef : sls) = skipFuncDefs f sls
skipFuncDefs f (OtherLine : sls) = skipFuncDefs f sls
skipDataDefs :: String -> [SourceLine] -> [(SourceLine,String)]
skipDataDefs _ [] = []
skipDataDefs _ (Comment cmt : sls) = groupProgLines (Comment cmt : sls)
skipDataDefs _ (FuncDef f : sls) = groupProgLines (FuncDef f : sls)
skipDataDefs d (DataDef d1 : sls) =
if d == d1 then skipDataDefs d sls
else groupProgLines (DataDef d1 : sls)
skipDataDefs d (ModDef : sls) = skipDataDefs d sls
skipDataDefs d (OtherLine : sls) = skipDataDefs d sls
--------------------------------------------------------------------------
-- get comment for a function name:
getFuncComment :: String -> [(SourceLine,String)] -> String
getFuncComment _ [] = ""
getFuncComment fname ((def, cmt):fdcmts) = case def of
FuncDef f -> if fname == f then cmt else getFuncComment fname fdcmts
_ -> getFuncComment fname fdcmts
-- get comment for a constructor or a field name
getConsComment :: [String] -> String -> Maybe ((String,String))
getConsComment [] _ = Nothing
getConsComment (conscmt:conscmts) cname =
let (consname,rconscmt) = span isIdChar conscmt
in if consname == cname
then let (conscall,callcmt) = break (=='-') conscmt
in Just (if null callcmt then (consname,rconscmt)
else (conscall,callcmt))
else getConsComment conscmts cname
-- get comment for a type name:
getDataComment :: String -> [(SourceLine,String)] -> String
getDataComment _ [] = ""
getDataComment n ((def, cmt):fdcmts) = case def of
DataDef d -> if n == d then cmt else getDataComment n fdcmts
_ -> getDataComment n fdcmts
-- get all comments of a particular type (e.g., "param", "cons"):
getCommentType :: a -> [(a,b)] -> [b]
getCommentType ctype cmts = map snd (filter (\c -> fst c == ctype) cmts)
--------------------------------------------------------------------------
-- Split a comment into its main part and parts preceded by "@...":
-- Example: splitComment "aaaa\nbbbb\n@param xxxx\n@return yyyy"
-- = ("aaaa\nbbbb",[("param","xxxx"),("return","yyyy")])
splitComment :: String -> (String,[(String,String)])
splitComment cmt = splitCommentMain (lines cmt)
splitCommentMain :: [String] -> (String,[(String,String)])
splitCommentMain [] = ("",[])
splitCommentMain (l:ls) =
if l == "" || head l /= '@'
then let (maincmt,rest) = splitCommentMain ls
in (l++('\n':maincmt),rest)
else ([],splitCommentParams (takeWhile isAlpha (tail l))
(dropWhile isAlpha (tail l)) ls)
splitCommentParams :: String -> String -> [String] -> [(String,String)]
splitCommentParams param paramcmt [] = [(param,skipWhiteSpace paramcmt)]
splitCommentParams param paramcmt (l:ls) =
if l == "" || head l /= '@'
then splitCommentParams param (paramcmt++('\n':l)) ls
else ((param,skipWhiteSpace paramcmt)
: splitCommentParams (takeWhile isAlpha (tail l))
(dropWhile isAlpha (tail l)) ls)
-----------------------------------------------------------------------
-- auxiliaries:
-- skip leading blanks or CRs in a string:
skipWhiteSpace :: String -> String
skipWhiteSpace = dropWhile isWhiteSpace
isWhiteSpace :: Char -> Bool
isWhiteSpace c = c == ' ' || c == '\n'
-- enclose a non-letter identifier in brackets:
showId :: String -> String
showId name = if isAlpha (head name) then name
else ('(':name)++")"
-- if first argument is True, put brackets around second argument:
brackets :: Bool -> String -> String
brackets False s = s
brackets True s = "("++s++")"
-- extract last name from a path name:
getLastName :: String -> String
getLastName = reverse . takeWhile (/='/') . reverse
--------------------------------------------------------------------------
{-# OPTIONS_CYMAKE -F --pgmF=currypp --optF=contracts #-}
{-# OPTIONS_CYMAKE -F --pgmF=currypp --optF=contracts #-}
-- A specification of sorting a list and an implementation based
-- on the quicksort algorithm
......@@ -13,7 +13,7 @@ sorted [_] = True
sorted (x:y:ys) = x<=y && sorted (y:ys)
-- Trivial precondition, just for testing
sort'pre xs = length xs > 0
sort'pre xs = length xs >= 0
-- Postcondition: input and output lists should have the same length
sort'post xs ys = length xs == length ys
......
......@@ -8,7 +8,7 @@
all: cwrapper
# generate saved state for contract wrapper:
cwrapper: TransContracts.curry AbstractCurryComments.curry
cwrapper: TransContracts.curry
pakcs :l TransContracts :save :q && mv TransContracts cwrapper
.PHONY: clean
......
......@@ -22,6 +22,17 @@ For this purpose use the option "-e" as follows:
{-# OPTIONS_CYMAKE -F --pgmF=currypp --optF=contracts --optF=-e #-}
------------------------------------------------------------------------
Options:
The contract preprocessor accepts the following options:
-o : write the transformed Curry program into file <prog>.curry.CURRYPP
-e : encapsulate nondeterminism of assertions
-t : assert contracts only to top-level (but not to direct recursive) calls;
this might lead to a faster execution but less (incomplete!)
contract checking
------------------------------------------------------------------------
Assumptions:
......
......@@ -8,17 +8,16 @@ module TransContracts(main,transContracts) where
import AbstractCurry.Types
import AbstractCurry.Files
import AbstractCurryComments
import AbstractCurry.Pretty
import AbstractCurry.Build
import AbstractCurry.Select
import AbstractCurry.Transform
import Char
import Directory
import Distribution
import List
import Maybe(fromJust)
import System
import Time
banner :: String
banner = unlines [bannerLine,bannerText,bannerLine]
......@@ -36,10 +35,11 @@ transContracts verb moreopts orgfile infile outfile = do
modname = stripCurrySuffix orgfile
renameFile orgfile savefile
starttime <- getCPUTime
readFile infile >>= writeFile orgfile . replaceOptionsLine
srcprog <- readFile infile
writeFile orgfile (replaceOptionsLine srcprog)
inputProg <- tryReadCurry modname savefile
renameFile savefile orgfile
transformCProg opts (addCmtFuncInProg inputProg) modname modname outfile
transformCProg opts srcprog (addCmtFuncInProg inputProg) modname outfile
stoptime <- getCPUTime
when (verb>1) $ putStrLn
("Contract wrapper transformation time: " ++
......@@ -47,7 +47,8 @@ transContracts verb moreopts orgfile infile outfile = do
where
processOpts opts ppopts = case ppopts of
[] -> return opts
("-e":more) -> processOpts (opts { withEncapsulate = True }) more
("-e":more) -> processOpts (opts { withEncapsulate = True }) more
("-t":more) -> processOpts (opts { topLevelContracts = True }) more
_ -> showError
where
showError = do
......@@ -69,18 +70,24 @@ replaceOptionsLine = unlines . map replOptLine . lines
------------------------------------------------------------------------
-- Data type for transformation parameters
data Options = Options
{ withEncapsulate :: Bool -- encapsulate assertion checking by set functions?
, executeProg :: Bool -- load and execute transformed program?
{ -- encapsulate assertion checking by set functions?
withEncapsulate :: Bool
-- should contracts be asserted only to top-level entries of an operation
-- or also to all (recursive) calls?
, topLevelContracts :: Bool
-- load and execute transformed program?
, executeProg :: Bool
}
defaultOptions :: Options
defaultOptions = Options
{ withEncapsulate = False
, executeProg = False
{ withEncapsulate = False
, topLevelContracts = False
, executeProg = False
}
------------------------------------------------------------------------
-- Start the contract wrapper in "stand-alone mode":
main :: IO ()
main = do
putStrLn banner
......@@ -88,18 +95,21 @@ main = do
processArgs defaultOptions args
where
processArgs opts args = case args of
("-e":moreargs) -> processArgs (opts { withEncapsulate = True }) moreargs
("-r":moreargs) -> processArgs (opts { executeProg = True }) moreargs
("-e":margs) -> processArgs (opts { withEncapsulate = True }) margs
("-t":margs) -> processArgs (opts { topLevelContracts = True }) margs
("-r":margs) -> processArgs (opts { executeProg = True }) margs
[mnamec] -> let mname = stripCurrySuffix mnamec
in transform opts mname
(transformedModName mname ++ ".curry")
_ -> putStrLn $
"ERROR: Illegal arguments for transformation: " ++
unwords args ++ "\n" ++
"Usage: dsdcurry [-e|-r] <module_name>\n"++
"-e : encapsulate nondeterminism of assertions\n"++
"-r : load the transformed program into Curry system\n"
_ -> putStrLn $ unlines $
["ERROR: Illegal arguments for transformation: " ++ unwords args
,""
,"Usage: cwrapper [-e] [-t] [-r] <module_name>"
,"-e : encapsulate nondeterminism of assertions"
,"-t : assert contracts only to top-level (not recursive) calls"
,"-r : load the transformed program into Curry system"
]
-- Specifies how the name of the transformed module is built from the
-- name of the original module.
......@@ -116,16 +126,22 @@ loadIntoCurry m = do
-- The main transformation function.
transform :: Options -> String -> String -> IO ()
transform opts modname outfile = do
mmodsrc <- lookupModuleSourceInLoadPath modname
srcprog <- case mmodsrc of
Nothing -> error $
"Source code of module '"++modname++"' not found!"
Just (_,progname) -> readFile progname
let acyfile = abstractCurryFileName modname
doesFileExist acyfile >>= \b -> if b then removeFile acyfile else done
prog <- readCurryWithComments modname >>= return . addCmtFuncInProg
prog <- readCurry modname >>= return . addCmtFuncInProg
doesFileExist acyfile >>= \b -> if b then done
else error "Source program incorrect"
transformCProg opts prog modname (transformedModName modname) outfile
transformCProg opts srcprog prog (transformedModName modname) outfile
transformCProg :: Options -> CurryProg -> String -> String -> String -> IO ()
transformCProg opts prog modname outmodname outfile = do
let fdecls = functions prog
transformCProg :: Options -> String -> CurryProg -> String -> String -> IO ()
transformCProg opts srctxt prog outmodname outfile = do
let funposs = linesOfFDecls srctxt prog
fdecls = functions prog
funspecs = getFunDeclsWith isSpecName prog
specnames = map (dropSpecName . snd . funcName) funspecs
preconds = getFunDeclsWith isPreCondName prog
......@@ -136,7 +152,7 @@ transformCProg opts prog modname outmodname outfile = do
onlyprecond = prenames \\ map (snd . funcName) fdecls
onlypostcond = postnames \\ map (snd . funcName) fdecls
onlyspec = specnames \\ map (snd . funcName) fdecls
newprog = transformProgram opts fdecls funspecs preconds
newprog = transformProgram opts funposs fdecls funspecs preconds
postconds prog
unless (null onlyprecond) $
error ("Operations with precondition but without an implementation: "
......@@ -156,15 +172,15 @@ transformCProg opts prog modname outmodname outfile = do
if executeProg opts
then loadIntoCurry outmodname
else done
-- Get functions from a Curry module with a name satisfying the predicate:
getFunDeclsWith :: (String -> Bool) -> CurryProg -> [CFuncDecl]
getFunDeclsWith pred prog = filter (pred . snd . funcName) (functions prog)
-- Transform a given program w.r.t. given specifications and pre/postconditions
transformProgram :: Options -> [CFuncDecl] -> [CFuncDecl] -> [CFuncDecl]
-> [CFuncDecl] -> CurryProg -> CurryProg
transformProgram opts allfdecls specdecls predecls postdecls
transformProgram :: Options -> [(QName,Int)]-> [CFuncDecl] -> [CFuncDecl]
-> [CFuncDecl] -> [CFuncDecl] -> CurryProg -> CurryProg
transformProgram opts funposs allfdecls specdecls predecls postdecls
(CurryProg mname imps tdecls fdecls opdecls) =
let newpostconds = concatMap (genPostCond4Spec opts allfdecls postdecls)
specdecls
......@@ -177,9 +193,9 @@ transformProgram opts allfdecls specdecls predecls postdecls
(nub ("Test.Contract":"SetFunctions":imps))
tdecls
(map deleteCmtIfEmpty
(map (addContract opts allfdecls predecls contractpcs)
wonewfuns ++
newpostconds))
(map (addContract opts funposs allfdecls predecls contractpcs)
wonewfuns ++
newpostconds))
opdecls
-- Add an empty comment to each function which has no comment
......@@ -196,6 +212,7 @@ addCmtFuncInProg (CurryProg mname imps tdecls fdecls opdecls) =
-- otherwise generate a set containment check.
genPostCond4Spec :: Options -> [CFuncDecl] -> [CFuncDecl] -> CFuncDecl
-> [CFuncDecl]
genPostCond4Spec _ _ _ (CFunc _ _ _ _ _) = error "genPostCond4Spec"
genPostCond4Spec _ allfdecls postdecls (CmtFunc _ (m,f) ar vis texp _) =
let fname = dropSpecName f
detspec = isDetSpecName f -- determ. spec? (later: use prog.ana.)
......@@ -262,10 +279,11 @@ genPostCond4Spec _ allfdecls postdecls (CmtFunc _ (m,f) ar vis texp _) =
]
-- adds contract checking to a function if it has a pre- or postcondition
addContract :: Options -> [CFuncDecl] -> [CFuncDecl] -> [CFuncDecl]
-> CFuncDecl -> CFuncDecl
addContract opts allfdecls predecls postdecls
fdecl@(CmtFunc cmt (m,f) ar vis texp _) =
addContract :: Options -> [(QName,Int)] -> [CFuncDecl] -> [CFuncDecl]
-> [CFuncDecl] -> CFuncDecl -> CFuncDecl
addContract _ _ _ _ _ (CFunc _ _ _ _ _) = error "addContract"
addContract opts funposs allfdecls predecls postdecls
fdecl@(CmtFunc cmt qn@(m,f) ar vis texp _) =
let argvars = map (\i -> (i,"x"++show i)) [1..ar]
predecl = find (\fd -> dropPreCondName(snd(funcName fd)) == f) predecls
prename = funcName (fromJust predecl)
......@@ -274,6 +292,11 @@ addContract opts allfdecls predecls postdecls
encapsSuf = if withEncapsulate opts then "ND" else ""
encaps fn n = if withEncapsulate opts then setFun n fn [] else constF fn
rename qf = if qf==(m,f) then (m,f++"'org") else qf
fref = string2ac $
"'" ++ f ++ "' (module " ++ m ++
maybe ")"
(\l -> ", line " ++ show l ++ ")")
(lookup qn funposs)
orgfunexp = constF (rename (m,f))
obsfunexp = constF $
maybe (pre "id")
......@@ -282,22 +305,22 @@ addContract opts allfdecls predecls postdecls
allfdecls)
asrtCall = if predecl==Nothing
then applyF (cMod $ "withPostContract" ++ show ar ++ encapsSuf)
([string2ac f, encaps postname (ar+1), obsfunexp,
orgfunexp] ++
([fref, encaps postname (ar+1), obsfunexp, orgfunexp] ++
map CVar argvars)
else if postdecl==Nothing
then applyF (cMod $ "withPreContract" ++ show ar ++ encapsSuf)
([string2ac f, encaps prename ar, orgfunexp] ++
([fref, encaps prename ar, orgfunexp] ++
map CVar argvars)
else applyF (cMod $ "withContract" ++ show ar ++ encapsSuf)
([string2ac f, encaps prename ar,
([fref, encaps prename ar,
encaps postname (ar+1), obsfunexp, orgfunexp] ++
map CVar argvars)
oldfdecl = if topLevelContracts opts
then updQNamesInCLocalDecl rename (CLocalFunc (deleteCmt fdecl))
else CLocalFunc (renameFDecl rename (deleteCmt fdecl))
in if predecl==Nothing && postdecl==Nothing then fdecl else
cmtfunc cmt (m,f) ar vis texp
[simpleRuleWithLocals (map CPVar argvars)
asrtCall
[updQNamesInCLocalDecl rename (CLocalFunc (deleteCmt fdecl))]]
[simpleRuleWithLocals (map CPVar argvars) asrtCall [oldfdecl]]
-- Is this the name of a specification?
......@@ -349,6 +372,7 @@ setFun :: Int -> QName -> [CExpr] -> CExpr
setFun n qn args = applyF (sfMod $ "set"++show n) (constF qn : args)
------------------------------------------------------------------------
-- Auxiliary operations:
-- Replaces a result type of a function type by a new type
replaceResultType :: CTypeExpr -> CTypeExpr -> CTypeExpr
......@@ -363,28 +387,11 @@ extendFuncType t@(CTVar _) texp = t ~> texp
extendFuncType t@(CTCons _ _) texp = t ~> texp
extendFuncType (CFuncType t1 t2) texp = t1 ~> (extendFuncType t2 texp)
------------------------------------------------------------------------
-- Auxiliary operations:
--- Copy a file on demand, i.e., do not copy it if the target file
--- exists with the same time stamp and size.
copyFileOnDemand :: String -> String -> IO ()
copyFileOnDemand source target = do
let copycmd = do putStrLn "Copying auxiliary module:"
putStrLn (source++" -> "++target)
system ("cp "++source++" "++target) >> done
exfile <- doesFileExist target
if exfile
then do odate <- getModificationTime source
ndate <- getModificationTime target
osize <- fileSize source
nsize <- fileSize target
if compareClockTime ndate odate /= LT && osize == nsize
then done
else copycmd
else copycmd
--- Renames a function declaration (but not the body).
renameFDecl :: (QName -> QName) -> CFuncDecl -> CFuncDecl
renameFDecl rn (CFunc qn ar vis texp rules) = CFunc (rn qn) ar vis texp rules
renameFDecl _ (CmtFunc _ _ _ _ _ _) = error "renameFDecl"
------------------------------------------------------------------------
--- Deletes the comment in a function declaration.
deleteCmt :: CFuncDecl -> CFuncDecl
deleteCmt (CFunc qn ar vis texp rules) = CFunc qn ar vis texp rules
......@@ -398,3 +405,31 @@ deleteCmtIfEmpty (CmtFunc cmt qn ar vis texp rules) =
else CmtFunc cmt qn ar vis texp rules
------------------------------------------------------------------------
-- Compute names and lines numbers of all top-level operations in a program.
linesOfFDecls :: String -> CurryProg -> [(QName,Int)]
linesOfFDecls srctxt prog =
map (addSourceLineNumber (map firstId (lines srctxt)))
(map funcName (functions prog))
where
addSourceLineNumber ids qn = (qn, maybe 0 (+1) (elemIndex (snd qn) ids))
-- Compute the first identifier (name or operator in brackets) in a string:
firstId :: String -> String
firstId [] = ""
firstId (c:cs)
| isAlpha c = takeWhile isIdChar (c:cs)
| c == '(' = let bracketid = takeWhile (/=')') cs
in if all (`elem` infixIDs) bracketid
then bracketid
else ""
| otherwise = ""
-- Is this an alphanumeric character, underscore, or apostroph?
isIdChar :: Char -> Bool
isIdChar c = isAlphaNum c || c == '_' || c == '\''
-- All characters occurring in infix operators.
infixIDs :: String