Add type/doc capture

tools/lsp/squirrel/src/AST/Completion.hs

@@ -1,10 +1,11 @@
 
 module AST.Completion where
 
+import Data.Function (on)
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Data.Maybe (listToMaybe)
-import Data.List (isSubsequenceOf, nub)
+import Data.List (isSubsequenceOf, nubBy)
 
 import Duplo.Tree
 import Duplo.Lattice
@@ -16,8 +17,14 @@ import AST.Scope
 import Range
 import Product
 
--- import Debug.Trace
+import Debug.Trace
 
+data Completion = Completion
+  { cName :: Text
+  , cType :: Text
+  , cDoc  :: Text
+  }
+  deriving (Show)
 
 complete
   :: ( Eq (Product xs)
@@ -28,21 +35,30 @@ complete
      )
   => Range
   -> LIGO (Product xs)
-  -> Maybe [Text]
+  -> Maybe [Completion]
 complete r tree = do
   let l = spineTo (leq r . getElem) tree
   word <- listToMaybe l
   let scope   = getElem (extract word)
   let nameCat = getElem (extract word)
   return
-    $ filter (isSubseqOf (ppToText word))
+    $ filter (isSubseqOf (ppToText word) . cName)
-    $ nub
+    $ nubBy ((==) `on` cName)
-    $ map (ppToText . _sdName)
+    $ map asCompletion
     $ filter (fits nameCat . catFromType)
     $ scope
 
+asCompletion :: ScopedDecl -> Completion
+asCompletion sd = Completion
+  { cName = ppToText (_sdName sd)
+  , cType = ppToText (_sdType sd)
+  , cDoc  = ppToText (fsep $ map pp $ _sdDoc sd)
+  }
+
 isSubseqOf :: Text -> Text -> Bool
-isSubseqOf l r = isSubsequenceOf (Text.unpack l) (Text.unpack r)
+isSubseqOf l r =
+  -- traceShow (l, r, isSubsequenceOf (Text.unpack l) (Text.unpack r)) $
+  isSubsequenceOf (Text.unpack l) (Text.unpack r)
 
 fits :: Maybe Category -> Category -> Bool
 fits  Nothing _  = True

tools/lsp/squirrel/src/AST/Scope.hs

@@ -52,6 +52,7 @@ data ScopedDecl = ScopedDecl
   , _sdBody    :: Maybe Range
   , _sdType    :: Maybe (Either (LIGO ()) Kind)
   , _sdRefs    :: [Range]
+  , _sdDoc     :: [Text]
   }
   deriving Show via PP ScopedDecl
 
@@ -74,7 +75,7 @@ instance {-# OVERLAPS #-} Pretty FullEnv where
       mergeFE fe = getTag @"vars" @Env fe Prelude.<> getTag @"types" fe
 
 instance Pretty ScopedDecl where
-  pp (ScopedDecl n o _ t refs) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs
+  pp (ScopedDecl n o _ t refs doc) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs `indent` pp doc
 
 instance Pretty Kind where
   pp _ = "TYPE"
@@ -106,7 +107,7 @@ type Info' = Product [[ScopedDecl], Maybe Category, [Text], Range, ShowRange]
 
 addLocalScopes
   :: forall xs
-  .  (Contains Range xs, Eq (Product xs))
+  .  (Collectable xs, Eq (Product xs))
   => LIGO (Product xs)
   -> LIGO (Product ([ScopedDecl] : Maybe Category : xs))
 addLocalScopes tree =
@@ -246,7 +247,7 @@ updateOnly name r f = go
 
       [] -> (False, [])
 
-enter :: Contains Range xs => Product xs -> CollectM ()
+enter :: Collectable xs => Product xs -> CollectM ()
 enter r = do
   modify $ modElem (getElem @Range r :)
 
@@ -290,8 +291,8 @@ lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl
 lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName)
 
 -- | Add a type declaration to the current scope.
-defType :: HasRange a => LIGO a -> Kind -> LIGO a -> CollectM ()
+defType :: HasRange a => LIGO a -> Kind -> LIGO a -> [Text] -> CollectM ()
-defType name kind body = do
+defType name kind body doc = do
   define Type
     $ ScopedDecl
       (void name)
