Merge branch 'main' into package-manager-improvements

CONTRIBUTORS

@@ -1 +1,4 @@
-Robin Heggelund Hansen
+Robin Heggelund Hansen (robinheghan)
+Julian Antonielli (jjant)
+Aaron VonderHaar (avh4)
+lue (lue-bird)

compiler/src/AST/Canonical.hs

@@ -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)
 

compiler/src/AST/Source.hs

@@ -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)
 

compiler/src/Canonicalize/Expression.hs

@@ -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

compiler/src/Gren/ModuleName.hs

@@ -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"

compiler/src/Gren/Package.hs

@@ -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,25 +128,22 @@ gren =
 
 suggestions :: Map.Map Name.Name Name
 suggestions =
-  let random = toName gren "random"
-      time = toName gren "time"
-      file = toName gren "file"
-   in 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,
-          "Url.Parser" ==> url,
-          "Url" ==> url
-        ]
+  Map.fromList
+    [ "Browser" ==> browser,
+      "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
+    ]
 
 (==>) :: [Char] -> Name -> (Name.Name, Name)
 (==>) moduleName package =

compiler/src/Nitpick/PatternMatches.hs

@@ -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

compiler/src/Optimize/Expression.hs

@@ -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

compiler/src/Parse/Expression.hs

@@ -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)]
-                  addEnd start (Src.Record fields)
+                  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
               ]
         ]
 

compiler/src/Reporting/Error/Syntax.hs

@@ -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 ->

compiler/src/Reporting/Error/Type.hs

@@ -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",

compiler/src/Type/Constrain/Expression.hs

@@ -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)
 

gren.cabal

@@ -236,6 +236,7 @@ Test-Suite gren-tests
 
         -- tests
         Parse.SpaceSpec
+        Parse.RecordUpdateSpec
 
     Build-Depends:
         hspec >= 2.7.10 && < 3

tests/Parse/RecordUpdateSpec.hs

@@ -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

tests/Parse/SpaceSpec.hs

@@ -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'")