Fix double-nesting of Note constructors

Fixes #1784

In #1824 I introduced a bug in computing source spans for `Note` constructors.
The (very indirect) consequence of this bug was that doubly-nested `Note`
constructors would show up in the syntax tree.

For example, the following command would generate *far* more `Note`
constructors than you would expect before this fix:

```bash
$ dhall haskell-syntax-tree --noted <<< 'A B'
```

Among other things, that broke the LSP server, which assumes that
`Note` constructors are only nested once.

I added a regression test to prevent this from recurring in the
future.

dhall/src/Dhall/Parser/Expression.hs

@@ -64,6 +64,13 @@ src parser = do
     after       <- getSourcePos
     return (Src before after tokens)
 
+srcAnd :: Parser a -> Parser (Src, a)
+srcAnd parser = do
+    before      <- getSourcePos
+    (tokens, x) <- Text.Megaparsec.match parser
+    after       <- getSourcePos
+    return (Src before after tokens, x)
+
 {-| Wrap a `Parser` to still match the same text, but to wrap the resulting
     `Expr` in a `Note` constructor containing the `Src` span
 -}
@@ -240,6 +247,8 @@ parsers embedded = Parsers {..}
 
             a <- parseFirstOperatorExpression
 
+            whitespace
+
             let alternative4A = do
                     _arrow
                     whitespace
@@ -317,27 +326,21 @@ parsers embedded = Parsers {..}
     makeOperatorExpression firstSubExpression operatorParser subExpression = do
             a <- firstSubExpression
 
-            e <- noted (do
-                whitespace
-
-                b <- Text.Megaparsec.many $ do
-                    op <- operatorParser
+            bs <- Text.Megaparsec.many $ do
+                (Src _ _ textOp, op0) <- srcAnd (try (whitespace *> operatorParser))
 
-                    r  <- subExpression
+                r0 <- subExpression
 
-                    whitespace
-
-                    return (\l -> l `op` r)
-
-                return (foldl' (\x f -> f x) a b) )
-
-            case (a, e) of
-                (Note (Src start _ text0) _, Note (Src _ end text1) e') ->
-                    return (Note (Src start end (text0 <> text1)) e')
-                _ ->
+                let l@(Note (Src startL _ textL) _) `op` r@(Note (Src _ endR textR) _) =
+                        Note (Src startL endR (textL <> textOp <> textR)) (l `op0` r)
                     -- We shouldn't hit this branch if things are working, but
                     -- that is not enforced in the types
-                    return e
+                    l `op` r =
+                        l `op0` r
+
+                return (`op` r0)
+
+            return (foldl' (\x f -> f x) a bs)
 
     operatorParsers :: [Parser (Expr s a -> Expr s a -> Expr s a)]
     operatorParsers =

dhall/tests/Dhall/Test/QuickCheck.hs

@@ -54,6 +54,7 @@ import Test.Tasty.QuickCheck (QuickCheckTests(..))
 import Text.Megaparsec (SourcePos(..), Pos)
 
 import qualified Control.Spoon
+import qualified Data.Foldable as Foldable
 import qualified Data.List
 import qualified Data.Sequence
 import qualified Data.SpecialValues
@@ -71,6 +72,7 @@ import qualified Dhall.Parser as Parser
 import qualified Dhall.Set
 import qualified Dhall.TypeCheck
 import qualified Generic.Random
+import qualified Lens.Family as Lens
 import qualified Numeric.Natural as Nat
 import qualified Test.QuickCheck
 import qualified Test.Tasty
@@ -492,6 +494,18 @@ normalizingAnExpressionDoesntChangeItsInferredType expression =
     filterOutEmbeds :: Typer a
     filterOutEmbeds _ = Const Sort -- This could be any ill-typed expression.
 
+noDoubleNotes :: Expr () Import -> Property
+noDoubleNotes expression =
+    length
+        [ ()
+        | e <- Foldable.toList parsedExpression
+        , Note _ (Note _ _) <- Lens.toListOf Dhall.Core.subExpressions e
+        ] === 0
+  where
+    text = Dhall.Core.pretty expression
+
+    parsedExpression = Parser.exprFromText "" text
+
 embedThenExtractIsIdentity
     :: forall a. (ToDhall a, FromDhall a, Eq a, Typeable a, Arbitrary a, Show a)
     => Proxy a
@@ -545,6 +559,10 @@ tests =
           , Test.QuickCheck.property normalizingAnExpressionDoesntChangeItsInferredType
           , adjustQuickCheckTests 10000
           )
+        , ( "Parsing an expression doesn't generated doubly-nested Note constructors"
+          , Test.QuickCheck.property noDoubleNotes
+          , adjustQuickCheckTests 100
+          )
         , embedThenExtractIsIdentity (Proxy :: Proxy (Text.Text))
         , embedThenExtractIsIdentity (Proxy :: Proxy [Nat.Natural])
         , embedThenExtractIsIdentity (Proxy :: Proxy (Bool, Double))