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

Source checks are now chained and no longer call error functions

parent 12ccd1f1
...@@ -13,8 +13,8 @@ marked with a boolean flag (see below). ...@@ -13,8 +13,8 @@ marked with a boolean flag (see below).
\begin{verbatim} \begin{verbatim}
> module Base.Subst > module Base.Subst
> ( Subst (..), IntSubst (..), idSubst, substToList, bindSubst, unbindSubst > ( Subst (..), IntSubst (..), idSubst, singleSubst, bindSubst, unbindSubst
> , compose, substVar', isubstVar, restrictSubstTo > , substToList, compose, substVar', isubstVar, restrictSubstTo
> ) where > ) where
> import qualified Data.Map as Map > import qualified Data.Map as Map
...@@ -27,6 +27,9 @@ marked with a boolean flag (see below). ...@@ -27,6 +27,9 @@ marked with a boolean flag (see below).
> substToList :: Ord v => Subst v e -> [(v, e)] > substToList :: Ord v => Subst v e -> [(v, e)]
> substToList (Subst _ sigma) = Map.toList sigma > substToList (Subst _ sigma) = Map.toList sigma
> singleSubst :: Ord v => v -> e -> Subst v e
> singleSubst v e = bindSubst v e idSubst
> bindSubst :: Ord v => v -> e -> Subst v e -> Subst v e > bindSubst :: Ord v => v -> e -> Subst v e -> Subst v e
> bindSubst v e (Subst comp sigma) = Subst comp $ Map.insert v e sigma > bindSubst v e (Subst comp sigma) = Subst comp $ Map.insert v e sigma
......
...@@ -10,7 +10,7 @@ This module implements substitutions on types. ...@@ -10,7 +10,7 @@ This module implements substitutions on types.
\begin{verbatim} \begin{verbatim}
> module Base.TypeSubst > module Base.TypeSubst
> ( module Base.TypeSubst, idSubst, bindSubst, compose > ( module Base.TypeSubst, idSubst, singleSubst, bindSubst, compose
> ) where > ) where
> import Data.List (nub) > import Data.List (nub)
......
...@@ -27,6 +27,19 @@ import qualified Checks.WarnCheck as WC (warnCheck) ...@@ -27,6 +27,19 @@ import qualified Checks.WarnCheck as WC (warnCheck)
import CompilerEnv import CompilerEnv
import CompilerOpts 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 -- TODO: More documentation
-- |Check the kinds of type definitions and signatures. -- |Check the kinds of type definitions and signatures.
...@@ -34,10 +47,10 @@ import CompilerOpts ...@@ -34,10 +47,10 @@ import CompilerOpts
-- * Declarations: Nullary type constructors and type variables are -- * Declarations: Nullary type constructors and type variables are
-- disambiguated -- disambiguated
-- * Environment: remains unchanged -- * Environment: remains unchanged
kindCheck :: CompilerEnv -> Module -> (CompilerEnv, Module) kindCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
kindCheck env (Module m es is ds) kindCheck env (Module m es is ds)
| null msgs = (env, Module m es is ds') | null msgs = CheckSuccess (env, Module m es is ds')
| otherwise = errorMessages msgs | otherwise = CheckFailed msgs
where (ds', msgs) = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds where (ds', msgs) = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
-- |Check for a correct syntax. -- |Check for a correct syntax.
...@@ -45,36 +58,37 @@ kindCheck env (Module m es is ds) ...@@ -45,36 +58,37 @@ kindCheck env (Module m es is ds)
-- * Declarations: Nullary data constructors and variables are -- * Declarations: Nullary data constructors and variables are
-- disambiguated -- disambiguated
-- * Environment: remains unchanged -- * Environment: remains unchanged
syntaxCheck :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module) syntaxCheck :: Options -> CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
syntaxCheck opts env (Module m es is ds) syntaxCheck opts env (Module m es is ds)
| null msgs = (env, Module m es is ds') | null msgs = CheckSuccess (env, Module m es is ds')
| otherwise = errorMessages msgs | otherwise = CheckFailed msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env) where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env)
(valueEnv env) (tyConsEnv env) ds (valueEnv env) (tyConsEnv env) ds
-- |Check the precedences of infix operators. -- |Check the precedences of infix operators.
-- In addition, the abstract syntax tree is rearranged to reflect the -- In addition, the abstract syntax tree is rearranged to reflect the
-- relative precedences; the operator precedence environment is updated. -- relative precedences; the operator precedence environment is updated.
precCheck :: CompilerEnv -> Module -> (CompilerEnv, Module) precCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
precCheck env (Module m es is ds) precCheck env (Module m es is ds)
| null msgs = (env { opPrecEnv = pEnv' }, Module m es is ds') | null msgs = CheckSuccess (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = errorMessages msgs | otherwise = CheckFailed msgs
where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
-- |Apply the correct typing of the module. -- |Apply the correct typing of the module.
-- The declarations remain unchanged; the type constructor and value -- The declarations remain unchanged; the type constructor and value
-- environments are updated. -- environments are updated.
typeCheck :: CompilerEnv -> Module -> (CompilerEnv, Module) typeCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
typeCheck env mdl@(Module _ _ _ ds) = typeCheck env mdl@(Module _ _ _ ds)
(env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl) | null msgs = CheckSuccess (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env) | otherwise = CheckFailed msgs
(tyConsEnv env) (valueEnv env) ds where (tcEnv', tyEnv', msgs) = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) ds
-- |Check the export specification -- |Check the export specification
exportCheck :: CompilerEnv -> Module -> (CompilerEnv, Module) exportCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
exportCheck env (Module m es is ds) exportCheck env (Module m es is ds)
| null msgs = (env, Module m es' is ds) | null msgs = CheckSuccess (env, Module m es' is ds)
| otherwise = errorMessages msgs | otherwise = CheckFailed msgs
where (es', msgs) = EC.exportCheck (moduleIdent env) (aliasEnv env) where (es', msgs) = EC.exportCheck (moduleIdent env) (aliasEnv env)
(tyConsEnv env) (valueEnv env) es (tyConsEnv env) (valueEnv env) es
......
This diff is collapsed.
...@@ -26,6 +26,7 @@ import Curry.Files.Filenames ...@@ -26,6 +26,7 @@ import Curry.Files.Filenames
import Curry.Files.PathUtils import Curry.Files.PathUtils
import Curry.Syntax (Module (..), parseModule) import Curry.Syntax (Module (..), parseModule)
import Checks
import CompilerEnv import CompilerEnv
import CompilerOpts (Options (..), Verbosity (..), TargetType (..), defaultOptions) import CompilerOpts (Options (..), Verbosity (..), TargetType (..), defaultOptions)
import CurryBuilder (smake) import CurryBuilder (smake)
...@@ -49,8 +50,7 @@ parse fn src = parseModule True fn src >>= genCurrySyntax fn ...@@ -49,8 +50,7 @@ parse fn src = parseModule True fn src >>= genCurrySyntax fn
be defined using the argument 'paths'. be defined using the argument 'paths'.
-} -}
fullParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad Module) fullParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad Module)
fullParse paths fn src = fullParse paths fn src = genFullCurrySyntax checkModule paths fn $ parse fn src
genFullCurrySyntax checkModule paths fn $ parse fn src
{- |Behaves like 'fullParse', but returns the syntax tree of the source {- |Behaves like 'fullParse', but returns the syntax tree of the source
program 'src' (type 'Module'; see Module "CurrySyntax") after inferring program 'src' (type 'Module'; see Module "CurrySyntax") after inferring
...@@ -68,7 +68,7 @@ genCurrySyntax fn mod1 ...@@ -68,7 +68,7 @@ genCurrySyntax fn mod1
-- --
genFullCurrySyntax :: genFullCurrySyntax ::
(Options -> CompilerEnv -> Module -> (CompilerEnv, Module)) (Options -> CompilerEnv -> Module -> CheckResult (CompilerEnv, Module))
-> [FilePath] -> FilePath -> MsgMonad Module -> IO (MsgMonad Module) -> [FilePath] -> FilePath -> MsgMonad Module -> IO (MsgMonad Module)
genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do
errs <- makeInterfaces paths fn mod1 errs <- makeInterfaces paths fn mod1
...@@ -76,8 +76,9 @@ genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do ...@@ -76,8 +76,9 @@ genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do
then do then do
iEnv <- loadInterfaces paths mod1 iEnv <- loadInterfaces paths mod1
let env = importModules opts mod1 iEnv let env = importModules opts mod1 iEnv
(_, mod') = check opts env mod1 case check opts env mod1 of
return (return mod') CheckSuccess (_, mod') -> return (return mod')
CheckFailed errs' -> return $ failWith $ msgTxt $ head errs'
else return $ failWith $ head errs else return $ failWith $ head errs
where opts = mkOpts paths where opts = mkOpts paths
......
...@@ -28,7 +28,7 @@ import Curry.ExtendedFlat.InterfaceEquality (eqInterface) ...@@ -28,7 +28,7 @@ import Curry.ExtendedFlat.InterfaceEquality (eqInterface)
import Curry.Files.Filenames import Curry.Files.Filenames
import Curry.Files.PathUtils import Curry.Files.PathUtils
import Base.Messages (abortWith, putErrsLn) import Base.Messages (abortWith, errorMessages, putErrsLn)
import Env.Eval (evalEnv) import Env.Eval (evalEnv)
import Env.Value (ppTypes) import Env.Value (ppTypes)
...@@ -62,11 +62,11 @@ import Transformations ...@@ -62,11 +62,11 @@ import Transformations
-- The untyped AbstractCurry representation is written -- The untyped AbstractCurry representation is written
-- out directly after parsing and simple checking the source file. -- out directly after parsing and simple checking the source file.
-- The typed AbstractCurry code is written out after checking the module. -- The typed AbstractCurry code is written out after checking the module.
-- --
-- The compiler automatically loads the prelude when compiling any -- The compiler automatically loads the prelude when compiling any
-- module, except for the prelude itself, by adding an appropriate import -- module, except for the prelude itself, by adding an appropriate import
-- declaration to the module. -- declaration to the module.
-- --
-- Since this modified version of the Muenster Curry Compiler is used -- Since this modified version of the Muenster Curry Compiler is used
-- as a frontend for PAKCS, all functions for evaluating goals and generating -- as a frontend for PAKCS, all functions for evaluating goals and generating
-- C code are obsolete and commented out. -- C code are obsolete and commented out.
...@@ -74,24 +74,26 @@ import Transformations ...@@ -74,24 +74,26 @@ import Transformations
compileModule :: Options -> FilePath -> IO () compileModule :: Options -> FilePath -> IO ()
compileModule opts fn = do compileModule opts fn = do
loaded <- loadModule opts fn loaded <- loadModule opts fn
let (env, modul) = uncurry (checkModule opts) loaded case uncurry (checkModule opts) loaded of
showWarnings opts $ uncurry warnCheck loaded CheckFailed errs -> errorMessages errs
writeParsed opts fn modul CheckSuccess (env, modul) -> do
writeAbstractCurry opts fn env modul showWarnings opts $ uncurry warnCheck loaded
when withFlat $ do writeParsed opts fn modul
-- checkModule checks types, and then transModule introduces new writeAbstractCurry opts fn env modul
-- functions (by lambda lifting in 'desugar'). Consequence: The when withFlat $ do
-- types of the newly introduced functions are not inferred (hsi) -- checkModule checks types, and then transModule introduces new
let (env2, il, dumps) = transModule opts env modul -- functions (by lambda lifting in 'desugar'). Consequence: The
-- dump intermediate results -- types of the newly introduced functions are not inferred (hsi)
mapM_ (doDump opts) dumps let (env2, il, dumps) = transModule opts env modul
-- generate target code -- dump intermediate results
let intf = exportInterface env2 modul mapM_ (doDump opts) dumps
let modSum = summarizeModule (tyConsEnv env2) intf modul -- generate target code
writeFlat opts fn env2 modSum il let intf = exportInterface env2 modul
where let modSum = summarizeModule (tyConsEnv env2) intf modul
withFlat = any (`elem` optTargetTypes opts) writeFlat opts fn env2 modSum il
[FlatCurry, FlatXml, ExtendedFlatCurry] where
withFlat = any (`elem` optTargetTypes opts)
[FlatCurry, FlatXml, ExtendedFlatCurry]
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- Loading a module -- Loading a module
...@@ -151,14 +153,16 @@ importPrelude opts m@(CS.Module mid es is ds) ...@@ -151,14 +153,16 @@ importPrelude opts m@(CS.Module mid es is ds)
-- Checking a module -- Checking a module
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
checkModule :: Options -> CompilerEnv -> CS.Module -> (CompilerEnv, CS.Module) -- TODO: The order of the checks should be improved!
checkModule opts env mdl = qualEnv checkModule :: Options -> CompilerEnv -> CS.Module
$ uncurry exportCheck -> CheckResult (CompilerEnv, CS.Module)
$ uncurry qual checkModule opts env mdl = kindCheck env mdl -- should be only syntax checking ?
$ (if withTypeCheck then uncurry typeCheck else id) >>= uncurry (syntaxCheck opts)
$ uncurry precCheck >>= uncurry precCheck
$ uncurry (syntaxCheck opts) >>= (if withTypeCheck then uncurry typeCheck else return)
$ kindCheck env mdl >>= return . (uncurry qual)
>>= uncurry exportCheck
>>= return . qualEnv
where where
qualEnv (e, m) = (qualifyEnv opts e, m) qualEnv (e, m) = (qualifyEnv opts e, m)
withTypeCheck = any (`elem` optTargetTypes opts) withTypeCheck = any (`elem` optTargetTypes opts)
...@@ -181,7 +185,7 @@ transModule opts env mdl = (env5, ilCaseComp, dumps) ...@@ -181,7 +185,7 @@ transModule opts env mdl = (env5, ilCaseComp, dumps)
(il , env4) = ilTrans flat' lifted env3 (il , env4) = ilTrans flat' lifted env3
(ilCaseComp, env5) = completeCase il env4 (ilCaseComp, env5) = completeCase il env4
dumps = [ (DumpRenamed , show $ CS.ppModule mdl ) dumps = [ (DumpRenamed , show $ CS.ppModule mdl )
, (DumpTypes , show $ ppTypes (moduleIdent env) (valueEnv env)) , (DumpTypes , show $ ppTypes (moduleIdent env) (valueEnv env))
, (DumpDesugared , show $ CS.ppModule desugared ) , (DumpDesugared , show $ CS.ppModule desugared )
, (DumpSimplified, show $ CS.ppModule simplified ) , (DumpSimplified, show $ CS.ppModule simplified )
, (DumpLifted , show $ CS.ppModule lifted ) , (DumpLifted , show $ CS.ppModule lifted )
...@@ -197,7 +201,7 @@ transModule opts env mdl = (env5, ilCaseComp, dumps) ...@@ -197,7 +201,7 @@ transModule opts env mdl = (env5, ilCaseComp, dumps)
-- flat and abstract curry representations depending on the specified option. -- flat and abstract curry representations depending on the specified option.
-- If the interface of a modified Curry module did not change, the -- If the interface of a modified Curry module did not change, the
-- corresponding file name will be returned within the result of 'genFlat' -- corresponding file name will be returned within the result of 'genFlat'
-- (depending on the compiler flag "force") and other modules importing this -- (depending on the compiler flag "force") and other modules importing this
-- module won't be dependent on it any longer. -- module won't be dependent on it any longer.
-- |Output the parsed 'Module' on request -- |Output the parsed 'Module' on request
...@@ -210,7 +214,7 @@ writeParsed opts fn modul = when srcTarget $ ...@@ -210,7 +214,7 @@ writeParsed opts fn modul = when srcTarget $
targetFile = fromMaybe (sourceRepName fn) (optOutput opts) targetFile = fromMaybe (sourceRepName fn) (optOutput opts)
source = CS.showModule modul source = CS.showModule modul
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
-> IO () -> IO ()
writeFlat opts fn env modSum il = do writeFlat opts fn env modSum il = do
writeFlatCurry opts fn env modSum il writeFlatCurry opts fn env modSum il
......
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