purescript · MonoidMusician · May 22, 2022 · Oct 24, 2022 · Oct 24, 2022 · Oct 24, 2022
diff --git a/purescript.cabal b/purescript.cabal
@@ -342,6 +342,7 @@ library
     Language.PureScript.Sugar.Names.Env
     Language.PureScript.Sugar.Names.Exports
     Language.PureScript.Sugar.Names.Imports
+    Language.PureScript.Sugar.Names.Requalify
     Language.PureScript.Sugar.ObjectWildcards
     Language.PureScript.Sugar.Operators
     Language.PureScript.Sugar.Operators.Binders

diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -104,6 +104,7 @@ data SimpleErrorMessage
   | UndefinedTypeVariable (ProperName 'TypeName)
   | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))
   | EscapedSkolem Text (Maybe SourceSpan) SourceType
+  | TypeConstructorsDoNotUnify ModuleName SourceType ModuleName SourceType
   | TypesDoNotUnify SourceType SourceType
   | KindsDoNotUnify SourceType SourceType
   | ConstrainedTypeUnified SourceType SourceType
@@ -283,6 +284,7 @@ errorCode em = case unwrapErrorMessage em of
   UndefinedTypeVariable{} -> "UndefinedTypeVariable"
   PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym"
   EscapedSkolem{} -> "EscapedSkolem"
+  TypeConstructorsDoNotUnify{} -> "TypeConstructorsDoNotUnify"
   TypesDoNotUnify{} -> "TypesDoNotUnify"
   KindsDoNotUnify{} -> "KindsDoNotUnify"
   ConstrainedTypeUnified{} -> "ConstrainedTypeUnified"
@@ -410,6 +412,13 @@ addHint hint = addHints [hint]
 addHints :: [ErrorMessageHint] -> MultipleErrors -> MultipleErrors
 addHints hints = onErrorMessages $ \(ErrorMessage hints' se) -> ErrorMessage (hints ++ hints') se
 
+mkTypesDoNotUnify :: SourceType -> SourceType -> SimpleErrorMessage
+mkTypesDoNotUnify
+  t1@(TypeConstructor _ (Qualified (ByModuleName mn1) _))
+  t2@(TypeConstructor _ (Qualified (ByModuleName mn2) _))
+  = TypeConstructorsDoNotUnify mn1 t1 mn2 t2
+mkTypesDoNotUnify t1 t2 = TypesDoNotUnify t1 t2
+
 -- | A map from rigid type variable name/unknown variable pairs to new variables.
 data TypeMap = TypeMap
   { umSkolemMap   :: M.Map Int (String, Int, Maybe SourceSpan)
@@ -462,7 +471,9 @@ onTypesInErrorMessageM :: Applicative m => (SourceType -> m SourceType) -> Error
 onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple
   where
   gSimple (InfiniteType t) = InfiniteType <$> f t
+  gSimple (TypeConstructorsDoNotUnify mn1 t1 mn2 t2) = TypeConstructorsDoNotUnify mn1 <$> f t1 <*> pure mn2 <*> f t2
   gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2
+  gSimple (KindsDoNotUnify t1 t2) = KindsDoNotUnify <$> f t1 <*> f t2
   gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2
   gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
   gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
@@ -855,6 +866,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
                  , line "with type"
                  , row2Box
                  ]
+    renderSimpleErrorMessage (TypeConstructorsDoNotUnify mn1 u1 mn2 u2)
+      = let (row1Box, row2Box) = printRows u1 u2
+
+        in paras [ line "Could not match type"
+                 , row1Box
+                 , line $ "(defined in module " <> markCode (runModuleName mn1) <> ")"
+                 , line "with type"
+                 , row2Box
+                 , line $ "(defined in module " <> markCode (runModuleName mn2) <> ")"
+                 ]
 
     renderSimpleErrorMessage (KindsDoNotUnify k1 k2) =
       paras [ line "Could not match kind"
@@ -1564,14 +1585,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
     -- If verbose print all rows else only print unique rows
     printRows :: Type a -> Type a -> (Box.Box, Box.Box)
     printRows r1 r2 = case (full, r1, r2) of
-      (True, _ , _) -> (printRow typeAsBox r1, printRow typeAsBox r2)
+      (True, _ , _) -> (printRow prettyTypeWithDepth r1, printRow prettyTypeWithDepth r2)
 
       (_, RCons{}, RCons{}) ->
         let (sorted1, sorted2) = filterRows (rowToList r1) (rowToList r2)
         in (printRow typeDiffAsBox sorted1, printRow typeDiffAsBox sorted2)
 
-      (_, _, _) -> (printRow typeAsBox r1, printRow typeAsBox r2)
-
+      (_, _, _) -> (printRow prettyTypeWithDepth r1, printRow prettyTypeWithDepth r2)
 
     -- Keep the unique labels only
     filterRows :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a)
@@ -1646,13 +1666,15 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
 
   prettyTypeWithDepth :: Int -> Type a -> Box.Box
   prettyTypeWithDepth depth
