Merge pull request #2570 from ninioArtillero/duplicate-names-error

Improve duplicate names error

Author: facundominguez

liquidhaskell-boot/src/Language/Haskell/Liquid/LHNameResolution.hs

@@ -63,6 +63,7 @@ import           Language.Haskell.Liquid.Types.Names
 import           Language.Haskell.Liquid.Types.RType
 import           Language.Haskell.Liquid.Types.RTypeOp
 
+import           Control.Monad.Except (ExceptT, runExceptT, throwError)
 import           Control.Monad ((<=<), mplus, unless, void)
 import           Control.Monad.Identity
 import           Control.Monad.State.Strict
@@ -163,57 +164,60 @@ resolveLHNames
   -> BareSpecParsed
   -> TargetDependencies
   -> Either [Error] (BareSpec, LogicNameEnv, LogicMap)
-resolveLHNames cfg thisModule localVars impMods globalRdrEnv bareSpec0 dependencies = do
-    let ((bs, logicNameEnv, lmap2), ro) =
-          flip runState RenameOutput {roErrors = [], roUsedNames = [], roUsedDataCons = mempty} $ do
-            sp0 <- fixExpressionArgsOfTypeAliases taliases $ resolveBoundVarsInTypeAliases bareSpec0
-            -- First pass: A generic traversal that resolves names
-            -- of Haskell entities and type aliases.
-            sp1 <- mapMLocLHNames (\l -> (<$ l) <$> resolveLHName l) sp0
-            -- Data decls contain fieldnames that introduce measures with the
-            -- same names. We resolve them before constructing the logic
-            -- environment.
-            dataDecls <- mapM (mapDataDeclFieldNamesM resolveFieldLogicName) (dataDecls sp1)
-            let sp2 = sp1 {dataDecls}
-
-            es0 <- gets roErrors
-            if null es0 then do
-
-              -- Second pass: a traversal to resolve logic names using the following
-              -- lookup environments.
-              let (inScopeEnv, logicNameEnv0, privateReflectNames) =
-                    makeLogicEnvs impMods thisModule sp2 dependencies
-              -- Add resolved local defines to the logic map.
-                  lmap1 =
-                    lmap <> mkLogicMap (HM.fromList $
-                                         (\(k , v) ->
-                                             let k' = lhNameToResolvedSymbol <$> k in
-                                             (F.val k', (val <$> v) { lmVar = k' }))
-                                         <$> defines sp2)
-              sp3 <- fromBareSpecLHName <$>
-                       resolveLogicNames
-                         cfg
-                         thisModule
-                         inScopeEnv
-                         globalRdrEnv
-                         lmap1
-                         localVars
-                         logicNameEnv0
-                         privateReflectNames
-                         depsInlinesAndDefines
-                         sp2
-              dcs <- gets roUsedDataCons
-              return (sp3 {usedDataCons = dcs} , logicNameEnv0, lmap1)
-            else
-              return ( error "resolveLHNames: invalid spec"
-                     , error "resolveLHNames: invalid logic environment"
-                     , error "resolveLHNames: invalid logic map")
-        logicNameEnv' = extendLogicNameEnv logicNameEnv (roUsedNames ro)
-    if null (roErrors ro) then
-      Right (bs, logicNameEnv', lmap2)
-    else
-      Left (roErrors ro)
+resolveLHNames cfg thisModule localVars impMods globalRdrEnv bareSpec0 dependencies =
+  flip evalState RenameOutput { roErrors = [], roUsedNames = [], roUsedDataCons = mempty } $
+    runExceptT $ do
+      -- Prepare type aliases for resolution.
+      sp0 <- lift $ fixExpressionArgsOfTypeAliases taliases $ resolveBoundVarsInTypeAliases bareSpec0
+
+      checkErrors
+
+      -- First resolution pass: A generic traversal that resolves names
+      -- of Haskell entities and type alias binders.
+      sp1 <- lift $ mapMLocLHNames (\l -> (<$ l) <$> resolveLHName l) sp0
+
+      -- Data decls contain fieldnames that introduce measures with the
+      -- same names. We resolve them before constructing the logic
+      -- environments.
+      dataDecls <- lift $ mapM (mapDataDeclFieldNamesM resolveFieldLogicName) (dataDecls sp1)
+      let sp2 = sp1 {dataDecls}
+
+      checkErrors
+
+      -- Second resolution pass: a traversal to resolve logic names using the following
+      -- lookup environments.
+      let (inScopeEnv, logicNameEnv0, privateReflectNames) =
+            makeLogicEnvs impMods thisModule sp2 dependencies
+
+          -- Add resolved local defines to the logic map.
+          lmap1 = lmap <> mkLogicMap (HM.fromList $
+                   [ (F.val $ lhNameToResolvedSymbol <$> k,
+                      (val <$> v) { lmVar = lhNameToResolvedSymbol <$> k })
+                   | (k,v) <- defines sp2 ])
+      sp3 <- lift $ fromBareSpecLHName <$>
+                  resolveLogicNames
+                    cfg
+                    thisModule
+                    inScopeEnv
+                    globalRdrEnv
+                    lmap1
+                    localVars
+                    logicNameEnv0
+                    privateReflectNames
+                    depsInlinesAndDefines
+                    sp2
+
+      checkErrors
+
+      dcs <- gets roUsedDataCons
+      return (sp3 { usedDataCons = dcs }, logicNameEnv0, lmap1)
   where
+    -- Early exit name resolution if errors are found and pass them to the output.
+    checkErrors :: ExceptT [Error] (StateT RenameOutput Identity) ()
+    checkErrors = do
+      es <- gets roErrors
+      unless (null es) (throwError es)
+
     -- We collect type aliases before resolving names so we have a means to disambiguate
     -- imported and local ones (according to their resolution status).
     taliases = collectTypeAliases impMods thisModule bareSpec0 dependencies
@@ -285,6 +289,7 @@ resolveLHNames cfg thisModule localVars impMods globalRdrEnv bareSpec0 dependenc
               addError
                 (ErrDupNames
                    (LH.fSrcSpan lname)
+                   "variable"
                    (pprint s)
                    (map (PJ.text . GHC.showPprUnsafe) es)
                 )
@@ -360,6 +365,7 @@ resolveSymbolToTcName globalRdrEnv lx
         [] -> Left $ errResolve [] "type constructor" "Cannot resolve name" lx
         es -> Left $ ErrDupNames
                 (LH.fSrcSpan lx)
+                "type constructor"
                 (pprint s)
                 (map (PJ.text . GHC.showPprUnsafe) es)
   where
@@ -542,20 +548,38 @@ data TypeAliasResolution a
       , tarLocallyDefined :: [(GHC.Module, LHName, a)]
       }
 
