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).
\begin{verbatim}
> module Base.Subst
> ( Subst (..), IntSubst (..), idSubst, substToList, bindSubst, unbindSubst
> , compose, substVar', isubstVar, restrictSubstTo
> ( Subst (..), IntSubst (..), idSubst, singleSubst, bindSubst, unbindSubst
> , substToList, compose, substVar', isubstVar, restrictSubstTo
> ) where
> import qualified Data.Map as Map
......@@ -27,6 +27,9 @@ marked with a boolean flag (see below).
> substToList :: Ord v => Subst v e -> [(v, e)]
> 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 v e (Subst comp sigma) = Subst comp $ Map.insert v e sigma
......
......@@ -10,7 +10,7 @@ This module implements substitutions on types.
\begin{verbatim}
> module Base.TypeSubst
> ( module Base.TypeSubst, idSubst, bindSubst, compose
> ( module Base.TypeSubst, idSubst, singleSubst, bindSubst, compose
> ) where
> import Data.List (nub)
......
......@@ -27,6 +27,19 @@ 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
-- |Check the kinds of type definitions and signatures.
......@@ -34,10 +47,10 @@ import CompilerOpts
-- * Declarations: Nullary type constructors and type variables are
-- disambiguated
-- * Environment: remains unchanged
kindCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
kindCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
kindCheck env (Module m es is ds)
| null msgs = (env, Module m es is ds')
| otherwise = errorMessages msgs
| null msgs = CheckSuccess (env, Module m es is ds')
| otherwise = CheckFailed msgs
where (ds', msgs) = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
-- |Check for a correct syntax.
......@@ -45,36 +58,37 @@ kindCheck env (Module m es is ds)
-- * Declarations: Nullary data constructors and variables are
-- disambiguated
-- * Environment: remains unchanged
syntaxCheck :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module)
syntaxCheck :: Options -> CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
syntaxCheck opts env (Module m es is ds)
| null msgs = (env, Module m es is ds')
| otherwise = errorMessages msgs
| null msgs = CheckSuccess (env, Module m es is ds')
| otherwise = CheckFailed msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env)
(valueEnv env) (tyConsEnv env) ds
-- |Check the precedences of infix operators.
-- In addition, the abstract syntax tree is rearranged to reflect the
-- 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)
| null msgs = (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = errorMessages msgs
| null msgs = CheckSuccess (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = CheckFailed 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 -> (CompilerEnv, Module)
typeCheck env mdl@(Module _ _ _ ds) =
(env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env)
typeCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
typeCheck env mdl@(Module _ _ _ ds)
| null msgs = CheckSuccess (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
| otherwise = CheckFailed msgs
where (tcEnv', tyEnv', msgs) = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) ds
-- |Check the export specification
exportCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
exportCheck :: CompilerEnv -> Module -> CheckResult (CompilerEnv, Module)
exportCheck env (Module m es is ds)
| null msgs = (env, Module m es' is ds)
| otherwise = errorMessages msgs
| null msgs = CheckSuccess (env, Module m es' is ds)
| otherwise = CheckFailed msgs
where (es', msgs) = EC.exportCheck (moduleIdent env) (aliasEnv env)
(tyConsEnv env) (valueEnv env) es
......
This diff is collapsed.
......@@ -26,6 +26,7 @@ import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax (Module (..), parseModule)
import Checks
import CompilerEnv
import CompilerOpts (Options (..), Verbosity (..), TargetType (..), defaultOptions)
import CurryBuilder (smake)
......@@ -49,8 +50,7 @@ parse fn src = parseModule True fn src >>= genCurrySyntax fn
be defined using the argument 'paths'.
-}
fullParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad Module)
fullParse paths fn src =
genFullCurrySyntax checkModule paths fn $ parse fn src
fullParse paths fn src = genFullCurrySyntax checkModule paths fn $ parse fn src
{- |Behaves like 'fullParse', but returns the syntax tree of the source
program 'src' (type 'Module'; see Module "CurrySyntax") after inferring
......@@ -68,7 +68,7 @@ genCurrySyntax fn mod1
--
genFullCurrySyntax ::
(Options -> CompilerEnv -> Module -> (CompilerEnv, Module))
(Options -> CompilerEnv -> Module -> CheckResult (CompilerEnv, Module))
-> [FilePath] -> FilePath -> MsgMonad Module -> IO (MsgMonad Module)
genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do
errs <- makeInterfaces paths fn mod1
......@@ -76,8 +76,9 @@ genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do
then do
iEnv <- loadInterfaces paths mod1
let env = importModules opts mod1 iEnv
(_, mod') = check opts env mod1
return (return mod')
case check opts env mod1 of
CheckSuccess (_, mod') -> return (return mod')
CheckFailed errs' -> return $ failWith $ msgTxt $ head errs'
else return $ failWith $ head errs
where opts = mkOpts paths
......
......@@ -28,7 +28,7 @@ import Curry.ExtendedFlat.InterfaceEquality (eqInterface)
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Base.Messages (abortWith, putErrsLn)
import Base.Messages (abortWith, errorMessages, putErrsLn)
import Env.Eval (evalEnv)
import Env.Value (ppTypes)
......@@ -74,7 +74,9 @@ import Transformations
compileModule :: Options -> FilePath -> IO ()
compileModule opts fn = do
loaded <- loadModule opts fn
let (env, modul) = uncurry (checkModule opts) loaded
case uncurry (checkModule opts) loaded of
CheckFailed errs -> errorMessages errs
CheckSuccess (env, modul) -> do
showWarnings opts $ uncurry warnCheck loaded
writeParsed opts fn modul
writeAbstractCurry opts fn env modul
......@@ -151,14 +153,16 @@ importPrelude opts m@(CS.Module mid es is ds)
-- Checking a module
-- ---------------------------------------------------------------------------
checkModule :: Options -> CompilerEnv -> CS.Module -> (CompilerEnv, CS.Module)
checkModule opts env mdl = qualEnv
$ uncurry exportCheck
$ uncurry qual
$ (if withTypeCheck then uncurry typeCheck else id)
$ uncurry precCheck
$ uncurry (syntaxCheck opts)
$ kindCheck env mdl
-- TODO: The order of the checks should be improved!
checkModule :: Options -> CompilerEnv -> CS.Module
-> CheckResult (CompilerEnv, CS.Module)
checkModule opts env mdl = kindCheck env mdl -- should be only syntax checking ?
>>= uncurry (syntaxCheck opts)
>>= uncurry precCheck
>>= (if withTypeCheck then uncurry typeCheck else return)
>>= return . (uncurry qual)
>>= uncurry exportCheck
>>= return . qualEnv
where
qualEnv (e, m) = (qualifyEnv opts e, m)
withTypeCheck = any (`elem` optTargetTypes opts)
......
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