diff --git a/hls-haddock-comments-plugin.cabal b/hls-haddock-comments-plugin.cabal --- a/hls-haddock-comments-plugin.cabal +++ b/hls-haddock-comments-plugin.cabal @@ -1,33 +1,55 @@ -cabal-version: 2.2 -name: hls-haddock-comments-plugin -version: 1.0.0.0 -synopsis: Haddock comments plugin for Haskell Language Server +cabal-version: 2.4 +name: hls-haddock-comments-plugin +version: 1.0.0.1 +synopsis: Haddock comments plugin for Haskell Language Server description: Please see the README on GitHub at -license: Apache-2.0 -license-file: LICENSE -author: Potato Hatsue -maintainer: berberman@yandex.com -category: Development -build-type: Simple -homepage: https://github.com/haskell/haskell-language-server -bug-reports: https://github.com/haskell/haskell-language-server/issues +license: Apache-2.0 +license-file: LICENSE +author: Potato Hatsue +maintainer: berberman@yandex.com +category: Development +build-type: Simple +homepage: https://github.com/haskell/haskell-language-server +bug-reports: https://github.com/haskell/haskell-language-server/issues +extra-source-files: + LICENSE + test/testdata/*.hs library - exposed-modules: Ide.Plugin.HaddockComments - hs-source-dirs: src - ghc-options: -Wall -Wno-name-shadowing -Wredundant-constraints -Wno-unticked-promoted-constructors + exposed-modules: Ide.Plugin.HaddockComments + hs-source-dirs: src + ghc-options: + -Wall -Wno-name-shadowing -Wredundant-constraints + -Wno-unticked-promoted-constructors + build-depends: - , base >=4.12 && <5 + , base >=4.12 && <5 , containers , ghc , ghc-exactprint - , ghcide ^>= 1.0.0.0 + , ghcide ^>=1.2 + , hls-plugin-api ^>=1.1 , lsp-types - , hls-plugin-api ^>= 1.0.0.0 , text , unordered-containers + default-language: Haskell2010 + default-extensions: + DataKinds + TypeOperators + +test-suite tests + type: exitcode-stdio-1.0 default-language: Haskell2010 - default-extensions: DataKinds, TypeOperators + hs-source-dirs: test + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , base + , bytestring + , filepath + , hls-haddock-comments-plugin + , hls-test-utils ^>= 1.0 + , text diff --git a/src/Ide/Plugin/HaddockComments.hs b/src/Ide/Plugin/HaddockComments.hs --- a/src/Ide/Plugin/HaddockComments.hs +++ b/src/Ide/Plugin/HaddockComments.hs @@ -1,25 +1,26 @@ {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.HaddockComments (descriptor) where -import Control.Monad (join) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map as Map -import qualified Data.Text as T -import Development.IDE hiding (pluginHandlers) -import Development.IDE.GHC.Compat -import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (..), annsA, astA) -import Ide.Types -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) -import Language.Haskell.GHC.ExactPrint.Utils -import Language.LSP.Types -import Control.Monad.IO.Class +import Control.Monad (join) +import Control.Monad.IO.Class +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map as Map +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (..), + annsA, astA) +import Ide.Types +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) +import Language.Haskell.GHC.ExactPrint.Utils +import Language.LSP.Types ----------------------------------------------------------------------------- descriptor :: PluginId -> PluginDescriptor IdeState @@ -50,11 +51,11 @@ -- | Defines how to generate haddock comments by tweaking annotations of AST data GenComments = forall a. GenComments - { title :: T.Text, - fromDecl :: HsDecl GhcPs -> Maybe a, - collectKeys :: a -> [AnnKey], - isFresh :: Annotation -> Bool, - updateAnn :: Annotation -> Annotation, + { title :: T.Text, + fromDecl :: HsDecl GhcPs -> Maybe a, + collectKeys :: a -> [AnnKey], + isFresh :: Annotation -> Bool, + updateAnn :: Annotation -> Annotation, updateDeclAnn :: Annotation -> Annotation } @@ -81,7 +82,7 @@ title = "Generate signature comments" fromDecl (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ x)))) = Just x - fromDecl _ = Nothing + fromDecl _ = Nothing updateAnn x = x {annEntryDelta = DP (0, 1), annsDP = dp} updateDeclAnn = cleanPriorComments @@ -124,6 +125,9 @@ _edit = Just WorkspaceEdit {..} _isPreferred = Nothing _disabled = Nothing + _xdata = Nothing + _changeAnnotations = Nothing + toRange :: SrcSpan -> Maybe Range toRange src diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Main + ( main, + ) +where + +import qualified Data.ByteString.Lazy as LBS +import Data.Foldable (find) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import qualified Ide.Plugin.HaddockComments as HaddockComments +import System.FilePath ((<.>), ()) +import Test.Hls + +main :: IO () +main = defaultTestRunner tests + +plugin :: PluginDescriptor IdeState +plugin = HaddockComments.descriptor "haddockComments" + +tests :: TestTree +tests = + testGroup + "haddock comments" + [ goldenTest "HigherRankFunction" Signature 4 6, + goldenTest "KindSigFunction" Signature 9 10, + goldenTest "MultivariateFunction" Signature 4 8, + goldenTest "QualFunction" Signature 2 10, + goldenTest "Record" Record 7 2, + expectedNothing "ConstFunction" Signature 2 2, + expectedNothing "StaleFunction" Signature 3 3, + expectedNothing "StaleRecord" Record 3 12 + ] + +goldenTest :: FilePath -> GenCommentsType -> Int -> Int -> TestTree +goldenTest fp (toTitle -> expectedTitle) l c = goldenGitDiff (fp <> " (golden)") goldenFilePath $ + runSessionWithServer plugin haddockCommentsPath $ do + doc <- openDoc hsFilePath "haskell" + actions <- getCodeActions doc (Range (Position l c) (Position l $ succ c)) + case find ((== Just expectedTitle) . caTitle) actions of + Just (InR x) -> do + executeCodeAction x + LBS.fromStrict . encodeUtf8 <$> documentContents doc + _ -> liftIO $ assertFailure "Unable to find CodeAction" + where + hsFilePath = fp <.> "hs" + goldenFilePath = haddockCommentsPath fp <.> "expected" <.> "hs" + +expectedNothing :: FilePath -> GenCommentsType -> Int -> Int -> TestTree +expectedNothing fp (toTitle -> expectedTitle) l c = testCase fp $ + runSessionWithServer plugin haddockCommentsPath $ do + doc <- openDoc (fp <.> "hs") "haskell" + titles <- mapMaybe caTitle <$> getCodeActions doc (Range (Position l c) (Position l $ succ c)) + liftIO $ expectedTitle `notElem` titles @? "Unexpected CodeAction" + +data GenCommentsType = Signature | Record + +toTitle :: GenCommentsType -> Text +toTitle Signature = "Generate signature comments" +toTitle Record = "Generate fields comments" + +caTitle :: (Command |? CodeAction) -> Maybe Text +caTitle (InR CodeAction {_title}) = Just _title +caTitle _ = Nothing + +haddockCommentsPath :: String +haddockCommentsPath = "test" "testdata" + diff --git a/test/testdata/ConstFunction.hs b/test/testdata/ConstFunction.hs new file mode 100644 --- /dev/null +++ b/test/testdata/ConstFunction.hs @@ -0,0 +1,4 @@ +module ConstFunction where + +f :: Int +f = 233 diff --git a/test/testdata/HigherRankFunction.expected.hs b/test/testdata/HigherRankFunction.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/HigherRankFunction.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RankNTypes #-} + +module HigherRankFunction where + +f :: (forall a. [a] -> Int) -- ^ + -> [b] -- ^ + -> [c] -- ^ + -> (Int, Int) +f l xs ys = (l xs, l ys) diff --git a/test/testdata/HigherRankFunction.hs b/test/testdata/HigherRankFunction.hs new file mode 100644 --- /dev/null +++ b/test/testdata/HigherRankFunction.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RankNTypes #-} + +module HigherRankFunction where + +f :: (forall a. [a] -> Int) -> [b] -> [c] -> (Int, Int) +f l xs ys = (l xs, l ys) diff --git a/test/testdata/KindSigFunction.expected.hs b/test/testdata/KindSigFunction.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/KindSigFunction.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +module KindSigFunction where + +import GHC.TypeLits + +f :: KnownSymbol k => (proxy :: k -> *) k -- ^ + -> String +f = symbolVal diff --git a/test/testdata/KindSigFunction.hs b/test/testdata/KindSigFunction.hs new file mode 100644 --- /dev/null +++ b/test/testdata/KindSigFunction.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} + +module KindSigFunction where + +import GHC.TypeLits + +f :: KnownSymbol k => (proxy :: k -> *) k -> String +f = symbolVal diff --git a/test/testdata/MultivariateFunction.expected.hs b/test/testdata/MultivariateFunction.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/MultivariateFunction.expected.hs @@ -0,0 +1,13 @@ +module MultivariateFunction where + +-- | some +-- docs +f :: a -- ^ + -> b -- ^ + -> c -- ^ + -> d -- ^ + -> e -- ^ + -> f -- ^ + -> g -- ^ + -> g +f _ _ _ _ _ _ x = x diff --git a/test/testdata/MultivariateFunction.hs b/test/testdata/MultivariateFunction.hs new file mode 100644 --- /dev/null +++ b/test/testdata/MultivariateFunction.hs @@ -0,0 +1,6 @@ +module MultivariateFunction where + +-- | some +-- docs +f :: a -> b -> c -> d -> e -> f -> g -> g +f _ _ _ _ _ _ x = x diff --git a/test/testdata/QualFunction.expected.hs b/test/testdata/QualFunction.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/QualFunction.expected.hs @@ -0,0 +1,6 @@ +module QualFunction where + +f :: (Show a, Show b) => a -- ^ + -> b -- ^ + -> String +f x y = show x <> show y diff --git a/test/testdata/QualFunction.hs b/test/testdata/QualFunction.hs new file mode 100644 --- /dev/null +++ b/test/testdata/QualFunction.hs @@ -0,0 +1,4 @@ +module QualFunction where + +f :: (Show a, Show b) => a -> b -> String +f x y = show x <> show y diff --git a/test/testdata/Record.expected.hs b/test/testdata/Record.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Record.expected.hs @@ -0,0 +1,20 @@ +module Record where + +-- | A record +data Record a b c d e f + = RecordA + { + -- | + a :: a, + -- | + b :: b + } + | Pair c d + | RecordB + { + -- | + c :: e, + -- | + d :: f + } + | Void diff --git a/test/testdata/Record.hs b/test/testdata/Record.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Record.hs @@ -0,0 +1,14 @@ +module Record where + +-- | A record +data Record a b c d e f + = RecordA + { a :: a, + b :: b + } + | Pair c d + | RecordB + { c :: e, + d :: f + } + | Void diff --git a/test/testdata/StaleFunction.hs b/test/testdata/StaleFunction.hs new file mode 100644 --- /dev/null +++ b/test/testdata/StaleFunction.hs @@ -0,0 +1,6 @@ +module StaleFunction where + +f :: a + -> b -- ^ ... + -> c -> c +f _ _ c = c diff --git a/test/testdata/StaleRecord.hs b/test/testdata/StaleRecord.hs new file mode 100644 --- /dev/null +++ b/test/testdata/StaleRecord.hs @@ -0,0 +1,6 @@ +module StaleRecord where + +data Record = Record + { a :: Int, -- ^ ... + b :: String + }