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

Checks improved

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