feat: Improve printing of incomplete patterns

madlib-lang · Nov 7, 2022 · 092bbe8 · 092bbe8
1 parent 1db2ee4
commit 092bbe8
Show file tree

Hide file tree

Showing 2 changed files with 38 additions and 10 deletions.
diff --git a/compiler/main/Explain/Format.hs b/compiler/main/Explain/Format.hs
@@ -182,8 +182,8 @@ createSimpleWarningDiagnostic _ _ warning = case warning of
 
   IncompletePattern missingPatterns ->
     "Incomplete pattern\n\n"
-    <> "Missing patterns:\n"
-    <> intercalate "\n" (map ("  - "++) missingPatterns)
+    <> "Examples of missing patterns:\n"
+    <> intercalate "\n" (map ("  - "++) missingPatterns) <> "\n\n"
     <> "Note: If the input of where is not handled by a branch, it will most likely crash at\nruntime.\n"
     <> "Hint: Pattern match the missing constructors or add a catch all branch with '_ => ...'."
 
@@ -416,7 +416,7 @@ createWarningDiagnostic _ context warning = case warning of
           [ ( Diagnose.Position (startL, startC) (endL, endC) modulePath
             , Diagnose.This $
                 "The branches do not cover all cases\n"
-                <> "Missing patterns:\n"
+                <> "Examples of missing patterns:\n"
                 <> intercalate "\n" (map ("  - "++) missingPatterns)
             )
           ]

diff --git a/compiler/main/Infer/ExhaustivePatterns.hs b/compiler/main/Infer/ExhaustivePatterns.hs
@@ -85,7 +85,7 @@ simplify ast env (Slv.Typed _ _ pattern) = case pattern of
     return $ Ctor (ADTInfo (length ctors) ctors) name args'
 
   Slv.PList lis -> do
-    let nil     = Ctor (ADTInfo 2 [conCtor, nilCtor]) "Nil" []
+    let nil     = Ctor (ADTInfo 2 [conCtor, nilCtor]) "__Nil__" []
 
     case Slv.getSpreadPattern lis of
       Just _ -> do
@@ -95,13 +95,13 @@ simplify ast env (Slv.Typed _ _ pattern) = case pattern of
         foldM
           (\tl hd -> do
               hd' <- simplify ast env hd
-              return $ Ctor (ADTInfo 2 [conCtor, nilCtor]) "Cons" [tl, hd']
+              return $ Ctor (ADTInfo 2 [conCtor, nilCtor]) "__Cons__" [tl, hd']
           )
           nil
           lis
     where
-      conCtor = Slv.Untyped emptyArea (Slv.Constructor "Cons" [Slv.Untyped emptyArea (Slv.TRSingle "a")] tList)
-      nilCtor = Slv.Untyped emptyArea (Slv.Constructor "Nil" [] tList)
+      conCtor = Slv.Untyped emptyArea (Slv.Constructor "__Cons__" [Slv.Untyped emptyArea (Slv.TRSingle "a")] tList)
+      nilCtor = Slv.Untyped emptyArea (Slv.Constructor "__Nil__" [] tList)
       buildConsPattern :: [Slv.Pattern] -> Infer Pattern
       buildConsPattern patterns = case patterns of
         [pat] ->
@@ -110,7 +110,7 @@ simplify ast env (Slv.Typed _ _ pattern) = case pattern of
         pat : pats -> do
           pat'  <- simplify ast env pat
           pats' <- buildConsPattern pats
-          return $ Ctor (ADTInfo 2 [conCtor, nilCtor]) "Cons" [pats', pat']
+          return $ Ctor (ADTInfo 2 [conCtor, nilCtor]) "__Cons__" [pats', pat']
 
   Slv.PSpread pattern ->
     simplify ast env pattern
@@ -330,7 +330,6 @@ checkPatterns ast env area patterns = do
           return ()
 
         badPatterns -> do
-          liftIO $ putStrLn $ ppShow badPatterns
           pushWarning (CompilationWarning (IncompletePattern (map showPattern $ concat badPatterns)) (Context (envCurrentPath env) area))
 
 
@@ -351,12 +350,41 @@ showPattern pattern = case pattern of
         s
 
   Ctor _ name args ->
-    name <> "(" <> List.intercalate ", " (showPattern <$> args) <> ")"
+    if name == "__Cons__" then
+      "[" <> List.intercalate ", " (List.replicate (getConsArgCount pattern) "_") <> "]"
+    else if name == "__Nil__" then
+      "[]"
+    else if name `List.elem` [ "(,)"
+                             , "(,,)"
+                             , "(,,,)"
+                             , "(,,,,)"
+                             , "(,,,,,)"
+                             , "(,,,,,,)"
+                             , "(,,,,,,,)"
+                             , "(,,,,,,,,)"
+                             , "(,,,,,,,,,)"
+                             ] then
+      "#[" <> showArgs args <> "]"
+    else if null args then
+      name
+    else
+      name <> "(" <> showArgs args <> ")"
+    where
+      showArgs as = List.intercalate ", " (showPattern <$> as)
 
   Record fields ->
     "{ " <> List.intercalate ", " (map (\(name, pat) -> name <> ": " <> showPattern pat) (Map.toList fields)) <> " }"
 
 
+getConsArgCount :: Pattern -> Int
+getConsArgCount pattern = case pattern of
+  Ctor _ "__Cons__" args ->
+    1 + getConsArgCount (head args)
+
+  _ ->
+    0
+
+
 -- EXHAUSTIVE PATTERNS