-errResolveTypeAlias :: LocSymbol -> TypeAliasResolution b -> Error
+errResolveTypeAlias :: LocSymbol -> TypeAliasResolution (RTAlias x a) -> Error
 errResolveTypeAlias ls (FoundTypeAliases imported local) =
-  ErrDupNames (LH.fSrcSpan ls) (pprint $ val ls)
+  ErrDupNames (LH.fSrcSpan ls) "type alias" (pprint $ val ls)
     (
-      map (\(m, lhn, _) -> pprint (LH.qualifySymbol (symbol . GHC.moduleNameString . GHC.moduleName $ m)
-                                   $ getLHNameSymbol lhn)
-                           PJ.<+>
-                           PJ.text "defined in current module")
-      local
+      -- Currently, multiple local definitions prevent this error from being raised,
+      -- because duplicate names are discarded when constructing the alias environment
+      -- for each individual module,
+      -- and a local alias always shadows any imported one. Such duplicates are detected
+      -- later during validation of the final target spec.
+      --
+      -- Also, note that collected local type alias names remain unresolved at this stage,
+      -- so we must extract their symbol using a function that can safely handle unresolved
+      -- names.
+      map (\(_, lhn, rta) -> pprint (getLHNameSymbol lhn)
+                             PJ.<+>
+                             PJ.text "defined in current module at"
+                             PJ.<+>
+                             pprint  (LH.fSrcSpan . rtName $ rta)
+          )
+          local
      ++
-     map (\(m, lhn, _) -> pprint (lhNameToResolvedSymbol lhn)
-                          PJ.<+>
-                          PJ.text ("imported from " ++ GHC.moduleNameString (GHC.moduleName m)))
-      imported
+     map (\(m, lhn, rta) -> pprint (lhNameToUnqualifiedSymbol lhn)
+                            PJ.<+>
+                            PJ.text "imported from module"
+                            PJ.<+>
+                            PJ.text (GHC.moduleNameString (GHC.moduleName m))
+                            PJ.<+>
+                            PJ.text "defined at"
+                            PJ.<+>
+                            pprint (LH.fSrcSpan . rtName $ rta)
+         )
+         imported
     )
 errResolveTypeAlias ls (NoSuchTypeAlias alts) =
   errResolve alts "type alias" "Cannot resolve name" ls
