Commit 03cfac7f authored by Michael Hanus 's avatar Michael Hanus
Browse files

cpm and currypp updated

parent 832a3e98
......@@ -58,7 +58,7 @@ createSymlink from to = system $ "ln -s " ++ (quote from) ++ " " ++ (quote to)
--- Deletes a symlink.
removeSymlink :: String -> IO Int
removeSymlink link = system $ "rm " ++ (quote link)
removeSymlink link = system $ "rm " ++ quote link
--- Tests whether a file is a symlink.
isSymlink :: String -> IO Bool
......
......@@ -45,7 +45,7 @@ cpmBanner :: String
cpmBanner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText =
"Curry Package Manager <curry-language.org/tools/cpm> (version of 24/05/2017)"
"Curry Package Manager <curry-language.org/tools/cpm> (version of 01/06/2017)"
bannerLine = take (length bannerText) (repeat '-')
main :: IO ()
......@@ -87,7 +87,7 @@ runWithArgs opts = do
Compiler o -> compiler o config getRepoGC
Exec o -> exec o config getRepoGC
Doc o -> docCmd o config getRepoGC
Test o -> test o config getRepoGC
Test o -> testCmd o config getRepoGC
Link o -> linkCmd o config
Add o -> addCmd o config
Clean -> cleanPackage Info
......@@ -912,7 +912,7 @@ linkCmd :: LinkOptions -> Config -> IO (ErrorLogger ())
linkCmd (LinkOptions src) _ =
tryFindLocalPackageSpec "." |>= \specDir ->
cleanCurryPathCache specDir |>
log Info ("Linking '" ++ src ++ "' into local package cache") |>
log Info ("Linking '" ++ src ++ "' into local package cache...") |>
linkToLocalCache src specDir
--- `add` command: copy the given package to the repository index
......@@ -1002,9 +1002,9 @@ docCmd opts cfg getRepoGC =
--- `test` command: run `curry check` on the modules provided as an argument
--- or, if they are not provided, on the exported (if specified)
--- or all source modules of the package.
test :: TestOptions -> Config -> IO (Repository,GlobalCache)
-> IO (ErrorLogger ())
test opts cfg getRepoGC =
testCmd :: TestOptions -> Config -> IO (Repository,GlobalCache)
-> IO (ErrorLogger ())
testCmd opts cfg getRepoGC =
tryFindLocalPackageSpec "." |>= \specDir ->
loadPackageSpec specDir |>= \pkg -> do
checkCompiler cfg pkg
......
......@@ -22,8 +22,8 @@ module CPM.PackageCache.Local
) where
import Debug
import Directory (createDirectoryIfMissing, copyFile, getDirectoryContents
, doesDirectoryExist, doesFileExist)
import Directory (createDirectoryIfMissing, copyFile, getAbsolutePath
, getDirectoryContents, doesDirectoryExist, doesFileExist)
import Either (rights)
import FilePath ((</>))
import List (isPrefixOf)
......@@ -34,7 +34,7 @@ import CPM.FileUtil (isSymlink, removeSymlink, createSymlink, linkTarget)
import CPM.Package (Package, packageId, readPackageSpec)
import CPM.PackageCache.Global (installedPackageDir)
--- Get the cache directory of the local package cache.
--- The cache directory of the local package cache.
---
--- @param dir the package directory
cacheDir :: String -> String
......@@ -48,9 +48,11 @@ allPackages pkgDir = do
cacheExists <- doesDirectoryExist cdir
if cacheExists
then do
pkgDirs <- getDirectoryContents cdir
pkgPaths <- return $ map (cdir </>) $ filter (not . isPrefixOf ".") pkgDirs
specPaths <- return $ map (</> "package.json") pkgPaths
debugMessage $ "Reading local package cache from '" ++ cdir ++ "'..."
cdircont <- getDirectoryContents cdir
let pkgDirs = filter (not . isPrefixOf ".") cdircont
pkgPaths <- mapIO removeIfIllegalSymLink $ map (cdir </>) pkgDirs
specPaths <- return $ map (</> "package.json") $ concat pkgPaths
specs <- mapIO (readPackageSpecIO . readFile) specPaths
succeedIO $ rights specs
else succeedIO []
......@@ -58,6 +60,14 @@ allPackages pkgDir = do
readPackageSpecIO = liftIO readPackageSpec
cdir = cacheDir pkgDir
removeIfIllegalSymLink target = do
dirExists <- doesDirectoryExist target
fileExists <- doesFileExist target
isLink <- isSymlink target
if isLink && (dirExists || fileExists)
then return [target]
else when isLink (removeSymlink target >> done) >> return []
--- Creates a link to a package from the global cache in the local cache. Does
--- not overwrite existing links.
---
......@@ -137,16 +147,19 @@ ensureCacheDir pkgDir = do
deleteIfLink :: String -> IO (ErrorLogger ())
deleteIfLink target = do
dirExists <- doesDirectoryExist target
dirExists <- doesDirectoryExist target
fileExists <- doesFileExist target
isLink <- isSymlink target
if dirExists || fileExists
then do
isLink <- isSymlink target
then
if isLink
then removeSymlink target >> succeedIO ()
else failIO $ "deleteIfLink can only delete links!\n" ++
"Unexpected target: " ++ target
else succeedIO ()
else
if isLink -- maybe it is a link to some non-existing target
then removeSymlink target >> succeedIO ()
else succeedIO ()
linkExists :: String -> IO Bool
linkExists target = do
......@@ -176,7 +189,8 @@ createLink pkgDir from name replace = do
if exists && not replace
then succeedIO ()
else deleteIfLink target |> do
rc <- createSymlink from target
fromabs <- getAbsolutePath from
rc <- createSymlink fromabs target
if rc == 0
then succeedIO ()
else failIO $ "Failed to create symlink from '" ++ from ++ "' to '" ++
......
......@@ -148,7 +148,7 @@ installLocalDependencies cfg repo gc dir =
copyDependencies cfg gc pkgSpec (resolvedPackages result) dir |>
succeedIO (pkgSpec, resolvedPackages result)
--- Links a directory into the local package cache. Used for cpm link.
--- Links a directory into the local package cache. Used for `cpm link`.
linkToLocalCache :: String -> String -> IO (ErrorLogger ())
linkToLocalCache src pkgDir = do
dirExists <- doesDirectoryExist src
......
------------------------------------------------------------------------
--- A type is sensible if there exists at least one value of this type.
--- This module contains an analysis which associates to each type
--- constructor the following information:
--- * sensible, i.e., there is always some value of this type
--- * parametric sensible, i.e., it is sensible of all type arguments
--- are instantiated with sensible types
--- * not sensible, i.e., maybe not sensible
------------------------------------------------------------------------
module Analysis.SensibleTypes
( Sensible(..), showSensible, sensibleType )
where
import Analysis.Types
import Analysis.ProgInfo
import FlatCurry.Types
import FlatCurry.Goodies
import Maybe
--- Datatype to represent sensible type information.
data Sensible = NotSensible | PSensible | Sensible
-- Show higher-order information as a string.
showSensible :: AOutFormat -> Sensible -> String
showSensible _ Sensible = "sensible"
showSensible _ PSensible = "parametric sensible"
showSensible _ NotSensible = "not sensible"
lubSens :: Sensible -> Sensible -> Sensible
lubSens Sensible _ = Sensible
lubSens PSensible Sensible = Sensible
lubSens PSensible PSensible = PSensible
lubSens PSensible NotSensible = PSensible
lubSens NotSensible x = x
------------------------------------------------------------------------
-- Analysis of sensible types
sensibleType :: Analysis Sensible
sensibleType = dependencyTypeAnalysis "SensibleType" NotSensible sensOfType
-- predefined sensible data types
predefinedSensibles :: [QName]
predefinedSensibles = [pre "Int", pre "Float", pre "Char", pre "IO"]
where pre tc = ("Prelude",tc)
sensOfType :: TypeDecl -> [(QName,Sensible)] -> Sensible
sensOfType (TypeSyn _ _ _ typeExpr) usedtypes =
sensOfTypeExpr usedtypes typeExpr
sensOfType (Type tc _ _ conDecls) usedtypes
| tc `elem` predefinedSensibles = Sensible
| otherwise = foldr lubSens NotSensible (map sensOfConsDecl conDecls)
where
sensOfConsDecl (Cons _ _ _ typeExprs)
| all (== Sensible) senstargs = Sensible
| all (/= NotSensible) senstargs = PSensible
| otherwise = NotSensible
where senstargs = map (sensOfTypeExpr usedtypes) typeExprs
-- Compute the sensibility of a type expression which depends on the
-- information about type cosntructors.
sensOfTypeExpr :: [(QName,Sensible)] -> TypeExpr -> Sensible
sensOfTypeExpr _ (TVar _) = PSensible
sensOfTypeExpr _ (FuncType _ _) = NotSensible -- we do not know which functions
-- of some type exists...
sensOfTypeExpr usedtypes (TCons tc typeExprs)
| senstc == Sensible || (senstc == PSensible && all (==Sensible) senstargs)
= Sensible
| senstc == PSensible && all (/=NotSensible) senstargs
= PSensible
| otherwise
= NotSensible
where
senstc = maybe NotSensible id (lookup tc usedtypes)
senstargs = map (sensOfTypeExpr usedtypes) typeExprs
-----------------------------------------------------------------------
Sensible types analysis
-----------------------
The `SensibleType` analysis is a type analysis which checks
whether a type is sensible, i.e., whether there exists at least
one value of this type. This analysis associates to each type
constructor the following information:
* sensible, i.e., there is exists some value of this type
* parametric sensible, i.e., it is parametric type which is sensible
if all type arguments are instantiated with sensible types
* not sensible, i.e., there may be no values of this type
For instance, the list type constructor "[]" is sensible
and the pair type constructor "(,)" is parametric sensible.
For further examples, consider the following type declarations:
type Pair = (Int,Int)
data RTree a = RTree a [RTree a]
data ITree a = ITree a (ITree a)
type IntRTree = RTree Int
type IntITree = ITree Int
type ITreeRTree = RTree (ITree Int)
Then this analysis computes the following information:
Pair : sensible
RTree : parametric sensible
ITree : not sensible
IntRTree : sensible
IntITree : not sensible
ITreeRTree : not sensible
Note that function types are classified as not sensible since it is
not known whether some operation of this type exists.
......@@ -2,7 +2,7 @@
--- A few base functions for analysing type dependencies in FlatCurry programs.
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version April 2013
--- @version Junes 2017
-----------------------------------------------------------------------------
module CASS.FlatCurryDependency(dependsDirectlyOnTypes,callsDirectly) where
......@@ -24,7 +24,7 @@ dependsDirectlyOnTypes (TypeSyn _ _ _ typeExpr) = nub (tconsOf typeExpr)
tconsOf :: TypeExpr -> [(String,String)]
tconsOf (TVar _) = []
tconsOf (FuncType a b) = tconsOf a ++ tconsOf b
tconsOf (TCons qName _) = [qName]
tconsOf (TCons qName texps) = qName : concatMap tconsOf texps
-----------------------------------------------------------------------------
......
......@@ -41,6 +41,7 @@ import Analysis.RequiredValue
import qualified Analysis.RequiredValues as RVS
import Analysis.RightLinearity
import Analysis.RootReplaced
import Analysis.SensibleTypes
import Analysis.SolutionCompleteness
import Analysis.Termination
import Analysis.TotallyDefined
......@@ -70,6 +71,7 @@ registeredAnalysis =
,cassAnalysis "Higher-order constructors" hiOrdCons showOrder
,cassAnalysis "Higher-order functions" hiOrdFunc showOrder
,cassAnalysis "Productive operations" productivityAnalysis showProductivity
,cassAnalysis "Sensible types" sensibleType showSensible
,cassAnalysis "Sibling constructors" siblingCons showSibling
,cassAnalysis "Required value" reqValueAnalysis showAFType
,cassAnalysis "Required value sets" RVS.reqValueAnalysis RVS.showAFType
......
......@@ -25,7 +25,7 @@ import AbstractCurry.Pretty (showCProg)
import AbstractCurry.Transform (renameCurryModule,updCProg,updQNamesInCProg)
import AnsiCodes
import Distribution
import FilePath ((</>), takeDirectory)
import FilePath ((</>), pathSeparator, takeDirectory)
import qualified FlatCurry.Types as FC
import FlatCurry.Files
import qualified FlatCurry.Goodies as FCG
......@@ -34,7 +34,7 @@ import IO
import List
import Maybe (fromJust, isJust)
import ReadNumeric (readNat)
import System (system, exitWith, getArgs, getPID)
import System (system, exitWith, getArgs, getPID, getEnviron)
import CheckDetUsage (checkDetUse, containsDetOperations)
import ContractUsage
......@@ -54,7 +54,7 @@ ccBanner :: String
ccBanner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "CurryCheck: a tool for testing Curry programs (Version " ++
packageVersion ++ " of 06/02/2017)"
packageVersion ++ " of 01/06/2017)"
bannerLine = take (length bannerText) (repeat '-')
-- Help text
......@@ -172,6 +172,10 @@ putStrIfNormal opts s = unless (isQuiet opts) (putStr s >> hFlush stdout)
putStrIfVerbose :: Options -> String -> IO ()
putStrIfVerbose opts s = when (optVerb opts > 1) (putStr s >> hFlush stdout)
--- Print second argument if verbosity level > 3:
putStrLnIfDebug :: Options -> String -> IO ()
putStrLnIfDebug opts s = when (optVerb opts > 3) (putStrLn s >> hFlush stdout)
--- use some coloring (from library AnsiCodes) if color option is on:
withColor :: Options -> (String -> String) -> String -> String
withColor opts coloring = if optColor opts then coloring else id
......@@ -676,7 +680,7 @@ analyseCurryProg opts modname orgprog = do
return .
maybe (error $ "Source file of module '"++modname++"' not found!") id
let srcdir = takeDirectory srcfilename
when (optVerb opts > 3) $ putStrLn ("Source file: " ++ srcfilename)
putStrLnIfDebug opts $ "Source file: " ++ srcfilename
prooffiles <- if optProof opts then getProofFiles srcdir else return []
unless (null prooffiles) $ putStrIfVerbose opts $
unlines ("Proof files found:" : map ("- " ++) prooffiles)
......@@ -879,7 +883,7 @@ cleanup opts mainmodname modules =
maybe done
(\ (_,srcfilename) -> do
system $ installDir </> "bin" </> "cleancurry" ++ " " ++ modname
system $ "rm -f " ++ srcfilename
system $ "/bin/rm -f " ++ srcfilename
done )
-- Show some statistics about number of tests:
......@@ -906,7 +910,9 @@ main = do
(putStr (unlines opterrors) >> putStrLn usageText >> exitWith 1)
putStrIfNormal opts ccBanner
when (null args || optHelp opts) (putStrLn usageText >> exitWith 1)
testModules <- mapIO (analyseModule opts) (map stripCurrySuffix args)
let mods = map stripCurrySuffix args
mapIO_ checkModuleName mods
testModules <- mapIO (analyseModule opts) mods
let staticerrs = concatMap staticErrors (concat testModules)
finaltestmodules = filter testThisModule (concat testModules)
testmodname = if null (optMainProg opts)
......@@ -922,12 +928,17 @@ main = do
"Generating main test module '"++testmodname++"'..."
genMainTestModule opts testmodname finaltestmodules
putStrIfNormal opts $ withColor opts blue $ "and compiling it...\n"
ret <- system $ unwords $ [installDir </> "bin" </> "curry"
,"--noreadline"
,":set -time"
,":set v0"
,":set parser -Wnone"
,":l "++testmodname,":eval main :q"]
currypath <- getEnviron "CURRYPATH"
let runcmd = unwords $
[ installDir </> "bin" </> "curry"
, "--noreadline"
, ":set -time"
, ":set " ++ if optVerb opts > 3 then "v1" else "v0"
, ":set parser -Wnone"
, if null currypath then "" else ":set path " ++ currypath
, ":l "++testmodname,":eval main :q" ]
putStrLnIfDebug opts $ "Executing command:\n" ++ runcmd
ret <- system runcmd
cleanup opts testmodname finaltestmodules
unless (isQuiet opts || ret /= 0) $
putStrLn $ withColor opts green $ showTestStatistics finaltestmodules
......@@ -935,6 +946,12 @@ main = do
where
showStaticErrors opts errs = putStrLn $ withColor opts red $
unlines (line : "STATIC ERRORS IN PROGRAMS:" : errs) ++ line
checkModuleName mn =
when (pathSeparator `elem` mn) $ do
putStrLn $ "Module names with path prefixes not allowed: " ++ mn
exitWith 1
line = take 78 (repeat '=')
-------------------------------------------------------------------------
......@@ -983,7 +1000,7 @@ generatorModule = "SearchTreeGenerators"
writeCurryProgram :: Options -> String -> CurryProg -> String -> IO ()
writeCurryProgram opts srcdir p appendix = do
let progfile = srcdir </> modNameToPath (progName p) ++ ".curry"
when (optVerb opts > 3) $ putStrLn ("Writing program: " ++ progfile)
putStrLnIfDebug opts $ "Writing program: " ++ progfile
writeFile progfile
(showCProg p ++ "\n" ++ appendix ++ "\n")
......
------------------------------------------------------------------------
--- A type is sensible if there exists at least one value of this type.
--- This module contains an analysis which associates to each type
--- constructor the following information:
--- * sensible, i.e., there is always some value of this type
--- * parametric sensible, i.e., it is sensible of all type arguments
--- are instantiated with sensible types
--- * not sensible, i.e., maybe not sensible
------------------------------------------------------------------------
module Analysis.SensibleTypes
( Sensible(..), showSensible, sensibleType )
where
import Analysis.Types
import Analysis.ProgInfo
import FlatCurry.Types
import FlatCurry.Goodies
import Maybe
--- Datatype to represent sensible type information.
data Sensible = NotSensible | PSensible | Sensible
-- Show higher-order information as a string.
showSensible :: AOutFormat -> Sensible -> String
showSensible _ Sensible = "sensible"
showSensible _ PSensible = "parametric sensible"
showSensible _ NotSensible = "not sensible"
lubSens :: Sensible -> Sensible -> Sensible
lubSens Sensible _ = Sensible
lubSens PSensible Sensible = Sensible
lubSens PSensible PSensible = PSensible
lubSens PSensible NotSensible = PSensible
lubSens NotSensible x = x
------------------------------------------------------------------------
-- Analysis of sensible types
sensibleType :: Analysis Sensible
sensibleType = dependencyTypeAnalysis "SensibleType" NotSensible sensOfType
-- predefined sensible data types
predefinedSensibles :: [QName]
predefinedSensibles = [pre "Int", pre "Float", pre "Char", pre "IO"]
where pre tc = ("Prelude",tc)
sensOfType :: TypeDecl -> [(QName,Sensible)] -> Sensible
sensOfType (TypeSyn _ _ _ typeExpr) usedtypes =
sensOfTypeExpr usedtypes typeExpr
sensOfType (Type tc _ _ conDecls) usedtypes
| tc `elem` predefinedSensibles = Sensible
| otherwise = foldr lubSens NotSensible (map sensOfConsDecl conDecls)
where
sensOfConsDecl (Cons _ _ _ typeExprs)
| all (== Sensible) senstargs = Sensible
| all (/= NotSensible) senstargs = PSensible
| otherwise = NotSensible
where senstargs = map (sensOfTypeExpr usedtypes) typeExprs
-- Compute the sensibility of a type expression which depends on the
-- information about type cosntructors.
sensOfTypeExpr :: [(QName,Sensible)] -> TypeExpr -> Sensible
sensOfTypeExpr _ (TVar _) = PSensible
sensOfTypeExpr _ (FuncType _ _) = NotSensible -- we do not know which functions
-- of some type exists...
sensOfTypeExpr usedtypes (TCons tc typeExprs)
| senstc == Sensible || (senstc == PSensible && all (==Sensible) senstargs)
= Sensible
| senstc == PSensible && all (/=NotSensible) senstargs
= PSensible
| otherwise
= NotSensible
where
senstc = maybe NotSensible id (lookup tc usedtypes)
senstargs = map (sensOfTypeExpr usedtypes) typeExprs
-----------------------------------------------------------------------
Sensible types analysis
-----------------------
The `SensibleType` analysis is a type analysis which checks
whether a type is sensible, i.e., whether there exists at least
one value of this type. This analysis associates to each type
constructor the following information:
* sensible, i.e., there is exists some value of this type
* parametric sensible, i.e., it is parametric type which is sensible
if all type arguments are instantiated with sensible types
* not sensible, i.e., there may be no values of this type
For instance, the list type constructor "[]" is sensible
and the pair type constructor "(,)" is parametric sensible.
For further examples, consider the following type declarations:
type Pair = (Int,Int)
data RTree a = RTree a [RTree a]
data ITree a = ITree a (ITree a)
type IntRTree = RTree Int
type IntITree = ITree Int
type ITreeRTree = RTree (ITree Int)
Then this analysis computes the following information:
Pair : sensible
RTree : parametric sensible
ITree : not sensible
IntRTree : sensible
IntITree : not sensible
ITreeRTree : not sensible
Note that function types are classified as not sensible since it is
not known whether some operation of this type exists.
......@@ -2,7 +2,7 @@
--- A few base functions for analysing type dependencies in FlatCurry programs.
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version April 2013
--- @version Junes 2017
-----------------------------------------------------------------------------
module CASS.FlatCurryDependency(dependsDirectlyOnTypes,callsDirectly) where
......@@ -24,7 +24,7 @@ dependsDirectlyOnTypes (TypeSyn _ _ _ typeExpr) = nub (tconsOf typeExpr)
tconsOf :: TypeExpr -> [(String,String)]
tconsOf (TVar _) = []
tconsOf (FuncType a b) = tconsOf a ++ tconsOf b
tconsOf (TCons qName _) = [qName]
tconsOf (TCons qName texps) = qName : concatMap tconsOf texps
-----------------------------------------------------------------------------
......
......@@ -41,6 +41,7 @@ import Analysis.RequiredValue
import qualified Analysis.RequiredValues as RVS
import Analysis.RightLinearity
import Analysis.RootReplaced
import Analysis.SensibleTypes
import Analysis.SolutionCompleteness
import Analysis.Termination
import Analysis.TotallyDefined
......@@ -70,6 +71,7 @@ registeredAnalysis =
,cassAnalysis "Higher-order constructors" hiOrdCons showOrder
,cassAnalysis "Higher-order functions" hiOrdFunc showOrder
,cassAnalysis "Productive operations" productivityAnalysis showProductivity
,cassAnalysis "Sensible types" sensibleType showSensible
,cassAnalysis "Sibling constructors" siblingCons showSibling
,cassAnalysis "Required value" reqValueAnalysis showAFType
,cassAnalysis "Required value sets" RVS.reqValueAnalysis RVS.showAFType
......
......@@ -25,7 +25,7 @@ import AbstractCurry.Pretty (showCProg)
import AbstractCurry.Transform (renameCurryModule,updCProg,updQNamesInCProg)
import AnsiCodes
import Distribution
import FilePath ((</>), takeDirectory)
import FilePath ((</>), pathSeparator, takeDirectory)
import qualified FlatCurry.Types as FC
import FlatCurry.Files
import qualified FlatCurry.Goodies as FCG
......@@ -34,7 +34,7 @@ import IO
import List
import Maybe (fromJust, isJust)
import ReadNumeric (readNat)
import System (system, exitWith, getArgs, getPID)
import System (system, exitWith, getArgs, getPID, getEnviron)
import CheckDetUsage (checkDetUse, containsDetOperations)
import ContractUsage
......@@ -54,7 +54,7 @@ ccBanner :: String
ccBanner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "CurryCheck: a tool for testing Curry programs (Version " ++
packageVersion ++ " of 06/02/2017)"
packageVersion ++ " of 01/06/2017)"
bannerLine = take (length bannerText) (repeat '-')
-- Help text
......@@ -172,6 +172,10 @@ putStrIfNormal opts s = unless (isQuiet opts) (putStr s >> hFlush stdout)
putStrIfVerbose :: Options -> String -> IO ()
putStrIfVerbose opts s = when (optVerb opts > 1) (putStr s >> hFlush stdout)
--- Print second argument if verbosity level > 3:
putStrLnIfDebug :: Options -> String -> IO ()
putStrLnIfDebug opts s = when (optVerb opts > 3) (putStrLn s >> hFlush stdout)
--- use some coloring (from library AnsiCodes) if color option is on:
withColor :: Options -> (String -> String) -> String -> String
withColor opts coloring = if optColor opts then coloring else id
......@@ -676,7 +680,7 @@ analyseCurryProg opts modname orgprog = do
return .
maybe (error $ "Source file of module '"++modname++"' not found!") id
let srcdir = takeDirectory srcfilename
when (optVerb opts > 3) $ putStrLn ("Source file: " ++ srcfilename)
putStrLnIfDebug opts $ "Source file: " ++ srcfilename
prooffiles <- if optProof opts then getProofFiles srcdir else return []
unless (null prooffiles) $ putStrIfVerbose opts $
unlines ("Proof files found:" : map ("- " ++) prooffiles)
......@@ -879,7 +883,7 @@ cleanup opts mainmodname modules =
maybe done
(\ (_,srcfilename) -> do
system $ installDir </> "bin" </> "cleancurry" ++ " " ++ modname
system $ "rm -f " ++ srcfilename
system $ "/bin/rm -f " ++ srcfilename
done )
-- Show some statistics about number of tests:
......@@ -906,7 +910,9 @@ main = do
(putStr (unlines opterrors) >> putStrLn usageText >> exitWith 1)
putStrIfNormal opts ccBanner
when (null args || optHelp opts) (putStrLn usageText >> exitWith 1)
testModules <- mapIO (analyseModule opts) (map stripCurrySuffix args)
let mods = map stripCurrySuffix args
mapIO_ checkModuleName mods
testModules <- mapIO (analyseModule opts) mods
let staticerrs = concatMap staticErrors (concat testModules)
finaltestmodules = filter testThisModule (concat testModules)
testmodname = if null (optMainProg opts)
......@@ -922,12 +928,17 @@ main = do
"Generating main test module '"++testmodname++"'..."
genMainTestModule opts testmodname finaltestmodules
putStrIfNormal opts $ withColor opts blue $ "and compiling it...\n"
ret <- system $ unwords $ [installDir </> "bin" </> "curry"
,"--noreadline"
,":set -time"
,":set v0"
,":set parser -Wnone"
,":l "++testmodname,":eval main :q"]
currypath <- getEnviron "CURRYPATH"
let runcmd = unwords $
[ installDir </> "bin" </> "curry"
, "--noreadline"