small refactorings

src/Checks.hs

@@ -39,22 +39,17 @@ instance Monad CheckStatus where
 -- TODO: More documentation
 
 -- |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
+-- disambiguated in the declarations; the environment remains unchanged.
 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 :: 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.
+-- |Check for a correct syntax.
+-- In addition, nullary data constructors and variables are
+-- disambiguated in the declarations; the environment remains unchanged.
 syntaxCheck :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module)
 syntaxCheck opts env (Module m es is ds)
   | null msgs = (env, Module m es is ds')
@@ -62,7 +57,18 @@ syntaxCheck opts env (Module m es is ds)
   where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env) (aliasEnv env)
                    (arityEnv env) (valueEnv env) (tyConsEnv env) ds
 
--- |Apply the type check.
+-- |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 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 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)
@@ -72,5 +78,4 @@ typeCheck env mdl@(Module _ _ _ ds) = (env { tyConsEnv = tcEnv', valueEnv = tyEn
 
 -- |Check for warnings.
 warnCheck :: CompilerEnv -> Module -> [Message]
-warnCheck env (Module _ _ is ds)
-  = WC.warnCheck (moduleIdent env) (valueEnv env) is ds
+warnCheck env mdl = WC.warnCheck (valueEnv env) mdl

src/Checks/PrecCheck.lhs

@@ -30,7 +30,8 @@ of the operators involved.
 > import Base.Messages (Message, toMessage)
 > import Base.Utils (findDouble)
 
-> import Env.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP, qualLookupP)
+> import Env.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
+>   , qualLookupP)
 
 > precCheck :: ModuleIdent -> PEnv -> [Decl] -> ([Decl], PEnv, [Message])
 > precCheck m pEnv decls = runPCM (checkDecls decls) initState
@@ -58,14 +59,14 @@ The Prec check monad.
 > getPrecEnv :: PCM PEnv
 > getPrecEnv = S.gets precEnv
 
-> withPrecEnv :: (PEnv -> PEnv) -> PCM ()
-> withPrecEnv f = S.modify $ \ s -> s { precEnv = f $ precEnv s }
+> modifyPrecEnv :: (PEnv -> PEnv) -> PCM ()
+> modifyPrecEnv f = S.modify $ \ s -> s { precEnv = f $ precEnv s }
 
 > withLocalPrecEnv :: PCM a -> PCM a
 > withLocalPrecEnv act = do
 >   oldEnv <- getPrecEnv
 >   res <- act
->   withPrecEnv $ const oldEnv
+>   modifyPrecEnv $ const oldEnv
 >   return res
 
 > report :: Message -> PCM ()
@@ -83,10 +84,10 @@ imported precedence environment.
 > bindPrecs ds = case findDouble opFixDecls of
 >   Just op -> report $ errDuplicatePrecedence op
 >   Nothing -> case filter (`notElem` bvs) opFixDecls of
->     op : _ -> report $  errUndefinedOperator op
+>     op : _ -> report $ errUndefinedOperator op
 >     []     -> do
 >       m <- getModuleIdent
->       withPrecEnv $ \ env -> foldr (bindPrec m) env fixDs
+>       modifyPrecEnv $ \ env -> foldr (bindPrec m) env fixDs
 >   where
 >     (fixDs, nonFixDs) = partition isInfixDecl ds
 >     opFixDecls        = [ op | InfixDecl _ _ _ ops <- fixDs, op <- ops]
@@ -137,12 +138,11 @@ interface.
 >   liftM2 (Equation p) (checkLhs lhs) (checkRhs rhs)
 
 > checkLhs :: Lhs -> PCM Lhs
-> checkLhs (FunLhs f ts) = FunLhs f `liftM` mapM checkConstrTerm ts
+> checkLhs (FunLhs    f ts) = FunLhs f `liftM` mapM checkConstrTerm ts
 > checkLhs (OpLhs t1 op t2) =
->   liftM2 (\u1 u2 -> OpLhs u1 op u2) t1' t2'
->   where t1' = (checkConstrTerm t1 >>= checkOpL op)
->         t2' = (checkConstrTerm t2 >>= checkOpR op)
-> checkLhs (ApLhs lhs ts) =
+>   liftM2 (flip OpLhs op) (checkConstrTerm t1 >>= checkOpL op)
+>                          (checkConstrTerm t2 >>= checkOpR op)
+> checkLhs (ApLhs   lhs ts) =
 >   liftM2 ApLhs (checkLhs lhs) (mapM checkConstrTerm ts)
 
 > checkConstrTerm :: ConstrTerm -> PCM ConstrTerm

