Split export check and expansion into separate functions

src/Checks.hs

@@ -14,7 +14,7 @@
 module Checks where
 
 import qualified Checks.InterfaceCheck as IC (interfaceCheck)
-import qualified Checks.ExportCheck    as EC (exportCheck)
+import qualified Checks.ExportCheck    as EC (exportCheck, expandExports)
 import qualified Checks.KindCheck      as KC (kindCheck)
 import qualified Checks.PrecCheck      as PC (precCheck)
 import qualified Checks.SyntaxCheck    as SC (syntaxCheck)
@@ -82,10 +82,17 @@ typeCheck _ (env, mdl@(Module _ _ _ _ ds))
 
 -- |Check the export specification
 exportCheck :: Monad m => Check m Module
-exportCheck _ (env, Module ps m es is ds)
-  | null msgs = ok (env, Module ps m es' is ds)
+exportCheck _ (env, mdl@(Module _ _ es _ _))
+  | null msgs = ok (env, mdl)
   | otherwise = failMessages msgs
-  where (es', msgs) = EC.exportCheck (moduleIdent env) (aliasEnv env)
+  where msgs = EC.exportCheck (moduleIdent env) (aliasEnv env)
+                              (tyConsEnv env) (valueEnv env) es
+
+-- |Check the export specification
+expandExports :: Monad m => Options -> CompEnv Module -> m (CompEnv Module)
+expandExports _ (env, Module ps m es is ds)
+  = return (env, Module ps m (Just es') is ds)
+  where es' = EC.expandExports (moduleIdent env) (aliasEnv env)
                                (tyConsEnv env) (valueEnv env) es
 
 -- |Check for warnings.

src/Checks/ExportCheck.hs

@@ -22,7 +22,7 @@
         list of sub-entities.
 -}
 {-# LANGUAGE CPP #-}
-module Checks.ExportCheck (exportCheck) where
+module Checks.ExportCheck (exportCheck, expandExports) where
 
 #if __GLASGOW_HASKELL__ < 710
 import           Control.Applicative        ((<$>))
@@ -55,17 +55,28 @@ import Env.Value           (ValueEnv, ValueInfo (..), qualLookupValueUnique)
 -- Check and expansion of the export statement
 -- ---------------------------------------------------------------------------
 
-exportCheck :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv
-            -> Maybe ExportSpec -> (Maybe ExportSpec, [Message])
-exportCheck m aEnv tcEnv tyEnv spec = case errs of
-  [] -> (Just $ Exporting (exportPos spec) es, checkNonUniqueness es)
-  ms -> (spec, ms)
+expandExports :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv
+              -> Maybe ExportSpec -> ExportSpec
+expandExports m aEnv tcEnv tyEnv spec = Exporting (exportPos spec) es
   where
   exportPos (Just (Exporting p _)) = p
   exportPos Nothing                = NoPos
 
-  (es, errs) = runECM ((joinExports . canonExports tcEnv) <$> expandSpec spec)
-                      initState
+  es = fst (checkAndExpand m aEnv tcEnv tyEnv spec)
+
+exportCheck :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv
+            -> Maybe ExportSpec -> [Message]
+exportCheck m aEnv tcEnv tyEnv spec = case errs of
+  [] -> checkNonUniqueness es
+  ms -> ms
+  where
+  (es, errs) = checkAndExpand m aEnv tcEnv tyEnv spec
+
+checkAndExpand :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv
+               -> Maybe ExportSpec -> ([Export], [Message])
+checkAndExpand m aEnv tcEnv tyEnv spec
+  = runECM ((joinExports . canonExports tcEnv) <$> expandSpec spec) initState
+  where
   initState  = ECState m imported tcEnv tyEnv []
   imported   = Set.fromList (Map.elems aEnv)
 

src/Modules.hs

@@ -199,15 +199,8 @@ checkModule opts mdl = do
   sc <- syntaxCheck opts kc  >>= dumpCS DumpSyntaxChecked
   pc <- precCheck   opts sc  >>= dumpCS DumpPrecChecked
   tc <- typeCheck   opts pc  >>= dumpCS DumpTypeChecked
-  -- TODO: This is a workaround to avoid the expansion of the export
-  -- specification for generating the HTML listing. If a module does not
-  -- contain an export specification, the check generates one which leads
-  -- to a mismatch between the identifiers from the lexer and those in the
-  -- resulting module.
-  -- Therefore, it would be better if checking and expansion are separated.
-  if null (optTargetTypes opts)
-    then return tc
-    else exportCheck opts tc >>= dumpCS DumpExportChecked
+  ec <- exportCheck opts tc  >>= dumpCS DumpExportChecked
+  return ec
   where dumpCS = dumpWith opts CS.ppModule
 
 -- ---------------------------------------------------------------------------
@@ -236,7 +229,8 @@ transModule opts mdl = do
 writeOutput :: Options -> FilePath -> CompEnv CS.Module -> IO ()
 writeOutput opts fn mdl@(_, modul) = do
   writeParsed opts fn modul
-  qmdl <- dumpWith opts CS.ppModule DumpQualified $ qual mdl
+  mdl' <- expandExports opts mdl
+  qmdl <- dumpWith opts CS.ppModule DumpQualified $ qual mdl'
   writeAbstractCurry opts fn qmdl
   -- generate interface file
   let intf = uncurry exportInterface qmdl