Commit 501a9137 authored by Michael Hanus 's avatar Michael Hanus
Browse files

tools adapted to ForallType

parent 07398e8f
......@@ -601,7 +601,7 @@ Unless the option \code{--versions} is set, only the newest version
of a package (compatible to the current compiler) is shown.
The option \code{--versions} shows all versions of the packages.
If a package is not compatible to the current compiler, then
the package version is shown as \ccode{???}.
the package version is shown in brackets (e.g., \ccode{(1.5.4)}).
The option \code{--csv} shows the information in CSV format.
\item[\fbox{\code{list --category [--csv]}}]
......
......@@ -847,11 +847,11 @@ packageVersionAsTable cfg pkgs = (colsizes, rows)
formatPkg p = [name p, synopsis p, showVersionIfCompatible cfg p]
--- Shows the version of a package if it is compatible with the
--- current compiler, otherwise shows "???".
--- current compiler, otherwise shows the version in brackets.
showVersionIfCompatible :: Config -> Package -> String
showVersionIfCompatible cfg p =
if isCompatibleToCompiler cfg p then showVersion (version p)
else "???"
let s = showVersion (version p)
in if isCompatibleToCompiler cfg p then s else '(' : s ++ ")"
cpmInfo :: String
cpmInfo = "Use 'cpm info PACKAGE' for more information about a package."
......@@ -868,7 +868,7 @@ search (SearchOptions q smod) cfg repo = putStr rendered >> succeedIO ()
(colsizes,rows) = packageVersionAsTable cfg results
rendered = unlines $
if null results
then ["No packages found for '" ++ q, "", cpmUpdate]
then ["No packages found for '" ++ q, "'", cpmUpdate]
else [ render (table rows colsizes), cpmInfo, cpmUpdate ]
upgrade :: UpgradeOptions -> Config -> Repository -> GlobalCache
......
......@@ -65,7 +65,8 @@ allPackages pkgDir = do
--- @param dir the package directory
--- @param gc the global package cache
--- @param pkg the package to copy
createLinkToGlobalCache :: Config -> String -> GlobalCache -> Package -> IO (ErrorLogger ())
createLinkToGlobalCache :: Config -> String -> GlobalCache -> Package
-> IO (ErrorLogger ())
createLinkToGlobalCache cfg pkgDir _ pkg =
createLink pkgDir (installedPackageDir cfg pkg) (packageId pkg) False
......@@ -76,7 +77,8 @@ createLinkToGlobalCache cfg pkgDir _ pkg =
--- @param dir the package directory
--- @param gc the global package cache
--- @param pkgs the list of packages
linkPackages :: Config -> String -> GlobalCache -> [Package] -> IO (ErrorLogger ())
linkPackages :: Config -> String -> GlobalCache -> [Package]
-> IO (ErrorLogger ())
linkPackages cfg pkgDir gc pkgs =
mapEL (createLinkToGlobalCache cfg pkgDir gc) pkgs |> succeedIO ()
......@@ -171,12 +173,13 @@ createLink :: String -> String -> String -> Bool -> IO (ErrorLogger ())
createLink pkgDir from name replace = do
ensureCacheDir pkgDir
exists <- linkExists target
if exists && (not replace)
if exists && not replace
then succeedIO ()
else deleteIfLink target |> do
rc <- createSymlink from target
if rc == 0
then succeedIO ()
else failIO $ "Failed to create symlink from '" ++ from ++ "' to '" ++ target ++ "', return code " ++ (show rc)
else failIO $ "Failed to create symlink from '" ++ from ++ "' to '" ++
target ++ "', return code " ++ show rc
where
target = (cacheDir pkgDir) </> name
target = cacheDir pkgDir </> name
......@@ -153,9 +153,9 @@ linkToLocalCache :: String -> String -> IO (ErrorLogger ())
linkToLocalCache src pkgDir = do
dirExists <- doesDirectoryExist src
if dirExists
then loadPackageSpec src |>=
\pkgSpec -> LocalCache.createLink pkgDir src (packageId pkgSpec) True |>
succeedIO ()
then loadPackageSpec src |>= \pkgSpec ->
LocalCache.createLink pkgDir src (packageId pkgSpec) True |>
succeedIO ()
else log Critical ("Directory '" ++ src ++ "' does not exist.") |>
succeedIO ()
......
......@@ -50,6 +50,7 @@ orderOfTypeExpr (TVar _) = FO
orderOfTypeExpr (FuncType _ _) = HO
orderOfTypeExpr (TCons _ typeExprs) =
foldr hoOr FO (map orderOfTypeExpr typeExprs)
orderOfTypeExpr (ForallType _ texp) = orderOfTypeExpr texp
-----------------------------------------------------------------------
-- higher-order constructor analysis
......
......@@ -44,6 +44,7 @@ typesInTypeExpr usedtypes (FuncType t1 t2) =
typesInTypeExpr usedtypes (TCons tc texps) =
foldr join (join [tc] (maybe [] id (lookup tc usedtypes)))
(map (typesInTypeExpr usedtypes) texps)
typesInTypeExpr usedtypes (ForallType _ t) = typesInTypeExpr usedtypes t
join :: [QName] -> [QName] -> [QName]
join tcs1 tcs2 = foldr insert tcs2 tcs1
......
......@@ -21,10 +21,11 @@ dependsDirectlyOnTypes (Type _ _ _ consDeclList) =
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 :: TypeExpr -> [QName]
tconsOf (TVar _) = []
tconsOf (FuncType a b) = tconsOf a ++ tconsOf b
tconsOf (TCons qName _) = [qName]
tconsOf (ForallType _ te) = tconsOf te
-----------------------------------------------------------------------------
......
rewriting
=========
These libraries provide a representation of first-order terms
and various notions of term rewriting, like position, substitution,
unification, critical pairs, etc. Moreover, it defines also
operations for rewriting and narrowing strategies and a
representation of definitional trees.
A previous version of these libraries were part of the
PAKCS/KiCS2 distributions.
......@@ -50,6 +50,7 @@ orderOfTypeExpr (TVar _) = FO
orderOfTypeExpr (FuncType _ _) = HO
orderOfTypeExpr (TCons _ typeExprs) =
foldr hoOr FO (map orderOfTypeExpr typeExprs)
orderOfTypeExpr (ForallType _ texp) = orderOfTypeExpr texp
-----------------------------------------------------------------------
-- higher-order constructor analysis
......
......@@ -44,6 +44,7 @@ typesInTypeExpr usedtypes (FuncType t1 t2) =
typesInTypeExpr usedtypes (TCons tc texps) =
foldr join (join [tc] (maybe [] id (lookup tc usedtypes)))
(map (typesInTypeExpr usedtypes) texps)
typesInTypeExpr usedtypes (ForallType _ t) = typesInTypeExpr usedtypes t
join :: [QName] -> [QName] -> [QName]
join tcs1 tcs2 = foldr insert tcs2 tcs1
......
......@@ -21,10 +21,11 @@ dependsDirectlyOnTypes (Type _ _ _ consDeclList) =
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 :: TypeExpr -> [QName]
tconsOf (TVar _) = []
tconsOf (FuncType a b) = tconsOf a ++ tconsOf b
tconsOf (TCons qName _) = [qName]
tconsOf (ForallType _ te) = tconsOf te
-----------------------------------------------------------------------------
......
......@@ -61,7 +61,7 @@ ccBanner = unlines [bannerLine,bannerText,bannerLine]
-- Help text
usageText :: String
usageText = usageInfo ("Usage: curry check [options] <module names>\n") options
-------------------------------------------------------------------------
-- Representation of command line options.
data Options = Options
......@@ -281,7 +281,7 @@ createTests opts mainmodname tm = map createTest (propTests tm)
msgOf test = string2ac $ genTestMsg (orgModuleName tm) test
testmname = testModuleName tm
genTestName (modName, fName) = fName ++ "_" ++ modNameToId modName
easyCheckFuncName arity =
......@@ -323,17 +323,17 @@ createTests opts mainmodname tm = map createTest (propTests tm)
in if n==0 then stdConfigOp
else applyF (easyCheckExecModule,"setMaxTest")
[cInt n, stdConfigOp]
configOpWithMaxFail =
let n = optMaxFail opts
in if n==0 then configOpWithMaxTest
else applyF (easyCheckExecModule,"setMaxFail")
[cInt n, configOpWithMaxTest]
msgvar = (0,"msg")
stdConfigOp = constF (easyCheckConfig opts)
ioTestBody (_, name) test =
[simpleRule [] $ applyF (easyCheckExecModule,"checkPropIOWithMsg")
[stdConfigOp, msgOf test, CSymbol (testmname,name)]]
......@@ -375,7 +375,7 @@ typename2genopname mainmod definedgenops (mn,tc)
= (mainmod, "gen_" ++ modNameToId mn ++ "_" ++ tc)
where
maybeuserdefined = find (\qn -> "gen"++tc == snd qn) definedgenops
transTC tcons | tcons == "[]" = "List"
| tcons == "()" = "Unit"
| tcons == "(,)" = "Pair"
......@@ -484,7 +484,7 @@ transformDetTests opts prooffiles
opDecls)
where
preCondOps = preCondOperations functions
-- generate determinism tests:
detOpTests = genDetOpTests prooffiles preCondOps functions
......@@ -629,7 +629,7 @@ poly2default dt fdecl@(CFunc (mn,fname) arity vis qftype rs)
= [(True, CFunc (mn,fname) arity vis (CQualType clscon ftype) rs)]
where
CQualType clscon ftype = defaultQualType qftype
p2dt (CTVar _) = baseType (pre dt)
p2dt (CFuncType t1 t2) = CFuncType (p2dt t1) (p2dt t2)
p2dt (CTApply t1 t2) = CTApply (p2dt t1) (p2dt t2)
......@@ -899,13 +899,13 @@ collectAllTestTypeDecls tdecls testtypenames = do
allTConsInDecl :: FC.TypeDecl -> [QName]
allTConsInDecl = FCG.trType (\_ _ _ -> concatMap allTConsInConsDecl)
(\_ _ _ -> allTConsInTypeExpr)
allTConsInConsDecl :: FC.ConsDecl -> [QName]
allTConsInConsDecl = FCG.trCons (\_ _ _ -> concatMap allTConsInTypeExpr)
allTConsInTypeExpr :: FC.TypeExpr -> [QName]
allTConsInTypeExpr =
FCG.trTypeExpr (\_ -> []) (\tc targs -> tc : concat targs) (++)
FCG.trTypeExpr (\_ -> []) (\tc targs -> tc : concat targs) (++) (flip const)
-- Creates a test data generator for a given type declaration.
createTestDataGenerator :: String -> FC.TypeDecl -> CFuncDecl
......@@ -942,6 +942,9 @@ createTestDataGenerator mainmodname tdecl = type2genData tdecl
"': cannot create value generators for functions!"
type2gen (FC.TCons qtc argtypes) =
applyF (typename2genopname mainmodname [] qtc) (map type2gen argtypes)
type2gen (FC.ForallType _ _) =
error $ "Type '" ++ qtString ++
"': cannot create value generators for forall types!"
ctvars = map (\i -> CTVar (i,"a"++show i)) tvars
cvars = map (\i -> (i,"a"++show i)) tvars
......@@ -983,7 +986,7 @@ main = do
opts <- processOpts (foldl (flip id) defaultOptions funopts)
unless (null opterrors)
(putStr (unlines opterrors) >> putStrLn usageText >> exitWith 1)
putStrIfNormal opts ccBanner
putStrIfNormal opts ccBanner
when (null args || optHelp opts) (putStrLn usageText >> exitWith 1)
testModules <- mapIO (analyseModule opts) (map stripCurrySuffix args)
let staticerrs = concatMap staticErrors (concat testModules)
......@@ -1064,7 +1067,7 @@ searchTreeModule = "SearchTree"
--- Name of SearchTree type constructor.
searchTreeTC :: QName
searchTreeTC = (searchTreeModule,"SearchTree")
--- Name of the SearchTreeGenerator module.
generatorModule :: String
generatorModule = "SearchTreeGenerators"
......
rewriting
=========
These libraries provide a representation of first-order terms
and various notions of term rewriting, like position, substitution,
unification, critical pairs, etc. Moreover, it defines also
operations for rewriting and narrowing strategies and a
representation of definitional trees.
A previous version of these libraries were part of the
PAKCS/KiCS2 distributions.
......@@ -50,6 +50,7 @@ orderOfTypeExpr (TVar _) = FO
orderOfTypeExpr (FuncType _ _) = HO
orderOfTypeExpr (TCons _ typeExprs) =
foldr hoOr FO (map orderOfTypeExpr typeExprs)
orderOfTypeExpr (ForallType _ texp) = orderOfTypeExpr texp
-----------------------------------------------------------------------
-- higher-order constructor analysis
......
......@@ -44,6 +44,7 @@ typesInTypeExpr usedtypes (FuncType t1 t2) =
typesInTypeExpr usedtypes (TCons tc texps) =
foldr join (join [tc] (maybe [] id (lookup tc usedtypes)))
(map (typesInTypeExpr usedtypes) texps)
typesInTypeExpr usedtypes (ForallType _ t) = typesInTypeExpr usedtypes t
join :: [QName] -> [QName] -> [QName]
join tcs1 tcs2 = foldr insert tcs2 tcs1
......
......@@ -21,10 +21,11 @@ dependsDirectlyOnTypes (Type _ _ _ consDeclList) =
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 :: TypeExpr -> [QName]
tconsOf (TVar _) = []
tconsOf (FuncType a b) = tconsOf a ++ tconsOf b
tconsOf (TCons qName _) = [qName]
tconsOf (ForallType _ te) = tconsOf te
-----------------------------------------------------------------------------
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment