mirror of
https://github.com/gren-lang/compiler.git
synced 2024-10-26 18:00:47 +03:00
Merge pull request #121 from allanderek/main
Allow _key style wildcard patterns.
This commit is contained in:
commit
d2769431b5
@ -2,3 +2,4 @@ Robin Heggelund Hansen (robinheghan)
|
||||
Julian Antonielli (jjant)
|
||||
Aaron VonderHaar (avh4)
|
||||
lue (lue-bird)
|
||||
Allan Clark (allanderek)
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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 =
|
||||
|
@ -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
|
||||
|
@ -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 ->
|
||||
|
@ -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
|
||||
|
40
tests/Helpers/Parse.hs
Normal file
40
tests/Helpers/Parse.hs
Normal file
@ -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
|
55
tests/Parse/UnderscorePatternSpec.hs
Normal file
55
tests/Parse/UnderscorePatternSpec.hs
Normal file
@ -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)
|
Loading…
Reference in New Issue
Block a user