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

Checks improved

parent 6bef7507
......@@ -13,8 +13,9 @@
-}
module Checks where
import Curry.Base.MessageMonad (Message)
import Curry.Syntax
import Curry.Syntax (Module (..))
import Base.Messages
import qualified Checks.KindCheck as KC (kindCheck)
import qualified Checks.PrecCheck as PC (precCheck)
......@@ -25,36 +26,51 @@ import qualified Checks.WarnCheck as WC (warnCheck)
import CompilerEnv
import CompilerOpts
data CheckStatus a
= CheckFailed [Message]
| CheckSuccess a
instance Monad CheckStatus where
return = CheckSuccess
m >>= f = case m of
CheckFailed errs -> CheckFailed errs
CheckSuccess a -> f a
-- TODO: More documentation
-- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished
kindCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
kindCheck (Module m es is ds) env = (Module m es is ds', env)
where ds' = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
kindCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
kindCheck env (Module m es is ds)
| null msgs = (env, Module m es is ds')
| otherwise = errorMessages msgs
where (ds', msgs) = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
-- |Apply the precendences of infix operators.
-- This function reanrranges the AST.
precCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
precCheck (Module m es is ds) env = (Module m es is ds', env { opPrecEnv = pEnv' })
where (pEnv', ds') = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
precCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
precCheck env (Module m es is ds)
| null msgs = (env { opPrecEnv = pEnv' }, Module m es is ds')
| otherwise = errorMessages msgs
where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
-- |Apply the syntax check.
syntaxCheck :: Options -> Module -> CompilerEnv -> (Module, CompilerEnv)
syntaxCheck opts (Module m es is ds) env = (Module m es is ds', env)
where ds' = SC.syntaxCheck withExt (moduleIdent env) (aliasEnv env)
syntaxCheck :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module)
syntaxCheck opts env (Module m es is ds)
| null msgs = (env, Module m es is ds')
| otherwise = errorMessages msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env) (aliasEnv env)
(arityEnv env) (valueEnv env) (tyConsEnv env) ds
withExt = BerndExtension `elem` optExtensions opts
-- |Apply the type check.
typeCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
typeCheck mdl@(Module _ _ _ ds) env = (mdl, env { tyConsEnv = tcEnv', valueEnv = tyEnv' })
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
-- TODO: Which kind of warnings?
-- |Check for warnings.
warnCheck :: Module -> CompilerEnv -> [Message]
warnCheck (Module _ _ is ds) env
warnCheck :: CompilerEnv -> Module -> [Message]
warnCheck env (Module _ _ is ds)
= WC.warnCheck (moduleIdent env) (valueEnv env) is ds
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
......@@ -39,11 +39,11 @@ type annotation is present.
> import Base.Expr
> import Base.Messages (errorAt, errorAt', internalError)
> import Base.SCC
> import Base.TopEnv
> import Base.Types
> import Base.TypeSubst
> import Base.Utils (foldr2)
> import Env.TopEnv
> import Env.TypeConstructors (TCEnv, TypeInfo (..), bindTypeInfo, qualLookupTC)
> import Env.Value ( ValueEnv, ValueInfo (..), bindFun, rebindFun
> , bindGlobalInfo, bindLabel, lookupValue, qualLookupValue )
......@@ -1246,17 +1246,18 @@ know that they are closed.
Miscellaneous functions.
\begin{verbatim}
> remove :: Eq a => a -> [(a,b)] -> [(a,b)]
> remove _ [] = []
> remove k ((k',e):kes) | k == k' = kes
> | otherwise = (k',e):(remove k kes)
> remove :: Eq a => a -> [(a, b)] -> [(a, b)]
> remove _ [] = []
> remove k (kv : kvs)
> | k == fst kv = kvs
> | otherwise = kv : remove k kvs
\end{verbatim}
Error functions.
\begin{verbatim}
> recursiveTypes :: [Ident] -> (Position,String)
> recursiveTypes [] = error "TypeCheck.recursiveTypes: empty list"
> recursiveTypes [] = error "TypeCheck.recursiveTypes: empty list"
> recursiveTypes [tc] =
> (positionOfIdent tc,
> "Recursive synonym type " ++ name tc)
......
......@@ -23,7 +23,8 @@ import Curry.Base.Position
import Curry.Base.MessageMonad
import Curry.Syntax
import qualified Env.ScopeEnv as ScopeEnv
import qualified Base.ScopeEnv as ScopeEnv
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
......
......@@ -42,7 +42,7 @@ data Options = Options
, optOverlapWarn :: Bool -- ^ show "overlap" warnings
, optTargetTypes :: [TargetType] -- ^ what to generate
, optExtensions :: [Extension] -- ^ enabled language extensions
, optDumps :: [DumpLevel] -- ^ dumps
, optDumps :: [DumpLevel] -- ^ dump levels
}
-- | Default compiler options
......@@ -85,9 +85,6 @@ classifyVerbosity :: String -> Verbosity
classifyVerbosity "0" = Quiet
classifyVerbosity _ = Verbose
-- TODO: dump FlatCurry code, dump AbstractCurry code, dump after 'case'
-- expansion
-- |Data type for representing code dumps
data DumpLevel
= DumpRenamed -- ^ dump source after renaming
......@@ -96,7 +93,7 @@ data DumpLevel
| DumpSimplified -- ^ dump source after simplification
| DumpLifted -- ^ dump source after lambda-lifting
| DumpIL -- ^ dump IL code after translation
| DumpCase -- ^ dump IL code after case elimination
| DumpCase -- ^ dump IL code after case completion
deriving (Eq, Bounded, Enum, Show)
-- |All available 'DumpLevel's
......@@ -105,14 +102,17 @@ dumpAll = [minBound .. maxBound]
-- |Data type representing language extensions
data Extension
= BerndExtension -- TODO: Give it a more concise name
| Records
| FunctionPatterns
= Records
| FunctionalPatterns
| AnonymousFreeVariables
| NoImplicitPrelude
| UnknownExtension String
deriving (Eq, Read, Show)
-- |'Extension's available by @-e@ flag
pakcsExtensions :: [Extension]
pakcsExtensions = [Records, FunctionalPatterns]
-- |Classifies a 'String' as an 'Extension'
classifyExtension :: String -> Extension
classifyExtension str = case reads str of
......@@ -190,7 +190,7 @@ options =
-- extensions
, Option "e" ["extended"]
(NoArg (\ opts -> opts { optExtensions =
nub $ BerndExtension : optExtensions opts }))
nub $ pakcsExtensions ++ optExtensions opts }))
"enable extended Curry functionalities"
, Option "X" []
(ReqArg (\ arg opts -> opts { optExtensions =
......
......@@ -21,7 +21,7 @@ This module controls the compilation of modules.
\begin{verbatim}
> module Modules
> ( compileModule, loadModule, checkModuleHeader, simpleCheckModule, checkModule
> ( compileModule, loadModule, checkModuleHeader, checkModule
> ) where
> import Control.Monad (liftM, unless, when)
......@@ -83,34 +83,23 @@ code are obsolete and commented out.
> compileModule :: Options -> FilePath -> IO ()
> compileModule opts fn = do
> (env, mdl) <- loadModule opts fn
> if not withFlat
> then do
> let (env2, modul, _intf, warnMsgs) = simpleCheckModule opts env mdl
> showWarnings opts warnMsgs
> -- output the parsed source
> writeParsed opts fn modul
> -- output AbstractCurry
> writeAbstractCurry opts fn env2 modul
> else 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, modul, intf, warnMsgs) = checkModule opts env mdl
> showWarnings opts warnMsgs
> writeParsed opts fn modul
> writeAbstractCurry opts fn env2 modul
> let (env3, il, dumps) = transModule opts env2 modul
> -- dump intermediate results
> mapM_ (doDump opts) dumps
> -- generate target code
> let modSum = summarizeModule (tyConsEnv env3) intf modul
> writeFlat opts fn env3 modSum il
> (env, modul, intf, warnings) <- uncurry (checkModule opts) `liftM` loadModule opts fn
> showWarnings opts $ warnings
> 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 modSum = summarizeModule (tyConsEnv env2) intf modul
> writeFlat opts fn env2 modSum il
> where
> fcyTarget = FlatCurry `elem` optTargetTypes opts
> xmlTarget = FlatXml `elem` optTargetTypes opts
> extTarget = ExtendedFlatCurry `elem` optTargetTypes opts
> withFlat = or [fcyTarget, xmlTarget, extTarget]
> withFlat = any (`elem` optTargetTypes opts)
> [FlatCurry, FlatXml, ExtendedFlatCurry]
-- ---------------------------------------------------------------------------
-- Loading a module
......@@ -185,38 +174,22 @@ Haskell and original MCC where a module obtains \texttt{main}).
-- Checking a module
-- ---------------------------------------------------------------------------
> -- |
> simpleCheckModule :: Options -> CompilerEnv -> CS.Module
> -> (CompilerEnv, CS.Module, CS.Interface, [Message])
> simpleCheckModule opts env mdl = (env3, mdl2, intf, warnMsgs)
> where
> -- check for warnings
> warnMsgs = warnCheck mdl env
> -- check kinds, syntax, precedence
> (mdl2, env2) = uncurry qual
> $ uncurry precCheck
> $ uncurry (syntaxCheck opts)
> $ uncurry kindCheck
> (mdl, env)
> env3 = qualifyEnv opts env2
> intf = exportInterface env3 mdl2
> checkModule :: Options -> CompilerEnv -> CS.Module
> -> (CompilerEnv, CS.Module, CS.Interface, [Message])
> checkModule opts env mdl = (env3, mdl3, intf, warnMsgs)
> checkModule opts env mdl = (env', mdl', intf, warnings)
> where
> -- check for warnings
> warnMsgs = warnCheck mdl env
> -- check kinds, syntax, precedence, types
> (mdl2, env2) = uncurry qual
> $ uncurry typeCheck
> warnings = warnCheck env mdl
> intf = exportInterface env' mdl'
> (env', mdl') = qualifyE $ expand $ uncurry qual
> $ (if withFlat then uncurry typeCheck else id)
> $ uncurry precCheck
> $ uncurry (syntaxCheck opts)
> $ uncurry kindCheck
> (mdl, env)
> mdl3 = expandInterface env2 $ mdl2
> env3 = qualifyEnv opts env2
> intf = exportInterface env3 mdl3
> (env, mdl)
> expand (e, m) = if withFlat then (e, expandInterface e m) else (e, m)
> qualifyE (e, m) = (qualifyEnv opts e, m)
> withFlat = any (`elem` optTargetTypes opts)
> [FlatCurry, FlatXml, ExtendedFlatCurry]
-- ---------------------------------------------------------------------------
-- Translating a module
......@@ -266,8 +239,7 @@ be dependent on it any longer.
> targetFile = fromMaybe (sourceRepName fn) (optOutput opts)
> source = CS.showModule modul
> writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary
> -> IL.Module -> IO ()
> writeFlat :: Options -> FilePath -> CompilerEnv -> ModuleSummary -> IL.Module -> IO ()
> writeFlat opts fn env modSum il = do
> writeFlatCurry opts fn env modSum il
> writeInterface opts fn env modSum il
......@@ -289,8 +261,9 @@ be dependent on it any longer.
> writeInterface :: Options -> FilePath -> CompilerEnv -> ModuleSummary
> -> IL.Module -> IO ()
> writeInterface opts fn env modSum il
> | optForce opts = outputInterface
> | otherwise = do
> | not (optInterface opts) = return ()
> | optForce opts = outputInterface
> | otherwise = do
> mfint <- EF.readFlatInterface targetFile
> let oldInterface = fromMaybe emptyIntf mfint
> when (mfint == mfint) $ return () -- necessary to close file -- TODO
......@@ -345,6 +318,6 @@ standard output.
> dumpHeader DumpSimplified = "Source code after simplification"
> dumpHeader DumpLifted = "Source code after lifting"
> dumpHeader DumpIL = "Intermediate code"
> dumpHeader DumpCase = "Intermediate code after case simplification"
> dumpHeader DumpCase = "Intermediate code after case completion"
\end{verbatim}
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