@@ -670,7 +694,10 @@ mkAliasEnv:: GHC.Module -> GHC.ImportedMods -> (GHC.Module, [(LHName, a)]) -> In
 mkAliasEnv thisModule impMods (m, lhnames) =
     let aliases = moduleAliases thisModule impMods m
      in fromListSEnv
-          [ (LH.dropModuleNames $ getLHNameSymbol lhname, map (,(m, lhname, x)) aliases)
+          -- Note that when building a name environment for the current module
+          -- we might process unresolved names here.
+          [ (LH.dropModuleNames $ getLHNameSymbol lhname
+            , map (,(m, lhname, x)) aliases)
           | (lhname, x) <- lhnames
           ]
 
@@ -792,6 +819,7 @@ resolveLogicNames cfg thisModule env globalRdrEnv lmap0 localVars lnameEnv priva
         errDupInScopeNames locSym inScopeNames =
           ErrDupNames
             (LH.fSrcSpan locSym)
+            "non-reflected logic entity"
             (pprint (val locSym))
             [ pprint (lhNameToResolvedSymbol n) PJ.<+>
               PJ.text
@@ -835,6 +863,7 @@ resolveLogicNames cfg thisModule env globalRdrEnv lmap0 localVars lnameEnv priva
             addError
               (ErrDupNames
                  (LH.fSrcSpan s)
+                 "data constructor"
                  (pprint $ val s)
                  (map (PJ.text . GHC.showPprUnsafe) es)
               )
@@ -874,6 +903,7 @@ resolveLogicNames cfg thisModule env globalRdrEnv lmap0 localVars lnameEnv priva
               addError
                  (ErrDupNames
                    (LH.fSrcSpan s)
+                   "variable"
                    (pprint $ val s)
                    (map (PJ.text . GHC.showPprUnsafe) es)
                  )

liquidhaskell-boot/src/Language/Haskell/Liquid/Types/Errors.hs

@@ -284,8 +284,8 @@ data TError t =
                 } -- ^ sort error in specification
 
   | ErrDupAlias { pos  :: !SrcSpan
-                , var  :: !Doc
                 , kind :: !Doc
+                , var  :: !Doc
                 , locs :: ![SrcSpan]
                 } -- ^ multiple alias with same name error
 
@@ -311,9 +311,10 @@ data TError t =
                 } -- ^ duplicate fields in same datacon
 
   | ErrDupNames { pos   :: !SrcSpan
+                , kind  :: !Doc
                 , var   :: !Doc
                 , names :: ![Doc]
-                } -- ^ name resolves to multiple possible GHC vars
+                } -- ^ name resolves to multiple matches
 
   | ErrBadData  { pos :: !SrcSpan
                 , var :: !Doc
@@ -901,8 +902,8 @@ ppError' _ dCtx (ErrDupField _ dc x)
         $+$ dCtx
         $+$ nest 4 (text "Duplicated definitions for field" <+> ppTicks x)
 
-ppError' _ dCtx (ErrDupNames _ x ns)
-  = text "Ambiguous specification symbol" <+> ppTicks x
+ppError' _ dCtx (ErrDupNames _ k v ns)
+  = text "Ambiguous specification symbol"  <+> ppTicks v <+> "for" <+> pprint k
         $+$ dCtx
         $+$ ppNames ns