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