mirror of
https://github.com/gren-lang/compiler.git
synced 2024-09-11 08:45:42 +03:00
Merge branch 'main' into package-manager-improvements
This commit is contained in:
commit
23f9ec2766
@ -1 +1,4 @@
|
||||
Robin Heggelund Hansen
|
||||
Robin Heggelund Hansen (robinheghan)
|
||||
Julian Antonielli (jjant)
|
||||
Aaron VonderHaar (avh4)
|
||||
lue (lue-bird)
|
||||
|
@ -98,7 +98,7 @@ data Expr_
|
||||
| Case Expr [CaseBranch]
|
||||
| Accessor Name
|
||||
| Access Expr (A.Located Name)
|
||||
| Update Name Expr (Map.Map Name FieldUpdate)
|
||||
| Update Expr (Map.Map Name FieldUpdate)
|
||||
| Record (Map.Map Name Expr)
|
||||
deriving (Show)
|
||||
|
||||
|
@ -73,7 +73,7 @@ data Expr_
|
||||
| Case Expr [(Pattern, Expr)]
|
||||
| Accessor Name
|
||||
| Access Expr (A.Located Name)
|
||||
| Update (A.Located Name) [(A.Located Name, Expr)]
|
||||
| Update Expr [(A.Located Name, Expr)]
|
||||
| Record [(A.Located Name, Expr)]
|
||||
deriving (Show)
|
||||
|
||||
|
@ -110,11 +110,11 @@ canonicalize env (A.At region expression) =
|
||||
Can.Access
|
||||
<$> canonicalize env record
|
||||
<*> Result.ok field
|
||||
Src.Update (A.At reg name) fields ->
|
||||
Src.Update baseRecord fields ->
|
||||
let makeCanFields =
|
||||
Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields
|
||||
in Can.Update name
|
||||
<$> (A.At reg <$> findVar reg env name)
|
||||
in Can.Update
|
||||
<$> (canonicalize env baseRecord)
|
||||
<*> (sequenceA =<< makeCanFields)
|
||||
Src.Record fields ->
|
||||
do
|
||||
|
@ -170,12 +170,12 @@ debug = Canonical Pkg.core Name.debug
|
||||
-- HTML
|
||||
|
||||
virtualDom :: Canonical
|
||||
virtualDom = Canonical Pkg.virtualDom Name.virtualDom
|
||||
virtualDom = Canonical Pkg.browser Name.virtualDom
|
||||
|
||||
-- JSON
|
||||
|
||||
jsonDecode :: Canonical
|
||||
jsonDecode = Canonical Pkg.json "Json.Decode"
|
||||
jsonDecode = Canonical Pkg.core "Json.Decode"
|
||||
|
||||
jsonEncode :: Canonical
|
||||
jsonEncode = Canonical Pkg.json "Json.Encode"
|
||||
jsonEncode = Canonical Pkg.core "Json.Encode"
|
||||
|
@ -19,10 +19,6 @@ module Gren.Package
|
||||
kernel,
|
||||
core,
|
||||
browser,
|
||||
virtualDom,
|
||||
html,
|
||||
json,
|
||||
http,
|
||||
url,
|
||||
--
|
||||
suggestions,
|
||||
@ -120,22 +116,6 @@ browser :: Name
|
||||
browser =
|
||||
toName gren "browser"
|
||||
|
||||
virtualDom :: Name
|
||||
virtualDom =
|
||||
toName gren "virtual-dom"
|
||||
|
||||
html :: Name
|
||||
html =
|
||||
toName gren "html"
|
||||
|
||||
json :: Name
|
||||
json =
|
||||
toName gren "json"
|
||||
|
||||
http :: Name
|
||||
http =
|
||||
toName gren "http"
|
||||
|
||||
url :: Name
|
||||
url =
|
||||
toName gren "url"
|
||||
@ -148,22 +128,19 @@ gren =
|
||||
|
||||
suggestions :: Map.Map Name.Name Name
|
||||
suggestions =
|
||||
let random = toName gren "random"
|
||||
time = toName gren "time"
|
||||
file = toName gren "file"
|
||||
in Map.fromList
|
||||
Map.fromList
|
||||
[ "Browser" ==> browser,
|
||||
"File" ==> file,
|
||||
"File.Download" ==> file,
|
||||
"File.Select" ==> file,
|
||||
"Html" ==> html,
|
||||
"Html.Attributes" ==> html,
|
||||
"Html.Events" ==> html,
|
||||
"Http" ==> http,
|
||||
"Json.Decode" ==> json,
|
||||
"Json.Encode" ==> json,
|
||||
"Random" ==> random,
|
||||
"Time" ==> time,
|
||||
"File" ==> browser,
|
||||
"File.Download" ==> browser,
|
||||
"File.Select" ==> browser,
|
||||
"Html" ==> browser,
|
||||
"Html.Attributes" ==> browser,
|
||||
"Html.Events" ==> browser,
|
||||
"Http" ==> browser,
|
||||
"Json.Decode" ==> core,
|
||||
"Json.Encode" ==> core,
|
||||
"Random" ==> core,
|
||||
"Time" ==> core,
|
||||
"Url.Parser" ==> url,
|
||||
"Url" ==> url
|
||||
]
|
||||
|
@ -180,7 +180,7 @@ checkExpr (A.At region expression) errors =
|
||||
errors
|
||||
Can.Access record _ ->
|
||||
checkExpr record errors
|
||||
Can.Update _ record fields ->
|
||||
Can.Update record fields ->
|
||||
checkExpr record $ Map.foldr checkField errors fields
|
||||
Can.Record fields ->
|
||||
Map.foldr checkExpr errors fields
|
||||
|
@ -124,7 +124,7 @@ optimize cycle (A.At region expression) =
|
||||
do
|
||||
optRecord <- optimize cycle record
|
||||
Names.registerField field (Opt.Access optRecord field)
|
||||
Can.Update _ record updates ->
|
||||
Can.Update record updates ->
|
||||
Names.registerFieldDict updates Opt.Update
|
||||
<*> optimize cycle record
|
||||
<*> traverse (optimizeUpdate cycle) updates
|
||||
|
@ -168,26 +168,31 @@ record start =
|
||||
oneOf
|
||||
E.RecordOpen
|
||||
[ do
|
||||
word1 0x7D {-}-} E.RecordOpen
|
||||
word1 0x7D {-}-} E.RecordEnd
|
||||
addEnd start (Src.Record []),
|
||||
do
|
||||
starter <- addLocation (Var.lower E.RecordField)
|
||||
expr <- specialize E.RecordUpdateExpr term
|
||||
Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals
|
||||
oneOf
|
||||
E.RecordEquals
|
||||
[ do
|
||||
word1 0x7C E.RecordEquals
|
||||
word1 0x7C {- vertical bar -} E.RecordPipe
|
||||
Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
|
||||
firstField <- chompField
|
||||
fields <- chompFields [firstField]
|
||||
addEnd start (Src.Update starter fields),
|
||||
addEnd start (Src.Update expr fields),
|
||||
do
|
||||
word1 0x3D {-=-} E.RecordEquals
|
||||
Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr
|
||||
(value, end) <- specialize E.RecordExpr expression
|
||||
Space.checkIndent end E.RecordIndentEnd
|
||||
fields <- chompFields [(starter, value)]
|
||||
case expr of
|
||||
A.At exprRegion (Src.Var Src.LowVar name) -> do
|
||||
fields <- chompFields [(A.At exprRegion name, value)]
|
||||
addEnd start (Src.Record fields)
|
||||
A.At (A.Region (A.Position row col) _) _ ->
|
||||
P.Parser $ \_ _ _ _ eerr ->
|
||||
eerr row col E.RecordField
|
||||
]
|
||||
]
|
||||
|
||||
|
@ -211,7 +211,9 @@ data Record
|
||||
| RecordEnd Row Col
|
||||
| RecordField Row Col
|
||||
| RecordEquals Row Col
|
||||
| RecordPipe Row Col
|
||||
| RecordExpr Expr Row Col
|
||||
| RecordUpdateExpr Expr Row Col
|
||||
| RecordSpace Space Row Col
|
||||
| --
|
||||
RecordIndentOpen Row Col
|
||||
@ -4354,7 +4356,7 @@ toRecordReport source context record startRow startCol =
|
||||
"expecting",
|
||||
"to",
|
||||
"see",
|
||||
"another",
|
||||
"a",
|
||||
"record",
|
||||
"field",
|
||||
"defined",
|
||||
@ -4416,8 +4418,48 @@ toRecordReport source context record startRow startCol =
|
||||
noteForRecordError
|
||||
]
|
||||
)
|
||||
RecordPipe row col ->
|
||||
let surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
|
||||
region = toRegion row col
|
||||
in Report.Report "PROBLEM IN RECORD" region [] $
|
||||
Code.toSnippet
|
||||
source
|
||||
surroundings
|
||||
(Just region)
|
||||
( D.reflow $
|
||||
"I am partway through parsing a record, but I got stuck here:",
|
||||
D.stack
|
||||
[ D.fillSep $
|
||||
[ "I",
|
||||
"just",
|
||||
"saw",
|
||||
"an",
|
||||
"expression",
|
||||
"so",
|
||||
"I",
|
||||
"was",
|
||||
"expecting",
|
||||
"to",
|
||||
"see",
|
||||
"a",
|
||||
"|",
|
||||
"symbol",
|
||||
"next.",
|
||||
"So",
|
||||
"try",
|
||||
"putting",
|
||||
"a",
|
||||
D.green "|",
|
||||
"sign",
|
||||
"here?"
|
||||
],
|
||||
noteForRecordError
|
||||
]
|
||||
)
|
||||
RecordExpr expr row col ->
|
||||
toExprReport source (InNode NRecord startRow startCol context) expr row col
|
||||
RecordUpdateExpr expr row col ->
|
||||
toExprReport source context expr row col
|
||||
RecordSpace space row col ->
|
||||
toSpaceReport source space row col
|
||||
RecordIndentOpen row col ->
|
||||
|
@ -58,7 +58,7 @@ data Context
|
||||
| CallArity MaybeName Int
|
||||
| CallArg MaybeName Index.ZeroBased
|
||||
| RecordAccess A.Region (Maybe Name.Name) A.Region Name.Name
|
||||
| RecordUpdateKeys Name.Name (Map.Map Name.Name Can.FieldUpdate)
|
||||
| RecordUpdateKeys (Map.Map Name.Name Can.FieldUpdate)
|
||||
| RecordUpdateValue Name.Name
|
||||
| Destructure
|
||||
|
||||
@ -894,7 +894,7 @@ toExprReport source localizer exprRegion category tipe expected =
|
||||
]
|
||||
]
|
||||
)
|
||||
RecordUpdateKeys record expectedFields ->
|
||||
RecordUpdateKeys expectedFields ->
|
||||
case T.iteratedDealias tipe of
|
||||
T.Record actualFields ext ->
|
||||
case Map.lookupMin (Map.difference expectedFields actualFields) of
|
||||
@ -902,7 +902,7 @@ toExprReport source localizer exprRegion category tipe expected =
|
||||
mismatch
|
||||
( Nothing,
|
||||
"Something is off with this record update:",
|
||||
"The `" <> Name.toChars record <> "` record is",
|
||||
"The record is",
|
||||
"But this update needs it to be compatable with:",
|
||||
[ D.reflow
|
||||
"Do you mind creating an <http://sscce.org/> that produces this error message and\
|
||||
@ -911,19 +911,18 @@ toExprReport source localizer exprRegion category tipe expected =
|
||||
]
|
||||
)
|
||||
Just (field, Can.FieldUpdate fieldRegion _) ->
|
||||
let rStr = "`" <> Name.toChars record <> "`"
|
||||
fStr = "`" <> Name.toChars field <> "`"
|
||||
let fStr = "`" <> Name.toChars field <> "`"
|
||||
in custom
|
||||
(Just fieldRegion)
|
||||
( D.reflow $
|
||||
"The " <> rStr <> " record does not have a " <> fStr <> " field:",
|
||||
"The record does not have a " <> fStr <> " field:",
|
||||
case Suggest.sort (Name.toChars field) (Name.toChars . fst) (Map.toList actualFields) of
|
||||
[] ->
|
||||
D.reflow $ "In fact, " <> rStr <> " is a record with NO fields!"
|
||||
D.reflow $ "In fact, this is a record with NO fields!"
|
||||
f : fs ->
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
"This is usually a typo. Here are the " <> rStr <> " fields that are most similar:",
|
||||
"This is usually a typo. Here are the fields that are most similar:",
|
||||
toNearbyRecord localizer f fs ext,
|
||||
D.fillSep
|
||||
[ "So",
|
||||
|
@ -113,8 +113,8 @@ constrain rtv (A.At region expression) expected =
|
||||
[ recordCon,
|
||||
CEqual region (Access field) fieldType expected
|
||||
]
|
||||
Can.Update name expr fields ->
|
||||
constrainUpdate rtv region name expr fields expected
|
||||
Can.Update expr fields ->
|
||||
constrainUpdate rtv region expr fields expected
|
||||
Can.Record fields ->
|
||||
constrainRecord rtv region fields expected
|
||||
|
||||
@ -360,8 +360,8 @@ constrainField rtv expr =
|
||||
|
||||
-- CONSTRAIN RECORD UPDATE
|
||||
|
||||
constrainUpdate :: RTV -> A.Region -> Name.Name -> Can.Expr -> Map.Map Name.Name Can.FieldUpdate -> Expected Type -> IO Constraint
|
||||
constrainUpdate rtv region name expr fields expected =
|
||||
constrainUpdate :: RTV -> A.Region -> Can.Expr -> Map.Map Name.Name Can.FieldUpdate -> Expected Type -> IO Constraint
|
||||
constrainUpdate rtv region expr fields expected =
|
||||
do
|
||||
extVar <- mkFlexVar
|
||||
fieldDict <- Map.traverseWithKey (constrainUpdateField rtv region) fields
|
||||
@ -377,7 +377,7 @@ constrainUpdate rtv region name expr fields expected =
|
||||
let vars = Map.foldr (\(v, _, _) vs -> v : vs) [recordVar, extVar] fieldDict
|
||||
let cons = Map.foldr (\(_, _, c) cs -> c : cs) [recordCon] fieldDict
|
||||
|
||||
con <- constrain rtv expr (FromContext region (RecordUpdateKeys name fields) recordType)
|
||||
con <- constrain rtv expr (FromContext region (RecordUpdateKeys fields) recordType)
|
||||
|
||||
return $ exists vars $ CAnd (fieldsCon : con : cons)
|
||||
|
||||
|
@ -236,6 +236,7 @@ Test-Suite gren-tests
|
||||
|
||||
-- tests
|
||||
Parse.SpaceSpec
|
||||
Parse.RecordUpdateSpec
|
||||
|
||||
Build-Depends:
|
||||
hspec >= 2.7.10 && < 3
|
||||
|
77
tests/Parse/RecordUpdateSpec.hs
Normal file
77
tests/Parse/RecordUpdateSpec.hs
Normal file
@ -0,0 +1,77 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Parse.RecordUpdateSpec where
|
||||
|
||||
import AST.Source qualified as Src
|
||||
import Data.ByteString qualified as BS
|
||||
import Helpers.Instances ()
|
||||
import Parse.Expression (expression)
|
||||
import Parse.Primitives qualified as P
|
||||
import Reporting.Annotation qualified as A
|
||||
import Test.Hspec
|
||||
|
||||
data ParseError
|
||||
= ExprError P.Row P.Col
|
||||
| OtherError String P.Row P.Col
|
||||
deriving (Show, Eq)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "record update" $ do
|
||||
it "regression test" $
|
||||
parseRecordLiteral "{ field = 2 }"
|
||||
|
||||
it "regression test with multiple fields" $
|
||||
parseRecordLiteral "{ f1 = 1, f2 = 2, f3 = 3 }"
|
||||
|
||||
it "basic case" $
|
||||
parse "{ record | prop = 1 }"
|
||||
|
||||
it "qualified var" $
|
||||
parse "{ Module.record | prop = 1 }"
|
||||
|
||||
it "nested var" $
|
||||
parse "{ Module.record.nested | prop = 1 }"
|
||||
|
||||
it "update literal record" $
|
||||
parse "{ { prop = 2 } | prop = 1 }"
|
||||
|
||||
it "parenthesized if statement" $
|
||||
parse "{ (if 1 == 2 then { prop = 2 } else { prop = 3 }) | prop = 1 }"
|
||||
|
||||
it "parenthesized if statement with || operator" $
|
||||
parse "{ (if left || right then { prop = 2 } else { prop = 3 }) | prop = 1 }"
|
||||
|
||||
--
|
||||
|
||||
parse :: BS.ByteString -> IO ()
|
||||
parse str =
|
||||
( P.fromByteString
|
||||
(P.specialize (\_ row col -> ExprError row col) expression)
|
||||
(OtherError "fromByteString failed")
|
||||
str
|
||||
)
|
||||
`shouldSatisfy` isUpdateExpr
|
||||
|
||||
isUpdateExpr :: Either x (Src.Expr, A.Position) -> Bool
|
||||
isUpdateExpr result =
|
||||
case result of
|
||||
Right (A.At _ (Src.Update _ _), _) -> True
|
||||
_ -> False
|
||||
|
||||
--
|
||||
|
||||
parseRecordLiteral :: BS.ByteString -> IO ()
|
||||
parseRecordLiteral str =
|
||||
( P.fromByteString
|
||||
(P.specialize (\_ row col -> ExprError row col) expression)
|
||||
(OtherError "fromByteString failed")
|
||||
str
|
||||
)
|
||||
`shouldSatisfy` isRecordLiteral
|
||||
|
||||
isRecordLiteral :: Either x (Src.Expr, A.Position) -> Bool
|
||||
isRecordLiteral result =
|
||||
case result of
|
||||
Right (A.At _ (Src.Record _), _) -> True
|
||||
_ -> False
|
@ -68,7 +68,7 @@ spec = do
|
||||
|
||||
parse :: P.Parser (ParseError x) a -> BS.ByteString -> Either (ParseError x) a
|
||||
parse parser =
|
||||
P.fromByteString parser (OtherError "fromBytString failed")
|
||||
P.fromByteString parser (OtherError "fromByteString failed")
|
||||
|
||||
a :: P.Parser (ParseError x) ()
|
||||
a = P.word1 0x61 {- a -} (OtherError "Expected 'a'")
|
||||
|
Loading…
Reference in New Issue
Block a user