-    | full = typeAsBox depth
-    | otherwise = typeAsBox depth . eraseForAllKindAnnotations . eraseKindApps
+    | full = typeAsBoxWith depth prettyOptions
+    | otherwise = typeAsBoxWith depth prettyOptions . eraseForAllKindAnnotations . eraseKindApps
 
   prettyTypeAtom :: Type a -> Box.Box
   prettyTypeAtom
-    | full = typeAtomAsBox prettyDepth
-    | otherwise = typeAtomAsBox prettyDepth . eraseForAllKindAnnotations . eraseKindApps
+    | full = typeAtomAsBoxWith prettyDepth prettyOptions
+    | otherwise = typeAtomAsBoxWith prettyDepth prettyOptions . eraseForAllKindAnnotations . eraseKindApps
+
+  prettyOptions = defaultTypeRenderOptions { troDisqualifyNames = False }
 
   levelText :: Text
   levelText = case level of
@@ -1684,6 +1706,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon
       where
       isCheckHint ErrorCheckingType{} = True
       isCheckHint _ = False
+    stripRedundantHints TypeConstructorsDoNotUnify{} = stripFirst isUnifyHint
+      where
+      isUnifyHint ErrorUnifyingTypes{} = True
+      isUnifyHint _ = False
     stripRedundantHints TypesDoNotUnify{} = stripFirst isUnifyHint
       where
       isUnifyHint ErrorUnifyingTypes{} = True

diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -41,6 +41,7 @@ import           Language.PureScript.ModuleDependencies
 import           Language.PureScript.Names
 import           Language.PureScript.Renamer
 import           Language.PureScript.Sugar
+import           Language.PureScript.Sugar.Names.Requalify
 import           Language.PureScript.TypeChecker
 import           Language.PureScript.Make.BuildPlan
 import qualified Language.PureScript.Make.BuildPlan as BuildPlan
@@ -87,13 +88,14 @@ rebuildModuleWithIndex
 rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) moduleIndex = do
   progress $ CompilingModule moduleName moduleIndex
   let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
-      withPrim = importPrim m
+      withPrim = importPrim m -- TODO: are we importing Prim twice
   lint withPrim
 
   ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
     (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty)
     let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
-    (checked, CheckState{..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
+        localImports = maybe (internalError "no local imports") (\(_, imports, _) -> imports) $ M.lookup moduleName exEnv'
+    (checked, CheckState{..}) <- rethrow (requalifyTypesInErrors localImports) $ runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env
     let usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) ->
           M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkConstructorImportsForCoercible
     -- Imports cannot be linted before type checking because we need to

diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs
@@ -127,7 +127,7 @@ isPlainIdent _ = False
 -- Operator alias names.
 --
 newtype OpName (a :: OpNameType) = OpName { runOpName :: Text }
-  deriving (Show, Eq, Ord, Generic)
+  deriving (Show, Read, Eq, Ord, Generic)
 
 instance NFData (OpName a)
 instance Serialise (OpName a)
@@ -156,7 +156,7 @@ coerceOpName = OpName . runOpName
 -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
 --
 newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text }
-  deriving (Show, Eq, Ord, Generic)
+  deriving (Show, Read, Eq, Ord, Generic)
 
 instance NFData (ProperName a)
 instance Serialise (ProperName a)
@@ -188,7 +188,7 @@ coerceProperName = ProperName . runProperName
 -- Module names
 --
 newtype ModuleName = ModuleName Text
-  deriving (Show, Eq, Ord, Generic)
+  deriving (Show, Read, Eq, Ord, Generic)
   deriving newtype Serialise
 
 instance NFData ModuleName

diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
@@ -7,13 +7,17 @@
 module Language.PureScript.Pretty.Types
   ( PrettyPrintType(..)
   , PrettyPrintConstraint
+  , TypeRenderOptions(..)
+  , defaultTypeRenderOptions
   , convertPrettyPrintType
   , typeAsBox
+  , typeAsBoxWith
   , typeDiffAsBox
   , prettyPrintType
   , prettyPrintTypeWithUnicode
   , prettyPrintSuggestedType
   , typeAtomAsBox
+  , typeAtomAsBoxWith
   , prettyPrintTypeAtom
   , prettyPrintLabel
   , prettyPrintObjectKey
@@ -181,7 +185,7 @@ explicitParens = mkPattern match
   match _ = Nothing
 
 matchTypeAtom :: TypeRenderOptions -> Pattern () PrettyPrintType Box
-matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =
+matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting, troDisqualifyNames = disqualifying} =
     typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) (matchType tro)
   where
     typeLiterals :: Pattern () PrettyPrintType Box
@@ -190,7 +194,10 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} =
       match (PPTypeVar var _) = Just $ text $ T.unpack var
       match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s
       match (PPTypeLevelInt n) = Just $ text $ show n
