purescript · kritzcreek · Oct 30, 2017 · Oct 27, 2017 · kritzcreek · Oct 27, 2017
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -1,5 +1,6 @@
 module Language.PureScript.Docs.Convert.Single
   ( convertSingleModule
+  , convertComments
   ) where
 
 import Protolude hiding (moduleName)

diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs
@@ -130,7 +130,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl), mns) =
 
     complLocation = _annLocation ann
 
-    complDocumentation = Nothing
+    complDocumentation = _annDocumentation ann
 
     showFixity p a r o =
       let asso = case a of

diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
@@ -44,6 +44,7 @@ import           Control.Lens                       hiding (op, (&))
 import           "monad-logger" Control.Monad.Logger
 import qualified Data.Map.Lazy                      as Map
 import qualified Language.PureScript                as P
+import           Language.PureScript.Docs.Convert.Single (convertComments)
 import           Language.PureScript.Externs
 import           Language.PureScript.Ide.Externs
 import           Language.PureScript.Ide.Reexports
@@ -199,6 +200,7 @@ populateVolatileStateSTM ref = do
         moduleDeclarations
         & map resolveDataConstructorsForModule
         & resolveLocations asts
+        & resolveDocumentation (map fst modules)
         & resolveInstances externs
         & resolveOperators
         & resolveReexports reexportRefs
@@ -221,23 +223,7 @@ resolveLocationsForModule (defs, types) decls =
   map convertDeclaration decls
   where
     convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
-    convertDeclaration (IdeDeclarationAnn ann d) = case d of
-      IdeDeclValue v ->
-        annotateFunction (v ^. ideValueIdent) (IdeDeclValue v)
-      IdeDeclType t ->
-        annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t)
-      IdeDeclTypeSynonym s ->
-        annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s)
-      IdeDeclDataConstructor dtor ->
-        annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor)
-      IdeDeclTypeClass tc ->
-        annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc)
-      IdeDeclValueOperator operator ->
-        annotateValue (operator ^. ideValueOpName . opNameT) (IdeDeclValueOperator operator)
-      IdeDeclTypeOperator operator ->
-        annotateType (operator ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator operator)
-      IdeDeclKind i ->
-        annotateKind (i ^. properNameT) (IdeDeclKind i)
+    convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' annotateFunction annotateValue annotateType annotateKind d
       where
         annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs
                                                     , _annTypeAnnotation = Map.lookup x types
@@ -246,6 +232,71 @@ resolveLocationsForModule (defs, types) decls =
         annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs})
         annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs})
 
+convertDeclaration'
+  :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn)
+  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+  -> IdeDeclaration
+  -> IdeDeclarationAnn
+convertDeclaration' annotateFunction annotateValue annotateType annotateKind d =
+  case d of
+    IdeDeclValue v ->
+      annotateFunction (v ^. ideValueIdent) d
+    IdeDeclType t ->
+      annotateType (t ^. ideTypeName . properNameT) d
+    IdeDeclTypeSynonym s ->
+      annotateType (s ^. ideSynonymName . properNameT) d
+    IdeDeclDataConstructor dtor ->
+      annotateValue (dtor ^. ideDtorName . properNameT) d
+    IdeDeclTypeClass tc ->
+      annotateType (tc ^. ideTCName . properNameT) d
+    IdeDeclValueOperator operator ->
+      annotateValue (operator ^. ideValueOpName . opNameT) d
+    IdeDeclTypeOperator operator ->
+      annotateType (operator ^. ideTypeOpName . opNameT) d
+    IdeDeclKind i ->
+      annotateKind (i ^. properNameT) d
+
+resolveDocumentation
+  :: ModuleMap P.Module
+  -> ModuleMap [IdeDeclarationAnn]
+  -> ModuleMap [IdeDeclarationAnn]
+resolveDocumentation modules =
+  Map.mapWithKey (\mn decls ->
+    maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules))
+
+resolveDocumentationForModule
+  :: P.Module
+    -> [IdeDeclarationAnn]
+    -> [IdeDeclarationAnn]
+resolveDocumentationForModule (P.Module _ _ _ sdecls _) decls = map convertDecl decls
+  where 
+  comments :: Map P.Name [P.Comment]
+  comments = Map.fromListWith (flip (<>)) $ mapMaybe (\d -> 
+    case name d of 
+      Just name' -> Just (name', snd $ P.declSourceAnn d)
+      _ -> Nothing)
+    sdecls 
+
+  name :: P.Declaration -> Maybe P.Name
+  name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d
+  name decl = P.declName decl
+
+  convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn
+  convertDecl (IdeDeclarationAnn ann d) = 
+    convertDeclaration'
+      (annotateValue . P.IdentName)
+      (annotateValue . P.IdentName . P.Ident) 
+      (annotateValue . P.TyName . P.ProperName)
+      (annotateValue . P.KiName . P.ProperName)
+      d
+    where
+      docs :: P.Name -> Text
+      docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments
+
+      annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident })
+
 resolveInstances
   :: ModuleMap P.ExternsFile
   -> ModuleMap [IdeDeclarationAnn]

diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs
@@ -114,13 +114,14 @@ data Annotation
   { _annLocation       :: Maybe P.SourceSpan
   , _annExportedFrom   :: Maybe P.ModuleName
   , _annTypeAnnotation :: Maybe P.Type
+  , _annDocumentation  :: Maybe Text
   } deriving (Show, Eq, Ord, Generic, NFData)
 
 makeLenses ''Annotation
 makeLenses ''IdeDeclarationAnn
 
 emptyAnn :: Annotation
-emptyAnn = Annotation Nothing Nothing Nothing
+emptyAnn = Annotation Nothing Nothing Nothing Nothing
 
 type DefinitionSites a = Map IdeNamespaced a
 type TypeAnnotations = Map P.Ident P.Type

diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs
@@ -5,10 +5,12 @@ module Language.PureScript.Ide.CompletionSpec where
 import Protolude
 
 import Language.PureScript as P
+import Language.PureScript.Ide.Test as Test
+import Language.PureScript.Ide.Command as Command
 import Language.PureScript.Ide.Completion
-import Language.PureScript.Ide.Test
 import Language.PureScript.Ide.Types
 import Test.Hspec
+import System.FilePath
 
 reexportMatches :: [Match IdeDeclarationAnn]
 reexportMatches =
@@ -21,6 +23,15 @@ reexportMatches =
 matches :: [(Match IdeDeclarationAnn, [P.ModuleName])]
 matches = map (\d -> (Match (mn "Main", d), [mn "Main"])) [ ideKind "Kind", ideType "Type" Nothing [] ]
 
+typ :: Text -> Command
+typ txt = Type txt [] Nothing
+
+load :: [Text] -> Command
+load = LoadSync . map Test.mn
+
+rebuildSync :: FilePath -> Command
+rebuildSync fp = RebuildSync ("src" </> fp) Nothing
+
 spec :: Spec
 spec = describe "Applying completion options" $ do
   it "keeps all matches if maxResults is not specified" $ do
@@ -32,3 +43,24 @@ spec = describe "Applying completion options" $ do
   it "groups reexports for a single identifier" $ do
     applyCompletionOptions (defaultCompletionOptions { coGroupReexports = True })
       reexportMatches `shouldBe` [(Match (mn "A", ideKind "Kind"), [mn "A", mn "B"])]
+
+  it "gets simple docs on definition itself" $ do
+    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $
+      Test.runIde [ load ["CompletionSpecDocs"]
+                  , typ "something"
+                  ]
+    result `shouldSatisfy` \res -> complDocumentation res == Just "Doc x\n"
+
+  it "gets multiline docs" $ do
+    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $
+      Test.runIde [ load ["CompletionSpecDocs"]
+                  , typ "multiline"
+                  ]
+    result `shouldSatisfy` \res -> complDocumentation res == Just "This is\na multi-line\ncomment\n"
+
+  it "gets simple docs on type annotation" $ do
+    ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $
+      Test.runIde [ load ["CompletionSpecDocs"]
+                  , typ "withType"
+                  ]
+    result `shouldSatisfy` \res -> complDocumentation res == Just "Doc *123*\n"
diff --git a/tests/support/pscide/src/CompletionSpecDocs.purs b/tests/support/pscide/src/CompletionSpecDocs.purs
@@ -0,0 +1,13 @@
+module CompletionSpecDocs where
+
+-- | Doc x
+something = "something"
+
+-- | Doc *123*
+withType :: Int
+withType = 42
+
+-- | This is
+-- | a multi-line
+-- | comment
+multiline = "multiline"