Merge pull request #121 from allanderek/main

Allow _key style wildcard patterns.

CONTRIBUTORS

@@ -2,3 +2,4 @@ Robin Heggelund Hansen (robinheghan)
 Julian Antonielli (jjant)
 Aaron VonderHaar (avh4)
 lue (lue-bird)
+Allan Clark (allanderek)

compiler/src/AST/Source.hs

@@ -92,7 +92,7 @@ data Def
 type Pattern = A.Located Pattern_
 
 data Pattern_
-  = PAnything
+  = PAnything Name
   | PVar Name
   | PRecord [RecordFieldPattern]
   | PAlias Pattern (A.Located Name)

compiler/src/Canonicalize/Expression.hs

@@ -237,7 +237,7 @@ addBindings bindings (A.At _ def) =
 addBindingsHelp :: Dups.Dict A.Region -> Src.Pattern -> Dups.Dict A.Region
 addBindingsHelp bindings (A.At region pattern) =
   case pattern of
-    Src.PAnything ->
+    Src.PAnything _ ->
       bindings
     Src.PVar name ->
       Dups.insert name region region bindings
@@ -349,7 +349,7 @@ addEdge edges nodes aname@(A.At _ name) =
 getPatternNames :: [A.Located Name.Name] -> Src.Pattern -> [A.Located Name.Name]
 getPatternNames names (A.At region pattern) =
   case pattern of
-    Src.PAnything -> names
+    Src.PAnything _ -> names
     Src.PVar name -> A.At region name : names
     Src.PRecord fields ->
       List.foldl' (\n f -> getPatternNames n (extractRecordFieldPattern f)) names fields

compiler/src/Canonicalize/Pattern.hs

@@ -58,7 +58,7 @@ canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern
 canonicalize env (A.At region pattern) =
   A.At region
     <$> case pattern of
-      Src.PAnything ->
+      Src.PAnything _ ->
         Result.ok Can.PAnything
       Src.PVar name ->
         logVar name region (Can.PVar name)

compiler/src/Parse/Expression.hs

@@ -37,7 +37,8 @@ term =
         array start,
         record start >>= accessible start,
         accessor start,
-        character start
+        character start,
+        wildcard
       ]
 
 string :: A.Position -> Parser E.Expr Src.Expr
@@ -112,6 +113,15 @@ variable start =
     var <- Var.foreignAlpha E.Start
     addEnd start var
 
+wildcard :: Parser E.Expr a
+wildcard =
+  do
+    word1 0x5F {- _ -} E.Start
+    -- Note, because this is not optional, this will not match '_' on its own.
+    name <- Var.lower E.Start
+    P.Parser $ \(P.State _ _ _ _ row col) _ _ cerr _ ->
+      cerr row col (E.WildCard $ E.WildCardAttempt name)
+
 accessible :: A.Position -> Src.Expr -> Parser E.Expr Src.Expr
 accessible start expr =
   oneOfWithFallback

compiler/src/Parse/Pattern.hs