-      match (PPTypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor
+      match (PPTypeConstructor ctor) = Just $ text $ T.unpack $
+        if disqualifying
+          then runProperName $ disqualify ctor
+          else showQualified runProperName ctor
       match (PPTUnknown u)
         | suggesting = Just $ text "_"
         | otherwise = Just $ text $ 't' : show u
@@ -238,10 +245,16 @@ forall_ = mkPattern match
   match (PPForAll idents ty) = Just (map (first T.unpack) idents, ty)
   match _ = Nothing
 
-typeAtomAsBox' :: PrettyPrintType -> Box
-typeAtomAsBox'
+typeAtomAsBoxWith' :: TypeRenderOptions -> PrettyPrintType -> Box
+typeAtomAsBoxWith' tro
   = fromMaybe (internalError "Incomplete pattern")
-  . PA.pattern (matchTypeAtom defaultOptions) ()
+  . PA.pattern (matchTypeAtom tro) ()
+
+typeAtomAsBox' :: PrettyPrintType -> Box
+typeAtomAsBox' = typeAtomAsBoxWith' defaultTypeRenderOptions
+
+typeAtomAsBoxWith :: Int -> TypeRenderOptions -> Type a -> Box
+typeAtomAsBoxWith maxDepth tro = typeAtomAsBoxWith' tro . convertPrettyPrintType maxDepth
 
 typeAtomAsBox :: Int -> Type a -> Box
 typeAtomAsBox maxDepth = typeAtomAsBox' . convertPrettyPrintType maxDepth
@@ -250,14 +263,22 @@ typeAtomAsBox maxDepth = typeAtomAsBox' . convertPrettyPrintType maxDepth
 prettyPrintTypeAtom :: Int -> Type a -> String
 prettyPrintTypeAtom maxDepth = render . typeAtomAsBox maxDepth
 
+typeAsBoxWith' :: TypeRenderOptions -> PrettyPrintType -> Box
+typeAsBoxWith' tro
+  = fromMaybe (internalError "Incomplete pattern")
+  . PA.pattern (matchType tro) ()
+
+typeAsBoxWith :: Int -> TypeRenderOptions -> Type a -> Box
+typeAsBoxWith maxDepth tro = typeAsBoxWith' tro . convertPrettyPrintType maxDepth
+
 typeAsBox' :: PrettyPrintType -> Box
-typeAsBox' = typeAsBoxImpl defaultOptions
+typeAsBox' = typeAsBoxWith' defaultTypeRenderOptions
 
 typeAsBox :: Int -> Type a -> Box
 typeAsBox maxDepth = typeAsBox' . convertPrettyPrintType maxDepth
 
 typeDiffAsBox' :: PrettyPrintType -> Box
-typeDiffAsBox' = typeAsBoxImpl diffOptions
+typeDiffAsBox' = typeAsBoxWith' diffOptions
 
 typeDiffAsBox :: Int -> Type a -> Box
 typeDiffAsBox maxDepth = typeDiffAsBox' . convertPrettyPrintType maxDepth
@@ -266,28 +287,29 @@ data TypeRenderOptions = TypeRenderOptions
   { troSuggesting :: Bool
   , troUnicode :: Bool
   , troRowAsDiff :: Bool
+  , troDisqualifyNames :: Bool
   }
 
-suggestingOptions :: TypeRenderOptions
-suggestingOptions = TypeRenderOptions True False False
+defaultTypeRenderOptions :: TypeRenderOptions
+defaultTypeRenderOptions = TypeRenderOptions
+  { troSuggesting = False
+  , troUnicode = False
+  , troRowAsDiff = False
+  , troDisqualifyNames = True
+  }
 
-defaultOptions :: TypeRenderOptions
-defaultOptions = TypeRenderOptions False False False
+suggestingOptions :: TypeRenderOptions
+suggestingOptions = defaultTypeRenderOptions { troSuggesting = True }
 
 diffOptions :: TypeRenderOptions
-diffOptions = TypeRenderOptions False False True
+diffOptions = defaultTypeRenderOptions { troRowAsDiff = True }
 
 unicodeOptions :: TypeRenderOptions
-unicodeOptions = TypeRenderOptions False True False
-
-typeAsBoxImpl :: TypeRenderOptions -> PrettyPrintType -> Box
-typeAsBoxImpl tro
-  = fromMaybe (internalError "Incomplete pattern")
-  . PA.pattern (matchType tro) ()
+unicodeOptions = defaultTypeRenderOptions { troUnicode = True }
 
 -- | Generate a pretty-printed string representing a 'Type'
 prettyPrintType :: Int -> Type a -> String
-prettyPrintType = flip prettyPrintType' defaultOptions
+prettyPrintType = flip prettyPrintType' defaultTypeRenderOptions
 
 -- | Generate a pretty-printed string representing a 'Type' using unicode
 -- symbols where applicable
@@ -299,7 +321,7 @@ prettyPrintSuggestedType :: Type a -> String
 prettyPrintSuggestedType = prettyPrintType' maxBound suggestingOptions
 
 prettyPrintType' :: Int -> TypeRenderOptions -> Type a -> String
-prettyPrintType' maxDepth tro = render . typeAsBoxImpl tro . convertPrettyPrintType maxDepth
+prettyPrintType' maxDepth tro = render . typeAsBoxWith' tro . convertPrettyPrintType maxDepth
 
 prettyPrintLabel :: Label -> Text
 prettyPrintLabel (Label s) =