Commit e8024a1b authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Error handling improved

parent d4966e8e
......@@ -2,16 +2,18 @@ module Base.Messages
( -- * Output of user information
info, status, putErrLn, putErrsLn
-- * program abortion
, abortWith, abortWithMessages, internalError, errorMessage, errorMessages
, abortWith, abortWithMessage, abortWithMessages
, internalError, errorMessage, errorMessages
-- * creating messages
, Message, posMessage
, Message, message, posMessage
) where
import Control.Monad (unless)
import System.IO (hPutStrLn, stderr)
import System.Exit (exitFailure)
import Curry.Base.Message (Message, posMessage, ppMessage, ppMessages)
import Curry.Base.Message
(Message, message, posMessage, ppMessage, ppMessages)
import CompilerOpts (Options (optVerbosity), Verbosity (..))
......@@ -31,10 +33,15 @@ putErrLn = hPutStrLn stderr
putErrsLn :: [String] -> IO ()
putErrsLn = mapM_ putErrLn
-- |Print a list of error messages on 'stderr' and abort the program
-- |Print a list of 'String's as error messages on 'stderr'
-- and abort the program
abortWith :: [String] -> IO a
abortWith errs = putErrsLn errs >> exitFailure
-- |Print a single error message on 'stderr' and abort the program
abortWithMessage :: Message -> IO a
abortWithMessage msg = abortWithMessages [msg]
-- |Print a list of error messages on 'stderr' and abort the program
abortWithMessages :: [Message] -> IO a
abortWithMessages msgs = putErrLn (show $ ppMessages msgs) >> exitFailure
......
......@@ -18,12 +18,14 @@ module CurryBuilder (buildCurry, smake) where
import Control.Monad (liftM)
import Data.Maybe (catMaybes, mapMaybe)
import System.FilePath (normalise)
import Text.PrettyPrint
import Curry.Base.Ident
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Base.Messages (info, status, abortWith)
import Base.Messages
(info, status, Message, message, abortWithMessage, abortWithMessages)
import CompilerOpts (Options (..), TargetType (..))
import CurryDeps (Source (..), flatDeps)
......@@ -35,11 +37,11 @@ buildCurry :: Options -> String -> IO ()
buildCurry opts s = do
target <- findCurry opts s
case target of
Left err -> abortWith [err]
Left err -> abortWithMessage err
Right fn -> do
(srcs, depErrs) <- flatDeps opts fn
if not $ null depErrs
then abortWith depErrs
then abortWithMessages depErrs
else makeCurry (defaultToFlatCurry opts) srcs fn
where
defaultToFlatCurry opt
......@@ -47,7 +49,7 @@ buildCurry opts s = do
| otherwise = opt
-- |Search for a compilation target identified by the given 'String'.
findCurry :: Options -> String -> IO (Either String FilePath)
findCurry :: Options -> String -> IO (Either Message FilePath)
findCurry opts s = do
mbTarget <- findFile `orIfNotFound` findModule
case mbTarget of
......@@ -65,9 +67,9 @@ findCurry opts s = do
then lookupCurryFile paths moduleFile
else return Nothing
complaint
| canBeFile && canBeModule = errMissingTarget s
| canBeFile = errMissingFile s
| canBeModule = errMissingModule s
| canBeFile && canBeModule = errMissing "target" s
| canBeFile = errMissing "file" s
| canBeModule = errMissing "module" s
| otherwise = errUnrecognized s
first `orIfNotFound` second = do
mbFile <- first
......@@ -133,8 +135,8 @@ smake :: [FilePath] -- ^ destination files
-> IO a -- ^ action to perform if destination files are newer
-> IO a
smake dests deps actOutdated actUpToDate = do
destTimes <- getDestTimes dests
depTimes <- getDepTimes deps
destTimes <- catMaybes `liftM` mapM getModuleModTime dests
depTimes <- mapM (abortOnMissing getModuleModTime) deps
make destTimes depTimes
where
make destTimes depTimes
......@@ -142,35 +144,24 @@ smake dests deps actOutdated actUpToDate = do
| outOfDate destTimes depTimes = actOutdated
| otherwise = actUpToDate
-- getDestTimes :: [FilePath] -> IO [ClockTime]
getDestTimes = liftM catMaybes . mapM getModuleModTime
-- getDepTimes :: [FilePath] -> IO [ClockTime]
getDepTimes = mapM (abortOnMissing getModuleModTime)
-- outOfDate :: [ClockTime] -> [ClockTime] -> Bool
outOfDate tgtimes dptimes = or [ tg < dp | tg <- tgtimes, dp <- dptimes]
abortOnMissing :: (FilePath -> IO (Maybe a)) -> FilePath -> IO a
abortOnMissing act f = act f >>= \res -> case res of
Nothing -> abortWith [errModificationTime f]
Nothing -> abortWithMessage $ errModificationTime f
Just val -> return val
errMissingFile :: String -> String
errMissingFile f = "Missing file " ++ quote f
errMissingModule :: String -> String
errMissingModule f = "Missing module " ++ quote f
errMissingTarget :: String -> String
errMissingTarget f = "Missing target " ++ quote f
errMissing :: String -> String -> Message
errMissing what which = message $ sep $ map text
[ "Missing", what, quote which ]
errUnrecognized :: String -> String
errUnrecognized f = "Unrecognized input " ++ quote f
errUnrecognized :: String -> Message
errUnrecognized f = message $ sep $ map text
[ "Unrecognized input", quote f ]
errModificationTime :: FilePath -> String
errModificationTime f = "Could not inspect modification time of file "
++ quote f
errModificationTime :: FilePath -> Message
errModificationTime f = message $ sep $ map text
[ "Could not inspect modification time of file", quote f ]
quote :: String -> String
quote s = "\"" ++ s ++ "\""
{- |
Module : $Header$
Description : Computation of module dependencies
Copyright : (c) 2002-2004, Wolfgang Lux
2005, Martin Engelke (men@informatik.uni-kiel.de)
2007, Sebastian Fischer (sebf@informatik.uni-kiel.de)
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
Copyright : (c) 2002 - 2004 Wolfgang Lux
2005 Martin Engelke
2007 Sebastian Fischer
2011 - 2012 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -25,16 +25,17 @@ module CurryDeps
( Source (..), flatDeps, deps, flattenDeps, sourceDeps, moduleDeps ) where
import Control.Monad (foldM, liftM, unless)
import Data.List (intercalate, isSuffixOf, nub)
import Data.List (isSuffixOf, nub)
import qualified Data.Map as Map (Map, empty, insert, lookup, toList)
import Text.PrettyPrint
import Curry.Base.Ident
import Curry.Base.Message
import Curry.Base.Message (runMsg, Message, message)
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax (Module (..), ImportDecl (..), parseHeader, patchModuleId)
import Base.Messages (abortWith, internalError)
import Base.Messages (abortWithMessage, internalError)
import Base.SCC (scc)
import CompilerOpts (Options (..), Extension (..))
......@@ -49,13 +50,13 @@ type SourceEnv = Map.Map ModuleIdent Source
-- |Retrieve the dependencies of a source file in topological order
-- and possible errors during flattering
flatDeps :: Options -> FilePath -> IO ([(ModuleIdent, Source)], [String])
flatDeps :: Options -> FilePath -> IO ([(ModuleIdent, Source)], [Message])
flatDeps opts fn = flattenDeps `liftM` deps opts Map.empty fn
-- |Retrieve the dependencies of a source file as a 'SourceEnv'
deps :: Options -> SourceEnv -> FilePath -> IO SourceEnv
deps opts sEnv fn
| ext == icurryExt = return Map.empty
| ext == icurryExt = return sEnv
| ext `elem` sourceExts = sourceDeps opts sEnv fn
| otherwise = targetDeps opts sEnv fn
where ext = takeExtension fn
......@@ -85,13 +86,7 @@ targetDeps opts sEnv fn = do
-- |Retrieve the dependencies of a given source file
sourceDeps :: Options -> SourceEnv -> FilePath -> IO SourceEnv
sourceDeps opts sEnv fn = do
mbFile <- readModule fn
case mbFile of
Nothing -> internalError $ "CurryDeps.sourceDeps: missing file " ++ fn
Just file -> do
let hdr = patchModuleId fn $ ok $ parseHeader fn file
moduleDeps opts sEnv fn hdr
sourceDeps opts sEnv fn = readHeader fn >>= moduleDeps opts sEnv fn
-- |Retrieve the dependencies of a given module
moduleDeps :: Options -> SourceEnv -> FilePath -> Module -> IO SourceEnv
......@@ -103,7 +98,7 @@ moduleDeps opts sEnv fn (Module m _ is _) = case Map.lookup m sEnv of
foldM (moduleIdentDeps opts) sEnv' imps
-- |Retrieve the imported modules and add the import of the Prelude
-- according to the compiler options.
-- according to the compiler options.
imports :: Options -> ModuleIdent -> [ImportDecl] -> [ModuleIdent]
imports opts m ds = nub $
[preludeMIdent | m /= preludeMIdent && implicitPrelude]
......@@ -119,19 +114,27 @@ moduleIdentDeps opts sEnv m = case Map.lookup m sEnv of
case mFile of
Nothing -> return $ Map.insert m Unknown sEnv
Just fn
| icurryExt `isSuffixOf` fn -> return $ Map.insert m (Interface fn) sEnv
| otherwise -> checkModuleHeader fn
where
checkModuleHeader fn = do
hdr@(Module m' _ _ _) <- patchModuleId fn `liftM` (ok . parseHeader fn)
`liftM` readFile fn
unless (m == m') $ abortWith [errWrongModule m m']
moduleDeps opts sEnv fn hdr
| icurryExt `isSuffixOf` fn ->
return $ Map.insert m (Interface fn) sEnv
| otherwise -> do
hdr@(Module m' _ _ _) <- readHeader fn
unless (m == m') $ abortWithMessage $ errWrongModule m m'
moduleDeps opts sEnv fn hdr
readHeader :: FilePath -> IO Module
readHeader fn = do
mbFile <- readModule fn
case mbFile of
Nothing -> abortWithMessage $ errMissingFile fn
Just src -> do
case runMsg $ parseHeader fn src of
Left err -> abortWithMessage err
Right (hdr, _) -> return $ patchModuleId fn hdr
-- If we want to compile the program instead of generating Makefile
-- dependencies the environment has to be sorted topologically. Note
-- dependencies, the environment has to be sorted topologically. Note
-- that the dependency graph should not contain any cycles.
flattenDeps :: SourceEnv -> ([(ModuleIdent, Source)], [String])
flattenDeps :: SourceEnv -> ([(ModuleIdent, Source)], [Message])
flattenDeps = fdeps . sortDeps
where
sortDeps :: SourceEnv -> [[(ModuleIdent, Source)]]
......@@ -142,7 +145,7 @@ flattenDeps = fdeps . sortDeps
imported (_, Source _ ms) = ms
imported (_, _) = []
fdeps :: [[(ModuleIdent, Source)]] -> ([(ModuleIdent, Source)], [String])
fdeps :: [[(ModuleIdent, Source)]] -> ([(ModuleIdent, Source)], [Message])
fdeps = foldr checkdep ([], [])
checkdep [] (srcs, errs) = (srcs , errs )
......@@ -150,17 +153,23 @@ flattenDeps = fdeps . sortDeps
checkdep dep (srcs, errs) = (srcs , err : errs)
where err = errCyclicImport $ map fst dep
errWrongModule :: ModuleIdent -> ModuleIdent -> String
errWrongModule m m' =
"Expected module for " ++ show m ++ " but found " ++ show m'
errMissingFile :: FilePath -> Message
errMissingFile fn = message $ sep $ map text [ "Missing file:", fn ]
errWrongModule :: ModuleIdent -> ModuleIdent -> Message
errWrongModule m m' = message $ sep $
[ text "Expected module for", text (moduleName m) <> comma
, text "but found", text (moduleName m') ]
errCyclicImport :: [ModuleIdent] -> String
errCyclicImport :: [ModuleIdent] -> Message
errCyclicImport [] = internalError "CurryDeps.errCyclicImport: empty list"
errCyclicImport [m] = "Recursive import for module " ++ moduleName m
errCyclicImport ms = "Cylic import dependency between modules "
++ intercalate ", " inits ++ " and " ++ lastm
errCyclicImport [m] = message $ sep $ map text
[ "Recursive import for module", moduleName m ]
errCyclicImport ms = message $ sep $
text "Cylic import dependency between modules" : punctuate comma inits
++ [text "and", lastm]
where
(inits, lastm) = splitLast $ map moduleName ms
splitLast [] = internalError "CurryDeps.splitLast: empty list"
splitLast (x : []) = ([] , x)
splitLast (x : y : ys) = (x : xs, z) where (xs, z) = splitLast (y : ys)
(inits, lastm) = splitLast $ map (text . moduleName) ms
splitLast [] = internalError "CurryDeps.splitLast: empty list"
splitLast (x : []) = ([] , x)
splitLast (x : xs) = (x : ys, y) where (ys, y) = splitLast xs
......@@ -49,25 +49,27 @@ parse fn src = parseModule True fn src >>= genCurrySyntax
environment variable "PAKCSLIBPATH". Additional search paths can
be defined using the argument 'paths'.
-}
fullParse :: Options -> FilePath -> String -> IO (MessageM Module)
fullParse :: Options -> FilePath -> String -> MessageIO Module
fullParse opts fn src = genFullCurrySyntax opts fn $ parse fn src
genFullCurrySyntax :: Options -> FilePath -> MessageM Module -> IO (MessageM Module)
genFullCurrySyntax opts fn m = runMsgIO m $ \mod1 -> do
errs <- makeInterfaces opts fn mod1
genFullCurrySyntax :: Options -> FilePath -> MessageM Module -> MessageIO Module
genFullCurrySyntax opts fn m = case runMsg m of
Left err -> failWith $ show err
Right (mod1, _) -> do
errs <- liftIO $ makeInterfaces opts fn mod1
if null errs
then do
loaded <- loadModule opts fn
loaded <- liftIO $ loadModule opts fn
case checkModule opts loaded of
CheckFailed errs' -> return $ failWith $ show $ head errs'
CheckSuccess (_, mod',_) -> return (return mod')
else return $ failWith $ show $ head errs
CheckFailed errs' -> failWith $ show $ head errs'
CheckSuccess (_, mod',_) -> return mod'
else failWith $ show $ head errs
-- TODO: Resembles CurryBuilder
-- Generates interface files for importes modules, if they don't exist or
-- if they are not up-to-date.
makeInterfaces :: Options -> FilePath -> Module -> IO [String]
makeInterfaces :: Options -> FilePath -> Module -> IO [Message]
makeInterfaces opts fn mdl = do
(deps1, errs) <- fmap flattenDeps $ moduleDeps opts Map.empty fn mdl
when (null errs) $ mapM_ (compile deps1 . snd) deps1
......
......@@ -13,11 +13,10 @@
-}
module Html.CurryHtml (source2html) where
import Control.Exception (SomeException (..), catch)
import Data.Maybe (fromMaybe, isJust)
import Curry.Base.Ident (QualIdent (..), unqualify)
import Curry.Base.Message (MessageM, failWith, runMsg)
import Curry.Base.Message (fromIO)
import Curry.Files.PathUtils (readModule, writeModule, lookupCurryFile
, dropExtension, takeFileName)
import Curry.Syntax (lexFile)
......@@ -56,27 +55,13 @@ filename2program opts filename = do
case mbModule of
Nothing -> abortWith ["Missing file: " ++ filename]
Just cont -> do
typingParseRes <- catchError $ fullParse opts filename cont
fullParseRes <- catchError $ fullParse (opts { optTargetTypes = [UntypedAbstractCurry]}) filename cont
parseRes <- catchError $ return (parse filename cont)
lexRes <- catchError $ return (lexFile filename cont)
typingParseRes <- fromIO $ fullParse opts filename cont
fullParseRes <- fromIO $ fullParse (opts { optTargetTypes = [UntypedAbstractCurry]}) filename cont
let parseRes = parse filename cont
lexRes = lexFile filename cont
return $ genProgram cont [typingParseRes, fullParseRes, parseRes] lexRes
--- this function intercepts errors and converts it to Messages
--- @param a show-function for (Result a)
--- @param a function that generates a (Result a)
--- @return (Result a) without runtimeerrors
-- FIXME This is ugly. Avoid exceptions and report failure via MsgMonad
-- instead! (hsi)
catchError :: Show a => IO (MessageM a) -> IO (MessageM a)
catchError toDo = Control.Exception.catch (toDo >>= returnNF) handler
where
handler (SomeException e) = return (failWith (show e))
returnNF a = normalform a `seq` return a
normalform = length . show . runMsg
-- generates htmlcode with syntax highlighting
-- @param modulname
......
......@@ -79,8 +79,8 @@ data FunctionKind
--- @return program
genProgram :: String -> [MessageM Module] -> MessageM [(Position, Token)] -> Program
genProgram plainText parseResults m = case runMsg m of
(Left e, msgs) -> buildMessagesIntoPlainText (e : msgs) plainText
(Right posNtokList, mess) ->
Left e -> buildMessagesIntoPlainText [e] plainText
Right (posNtokList, mess) ->
let messages = (prepareMessages (concatMap getMessages parseResults ++ mess))
mergedMessages = (mergeMessages' (trace' ("Messages: " ++ show messages) messages) posNtokList)
(nameList,codes) = catIdentifiers parseResults
......@@ -152,7 +152,7 @@ flatCode code = code
-- ----------Message---------------------------------------
getMessages :: MessageM a -> [Message]
getMessages = snd . runMsg --(Result mess _) = mess
getMessages = either return snd . runMsg --(Result mess _) = mess
-- getMessages (Failure mess) = mess
lessMessage :: Message -> Message -> Bool
......@@ -194,7 +194,7 @@ buildMessagesIntoPlainText messages text =
--- @param parse-Modules [typingParse,fullParse,parse]
catIdentifiers :: [MessageM Module] -> ([(ModuleIdent,ModuleIdent)],[Code])
catIdentifiers = catIds . rights_sc . map (fst . runMsg)
catIdentifiers = catIds . map fst . rights_sc . map runMsg
where
catIds [] = ([],[])
catIds [m] =
......
......@@ -107,20 +107,22 @@ loadModule opts fn = do
-- read module
mbSrc <- readModule fn
case mbSrc of
Nothing -> abortWith ["missing file: " ++ fn] -- TODO
Nothing -> abortWith ["Missing file: " ++ fn] -- TODO
Just src -> do
-- parse module
let parsed = ok $ CS.parseModule True fn src -- TODO
-- check module header
let (mdl, hdrErrs) = checkModuleHeader opts fn parsed
unless (null hdrErrs) $ abortWithMessages hdrErrs -- TODO
-- load the imported interfaces into an InterfaceEnv
(iEnv, intfErrs) <- loadInterfaces (optImportPaths opts) mdl
unless (null intfErrs) $ abortWithMessages intfErrs -- TODO
-- add information of imported modules
let (env, impErrs) = importModules opts mdl iEnv
unless (null impErrs) $ abortWithMessages impErrs -- TODO
return (env, mdl)
case runMsg $ CS.parseModule True fn src of
Left err -> abortWithMessages [err]
Right (parsed, _) -> do
-- check module header
let (mdl, hdrErrs) = checkModuleHeader opts fn parsed
unless (null hdrErrs) $ abortWithMessages hdrErrs -- TODO
-- load the imported interfaces into an InterfaceEnv
(iEnv, intfErrs) <- loadInterfaces (optImportPaths opts) mdl
unless (null intfErrs) $ abortWithMessages intfErrs -- TODO
-- add information of imported modules
let (env, impErrs) = importModules opts mdl iEnv
unless (null impErrs) $ abortWithMessages impErrs -- TODO
return (env, mdl)
checkModuleHeader :: Options -> FilePath -> CS.Module -> (CS.Module, [Message])
checkModuleHeader opts fn = checkModuleId fn
......
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