Treat multi-lets as syntactic sugar (#1242)

Closes #1185.

This mostly reverts "Add support for multi-`let` (#675)" /
8a5bfaa.

Also:

* Add fields for Src
  This is useful for to make 'Note's less noisy during debugging:

      first srcText expr

dhall-json/src/Dhall/JSON.hs

@@ -649,17 +649,12 @@ convertToHomogeneousMaps (Conversion {..}) e0 = loop (Core.normalize e0)
             a' = loop a
             b' = loop b
 
-        Core.Let as b ->
-            Core.Let as' b'
+        Core.Let a b c d ->
+            Core.Let a b' c' d'
           where
-            f (Core.Binding x y z) = Core.Binding x y' z'
-              where
-                y' = fmap loop y
-                z' =      loop z
-
-            as' = fmap f as
-
-            b' = loop b
+            b' = fmap loop b
+            c' =      loop c
+            d' =      loop d
 
         Core.Annot a b ->
             Core.Annot a' b'

dhall-lsp-server/src/Dhall/LSP/Backend/Completion.hs

@@ -9,10 +9,9 @@ import System.Environment (getEnvironment)
 import System.Timeout (timeout)
 
 import Dhall.Context (empty, toList)
-import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.Text as Text
 import Dhall.Context (Context, insert)
-import Dhall.Core (Expr(..), Binding(..), Var(..), normalize, shift, subst, pretty, reservedIdentifiers)
+import Dhall.Core (Expr(..), Var(..), normalize, shift, subst, pretty, reservedIdentifiers)
 import Dhall.TypeCheck (X, typeWithA, typeOf)
 import Dhall.Parser (Src, exprFromText)
 import qualified Dhall.Map
@@ -78,7 +77,7 @@ buildCompletionContext = buildCompletionContext' empty empty
 
 buildCompletionContext' :: Context (Expr Src X) -> Context (Expr Src X)
   -> Expr Src X -> CompletionContext
-buildCompletionContext' context values (Let (Binding x mA a :| []) e)
+buildCompletionContext' context values (Let x mA a e)
   -- We prefer the actual value over the annotated type in order to get
   -- 'dependent let' behaviour whenever possible.
   | Right _A <- typeWithA absurd context a =

dhall-lsp-server/src/Dhall/LSP/Backend/Linting.hs

@@ -6,46 +6,52 @@ module Dhall.LSP.Backend.Linting
 where
 
 import Dhall.Parser (Src)
-import Dhall.Core (Expr(..), Binding(..), Var(..), subExpressions, freeIn, Import)
+import Dhall.Core ( Expr(..), Binding(..), MultiLet(..), Var(..), Import
+                  , subExpressions, freeIn, multiLet, wrapInLets)
 import qualified Dhall.Lint as Dhall
 
 import Dhall.LSP.Backend.Diagnostics
 
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Maybe (maybeToList)
 import Data.Monoid ((<>))
 import Data.Text (Text)
-import Data.List.NonEmpty (NonEmpty(..), tails, toList)
 import Control.Lens (universeOf)
 
 data Suggestion = Suggestion {
     range :: Range,
     suggestion :: Text
     }
 
--- Diagnose nested let blocks.
-diagLetInLet :: Expr Src a -> [Suggestion]
-diagLetInLet (Note _ (Let _ (Note src (Let _ _)))) =
-  [Suggestion (rangeFromDhall src) "Superfluous 'in' before nested let binding"]
-diagLetInLet _ = []
-
--- Given a (noted) let block compute all unused variables in the block.
-unusedBindings :: Eq a => Expr s a -> [Text]
-unusedBindings (Note _ (Let bindings d)) =
-  let go (Binding var _ _ : []) | not (V var 0 `freeIn` d) = [var]
-      go (Binding var _ _ : (b : bs)) | not (V var 0 `freeIn` Let (b :| bs) d) = [var]
+-- Diagnose nested let-blocks.
+--
+-- Pattern matching on a 'Let' wrapped in a 'Note' prevents us from repeating
+-- the search beginning at different @let@s in the same let-block – only
+-- the outermost 'Let' of a let-block is wrapped in a 'Note'.
+diagLetInLet :: Expr Src a -> Maybe Suggestion
+diagLetInLet (Note _ (Let x mA a b)) = case multiLet x mA a b of
+    MultiLet _ (Note src (Let _ _ _ _)) ->
+      Just (Suggestion (rangeFromDhall src) "Superfluous 'in' before nested let binding")
+    _ -> Nothing
+diagLetInLet _ = Nothing
+
+-- Given a let-block compute all unused variables in the block.
+unusedBindings :: Eq a => MultiLet s a -> [Text]
+unusedBindings (MultiLet bindings d) =
+  let go (Binding var _ _ : bs) | not (V var 0 `freeIn` wrapInLets bs d) = [var]
       go _ = []
-  in concatMap go (toList $ tails bindings)
-unusedBindings _ = []
+  in foldMap go (NonEmpty.tails bindings)
 
 -- Diagnose unused let bindings.
-diagUnusedBinding :: Eq a => Expr Src a -> [Suggestion]
-diagUnusedBinding e@(Note src (Let _ _)) = map
+diagUnusedBindings :: Eq a => Expr Src a -> [Suggestion]
+diagUnusedBindings (Note src (Let x mA a e)) = map
   (\var ->
     Suggestion (rangeFromDhall src) ("Unused let binding '" <> var <> "'"))
-  (unusedBindings e)
-diagUnusedBinding _ = []
+  (unusedBindings (multiLet x mA a e))
+diagUnusedBindings _ = []
 
 -- | Given an dhall expression suggest all the possible improvements that would
 --   be made by the linter.
 suggest :: Expr Src Import -> [Suggestion]
-suggest expr = concat [ diagLetInLet e ++ diagUnusedBinding e
+suggest expr = concat [ maybeToList (diagLetInLet e) ++ diagUnusedBindings e
                       | e <- universeOf subExpressions expr ]

dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs

@@ -11,9 +11,8 @@ module Dhall.LSP.Backend.Parsing
   )
 where
 
-import Data.List.NonEmpty (NonEmpty(..))
 import Data.Text (Text)
-import Dhall.Core (Expr(..), Import, Binding(..), Var(..))
+import Dhall.Core (Expr(..), Import, Var(..))
 import Dhall.Src (Src(..))
 import Dhall.Parser
 import Dhall.Parser.Token
@@ -227,7 +226,7 @@ binderExprFromText txt =
       value <- try (do _equal; expr)
           <|> (do skipManyTill anySingle (lookAhead boundary <|> _in); return holeExpr)
       inner <- parseBinderExpr
-      return (Let (Binding name mType value :| []) inner)
+      return (Let name mType value inner)
 
     forallBinder = do
       _forall

dhall-lsp-server/src/Dhall/LSP/Backend/Typing.hs

@@ -1,19 +1,18 @@
 module Dhall.LSP.Backend.Typing (annotateLet, exprAt, srcAt, typeAt) where
 
 import Dhall.Context (Context, insert, empty)
-import Dhall.Core (Expr(..), Binding(..), subExpressions, normalize, shift, subst, Var(..), pretty)
+import Dhall.Core (Expr(..), subExpressions, normalize, shift, subst, Var(..), pretty)
 import Dhall.TypeCheck (typeWithA, X, TypeError(..))
 import Dhall.Parser (Src(..))
 
-import Data.List.NonEmpty (NonEmpty (..))
 import Data.Monoid ((<>))
 import Control.Lens (toListOf)
 import Data.Text (Text)
 import Control.Applicative ((<|>))
 import Data.Bifunctor (first)
 import Data.Void (absurd)
 
-import Dhall.LSP.Backend.Parsing (getLetInner, getLetAnnot, getLetIdentifier,
+import Dhall.LSP.Backend.Parsing (getLetAnnot, getLetIdentifier,
   getLamIdentifier, getForallIdentifier)
 import Dhall.LSP.Backend.Diagnostics (Position, Range(..), rangeFromDhall)
 import Dhall.LSP.Backend.Dhall (WellTyped, fromWellTyped)
@@ -23,18 +22,15 @@ import Dhall.LSP.Backend.Dhall (WellTyped, fromWellTyped)
 --   that subexpression if possible.
 typeAt :: Position -> WellTyped -> Either String (Maybe Src, Expr Src X)
 typeAt pos expr = do
-  expr' <- case splitLets (fromWellTyped expr) of
-             Just e -> return e
-             Nothing -> Left "The impossible happened: failed to split let\
-                              \ blocks when preprocessing for typeAt'."
+  let expr' = fromWellTyped expr
   (mSrc, typ) <- first show $ typeAt' pos empty expr'
   case mSrc of
     Just src -> return (Just src, normalize typ)
     Nothing -> return (srcAt pos expr', normalize typ)
 
 typeAt' :: Position -> Context (Expr Src X) -> Expr Src X -> Either (TypeError Src X) (Maybe Src, Expr Src X)
 -- the user hovered over the bound name in a let expression
-typeAt' pos ctx (Note src (Let (Binding _ _ a :| []) _)) | pos `inside` getLetIdentifier src = do
+typeAt' pos ctx (Note src (Let _ _ a _)) | pos `inside` getLetIdentifier src = do
   typ <- typeWithA absurd ctx a
   return (Just $ getLetIdentifier src, typ)
 
@@ -49,7 +45,7 @@ typeAt' pos _ctx (Note src (Pi _ _A _)) | Just src' <- getForallIdentifier src
   return (Just src', _A)
 
 -- the input only contains singleton lets
-typeAt' pos ctx (Let (Binding x _ a :| []) e@(Note src _)) | pos `inside` src = do
+typeAt' pos ctx (Let x _ a e@(Note src _)) | pos `inside` src = do
   _ <- typeWithA absurd ctx a
   let a' = shift 1 (V x 0) (normalize a)
   typeAt' pos ctx (shift (-1) (V x 0) (subst (V x 0) a' e))
@@ -78,16 +74,12 @@ typeAt' pos ctx expr = do
 
 -- | Find the smallest Note-wrapped expression at the given position.
 exprAt :: Position -> Expr Src a -> Maybe (Expr Src a)
-exprAt pos e = do e' <- splitLets e
-                  exprAt' pos e'
-
-exprAt' :: Position -> Expr Src a -> Maybe (Expr Src a)
-exprAt' pos e@(Note _ expr) = exprAt pos expr <|> Just e
-exprAt' pos expr =
+exprAt pos e@(Note _ expr) = exprAt pos expr <|> Just e
+exprAt pos expr =
   let subExprs = toListOf subExpressions expr
   in case [ (src, e) | (Note src e) <- subExprs, pos `inside` src ] of
     [] -> Nothing
-    ((src,e) : _) -> exprAt' pos e <|> Just (Note src e)
+    ((src,e) : _) -> exprAt pos e <|> Just (Note src e)
 
 
 -- | Find the smallest Src annotation containing the given position.
@@ -102,15 +94,11 @@ srcAt pos expr = do Note src _ <- exprAt pos expr
 --   something goes wrong returns a textual error message.
 annotateLet :: Position -> WellTyped -> Either String (Src, Text)
 annotateLet pos expr = do
-  expr' <- case splitLets (fromWellTyped expr) of
-             Just e -> return e
-             Nothing -> Left "The impossible happened: failed to split let\
-                              \ blocks when preprocessing for annotateLet'."
-  annotateLet' pos empty expr'
+  annotateLet' pos empty (fromWellTyped expr)
 
 annotateLet' :: Position -> Context (Expr Src X) -> Expr Src X -> Either String (Src, Text)
 -- the input only contains singleton lets
-annotateLet' pos ctx (Note src e@(Let (Binding _ _ a :| []) _))
+annotateLet' pos ctx (Note src e@(Let _ _ a _))
   | not $ any (pos `inside`) [ src' | Note src' _ <- toListOf subExpressions e ]
   = do _A <- first show $ typeWithA absurd ctx a
        srcAnnot <- case getLetAnnot src of
@@ -120,7 +108,7 @@ annotateLet' pos ctx (Note src e@(Let (Binding _ _ a :| []) _))
        return (srcAnnot, ": " <> pretty (normalize _A) <> " ")
 
 -- binders, see typeAt'
-annotateLet' pos ctx (Let (Binding x _ a :| []) e@(Note src _)) | pos `inside` src = do
+annotateLet' pos ctx (Let x _ a e@(Note src _)) | pos `inside` src = do
   _ <- first show $ typeWithA absurd ctx a
   let a' = shift 1 (V x 0) (normalize a)
   annotateLet' pos ctx (shift (-1) (V x 0) (subst (V x 0) a' e))
