Commit 3b6530c8 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Export of record labels without exporting the corresponding type is no longer allowed

parent de455b88
...@@ -30,7 +30,8 @@ import Curry.Syntax ...@@ -30,7 +30,8 @@ import Curry.Syntax
import Base.Messages (Message, internalError, posMessage) import Base.Messages (Message, internalError, posMessage)
import Base.TopEnv (allEntities, origName, localBindings, moduleImports) import Base.TopEnv (allEntities, origName, localBindings, moduleImports)
import Base.Types (DataConstr (..), constrIdent, recLabels) import Base.Types ( DataConstr (..), ExistTypeScheme (..), Type (..)
, TypeScheme (..), arrowBase, constrIdent, recLabels)
import Base.Utils (findMultiples) import Base.Utils (findMultiples)
import Env.ModuleAlias (AliasEnv) import Env.ModuleAlias (AliasEnv)
...@@ -130,19 +131,29 @@ expandThing' f tcExport = do ...@@ -130,19 +131,29 @@ expandThing' f tcExport = do
case qualLookupValue f tyEnv of case qualLookupValue f tyEnv of
[] -> justTcOr errUndefinedName [] -> justTcOr errUndefinedName
[Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport [Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport
[Label l _ _] -> return $ Export l : fromMaybe [] tcExport [Label l _ (ForAll _ (TypeArrow (TypeConstructor tc _) _))] -> do
[_] -> justTcOr errExportDataConstr report $ errExportLabel f tc
return $ Export l : fromMaybe [] tcExport
[c] -> justTcOr $ flip errExportDataConstr $ getTc c
_ -> do _ -> do
m <- getModuleIdent m <- getModuleIdent
case qualLookupValue (qualQualify m f) tyEnv of case qualLookupValue (qualQualify m f) tyEnv of
[] -> justTcOr errUndefinedName [] -> justTcOr errUndefinedName
[Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport [Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport
[Label l _ _] -> return $ Export l : fromMaybe [] tcExport [Label l _ (ForAll _ (TypeArrow (TypeConstructor tc _) _))] -> do
[_] -> justTcOr errExportDataConstr report $ errExportLabel f tc
return $ Export l : fromMaybe [] tcExport
[c] -> justTcOr $ flip errExportDataConstr $ getTc c
fs -> report (errAmbiguousName f fs) >> return [] fs -> report (errAmbiguousName f fs) >> return []
where justTcOr errFun = case tcExport of where justTcOr errFun = case tcExport of
Nothing -> report (errFun f) >> return [] Nothing -> report (errFun f) >> return []
Just tc -> return 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]
...@@ -325,10 +336,19 @@ errAmbiguous what qn qns = posMessage qn ...@@ -325,10 +336,19 @@ errAmbiguous what qn qns = posMessage qn
$+$ text "It could refer to:" $+$ text "It could refer to:"
$+$ nest 2 (vcat (map (text . escQualName) qns)) $+$ nest 2 (vcat (map (text . escQualName) qns))
errExportDataConstr :: QualIdent -> Message errExportDataConstr :: QualIdent -> QualIdent -> Message
errExportDataConstr c = posMessage c $ hsep $ map text errExportDataConstr c tc = errOutsideTypeExport "Data constructor" c tc
["Data constructor", escQualName c, "outside type export in export list"]
errNonDataType :: QualIdent -> Message errNonDataType :: QualIdent -> Message
errNonDataType tc = posMessage tc $ hsep $ map text errNonDataType tc = posMessage tc $ hsep $ map text
[escQualName tc, "is not a data type"] [escQualName tc, "is not a data type"]
errExportLabel :: QualIdent -> QualIdent -> Message
errExportLabel l tc = errOutsideTypeExport "Label" l tc
errOutsideTypeExport :: String -> QualIdent -> QualIdent -> Message
errOutsideTypeExport what q tc = posMessage q
$ text what <+> text (escQualName q)
<+> text "outside type export in export list"
$+$ text "Use `" <> text (qualName tc) <+> parens (text (qualName q))
<> text "' instead"
\ No newline at end of file
Supports Markdown
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