@@ -43,8 +43,8 @@ termHelp start =
   oneOf
     E.PStart
     [ do
-        wildcard
-        addEnd start Src.PAnything,
+        name <- wildcard
+        addEnd start (Src.PAnything name),
       do
         name <- Var.lower E.PStart
         addEnd start (Src.PVar name),
@@ -79,21 +79,26 @@ termHelp start =
 
 -- WILDCARD
 
-wildcard :: Parser E.Pattern ()
+wildcard :: Parser E.Pattern Name.Name
 wildcard =
-  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
+  P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
     if pos == end || P.unsafeIndex pos /= 0x5F {- _ -}
       then eerr row col E.PStart
       else
-        let !newPos = plusPtr pos 1
-            !newCol = col + 1
-         in if Var.getInnerWidth newPos end > 0
-              then
-                let (# badPos, badCol #) = Var.chompInnerChars newPos end newCol
-                 in cerr row col (E.PWildcardNotVar (Name.fromPtr pos badPos) (fromIntegral (badCol - col)))
-              else
-                let !newState = P.State src newPos end indent row newCol
-                 in cok () newState
+        let lowerVarPosition = plusPtr pos 1
+            (# newPos, newCol #) = Var.chompLower lowerVarPosition end (col + 1)
+            -- Note although we are getting the name, to check that it is not a reserved keyword, we are not storing it.
+            -- We ultimately wish to throw it away, but in theory we could make the AST of wildcard take the name
+            -- as a parameter, and then we could use that, to, for example, check that we are not shadowing/duplicating any
+            -- such wildcard names, eg. check against something like:
+            -- getZ _x _x z = z
+            -- when you probably meant
+            -- getZ _x _y z = z
+            !name = Name.fromPtr lowerVarPosition newPos
+            !newState = P.State src newPos end indent row newCol
+         in if Var.isReservedWord name
+              then eerr row col E.PStart
+              else cok name newState
 
 -- PARENTHESIZED PATTERNS
 

compiler/src/Parse/Symbol.hs

@@ -26,6 +26,7 @@ data BadOperator
   | BadArrow
   | BadEquals
   | BadHasType
+  deriving (Show)
 
 operator :: (Row -> Col -> x) -> (BadOperator -> Row -> Col -> x) -> Parser x Name.Name
 operator toExpectation toError =

compiler/src/Parse/Variable.hs

@@ -11,7 +11,9 @@ module Parse.Variable
     Upper (..),
     foreignUpper,
     foreignAlpha,
+    chompLower,
     chompInnerChars,
+    isReservedWord,
     getUpperWidth,
     getInnerWidth,
     getInnerWidthHelp,
@@ -52,13 +54,17 @@ lower toError =
           then eerr row col toError
           else
             let !name = Name.fromPtr pos newPos
-             in if Set.member name reservedWords
+             in if isReservedWord name
                   then eerr row col toError
                   else
                     let !newState =
                           P.State src newPos end indent row newCol
                      in cok name newState
 
+isReservedWord :: Name.Name -> Bool
+isReservedWord name =
+  Set.member name reservedWords
+
 reservedWords :: Set.Set Name.Name
 reservedWords =
   Set.fromList

compiler/src/Reporting/Error/Syntax.hs

@@ -39,6 +39,7 @@ module Reporting.Error.Syntax
     String (..),
     Escape (..),
     Number (..),
+    WildCard (..),
     --
     Space (..),
     toSpaceReport,
@@ -205,6 +206,8 @@ data Expr
   | Number Number Row Col
   | Space Space Row Col
   | IndentOperatorRight Name.Name Row Col
+  | WildCard WildCard Row Col
+  deriving (Show)
 
 data Record
   = RecordOpen Row Col
@@ -221,6 +224,7 @@ data Record
   | RecordIndentField Row Col
   | RecordIndentEquals Row Col
   | RecordIndentExpr Row Col
+  deriving (Show)
 
 data Array
   = ArraySpace Space Row Col
@@ -231,6 +235,7 @@ data Array
     ArrayIndentOpen Row Col
   | ArrayIndentEnd Row Col
   | ArrayIndentExpr Row Col
+  deriving (Show)
 
 data Func
   = FuncSpace Space Row Col
@@ -241,6 +246,7 @@ data Func
     FuncIndentArg Row Col
   | FuncIndentArrow Row Col
   | FuncIndentBody Row Col
+  deriving (Show)
 
 data Case
   = CaseSpace Space Row Col
@@ -256,6 +262,7 @@ data Case
   | CaseIndentArrow Row Col
   | CaseIndentBranch Row Col
   | CasePatternAlignment Word16 Row Col
+  deriving (Show)
 
 data If
   = IfSpace Space Row Col
@@ -272,6 +279,7 @@ data If
   | IfIndentThenBranch Row Col
   | IfIndentElseBranch Row Col
   | IfIndentElse Row Col
+  deriving (Show)
 
 data Let
   = LetSpace Space Row Col
@@ -284,6 +292,7 @@ data Let
   | LetIndentDef Row Col
   | LetIndentIn Row Col
   | LetIndentBody Row Col
+  deriving (Show)
 
 data Parenthesized
   = ParenthesizedOpen Row Col
@@ -296,6 +305,7 @@ data Parenthesized
     ParenthesizedIndentOpen Row Col
   | ParenthesizedIndentEnd Row Col
   | ParenthesizedIndentExpr Row Col
+  deriving (Show)
 
 data Def
   = DefSpace Space Row Col
@@ -309,6 +319,7 @@ data Def
   | DefIndentType Row Col
   | DefIndentBody Row Col
   | DefAlignment Word16 Row Col
+  deriving (Show)
 
 data Destruct
   = DestructSpace Space Row Col
@@ -317,6 +328,7 @@ data Destruct
   | DestructBody Expr Row Col
   | DestructIndentEquals Row Col
   | DestructIndentBody Row Col
+  deriving (Show)
 
 -- PATTERNS
 
@@ -331,11 +343,11 @@ data Pattern
   | PNumber Number Row Col
   | PFloat Word16 Row Col
   | PAlias Row Col
-  | PWildcardNotVar Name.Name Int Row Col
   | PSpace Space Row Col
   | --
     PIndentStart Row Col
   | PIndentAlias Row Col
+  deriving (Show)
 
 data PParenthesized
   = PParenthesizedSpace Space Row Col
@@ -343,6 +355,7 @@ data PParenthesized
   | PParenthesizedPattern Pattern Row Col
   | PParenthesizedIndentEnd Row Col
   | PParenthesizedEnd Row Col
+  deriving (Show)
 
 data PRecord
   = PRecordOpen Row Col
@@ -355,6 +368,7 @@ data PRecord
     PRecordIndentOpen Row Col
   | PRecordIndentEnd Row Col
   | PRecordIndentField Row Col
+  deriving (Show)
 
 data PArray
   = PArrayOpen Row Col
@@ -365,6 +379,7 @@ data PArray
     PArrayIndentOpen Row Col
   | PArrayIndentEnd Row Col
   | PArrayIndentExpr Row Col
+  deriving (Show)
 
 -- TYPES
 
@@ -376,6 +391,7 @@ data Type
   | TSpace Space Row Col
   | --
     TIndentStart Row Col
+  deriving (Show)
 
 data TRecord
   = TRecordOpen Row Col
@@ -392,6 +408,7 @@ data TRecord
   | TRecordIndentColon Row Col
   | TRecordIndentType Row Col
   | TRecordIndentEnd Row Col
+  deriving (Show)
 
 data TParenthesis
   = TParenthesisEnd Row Col
@@ -400,6 +417,7 @@ data TParenthesis
   | --
     TParenthesisIndentOpen Row Col
   | TParenthesisIndentEnd Row Col
+  deriving (Show)
 
 -- LITERALS
 
@@ -407,23 +425,31 @@ data Char
   = CharEndless
   | CharEscape Escape
   | CharNotString Word16
+  deriving (Show)
 
 data String
   = StringEndless_Single
   | StringEndless_Multi
   | StringEscape Escape
+  deriving (Show)
 
 data Escape
   = EscapeUnknown
   | BadUnicodeFormat Word16
   | BadUnicodeCode Word16
   | BadUnicodeLength Word16 Int Int
+  deriving (Show)
 
 data Number
   = NumberEnd
   | NumberDot Int
   | NumberHexDigit
   | NumberNoLeadingZero
+  deriving (Show)
+
+data WildCard
+  = WildCardAttempt Name.Name
+  deriving (Show)
 
 -- MISC
 
@@ -2770,6 +2796,22 @@ toExprReport source context expr startRow startCol =
       toStringReport source string row col
     Number number row col ->
       toNumberReport source number row col
+    WildCard (WildCardAttempt name) row col ->
+      let region = toRegion row col
+       in Report.Report "ATTEMPT TO USE WILDCARD VARIABLE" region [] $
+            Code.toSnippet
+              source
+              region
+              Nothing
+              ( D.reflow $
+                  "It appears you are attempting to use a variable name that starts with an underscore (_"
+                    ++ Name.toChars name
+                    ++ ") in an expression. Such variable names can appear in patterns but not expressions.\
+                       \ A pattern consisting of a variable name prefixed by an underscore is equivalent to using\
+                       \ a single '_' pattern and is allowed so that you may name what you are ignoring.",
+                D.reflow $
+                  "Perhaps rename the variable without the underscore prefix."
+              )
     Space space row col ->
       toSpaceReport source space row col
     IndentOperatorRight op row col ->
@@ -5410,40 +5452,6 @@ toPatternReport source context pattern startRow startCol =
                       \ in that case!"
                   ]
               )
-    PWildcardNotVar name width row col ->
-      let region = toWiderRegion row col (fromIntegral width)
-          examples =
-            case dropWhile (== '_') (Name.toChars name) of
-              [] -> [D.dullyellow "x", "or", D.dullyellow "age"]
-              c : cs -> [D.dullyellow (D.fromChars (Char.toLower c : cs))]
-       in Report.Report "UNEXPECTED NAME" region [] $
-            Code.toSnippet source region Nothing $
-              ( D.reflow $
-                  "Variable names cannot start with underscores like this:",
-                D.fillSep $
-                  [ "You",
-                    "can",
-                    "either",
-                    "have",
-                    "an",
-                    "underscore",
-                    "like",
-                    D.dullyellow "_",
-                    "to",
-                    "ignore",
-                    "the",
-                    "value,",
-                    "or",
-                    "you",
-                    "can",
-                    "have",
-                    "a",
-                    "name",
-                    "like"
-                  ]
-                    ++ examples
-                    ++ ["to", "use", "the", "matched", "value."]
-              )
     PSpace space row col ->
       toSpaceReport source space row col
     PIndentStart row col ->

gren.cabal

@@ -239,10 +239,12 @@ Test-Suite gren-tests
 
     other-modules:
         Helpers.Instances
+        Helpers.Parse
 
         -- tests
         Parse.SpaceSpec
         Parse.RecordUpdateSpec
+        Parse.UnderscorePatternSpec
 
     Build-Depends:
         hspec >= 2.7.10 && < 3

tests/Helpers/Parse.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Helpers.Parse
+  ( checkParse,
+    checkSuccessfulParse,
+    checkParseError,
+  )
+where
+
+import Data.ByteString qualified as BS
+import Parse.Primitives qualified as P
+import Parse.Space qualified as Space
+import Reporting.Annotation qualified as A
+import Test.Hspec qualified as Hspec
+
+checkParse :: (Show error, Show target) => Space.Parser error (A.Located target) -> (P.Row -> P.Col -> error) -> (Either error (A.Located target, A.Position) -> Bool) -> BS.ByteString -> IO ()
+checkParse parser toBadEnd checkResult str =
+  Hspec.shouldSatisfy
+    (P.fromByteString parser toBadEnd str)
+    checkResult
+
+checkSuccessfulParse :: (Show error, Show target) => Space.Parser error (A.Located target) -> (P.Row -> P.Col -> error) -> (target -> Bool) -> BS.ByteString -> IO ()
+checkSuccessfulParse parser toBadEnd checkTarget =
+  let checkResult result =
+        case result of
+          Right (A.At _ target, _) ->
+            checkTarget target
+          Left _ ->
+            False
+   in checkParse parser toBadEnd checkResult
+
+checkParseError :: (Show error, Show target) => Space.Parser error (A.Located target) -> (P.Row -> P.Col -> error) -> (error -> Bool) -> BS.ByteString -> IO ()
+checkParseError parser toBadEnd checkError =
+  let checkResult result =
+        case result of
+          Left err ->
+            checkError err
+          Right _ ->
+            False
+   in checkParse parser toBadEnd checkResult

tests/Parse/UnderscorePatternSpec.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parse.UnderscorePatternSpec where
+
+import AST.Source qualified as Src
+import Data.ByteString qualified as BS
+import Data.Name qualified as Name
+import Helpers.Instances ()
+import Helpers.Parse qualified as Helpers
+import Parse.Expression qualified as Expression
+import Parse.Pattern qualified as Pattern
+import Reporting.Error.Syntax qualified as Error.Syntax
+import Test.Hspec (Spec, describe, it)
+
+spec :: Spec
+spec = do
+  describe "Wildcard patterns" $ do
+    it "regression test" $
+      parse "" "_"
+    it "Newly allowed named wildcard pattern" $
+      parse "argument" "_argument"
+    it "You can have underscores as part of the lower variable which follows the underscore" $
+      parse "hello_world" "_hello_world"
+    it "Keywords are not allowed as the whole variable part of an underscore pattern" $
+      failToParse "_let"
+    it "But you can have a keyword as **part** of a variable name just as for normal variable names." $
+      parse "let_down" "_let_down"
+    it "But you cannot start with multiple underscores" $
+      failToParse "__hello"
+    it "But it must be a lower name, for an underscore pattern" $
+      failToParse "_Hello"
+    it "We should give the specialised error when we attempt to parse _key as an expression" $
+      let isWildCardAttemptError :: Error.Syntax.Expr -> Bool
+          isWildCardAttemptError err =
+            case err of
+              Error.Syntax.WildCard (Error.Syntax.WildCardAttempt _) _ _ ->
+                True
+              _ ->
+                False
+       in Helpers.checkParseError Expression.expression Error.Syntax.Start isWildCardAttemptError "_key"
+
+parse :: String -> BS.ByteString -> IO ()
+parse expectedName =
+  let isWildCardPattern :: Src.Pattern_ -> Bool
+      isWildCardPattern pattern =
+        case pattern of
+          Src.PAnything name ->
+            expectedName == (Name.toChars name)
+          _ ->
+            False
+   in Helpers.checkSuccessfulParse Pattern.expression Error.Syntax.PStart isWildCardPattern
+
+failToParse :: BS.ByteString -> IO ()
+failToParse =
+  Helpers.checkParseError Pattern.expression Error.Syntax.PStart (\_ -> True)