Commit 2a3be814 authored by Björn Peemöller 's avatar Björn Peemöller

Split export check and expansion into separate functions

parent 4b003317
......@@ -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.
......
......@@ -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)
......
......@@ -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
......
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