src/Checks/TypeCheck.lhs

@@ -64,13 +64,13 @@ constructor and type environments.
 \begin{verbatim}
 
 > typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv, ValueEnv)
-> typeCheck m tcEnv tyEnv ds =
->   run (tcDecls m tcEnv' Map.empty vds >>
+> typeCheck m tcEnv tyEnv decls =
+>   run (tcDecls m tcEnv' Map.empty valueDecls >>
 >        S.lift S.get >>= \theta -> S.get >>= \tyEnv' ->
->        return (tcEnv',subst theta tyEnv'))
->       (bindLabels m tcEnv' (bindConstrs m tcEnv' tyEnv))
->   where (tds,vds) = partition isTypeDecl ds
->         tcEnv' = bindTypes m tds tcEnv
+>        return (tcEnv', subst theta tyEnv'))
+>       (bindLabels m tcEnv' (bindConstrs m tcEnv' tyEnv)) -- initEnv
+>   where (typeDecls, valueDecls) = partition isTypeDecl decls
+>         tcEnv'                  = bindTypes m typeDecls tcEnv
 
 \end{verbatim}
 
@@ -172,19 +172,19 @@ have been properly renamed and all type synonyms are already expanded.
 \begin{verbatim}
 
 > bindConstrs :: ModuleIdent -> TCEnv -> ValueEnv -> ValueEnv
