Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry
curry-tools
Commits
03cfac7f
Commit
03cfac7f
authored
Jun 02, 2017
by
Michael Hanus
Browse files
cpm and currypp updated
parent
832a3e98
Changes
19
Hide whitespace changes
Inline
Side-by-side
cpm/src/CPM/FileUtil.curry
View file @
03cfac7f
...
@@ -58,7 +58,7 @@ createSymlink from to = system $ "ln -s " ++ (quote from) ++ " " ++ (quote to)
...
@@ -58,7 +58,7 @@ createSymlink from to = system $ "ln -s " ++ (quote from) ++ " " ++ (quote to)
--- Deletes a symlink.
--- Deletes a symlink.
removeSymlink :: String -> IO Int
removeSymlink :: String -> IO Int
removeSymlink link = system $ "rm " ++
(
quote link
)
removeSymlink link = system $ "rm " ++ quote link
--- Tests whether a file is a symlink.
--- Tests whether a file is a symlink.
isSymlink :: String -> IO Bool
isSymlink :: String -> IO Bool
...
...
cpm/src/CPM/Main.curry
View file @
03cfac7f
...
@@ -45,7 +45,7 @@ cpmBanner :: String
...
@@ -45,7 +45,7 @@ cpmBanner :: String
cpmBanner = unlines [bannerLine,bannerText,bannerLine]
cpmBanner = unlines [bannerLine,bannerText,bannerLine]
where
where
bannerText =
bannerText =
"Curry Package Manager <curry-language.org/tools/cpm> (version of
24
/0
5
/2017)"
"Curry Package Manager <curry-language.org/tools/cpm> (version of
01
/0
6
/2017)"
bannerLine = take (length bannerText) (repeat '-')
bannerLine = take (length bannerText) (repeat '-')
main :: IO ()
main :: IO ()
...
@@ -87,7 +87,7 @@ runWithArgs opts = do
...
@@ -87,7 +87,7 @@ runWithArgs opts = do
Compiler o -> compiler o config getRepoGC
Compiler o -> compiler o config getRepoGC
Exec o -> exec o config getRepoGC
Exec o -> exec o config getRepoGC
Doc o -> docCmd o config getRepoGC
Doc o -> docCmd o config getRepoGC
Test o -> test
o config getRepoGC
Test o -> test
Cmd
o config getRepoGC
Link o -> linkCmd o config
Link o -> linkCmd o config
Add o -> addCmd o config
Add o -> addCmd o config
Clean -> cleanPackage Info
Clean -> cleanPackage Info
...
@@ -912,7 +912,7 @@ linkCmd :: LinkOptions -> Config -> IO (ErrorLogger ())
...
@@ -912,7 +912,7 @@ linkCmd :: LinkOptions -> Config -> IO (ErrorLogger ())
linkCmd (LinkOptions src) _ =
linkCmd (LinkOptions src) _ =
tryFindLocalPackageSpec "." |>= \specDir ->
tryFindLocalPackageSpec "." |>= \specDir ->
cleanCurryPathCache specDir |>
cleanCurryPathCache specDir |>
log Info ("Linking '" ++ src ++ "' into local package cache") |>
log Info ("Linking '" ++ src ++ "' into local package cache
...
") |>
linkToLocalCache src specDir
linkToLocalCache src specDir
--- `add` command: copy the given package to the repository index
--- `add` command: copy the given package to the repository index
...
@@ -1002,9 +1002,9 @@ docCmd opts cfg getRepoGC =
...
@@ -1002,9 +1002,9 @@ docCmd opts cfg getRepoGC =
--- `test` command: run `curry check` on the modules provided as an argument
--- `test` command: run `curry check` on the modules provided as an argument
--- or, if they are not provided, on the exported (if specified)
--- or, if they are not provided, on the exported (if specified)
--- or all source modules of the package.
--- or all source modules of the package.
test :: TestOptions -> Config -> IO (Repository,GlobalCache)
test
Cmd
:: TestOptions -> Config -> IO (Repository,GlobalCache)
-> IO (ErrorLogger ())
-> IO (ErrorLogger ())
test opts cfg getRepoGC =
test
Cmd
opts cfg getRepoGC =
tryFindLocalPackageSpec "." |>= \specDir ->
tryFindLocalPackageSpec "." |>= \specDir ->
loadPackageSpec specDir |>= \pkg -> do
loadPackageSpec specDir |>= \pkg -> do
checkCompiler cfg pkg
checkCompiler cfg pkg
...
...
cpm/src/CPM/PackageCache/Local.curry
View file @
03cfac7f
...
@@ -22,8 +22,8 @@ module CPM.PackageCache.Local
...
@@ -22,8 +22,8 @@ module CPM.PackageCache.Local
) where
) where
import Debug
import Debug
import Directory (createDirectoryIfMissing, copyFile, get
DirectoryContents
import Directory (createDirectoryIfMissing, copyFile, get
AbsolutePath
, doesDirectoryExist, doesFileExist)
,
getDirectoryContents,
doesDirectoryExist, doesFileExist)
import Either (rights)
import Either (rights)
import FilePath ((</>))
import FilePath ((</>))
import List (isPrefixOf)
import List (isPrefixOf)
...
@@ -34,7 +34,7 @@ import CPM.FileUtil (isSymlink, removeSymlink, createSymlink, linkTarget)
...
@@ -34,7 +34,7 @@ import CPM.FileUtil (isSymlink, removeSymlink, createSymlink, linkTarget)
import CPM.Package (Package, packageId, readPackageSpec)
import CPM.Package (Package, packageId, readPackageSpec)
import CPM.PackageCache.Global (installedPackageDir)
import CPM.PackageCache.Global (installedPackageDir)
---
Get t
he cache directory of the local package cache.
---
T
he cache directory of the local package cache.
---
---
--- @param dir the package directory
--- @param dir the package directory
cacheDir :: String -> String
cacheDir :: String -> String
...
@@ -48,9 +48,11 @@ allPackages pkgDir = do
...
@@ -48,9 +48,11 @@ allPackages pkgDir = do
cacheExists <- doesDirectoryExist cdir
cacheExists <- doesDirectoryExist cdir
if cacheExists
if cacheExists
then do
then do
pkgDirs <- getDirectoryContents cdir
debugMessage $ "Reading local package cache from '" ++ cdir ++ "'..."
pkgPaths <- return $ map (cdir </>) $ filter (not . isPrefixOf ".") pkgDirs
cdircont <- getDirectoryContents cdir
specPaths <- return $ map (</> "package.json") pkgPaths
let pkgDirs = filter (not . isPrefixOf ".") cdircont
pkgPaths <- mapIO removeIfIllegalSymLink $ map (cdir </>) pkgDirs
specPaths <- return $ map (</> "package.json") $ concat pkgPaths
specs <- mapIO (readPackageSpecIO . readFile) specPaths
specs <- mapIO (readPackageSpecIO . readFile) specPaths
succeedIO $ rights specs
succeedIO $ rights specs
else succeedIO []
else succeedIO []
...
@@ -58,6 +60,14 @@ allPackages pkgDir = do
...
@@ -58,6 +60,14 @@ allPackages pkgDir = do
readPackageSpecIO = liftIO readPackageSpec
readPackageSpecIO = liftIO readPackageSpec
cdir = cacheDir pkgDir
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
--- Creates a link to a package from the global cache in the local cache. Does
--- not overwrite existing links.
--- not overwrite existing links.
---
---
...
@@ -137,16 +147,19 @@ ensureCacheDir pkgDir = do
...
@@ -137,16 +147,19 @@ ensureCacheDir pkgDir = do
deleteIfLink :: String -> IO (ErrorLogger ())
deleteIfLink :: String -> IO (ErrorLogger ())
deleteIfLink target = do
deleteIfLink target = do
dirExists <- doesDirectoryExist target
dirExists
<- doesDirectoryExist target
fileExists <- doesFileExist target
fileExists <- doesFileExist target
isLink <- isSymlink target
if dirExists || fileExists
if dirExists || fileExists
then do
then
isLink <- isSymlink target
if isLink
if isLink
then removeSymlink target >> succeedIO ()
then removeSymlink target >> succeedIO ()
else failIO $ "deleteIfLink can only delete links!\n" ++
else failIO $ "deleteIfLink can only delete links!\n" ++
"Unexpected target: " ++ target
"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 :: String -> IO Bool
linkExists target = do
linkExists target = do
...
@@ -176,7 +189,8 @@ createLink pkgDir from name replace = do
...
@@ -176,7 +189,8 @@ createLink pkgDir from name replace = do
if exists && not replace
if exists && not replace
then succeedIO ()
then succeedIO ()
else deleteIfLink target |> do
else deleteIfLink target |> do
rc <- createSymlink from target
fromabs <- getAbsolutePath from
rc <- createSymlink fromabs target
if rc == 0
if rc == 0
then succeedIO ()
then succeedIO ()
else failIO $ "Failed to create symlink from '" ++ from ++ "' to '" ++
else failIO $ "Failed to create symlink from '" ++ from ++ "' to '" ++
...
...
cpm/src/CPM/PackageCopy.curry
View file @
03cfac7f
...
@@ -148,7 +148,7 @@ installLocalDependencies cfg repo gc dir =
...
@@ -148,7 +148,7 @@ installLocalDependencies cfg repo gc dir =
copyDependencies cfg gc pkgSpec (resolvedPackages result) dir |>
copyDependencies cfg gc pkgSpec (resolvedPackages result) dir |>
succeedIO (pkgSpec, resolvedPackages result)
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 :: String -> String -> IO (ErrorLogger ())
linkToLocalCache src pkgDir = do
linkToLocalCache src pkgDir = do
dirExists <- doesDirectoryExist src
dirExists <- doesDirectoryExist src
...
...
cpm/vendor/cass-analysis/src/Analysis/SensibleTypes.curry
0 → 100644
View file @
03cfac7f
------------------------------------------------------------------------
--- 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
-----------------------------------------------------------------------
cpm/vendor/cass/docs/SensibleType.md
0 → 100644
View file @
03cfac7f
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.
cpm/vendor/cass/src/CASS/FlatCurryDependency.curry
View file @
03cfac7f
...
@@ -2,7 +2,7 @@
...
@@ -2,7 +2,7 @@
--- A few base functions for analysing type dependencies in FlatCurry programs.
--- A few base functions for analysing type dependencies in FlatCurry programs.
---
---
--- @author Heiko Hoffmann, Michael Hanus
--- @author Heiko Hoffmann, Michael Hanus
--- @version
April
201
3
--- @version
Junes
201
7
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
module CASS.FlatCurryDependency(dependsDirectlyOnTypes,callsDirectly) where
module CASS.FlatCurryDependency(dependsDirectlyOnTypes,callsDirectly) where
...
@@ -24,7 +24,7 @@ dependsDirectlyOnTypes (TypeSyn _ _ _ typeExpr) = nub (tconsOf typeExpr)
...
@@ -24,7 +24,7 @@ dependsDirectlyOnTypes (TypeSyn _ _ _ typeExpr) = nub (tconsOf typeExpr)
tconsOf :: TypeExpr -> [(String,String)]
tconsOf :: TypeExpr -> [(String,String)]
tconsOf (TVar _) = []
tconsOf (TVar _) = []
tconsOf (FuncType a b) = tconsOf a ++ tconsOf b
tconsOf (FuncType a b) = tconsOf a ++ tconsOf b
tconsOf (TCons qName
_
) =
[
qName
]
tconsOf (TCons qName
texps
) = qName
: concatMap tconsOf texps
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
...
...
cpm/vendor/cass/src/CASS/Registry.curry
View file @
03cfac7f
...
@@ -41,6 +41,7 @@ import Analysis.RequiredValue
...
@@ -41,6 +41,7 @@ import Analysis.RequiredValue
import qualified Analysis.RequiredValues as RVS
import qualified Analysis.RequiredValues as RVS
import Analysis.RightLinearity
import Analysis.RightLinearity
import Analysis.RootReplaced
import Analysis.RootReplaced
import Analysis.SensibleTypes
import Analysis.SolutionCompleteness
import Analysis.SolutionCompleteness
import Analysis.Termination
import Analysis.Termination
import Analysis.TotallyDefined
import Analysis.TotallyDefined
...
@@ -70,6 +71,7 @@ registeredAnalysis =
...
@@ -70,6 +71,7 @@ registeredAnalysis =
,cassAnalysis "Higher-order constructors" hiOrdCons showOrder
,cassAnalysis "Higher-order constructors" hiOrdCons showOrder
,cassAnalysis "Higher-order functions" hiOrdFunc showOrder
,cassAnalysis "Higher-order functions" hiOrdFunc showOrder
,cassAnalysis "Productive operations" productivityAnalysis showProductivity
,cassAnalysis "Productive operations" productivityAnalysis showProductivity
,cassAnalysis "Sensible types" sensibleType showSensible
,cassAnalysis "Sibling constructors" siblingCons showSibling
,cassAnalysis "Sibling constructors" siblingCons showSibling
,cassAnalysis "Required value" reqValueAnalysis showAFType
,cassAnalysis "Required value" reqValueAnalysis showAFType
,cassAnalysis "Required value sets" RVS.reqValueAnalysis RVS.showAFType
,cassAnalysis "Required value sets" RVS.reqValueAnalysis RVS.showAFType
...
...
currycheck/src/CurryCheck.curry
View file @
03cfac7f
...
@@ -25,7 +25,7 @@ import AbstractCurry.Pretty (showCProg)
...
@@ -25,7 +25,7 @@ import AbstractCurry.Pretty (showCProg)
import AbstractCurry.Transform (renameCurryModule,updCProg,updQNamesInCProg)
import AbstractCurry.Transform (renameCurryModule,updCProg,updQNamesInCProg)
import AnsiCodes
import AnsiCodes
import Distribution
import Distribution
import FilePath ((</>), takeDirectory)
import FilePath ((</>),
pathSeparator,
takeDirectory)
import qualified FlatCurry.Types as FC
import qualified FlatCurry.Types as FC
import FlatCurry.Files
import FlatCurry.Files
import qualified FlatCurry.Goodies as FCG
import qualified FlatCurry.Goodies as FCG
...
@@ -34,7 +34,7 @@ import IO
...
@@ -34,7 +34,7 @@ import IO
import List
import List
import Maybe (fromJust, isJust)
import Maybe (fromJust, isJust)
import ReadNumeric (readNat)
import ReadNumeric (readNat)
import System (system, exitWith, getArgs, getPID)
import System (system, exitWith, getArgs, getPID
, getEnviron
)
import CheckDetUsage (checkDetUse, containsDetOperations)
import CheckDetUsage (checkDetUse, containsDetOperations)
import ContractUsage
import ContractUsage
...
@@ -54,7 +54,7 @@ ccBanner :: String
...
@@ -54,7 +54,7 @@ ccBanner :: String
ccBanner = unlines [bannerLine,bannerText,bannerLine]
ccBanner = unlines [bannerLine,bannerText,bannerLine]
where
where
bannerText = "CurryCheck: a tool for testing Curry programs (Version " ++
bannerText = "CurryCheck: a tool for testing Curry programs (Version " ++
packageVersion ++ " of 0
6
/0
2
/2017)"
packageVersion ++ " of 0
1
/0
6
/2017)"
bannerLine = take (length bannerText) (repeat '-')
bannerLine = take (length bannerText) (repeat '-')
-- Help text
-- Help text
...
@@ -172,6 +172,10 @@ putStrIfNormal opts s = unless (isQuiet opts) (putStr s >> hFlush stdout)
...
@@ -172,6 +172,10 @@ putStrIfNormal opts s = unless (isQuiet opts) (putStr s >> hFlush stdout)
putStrIfVerbose :: Options -> String -> IO ()
putStrIfVerbose :: Options -> String -> IO ()
putStrIfVerbose opts s = when (optVerb opts > 1) (putStr s >> hFlush stdout)
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:
--- use some coloring (from library AnsiCodes) if color option is on:
withColor :: Options -> (String -> String) -> String -> String
withColor :: Options -> (String -> String) -> String -> String
withColor opts coloring = if optColor opts then coloring else id
withColor opts coloring = if optColor opts then coloring else id
...
@@ -676,7 +680,7 @@ analyseCurryProg opts modname orgprog = do
...
@@ -676,7 +680,7 @@ analyseCurryProg opts modname orgprog = do
return .
return .
maybe (error $ "Source file of module '"++modname++"' not found!") id
maybe (error $ "Source file of module '"++modname++"' not found!") id
let srcdir = takeDirectory srcfilename
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 []
prooffiles <- if optProof opts then getProofFiles srcdir else return []
unless (null prooffiles) $ putStrIfVerbose opts $
unless (null prooffiles) $ putStrIfVerbose opts $
unlines ("Proof files found:" : map ("- " ++) prooffiles)
unlines ("Proof files found:" : map ("- " ++) prooffiles)
...
@@ -879,7 +883,7 @@ cleanup opts mainmodname modules =
...
@@ -879,7 +883,7 @@ cleanup opts mainmodname modules =
maybe done
maybe done
(\ (_,srcfilename) -> do
(\ (_,srcfilename) -> do
system $ installDir </> "bin" </> "cleancurry" ++ " " ++ modname
system $ installDir </> "bin" </> "cleancurry" ++ " " ++ modname
system $ "rm -f " ++ srcfilename
system $ "
/bin/
rm -f " ++ srcfilename
done )
done )
-- Show some statistics about number of tests:
-- Show some statistics about number of tests:
...
@@ -906,7 +910,9 @@ main = do
...
@@ -906,7 +910,9 @@ main = do
(putStr (unlines opterrors) >> putStrLn usageText >> exitWith 1)
(putStr (unlines opterrors) >> putStrLn usageText >> exitWith 1)
putStrIfNormal opts ccBanner
putStrIfNormal opts ccBanner
when (null args || optHelp opts) (putStrLn usageText >> exitWith 1)
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)
let staticerrs = concatMap staticErrors (concat testModules)
finaltestmodules = filter testThisModule (concat testModules)
finaltestmodules = filter testThisModule (concat testModules)
testmodname = if null (optMainProg opts)
testmodname = if null (optMainProg opts)
...
@@ -922,12 +928,17 @@ main = do
...
@@ -922,12 +928,17 @@ main = do
"Generating main test module '"++testmodname++"'..."
"Generating main test module '"++testmodname++"'..."
genMainTestModule opts testmodname finaltestmodules
genMainTestModule opts testmodname finaltestmodules
putStrIfNormal opts $ withColor opts blue $ "and compiling it...\n"
putStrIfNormal opts $ withColor opts blue $ "and compiling it...\n"
ret <- system $ unwords $ [installDir </> "bin" </> "curry"
currypath <- getEnviron "CURRYPATH"
,"--noreadline"
let runcmd = unwords $
,":set -time"
[ installDir </> "bin" </> "curry"
,":set v0"
, "--noreadline"
,":set parser -Wnone"
, ":set -time"
,":l "++testmodname,":eval main :q"]
, ":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
cleanup opts testmodname finaltestmodules
unless (isQuiet opts || ret /= 0) $
unless (isQuiet opts || ret /= 0) $
putStrLn $ withColor opts green $ showTestStatistics finaltestmodules
putStrLn $ withColor opts green $ showTestStatistics finaltestmodules
...
@@ -935,6 +946,12 @@ main = do
...
@@ -935,6 +946,12 @@ main = do
where
where
showStaticErrors opts errs = putStrLn $ withColor opts red $
showStaticErrors opts errs = putStrLn $ withColor opts red $
unlines (line : "STATIC ERRORS IN PROGRAMS:" : errs) ++ line
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 '=')
line = take 78 (repeat '=')
-------------------------------------------------------------------------
-------------------------------------------------------------------------
...
@@ -983,7 +1000,7 @@ generatorModule = "SearchTreeGenerators"
...
@@ -983,7 +1000,7 @@ generatorModule = "SearchTreeGenerators"
writeCurryProgram :: Options -> String -> CurryProg -> String -> IO ()
writeCurryProgram :: Options -> String -> CurryProg -> String -> IO ()
writeCurryProgram opts srcdir p appendix = do
writeCurryProgram opts srcdir p appendix = do
let progfile = srcdir </> modNameToPath (progName p) ++ ".curry"
let progfile = srcdir </> modNameToPath (progName p) ++ ".curry"
when (optVerb opts > 3) $ putStrLn (
"Writing program: " ++ progfile
)
putStrLnIfDebug opts $
"Writing program: " ++ progfile
writeFile progfile
writeFile progfile
(showCProg p ++ "\n" ++ appendix ++ "\n")
(showCProg p ++ "\n" ++ appendix ++ "\n")
...
...
currypp/.cpm/packages/cass-analysis/src/Analysis/SensibleTypes.curry
0 → 100644
View file @
03cfac7f
------------------------------------------------------------------------
--- 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
-----------------------------------------------------------------------
currypp/.cpm/packages/cass/docs/SensibleType.md
0 → 100644
View file @
03cfac7f
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
ty