Attempt to improve function under-application and over-application errors

parser-typechecker/src/Unison/PrintError.hs

@@ -74,6 +74,7 @@ import Unison.Util.AnnotatedText qualified as AT
 import Unison.Util.ColorText (Color)
 import Unison.Util.ColorText qualified as Color
 import Unison.Util.Monoid (intercalateMap)
+import Unison.Util.Monoid qualified as Monoid
 import Unison.Util.Pretty (ColorText, Pretty)
 import Unison.Util.Pretty qualified as Pr
 import Unison.Util.Range (Range (..), startingLine)
@@ -328,14 +329,92 @@ renderTypeError e env src = case e of
               " expression ",
               "need to have the same type."
             ]
-  NotFunctionApplication {..} ->
+  FunctionUnderApplied {..} ->
     mconcat
-      [ "This looks like a function call, but with a ",
-        style Type1 (renderType' env ft),
-        " where the function should be.  Are you missing an operator?\n\n",
-        annotatedAsStyle Type1 src f,
+      [ Pr.lines
+          [ "I found a value  of type:  " <> style Type1 (renderType' env foundLeaf),
+            "where I expected to find:  " <> style Type2 (renderType' env expectedLeaf),
+            "it looks like it might be a function application that's just missing these arguments:\n\n",
+            Monoid.intercalateMap ", " (style Type1 . renderType' env) needArgs
+          ],
+        "\n\n",
+        showSourceMaybes
+          src
+          [ -- these are overwriting the colored ranges for some reason?
+            --   (,Color.ForceShow) <$> rangeForAnnotated mismatchSite
+            -- , (,Color.ForceShow) <$> rangeForType foundType
+            -- , (,Color.ForceShow) <$> rangeForType expectedType
+            -- ,
+            (,Type1) . startingLine <$> (rangeForAnnotated mismatchSite),
+            (,Type2) <$> rangeForAnnotated expectedLeaf
+          ],
+        fromOverHere'
+          src
+          [styleAnnotated Type1 foundLeaf]
+          [styleAnnotated Type2 expectedLeaf],
+        unitHint,
+        intLiteralSyntaxTip mismatchSite expectedType,
+        debugNoteLoc
+          . mconcat
+          $ [ "\nloc debug:",
+              "\n  mismatchSite: ",
+              annotatedToEnglish mismatchSite,
+              "\n     foundType: ",
+              annotatedToEnglish foundType,
+              "\n     foundLeaf: ",
+              annotatedToEnglish foundLeaf,
+              "\n  expectedType: ",
+              annotatedToEnglish expectedType,
+              "\n  expectedLeaf: ",
+              annotatedToEnglish expectedLeaf,
+              "\n"
+            ],
         debugSummary note
       ]
+    where
+      unitHintMsg =
+        "\nHint: Actions within a block must have type "
+          <> style Type2 (renderType' env expectedLeaf)
+          <> ".\n"
+          <> "      Use "
+          <> style Type1 "_ = <expr>"
+          <> " to ignore a result."
+      unitHint = if giveUnitHint then unitHintMsg else ""
+      giveUnitHint = case expectedType of
+        Type.Ref' u | u == unitRef -> case mismatchSite of
+          Term.Let1Named' v _ _ -> Var.isAction v
+          _ -> False
+        _ -> False
+  NotFunctionApplication {..} ->
+    case Type.arity ft of
+      0 ->
+        mconcat
+          [ "It looks like this expression is being called like a function:\n\n",
+            annotatedAsStyle ErrorSite src f,
+            "\n\nbut the thing being applied has the type:\n\n",
+            style Type2 (renderType' env ft),
+            "\n\nWhich doesn't expect any arguments.",
+            "\n\n",
+            debugSummary note
+          ]
+      arity ->
+        mconcat
+          [ "It looks like this function call\n\n",
+            annotatedAsStyle Type2 src f,
+            "\n\nis being applied to ",
+            Pr.blue $ Pr.shown (length args),
+            " arguments, but it has the type\n\n",
+            style Type2 (renderType' env ft),
+            "\n\nwhich only accepts only ",
+            Pr.blue $ Pr.shown arity,
+            maybePlural " argument" arity <> ".\n\n",
+            "Did you apply the function to too many arguments? \n\n",
+            debugSummary note
+          ]
+    where
+      maybePlural word n
+        | n == 1 = word
+        | otherwise = word <> "s"
   FunctionApplication {..} ->
     let fte = Type.removePureEffects False ft
         fteFreeVars = Set.map TypeVar.underlying $ ABT.freeVars fte

parser-typechecker/src/Unison/Typechecker/TypeError.hs

@@ -11,6 +11,7 @@ import Unison.Type (Type)
 import Unison.Type qualified as Type
 import Unison.Typechecker.Context qualified as C
 import Unison.Typechecker.Extractor qualified as Ex
+import Unison.Typechecker.TypeVar (lowerType)
 import Unison.Util.Monoid (whenM)
 import Unison.Var (Var)
 import Prelude hiding (all, and, or)
@@ -58,7 +59,17 @@ data TypeError v loc
   | NotFunctionApplication
       { f :: C.Term v loc,
         ft :: C.Type v loc,
-        note :: C.ErrorNote v loc
+        note :: C.ErrorNote v loc,
+        args :: [C.Term v loc]
+      }
+  | FunctionUnderApplied
+      { foundType :: C.Type v loc, -- overallType1
+        expectedType :: C.Type v loc, -- overallType2
+        foundLeaf :: C.Type v loc, -- leaf1
+        expectedLeaf :: C.Type v loc, -- leaf2
+        mismatchSite :: C.Term v loc,
+        note :: C.ErrorNote v loc,
+        needArgs :: [Type v loc]
       }
   | AbilityCheckFailure
       { ambient :: [C.Type v loc],
@@ -241,9 +252,27 @@ generalMismatch = do
   n <- Ex.errorNote
   mismatchSite <- Ex.innermostTerm
   ((foundLeaf, expectedLeaf), (foundType, expectedType)) <- firstLastSubtype
+  let mayNeedArgs = findUnderApplication foundLeaf expectedLeaf
+  -- If the found type is a function, and the result of that function matches the expected type,
+  -- it's likely we're missing some arguments from a function.
+
   case Type.cleanups [sub foundType, sub expectedType, sub foundLeaf, sub expectedLeaf] of
-    [ft, et, fl, el] -> pure $ Mismatch ft et fl el mismatchSite n
+    [ft, et, fl, el] ->
+      case mayNeedArgs of
+        Just needArgs ->
+          pure $ FunctionUnderApplied ft et fl el mismatchSite n (lowerType <$> needArgs)
+        Nothing ->
+          pure $ Mismatch ft et fl el mismatchSite n
     _ -> error "generalMismatch: Mismatched type binding"
+  where
+    findUnderApplication found expected
+      | Right True <- C.isSubtype found expected = pure []
+      | otherwise =
+          case found of
+            Type.Arrow' i o -> (i :) <$> findUnderApplication o expected
+            Type.ForallNamed' _ body -> findUnderApplication body expected
+            Type.Effect' _ inner -> findUnderApplication inner expected
+            _ -> Nothing
 
 and,
   or,
@@ -321,15 +350,15 @@ applyingNonFunction :: (Var v) => Ex.ErrorExtractor v loc (TypeError v loc)
 applyingNonFunction = do
   _ <- Ex.typeMismatch
   n <- Ex.errorNote
-  (f, ft) <- Ex.unique $ do
+  (f, ft, args) <- Ex.unique $ do
     Ex.pathStart
-    (arity0Type, _arg, _argNum) <- Ex.inSynthesizeApp
+    _synthApp <- Ex.inSynthesizeApp
     (_, f, ft, args) <- Ex.inFunctionCall
     let expectedArgCount = Type.arity ft
         foundArgCount = length args
     -- unexpectedArgLoc = ABT.annotation arg
-    whenM (expectedArgCount < foundArgCount) $ pure (f, arity0Type)
-  pure $ NotFunctionApplication f (Type.cleanup ft) n
+    whenM (expectedArgCount < foundArgCount) $ pure (f, ft, args)
+  pure $ NotFunctionApplication f (Type.cleanup ft) n args
 
 -- | Want to collect this info:
 -- The `n`th argument to `f` is `foundType`, but I was expecting `expectedType`.

unison-cli/src/Unison/LSP/FileAnalysis.hs

@@ -278,6 +278,7 @@ analyseNotes fileUri ppe src notes = do
               TypeError.Mismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite
               TypeError.BooleanMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite
               TypeError.ExistentialMismatch {mismatchSite} -> singleRange $ ABT.annotation mismatchSite
+              TypeError.FunctionUnderApplied {mismatchSite} -> singleRange $ ABT.annotation mismatchSite
               TypeError.FunctionApplication {f} -> singleRange $ ABT.annotation f
               TypeError.NotFunctionApplication {f} -> singleRange $ ABT.annotation f
               TypeError.AbilityCheckFailure {abilityCheckFailureSite} -> singleRange abilityCheckFailureSite

unison-core/src/Unison/Type.hs

@@ -102,6 +102,7 @@ arity :: Type v a -> Int
 arity (ForallNamed' _ body) = arity body
 arity (Arrow' _ o) = 1 + arity o
 arity (Ann' a _) = arity a
+arity (Effect' _ o) = arity o
 arity _ = 0
 
 -- some smart patterns
@@ -142,7 +143,7 @@ pattern Effects' es <- ABT.Tm' (Effects es)
 pattern Effect1' :: ABT.Term F v a -> ABT.Term F v a -> ABT.Term F v a
 pattern Effect1' e t <- ABT.Tm' (Effect e t)
 
-pattern Effect' :: (Ord v) => [Type v a] -> Type v a -> Type v a
+pattern Effect' :: [Type v a] -> Type v a -> Type v a
 pattern Effect' es t <- (unEffects1 -> Just (es, t))
 
 pattern Effect'' :: (Ord v) => [Type v a] -> Type v a -> Type v a
@@ -242,7 +243,7 @@ unEffect0 :: (Ord v) => Type v a -> ([Type v a], Type v a)
 unEffect0 (Effect1' e a) = (flattenEffects e, a)
 unEffect0 t = ([], t)
 
-unEffects1 :: (Ord v) => Type v a -> Maybe ([Type v a], Type v a)
+unEffects1 :: Type v a -> Maybe ([Type v a], Type v a)
 unEffects1 (Effect1' (Effects' es) a) = Just (es, a)
 unEffects1 _ = Nothing
 
@@ -756,6 +757,7 @@ functionResult = go False
   where
     go inArr (ForallNamed' _ body) = go inArr body
     go _inArr (Arrow' _i o) = go True o
+    go _inArr (Effect1' _e body) = go True body
     go inArr t = if inArr then Just t else Nothing
 
 -- | Bind all free variables (not in `except`) that start with a lowercase