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

Improved warning for ambiguous entities

parent c961a860
...@@ -181,15 +181,21 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}. ...@@ -181,15 +181,21 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}.
> data RenameInfo > data RenameInfo
> -- |Arity of data constructor > -- |Arity of data constructor
> = Constr Int > = Constr QualIdent Int
> -- |Record type and all labels for a single record label > -- |Record type and all labels for a single record label
> | RecordLabel QualIdent [Ident] > | RecordLabel QualIdent [Ident]
> -- |Arity of global function > -- |Arity of global function
> | GlobalVar Int QualIdent > | GlobalVar QualIdent Int
> -- |Arity of local function > -- |Arity of local function
> | LocalVar Int Ident > | LocalVar Ident Int
> deriving (Eq, Show) > deriving (Eq, Show)
> ppRenameInfo :: RenameInfo -> Doc
> ppRenameInfo (Constr qn _) = text (escQualName qn)
> ppRenameInfo (RecordLabel qn _) = text (escQualName qn)
> ppRenameInfo (GlobalVar qn _) = text (escQualName qn)
> ppRenameInfo (LocalVar n _) = text (escName n)
\end{verbatim} \end{verbatim}
Since record types are currently translated into data types, it is necessary Since record types are currently translated into data types, it is necessary
to ensure that all identifiers for records and constructors are different. to ensure that all identifiers for records and constructors are different.
...@@ -197,10 +203,10 @@ Furthermore, it is not allowed to declare a label more than once. ...@@ -197,10 +203,10 @@ Furthermore, it is not allowed to declare a label more than once.
\begin{verbatim} \begin{verbatim}
> renameInfo :: TCEnv -> ValueInfo -> RenameInfo > renameInfo :: TCEnv -> ValueInfo -> RenameInfo
> renameInfo _ (DataConstructor _ a _) = Constr $ a > renameInfo _ (DataConstructor qid a _) = Constr qid a
> renameInfo _ (NewtypeConstructor _ _) = Constr 1 > renameInfo _ (NewtypeConstructor qid _) = Constr qid 1
> renameInfo _ (Value qid a _) = GlobalVar a qid > renameInfo _ (Value qid a _) = GlobalVar qid a
> renameInfo tcEnv (Label _ r _) = case qualLookupTC r tcEnv of > renameInfo tcEnv (Label _ r _) = case qualLookupTC r tcEnv of
> [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r $ map fst fs > [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r $ map fst fs
> _ -> internalError $ "SyntaxCheck.renameInfo: ambiguous record " ++ show r > _ -> internalError $ "SyntaxCheck.renameInfo: ambiguous record " ++ show r
...@@ -227,15 +233,15 @@ Furthermore, it is not allowed to declare a label more than once. ...@@ -227,15 +233,15 @@ Furthermore, it is not allowed to declare a label more than once.
> bindConstr :: ConstrDecl -> SCM () > bindConstr :: ConstrDecl -> SCM ()
> bindConstr (ConstrDecl _ _ c tys) = do > bindConstr (ConstrDecl _ _ c tys) = do
> m <- getModuleIdent > m <- getModuleIdent
> modifyRenameEnv $ bindGlobal m c (Constr $ length tys) > modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) $ length tys)
> bindConstr (ConOpDecl _ _ _ op _) = do > bindConstr (ConOpDecl _ _ _ op _) = do
> m <- getModuleIdent > m <- getModuleIdent
> modifyRenameEnv $ bindGlobal m op (Constr 2) > modifyRenameEnv $ bindGlobal m op (Constr (qualifyWith m op) 2)
> bindNewConstr :: NewConstrDecl -> SCM () > bindNewConstr :: NewConstrDecl -> SCM ()
> bindNewConstr (NewConstrDecl _ _ c _) = do > bindNewConstr (NewConstrDecl _ _ c _) = do
> m <- getModuleIdent > m <- getModuleIdent
> modifyRenameEnv $ bindGlobal m c (Constr 1) > modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) 1)
> bindRecordLabel :: Ident -> [Ident] -> Ident -> SCM () > bindRecordLabel :: Ident -> [Ident] -> Ident -> SCM ()
> bindRecordLabel t allLabels l = do > bindRecordLabel t allLabels l = do
...@@ -248,21 +254,20 @@ Furthermore, it is not allowed to declare a label more than once. ...@@ -248,21 +254,20 @@ Furthermore, it is not allowed to declare a label more than once.
> -- |Bind a global function declaration in the 'RenameEnv' > -- |Bind a global function declaration in the 'RenameEnv'
> bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv > bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv
> bindFuncDecl m (FunctionDecl _ ident equs) env > bindFuncDecl _ (FunctionDecl _ _ []) _
> | null equs = internalError "SyntaxCheck.bindFuncDecl: no equations" > = internalError "SyntaxCheck.bindFuncDecl: no equations"
> | otherwise = let arty = length $ snd $ getFlatLhs $ head equs > bindFuncDecl m (FunctionDecl _ f (eq:_)) env
> qid = qualifyWith m ident > = let arty = length $ snd $ getFlatLhs eq
> in bindGlobal m ident (GlobalVar arty qid) env > in bindGlobal m f (GlobalVar (qualifyWith m f) arty) env
> bindFuncDecl m (ForeignDecl _ _ _ ident texpr) env > bindFuncDecl m (ForeignDecl _ _ _ f ty) env
> = let arty = typeArity texpr > = let arty = typeArity ty
> qid = qualifyWith m ident > in bindGlobal m f (GlobalVar (qualifyWith m f) arty) env
> in bindGlobal m ident (GlobalVar arty qid) env > bindFuncDecl m (TypeSig _ fs ty) env
> bindFuncDecl m (TypeSig _ ids texpr) env > = foldr bindTS env $ map (qualifyWith m) fs
> = foldr bindTS env $ map (qualifyWith m) ids
> where > where
> bindTS qid env' > bindTS qf env'
> | null $ qualLookupVar qid env' > | null $ qualLookupVar qf env'
> = bindGlobal m (unqualify qid) (GlobalVar (typeArity texpr) qid) env' > = bindGlobal m (unqualify qf) (GlobalVar qf (typeArity ty)) env'
> | otherwise > | otherwise
> = env' > = env'
> bindFuncDecl _ _ env = env > bindFuncDecl _ _ env = env
...@@ -274,14 +279,14 @@ Furthermore, it is not allowed to declare a label more than once. ...@@ -274,14 +279,14 @@ Furthermore, it is not allowed to declare a label more than once.
> bindVarDecl (FunctionDecl _ f eqs) env > bindVarDecl (FunctionDecl _ f eqs) env
> | null eqs = internalError "SyntaxCheck.bindVarDecl: no equations" > | null eqs = internalError "SyntaxCheck.bindVarDecl: no equations"
> | otherwise = let arty = length $ snd $ getFlatLhs $ head eqs > | otherwise = let arty = length $ snd $ getFlatLhs $ head eqs
> in bindLocal (unRenameIdent f) (LocalVar arty f) env > in bindLocal (unRenameIdent f) (LocalVar f arty) env
> bindVarDecl (PatternDecl _ t _) env = foldr bindVar env (bv t) > bindVarDecl (PatternDecl _ t _) env = foldr bindVar env (bv t)
> bindVarDecl (FreeDecl _ vs) env = foldr bindVar env vs > bindVarDecl (FreeDecl _ vs) env = foldr bindVar env vs
> bindVarDecl _ env = env > bindVarDecl _ env = env
> bindVar :: Ident -> RenameEnv -> RenameEnv > bindVar :: Ident -> RenameEnv -> RenameEnv
> bindVar v | isAnonId v = id > bindVar v | isAnonId v = id
> | otherwise = bindLocal (unRenameIdent v) (LocalVar 0 v) > | otherwise = bindLocal (unRenameIdent v) (LocalVar v 0)
> lookupVar :: Ident -> RenameEnv -> [RenameInfo] > lookupVar :: Ident -> RenameEnv -> [RenameInfo]
> lookupVar v env = lookupNestEnv v env ++! lookupTupleConstr v > lookupVar v env = lookupNestEnv v env ++! lookupTupleConstr v
...@@ -293,7 +298,8 @@ Furthermore, it is not allowed to declare a label more than once. ...@@ -293,7 +298,8 @@ Furthermore, it is not allowed to declare a label more than once.
> lookupTupleConstr :: Ident -> [RenameInfo] > lookupTupleConstr :: Ident -> [RenameInfo]
> lookupTupleConstr v > lookupTupleConstr v
> | isTupleId v = [Constr $ tupleArity v] > | isTupleId v = let a = tupleArity v
> in [Constr (qualifyWith preludeMIdent $ tupleId a) a]
> | otherwise = [] > | otherwise = []
> qualLookupListCons :: QualIdent -> RenameEnv -> [RenameInfo] > qualLookupListCons :: QualIdent -> RenameEnv -> [RenameInfo]
...@@ -577,11 +583,11 @@ checkParen ...@@ -577,11 +583,11 @@ checkParen
> m <- getModuleIdent > m <- getModuleIdent
> k <- getScopeId > k <- getScopeId
> case qualLookupVar c env of > case qualLookupVar c env of
> [Constr n] -> processCons c n > [Constr _ n] -> processCons c n
> [r] -> processVarFun r k > [r] -> processVarFun r k
> rs -> case qualLookupVar (qualQualify m c) env of > rs -> case qualLookupVar (qualQualify m c) env of
> [Constr n] -> processCons (qualQualify m c) n > [Constr _ n] -> processCons (qualQualify m c) n
> [r] -> processVarFun r k > [r] -> processVarFun r k
> [] > []
> | null ts && not (isQualified c) -> > | null ts && not (isQualified c) ->
> return $ VariablePattern $ renameIdent (unqualify c) k > return $ VariablePattern $ renameIdent (unqualify c) k
...@@ -590,7 +596,7 @@ checkParen ...@@ -590,7 +596,7 @@ checkParen
> report $ errUndefinedData c > report $ errUndefinedData c
> return $ ConstructorPattern c ts' > return $ ConstructorPattern c ts'
> _ -> do ts' <- mapM (checkPattern p) ts > _ -> do ts' <- mapM (checkPattern p) ts
> report $ errAmbiguousData c > report $ errAmbiguousData rs c
> return $ ConstructorPattern c ts' > return $ ConstructorPattern c ts'
> where > where
> n' = length ts > n' = length ts
...@@ -617,14 +623,14 @@ checkParen ...@@ -617,14 +623,14 @@ checkParen
> m <- getModuleIdent > m <- getModuleIdent
> env <- getRenameEnv > env <- getRenameEnv
> case qualLookupVar op env of > case qualLookupVar op env of
> [Constr n] -> infixPattern op n > [Constr _ n] -> infixPattern op n
> [_] -> funcPattern op > [_] -> funcPattern op
> rs -> case qualLookupVar (qualQualify m op) env of > rs -> case qualLookupVar (qualQualify m op) env of
> [Constr n] -> infixPattern (qualQualify m op) n > [Constr _ n] -> infixPattern (qualQualify m op) n
> [_] -> funcPattern (qualQualify m op) > [_] -> funcPattern (qualQualify m op)
> rs' -> do if (null rs && null rs') > rs' -> do if (null rs && null rs')
> then report $ errUndefinedData op > then report $ errUndefinedData op
> else report $ errAmbiguousData op > else report $ errAmbiguousData rs op
> liftM2 (flip InfixPattern op) (checkPattern p t1) > liftM2 (flip InfixPattern op) (checkPattern p t1)
> (checkPattern p t2) > (checkPattern p t2)
> where > where
...@@ -782,17 +788,17 @@ checkParen ...@@ -782,17 +788,17 @@ checkParen
> case qualLookupVar v env of > case qualLookupVar v env of
> [] -> do report $ errUndefinedVariable v > [] -> do report $ errUndefinedVariable v
> return $ Variable v > return $ Variable v
> [Constr _] -> return $ Constructor v > [Constr _ _] -> return $ Constructor v
> [GlobalVar _ _] -> return $ Variable v > [GlobalVar _ _] -> return $ Variable v
> [LocalVar _ v'] -> return $ Variable $ qualify v' > [LocalVar v' _] -> return $ Variable $ qualify v'
> rs -> do > rs -> do
> m <- getModuleIdent > m <- getModuleIdent
> case qualLookupVar (qualQualify m v) env of > case qualLookupVar (qualQualify m v) env of
> [] -> do report $ errAmbiguousIdent rs v > [] -> do report $ errAmbiguousIdent rs v
> return $ Variable v > return $ Variable v
> [Constr _] -> return $ Constructor v > [Constr _ _] -> return $ Constructor v
> [GlobalVar _ _] -> return $ Variable v > [GlobalVar _ _] -> return $ Variable v
> [LocalVar _ v'] -> return $ Variable $ qualify v' > [LocalVar v' _] -> return $ Variable $ qualify v'
> rs' -> do report $ errAmbiguousIdent rs' v > rs' -> do report $ errAmbiguousIdent rs' v
> return $ Variable v > return $ Variable v
...@@ -815,16 +821,16 @@ checkParen ...@@ -815,16 +821,16 @@ checkParen
> env <- getRenameEnv > env <- getRenameEnv
> case qualLookupVar v env of > case qualLookupVar v env of
> [] -> report (errUndefinedVariable v) >> return op > [] -> report (errUndefinedVariable v) >> return op
> [Constr _] -> return $ InfixConstr v > [Constr _ _] -> return $ InfixConstr v
> [GlobalVar _ _] -> return $ InfixOp v > [GlobalVar _ _] -> return $ InfixOp v
> [LocalVar _ v'] -> return $ InfixOp $ qualify v' > [LocalVar v' _] -> return $ InfixOp $ qualify v'
> rs -> do > rs -> do
> m <- getModuleIdent > m <- getModuleIdent
> case qualLookupVar (qualQualify m v) env of > case qualLookupVar (qualQualify m v) env of
> [] -> report (errAmbiguousIdent rs v) >> return op > [] -> report (errAmbiguousIdent rs v) >> return op
> [Constr _] -> return $ InfixConstr v > [Constr _ _] -> return $ InfixConstr v
> [GlobalVar _ _] -> return $ InfixOp v > [GlobalVar _ _] -> return $ InfixOp v
> [LocalVar _ v'] -> return $ InfixOp $ qualify v' > [LocalVar v' _] -> return $ InfixOp $ qualify v'
> rs' -> report (errAmbiguousIdent rs' v) >> return op > rs' -> report (errAmbiguousIdent rs' v) >> return op
> where v = opName op > where v = opName op
...@@ -918,7 +924,7 @@ the user about the fact that the identifier is ambiguous. ...@@ -918,7 +924,7 @@ the user about the fact that the identifier is ambiguous.
> isDataConstr v = any isConstr . lookupVar v . globalEnv . toplevelEnv > isDataConstr v = any isConstr . lookupVar v . globalEnv . toplevelEnv
> isConstr :: RenameInfo -> Bool > isConstr :: RenameInfo -> Bool
> isConstr (Constr _) = True > isConstr (Constr _ _) = True
> isConstr (GlobalVar _ _) = False > isConstr (GlobalVar _ _) = False
> isConstr (LocalVar _ _) = False > isConstr (LocalVar _ _) = False
> isConstr (RecordLabel _ _) = False > isConstr (RecordLabel _ _) = False
...@@ -929,14 +935,14 @@ varIdent (LocalVar _ v) = v ...@@ -929,14 +935,14 @@ varIdent (LocalVar _ v) = v
varIdent _ = internalError "SyntaxCheck.varIdent: no variable" varIdent _ = internalError "SyntaxCheck.varIdent: no variable"
> qualVarIdent :: RenameInfo -> QualIdent > qualVarIdent :: RenameInfo -> QualIdent
> qualVarIdent (GlobalVar _ v) = v > qualVarIdent (GlobalVar v _) = v
> qualVarIdent (LocalVar _ v) = qualify v > qualVarIdent (LocalVar v _) = qualify v
> qualVarIdent _ = internalError "SyntaxCheck.qualVarIdent: no variable" > qualVarIdent _ = internalError "SyntaxCheck.qualVarIdent: no variable"
> arity :: RenameInfo -> Int > arity :: RenameInfo -> Int
> arity (Constr n) = n > arity (Constr _ n) = n
> arity (GlobalVar n _) = n > arity (GlobalVar _ n) = n
> arity (LocalVar n _) = n > arity (LocalVar _ n) = n
> arity (RecordLabel _ ls) = length ls > arity (RecordLabel _ ls) = length ls
\end{verbatim} \end{verbatim}
...@@ -1013,27 +1019,28 @@ Error messages. ...@@ -1013,27 +1019,28 @@ Error messages.
> errUndefinedVariable :: QualIdent -> Message > errUndefinedVariable :: QualIdent -> Message
> errUndefinedVariable v = posMessage v $ hsep $ map text > errUndefinedVariable v = posMessage v $ hsep $ map text
> [qualName v, "is undefined"] > [escQualName v, "is undefined"]
> errUndefinedData :: QualIdent -> Message > errUndefinedData :: QualIdent -> Message
> errUndefinedData c = posMessage c $ hsep $ map text > errUndefinedData c = posMessage c $ hsep $ map text
> ["Undefined data constructor", qualName c] > ["Undefined data constructor", escQualName c]
> errUndefinedLabel :: Ident -> Message > errUndefinedLabel :: Ident -> Message
> errUndefinedLabel l = posMessage l $ hsep $ map text > errUndefinedLabel l = posMessage l $ hsep $ map text
> ["Undefined record label", escName l] > ["Undefined record label", escName l]
> errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message > errAmbiguousIdent :: [RenameInfo] -> QualIdent -> Message
> errAmbiguousIdent rs | any isConstr rs = errAmbiguousData > errAmbiguousIdent rs qn | any isConstr rs = errAmbiguousData rs qn
> | otherwise = errAmbiguousVariable > | otherwise = errAmbiguous "variable" rs qn
> errAmbiguousVariable :: QualIdent -> Message > errAmbiguousData :: [RenameInfo] -> QualIdent -> Message
> errAmbiguousVariable v = posMessage v $ hsep $ map text > errAmbiguousData = errAmbiguous "data constructor"
> ["Ambiguous variable", qualName v]
> errAmbiguousData :: QualIdent -> Message > errAmbiguous :: String -> [RenameInfo] -> QualIdent -> Message
> errAmbiguousData c = posMessage c $ hsep $ map text > errAmbiguous what rs qn = posMessage qn
> ["Ambiguous data constructor", qualName c] > $ text "Ambiguous" <+> text what <+> text (escQualName qn)
> $+$ text "It could refer to:"
> $+$ nest 2 (vcat (map ppRenameInfo rs))
> errDuplicateDefinition :: Ident -> Message > errDuplicateDefinition :: Ident -> Message
> errDuplicateDefinition v = posMessage v $ hsep $ map text > errDuplicateDefinition v = posMessage v $ hsep $ map text
...@@ -1041,7 +1048,7 @@ Error messages. ...@@ -1041,7 +1048,7 @@ Error messages.
> errDuplicateVariable :: Ident -> Message > errDuplicateVariable :: Ident -> Message
> errDuplicateVariable v = posMessage v $ hsep $ map text > errDuplicateVariable v = posMessage v $ hsep $ map text
> [idName v, "occurs more than once in pattern"] > [escName v, "occurs more than once in pattern"]
> errMultipleDataConstructor :: [Ident] -> Message > errMultipleDataConstructor :: [Ident] -> Message
> errMultipleDataConstructor [] = internalError > errMultipleDataConstructor [] = internalError
...@@ -1065,11 +1072,11 @@ Error messages. ...@@ -1065,11 +1072,11 @@ Error messages.
> errMissingLabel :: Position -> Ident -> QualIdent -> String -> Message > errMissingLabel :: Position -> Ident -> QualIdent -> String -> Message
> errMissingLabel p l r what = posMessage p $ hsep $ map text > errMissingLabel p l r what = posMessage p $ hsep $ map text
> ["Missing label", escName l, "in the", what, "of", escName (unqualify r)] > ["Missing label", escName l, "in the", what, "of", escQualName r]
> errIllegalLabel :: Ident -> QualIdent -> Message > errIllegalLabel :: Ident -> QualIdent -> Message
> errIllegalLabel l r = posMessage l $ hsep $ map text > errIllegalLabel l r = posMessage l $ hsep $ map text
> ["Label", escName l, "is not defined in record", escName (unqualify r)] > ["Label", escName l, "is not defined in record", escQualName r]
> errIllegalRecordId :: Ident -> Message > errIllegalRecordId :: Ident -> Message
> errIllegalRecordId r = posMessage r $ hsep $ map text > errIllegalRecordId r = posMessage r $ hsep $ map text
...@@ -1100,7 +1107,7 @@ Error messages. ...@@ -1100,7 +1107,7 @@ Error messages.
> errWrongArity :: QualIdent -> Int -> Int -> Message > errWrongArity :: QualIdent -> Int -> Int -> Message
> errWrongArity c arity' argc = posMessage c $ hsep (map text > errWrongArity c arity' argc = posMessage c $ hsep (map text
> ["Data constructor", qualName c, "expects", arguments arity']) > ["Data constructor", escQualName c, "expects", arguments arity'])
> <> comma <+> text "but is applied to" <+> text (show argc) > <> comma <+> text "but is applied to" <+> text (show argc)
> where arguments 0 = "no arguments" > where arguments 0 = "no arguments"
> arguments 1 = "1 argument" > arguments 1 = "1 argument"
......
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