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

CASS now re-analyzes program if source OR FlatCurry file is newer than analysis results

parent 3dc5da81
......@@ -19,7 +19,7 @@ import IOExts
import XML
import Analysis
import Configuration(debugMessageLevel,numberOfWorkers)
import Configuration(debugMessage,numberOfWorkers)
import CurryFiles(getImports)
import GenericProgInfo
import AnalysisDependencies(getModulesToAnalyze)
......@@ -137,11 +137,6 @@ lookupRegAnaWorker :: String -> ([String] -> IO ())
lookupRegAnaWorker aname =
maybe (const done) regAnaWorker (lookupRegAna aname registeredAnalysis)
--------------------------------------------------------------------
debugMessage dl message =
debugMessageLevel dl ("AnalysisCollection: "++message)
--------------------------------------------------------------------
-- Run an analysis with a given name on a given module with a list
-- of workers identified by their handles and return the analysis results.
......@@ -186,7 +181,7 @@ analyzeMain :: Analysis a -> String -> [Handle] -> Bool -> Bool
-> IO (Either (ProgInfo a) String)
analyzeMain analysis modname handles enforce load = do
let ananame = analysisName analysis
debugMessage 2 ("start analysis "++modname++"/"++ananame)
debugMessage 2 ("Start analysis: "++modname++"/"++ananame)
modulesToDo <- getModulesToAnalyze enforce analysis modname
let numModules = length modulesToDo
workresult <-
......@@ -194,11 +189,12 @@ analyzeMain analysis modname handles enforce load = do
then return Nothing
else do
when (numModules>1) $
debugMessage 1 ("Number of modules to be analyzed: " ++ show numModules)
debugMessage 1
("Number of modules to be analyzed: " ++ show numModules)
prepareCombinedAnalysis analysis modname (map fst modulesToDo) handles
numworkers <- numberOfWorkers
if numworkers>0
then do debugMessage 2 "start MasterLoop"
then do debugMessage 2 "Starting master loop"
masterLoop handles [] ananame modname modulesToDo []
else analyzeLocally ananame (map fst modulesToDo)
result <-
......@@ -208,7 +204,7 @@ analyzeMain analysis modname handles enforce load = do
else return (Left emptyProgInfo))
(return . Right)
workresult
debugMessage 4 ("result: " ++ either showProgInfo id result)
debugMessage 4 ("Result: " ++ either showProgInfo id result)
return result
-- Analyze a module and all its imports locally without worker processes.
......
......@@ -5,12 +5,11 @@
--- @version January 2015
-----------------------------------------------------------------------
module AnalysisDependencies(getModulesToAnalyze,reduceDependencies,
readNewestFlatCurry) where
module AnalysisDependencies(getModulesToAnalyze,reduceDependencies) where
import FlatCurry
import FlatCurryGoodies(progImports)
import ReadShowTerm(readQTerm,showQTerm)
import ReadShowTerm(readQTerm)
import Directory(doesFileExist,getModificationTime)
import Distribution(findFileInLoadPath)
import Maybe(fromMaybe)
......@@ -18,12 +17,11 @@ import List(delete)
import Time(ClockTime)
import Analysis
import GenericProgInfo
import LoadAnalysis(getAnalysisPublicFile,storeImportModuleList,getImportModuleListFile)
import Configuration(debugMessageLevel,getWithPrelude)
import LoadAnalysis(getAnalysisPublicFile,storeImportModuleList,
getImportModuleListFile)
import Configuration(debugMessage,getWithPrelude)
import CurryFiles
debugMessage dl message = debugMessageLevel dl ("Dependencies: "++message)
-----------------------------------------------------------------------
--- Compute the modules and their imports which must be analyzed
--- w.r.t. a given analysis and main module.
......@@ -44,13 +42,14 @@ getModulesToAnalyze enforce analysis moduleName =
else do
moduleList <- getDependencyList [moduleName] []
debugMessage 3 ("Complete module list: "++ show moduleList)
storeImportModuleList moduleName (map fst moduleList)
sourceTimeList <- mapIO getSourceFileTime (map fst moduleList)
--debugMessage 3 ("Source time list: "++ show sourceTimeList)
anaTimeList <- mapIO (getAnaFileTime ananame) (map fst moduleList)
--debugMessage 3 ("Analysis time list: "++ show anaTimeList)
let impmods = map fst moduleList
storeImportModuleList moduleName impmods
sourceTimeList <- mapIO getSourceFileTime impmods
fcyTimeList <- mapIO getFlatCurryFileTime impmods
anaTimeList <- mapIO (getAnaFileTime ananame) impmods
let (modulesToDo,modulesUpToDate) =
findModulesToAnalyze moduleList anaTimeList sourceTimeList ([],[])
findModulesToAnalyze moduleList
anaTimeList sourceTimeList fcyTimeList ([],[])
--debugMessage 3 ("Modules up-to-date: "++ show modulesUpToDate)
withprelude <- getWithPrelude
let modulesToAnalyze = if enforce then moduleList else
......@@ -73,10 +72,20 @@ isAnalysisFileNewer ananame modname = do
atime <- getAnaFileTime ananame modname
stime <- getSourceFileTime modname
ftime <- getFlatCurryFileTime modname
return (snd atime >= Just (snd stime) && snd atime >= snd ftime)
return (isAnalysisFileTimeNewer (snd atime) (Just (snd stime)) (snd ftime))
-- Is the analysis file time up-to-date w.r.t. the file times of
-- the source file and the FlatCurry file?
-- Returns True if the analysis file is newer than the source file
-- and the FlatCurry file (if is exists).
isAnalysisFileTimeNewer :: Maybe ClockTime -> Maybe ClockTime -> Maybe ClockTime
-> Bool
isAnalysisFileTimeNewer anatime srctime fcytime =
anatime >= srctime && anatime >= fcytime
-- Read current import dependencies and checks whether the current analysis
-- file is valud.
-- file is valid, i.e., it is newer than the source and FlatCurry files
-- of all (directly and indirectly) imported modules.
isAnalysisValid :: String -> String -> IO Bool
isAnalysisValid ananame modname =
getImportModuleListFile modname >>= maybe
......@@ -87,10 +96,13 @@ isAnalysisValid ananame modname =
if itime>=stime
then do
implist <- readFile importListFile >>= return . readQTerm
sourceTimeList <- mapIO getSourceFileTime implist
anaTimeList <- mapIO (getAnaFileTime ananame) implist
return (all (uncurry (>=))
(zip (map snd anaTimeList) (map (Just . snd) sourceTimeList)))
sourceTimeList <- mapIO getSourceFileTime implist
fcyTimeList <- mapIO getFlatCurryFileTime implist
anaTimeList <- mapIO (getAnaFileTime ananame) implist
return (all (\ (x,y,z) -> isAnalysisFileTimeNewer x y z)
(zip3 (map snd anaTimeList)
(map (Just . snd) sourceTimeList)
(map snd fcyTimeList)))
else return False)
......@@ -111,8 +123,11 @@ getDependencyList (mname:mods) moddeps =
(lookupAndReorder mname [] moddeps)
-- add new modules if they are not already there:
addNewMods :: [String] -> [String] -> [String]
addNewMods oldmods newmods = oldmods ++ filter (`notElem` oldmods) newmods
lookupAndReorder :: String -> [(String, [String])] -> [(String, [String])]
-> Maybe ([(String, [String])], [String])
lookupAndReorder _ _ [] = Nothing
lookupAndReorder mname list1 ((amod,amodimports):rest)
| mname==amod = Just ((amod,amodimports):reverse list1++rest, amodimports)
......@@ -131,36 +146,45 @@ getAnaFileTime anaName moduleName = do
-- check if analysis result of a module can be loaded or needs to be
-- newly analyzed
findModulesToAnalyze :: [(String,[String])] -> [(String,Maybe ClockTime)]
findModulesToAnalyze :: [(String,[String])]
-> [(String,Maybe ClockTime)]
-> [(String,ClockTime)]
-> [(String,Maybe ClockTime)]
-> ([(String,[String])],[String])
-> ([(String,[String])],[String])
findModulesToAnalyze [] _ _ (modulesToDo,modulesUpToDate) =
findModulesToAnalyze [] _ _ _ (modulesToDo,modulesUpToDate) =
(reverse modulesToDo, modulesUpToDate)
findModulesToAnalyze (m:ms) anaTimeList sourceTimeList resultLists =
let (mod,imports)= m
(modulesToDo,modulesUpToDate) = resultLists in
findModulesToAnalyze (m@(mod,imports):ms)
anaTimeList sourceTimeList fcyTimeList
(modulesToDo,modulesUpToDate) =
case (lookup mod anaTimeList) of
Just Nothing -> findModulesToAnalyze ms anaTimeList sourceTimeList
fcyTimeList
((m:modulesToDo),modulesUpToDate)
Just(Just time) ->
if checkTime mod time imports anaTimeList sourceTimeList modulesToDo
then findModulesToAnalyze ms anaTimeList sourceTimeList
Just (Just time) ->
if checkTime mod time imports anaTimeList sourceTimeList fcyTimeList
modulesToDo
then findModulesToAnalyze ms anaTimeList sourceTimeList fcyTimeList
(modulesToDo,(mod:modulesUpToDate))
else findModulesToAnalyze ms anaTimeList sourceTimeList
else findModulesToAnalyze ms anaTimeList sourceTimeList fcyTimeList
((m:modulesToDo),modulesUpToDate)
where
-- function to check if result file is up-to-date
-- compares timestamp of analysis result file with module source file
-- compares timestamp of analysis result file with module source/FlatCurry file
-- and with timpestamp of result files of all imported modules
checkTime :: String -> ClockTime -> [String] -> [(String,Maybe ClockTime)]
-> [(String,ClockTime)] -> [(String,[String])] -> Bool
checkTime mod time1 [] _ sourceTimeList _ =
(Just time1) >= (lookup mod sourceTimeList)
checkTime mod time1 (impt:impts) anaTimeList sourceTimeList resultList =
((lookup impt resultList)==Nothing)
&&((Just time1)>=(fromMaybe Nothing (lookup impt anaTimeList)))
&&(checkTime mod time1 impts anaTimeList sourceTimeList resultList)
-> [(String,ClockTime)] -> [(String,Maybe ClockTime)]
-> [(String,[String])] -> Bool
checkTime mod time1 [] _ sourceTimeList fcyTimeList _ =
isAnalysisFileTimeNewer (Just time1) (lookup mod sourceTimeList)
(fromMaybe Nothing (lookup mod fcyTimeList))
checkTime mod time1 (impt:impts) anaTimeList sourceTimeList fcyTimeList
resultList =
(lookup impt resultList) == Nothing
&& (Just time1) >= (fromMaybe Nothing (lookup impt anaTimeList))
&& checkTime mod time1 impts anaTimeList sourceTimeList fcyTimeList resultList
-----------------------------------------------------------------------
-- Remove the module analysis dependencies (first argument) w.r.t.
......
......@@ -42,7 +42,7 @@ data AnalysisServerMessage =
--- Without any program arguments, the server is started on a socket.
--- Otherwise, it is started in batch mode to analyze a module.
main = do
debugMessageLevel 1 systemBanner
debugMessage 1 systemBanner
initializeAnalysisSystem
args <- getArgs
processArgs False args
......@@ -105,7 +105,7 @@ mainServer mbport = do
then do
serveraddress <- getServerAddress
(workerport,workersocket) <- listenOnFresh
debugMessageLevel 2 ("SERVER: port to workers: "++show workerport)
debugMessage 2 ("SERVER: port to workers: "++show workerport)
handles <- startWorkers numworkers workersocket serveraddress workerport []
serverLoop socket1 handles
sClose workersocket
......@@ -213,14 +213,14 @@ startWorkers:: Int -> Socket -> String -> Int -> [Handle] -> IO [Handle]
startWorkers number workersocket serveraddress workerport handles = do
if number>0
then do
debugMessageLevel 4 ("Number:"++(show number))
debugMessage 4 ("Number:"++(show number))
let command = baseDir++"/cass_worker "++serveraddress++" "
++(show workerport)++" &"
debugMessageLevel 4 ("system command: "++command)
debugMessage 4 ("system command: "++command)
system command
debugMessageLevel 4 ("Wait for socket accept for client "++show number)
debugMessage 4 ("Wait for socket accept for client "++show number)
connection <- waitForSocketAccept workersocket waitTime
debugMessageLevel 4 ("Socket accept for client "++show number)
debugMessage 4 ("Socket accept for client "++show number)
case connection of
Just (_,handle) -> do
startWorkers (number-1) workersocket serveraddress workerport
......@@ -240,7 +240,7 @@ stopWorkers (handle:whandles) = do
--------------------------------------------------------------------------
-- server loop to answer analysis requests over network
serverLoop socket1 whandles = do
--debugMessageLevel 3 "SERVER: serverLoop"
--debugMessage 3 "SERVER: serverLoop"
connection <- waitForSocketAccept socket1 waitTime
case connection of
Just (_,handle) -> serverLoopOnHandle socket1 whandles handle
......@@ -264,11 +264,11 @@ serverLoopOnHandle socket1 whandles handle = do
eof <- hIsEOF handle
if eof
then do hClose handle
debugMessageLevel 2 "SERVER connection: eof"
debugMessage 2 "SERVER connection: eof"
serverLoop socket1 whandles
else do
string <- hGetLineUntilEOF handle
debugMessageLevel 2 ("SERVER got message: "++string)
debugMessage 2 ("SERVER got message: "++string)
let force = False
case parseServerMessage string of
ParseError -> do
......@@ -301,7 +301,7 @@ serverLoopOnHandle socket1 whandles handle = do
removeServerPortNumber
where
sendResult resultstring = do
debugMessageLevel 4 ("formatted result:\n"++resultstring)
debugMessage 4 ("formatted result:\n"++resultstring)
sendServerResult handle resultstring
serverLoopOnHandle socket1 whandles handle
......@@ -319,7 +319,7 @@ sendServerResult handle resultstring = do
-- Send a server error in the format "error <error message>\n".
sendServerError handle errstring = do
debugMessageLevel 1 errstring
debugMessage 1 errstring
hPutStrLn handle ("error "++errstring)
hFlush handle
......
......@@ -7,19 +7,16 @@
module AnalysisWorker(main) where
import IO(hClose,hFlush,hWaitForInput,hPutStrLn,hGetLine)
import IO(Handle,hClose,hFlush,hWaitForInput,hPutStrLn,hGetLine)
import ReadShowTerm(readQTerm)
import Socket(connectToSocket)
import System(getArgs,setEnviron)
import AnalysisCollection(lookupRegAnaWorker)
import ServerFunctions(WorkerMessage(..))
import Configuration(debugMessageLevel,waitTime,getDefaultPath)
debugMessage dl message =
debugMessageLevel dl ("AnalysisWorker: "++message)
import Configuration(debugMessage,waitTime,getDefaultPath)
main :: IO ()
main = do
args <- getArgs
if length args /= 2
......@@ -32,6 +29,7 @@ main = do
worker handle
-- communication loop
worker :: Handle -> IO ()
worker handle = do
gotInput <- hWaitForInput handle waitTime
if gotInput
......@@ -40,11 +38,11 @@ worker handle = do
debugMessage 3 ("input: "++input)
case readQTerm input of
Task ananame moduleName -> do
debugMessage 1 ("start task: "++ananame++" for "++moduleName)
debugMessage 1 ("Start task: "++ananame++" for "++moduleName)
-- Run the analysis worker for the given analysis and module:
(lookupRegAnaWorker ananame) [moduleName]
debugMessage 1 ("finished task: "++ananame++" for "++moduleName)
debugMessage 3 ("output: "++input)
debugMessage 1 ("Finished task: "++ananame++" for "++moduleName)
debugMessage 3 ("Output: "++input)
hPutStrLn handle input
hFlush handle
worker handle
......@@ -52,7 +50,7 @@ worker handle = do
setEnviron "CURRYPATH" path
worker handle
StopWorker -> do
debugMessage 2 "stop worker"
debugMessage 2 "Stop worker"
hClose handle
done
else done
......@@ -13,7 +13,7 @@ module Configuration
(systemBanner,baseDir,getServerAddress,updateRCFile,updateCurrentProperty,
getFPMethod,getWithPrelude,
storeServerPortNumber,removeServerPortNumber,getServerPortNumber,
getDefaultPath,waitTime,numberOfWorkers,debugMessageLevel) where
getDefaultPath,waitTime,numberOfWorkers,debugMessage) where
import System
import Distribution(installDir,curryCompiler)
......@@ -28,7 +28,7 @@ import Char(isSpace)
systemBanner =
let bannerText = "CASS: Curry Analysis Server System ("++
"version of 22/10/2014 for "++curryCompiler++")"
"version of 20/01/2015 for "++curryCompiler++")"
bannerLine = take (length bannerText) (repeat '=')
in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine
......@@ -141,7 +141,7 @@ getServerPortNumber = do
then return portnum
else do removeFile serverPortFileName
getServerPortNumber
else do debugMessageLevel 2 "Starting analysis server..."
else do debugMessage 2 "Starting analysis server..."
tcmd <- getTerminalCommand
let serverCmd = baseDir++"/cass"
if all isSpace tcmd
......@@ -154,7 +154,7 @@ getServerPortNumber = do
exfile <- doesFileExist serverPortFileName
if exfile
then readServerPortPid >>= return . fst
else do debugMessageLevel 2 "Waiting for server start..."
else do debugMessage 2 "Waiting for server start..."
sleep 1
waitForServerPort serverPortFileName
......@@ -204,8 +204,8 @@ numberOfWorkers = do
--- Prints a message if debugging level (as specified in the Config file)
--- is at least n:
debugMessageLevel :: Int -> String -> IO ()
debugMessageLevel n message = do
debugMessage :: Int -> String -> IO ()
debugMessage n message = do
properties <- getProperties
let number = lookup "debugLevel" properties
case number of
......
......@@ -15,13 +15,13 @@ import FlatCurryGoodies(progImports)
import Directory(doesFileExist,getModificationTime)
import Distribution(lookupFileInLoadPath,lookupModuleSourceInLoadPath)
import Time(ClockTime)
import Configuration(debugMessageLevel)
import Configuration(debugMessage)
-- Get the imports of a module.
getImports :: String -> IO [String]
getImports moduleName = do
debugMessageLevel 3 ("Reading interface of module "++moduleName)
debugMessage 3 ("Reading interface of module "++moduleName)
readNewestFlatCurryInt moduleName >>= return . progImports
--- Returns a directory name and the actual source file name for a module
......
......@@ -2,14 +2,15 @@
--- This module defines a datatype to represent the analysis information.
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version September 2014
--- @version January 2015
-----------------------------------------------------------------------
module GenericProgInfo where
import Configuration(debugMessageLevel)
import Configuration(debugMessage)
import Directory(removeFile)
import FiniteMap
import FilePath((<.>))
import FlatCurry
import XML
......@@ -68,16 +69,16 @@ publicProgInfo (ProgInfo pub _) = ProgInfo pub (emptyFM (<))
--- Writes a ProgInfo into a file.
writeAnalysisFiles :: String -> ProgInfo _ -> IO ()
writeAnalysisFiles basefname (ProgInfo pub priv) = do
writeFile (basefname++".priv") (showFM priv)
writeFile (basefname++".pub") (showFM pub)
debugMessageLevel 3 $ "Analysis file '"++basefname++"' written."
debugMessage 3 $ "Writing analysis files '"++basefname++"'..."
writeFile (basefname <.> "priv") (showFM priv)
writeFile (basefname <.> "pub") (showFM pub)
--- Reads a ProgInfo from the analysis files where the base file name is given.
readAnalysisFiles :: String -> IO (ProgInfo _)
readAnalysisFiles basefname = do
debugMessageLevel 3 $ "Reading analysis files '"++basefname++"'..."
let pubcontfile = basefname++".pub"
privcontfile = basefname++".priv"
debugMessage 3 $ "Reading analysis files '"++basefname++"'..."
let pubcontfile = basefname <.> "pub"
privcontfile = basefname <.> "priv"
pubcont <- readFile pubcontfile
privcont <- readFile privcontfile
let pinfo = ProgInfo (readFM (<) pubcont) (readFM (<) privcont)
......@@ -92,7 +93,7 @@ readAnalysisFiles basefname = do
--- Reads the public ProgInfo from the public analysis file.
readAnalysisPublicFile :: String -> IO (ProgInfo _)
readAnalysisPublicFile fname = do
debugMessageLevel 3 $ "Reading public analysis file '"++fname++"'..."
debugMessage 3 $ "Reading public analysis file '"++fname++"'..."
fcont <- readFile fname
let pinfo = ProgInfo (readFM (<) fcont) (emptyFM (<))
catch (return $!! pinfo)
......
......@@ -9,55 +9,40 @@
module LoadAnalysis where
import Directory
import FileGoodies(separatorChar,splitDirectoryBaseName,stripSuffix)
import Distribution(stripCurrySuffix)
import FilePath
import System(system,getArgs,getEnviron)
import GenericProgInfo
import Configuration(debugMessageLevel,getWithPrelude)
import Configuration(debugMessage,getWithPrelude)
import IO
import FiniteMap
import ReadShowTerm(readQTerm,showQTerm)
import FlatCurry(QName)
import CurryFiles(findModuleSourceInLoadPath)
debugMessage :: Int -> String -> IO ()
debugMessage n message = debugMessageLevel n ("LoadAnalysis: "++message)
--- Get the file name in which analysis results are stored
--- (without suffix ".pub" or ".priv")
-- TODO: does not work for Windows
getAnalysisBaseFile :: String -> String -> IO String
getAnalysisBaseFile moduleName anaName = do
analysisDirectory <- getAnalysisDirectory
currentDir <- getCurrentDirectory >>= return . dropDrive
let modAnaName = moduleName <.> anaName
(fileDir,_) <- findModuleSourceInLoadPath moduleName
if fileDir == "." || fileDir == "./"
then do
currentDir <- getCurrentDirectory
return (analysisDirectory++currentDir++"/"++moduleName++"."++anaName)
else
if head fileDir /= '/' -- TODO: does not work for Windows
then do -- is relative path name
currentDir <- getCurrentDirectory
return (analysisDirectory++currentDir++"/"++fileDir++"/"++
moduleName++"."++anaName)
else return (analysisDirectory++fileDir++"/"++moduleName++"."++anaName)
if isAbsolute fileDir
then return (analysisDirectory </> dropDrive fileDir </> modAnaName)
else return (analysisDirectory </> currentDir </> fileDir </> modAnaName)
--- Get the file name in which public analysis results are stored.
getAnalysisPublicFile :: String -> String -> IO String
getAnalysisPublicFile modname ananame = do
getAnalysisBaseFile modname ananame >>= return . (++".pub")
getAnalysisBaseFile modname ananame >>= return . (<.> "pub")
-- directory where analysis info files are stored ($HOME has to be set)
getAnalysisDirectory :: IO String
getAnalysisDirectory = do
homeDir <- getHomeDirectory
return (homeDir++"/.curry/Analysis/")
-- splits directory path in hierarchic list of folders of path
splitDirectories :: String -> [String]
splitDirectories dir =
let (rbase,rdir) = break (==separatorChar) (reverse dir) in
if null rdir then []
else (splitDirectories (reverse (tail rdir)))++[(reverse rbase)]
return (homeDir </> ".curry" </> "Analysis")
-- loads analysis results for a list of modules
getInterfaceInfos :: String -> [String] -> IO (ProgInfo a)
......@@ -77,7 +62,7 @@ getInterfaceInfos anaName (mod:mods) =
loadDefaultAnalysisValues :: String -> String -> IO [(QName,a)]
loadDefaultAnalysisValues anaName moduleName = do
(_,fileName) <- findModuleSourceInLoadPath moduleName
let defaultFileName = stripSuffix fileName ++ ".defaults."++anaName
let defaultFileName = stripCurrySuffix fileName ++ ".defaults."++anaName
fileExists <- doesFileExist defaultFileName
if fileExists
then do debugMessage 3 ("Load default values from " ++ defaultFileName)
......@@ -102,8 +87,7 @@ loadPublicAnalysis anaName moduleName = do
storeImportModuleList :: String -> [String] -> IO ()
storeImportModuleList modname modlist = do
importListFile <- getAnalysisBaseFile modname "IMPORTLIST"
let (dir,_) = splitDirectoryBaseName importListFile
createDirectoryR dir
createDirectoryR (dropFileName importListFile)
writeFile importListFile (showQTerm modlist)
--- Gets the file containing import dependencies for a main module
......@@ -116,30 +100,27 @@ getImportModuleListFile modname = do
--- Store an analysis results in a file and create directories if neccesssary.
--- The first argument is the analysis name.
storeAnalysisResult:: String -> String -> ProgInfo a -> IO ()
storeAnalysisResult :: String -> String -> ProgInfo a -> IO ()
storeAnalysisResult ananame moduleName result = do
baseFileName <- getAnalysisBaseFile moduleName ananame
let (dir,_) = splitDirectoryBaseName baseFileName
createDirectoryR dir
createDirectoryR (dropFileName baseFileName)
debugMessage 4 ("Analysis result: " ++ showProgInfo result)
writeAnalysisFiles baseFileName result
-- creates directory (and all needed root-directories) recursively
createDirectoryR::String->IO()
createDirectoryR dir = do
let dirList = splitDirectories dir
createDirectoryRHelp "" dirList
createDirectoryRHelp::String->[String]->IO()
createDirectoryRHelp _ [] = done
createDirectoryRHelp dirname (dir:restList) = do
let createdDir = dirname++"/"++dir
dirExists <- doesDirectoryExist createdDir
if (dirExists)
then done
else createDirectory createdDir
createDirectoryRHelp createdDir restList
createDirectoryR :: String -> IO ()
createDirectoryR maindir =
let (drv,dir) = splitDrive maindir
in createDirectories drv (splitDirectories dir)
where
createDirectories _ [] = done
createDirectories dirname (dir:dirs) = do
let createdDir = dirname </> dir
dirExists <- doesDirectoryExist createdDir
unless dirExists $ do
debugMessage 3 ("Creating directory '"++createdDir++"'...")
createDirectory createdDir
createDirectories createdDir dirs
-- delete all savefiles of analysis
deleteAnalysisFiles :: String -> IO Int
......
------------------------------------------------------------------------
--- Implementation of the analysis computations on the server side
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version January 2015
------------------------------------------------------------------------
-- analysis computations on the server side
module ServerFunctions where
......@@ -18,12 +25,10 @@ import Analysis
import GenericProgInfo
import AnalysisDependencies
import XML(showXmlDoc,xml)
import Configuration(debugMessageLevel,waitTime)
import Configuration(debugMessage,waitTime)
data WorkerMessage = Task String String | ChangePath String | StopWorker
debugMessage dl message = debugMessageLevel dl ("ServerFunctions: "++message)
-- Master loop for communication with workers
-- Argument 1: handles for workers that are currently free
......@@ -37,18 +42,18 @@ debugMessage dl message = debugMessageLevel dl ("ServerFunctions: "++message)
masterLoop :: [Handle] -> [Handle] -> String -> String
-> [(String,[String])] -> [String] -> IO (Maybe String)
masterLoop _ [] _ _ [] [] = do
debugMessage 2 "masterLoop terminated"
debugMessage 2 "Master loop: terminated"
return Nothing
masterLoop _ (b:busyWorker) ananame mainModule [] [] = do
debugMessage 2 "masterLoop waiting for worker result"
debugMessage 2 "Master loop: waiting for worker result"
inputHandle <- hWaitForInputs (b:busyWorker) waitTime
if inputHandle/=0
then return (Just "No input from any worker received")
else do
let handle = b
input <- hGetLine handle
debugMessage 2 ("got message: "++input)
debugMessage 2 ("Master loop: got message: "++input)
let Task ananame2 moduleName2 = readQTerm input
if ananame==ananame2 && moduleName2==mainModule
then return Nothing
......@@ -56,19 +61,19 @@ masterLoop _ (b:busyWorker) ananame mainModule [] [] = do
masterLoop idleWorker busyWorker ananame mainModule
modulesToDo@(_:_) [] = do
debugMessage 3 ("modulesToDo: "++(showQTerm modulesToDo))
debugMessage 3 ("Master loop: modules to do: "++(showQTerm modulesToDo))
let modulesToDo2 = filter ((not . null) . snd) modulesToDo
waitList = map fst (filter (null . snd) modulesToDo)
if null waitList
then do
debugMessage 2 "MasterLoop: waiting for workers to finish"
debugMessage 2 "Master loop: waiting for workers to finish"
inputHandle <- hWaitForInputs busyWorker waitTime
if inputHandle<0
then return (Just "No input from any worker received")
else do
let handle = busyWorker !! inputHandle
input <- hGetLine handle
debugMessage 2 ("got message: "++input)
debugMessage 2 ("Master loop: got message: "++input)
let Task ananame2 moduleName2 = readQTerm input
if ananame==ananame2
then do
......@@ -84,11 +89,11 @@ masterLoop idleWorker busyWorker ananame mainModule
masterLoop (handle:idleWorker) busyWorker ananame mainModule modulesToDo