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 @@ ...@@ -14,7 +14,7 @@
module Checks where module Checks where
import qualified Checks.InterfaceCheck as IC (interfaceCheck) 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.KindCheck as KC (kindCheck)
import qualified Checks.PrecCheck as PC (precCheck) import qualified Checks.PrecCheck as PC (precCheck)
import qualified Checks.SyntaxCheck as SC (syntaxCheck) import qualified Checks.SyntaxCheck as SC (syntaxCheck)
...@@ -82,11 +82,18 @@ typeCheck _ (env, mdl@(Module _ _ _ _ ds)) ...@@ -82,11 +82,18 @@ typeCheck _ (env, mdl@(Module _ _ _ _ ds))
-- |Check the export specification -- |Check the export specification
exportCheck :: Monad m => Check m Module exportCheck :: Monad m => Check m Module
exportCheck _ (env, Module ps m es is ds) exportCheck _ (env, mdl@(Module _ _ es _ _))
| null msgs = ok (env, Module ps m es' is ds) | null msgs = ok (env, mdl)
| otherwise = failMessages msgs | 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 (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. -- |Check for warnings.
warnCheck :: Options -> CompilerEnv -> Module -> [Message] warnCheck :: Options -> CompilerEnv -> Module -> [Message]
......
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
list of sub-entities. list of sub-entities.
-} -}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Checks.ExportCheck (exportCheck) where module Checks.ExportCheck (exportCheck, expandExports) where
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
...@@ -55,17 +55,28 @@ import Env.Value (ValueEnv, ValueInfo (..), qualLookupValueUnique) ...@@ -55,17 +55,28 @@ import Env.Value (ValueEnv, ValueInfo (..), qualLookupValueUnique)
-- Check and expansion of the export statement -- Check and expansion of the export statement
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
exportCheck :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv expandExports :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv
-> Maybe ExportSpec -> (Maybe ExportSpec, [Message]) -> Maybe ExportSpec -> ExportSpec
exportCheck m aEnv tcEnv tyEnv spec = case errs of expandExports m aEnv tcEnv tyEnv spec = Exporting (exportPos spec) es
[] -> (Just $ Exporting (exportPos spec) es, checkNonUniqueness es)
ms -> (spec, ms)
where where
exportPos (Just (Exporting p _)) = p exportPos (Just (Exporting p _)) = p
exportPos Nothing = NoPos exportPos Nothing = NoPos
(es, errs) = runECM ((joinExports . canonExports tcEnv) <$> expandSpec spec) es = fst (checkAndExpand m aEnv tcEnv tyEnv spec)
initState
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 [] initState = ECState m imported tcEnv tyEnv []
imported = Set.fromList (Map.elems aEnv) imported = Set.fromList (Map.elems aEnv)
......
...@@ -199,15 +199,8 @@ checkModule opts mdl = do ...@@ -199,15 +199,8 @@ checkModule opts mdl = do
sc <- syntaxCheck opts kc >>= dumpCS DumpSyntaxChecked sc <- syntaxCheck opts kc >>= dumpCS DumpSyntaxChecked
pc <- precCheck opts sc >>= dumpCS DumpPrecChecked pc <- precCheck opts sc >>= dumpCS DumpPrecChecked
tc <- typeCheck opts pc >>= dumpCS DumpTypeChecked tc <- typeCheck opts pc >>= dumpCS DumpTypeChecked
-- TODO: This is a workaround to avoid the expansion of the export ec <- exportCheck opts tc >>= dumpCS DumpExportChecked
-- specification for generating the HTML listing. If a module does not return ec
-- 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
where dumpCS = dumpWith opts CS.ppModule where dumpCS = dumpWith opts CS.ppModule
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
...@@ -236,7 +229,8 @@ transModule opts mdl = do ...@@ -236,7 +229,8 @@ transModule opts mdl = do
writeOutput :: Options -> FilePath -> CompEnv CS.Module -> IO () writeOutput :: Options -> FilePath -> CompEnv CS.Module -> IO ()
writeOutput opts fn mdl@(_, modul) = do writeOutput opts fn mdl@(_, modul) = do
writeParsed opts fn modul 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 writeAbstractCurry opts fn qmdl
-- generate interface file -- generate interface file
let intf = uncurry exportInterface qmdl 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