WIP

Author: ChrisPenner

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

@@ -367,7 +367,7 @@ data InfoNote v loc
     -- job to use the binding with the smallest containing scope so as to respect variable
     -- shadowing.
     -- This is used in the LSP.
-    VarBinding v (Type v loc)
+    VarBinding v loc (Type v loc)
   | -- | The usage of a particular variable. We report the variable and its location so we can match a given source location with a specific symbol later in the LSP.
     VarMention v loc
   deriving (Show)
@@ -394,7 +394,7 @@ substituteSolved ::
   InfoNote v loc
 substituteSolved ctx  = \case
   (SolvedBlank b v t) -> SolvedBlank b v (applyCtx ctx t)
-  VarBinding v t -> VarBinding v (applyCtx ctx t)
+  VarBinding v loc t -> VarBinding v loc (applyCtx ctx t)
   i -> i
 
 
@@ -815,7 +815,7 @@ extend' e c@(Context ctx) = Context . (: ctx) . (e,) <$> i'
 extend :: (Var v) => Element v loc -> Context v loc -> M v loc (Context v loc)
 extend e c = do
   case e of
-    Ann v _loc t -> noteVarBinding v t
+    Ann v loc t -> noteVarBinding v loc t
     _ -> pure ()
   either compilerCrash pure $ extend' e c
 
@@ -1122,8 +1122,8 @@ noteTopLevelType e binding typ = case binding of
 -- | Take note of the types and locations of all bindings, including let bindings, letrec
 -- bindings, lambda argument bindings and top-level bindings.
 -- This information is used to provide information to the LSP after typechecking.
-noteVarBinding :: (Var v) => v -> Type v loc ->  M v loc ()
-noteVarBinding v t = btw $ VarBinding v t
+noteVarBinding :: (Var v) => v -> loc -> Type v loc ->  M v loc ()
+noteVarBinding v loc t = btw $ VarBinding v loc t
 
 noteVarMention :: (Var v) => v -> loc -> M v loc ()
 noteVarMention v loc = do
