Commit 4b003317 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Fixed bug in export check and improved code structure

Previous to this commit, the shadowing of imported type constructors
by local type constructors was not implemented, causing misleading
error messages.
parent a06618c2
...@@ -48,8 +48,8 @@ import Base.Types ( DataConstr (..), ExistTypeScheme (..), Type (..) ...@@ -48,8 +48,8 @@ import Base.Types ( DataConstr (..), ExistTypeScheme (..), Type (..)
import Base.Utils (findMultiples) import Base.Utils (findMultiples)
import Env.ModuleAlias (AliasEnv) import Env.ModuleAlias (AliasEnv)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC) import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTCUnique)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) import Env.Value (ValueEnv, ValueInfo (..), qualLookupValueUnique)
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- Check and expansion of the export statement -- Check and expansion of the export statement
...@@ -57,24 +57,44 @@ import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) ...@@ -57,24 +57,44 @@ import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
exportCheck :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv exportCheck :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv
-> Maybe ExportSpec -> (Maybe ExportSpec, [Message]) -> Maybe ExportSpec -> (Maybe ExportSpec, [Message])
exportCheck m aEnv tcEnv tyEnv spec = case expErrs of exportCheck m aEnv tcEnv tyEnv spec = case errs of
[] -> (Just $ Exporting (exportPos spec) exports, ambiErrs) [] -> (Just $ Exporting (exportPos spec) es, checkNonUniqueness es)
ms -> (spec, ms) ms -> (spec, ms)
where where
exportPos (Just (Exporting p _)) = p exportPos (Just (Exporting p _)) = p
exportPos Nothing = NoPos exportPos Nothing = NoPos
(exports, expErrs) = runECM ((joinExports . canonExports tcEnv) (es, errs) = runECM ((joinExports . canonExports tcEnv) <$> expandSpec spec)
<$> expandSpec spec) initState initState
initState = ECState m imported tcEnv tyEnv [] initState = ECState m imported tcEnv tyEnv []
imported = Set.fromList $ Map.elems aEnv imported = Set.fromList (Map.elems aEnv)
ambiErrs = map errMultipleType (findMultiples exportedTypes) -- Check whether two entities of the same kind (type or constructor/function)
++ map errMultipleName (findMultiples exportedValues) -- share the same unqualified name, which is not allowed since they could
-- not be uniquely resolved at their usage.
-- For instance, consider the following module
-- @
-- module M (Bool, Prelude.Bool) where
-- data Bool = False | True
-- @
-- If this export would be allowed, in a module @M1@ as follows
-- @
-- module M1 where
-- import M (Bool)
-- @
-- the type @Bool@ could not be resolved uniquely to its definition.
-- Naturally, the same applies for constructors or functions.
checkNonUniqueness :: [Export] -> [Message]
checkNonUniqueness es = map errMultipleType (findMultiples types )
++ map errMultipleName (findMultiples values)
where
types = [ unqualify tc | ExportTypeWith tc _ <- es ]
values = [ c | ExportTypeWith _ cs <- es, c <- cs ]
++ [ unqualify f | Export f <- es ]
exportedTypes = [unqualify tc | ExportTypeWith tc _ <- exports] -- -----------------------------------------------------------------------------
exportedValues = [c | ExportTypeWith _ cs <- exports, c <- cs] -- Expansion + Check
++ [unqualify f | Export f <- exports] -- -----------------------------------------------------------------------------
data ECState = ECState data ECState = ECState
{ moduleIdent :: ModuleIdent { moduleIdent :: ModuleIdent
...@@ -134,8 +154,9 @@ expandExport (ExportModule em) = expandModule em ...@@ -134,8 +154,9 @@ expandExport (ExportModule em) = expandModule em
-- |Expand export of type constructor / function -- |Expand export of type constructor / function
expandThing :: QualIdent -> ECM [Export] expandThing :: QualIdent -> ECM [Export]
expandThing tc = do expandThing tc = do
m <- getModuleIdent
tcEnv <- getTyConsEnv tcEnv <- getTyConsEnv
case qualLookupTC tc tcEnv of case qualLookupTCUnique m tc tcEnv of
[] -> expandThing' tc Nothing [] -> expandThing' tc Nothing
[t] -> expandThing' tc (Just [ExportTypeWith (origName t) []]) [t] -> expandThing' tc (Just [ExportTypeWith (origName t) []])
ts -> report (errAmbiguousType tc ts) >> return [] ts -> report (errAmbiguousType tc ts) >> return []
...@@ -143,39 +164,34 @@ expandThing tc = do ...@@ -143,39 +164,34 @@ expandThing tc = do
-- |Expand export of data cons / function -- |Expand export of data cons / function
expandThing' :: QualIdent -> Maybe [Export] -> ECM [Export] expandThing' :: QualIdent -> Maybe [Export] -> ECM [Export]
expandThing' f tcExport = do expandThing' f tcExport = do
m <- getModuleIdent
tyEnv <- getValueEnv tyEnv <- getValueEnv
case qualLookupValue f tyEnv of case qualLookupValueUnique m f tyEnv of
[] -> justTcOr errUndefinedName [] -> justTcOr errUndefinedName
[Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport [Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport
[Label l _ (ForAll _ (TypeArrow (TypeConstructor tc _) _))] -> do [Label l _ (ForAll _ (TypeArrow (TypeConstructor tc _) _))] -> do
report $ errExportLabel f tc report $ errExportLabel f tc
return $ Export l : fromMaybe [] tcExport return $ Export l : fromMaybe [] tcExport
[c] -> justTcOr $ flip errExportDataConstr $ getTc c [c] -> justTcOr $ flip errExportDataConstr $ getTc c
_ -> do fs -> report (errAmbiguousName f fs) >> return []
m <- getModuleIdent where
case qualLookupValue (qualQualify m f) tyEnv of justTcOr errFun = case tcExport of
[] -> justTcOr errUndefinedName Nothing -> report (errFun f) >> return []
[Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport Just tc -> return tc
[Label l _ (ForAll _ (TypeArrow (TypeConstructor tc _) _))] -> do
report $ errExportLabel f tc getTc (DataConstructor _ _ _ (ForAllExist _ _ ty)) = getTc' ty
return $ Export l : fromMaybe [] tcExport getTc (NewtypeConstructor _ _ (ForAllExist _ _ ty)) = getTc' ty
[c] -> justTcOr $ flip errExportDataConstr $ getTc c getTc (Label _ _ (ForAll _ (TypeArrow (TypeConstructor tc _) _))) = tc
fs -> report (errAmbiguousName f fs) >> return [] getTc _ = internalError "ExportCheck.getTc"
where justTcOr errFun = case tcExport of
Nothing -> report (errFun f) >> return [] getTc' ty = let (TypeConstructor tc _) = arrowBase ty in tc
Just tc -> return tc
getTc (DataConstructor _ _ _ (ForAllExist _ _ ty)) = getTc' ty
getTc (NewtypeConstructor _ _ (ForAllExist _ _ ty)) = getTc' ty
getTc (Label _ _ (ForAll _ (TypeArrow (TypeConstructor tc _) _))) = tc
getTc _ = internalError "ExportCheck.getTc"
getTc' ty' = let (TypeConstructor tc _) = arrowBase ty'
in tc
-- |Expand type constructor with explicit data constructors and record labels -- |Expand type constructor with explicit data constructors and record labels
expandTypeWith :: QualIdent -> [Ident] -> ECM [Export] expandTypeWith :: QualIdent -> [Ident] -> ECM [Export]
expandTypeWith tc xs = do expandTypeWith tc xs = do
m <- getModuleIdent
tcEnv <- getTyConsEnv tcEnv <- getTyConsEnv
case qualLookupTC tc tcEnv of case qualLookupTCUnique m tc tcEnv of
[] -> report (errUndefinedType tc) >> return [] [] -> report (errUndefinedType tc) >> return []
[t@(DataType _ _ cs)] -> do [t@(DataType _ _ cs)] -> do
mapM_ (checkElement (visibleElems cs)) xs' mapM_ (checkElement (visibleElems cs)) xs'
...@@ -195,8 +211,9 @@ expandTypeWith tc xs = do ...@@ -195,8 +211,9 @@ expandTypeWith tc xs = do
-- |Expand type constructor with all data constructors and record labels -- |Expand type constructor with all data constructors and record labels
expandTypeAll :: QualIdent -> ECM [Export] expandTypeAll :: QualIdent -> ECM [Export]
expandTypeAll tc = do expandTypeAll tc = do
m <- getModuleIdent
tcEnv <- getTyConsEnv tcEnv <- getTyConsEnv
case qualLookupTC tc tcEnv of case qualLookupTCUnique m tc tcEnv of
[] -> report (errUndefinedType tc) >> return [] [] -> report (errUndefinedType tc) >> return []
[t@(DataType _ _ _)] -> return $ [exportType t] [t@(DataType _ _ _)] -> return $ [exportType t]
[t@(RenamingType _ _ _)] -> return $ [exportType t] [t@(RenamingType _ _ _)] -> return $ [exportType t]
...@@ -216,11 +233,10 @@ expandLocalModule :: ECM [Export] ...@@ -216,11 +233,10 @@ expandLocalModule :: ECM [Export]
expandLocalModule = do expandLocalModule = do
tcEnv <- getTyConsEnv tcEnv <- getTyConsEnv
tyEnv <- getValueEnv tyEnv <- getValueEnv
return $ [exportType t | (_, t) <- localBindings tcEnv] ++ return $
[ Export f' | (f, Value f' _ _) <- localBindings tyEnv [ exportType t | (_, t) <- localBindings tcEnv ]
, f == unRenameIdent f] ++ ++ [ Export f' | (f, Value f' _ _) <- localBindings tyEnv, hasGlobalScope f ]
[ Export l' | (l, Label l' _ _) <- localBindings tyEnv ++ [ Export l' | (l, Label l' _ _) <- localBindings tyEnv, hasGlobalScope l ]
, l == unRenameIdent l]
-- |Expand a module export -- |Expand a module export
expandImportedModule :: ModuleIdent -> ECM [Export] expandImportedModule :: ModuleIdent -> ECM [Export]
...@@ -236,6 +252,10 @@ exportType t = ExportTypeWith tc xs ...@@ -236,6 +252,10 @@ exportType t = ExportTypeWith tc xs
where tc = origName t where tc = origName t
xs = elements t xs = elements t
-- -----------------------------------------------------------------------------
-- Canonicalization and joining of exports
-- -----------------------------------------------------------------------------
-- In contrast to Haskell, the export of field labels and record constructors -- In contrast to Haskell, the export of field labels and record constructors
-- without their types is NOT allowed. -- without their types is NOT allowed.
-- Thus, given the declaration @data T a = C { l :: a }@ -- Thus, given the declaration @data T a = C { l :: a }@
......
module ExportAmbiguousErrors (Bool, Prelude.Bool, not, Prelude.not) where
import Prelude
data Bool = False | True
not :: Bool -> Bool
not False = True
not True = False
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