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

Improved error messages of export check

parent b2ee9ee2
......@@ -152,8 +152,8 @@ checkThing' f tcExport = do
[] -> justTcOr errUndefinedName
[v] -> case v of
Value _ _ _ -> ok
Label _ _ _ -> report $ errExportLabel f (getTc v)
_ -> justTcOr $ flip errExportDataConstr (getTc v)
Label _ _ _ -> report $ errOutsideTypeLabel f (getTc v)
_ -> justTcOr $ flip errOutsideTypeConstructor (getTc v)
fs -> report (errAmbiguousName f fs)
where
justTcOr errFun = maybe (report $ errFun f) (const ok) tcExport
......@@ -265,7 +265,7 @@ expandThing tc = do
tcEnv <- getTyConsEnv
case qualLookupTCUnique m tc tcEnv of
[] -> expandThing' tc Nothing
[t] -> expandThing' tc (Just [ExportTypeWith (origName t) []])
[t] -> expandThing' tc (Just [ExportTypeWith (origName t @> tc) []])
err -> internalError $ currentModuleName ++ ".expandThing: " ++ show err
-- |Expand export of data cons / function
......@@ -274,7 +274,7 @@ expandThing' f tcExport = do
m <- getModuleIdent
tyEnv <- getValueEnv
case qualLookupValueUnique m f tyEnv of
[Value f' _ _] -> return $ Export f' : fromMaybe [] tcExport
[Value f' _ _] -> return $ Export (f' @> f) : fromMaybe [] tcExport
_ -> return $ fromMaybe [] tcExport
-- |Expand type constructor with explicit data constructors and record labels
......@@ -283,7 +283,7 @@ expandTypeWith tc xs = do
m <- getModuleIdent
tcEnv <- getTyConsEnv
case qualLookupTCUnique m tc tcEnv of
[t] -> return [ExportTypeWith (origName t) $ nub xs]
[t] -> return [ExportTypeWith (origName t @> tc) $ nub xs]
err -> internalError $ currentModuleName ++ ".expandTypeWith: " ++ show err
-- |Expand type constructor with all data constructors and record labels
......@@ -400,30 +400,28 @@ visibleElems cs = map constrIdent cs ++ (nub (concatMap recLabels cs))
-- Error messages
-- ---------------------------------------------------------------------------
errModuleNotImported :: ModuleIdent -> Message
errModuleNotImported m = posMessage m $ hsep $ map text
["Module", escModuleName m, "not imported"]
errAmbiguousName :: QualIdent -> [ValueInfo] -> Message
errAmbiguousName x vs = errAmbiguous "name" x (map origName vs)
errUndefinedType :: QualIdent -> Message
errUndefinedType = errUndefined "Type"
errAmbiguousType :: QualIdent -> [TypeInfo] -> Message
errAmbiguousType tc tcs = errAmbiguous "type" tc (map origName tcs)
errUndefinedElement :: QualIdent -> Ident -> Message
errUndefinedElement tc c = posMessage c $ hsep $ map text
[ idName c, "is not a constructor or label of type ", qualName tc ]
errAmbiguous :: String -> QualIdent -> [QualIdent] -> Message
errAmbiguous what qn qns = posMessage qn
$ text "Ambiguous" <+> text what <+> text (escQualName qn)
$+$ text "It could refer to:"
$+$ nest 2 (vcat (map (text . escQualName) qns))
errUndefinedName :: QualIdent -> Message
errUndefinedName = errUndefined "Name"
errModuleNotImported :: ModuleIdent -> Message
errModuleNotImported m = posMessage m $ hsep $ map text
["Module", escModuleName m, "not imported"]
errUndefined :: String -> QualIdent -> Message
errUndefined what tc = posMessage tc $ hsep $ map text
["Undefined", what, escQualName tc, "in export list"]
errMultipleName :: [Ident] -> Message
errMultipleName = errMultiple "name"
errMultipleType :: [Ident] -> Message
errMultipleType = errMultiple "type"
errMultipleName :: [Ident] -> Message
errMultipleName = errMultiple "name"
errMultiple :: String -> [Ident] -> Message
errMultiple _ [] = internalError $
currentModuleName ++ ".errMultiple: empty list"
......@@ -432,27 +430,15 @@ errMultiple what (i:is) = posMessage i $
$+$ nest 2 (vcat (map showPos (i:is)))
where showPos = text . showLine . idPosition
errAmbiguousType :: QualIdent -> [TypeInfo] -> Message
errAmbiguousType tc tcs = errAmbiguous "type" tc (map origName tcs)
errAmbiguousName :: QualIdent -> [ValueInfo] -> Message
errAmbiguousName x vs = errAmbiguous "name" x (map origName vs)
errAmbiguous :: String -> QualIdent -> [QualIdent] -> Message
errAmbiguous what qn qns = posMessage qn
$ text "Ambiguous" <+> text what <+> text (escQualName qn)
$+$ text "It could refer to:"
$+$ nest 2 (vcat (map (text . escQualName) qns))
errExportDataConstr :: QualIdent -> QualIdent -> Message
errExportDataConstr c tc = errOutsideTypeExport "Data constructor" c tc
errNonDataType :: QualIdent -> Message
errNonDataType tc = posMessage tc $ hsep $ map text
[escQualName tc, "is not a data type"]
errExportLabel :: QualIdent -> QualIdent -> Message
errExportLabel l tc = errOutsideTypeExport "Label" l tc
errOutsideTypeConstructor :: QualIdent -> QualIdent -> Message
errOutsideTypeConstructor c tc = errOutsideTypeExport "Data constructor" c tc
errOutsideTypeLabel :: QualIdent -> QualIdent -> Message
errOutsideTypeLabel l tc = errOutsideTypeExport "Label" l tc
errOutsideTypeExport :: String -> QualIdent -> QualIdent -> Message
errOutsideTypeExport what q tc = posMessage q
......@@ -460,3 +446,17 @@ errOutsideTypeExport what q tc = posMessage q
<+> text "outside type export in export list"
$+$ text "Use `" <> text (qualName tc) <+> parens (text (qualName q))
<> text "' instead"
errUndefinedElement :: QualIdent -> Ident -> Message
errUndefinedElement tc c = posMessage c $ hsep $ map text
[ escName c, "is not a constructor or label of type", escQualName tc ]
errUndefinedName :: QualIdent -> Message
errUndefinedName = errUndefined "name"
errUndefinedType :: QualIdent -> Message
errUndefinedType = errUndefined "type"
errUndefined :: String -> QualIdent -> Message
errUndefined what tc = posMessage tc $ hsep $ map text
["Undefined", what, escQualName tc, "in export list"]
......@@ -102,8 +102,11 @@ qualLookupTC tc tcEnv = qualLookupTopEnv tc tcEnv
qualLookupTCUnique :: ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTCUnique m x tyEnv = case qualLookupTC x tyEnv of
[] -> []
[v] -> [v]
_ -> qualLookupTC (qualQualify m x) tyEnv
[t] -> [t]
ts -> case qualLookupTC (qualQualify m x) tyEnv of
[] -> ts
[t] -> [t]
qts -> qts
lookupTupleTC :: Ident -> [TypeInfo]
lookupTupleTC tc | isTupleId tc = [tupleTCs !! (tupleArity tc - 2)]
......
......@@ -130,7 +130,10 @@ qualLookupValueUnique :: ModuleIdent -> QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValueUnique m x tyEnv = case qualLookupValue x tyEnv of
[] -> []
[v] -> [v]
_ -> qualLookupValue (qualQualify m x) tyEnv
vs -> case qualLookupValue (qualQualify m x) tyEnv of
[] -> vs
[v] -> [v]
qvs -> qvs
lookupTuple :: Ident -> [ValueInfo]
lookupTuple c | isTupleId c = [tupleDCs !! (tupleArity c - 2)]
......
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