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.

src/Checks/ExportCheck.hs

@@ -48,8 +48,8 @@ import Base.Types          ( DataConstr (..), ExistTypeScheme (..), Type (..)
 import Base.Utils          (findMultiples)
 
 import Env.ModuleAlias     (AliasEnv)
-import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
-import Env.Value           (ValueEnv, ValueInfo (..), qualLookupValue)
+import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTCUnique)
+import Env.Value           (ValueEnv, ValueInfo (..), qualLookupValueUnique)
 
 -- ---------------------------------------------------------------------------
 -- Check and expansion of the export statement
@@ -57,24 +57,44 @@ import Env.Value           (ValueEnv, ValueInfo (..), qualLookupValue)
 
 exportCheck :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv
             -> Maybe ExportSpec -> (Maybe ExportSpec, [Message])
-exportCheck m aEnv tcEnv tyEnv spec = case expErrs of
-  [] -> (Just $ Exporting (exportPos spec) exports, ambiErrs)
+exportCheck m aEnv tcEnv tyEnv spec = case errs of
+  [] -> (Just $ Exporting (exportPos spec) es, checkNonUniqueness es)
   ms -> (spec, ms)
   where
   exportPos (Just (Exporting p _)) = p
   exportPos Nothing                = NoPos
 
-  (exports, expErrs) = runECM ((joinExports . canonExports tcEnv)
-                         <$> expandSpec spec) initState
-  initState          = ECState m imported tcEnv tyEnv []
-  imported           = Set.fromList $ Map.elems aEnv
-
-  ambiErrs = map errMultipleType  (findMultiples exportedTypes)
-          ++ map errMultipleName (findMultiples exportedValues)
+  (es, errs) = runECM ((joinExports . canonExports tcEnv) <$> expandSpec spec)
+                      initState
+  initState  = ECState m imported tcEnv tyEnv []
+  imported   = Set.fromList (Map.elems aEnv)
+
+-- Check whether two entities of the same kind (type or constructor/function)
+-- 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]
-                ++ [unqualify f | Export f <- exports]
+-- -----------------------------------------------------------------------------
+-- Expansion + Check
+-- -----------------------------------------------------------------------------
 
 data ECState = ECState
   { moduleIdent  :: ModuleIdent
@@ -134,8 +154,9 @@ expandExport (ExportModule      em) = expandModule em
 -- |Expand export of type constructor / function
 expandThing :: QualIdent -> ECM [Export]
 expandThing tc = do
+  m     <- getModuleIdent
   tcEnv <- getTyConsEnv
-  case qualLookupTC tc tcEnv of
+  case qualLookupTCUnique m tc tcEnv of
     []  -> expandThing' tc Nothing
     [t] -> expandThing' tc (Just [ExportTypeWith (origName t) []])
     ts  -> report (errAmbiguousType tc ts) >> return []
@@ -143,39 +164,34 @@ expandThing tc = do
 -- |Expand export of data cons / function
 expandThing' :: QualIdent -> Maybe [Export] -> ECM [Export]
 expandThing' f tcExport = do
+  m     <- getModuleIdent
   tyEnv <- getValueEnv
-  case qualLookupValue f tyEnv of
+  case qualLookupValueUnique m f tyEnv of
     []             -> justTcOr errUndefinedName
     [Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport
     [Label l  _ (ForAll _ (TypeArrow (TypeConstructor tc _) _))] -> do
       report $ errExportLabel f tc
       return $ Export l  : fromMaybe [] tcExport
     [c]            -> justTcOr $ flip errExportDataConstr $ getTc c
-    _              -> do
-      m <- getModuleIdent
-      case qualLookupValue (qualQualify m f) tyEnv of
-        []             -> justTcOr errUndefinedName
-        [Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport
-        [Label l  _ (ForAll _ (TypeArrow (TypeConstructor tc _) _))] -> do
-          report $ errExportLabel f tc
-          return $ Export l  : fromMaybe [] tcExport
-        [c]            -> justTcOr $ flip errExportDataConstr $ getTc c
-        fs             -> report (errAmbiguousName f fs) >> return []
-  where justTcOr errFun = case tcExport of
-          Nothing -> report (errFun f) >> return []
-          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
+    fs             -> report (errAmbiguousName f fs) >> return []
+  where
+  justTcOr errFun = case tcExport of
+    Nothing -> report (errFun f) >> return []
+    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
 expandTypeWith :: QualIdent -> [Ident] -> ECM [Export]
 expandTypeWith tc xs = do
+  m     <- getModuleIdent
   tcEnv <- getTyConsEnv
-  case qualLookupTC tc tcEnv of
+  case qualLookupTCUnique m tc tcEnv of
     [] -> report (errUndefinedType tc) >> return []
     [t@(DataType _ _ cs)]    -> do
       mapM_ (checkElement (visibleElems cs)) xs'
@@ -195,8 +211,9 @@ expandTypeWith tc xs = do
 -- |Expand type constructor with all data constructors and record labels
 expandTypeAll :: QualIdent -> ECM [Export]
 expandTypeAll tc = do
+  m     <- getModuleIdent
   tcEnv <- getTyConsEnv
-  case qualLookupTC tc tcEnv of
+  case qualLookupTCUnique m tc tcEnv of
     [] -> report (errUndefinedType tc) >> return []
     [t@(DataType     _ _ _)] -> return $ [exportType t]
     [t@(RenamingType _ _ _)] -> return $ [exportType t]
@@ -216,11 +233,10 @@ expandLocalModule :: ECM [Export]
 expandLocalModule = do
   tcEnv <- getTyConsEnv
   tyEnv <- getValueEnv
-  return $ [exportType t | (_, t) <- localBindings tcEnv] ++
-    [ Export f' | (f, Value f' _ _) <- localBindings tyEnv
-    , f == unRenameIdent f] ++
-    [ Export l' | (l, Label l' _ _) <- localBindings tyEnv
-    , l == unRenameIdent l]
+  return $
+       [ exportType t | (_, t) <- localBindings tcEnv ]
+    ++ [ Export f' | (f, Value f' _ _) <- localBindings tyEnv, hasGlobalScope f ]
+    ++ [ Export l' | (l, Label l' _ _) <- localBindings tyEnv, hasGlobalScope l ]
 
 -- |Expand a module export
 expandImportedModule :: ModuleIdent -> ECM [Export]
@@ -236,6 +252,10 @@ exportType t = ExportTypeWith tc xs
   where tc = origName t
         xs = elements t
 
+-- -----------------------------------------------------------------------------
+-- Canonicalization and joining of exports
+-- -----------------------------------------------------------------------------
+
 -- In contrast to Haskell, the export of field labels and record constructors
 -- without their types is NOT allowed.
 -- Thus, given the declaration @data T a = C { l :: a }@

test/ExportAmbiguousErrors.curry

+module ExportAmbiguousErrors (Bool, Prelude.Bool, not, Prelude.not) where
+
+import Prelude
+
+data Bool = False | True
+
+not :: Bool -> Bool
+not False = True
+not True  = False