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

Improved dumping (dumps are now printed when possible, even in case

of errors encountered later)
parent 515d1c9e
......@@ -36,7 +36,7 @@ Executable cymake
Build-Depends: base == 3.*
Build-Depends:
curry-base == 0.3.7
, mtl, containers, pretty, transformers
, containers, either, mtl, pretty, transformers
ghc-options: -Wall
Other-Modules:
Base.CurryTypes
......
......@@ -13,6 +13,7 @@
-}
module Checks where
import Control.Monad.Trans.Either
import Curry.Syntax (Module (..))
import Base.Messages
......@@ -27,30 +28,18 @@ import qualified Checks.WarnCheck as WC (warnCheck)
import CompilerEnv
import CompilerOpts
data CheckResult a
= CheckSuccess a
| CheckFailed [Message]
instance Monad CheckResult where
return = CheckSuccess
(>>=) = thenCheck
thenCheck :: CheckResult a -> (a -> CheckResult b) -> CheckResult b
thenCheck chk cont = case chk of
CheckSuccess a -> cont a
CheckFailed errs -> CheckFailed errs
-- TODO: More documentation
type Check m = Options -> CompilerEnv -> Module
-> EitherT [Message] m (CompilerEnv, Module)
-- |Check the kinds of type definitions and signatures.
--
-- * Declarations: Nullary type constructors and type variables are
-- disambiguated
-- * Environment: remains unchanged
kindCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
kindCheck env (Module m es is ds)
| null msgs = CheckSuccess (env, Module m es is ds')
| otherwise = CheckFailed msgs
kindCheck :: Monad m => Check m
kindCheck _ env (Module m es is ds)
| null msgs = right (env, Module m es is ds')
| otherwise = left msgs
where (ds', msgs) = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
-- |Check for a correct syntax.
......@@ -58,10 +47,10 @@ kindCheck env (Module m es is ds)
-- * Declarations: Nullary data constructors and variables are
-- disambiguated, variables are renamed
-- * Environment: remains unchanged
syntaxCheck :: Options -> CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
syntaxCheck :: Monad m => Check m
syntaxCheck opts env (Module m es is ds)
| null msgs = CheckSuccess (env, Module m es is ds')
| otherwise = CheckFailed msgs
| null msgs = right (env, Module m es is ds')
| otherwise = left msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env)
(valueEnv env) (tyConsEnv env) ds
......@@ -70,27 +59,27 @@ syntaxCheck opts env (Module m es is ds)
-- * Declarations: Expressions are reordered according to the specified
-- precedences
-- * Environment: The operator precedence environment is updated
precCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
precCheck env (Module m es is ds)
| null msgs = CheckSuccess (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = CheckFailed msgs
precCheck :: Monad m => Check m
precCheck _ env (Module m es is ds)
| null msgs = right (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = left msgs
where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
-- |Apply the correct typing of the module.
-- The declarations remain unchanged; the type constructor and value
-- environments are updated.
typeCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
typeCheck env mdl@(Module _ _ _ ds)
| null msgs = CheckSuccess (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
| otherwise = CheckFailed msgs
typeCheck :: Monad m => Check m
typeCheck _ env mdl@(Module _ _ _ ds)
| null msgs = right (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
| otherwise = left msgs
where (tcEnv', tyEnv', msgs) = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) ds
-- |Check the export specification
exportCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
exportCheck env (Module m es is ds)
| null msgs = CheckSuccess (env, Module m es' is ds)
| otherwise = CheckFailed msgs
exportCheck :: Monad m => Check m
exportCheck _ env (Module m es is ds)
| null msgs = right (env, Module m es' is ds)
| otherwise = left msgs
where (es', msgs) = EC.exportCheck (moduleIdent env) (aliasEnv env)
(tyConsEnv env) (valueEnv env) es
......
......@@ -15,8 +15,9 @@
module Frontend (parse, fullParse) where
import Control.Monad.Writer
import Data.Maybe (mapMaybe)
import qualified Data.Map as Map (empty)
import Control.Monad.Trans.Either
import Data.Maybe (mapMaybe)
import qualified Data.Map as Map (empty)
import Curry.Base.Message
......@@ -24,7 +25,6 @@ import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax (Module (..), parseModule)
import Checks (CheckResult (..))
import CompilerOpts (Options (..), defaultOptions)
import CurryBuilder (smake)
import CurryDeps (Source (..), flattenDeps, moduleDeps)
......@@ -60,9 +60,10 @@ genFullCurrySyntax opts fn m = case runMsg m of
if null errs
then do
loaded <- liftIO $ loadModule opts fn
case checkModule opts loaded of
CheckFailed errs' -> failWith $ show $ head errs'
CheckSuccess (_, mod',_) -> return mod'
checked <- liftIO $ runEitherT $ checkModule opts loaded
case checked of
Left errs' -> failWith $ show $ head errs'
Right (_, mod') -> return mod'
else failWith $ show $ head errs
-- TODO: Resembles CurryBuilder
......
......@@ -19,6 +19,8 @@ module Modules
) where
import Control.Monad (unless, when)
import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Data.Maybe (fromMaybe)
import Text.PrettyPrint
......@@ -73,11 +75,11 @@ import Transformations
compileModule :: Options -> FilePath -> IO ()
compileModule opts fn = do
loaded <- loadModule opts fn
case checkModule opts loaded of
CheckFailed errs -> abortWithMessages errs
CheckSuccess (env, mdl, dumps) -> do
checked <- runEitherT $ checkModule opts loaded
case checked of
Left errs -> abortWithMessages errs
Right (env, mdl) -> do
warn opts $ warnCheck env mdl
mapM_ (doDump opts) dumps
writeOutput opts fn (env, mdl)
writeOutput :: Options -> FilePath -> (CompilerEnv, CS.Module) -> IO ()
......@@ -105,7 +107,6 @@ writeOutput opts fn (env, modul) = do
loadModule :: Options -> FilePath -> IO (CompilerEnv, CS.Module)
loadModule opts fn = do
-- read module
mbSrc <- readModule fn
case mbSrc of
Nothing -> abortWithMessages [message $ text $ "Missing file: " ++ fn] -- TODO
......@@ -170,23 +171,22 @@ importPrelude opts fn m@(CS.Module mid es is ds)
-- AbstractCurry is deactivated as it requires the value information
-- collected by the type checker.
checkModule :: Options -> (CompilerEnv, CS.Module)
-> CheckResult (CompilerEnv, CS.Module, [Dump])
-> EitherT [Message] IO (CompilerEnv, CS.Module)
checkModule opts (env, mdl) = do
(env1, kc) <- kindCheck env mdl -- should be only syntax checking ?
doDump opts (DumpParsed , env , show $ CS.ppModule mdl)
(env1, kc) <- kindCheck opts env mdl -- should be only syntax checking ?
doDump opts (DumpKindChecked , env1, show $ CS.ppModule kc)
(env2, sc) <- syntaxCheck opts env1 kc
(env3, pc) <- precCheck env2 sc
doDump opts (DumpSyntaxChecked, env2, show $ CS.ppModule sc)
(env3, pc) <- precCheck opts env2 sc
doDump opts (DumpPrecChecked , env3, show $ CS.ppModule pc)
(env4, tc) <- if withTypeCheck
then typeCheck env3 pc >>= uncurry exportCheck
then typeCheck opts env3 pc >>= uncurry (exportCheck opts)
else return (env3, pc)
doDump opts (DumpTypeChecked , env4, show $ CS.ppModule tc)
(env5, ql) <- return $ qual opts env4 tc
let dumps = [ (DumpParsed , env , show $ CS.ppModule mdl)
, (DumpKindChecked , env1, show $ CS.ppModule kc)
, (DumpSyntaxChecked, env2, show $ CS.ppModule sc)
, (DumpPrecChecked , env3, show $ CS.ppModule pc)
, (DumpTypeChecked , env4, show $ CS.ppModule tc)
, (DumpQualified , env5, show $ CS.ppModule ql)
]
return (env5, ql, dumps)
doDump opts (DumpQualified , env5, show $ CS.ppModule ql)
return (env5, ql)
where
withTypeCheck = any (`elem` optTargetTypes opts)
[FlatCurry, ExtendedFlatCurry, FlatXml, AbstractCurry]
......@@ -300,10 +300,10 @@ writeAbstractCurry opts fname env modul = do
useSubDir = optUseSubdir opts
-- |The 'dump' function writes the selected information to standard output.
doDump :: Options -> Dump -> IO ()
doDump :: MonadIO m => Options -> Dump -> m ()
doDump opts (level, env, dump) = when (level `elem` optDumps opts) $ do
when (optDumpEnv opts) $ putStrLn $ showCompilerEnv env
putStrLn $ unlines [header, replicate (length header) '=', dump]
when (optDumpEnv opts) $ liftIO $ putStrLn $ showCompilerEnv env
liftIO $ putStrLn $ unlines [header, replicate (length header) '=', dump]
where
header = lookupHeader dumpLevel
lookupHeader [] = "Unknown dump level " ++ show level
......
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