From 5696ff65d6b10d002fef993694f257fc7529f8dd Mon Sep 17 00:00:00 2001 From: jjant Date: Wed, 25 May 2022 18:09:19 +0100 Subject: [PATCH 01/21] Remove record name from error --- compiler/src/Reporting/Error/Type.hs | 15 +++++++-------- compiler/src/Type/Constrain/Expression.hs | 10 +++++----- 2 files changed, 12 insertions(+), 13 deletions(-) diff --git a/compiler/src/Reporting/Error/Type.hs b/compiler/src/Reporting/Error/Type.hs index 9511b309..291dce99 100644 --- a/compiler/src/Reporting/Error/Type.hs +++ b/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 @@ -884,7 +884,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 @@ -892,7 +892,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 that produces this error message and\ @@ -901,19 +901,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", diff --git a/compiler/src/Type/Constrain/Expression.hs b/compiler/src/Type/Constrain/Expression.hs index f8937968..9e4f8711 100644 --- a/compiler/src/Type/Constrain/Expression.hs +++ b/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) From 5c767ab5ad04aa74ecbbcb2ddb27049842ce27c9 Mon Sep 17 00:00:00 2001 From: jjant Date: Wed, 25 May 2022 18:11:24 +0100 Subject: [PATCH 02/21] Remove record name from canonical ast --- compiler/src/AST/Canonical.hs | 2 +- compiler/src/Canonicalize/Expression.hs | 2 +- compiler/src/Nitpick/PatternMatches.hs | 2 +- compiler/src/Optimize/Expression.hs | 2 +- compiler/src/Type/Constrain/Expression.hs | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/compiler/src/AST/Canonical.hs b/compiler/src/AST/Canonical.hs index 178b8b43..9e575b2b 100644 --- a/compiler/src/AST/Canonical.hs +++ b/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) diff --git a/compiler/src/Canonicalize/Expression.hs b/compiler/src/Canonicalize/Expression.hs index f773c75b..f5d3d3c7 100644 --- a/compiler/src/Canonicalize/Expression.hs +++ b/compiler/src/Canonicalize/Expression.hs @@ -113,7 +113,7 @@ canonicalize env (A.At region expression) = Src.Update (A.At reg name) fields -> let makeCanFields = Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields - in Can.Update name + in Can.Update <$> (A.At reg <$> findVar reg env name) <*> (sequenceA =<< makeCanFields) Src.Record fields -> diff --git a/compiler/src/Nitpick/PatternMatches.hs b/compiler/src/Nitpick/PatternMatches.hs index ffbaeeb8..041ad9a1 100644 --- a/compiler/src/Nitpick/PatternMatches.hs +++ b/compiler/src/Nitpick/PatternMatches.hs @@ -179,7 +179,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 diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs index 04128a7a..7b17210b 100644 --- a/compiler/src/Optimize/Expression.hs +++ b/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 diff --git a/compiler/src/Type/Constrain/Expression.hs b/compiler/src/Type/Constrain/Expression.hs index 9e4f8711..13d001fe 100644 --- a/compiler/src/Type/Constrain/Expression.hs +++ b/compiler/src/Type/Constrain/Expression.hs @@ -113,7 +113,7 @@ constrain rtv (A.At region expression) expected = [ recordCon, CEqual region (Access field) fieldType expected ] - Can.Update _ expr fields -> + Can.Update expr fields -> constrainUpdate rtv region expr fields expected Can.Record fields -> constrainRecord rtv region fields expected From 16057ca57fed5b200e98c53384d830e0d4527d99 Mon Sep 17 00:00:00 2001 From: jjant Date: Wed, 25 May 2022 18:33:13 +0100 Subject: [PATCH 03/21] Remove name from source ast --- compiler/src/AST/Source.hs | 2 +- compiler/src/Canonicalize/Expression.hs | 4 ++-- compiler/src/Parse/Expression.hs | 10 +++++----- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/compiler/src/AST/Source.hs b/compiler/src/AST/Source.hs index 5d64cd9c..e6dcb047 100644 --- a/compiler/src/AST/Source.hs +++ b/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) diff --git a/compiler/src/Canonicalize/Expression.hs b/compiler/src/Canonicalize/Expression.hs index f5d3d3c7..9d30b0dc 100644 --- a/compiler/src/Canonicalize/Expression.hs +++ b/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 - <$> (A.At reg <$> findVar reg env name) + <$> (canonicalize env baseRecord) <*> (sequenceA =<< makeCanFields) Src.Record fields -> do diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs index dedec1ff..d81ae0cc 100644 --- a/compiler/src/Parse/Expression.hs +++ b/compiler/src/Parse/Expression.hs @@ -21,7 +21,7 @@ import qualified Parse.Type as Type import qualified Parse.Variable as Var import qualified Reporting.Annotation as A import qualified Reporting.Error.Syntax as E - +import qualified Debug.Trace -- TERMS term :: Parser E.Expr Src.Expr @@ -171,22 +171,22 @@ record start = word1 0x7D {-}-} E.RecordOpen addEnd start (Src.Record []), do - starter <- addLocation (Var.lower E.RecordField) + (A.At reg name) <- addLocation (Var.lower E.RecordField) Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals oneOf E.RecordEquals [ do - word1 0x7C E.RecordEquals + word1 0x7C {- vertical bar -} E.RecordEquals Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField firstField <- chompField fields <- chompFields [firstField] - addEnd start (Src.Update starter fields), + addEnd start (Src.Update (A.At reg (Src.Var Src.LowVar name)) 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)] + fields <- chompFields [((A.At reg name), value)] addEnd start (Src.Record fields) ] ] From 7fd2dae209ddac0caa3bb444044a1fe4f3885b5e Mon Sep 17 00:00:00 2001 From: jjant Date: Wed, 25 May 2022 19:21:21 +0100 Subject: [PATCH 04/21] Refactor that breaks parsing --- compiler/src/Parse/Expression.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs index d81ae0cc..13421957 100644 --- a/compiler/src/Parse/Expression.hs +++ b/compiler/src/Parse/Expression.hs @@ -171,17 +171,19 @@ record start = word1 0x7D {-}-} E.RecordOpen addEnd start (Src.Record []), do - (A.At reg name) <- addLocation (Var.lower E.RecordField) - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals oneOf E.RecordEquals [ do + (A.At reg name) <- addLocation (Var.lower E.RecordField) + Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals word1 0x7C {- vertical bar -} E.RecordEquals Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField firstField <- chompField fields <- chompFields [firstField] addEnd start (Src.Update (A.At reg (Src.Var Src.LowVar name)) fields), do + (A.At reg name) <- addLocation (Var.lower E.RecordField) + Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals word1 0x3D {-=-} E.RecordEquals Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr (value, end) <- specialize E.RecordExpr expression From 2ca0439bfcdb6add986a4b16ac6d16c2bcc5b55e Mon Sep 17 00:00:00 2001 From: jjant Date: Thu, 26 May 2022 22:03:20 +0100 Subject: [PATCH 05/21] Add Parser.backtrackable --- compiler/src/Parse/Primitives.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/compiler/src/Parse/Primitives.hs b/compiler/src/Parse/Primitives.hs index ae8213e8..f4d07b0c 100644 --- a/compiler/src/Parse/Primitives.hs +++ b/compiler/src/Parse/Primitives.hs @@ -10,6 +10,7 @@ module Parse.Primitives Row, Col, oneOf, + backtrackable, oneOfWithFallback, inContext, specialize, @@ -54,6 +55,12 @@ newtype Parser x a b ) +backtrackable :: Parser x a -> Parser x a +backtrackable (Parser parser) = + Parser $ \state cok eok _ eerr -> + parser state cok eok eerr eerr + + data State -- PERF try taking some out to avoid allocation = State { _src :: ForeignPtr Word8, From 193df584a75b12aac1a135c0eb2ae537c78df32c Mon Sep 17 00:00:00 2001 From: jjant Date: Thu, 26 May 2022 22:11:40 +0100 Subject: [PATCH 06/21] Parser working with backtrackable --- compiler/src/Compile.hs | 5 +++-- compiler/src/Parse/Expression.hs | 3 ++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/compiler/src/Compile.hs b/compiler/src/Compile.hs index 45cba801..5f264d55 100644 --- a/compiler/src/Compile.hs +++ b/compiler/src/Compile.hs @@ -21,6 +21,7 @@ import qualified Reporting.Result as R import System.IO.Unsafe (unsafePerformIO) import qualified Type.Constrain.Module as Type import qualified Type.Solve as Type +import qualified Debug.Trace -- COMPILE @@ -33,8 +34,8 @@ data Artifacts = Artifacts compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts compile pkg ifaces modul = do - canonical <- canonicalize pkg ifaces modul - annotations <- typeCheck modul canonical + canonical <- canonicalize pkg ifaces (Debug.Trace.traceShowId modul) + annotations <- typeCheck modul (Debug.Trace.traceShowId canonical) () <- nitpick canonical objects <- optimize modul annotations canonical return (Artifacts canonical annotations objects) diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs index 13421957..24671b10 100644 --- a/compiler/src/Parse/Expression.hs +++ b/compiler/src/Parse/Expression.hs @@ -173,7 +173,8 @@ record start = do oneOf E.RecordEquals - [ do + [ P.backtrackable $ + do (A.At reg name) <- addLocation (Var.lower E.RecordField) Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals word1 0x7C {- vertical bar -} E.RecordEquals From c0e27ce8776d382b52a31e81fe06f9e6319adf9a Mon Sep 17 00:00:00 2001 From: jjant Date: Thu, 26 May 2022 22:26:09 +0100 Subject: [PATCH 07/21] Record update working --- compiler/src/Parse/Expression.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs index 24671b10..2f9cef73 100644 --- a/compiler/src/Parse/Expression.hs +++ b/compiler/src/Parse/Expression.hs @@ -21,7 +21,7 @@ import qualified Parse.Type as Type import qualified Parse.Variable as Var import qualified Reporting.Annotation as A import qualified Reporting.Error.Syntax as E -import qualified Debug.Trace + -- TERMS term :: Parser E.Expr Src.Expr @@ -175,13 +175,13 @@ record start = E.RecordEquals [ P.backtrackable $ do - (A.At reg name) <- addLocation (Var.lower E.RecordField) + expr <- specialize undefined term Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals word1 0x7C {- vertical bar -} E.RecordEquals Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField firstField <- chompField fields <- chompFields [firstField] - addEnd start (Src.Update (A.At reg (Src.Var Src.LowVar name)) fields), + addEnd start (Src.Update expr fields), do (A.At reg name) <- addLocation (Var.lower E.RecordField) Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals @@ -189,7 +189,7 @@ record start = Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr (value, end) <- specialize E.RecordExpr expression Space.checkIndent end E.RecordIndentEnd - fields <- chompFields [((A.At reg name), value)] + fields <- chompFields [(A.At reg name, value)] addEnd start (Src.Record fields) ] ] From 033bc37c968974d4d5a1d30bb9c879cd0fc6d17f Mon Sep 17 00:00:00 2001 From: jjant Date: Thu, 26 May 2022 22:29:51 +0100 Subject: [PATCH 08/21] Formatting --- compiler/src/Parse/Expression.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs index 2f9cef73..0ef34acc 100644 --- a/compiler/src/Parse/Expression.hs +++ b/compiler/src/Parse/Expression.hs @@ -174,14 +174,14 @@ record start = oneOf E.RecordEquals [ P.backtrackable $ - do - expr <- specialize undefined term - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals - word1 0x7C {- vertical bar -} E.RecordEquals - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField - firstField <- chompField - fields <- chompFields [firstField] - addEnd start (Src.Update expr fields), + do + expr <- specialize undefined term + Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals + word1 0x7C {- vertical bar -} E.RecordEquals + Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField + firstField <- chompField + fields <- chompFields [firstField] + addEnd start (Src.Update expr fields), do (A.At reg name) <- addLocation (Var.lower E.RecordField) Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals From 3766774a2053dc701e38959187e8aa1d90c6e052 Mon Sep 17 00:00:00 2001 From: jjant Date: Thu, 26 May 2022 22:32:54 +0100 Subject: [PATCH 09/21] Remove logging --- compiler/src/Compile.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/compiler/src/Compile.hs b/compiler/src/Compile.hs index 5f264d55..45cba801 100644 --- a/compiler/src/Compile.hs +++ b/compiler/src/Compile.hs @@ -21,7 +21,6 @@ import qualified Reporting.Result as R import System.IO.Unsafe (unsafePerformIO) import qualified Type.Constrain.Module as Type import qualified Type.Solve as Type -import qualified Debug.Trace -- COMPILE @@ -34,8 +33,8 @@ data Artifacts = Artifacts compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts compile pkg ifaces modul = do - canonical <- canonicalize pkg ifaces (Debug.Trace.traceShowId modul) - annotations <- typeCheck modul (Debug.Trace.traceShowId canonical) + canonical <- canonicalize pkg ifaces modul + annotations <- typeCheck modul canonical () <- nitpick canonical objects <- optimize modul annotations canonical return (Artifacts canonical annotations objects) From 954bffdf83660ab4f35471f2db901d8ceb678231 Mon Sep 17 00:00:00 2001 From: jjant Date: Fri, 27 May 2022 08:38:46 +0100 Subject: [PATCH 10/21] Run ormolu and fix command in contributing.md --- CONTRIBUTING.md | 2 +- compiler/src/Parse/Primitives.hs | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index f15df680..62cf7f63 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -3,4 +3,4 @@ - build: `cabal build -f dev` - run tests: `cabal test -f dev` -- format files: `find -name '*.hs' | xargs -t ormolu -m inplace` +- format files: `find . -name '*.hs' | xargs -t ormolu -m inplace` diff --git a/compiler/src/Parse/Primitives.hs b/compiler/src/Parse/Primitives.hs index f4d07b0c..684305d0 100644 --- a/compiler/src/Parse/Primitives.hs +++ b/compiler/src/Parse/Primitives.hs @@ -60,7 +60,6 @@ backtrackable (Parser parser) = Parser $ \state cok eok _ eerr -> parser state cok eok eerr eerr - data State -- PERF try taking some out to avoid allocation = State { _src :: ForeignPtr Word8, From 1de9cc7f9f9e1d987dfdee35d5870771f0035630 Mon Sep 17 00:00:00 2001 From: jjant Date: Fri, 27 May 2022 09:29:03 +0100 Subject: [PATCH 11/21] Merge main and run ormolu on it --- terminal/src/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/terminal/src/Main.hs b/terminal/src/Main.hs index ac152bde..7a2f9f0f 100644 --- a/terminal/src/Main.hs +++ b/terminal/src/Main.hs @@ -8,7 +8,7 @@ where import qualified Bump import qualified Data.List as List import qualified Diff ---import qualified Format +-- import qualified Format import qualified Gren.Version as V import qualified Init import qualified Install @@ -31,7 +31,7 @@ main = init, make, install, - --format, + -- format, bump, diff, publish @@ -254,7 +254,7 @@ diff = in Terminal.Command "diff" Uncommon details example diffArgs noFlags Diff.run -- FORMAT - {- +{- format :: Terminal.Command format = let details = From b4a1b66c58d56e5b8bb47ed66d86ff5efb309653 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 5 Aug 2022 14:50:15 +0200 Subject: [PATCH 12/21] Add tests for new syntax. --- gren.cabal | 1 + tests/Parse/RecordUpdateSpec.hs | 60 +++++++++++++++++++++++++++++++++ tests/Parse/SpaceSpec.hs | 2 +- 3 files changed, 62 insertions(+), 1 deletion(-) create mode 100644 tests/Parse/RecordUpdateSpec.hs diff --git a/gren.cabal b/gren.cabal index ae516540..8e7099be 100644 --- a/gren.cabal +++ b/gren.cabal @@ -238,6 +238,7 @@ Test-Suite gren-tests -- tests Parse.SpaceSpec + Parse.RecordUpdateSpec Build-Depends: hspec >= 2.7.10 && < 3 diff --git a/tests/Parse/RecordUpdateSpec.hs b/tests/Parse/RecordUpdateSpec.hs new file mode 100644 index 00000000..2633e862 --- /dev/null +++ b/tests/Parse/RecordUpdateSpec.hs @@ -0,0 +1,60 @@ +{-# 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 "basic case" $ + parse "{ record | prop = 1 }" + + it "qualified var" $ + parse "{ Module.record | prop = 1 }" + + it "nested var" $ + parse "{ Module.record.nested | prop = 1 }" + + it "literal var" $ + parse "{ { prop = 2 } | prop = 1 }" + + it "if statement" $ + parse "{ if 1 == 2 then { prop = 2 } else { prop = 3 } | prop = 1 }" + + it "if statement with || operator" $ + parse "{ if left || right then { prop = 2 } else { prop = 3 } | 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 diff --git a/tests/Parse/SpaceSpec.hs b/tests/Parse/SpaceSpec.hs index d587de4b..456b0ab9 100644 --- a/tests/Parse/SpaceSpec.hs +++ b/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'") From e9895d3167a52042dbd3e1545b9f964ca92760b0 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 5 Aug 2022 15:03:08 +0200 Subject: [PATCH 13/21] Use error type in place of undefined. --- compiler/src/Parse/Expression.hs | 2 +- compiler/src/Reporting/Error/Syntax.hs | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs index 410974a1..527cf767 100644 --- a/compiler/src/Parse/Expression.hs +++ b/compiler/src/Parse/Expression.hs @@ -175,7 +175,7 @@ record start = E.RecordEquals [ P.backtrackable $ do - expr <- specialize undefined term + expr <- specialize E.RecordUpdateExpr term Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals word1 0x7C {- vertical bar -} E.RecordEquals Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField diff --git a/compiler/src/Reporting/Error/Syntax.hs b/compiler/src/Reporting/Error/Syntax.hs index b8e66101..d026f56b 100644 --- a/compiler/src/Reporting/Error/Syntax.hs +++ b/compiler/src/Reporting/Error/Syntax.hs @@ -212,6 +212,7 @@ data Record | RecordField Row Col | RecordEquals Row Col | RecordExpr Expr Row Col + | RecordUpdateExpr Expr Row Col | RecordSpace Space Row Col | -- RecordIndentOpen Row Col @@ -4418,6 +4419,8 @@ toRecordReport source context record startRow startCol = ) RecordExpr expr row col -> toExprReport source (InNode NRecord startRow startCol context) expr row col + RecordUpdateExpr expr row col -> + toExprReport source (InNode NRecord startRow startCol context) expr row col RecordSpace space row col -> toSpaceReport source space row col RecordIndentOpen row col -> From 89f4defc18cd0d233b8adbe04ed90d33e89ab4f4 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 5 Aug 2022 15:24:02 +0200 Subject: [PATCH 14/21] Add some extra testing. --- tests/Parse/RecordUpdateSpec.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/tests/Parse/RecordUpdateSpec.hs b/tests/Parse/RecordUpdateSpec.hs index 2633e862..42a8fb3b 100644 --- a/tests/Parse/RecordUpdateSpec.hs +++ b/tests/Parse/RecordUpdateSpec.hs @@ -18,6 +18,9 @@ data ParseError spec :: Spec spec = do describe "record update" $ do + it "regression test" $ + parseRecordLiteral "{ field = 2 }" + it "basic case" $ parse "{ record | prop = 1 }" @@ -27,7 +30,7 @@ spec = do it "nested var" $ parse "{ Module.record.nested | prop = 1 }" - it "literal var" $ + it "update literal record" $ parse "{ { prop = 2 } | prop = 1 }" it "if statement" $ @@ -58,3 +61,20 @@ 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 From 2b823ad176f58aae36b8b6b2ff7cc1ae013bbd0e Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 12 Aug 2022 10:00:11 +0200 Subject: [PATCH 15/21] Parse terms in record updates without backtracking. --- compiler/src/Parse/Expression.hs | 28 +++++++++++++++------------- compiler/src/Parse/Primitives.hs | 6 ------ tests/Parse/RecordUpdateSpec.hs | 9 +++------ 3 files changed, 18 insertions(+), 25 deletions(-) diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs index 527cf767..72a567d3 100644 --- a/compiler/src/Parse/Expression.hs +++ b/compiler/src/Parse/Expression.hs @@ -171,26 +171,28 @@ record start = word1 0x7D {-}-} E.RecordOpen addEnd start (Src.Record []), do + expr <- specialize E.RecordUpdateExpr term + Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals oneOf E.RecordEquals - [ P.backtrackable $ - do - expr <- specialize E.RecordUpdateExpr term - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals - word1 0x7C {- vertical bar -} E.RecordEquals - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField - firstField <- chompField - fields <- chompFields [firstField] - addEnd start (Src.Update expr fields), + [ do + word1 0x7C {- vertical bar -} E.RecordEquals + Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField + firstField <- chompField + fields <- chompFields [firstField] + addEnd start (Src.Update expr fields), do - (A.At reg name) <- addLocation (Var.lower E.RecordField) - Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals word1 0x3D {-=-} E.RecordEquals Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr (value, end) <- specialize E.RecordExpr expression Space.checkIndent end E.RecordIndentEnd - fields <- chompFields [(A.At reg name, 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.RecordEquals ] ] diff --git a/compiler/src/Parse/Primitives.hs b/compiler/src/Parse/Primitives.hs index aefb817d..c4fc0e79 100644 --- a/compiler/src/Parse/Primitives.hs +++ b/compiler/src/Parse/Primitives.hs @@ -10,7 +10,6 @@ module Parse.Primitives Row, Col, oneOf, - backtrackable, oneOfWithFallback, inContext, specialize, @@ -55,11 +54,6 @@ newtype Parser x a b ) -backtrackable :: Parser x a -> Parser x a -backtrackable (Parser parser) = - Parser $ \state cok eok _ eerr -> - parser state cok eok eerr eerr - data State -- PERF try taking some out to avoid allocation = State { _src :: ForeignPtr Word8, diff --git a/tests/Parse/RecordUpdateSpec.hs b/tests/Parse/RecordUpdateSpec.hs index 42a8fb3b..c992e0ad 100644 --- a/tests/Parse/RecordUpdateSpec.hs +++ b/tests/Parse/RecordUpdateSpec.hs @@ -21,6 +21,9 @@ spec = 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 }" @@ -33,12 +36,6 @@ spec = do it "update literal record" $ parse "{ { prop = 2 } | prop = 1 }" - it "if statement" $ - parse "{ if 1 == 2 then { prop = 2 } else { prop = 3 } | prop = 1 }" - - it "if statement with || operator" $ - parse "{ if left || right then { prop = 2 } else { prop = 3 } | prop = 1 }" - it "parenthesized if statement" $ parse "{ (if 1 == 2 then { prop = 2 } else { prop = 3 }) | prop = 1 }" From c27f0fe20aeca43dc62f4891ab94ec36a6d9ac2e Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 12 Aug 2022 10:32:05 +0200 Subject: [PATCH 16/21] improve error message --- compiler/src/Parse/Expression.hs | 6 ++-- compiler/src/Reporting/Error/Syntax.hs | 42 ++++++++++++++++++++++++-- 2 files changed, 42 insertions(+), 6 deletions(-) diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs index 72a567d3..84e487ad 100644 --- a/compiler/src/Parse/Expression.hs +++ b/compiler/src/Parse/Expression.hs @@ -168,7 +168,7 @@ record start = oneOf E.RecordOpen [ do - word1 0x7D {-}-} E.RecordOpen + word1 0x7D {-}-} E.RecordEnd addEnd start (Src.Record []), do expr <- specialize E.RecordUpdateExpr term @@ -176,7 +176,7 @@ record start = oneOf E.RecordEquals [ do - word1 0x7C {- vertical bar -} E.RecordEquals + word1 0x7C {- vertical bar -} E.RecordPipe Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField firstField <- chompField fields <- chompFields [firstField] @@ -192,7 +192,7 @@ record start = addEnd start (Src.Record fields) A.At (A.Region (A.Position row col) _) _ -> P.Parser $ \_ _ _ _ eerr -> - eerr row col E.RecordEquals + eerr row col E.RecordField ] ] diff --git a/compiler/src/Reporting/Error/Syntax.hs b/compiler/src/Reporting/Error/Syntax.hs index d026f56b..2b97d3c6 100644 --- a/compiler/src/Reporting/Error/Syntax.hs +++ b/compiler/src/Reporting/Error/Syntax.hs @@ -211,8 +211,8 @@ 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 @@ -4417,10 +4417,46 @@ 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 (InNode NRecord startRow startCol context) expr row col RecordSpace space row col -> toSpaceReport source space row col RecordIndentOpen row col -> From be68050331fdfd6a3cd6a270ffe12c47e1d1952a Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 12 Aug 2022 10:34:38 +0200 Subject: [PATCH 17/21] Improve error messages for first expression. --- compiler/src/Reporting/Error/Syntax.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/compiler/src/Reporting/Error/Syntax.hs b/compiler/src/Reporting/Error/Syntax.hs index 2b97d3c6..bda7f11f 100644 --- a/compiler/src/Reporting/Error/Syntax.hs +++ b/compiler/src/Reporting/Error/Syntax.hs @@ -213,6 +213,7 @@ data Record | RecordEquals Row Col | RecordPipe Row Col | RecordExpr Expr Row Col + | RecordUpdateExpr Expr Row Col | RecordSpace Space Row Col | -- RecordIndentOpen Row Col @@ -4457,6 +4458,8 @@ toRecordReport source context record startRow startCol = ) RecordExpr expr row col -> toExprReport source (InNode NRecord startRow startCol context) expr row col + RecordUpdateExpr expr row col -> + toExprReport source (InNode NRecord startRow startCol context) expr row col RecordSpace space row col -> toSpaceReport source space row col RecordIndentOpen row col -> From 16dcbb8803dd652375edd5930a2ca3756197aa5c Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 12 Aug 2022 11:57:06 +0200 Subject: [PATCH 18/21] Fix package resolution with new package scheme. --- compiler/src/Gren/ModuleName.hs | 6 ++-- compiler/src/Gren/Package.hs | 55 ++++++++++----------------------- terminal/src/Repl.hs | 3 +- 3 files changed, 20 insertions(+), 44 deletions(-) diff --git a/compiler/src/Gren/ModuleName.hs b/compiler/src/Gren/ModuleName.hs index 16ec99b8..92cf33bb 100644 --- a/compiler/src/Gren/ModuleName.hs +++ b/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" diff --git a/compiler/src/Gren/Package.hs b/compiler/src/Gren/Package.hs index 9527f125..abcf2397 100644 --- a/compiler/src/Gren/Package.hs +++ b/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 = diff --git a/terminal/src/Repl.hs b/terminal/src/Repl.hs index ef3216cc..4fd19955 100644 --- a/terminal/src/Repl.hs +++ b/terminal/src/Repl.hs @@ -522,8 +522,7 @@ defaultDeps :: Map.Map Pkg.Name C.Constraint defaultDeps = Map.fromList [ (Pkg.core, C.anything), - (Pkg.json, C.anything), - (Pkg.html, C.anything) + (Pkg.browser, C.anything) ] -- GET INTERPRETER From 5296aa3e6d70c437726771f89e21bb16eabd72a8 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 12 Aug 2022 12:17:47 +0200 Subject: [PATCH 19/21] Improve error message when using something in a record update expression which doesn't resolve to a record. --- compiler/src/Reporting/Error/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/src/Reporting/Error/Syntax.hs b/compiler/src/Reporting/Error/Syntax.hs index bda7f11f..75de8b86 100644 --- a/compiler/src/Reporting/Error/Syntax.hs +++ b/compiler/src/Reporting/Error/Syntax.hs @@ -4459,7 +4459,7 @@ toRecordReport source context record startRow startCol = RecordExpr expr row col -> toExprReport source (InNode NRecord startRow startCol context) expr row col RecordUpdateExpr expr row col -> - toExprReport source (InNode NRecord startRow startCol context) expr row col + toExprReport source context expr row col RecordSpace space row col -> toSpaceReport source space row col RecordIndentOpen row col -> From 35c003007ce65b89de543341eb74e1811a061d1b Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 12 Aug 2022 12:19:36 +0200 Subject: [PATCH 20/21] another => a, reads better when reporting error for a record with only one field. --- compiler/src/Reporting/Error/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/src/Reporting/Error/Syntax.hs b/compiler/src/Reporting/Error/Syntax.hs index 75de8b86..fae51b24 100644 --- a/compiler/src/Reporting/Error/Syntax.hs +++ b/compiler/src/Reporting/Error/Syntax.hs @@ -4356,7 +4356,7 @@ toRecordReport source context record startRow startCol = "expecting", "to", "see", - "another", + "a", "record", "field", "defined", From eaf81a1abd28a28f85e1427e5e7f683d2af17d14 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 12 Aug 2022 12:26:33 +0200 Subject: [PATCH 21/21] Update CONTRIBUTORS. --- CONTRIBUTORS | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS b/CONTRIBUTORS index f9e045fd..6d5ebe43 100644 --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1 +1,4 @@ -Robin Heggelund Hansen +Robin Heggelund Hansen (robinheghan) +Julian Antonielli (jjant) +Aaron VonderHaar (avh4) +lue (lue-bird)