From 188ff6ba8a2504e85969f2adeff6eaf497c58cff Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?=
 <44544735+xsebek@users.noreply.github.com>
Date: Sat, 12 Oct 2024 20:02:16 +0200
Subject: [PATCH] Fix TyDef narrowToPosition (#2170)

`STyDef` is not actually an atom and we need to recurse further.

| Recursing | TyDef |
|--------|--------|
| <img width="340" alt="false" src="https://github.com/user-attachments/assets/e42b5773-0c38-46bd-bb85-c0233bdbc290"> | <img width="340" alt="tydef" src="https://github.com/user-attachments/assets/84d88edd-50eb-40e2-bfb1-207167ad62e5"> |


Closes #2169.
---
 src/swarm-lang/Swarm/Language/LSP/Hover.hs | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/src/swarm-lang/Swarm/Language/LSP/Hover.hs b/src/swarm-lang/Swarm/Language/LSP/Hover.hs
index 54139d39a..6a62b9bee 100644
--- a/src/swarm-lang/Swarm/Language/LSP/Hover.hs
+++ b/src/swarm-lang/Swarm/Language/LSP/Hover.hs
@@ -113,6 +113,7 @@ narrowToPosition s0@(Syntax' _ t _ ty) pos = fromMaybe s0 $ case t of
   SApp s1 s2 -> d s1 <|> d s2
   SLet _ _ lv _ _ s1@(Syntax' _ _ _ lty) s2 -> d (locVarToSyntax' lv lty) <|> d s1 <|> d s2
   SBind mlv _ _ _ s1@(Syntax' _ _ _ lty) s2 -> (mlv >>= d . flip locVarToSyntax' (getInnerType lty)) <|> d s1 <|> d s2
+  STydef typ typBody _ti s1 -> d s1 <|> Just (locVarToSyntax' typ $ fromPoly typBody)
   SPair s1 s2 -> d s1 <|> d s2
   SDelay s -> d s
   SRcd m -> asum . map d . catMaybes . M.elems $ m
@@ -129,7 +130,6 @@ narrowToPosition s0@(Syntax' _ t _ ty) pos = fromMaybe s0 $ case t of
   TVar {} -> Nothing
   TRequire {} -> Nothing
   TRequireDevice {} -> Nothing
-  STydef {} -> Nothing
   -- these should not show up in surface language
   TRef {} -> Nothing
   TRobot {} -> Nothing
@@ -151,6 +151,8 @@ treeToMarkdown d (Node t children) =
   T.unlines $ renderDoc d t : map (treeToMarkdown $ d + 1) children
 
 class Show t => ExplainableType t where
+  fromPoly :: Polytype -> t
+
   -- | Pretty print the type.
   prettyType :: t -> Text
 
@@ -166,11 +168,13 @@ class Show t => ExplainableType t where
   eq :: t -> Polytype -> Bool
 
 instance ExplainableType () where
+  fromPoly = const ()
   prettyType = const "?"
   getInnerType = id
   eq _ _ = False
 
 instance ExplainableType Polytype where
+  fromPoly = id
   prettyType = prettyTextLine
   getInnerType = fmap $ \case
     (l :->: _r) -> l