Commit 710c052a authored by Kai-Oliver Prott's avatar Kai-Oliver Prott

Fix restricted re-export of record labels

parent 57e3faa0
......@@ -50,10 +50,10 @@ import Curry.Syntax
import Base.Messages (Message, internalError, posMessage)
import Base.TopEnv (allEntities, origName, localBindings, moduleImports)
import Base.Types ( Type (..), unapplyType, arrowBase
import Base.Types ( Type (..), unapplyType, arrowBase, rootOfType
, DataConstr (..), constrIdent, recLabels
, ClassMethod, methodName
, rawType )
, rawType, rawPredType )
import Base.Utils (findMultiples)
import Env.ModuleAlias (AliasEnv)
......@@ -325,26 +325,32 @@ expandLocalModule = do
tcEnv <- getTyConsEnv
tyEnv <- getValueEnv
return $
[ exportType t | (_, t) <- localBindings tcEnv ]
[ exportType t
| (_, t) <- localBindings tcEnv ]
++ [ exportLabel l' ty
| (l, Label l' _ ty) <- localBindings tyEnv, hasGlobalScope l ]
++ [ Export NoSpanInfo f'
| (f, Value f' _ _ _) <- localBindings tyEnv, hasGlobalScope f ]
++ [ Export NoSpanInfo l'
| (l, Label l' _ _) <- localBindings tyEnv, hasGlobalScope l ]
-- |Expand a module export
expandImportedModule :: ModuleIdent -> ECM [Export]
expandImportedModule m = do
tcEnv <- getTyConsEnv
tyEnv <- getValueEnv
return $ [exportType t | (_, t) <- moduleImports m tcEnv]
return $ [exportType t | (_, t) <- moduleImports m tcEnv]
++ [exportLabel l ty | (_, Label l _ ty) <- moduleImports m tyEnv]
++ [Export NoSpanInfo f | (_, Value f _ _ _) <- moduleImports m tyEnv]
++ [Export NoSpanInfo l | (_, Label l _ _) <- moduleImports m tyEnv]
exportType :: TypeInfo -> Export
exportType t = ExportTypeWith NoSpanInfo tc xs
where tc = origName t
xs = elements t
exportLabel :: QualIdent -> Type -> Export
exportLabel qid ty = case rawPredType ty of
TypeArrow a _ -> ExportTypeWith NoSpanInfo (rootOfType a) [qidIdent qid]
_ -> internalError $ "ExportCheck.exportLabel: " ++ show (qid, ty)
-- -----------------------------------------------------------------------------
-- Canonicalization and joining of exports
-- -----------------------------------------------------------------------------
......
......@@ -180,6 +180,7 @@ valueDecl m vEnv tvs (Export _ f) ds = case qualLookupValue f vEnv of
[Value _ cm a tySc] -> let pty = rawPredType tySc in
IFunctionDecl NoPos (qualUnqualify m f)
(if cm then Just (head tvs) else Nothing) a (fromQualPredType m tvs pty) : ds
[Label _ _ _ ] -> ds -- Record labels are collected somewhere else.
_ -> internalError $ "Exports.valueDecl: " ++ show f
valueDecl _ _ _ (ExportTypeWith _ _ _) ds = ds
valueDecl _ _ _ _ _ = internalError "Exports.valueDecl: no pattern match"
......
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