@@ -299,6 +300,7 @@ defType name kind body = do
       (Just $ getRange $ extract body)
       (Just (Right kind))
       []
+      doc
 
 -- -- observe :: Pretty i => Pretty res => Text -> i -> res -> res
 -- -- observe msg i res
@@ -312,8 +314,9 @@ def
   => LIGO a
   -> Maybe (LIGO a)
   -> Maybe (LIGO a)
+  -> [Text]
   -> CollectM ()
-def name ty body = do
+def name ty body doc = do
   define Variable
     $ ScopedDecl
       (void name)
@@ -321,55 +324,60 @@ def name ty body = do
       ((getRange . extract) <$> body)
       ((Left . void) <$> ty)
       []
+      doc
 
-instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Contract where
+type Collectable xs = (Contains Range xs, Contains [Text] xs)
+
+instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Contract where
   before r _ = enter r
   after  _ _ = skip
 
-instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) RawContract where
+instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) RawContract where
   before r _ = enter r
   after  _ _ = skip
 
-instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Binding where
+instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Binding where
   before r = \case
     Function recur name _args ty body -> do
       when recur do
-        def name (Just ty) (Just body)
+        def name (Just ty) (Just body) (getElem r)
       enter r
 
-    TypeDecl ty body -> defType ty Star body
+    TypeDecl ty body -> defType ty Star body (getElem r)
     _ -> enter r
 
-  after _ = \case
+  after r = \case
-    Irrefutable name    body -> do leave; def name  Nothing  (Just body)
+    Irrefutable name    body -> do leave; def name  Nothing  (Just body) (getElem r)
-    Var         name ty body -> do leave; def name (Just ty) (Just body)
+    Var         name ty body -> do leave; def name (Just ty) (Just body) (getElem r)
-    Const       name ty body -> do leave; def name (Just ty) (Just body)
+    Const       name ty body -> do leave; def name (Just ty) (Just body) (getElem r)
+
     Function recur name _args ty body -> do
       leave
       unless recur do
-        def name (Just ty) (Just body)
+        def name (Just ty) (Just body) (getElem r)
+
     _ -> skip
 
-instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) VarDecl where
+instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) VarDecl where
-  after _ (Decl _ name ty) = def name (Just ty) Nothing
+  after r (Decl _ name ty) = def name (Just ty) Nothing (getElem r)
 
 instance Scoped a CollectM (LIGO a) Mutable
 instance Scoped a CollectM (LIGO a) Type
 instance Scoped a CollectM (LIGO a) Variant
 instance Scoped a CollectM (LIGO a) TField
 
-instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Expr where
+instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Expr where
   before r = \case
     Let    {} -> enter r
     Lambda {} -> enter r
     ForLoop k _ _ _ _ -> do
       enter r
-      def k Nothing Nothing
+      def k Nothing Nothing (getElem r)
 
     ForBox k mv _ _ _ -> do
       enter r
-      def k Nothing Nothing
+      def k Nothing Nothing (getElem r)
-      maybe skip (\v -> def v Nothing Nothing) mv
+      maybe skip (\v -> def v Nothing Nothing (getElem r)) mv
 
     _ -> skip
 
@@ -380,7 +388,7 @@ instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) E
     ForBox  {} -> leave
     _ -> skip
 
-instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Alt where
+instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Alt where
   before r _ = enter r
   after  _ _ = leave
 
@@ -390,9 +398,9 @@ instance Scoped a CollectM (LIGO a) Assignment
 instance Scoped a CollectM (LIGO a) FieldAssignment
 instance Scoped a CollectM (LIGO a) Constant
 
-instance Contains Range xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Pattern where
+instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Pattern where
-  before _ = \case
+  before r = \case
-    IsVar n -> def n Nothing Nothing
+    IsVar n -> def n Nothing Nothing (getElem r)
     _       -> skip
 
 instance Scoped a CollectM (LIGO a) QualifiedName