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) ...@@ -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
......
...@@ -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/05/2017)" "Curry Package Manager <curry-language.org/tools/cpm> (version of 01/06/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 -> testCmd 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) testCmd :: TestOptions -> Config -> IO (Repository,GlobalCache)
-> IO (ErrorLogger ()) -> IO (ErrorLogger ())
test opts cfg getRepoGC = testCmd opts cfg getRepoGC =
tryFindLocalPackageSpec "." |>= \specDir -> tryFindLocalPackageSpec "." |>= \specDir ->
loadPackageSpec specDir |>= \pkg -> do loadPackageSpec specDir |>= \pkg -> do
checkCompiler cfg pkg checkCompiler cfg pkg
......
...@@ -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, getDirectoryContents import Directory (createDirectoryIfMissing, copyFile, getAbsolutePath
, 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 the cache directory of the local package cache. --- The 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 '" ++
......
...@@ -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
......
------------------------------------------------------------------------
--- 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 @@ ...@@ -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 2013 --- @version Junes 2017
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
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
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
......
...@@ -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
......
...@@ -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 06/02/2017)" packageVersion ++ " of 01/06/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")
......
------------------------------------------------------------------------
--- 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
ty