From 98431489cb1ac184421d3c40b02fb22018a80b28 Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Mon, 20 Dec 2021 23:42:14 -0500 Subject: [PATCH 1/2] Use `extQ` to choose parser. - In the process of development, it was forgotten that the "parent" type of patterns and exprs is different. When traversal occurs, SYB would throw out `Pat` types as it was only expecting `HsExpr` types. - Using `extQ` allows us to chain the expected types and we can then destructure patterns appropriately. --- .../src/Ide/Plugin/Literals.hs | 120 +++++++----------- 1 file changed, 44 insertions(+), 76 deletions(-) diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs index cf462c08c3..61a8367e1b 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} module Ide.Plugin.Literals ( collectLiterals , Literal(..) @@ -9,24 +9,23 @@ module Ide.Plugin.Literals ( , getSrcSpan ) where -import Data.Set (Set) -import qualified Data.Set as S +import Data.Maybe (maybeToList) import Data.Text (Text) import qualified Data.Text as T import Development.IDE.GHC.Compat hiding (getSrcSpan) import Development.IDE.GHC.Util (unsafePrintSDoc) import Development.IDE.Graph.Classes (NFData (rnf)) import qualified GHC.Generics as GHC -import Generics.SYB (Data, Typeable, cast, - everything) +import Generics.SYB (Data, Typeable, everything, + extQ) -- data type to capture what type of literal we are dealing with -- provides location and possibly source text (for OverLits) as well as it's value -- we currently don't have any use for PrimLiterals. They never have source text so we always drop them -- | Captures a Numeric Literals Location, Source Text, and Value. -data Literal = IntLiteral RealSrcSpan Text Integer - | FracLiteral RealSrcSpan Text Rational - deriving (GHC.Generic, Show, Ord, Eq) +data Literal = IntLiteral RealSrcSpan Text Integer + | FracLiteral RealSrcSpan Text Rational + deriving (GHC.Generic, Show, Ord, Eq, Data) instance NFData RealSrcSpan where rnf x = x `seq` () @@ -47,71 +46,40 @@ getSrcSpan = \case -- | Find all literals in a Parsed Source File collectLiterals :: (Data ast, Typeable ast) => ast -> [Literal] -collectLiterals = S.toList . collectLiterals' - -collectLiterals' :: (Data ast, Typeable ast) => ast -> Set Literal -collectLiterals' = everything (<>) (mkQ2 (S.empty :: Set Literal) traverseLExpr traverseLPat) - --- Located Patterns for whatever reason don't get picked up when using `(mkQ (S.empty :: Set Literal) traverseLExpr) --- as such we need to explicit traverse those in order to pull out any literals -mkQ2 :: (Typeable a, Typeable b, Typeable c) => r -> (b -> r) -> (c -> r) -> a -> r -mkQ2 def left right datum = case cast datum of - Just datum' -> left datum' - Nothing -> maybe def right (cast datum) - -traverseLPat :: GenLocated SrcSpan (Pat GhcPs) -> Set Literal -traverseLPat (L sSpan pat) = traversePat sSpan pat - -traversePat :: SrcSpan -> Pat GhcPs -> Set Literal -traversePat sSpan = \case - LitPat _ lit -> getLiteralAsList sSpan lit - NPat _ (L olSpan overLit) sexpr1 sexpr2 -> getOverLiteralAsList olSpan overLit - <> collectLiterals' sexpr1 - <> collectLiterals' sexpr2 - NPlusKPat _ _ (L olSpan loverLit) overLit sexpr1 sexpr2 -> getOverLiteralAsList olSpan loverLit - <> getOverLiteralAsList sSpan overLit - <> collectLiterals' sexpr1 - <> collectLiterals' sexpr2 - ast -> collectLiterals' ast - -traverseLExpr :: GenLocated SrcSpan (HsExpr GhcPs) -> Set Literal -traverseLExpr (L sSpan hsExpr) = traverseExpr sSpan hsExpr - -traverseExpr :: SrcSpan -> HsExpr GhcPs -> Set Literal -traverseExpr sSpan = \case - HsOverLit _ overLit -> getOverLiteralAsList sSpan overLit - HsLit _ lit -> getLiteralAsList sSpan lit - expr -> collectLiterals' expr - -getLiteralAsList :: SrcSpan -> HsLit GhcPs -> Set Literal -getLiteralAsList sSpan lit = case sSpan of - RealSrcSpan rss _ -> getLiteralAsList' lit rss - _ -> S.empty - -getLiteralAsList' :: HsLit GhcPs -> RealSrcSpan -> Set Literal -getLiteralAsList' lit = maybe S.empty S.singleton . flip getLiteral lit - --- Translate from Hs Type to our Literal type -getLiteral :: RealSrcSpan -> HsLit GhcPs -> Maybe Literal -getLiteral sSpan = \case - HsInt _ val -> fromIntegralLit sSpan val - HsRat _ val _ -> fromFractionalLit sSpan val - _ -> Nothing - -getOverLiteralAsList :: SrcSpan -> HsOverLit GhcPs -> Set Literal -getOverLiteralAsList sSpan lit = case sSpan of - RealSrcSpan rss _ -> getOverLiteralAsList' lit rss - _ -> S.empty - -getOverLiteralAsList' :: HsOverLit GhcPs -> RealSrcSpan -> Set Literal -getOverLiteralAsList' lit sSpan = maybe S.empty S.singleton (getOverLiteral sSpan lit) - -getOverLiteral :: RealSrcSpan -> HsOverLit GhcPs -> Maybe Literal -getOverLiteral sSpan OverLit{..} = case ol_val of - HsIntegral il -> fromIntegralLit sSpan il - HsFractional fl -> fromFractionalLit sSpan fl - _ -> Nothing -getOverLiteral _ _ = Nothing +collectLiterals = everything (<>) (maybeToList . (const Nothing `extQ` getLiteral `extQ` getPattern)) + +-- | Translate from HsLit and HsOverLit Types to our Literal Type +getLiteral :: GenLocated SrcSpan (HsExpr GhcPs) -> Maybe Literal +getLiteral (L (UnhelpfulSpan _) _) = Nothing +getLiteral (L (RealSrcSpan sSpan _ ) expr) = case expr of + HsLit _ lit -> fromLit lit sSpan + HsOverLit _ overLit -> fromOverLit overLit sSpan + _ -> Nothing + +-- | Destructure Patterns to unwrap any Literals +getPattern :: GenLocated SrcSpan (Pat GhcPs) -> Maybe Literal +getPattern (L (UnhelpfulSpan _) _) = Nothing +getPattern (L (RealSrcSpan patSpan _) pat) = case pat of + LitPat _ lit -> case lit of + HsInt _ val -> fromIntegralLit patSpan val + HsRat _ val _ -> fromFractionalLit patSpan val + _ -> Nothing + NPat _ (L (RealSrcSpan sSpan _) overLit) _ _ -> fromOverLit overLit sSpan + NPlusKPat _ _ (L (RealSrcSpan sSpan _) overLit1) _ _ _ -> fromOverLit overLit1 sSpan + _ -> Nothing + +fromLit :: HsLit p -> RealSrcSpan -> Maybe Literal +fromLit lit sSpan = case lit of + HsInt _ val -> fromIntegralLit sSpan val + HsRat _ val _ -> fromFractionalLit sSpan val + _ -> Nothing + +fromOverLit :: HsOverLit p -> RealSrcSpan -> Maybe Literal +fromOverLit OverLit{..} sSpan = case ol_val of + HsIntegral il -> fromIntegralLit sSpan il + HsFractional fl -> fromFractionalLit sSpan fl + _ -> Nothing +fromOverLit _ _ = Nothing fromIntegralLit :: RealSrcSpan -> IntegralLit -> Maybe Literal fromIntegralLit s (IL txt _ val) = fmap (\txt' -> IntLiteral s txt' val) (fromSourceText txt) From b06803118baa1eb4bee52ff57eedf4d36126a927 Mon Sep 17 00:00:00 2001 From: Nick Suchecki Date: Tue, 21 Dec 2021 21:45:04 -0500 Subject: [PATCH 2/2] Revert "Disable alternate numbers format plugin temporary (#2498)" This reverts commit 15d740269648c7ed119b147a6e7a7e12aa05f75a. --- .github/workflows/test.yml | 2 +- docs/features.md | 2 +- haskell-language-server.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index c9aea01024..38105a439e 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -244,7 +244,7 @@ jobs: name: Test hls-hlint-plugin test suite run: cabal test hls-hlint-plugin --test-options="$TEST_OPTS" || cabal test hls-hlint-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-hlint-plugin --test-options="$TEST_OPTS" - - if: matrix.test && false + - if: matrix.test name: Test hls-alternate-number-format-plugin test suite run: cabal test hls-alternate-number-format-plugin --test-options="$TEST_OPTS" || cabal test hls-alternate-number-format-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-alternate-number-format-plugin --test-options="$TEST_OPTS" diff --git a/docs/features.md b/docs/features.md index 5ee46320d9..37c203360b 100644 --- a/docs/features.md +++ b/docs/features.md @@ -17,7 +17,7 @@ You can watch demos for some of these features [below](#demos). - [Module name suggestions](#module-names) for insertion or correction - [Call hierarchy support](#call-hierarchy) - [Qualify names from an import declaration](#qualify-imported-names) in your code -- [Suggest alternate numeric formats](#alternate-number-formatting). This plugin is not included by default yet due to a performance issue, see +- [Suggest alternate numeric formats](#alternate-number-formatting) ## Demos diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index a57e526c9d..f0c1807906 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -165,7 +165,7 @@ flag splice flag alternateNumberFormat description: Enable Alternate Number Format plugin - default: False + default: True manual: True flag qualifyImportedNames