Try to fix "do" scoping

Author: ChrisPenner

parser-typechecker/package.yaml

@@ -11,7 +11,6 @@ library:
       other-modules: Paths_unison_parser_typechecker
 
   dependencies:
-    - recover-rtti
     - ListLike
     - aeson
     - async

parser-typechecker/src/Unison/Syntax/TermParser.hs

@@ -34,7 +34,6 @@ import Unison.ABT qualified as ABT
 import Unison.Builtin.Decls qualified as DD
 import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
 import Unison.ConstructorType qualified as CT
-import Unison.Debug qualified as Debug
 import Unison.HashQualified qualified as HQ
 import Unison.HashQualifiedPrime qualified as HQ'
 import Unison.Name (Name)
@@ -111,7 +110,7 @@ rewriteBlock = do
     rewriteTermlike kw mk = do
       kw <- quasikeyword kw
       lhs <- term
-      (_spanAnn, rhs) <- layoutBlock "==>"
+      (_openAnn, _spanAnn, rhs) <- layoutBlock "==>"
       pure (mk (ann kw <> ann rhs) lhs rhs)
     rewriteTerm = rewriteTermlike "term" DD.rewriteTerm
     rewriteCase = rewriteTermlike "case" DD.rewriteCase
@@ -233,10 +232,10 @@ matchCase = do
             [ Nothing <$ quasikeyword "otherwise",
               Just <$> infixAppOrBooleanOp
             ]
-        (_spanAnn, t) <- layoutBlock "->"
+        (_openAnn, _spanAnn, t) <- layoutBlock "->"
         pure (guard, t)
   let unguardedBlock = label "case match" do
-        (_spanAnn, t) <- layoutBlock "->"
+        (_openAnn, _spanAnn, t) <- layoutBlock "->"
         pure (Nothing, t)
   -- a pattern's RHS is either one or more guards, or a single unguarded block.
   guardsAndBlocks <- guardedBlocks <|> (pure @[] <$> unguardedBlock)