@@ -1237,20 +1237,13 @@ synthesizeWanted (Term.Constructor' r) =
 synthesizeWanted tm@(Term.Request' r) =
   fmap (wantRequest tm) . ungeneralize . Type.purifyArrows
     =<< getEffectConstructorType r
-synthesizeWanted tm@(Term.Let1Top' top binding e) = do
+synthesizeWanted (Term.Let1Top' top binding boundVarAnn e) = do
   (tbinding, wb) <- synthesizeBinding top binding
   v' <- ABT.freshen e freshenVar
   when (Var.isAction (ABT.variable e)) $
     -- enforce that actions in a block have type ()
     subtype tbinding (DDB.unitType (ABT.annotation binding))
-  case tm of
-    outer@(ABT.Tm' (Term.Let _ rhs abs@(ABT.Term _ _ (ABT.Abs v' body)))) -> do
-      -- let innerAnn = ABT.annotation inner
-      --     tbinding' = ABT.annotation binding
-      Debug.debugM Debug.Temp "synthesizeWanted (let binding)" (v', ("outer" :: Text, anythingToString $ ABT.annotation outer), ("rhs" :: Text, anythingToString $ ABT.annotation rhs), ("abs" :: Text, anythingToString $ ABT.annotation abs), ("body" :: Text, anythingToString $ ABT.annotation body))
-    _ -> pure ()
-  appendContext [Ann v' (error "Unset Ann loc: synthesizeWanted") tbinding]
-  -- Debug.debugM Debug.Temp "synthesizeWanted (missing annotation)" (v', anythingToString $ ABT.annotation tm, binding)
+  appendContext [Ann v' boundVarAnn tbinding]
   (t, w) <- synthesize (ABT.bindInheritAnnotation e (Term.var () v'))
   t <- applyM t
   when top $ noteTopLevelType  e binding tbinding
@@ -1338,7 +1331,7 @@ synthesizeWanted e
 
   -- ->I=> (Full Damas Milner rule)
   -- | Term.Lam' body <- e = do
-  | tm@(ABT.Tm' (Term.Lam (ABT.Abs' body))) <- e = do
+  | (ABT.Tm' (Term.Lam (ABT.Abs' boundVarAnn body))) <- e = do
       -- arya: are there more meaningful locations we could put into and
       -- pull out of the abschain?)
       [arg, i, e, o] <-
@@ -1351,14 +1344,8 @@ synthesizeWanted e
       let it = existential' l B.Blank i
           ot = existential' l B.Blank o
           et = existential' l B.Blank e
-      case tm of
-        ABT.Term _ tmAnn (ABT.Tm (Term.Lam (ABT.Term _ absAnn (ABT.Abs v body)))) -> do
-          Debug.debugM Debug.Temp "Lambda binding anns" (v, anythingToString tmAnn, anythingToString absAnn, anythingToString $ ABT.annotation body)
-        _ -> pure ()
-      let annLoc = error "Unset Ann loc: synthesizeWanted"
       appendContext $
-        [existential i, existential e, existential o, Ann arg annLoc it]
-      Debug.debugM Debug.Temp "tm arg loc (missing annotation)" arg
+        [existential i, existential e, existential o, Ann arg boundVarAnn it]
 
       when (Var.typeOf i == Var.Delay) $ do
         -- '(1 + 1) turns into a lambda with an arg variable of type Var.Delay
@@ -1689,7 +1676,6 @@ checkPattern scrutineeType p =
       v <- getAdvance p
       v' <- lift $ freshenVar v
       lift . appendContext $ [Ann v' loc scrutineeType]
-      Debug.debugM Debug.Temp "Pattern binding anns" (v, anythingToString loc)
       pure [(v, v')]
     -- Ex: [42, y, Foo z]
     Pattern.SequenceLiteral loc ps -> do
@@ -1777,7 +1763,6 @@ checkPattern scrutineeType p =
       v <- getAdvance p
       v' <- lift $ freshenVar v
       lift . appendContext $ [Ann v' loc scrutineeType]
-      Debug.debugM Debug.Temp "As Pattern anns" (v, anythingToString loc)
       ((v, v') :) <$> checkPattern scrutineeType p'
     -- ex: { a } -> a
     -- ex: { (x, 42) } -> a
@@ -1913,7 +1898,7 @@ annotateLetRecBindings isTop letrec =
                 pure (Term.ann (loc binding) e t2, t2, vloc)
               -- If we're not using an annotation, we make one up. There's 2 cases:
 
-              lam@(Term.Lam' _) ->
+              lam@(Term.Lam' {}) ->
                 -- If `e` is a lambda of arity K, we immediately refine the
                 -- existential to `a1 ->{e1} a2 ... ->{eK} r`. This gives better
                 -- inference of the lambda's ability variables in conjunction with
@@ -2476,29 +2461,23 @@ checkWanted want m (Type.Forall' body) = do
       ABT.bindInheritAnnotation body (universal' () x)
 -- =>I
 -- Lambdas are pure, so they add nothing to the wanted set
-checkWanted want (Term.Lam' body) (Type.Arrow'' i es o) = do
-  let annLoc = error "checkWanted: missing annotation"
+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 (missing annotation)" x
-    extendContext (Ann x annLoc i)
+    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
   pure want
-checkWanted want tm@(Term.Let1Top' top binding m) t = do
-  case tm of
-    outer@(ABT.Tm' (Term.Let _ rhs abs@(ABT.Term _ _ (ABT.Abs v' body)))) -> do
-      Debug.debugM Debug.Temp "checkWanted:Let" (v', ("outer" :: Text, anythingToString $ ABT.annotation outer), ("rhs" :: Text, anythingToString $ ABT.annotation rhs), ("abs" :: Text, anythingToString $ ABT.annotation abs), ("body" :: Text, anythingToString $ ABT.annotation body))
-    _ -> pure ()
-  let annLoc = error "checkWanted: missing annotation"
+checkWanted want (Term.Let1Top' top binding boundVarAnn m) t = do
   (tbinding, wbinding) <- synthesizeBinding top binding
   want <- coalesceWanted wbinding want
   v <- ABT.freshen m freshenVar
   markThenRetractWanted v $ do
     when (Var.isAction (ABT.variable m)) $
       -- enforce that actions in a block have type ()
       subtype tbinding (DDB.unitType (ABT.annotation binding))
-    extendContext (Ann v annLoc tbinding)
+    extendContext (Ann v boundVarAnn tbinding)
     checkWanted want (ABT.bindInheritAnnotation m (Term.var () v)) t
 checkWanted want (Term.LetRecNamed' [] m) t =
   checkWanted want m t

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

@@ -121,15 +121,26 @@ checkFile doc = runMaybeT do
                 & Foldable.toList
                 & reverse -- Type notes that come later in typechecking have more information filled in.
                 & foldMap \case
-                  Result.TypeInfo (Context.VarBinding v typ) -> Map.singleton v typ
+                  Result.TypeInfo (Context.VarBinding v _loc typ) -> Map.singleton v typ
                   _ -> mempty
                 & pure
+
+            let allVarBindings =
+                  typecheckingNotes
+                    & Foldable.toList
+                    & reverse -- Type notes that come later in typechecking have more information filled in.
+                    & foldMap \case
+                      Result.TypeInfo (Context.VarBinding v loc _typ) -> [(v, loc)]
+                      _ -> mempty
+            Debug.debugM Debug.Temp "allVarBindings" allVarBindings
+
             let allVarMentions =
                   typecheckingNotes
                     & Foldable.toList
                     & reverse -- Type notes that come later in typechecking have more information filled in.
                     & foldMap \case
                       Result.TypeInfo (Context.VarMention v loc) -> [(v, loc)]
+                      Result.TypeInfo (Context.VarBinding v loc _) -> [(v, loc)]
                       _ -> mempty
             Debug.debugM Debug.Temp "allVarMentions" allVarMentions
             Debug.debugM Debug.Temp "symbolTypes" symbolTypes

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

@@ -128,7 +128,10 @@ hoverInfo uri pos =
             node <- LSPQ.nodeAtPosition uri pos
             Debug.debugM Debug.Temp "node" node
             case node of
+              -- Var mentions
               LSPQ.TermNode (Term.Var' v) -> pure $ v
+              -- Var bindings
+              LSPQ.TermNode (ABT.Abs'' v _body) -> pure $ v
               LSPQ.TermNode {} -> empty
               LSPQ.TypeNode {} -> empty
               LSPQ.PatternNode _pat -> empty

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

@@ -198,9 +198,12 @@ instance Functor SourceNode where
 -- children contain that position.
 findSmallestEnclosingNode :: Pos -> Term Symbol Ann -> Maybe (SourceNode Ann)
 findSmallestEnclosingNode pos term
-  | -- Abs nodes annotate the location of the var being bound, not the body of the binding, so we just skip over them.
-    ABT.Abs'' _ body <- term =
-      findSmallestEnclosingNode pos body
+  | ABT.Term _ absAnn (ABT.Abs _ body) <- term =
+      -- Abs nodes annotate the location of the var being bound, not the body of the binding, so we either match on
+      -- the binding, or skip over them to the body.
+      if absAnn `Ann.contains` pos
+        then Just (TermNode term)
+        else findSmallestEnclosingNode pos body
   | annIsFilePosition ann && not (ann `Ann.contains` pos) = Nothing
   | Just r <- cleanImplicitUnit term = findSmallestEnclosingNode pos r
   | otherwise = do

unison-core/src/Unison/ABT.hs

@@ -230,8 +230,8 @@ pattern Cycle'' t <- Term _ _ (Cycle t)
 pattern Abs'' :: v -> Term f v a -> Term f v a
 pattern Abs'' v body <- Term _ _ (Abs v body)
 
-pattern Abs' :: (Foldable f, Functor f, Var v) => Subst f v a -> Term f v a
-pattern Abs' subst <- (unabs1 -> Just subst)
+pattern Abs' :: (Foldable f, Functor f, Var v) => a -> Subst f v a -> Term f v a
+pattern Abs' absAnn subst <- (unabs1 -> Just (absAnn, subst))
 
 pattern CycleA' :: a -> [(a, v)] -> Term f v a -> Term f v a
 pattern CycleA' a avs t <- Term _ a (Cycle (AbsNA' avs t))
@@ -469,8 +469,8 @@ data Subst f v a = Subst
     variable :: v
   }
 
-unabs1 :: forall a f v. (Foldable f, Functor f, Var v) => Term f v a -> Maybe (Subst f v a)
-unabs1 (Term _ _ (Abs v body)) = Just (Subst freshen bind bindInheritAnnotation v)
+unabs1 :: forall a f v. (Foldable f, Functor f, Var v) => Term f v a -> Maybe (a, Subst f v a)
+unabs1 (Term _ absAnn (Abs v body)) = Just (absAnn, Subst freshen bind bindInheritAnnotation v)
   where
     freshen :: (v -> t) -> t
     freshen f = f v

unison-core/src/Unison/Term.hs

@@ -469,7 +469,7 @@ pattern Abs' ::
   (Foldable f, Functor f, ABT.Var v) =>
   ABT.Subst f v a ->
   ABT.Term f v a
-pattern Abs' subst <- ABT.Abs' subst
+pattern Abs' subst <- ABT.Abs' _absAnn subst
 
 pattern Int' :: Int64 -> ABT.Term (F typeVar typeAnn patternAnn) v a
 pattern Int' n <- (ABT.out -> ABT.Tm (Int n))
@@ -620,9 +620,10 @@ pattern List' xs <- (ABT.out -> ABT.Tm (List xs))
 
 pattern Lam' ::
   (ABT.Var v) =>
+  a ->
   ABT.Subst (F typeVar typeAnn patternAnn) v a ->
   ABT.Term (F typeVar typeAnn patternAnn) v a
-pattern Lam' subst <- ABT.Tm' (Lam (ABT.Abs' subst))
+pattern Lam' absAnn subst <- ABT.Tm' (Lam (ABT.Abs' absAnn subst))
 
 pattern Delay' :: (Var v) => Term2 vt at ap v a -> Term2 vt at ap v a
 pattern Delay' body <- (unDelay -> Just body)
@@ -659,17 +660,19 @@ pattern LamsNamedOrDelay' vs body <- (unLamsUntilDelay' -> Just (vs, body))
 pattern Let1' ::
   (Var v) =>
   Term' vt v a ->
+  a ->
   ABT.Subst (F vt a a) v a ->
   Term' vt v a
-pattern Let1' b subst <- (unLet1 -> Just (_, b, subst))
+pattern Let1' b bindNameAnn subst <- (unLet1 -> Just (_, b, bindNameAnn, subst))
 
 pattern Let1Top' ::
   (Var v) =>
   IsTop ->
   Term' vt v a ->
+  a ->
   ABT.Subst (F vt a a) v a ->
   Term' vt v a
-pattern Let1Top' top b subst <- (unLet1 -> Just (top, b, subst))
+pattern Let1Top' top b bindNameAnn subst <- (unLet1 -> Just (top, b, bindNameAnn, subst))
 
 pattern Let1Named' ::
   v ->
@@ -1060,8 +1063,8 @@ singleLet isTop spanAnn absAnn (v, body) e = ABT.tm' spanAnn (Let isTop body (AB
 unLet1 ::
   (Var v) =>
   Term' vt v a ->
-  Maybe (IsTop, Term' vt v a, ABT.Subst (F vt a a) v a)
-unLet1 (ABT.Tm' (Let isTop b (ABT.Abs' subst))) = Just (isTop, b, subst)
+  Maybe (IsTop, Term' vt v a, a, ABT.Subst (F vt a a) v a)
+unLet1 (ABT.Tm' (Let isTop b (ABT.Abs' absAnn subst))) = Just (isTop, b, absAnn, subst)
 unLet1 _ = Nothing
 
 -- | Satisfies `unLet (let' bs e) == Just (bs, e)`
@@ -1374,7 +1377,7 @@ updateDependencies termUpdates typeUpdates = ABT.rebuildUp go
 -- | If the outermost term is a function application,
 -- perform substitution of the argument into the body
 betaReduce :: (Var v) => Term0 v -> Term0 v
-betaReduce (App' (Lam' f) arg) = ABT.bind f arg
+betaReduce (App' (Lam' _absAnn f) arg) = ABT.bind f arg
 betaReduce e = e
 
 betaNormalForm :: (Var v) => Term0 v -> Term0 v

unison-core/src/Unison/Type.hs

@@ -153,10 +153,10 @@ pattern Effect0' :: (Ord v) => [Type v a] -> Type v a -> Type v a
 pattern Effect0' es t <- (unEffect0 -> (es, t))
 
 pattern Forall' :: (ABT.Var v) => ABT.Subst F v a -> ABT.Term F v a
-pattern Forall' subst <- ABT.Tm' (Forall (ABT.Abs' subst))
+pattern Forall' subst <- ABT.Tm' (Forall (ABT.Abs' _ subst))
 
 pattern IntroOuter' :: (ABT.Var v) => ABT.Subst F v a -> ABT.Term F v a
-pattern IntroOuter' subst <- ABT.Tm' (IntroOuter (ABT.Abs' subst))
+pattern IntroOuter' subst <- ABT.Tm' (IntroOuter (ABT.Abs' _ subst))
 
 pattern IntroOuterNamed' :: v -> ABT.Term F v a -> ABT.Term F v a
 pattern IntroOuterNamed' v body <- ABT.Tm' (IntroOuter (ABT.out -> ABT.Abs v body))
@@ -181,7 +181,7 @@ pattern Cycle' :: [v] -> f (ABT.Term f v a) -> ABT.Term f v a
 pattern Cycle' xs t <- ABT.Cycle' xs t
 
 pattern Abs' :: (Foldable f, Functor f, ABT.Var v) => ABT.Subst f v a -> ABT.Term f v a
-pattern Abs' subst <- ABT.Abs' subst
+pattern Abs' subst <- ABT.Abs' _ subst
 
 unPure :: (Ord v) => Type v a -> Maybe (Type v a)
 unPure (Effect'' [] t) = Just t

unison-runtime/src/Unison/Runtime/ANF.hs

@@ -377,14 +377,14 @@ beta rec (Apps' l@(LamsNamed' vs body) as)
 beta _ _ = Nothing
 
 isStructured :: (Var v) => Term v a -> Bool
-isStructured (Var' _) = False
-isStructured (Lam' _) = False
-isStructured (Nat' _) = False
-isStructured (Int' _) = False
-isStructured (Float' _) = False
-isStructured (Text' _) = False
-isStructured (Char' _) = False
-isStructured (Constructor' _) = False
+isStructured (Var' {}) = False
+isStructured (Lam' {}) = False
+isStructured (Nat' {}) = False
+isStructured (Int' {}) = False
+isStructured (Float' {}) = False
+isStructured (Text' {}) = False
+isStructured (Char' {}) = False
+isStructured (Constructor' {}) = False
 isStructured (Apps' Constructor' {} args) = any isStructured args
 isStructured (If' b t f) =
   isStructured b || isStructured t || isStructured f