-> bindConstrs m tcEnv tyEnv =
->   foldr (bindData . snd) tyEnv (localBindings tcEnv)
->   where bindData (DataType tc n cs) tyEnv' =
->           foldr (bindConstr m n (constrType' tc n)) tyEnv' (catMaybes cs)
->         bindData (RenamingType tc n (DataConstr c n' [ty])) tyEnv' =
->           bindGlobalInfo NewtypeConstructor m c
->                          (ForAllExist n n' (TypeArrow ty (constrType' tc n)))
->                          tyEnv'
->         bindData (AliasType _ _ _) tyEnv' = tyEnv'
->         bindConstr m' n ty (DataConstr c n' tys) =
->           bindGlobalInfo DataConstructor m' c
->                          (ForAllExist n n' (foldr TypeArrow ty tys))
->         constrType' tc n = TypeConstructor tc (map TypeVariable [0..n-1])
+> bindConstrs m tcEnv tyEnv = foldr (bindData . snd) tyEnv (localBindings tcEnv)
+>   where
+>     bindData (DataType tc n cs) tyEnv' =
+>       foldr (bindConstr m n (constrType' tc n)) tyEnv' (catMaybes cs)
+>     bindData (RenamingType tc n (DataConstr c n' [ty])) tyEnv' =
+>       bindGlobalInfo NewtypeConstructor m c
+>                      (ForAllExist n n' (TypeArrow ty (constrType' tc n)))
+>                      tyEnv'
+>     bindData (AliasType _ _ _) tyEnv' = tyEnv'
+>     bindConstr m' n ty (DataConstr c n' tys) =
+>       bindGlobalInfo DataConstructor m' c
+>                      (ForAllExist n n' (foldr TypeArrow ty tys))
+>     constrType' tc n = TypeConstructor tc (map TypeVariable [0..n-1])
 
 \end{verbatim}
 \paragraph{Defining Field Labels}

src/CompilerEnv.hs

@@ -39,7 +39,7 @@ data CompilerEnv = CompilerEnv
   , labelEnv     :: LabelEnv     -- ^ record labels
   , opPrecEnv    :: PEnv         -- ^ operator precedences
   , tyConsEnv    :: TCEnv        -- ^ type constructors
-  , valueEnv     :: ValueEnv     -- ^ functions, ...
+  , valueEnv     :: ValueEnv     -- ^ functions and data constructors
   }
 
 initCompilerEnv :: ModuleIdent -> CompilerEnv

src/Frontend.hs

@@ -24,7 +24,7 @@ import Control.Monad.Writer
 import Curry.Base.MessageMonad
 import Curry.Files.Filenames
 import Curry.Files.PathUtils
-import Curry.Syntax (Module (..), Interface, parseModule)
+import Curry.Syntax (Module (..), parseModule)
 
 import CompilerEnv
 import CompilerOpts (Options (..), Verbosity (..), TargetType (..), defaultOptions)
@@ -68,7 +68,7 @@ genCurrySyntax fn mod1
 
 --
 genFullCurrySyntax ::
-  (Options -> CompilerEnv -> Module -> (CompilerEnv, Module, Interface, [Message]))
+  (Options -> CompilerEnv -> Module -> (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,8 @@ genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do
     then do
       iEnv <- loadInterfaces paths mod1
       let env = importModules opts mod1 iEnv
-          (_, mod', _, msgs) = check opts env mod1
-      return (tell msgs >> return  mod')
+          (_, mod') = check opts env mod1
+      return (return  mod')
     else return $ failWith $ head errs
   where opts = mkOpts paths
 

src/Imports.hs

@@ -39,10 +39,6 @@ import CompilerEnv
 import CompilerOpts
 import Records (importLabels, recordExpansion1, recordExpansion2)
 
--- ---------------------------------------------------------------------------
--- Interface
--- ---------------------------------------------------------------------------
-
 -- |The function 'importModules' brings the declarations of all
 -- imported interfaces into scope for the current module.
 importModules :: Options -> Module -> InterfaceEnv -> CompilerEnv
@@ -61,15 +57,6 @@ importModules opts (Module mid _ imps _) iEnv
       Nothing   -> internalError $ "Imports.importModules: no interface for "
                                    ++ show m
 
--- |
-qualifyEnv :: Options -> CompilerEnv -> CompilerEnv
-qualifyEnv opts env = recordExpansion2 opts
-                    $ qualifyLocal env
-                    $ foldl (flip importInterfaceIntf) initEnv
-                    $ Map.elems
-                    $ interfaceEnv env
-  where initEnv = initCompilerEnv $ moduleIdent env
-
 -- ---------------------------------------------------------------------------
 -- Importing an interface into the module
 -- ---------------------------------------------------------------------------
@@ -390,6 +377,15 @@ importUnifyData' tcEnv = fmap (setInfo allTyCons) tcEnv
 
 -- ---------------------------------------------------------------------------
 
+-- |
+qualifyEnv :: Options -> CompilerEnv -> CompilerEnv
+qualifyEnv opts env = recordExpansion2 opts
+                    $ qualifyLocal env
+                    $ foldl (flip importInterfaceIntf) initEnv
+                    $ Map.elems
+                    $ interfaceEnv env
+  where initEnv = initCompilerEnv $ moduleIdent env
+
 qualifyLocal :: CompilerEnv -> CompilerEnv -> CompilerEnv
 qualifyLocal currentEnv initEnv = currentEnv
   { opPrecEnv = foldr bindQual   pEnv  $ localBindings $ opPrecEnv currentEnv

src/Modules.lhs

@@ -83,8 +83,9 @@ code are obsolete and commented out.
 
 > compileModule :: Options -> FilePath -> IO ()
 > compileModule opts fn = do
->   (env, modul, intf, warnings) <- uncurry (checkModule opts) `liftM` loadModule opts fn
->   showWarnings opts $ warnings
+>   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
@@ -95,6 +96,7 @@ code are obsolete and commented out.
 >     -- dump intermediate results
 >     mapM_ (doDump opts) dumps
 >     -- generate target code
+>     let intf = exportInterface env modul
 >     let modSum = summarizeModule (tyConsEnv env2) intf modul
 >     writeFlat opts fn env2 modSum il
 >   where
@@ -174,22 +176,19 @@ Haskell and original MCC where a module obtains \texttt{main}).
 -- Checking a module
 -- ---------------------------------------------------------------------------
 
-> checkModule :: Options -> CompilerEnv -> CS.Module
->             -> (CompilerEnv, CS.Module, CS.Interface, [Message])
-> checkModule opts env mdl = (env', mdl', intf, warnings)
+> checkModule :: Options -> CompilerEnv -> CS.Module -> (CompilerEnv, CS.Module)
+> checkModule opts env mdl = qualifyEnvs
+>                          $ expand
+>                          $ uncurry qual
+>                          $ (if withFlat then uncurry typeCheck else id)
+>                          $ uncurry precCheck
+>                          $ uncurry (syntaxCheck opts)
+>                          $ kindCheck env mdl
 >   where
->     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
->                    (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]
+>   expand      (e, m) = if withFlat then (e, expandInterface e m) else (e, m)
+>   qualifyEnvs (e, m) = (qualifyEnv opts e, m)
+>   withFlat           = any (`elem` optTargetTypes opts)
+>                            [FlatCurry, FlatXml, ExtendedFlatCurry]
 
 -- ---------------------------------------------------------------------------
 -- Translating a module