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)
(tyConsEnv env) (valueEnv env) ds
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)
......@@ -62,11 +62,11 @@ import Transformations
-- The untyped AbstractCurry representation is written
-- out directly after parsing and simple checking the source file.
-- The typed AbstractCurry code is written out after checking the module.
--
--
-- The compiler automatically loads the prelude when compiling any
-- module, except for the prelude itself, by adding an appropriate import
-- declaration to the module.
--
--
-- Since this modified version of the Muenster Curry Compiler is used
-- as a frontend for PAKCS, all functions for evaluating goals and generating
-- C code are obsolete and commented out.
......@@ -74,24 +74,26 @@ import Transformations
compileModule :: Options -> FilePath -> IO ()
compileModule opts fn = do
loaded <- loadModule opts fn
let (env, modul) = uncurry (checkModule opts) loaded
showWarnings opts $ uncurry warnCheck loaded
writeParsed opts fn modul
writeAbstractCurry opts fn env modul
when withFlat $ do
-- checkModule checks types, and then transModule introduces new
-- functions (by lambda lifting in 'desugar'). Consequence: The
-- types of the newly introduced functions are not inferred (hsi)
let (env2, il, dumps) = transModule opts env modul
-- dump intermediate results
mapM_ (doDump opts) dumps
-- generate target code
let intf = exportInterface env2 modul
let modSum = summarizeModule (tyConsEnv env2) intf modul
writeFlat opts fn env2 modSum il
where
withFlat = any (`elem` optTargetTypes opts)
[FlatCurry, FlatXml, ExtendedFlatCurry]
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
when withFlat $ do
-- checkModule checks types, and then transModule introduces new
-- functions (by lambda lifting in 'desugar'). Consequence: The
-- types of the newly introduced functions are not inferred (hsi)
let (env2, il, dumps) = transModule opts env modul
-- dump intermediate results
mapM_ (doDump opts) dumps
-- generate target code
let intf = exportInterface env2 modul
let modSum = summarizeModule (tyConsEnv env2) intf modul
writeFlat opts fn env2 modSum il
where
withFlat = any (`elem` optTargetTypes opts)
[FlatCurry, FlatXml, ExtendedFlatCurry]
-- ---------------------------------------------------------------------------
-- Loading a module
......@@ -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)
......@@ -181,7 +185,7 @@ transModule opts env mdl = (env5, ilCaseComp, dumps)
(il , env4) = ilTrans flat' lifted env3
(ilCaseComp, env5) = completeCase il env4
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 )
, (DumpSimplified, show $ CS.ppModule simplified )
, (DumpLifted , show $ CS.ppModule lifted )
......@@ -197,7 +201,7 @@ transModule opts env mdl = (env5, ilCaseComp, dumps)
-- flat and abstract curry representations depending on the specified option.
-- If the interface of a modified Curry module did not change, the
-- 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.
-- |Output the parsed 'Module' on request
......@@ -210,7 +214,7 @@ writeParsed opts fn modul = when srcTarget $
targetFile = fromMaybe (sourceRepName fn) (optOutput opts)
source = CS.showModule modul
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module
-> IO ()
writeFlat opts fn env modSum il = do
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