@@ -454,10 +453,12 @@ lam p = label "lambda" $ mkLam <$> P.try (some prefixDefinitionName <* reserved
        in Term.lam' (ann (head vs) <> ann b) annotatedArgs b
 
 letBlock, handle, ifthen :: (Monad m, Var v) => TermP v m
-letBlock = label "let" $ (snd <$> layoutBlock "let")
+letBlock = label "let" $ do
+  (_openAnn, _spanAnn, tm) <- layoutBlock "let"
+  pure tm
 handle = label "handle" do
-  (handleSpan, b) <- block "handle"
-  (_withSpan, handler) <- layoutBlock "with"
+  (_handleOpenAnn, handleSpan, b) <- block "handle"
+  (_withOpenAnn, _withSpan, handler) <- layoutBlock "with"
   -- We don't use the annotation span from 'with' here because it will
   -- include a dedent if it's at the end of block.
   -- Meaning the newline gets overwritten when pretty-printing and it messes things up.
@@ -492,9 +493,9 @@ lamCase = do
 
 ifthen = label "if" do
   start <- peekAny
-  (_spanAnn, c) <- block "if"
-  (_spanAnn, t) <- block "then"
-  (_spanAnn, f) <- layoutBlock "else"
+  (_ifOpenAnn, _spanAnn, c) <- block "if"
+  (_thenAnn, _spanAnn, t) <- block "then"
+  (_elseAnn, _spanAnn, f) <- layoutBlock "else"
   pure $ Term.iff (ann start <> ann f) c t f
 
 text :: (Var v) => TermP v m
@@ -628,11 +629,17 @@ doc2Block = do
     docTop d = \case
       Doc.Section title body -> pure $ Term.apps' (f d "Section") [docParagraph d title, Term.list (gann body) body]
       Doc.Eval code ->
-        Term.app (gann d) (f d "Eval") . addDelay . snd
-          <$> subParse (block' False False "syntax.docEval" (pure $ pure ()) $ Ann.External <$ P.eof) code
+        let inner = do
+              (_openAnn, ann, tm) <- (block' False False "syntax.docEval" (pure $ pure ()) $ Ann.External <$ P.eof)
+              pure (ann, tm)
+         in Term.app (gann d) (f d "Eval") . addDelay . snd
+              <$> subParse inner code
       Doc.ExampleBlock code ->
-        Term.apps' (f d "ExampleBlock") . (Term.nat (gann d) 0 :) . pure . addDelay . snd
-          <$> subParse (block' False True "syntax.docExampleBlock" (pure $ pure ()) $ Ann.External <$ P.eof) code
+        let inner = do
+              (_openAnn, ann, tm) <- (block' False True "syntax.docExampleBlock" (pure $ pure ()) $ Ann.External <$ P.eof)
+              pure (ann, tm)
+         in Term.apps' (f d "ExampleBlock") . (Term.nat (gann d) 0 :) . pure . addDelay . snd
+              <$> subParse inner code
       Doc.CodeBlock label body ->
         pure $
           Term.apps'
@@ -1111,9 +1118,8 @@ delayQuote = P.label "quote" do
 
 delayBlock :: (Monad m, Var v) => P v m (Ann {- Ann spanning the whole block -}, Term v Ann)
 delayBlock = P.label "do" do
-  (spanAnn, b) <- layoutBlock "do"
-  let argSpan = (ann b {- would be nice to use the annotation for 'do' here, but it's not terribly important -})
-  pure $ (spanAnn, DD.delayTerm (ann b) argSpan b)
+  (openAnn, spanAnn, b) <- layoutBlock "do"
+  pure $ (spanAnn, DD.delayTerm (ann b) openAnn b)
 
 bang :: (Monad m, Var v) => TermP v m
 bang = P.label "bang" do
@@ -1264,7 +1270,7 @@ destructuringBind = do
     let boundVars' = snd <$> boundVars
     _ <- P.lookAhead (openBlockWith "=")
     pure (p, boundVars')
-  (_spanAnn, scrute) <- layoutBlock "=" -- Dwight K. Scrute ("The People's Scrutinee")
+  (_eqAnn, _spanAnn, scrute) <- layoutBlock "=" -- Dwight K. Scrute ("The People's Scrutinee")
   let guard = Nothing
   let absChain vs t = foldr (\v t -> ABT.abs' (ann t) v t) t vs
       thecase t = Term.MatchCase p (fmap (absChain boundVars) guard) $ absChain boundVars t
@@ -1310,7 +1316,7 @@ binding = label "binding" do
     Nothing -> do
       -- we haven't seen a type annotation, so lookahead to '=' before commit
       (lhsLoc, name, args) <- P.try (lhs <* P.lookAhead (openBlockWith "="))
-      (_bodySpanAnn, body) <- block "="
+      (_eqAnn, _bodySpanAnn, body) <- block "="
       verifyRelativeName' (fmap Name.unsafeParseVar name)
       let binding = mkBinding lhsLoc args body
       -- We don't actually use the span annotation from the block (yet) because it
@@ -1323,7 +1329,7 @@ binding = label "binding" do
       when (L.payload name /= L.payload nameT) $
         customFailure $
           SignatureNeedsAccompanyingBody nameT
-      (_bodySpanAnn, body) <- block "="
+      (_eqAnn, _bodySpanAnn, body) <- block "="
       let binding = mkBinding lhsLoc args body
       -- We don't actually use the span annotation from the block (yet) because it
       -- may contain a bunch of white-space and comments following a top-level-definition.
@@ -1339,10 +1345,30 @@ binding = label "binding" do
 customFailure :: (P.MonadParsec e s m) => e -> m a
 customFailure = P.customFailure
 
-block :: forall m v. (Monad m, Var v) => String -> P v m (Ann, Term v Ann)
+block ::
+  forall m v.
+  (Monad m, Var v) =>
+  String ->
+  P
+    v
+    m
+    ( Ann {- annotation of block-open symbol, e.g. 'do', 'let' -},
+      Ann {- annotation for whole block -},
+      Term v Ann
+    )
 block s = block' False False s (openBlockWith s) closeBlock
 
-layoutBlock :: forall m v. (Monad m, Var v) => String -> P v m (Ann, Term v Ann)
+layoutBlock ::
+  forall m v.
+  (Monad m, Var v) =>
+  String ->
+  P
+    v
+    m
+    ( Ann {- annotation of block-open symbol, e.g. 'do', 'let' -},
+      Ann {- annotation for whole layout block -},
+      Term v Ann
+    )
 layoutBlock s = block' False False s (openBlockWith s) optionalCloseBlock
 
 -- example: use Foo.bar.Baz + ++ x
@@ -1421,15 +1447,15 @@ block' ::
   String ->
   P v m (L.Token ()) ->
   P v m end ->
-  P v m (Ann {- ann which spans the whole block -}, Term v Ann)
+  P v m (Ann {- span for the opening token, e.g. the "do" or opening bracket -}, Ann {- ann which spans the whole block -}, Term v Ann)
 block' isTop implicitUnitAtEnd s openBlock closeBlock = do
   open <- openBlock
   (names, imports) <- imports
   _ <- optional semi
   statements <- local (\e -> e {names}) $ sepBy semi statement
   end <- closeBlock
   body <- substImports names imports <$> go open statements
-  pure (ann open <> ann end, body)
+  pure (ann open, ann open <> ann end, body)
   where
     statement = asum [Binding <$> binding, DestructuringBind <$> destructuringBind, Action <$> blockTerm]
     go :: L.Token () -> [BlockElement v] -> P v m (Term v Ann)
@@ -1448,7 +1474,6 @@ block' isTop implicitUnitAtEnd s openBlock closeBlock = do
               step elem result = case elem of
                 Binding ((a, v), tm) -> do
                   let fullLetRecSpan = ann a <> ann result
-                  Debug.debugM Debug.Temp "letrec" (v, a)
                   pure $
                     Term.consLetRec
                       isTop

parser-typechecker/src/Unison/Typechecker/Context.hs

@@ -105,8 +105,6 @@ import Unison.Typechecker.TypeLookup qualified as TL
 import Unison.Typechecker.TypeVar qualified as TypeVar
 import Unison.Var (Var)
 import Unison.Var qualified as Var
-import qualified Unison.Debug as Debug
-import Debug.RecoverRTTI (anythingToString)
 import Data.Set.NonEmpty (NESet)
 
 type TypeVar v loc = TypeVar.TypeVar (B.Blank loc) v
@@ -1243,7 +1241,6 @@ synthesizeWanted (Term.Let1Top' top binding boundVarAnn e) = do
   when (Var.isAction (ABT.variable e)) $
     -- enforce that actions in a block have type ()
     subtype tbinding (DDB.unitType (ABT.annotation binding))
-  Debug.debugM Debug.Temp "Let1Top" (ABT.variable e, v', anythingToString boundVarAnn, tbinding)
   appendContext [Ann v' boundVarAnn tbinding]
   (t, w) <- synthesize (ABT.bindInheritAnnotation e (Term.var () v'))
   t <- applyM t
@@ -1345,7 +1342,6 @@ synthesizeWanted e
       let it = existential' l B.Blank i
           ot = existential' l B.Blank o
           et = existential' l B.Blank e
-      Debug.debugM Debug.Temp "synthesizeWanted:Lam" (arg, anythingToString boundVarAnn, i, e, o)
       appendContext $
         [existential i, existential e, existential o, Ann arg boundVarAnn it]
 
@@ -1913,7 +1909,6 @@ annotateLetRecBindings isTop letrec =
                 pure $ (e, existential' (loc binding) B.Blank vt, vloc)
         (bindings, bindingTypes, vlocs) <- unzip3 <$> traverse f bindings
         appendContext (zipWith3 Ann vs vlocs bindingTypes)
-        Debug.debugM Debug.Temp "annotateLetRecBindings"  (zip vs (anythingToString <$> vlocs))
         -- check each `bi` against its type
         Foldable.for_ (zip3 vs bindings bindingTypes) $ \(v, b, t) -> do
           -- note: elements of a cycle have to be pure, otherwise order of effects
@@ -1930,7 +1925,6 @@ annotateLetRecBindings isTop letrec =
           bindingTypesGeneralized = zipWith gen bindingTypes bindingArities
           annotations = zipWith3 Ann vs vlocs bindingTypesGeneralized
 
-      Debug.debugM Debug.Temp "annotateLetRecBindings2"  (zip vs (anythingToString <$> vlocs))
       appendContext annotations
       let vTypes = vs `zip` bindingTypesGeneralized
       pure (body, vTypes)
@@ -2466,7 +2460,6 @@ checkWanted want m (Type.Forall' body) = do
 checkWanted want (Term.Lam' boundVarAnn body) (Type.Arrow'' i es o) = do
   x <- ABT.freshen body freshenVar
   markThenRetract0 x $ do
-    Debug.debugM Debug.Temp "checkWanted:Lam" (x, anythingToString boundVarAnn)
     extendContext (Ann x boundVarAnn i)
     body <- pure $ ABT.bindInheritAnnotation body (Term.var () x)
     checkWithAbilities es body o

parser-typechecker/unison-parser-typechecker.cabal

@@ -219,7 +219,6 @@ library
     , network-uri
     , nonempty-containers
     , pretty-simple
-    , recover-rtti
     , regex-tdfa
     , semialign
     , semigroups

unison-cli/src/Unison/LSP/Hover.hs

@@ -124,6 +124,7 @@ hoverInfo uri pos =
 
     hoverInfoForLocalVar :: MaybeT Lsp Text
     hoverInfoForLocalVar = do
+      Debug.debugM Debug.Temp "pos" pos
       let varFromNode = do
             node <- LSPQ.nodeAtPosition uri pos
             Debug.debugM Debug.Temp "node" node
@@ -140,7 +141,6 @@ hoverInfo uri pos =
       FileAnalysis {localBindingTypes} <- FileAnalysis.getFileAnalysis uri
       Debug.debugM Debug.Temp "localBindingTypes" localBindingTypes
       Debug.debugM Debug.Temp "localVar" localVar
-      Debug.debugM Debug.Temp "pos" pos
       (_range, typ) <- hoistMaybe $ IM.lookupMin $ IM.intersecting localBindingTypes (IM.ClosedInterval pos pos)
 
       pped <- lift $ ppedForFile uri

unison-cli/src/Unison/LSP/Queries.hs

@@ -240,8 +240,10 @@ findSmallestEnclosingNode pos term
               Term.And l r -> findSmallestEnclosingNode pos l <|> findSmallestEnclosingNode pos r
               Term.Or l r -> findSmallestEnclosingNode pos l <|> findSmallestEnclosingNode pos r
               Term.Lam a -> findSmallestEnclosingNode pos a
-              Term.LetRec _isTop xs y -> findSmallestEnclosingNode pos y <|> altSum (findSmallestEnclosingNode pos <$> xs)
-              Term.Let _isTop a b -> findSmallestEnclosingNode pos b <|> findSmallestEnclosingNode pos a
+              Term.LetRec _isTop xs y ->
+                findSmallestEnclosingNode pos y <|> altSum (findSmallestEnclosingNode pos <$> xs)
+              Term.Let _isTop a b ->
+                findSmallestEnclosingNode pos b <|> findSmallestEnclosingNode pos a
               Term.Match a cases ->
                 findSmallestEnclosingNode pos a
                   <|> altSum (cases <&> \(MatchCase pat grd body) -> ((PatternNode <$> findSmallestEnclosingPattern pos pat) <|> (grd >>= findSmallestEnclosingNode pos) <|> findSmallestEnclosingNode pos body))