Checks improved

src/Checks.hs

@@ -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

src/Checks/TypeCheck.lhs

@@ -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)

src/Checks/WarnCheck.hs

@@ -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)
 
 

src/CompilerOpts.hs

@@ -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 =

src/Modules.lhs

@@ -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}