Commit 9889e859 authored by Michael Hanus's avatar Michael Hanus
Browse files

CPM updated

parent 6d0c57c4
...@@ -17,13 +17,14 @@ module CPM.ErrorLogger ...@@ -17,13 +17,14 @@ module CPM.ErrorLogger
, failIO , failIO
, log , log
, showLogEntry , showLogEntry
, infoMessage, debugMessage, fromErrorLogger , infoMessage, debugMessage, errorMessage, fromErrorLogger
, showExecCmd, execQuietCmd , showExecCmd, execQuietCmd
) where ) where
import Global import Global
import IO ( hPutStrLn, stderr )
import Profile -- for show run-time import Profile -- for show run-time
import System (exitWith, system) import System ( exitWith, system )
import Text.Pretty import Text.Pretty
...@@ -135,12 +136,13 @@ foldEL f z (x:xs) = do ...@@ -135,12 +136,13 @@ foldEL f z (x:xs) = do
Right v -> foldEL f v xs Right v -> foldEL f v xs
Left m -> return $ ([], Left m) Left m -> return $ ([], Left m)
--- Renders a log entry. --- Renders a log entry to stderr.
showLogEntry :: LogEntry -> IO () showLogEntry :: LogEntry -> IO ()
showLogEntry (LogEntry lvl msg) = do showLogEntry (LogEntry lvl msg) = do
minLevel <- getLogLevel minLevel <- getLogLevel
if levelGte lvl minLevel if levelGte lvl minLevel
then putStrLn $ pPrint lvlText ++ msg then mapM_ (\l -> hPutStrLn stderr $ pPrint $ lvlText <+> text l)
(lines msg)
else return () else return ()
where where
lvlText = case lvl of lvlText = case lvl of
...@@ -215,6 +217,10 @@ infoMessage msg = (log Info msg |> succeedIO ()) >> done ...@@ -215,6 +217,10 @@ infoMessage msg = (log Info msg |> succeedIO ()) >> done
debugMessage :: String -> IO () debugMessage :: String -> IO ()
debugMessage msg = (log Debug msg |> succeedIO ()) >> done debugMessage msg = (log Debug msg |> succeedIO ()) >> done
--- Prints an error message in the standard IO monad.
errorMessage :: String -> IO ()
errorMessage msg = (log Error msg |> succeedIO ()) >> done
--- Transforms an error logger actions into a standard IO action. --- Transforms an error logger actions into a standard IO action.
--- It shows all messages and, if the result is not available, --- It shows all messages and, if the result is not available,
--- exits with a non-zero code. --- exits with a non-zero code.
......
...@@ -79,7 +79,7 @@ runWithArgs opts = do ...@@ -79,7 +79,7 @@ runWithArgs opts = do
debugMessage "Reading CPM configuration..." debugMessage "Reading CPM configuration..."
config <- readConfigurationWith (optDefConfig opts) >>= \c -> config <- readConfigurationWith (optDefConfig opts) >>= \c ->
case c of case c of
Left err -> do putStrLn $ "Error reading .cpmrc settings: " ++ err Left err -> do errorMessage $ "Error reading .cpmrc settings: " ++ err
exitWith 1 exitWith 1
Right c' -> return c' Right c' -> return c'
debugMessage ("Current configuration:\n" ++ showConfiguration config) debugMessage ("Current configuration:\n" ++ showConfiguration config)
...@@ -688,10 +688,10 @@ checkRequiredExecutables = do ...@@ -688,10 +688,10 @@ checkRequiredExecutables = do
debugMessage "Checking whether all required executables can be found..." debugMessage "Checking whether all required executables can be found..."
missingExecutables <- checkExecutables listOfExecutables missingExecutables <- checkExecutables listOfExecutables
unless (null missingExecutables) $ do unless (null missingExecutables) $ do
putStrLn $ "The following programs could not be found on the PATH " ++ errorMessage $ "The following programs could not be found on the PATH " ++
"(they are required for CPM to work):\n" ++ "(they are required for CPM to work):\n" ++
intercalate ", " missingExecutables intercalate ", " missingExecutables
exitWith 1 exitWith 1
debugMessage "All required executables found." debugMessage "All required executables found."
where where
listOfExecutables = listOfExecutables =
...@@ -1191,7 +1191,7 @@ genDocForPrograms opts cfg docdir specDir pkg = do ...@@ -1191,7 +1191,7 @@ genDocForPrograms opts cfg docdir specDir pkg = do
(\ms -> return (ms,True)) (\ms -> return (ms,True))
(docModules opts) (docModules opts)
if null docmods if null docmods
then putStrLn "No modules to be documented!" >> succeedIO () then log Info "No modules to be documented!"
else else
loadCurryPathFromCache cfg specDir |>= loadCurryPathFromCache cfg specDir |>=
maybe (computePackageLoadPath cfg specDir) maybe (computePackageLoadPath cfg specDir)
...@@ -1251,7 +1251,7 @@ testCmd opts cfg = ...@@ -1251,7 +1251,7 @@ testCmd opts cfg =
mainprogs <- curryModulesInDir (aspecDir </> "src") mainprogs <- curryModulesInDir (aspecDir </> "src")
let tests = testsuites pkg mainprogs let tests = testsuites pkg mainprogs
if null tests if null tests
then putStrLn "No modules to be tested!" >> succeedIO () then log Info "No modules to be tested!"
else foldEL (\_ -> execTest aspecDir) () tests else foldEL (\_ -> execTest aspecDir) () tests
where where
currycheck = curryExec cfg ++ " check" currycheck = curryExec cfg ++ " check"
...@@ -1418,8 +1418,8 @@ newPackage :: NewOptions -> IO (ErrorLogger ()) ...@@ -1418,8 +1418,8 @@ newPackage :: NewOptions -> IO (ErrorLogger ())
newPackage (NewOptions pname) = do newPackage (NewOptions pname) = do
exists <- doesDirectoryExist pname exists <- doesDirectoryExist pname
when exists $ do when exists $ do
putStrLn $ "There is already a directory with the new project name. " ++ errorMessage $ "There is already a directory with the new project name.\n"
"I cannot create new project!" ++ "I cannot create new project!"
exitWith 1 exitWith 1
let emptyAuthor = "YOUR NAME <YOUR EMAIL ADDRESS>" let emptyAuthor = "YOUR NAME <YOUR EMAIL ADDRESS>"
emptySynopsis = "PLEASE PROVIDE A ONE-LINE SUMMARY ABOUT THE PACKAGE" emptySynopsis = "PLEASE PROVIDE A ONE-LINE SUMMARY ABOUT THE PACKAGE"
......
...@@ -142,8 +142,8 @@ readRepository cfg large = do ...@@ -142,8 +142,8 @@ readRepository cfg large = do
(repo, repoErrors) <- readRepositoryFrom (repositoryDir cfg) (repo, repoErrors) <- readRepositoryFrom (repositoryDir cfg)
if null repoErrors if null repoErrors
then writeRepositoryCache cfg large repo >> return repo then writeRepositoryCache cfg large repo >> return repo
else do putStrLn "Problems while reading the package index:" else do errorMessage "Problems while reading the package index:"
mapIO putStrLn repoErrors mapM_ errorMessage repoErrors
exitWith 1 exitWith 1
Just repo -> return repo Just repo -> return repo
...@@ -162,9 +162,8 @@ warnOldRepo cfg = do ...@@ -162,9 +162,8 @@ warnOldRepo cfg = do
-- We assume that clock time is measured in seconds (as in PAKCS or KiCS2) -- We assume that clock time is measured in seconds (as in PAKCS or KiCS2)
let timediff = clockTimeToInt ctime - clockTimeToInt utime let timediff = clockTimeToInt ctime - clockTimeToInt utime
days = timediff `div` (60*60*24) days = timediff `div` (60*60*24)
putStrLn $ "Warning: your repository index is older than " ++ infoMessage $ "Warning: your repository index is older than " ++
show days ++ " days." show days ++ " days.\n" ++ useUpdateHelp
putStrLn useUpdateHelp
useUpdateHelp :: String useUpdateHelp :: String
useUpdateHelp = "Use 'cypm update' to download the newest package index." useUpdateHelp = "Use 'cypm update' to download the newest package index."
......
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