@@ -146,15 +134,6 @@ annotateLet' pos ctx expr = do
     (e:[]) -> annotateLet' pos ctx e
     _ -> Left "You weren't pointing at a let binder!"
 
-
--- Split all multilets into single lets in an expression
-splitLets :: Expr Src a -> Maybe (Expr Src a)
-splitLets (Note src (Let (b :| (b' : bs)) e)) = do
-  src' <- getLetInner src
-  splitLets (Note src (Let (b :| []) (Note src' (Let (b' :| bs) e))))
-splitLets expr = subExpressions splitLets expr
-
-
 -- Check if range lies completely inside a given subexpression.
 -- This version takes trailing whitespace into account
 -- (c.f. `sanitiseRange` from Backend.Diangostics).

dhall-nix/src/Dhall/Nix.hs

@@ -96,7 +96,7 @@ import Data.Fix (Fix(..))
 import Data.Traversable (for)
 import Data.Typeable (Typeable)
 import Data.Void (absurd)
-import Dhall.Core (Chunks(..), Const(..), Expr(..), Var(..))
+import Dhall.Core (Chunks(..), Const(..), Expr(..), MultiLet(..), Var(..))
 import Dhall.TypeCheck (X)
 import Nix.Atoms (NAtom(..))
 import Nix.Expr
@@ -230,7 +230,8 @@ dhallToNix e = loop (Dhall.Core.normalize e)
         a' <- loop a
         b' <- loop b
         return (Fix (NBinary NApp a' b'))
-    loop (Let as b) = do
+    loop (Let x mA a0 b0) = do
+        let MultiLet as b = Dhall.Core.multiLet x mA a0 b0
         as' <- for as $ \a -> do
           val <- loop $ Dhall.Core.value a
           pure $ NamedVar [StaticKey $ Dhall.Core.variable a] val Nix.nullPos

dhall/benchmark/deep-nested-large-record/Main.hs

@@ -25,23 +25,20 @@ issue412 :: Core.Expr s TypeCheck.X -> Gauge.Benchmarkable
 issue412 prelude = Gauge.whnf TypeCheck.typeOf expr
   where
     expr
-      = Core.Let (pure (Core.Binding "prelude" Nothing prelude))
+      = Core.Let "prelude" Nothing prelude
       $ Core.ListLit Nothing
       $ Seq.replicate 5
       $ Core.Var (Core.V "prelude" 0) `Core.Field` "types" `Core.Field` "Little" `Core.Field` "Foo"
 
 unionPerformance :: Core.Expr s TypeCheck.X -> Gauge.Benchmarkable
 unionPerformance prelude = Gauge.whnf TypeCheck.typeOf expr
   where
-    innerBinding =
-        Core.Binding "big" Nothing
-            (prelude `Core.Field` "types" `Core.Field` "Big")
-
-    outerBinding =
-        Core.Binding "x" Nothing
-            (Core.Let (pure innerBinding) (Core.Prefer "big" "big"))
-
-    expr = Core.Let (pure outerBinding) "x"
+    expr =
+        Core.Let "x" Nothing
+            (Core.Let "big" Nothing (prelude `Core.Field` "types" `Core.Field` "Big")
+                (Core.Prefer "big" "big")
+            )
+            "x"
 
 main :: IO ()
 main = do

dhall/src/Dhall/Binary.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE OverloadedStrings  #-}
@@ -25,7 +26,6 @@ module Dhall.Binary
 import Codec.CBOR.Term (Term(..))
 import Control.Applicative (empty, (<|>))
 import Control.Exception (Exception)
-import Data.Void (Void, absurd)
 import Dhall.Core
     ( Binding(..)
     , Chunks(..)
@@ -38,16 +38,16 @@ import Dhall.Core
     , ImportHashed(..)
     , ImportMode(..)
     , ImportType(..)
+    , MultiLet(..)
     , Scheme(..)
     , URL(..)
     , Var(..)
     )
 
 import Data.Foldable (toList)
-import Data.List.NonEmpty (NonEmpty(..))
 import Data.Monoid ((<>))
 import Data.Text (Text)
-import Prelude hiding (exponent)
+import Data.Void (Void, absurd)
 import GHC.Float (double2Float, float2Double)
 
 import qualified Crypto.Hash
@@ -371,19 +371,21 @@ instance ToTerm a => ToTerm (Expr Void a) where
         t₁ = encode t₀
     encode (Embed x) =
         encode x
-    encode (Let as₀ b₀) =
+    encode (Let x mA a b) =
         TList ([ TInt 25 ] ++ as₁ ++ [ b₁ ])
       where
+        MultiLet as₀ b₀ = Dhall.Core.multiLet x mA a b
+
         as₁ = do
-            Binding x mA₀ a₀ <- toList as₀
+            Binding x₀ mA₀ a₀ <- toList as₀
 
             let mA₁ = case mA₀ of
                     Nothing  -> TNull
                     Just _A₀ -> encode _A₀
 
             let a₁ = encode a₀
 
-            [ TString x, mA₁, a₁ ]
+            [ TString x₀, mA₁, a₁ ]
 
         b₁ = encode b₀
     encode (Annot t₀ _T₀) =
@@ -724,17 +726,11 @@ instance FromTerm a => FromTerm (Expr s a) where
 
                 a₀  <- decode a₁
 
-                let binding = Binding x mA₀ a₀
-
-                case ls₁ of
-                    [ b₁ ] -> do
-                        b₀ <- decode b₁
-
-                        return (Let (binding :| []) b₀)
-                    _ -> do
-                        Let (l₀ :| ls₀) b₀ <- process ls₁
+                b₀ <- case ls₁ of
+                    [ b₁ ] -> decode b₁
+                    _      -> process ls₁
 
-                        return (Let (binding :| (l₀ : ls₀)) b₀)
+                return (Let x mA₀ a₀ b₀)
             process _ = do
                 empty