Skip to content

Commit 3061ace

Browse files
drsoochdrsooch
authored
Refactor collectLiterals in AlternateNumberFormat. (haskell#2516)
* 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. * Revert "Disable alternate numbers format plugin temporary (haskell#2498)" This reverts commit 15d7402.
1 parent 3c2364b commit 3061ace

File tree

4 files changed

+47
-79
lines changed

4 files changed

+47
-79
lines changed

‎.github/workflows/test.yml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -244,7 +244,7 @@ jobs:
244244
name: Test hls-hlint-plugin test suite
245245
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"
246246

247-
- if: matrix.test && false
247+
- if: matrix.test
248248
name: Test hls-alternate-number-format-plugin test suite
249249
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"
250250

‎docs/features.md‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ You can watch demos for some of these features [below](#demos).
1717
- [Module name suggestions](#module-names) for insertion or correction
1818
- [Call hierarchy support](#call-hierarchy)
1919
- [Qualify names from an import declaration](#qualify-imported-names) in your code
20-
- [Suggest alternate numeric formats](#alternate-number-formatting). This plugin is not included by default yet due to a performance issue, see <https://github.com/haskell/haskell-language-server/issues/2490>
20+
- [Suggest alternate numeric formats](#alternate-number-formatting)
2121

2222
## Demos
2323

‎haskell-language-server.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -165,7 +165,7 @@ flag splice
165165

166166
flag alternateNumberFormat
167167
description: Enable Alternate Number Format plugin
168-
default: False
168+
default: True
169169
manual: True
170170

171171
flag qualifyImportedNames

‎plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs‎

Lines changed: 44 additions & 76 deletions
Original file line numberDiff line numberDiff line change
@@ -1,32 +1,31 @@
1-
{-# LANGUAGE DeriveGeneric #-}
2-
{-# LANGUAGE DerivingVia #-}
3-
{-# LANGUAGE FlexibleInstances #-}
4-
{-# LANGUAGE RankNTypes #-}
1+
{-# LANGUAGE DeriveDataTypeable #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE RankNTypes #-}
55
module Ide.Plugin.Literals (
66
collectLiterals
77
, Literal(..)
88
, getSrcText
99
, getSrcSpan
1010
) where
1111

12-
import Data.Set (Set)
13-
import qualified Data.Set as S
12+
import Data.Maybe (maybeToList)
1413
import Data.Text (Text)
1514
import qualified Data.Text as T
1615
import Development.IDE.GHC.Compat hiding (getSrcSpan)
1716
import Development.IDE.GHC.Util (unsafePrintSDoc)
1817
import Development.IDE.Graph.Classes (NFData (rnf))
1918
import qualified GHC.Generics as GHC
20-
import Generics.SYB (Data, Typeable, cast,
21-
everything)
19+
import Generics.SYB (Data, Typeable, everything,
20+
extQ)
2221

2322
-- data type to capture what type of literal we are dealing with
2423
-- provides location and possibly source text (for OverLits) as well as it's value
2524
-- we currently don't have any use for PrimLiterals. They never have source text so we always drop them
2625
-- | Captures a Numeric Literals Location, Source Text, and Value.
27-
data Literal = IntLiteral RealSrcSpan Text Integer
28-
| FracLiteral RealSrcSpan Text Rational
29-
deriving (GHC.Generic, Show, Ord, Eq)
26+
data Literal = IntLiteral RealSrcSpan Text Integer
27+
| FracLiteral RealSrcSpan Text Rational
28+
deriving (GHC.Generic, Show, Ord, Eq, Data)
3029

3130
instance NFData RealSrcSpan where
3231
rnf x = x `seq` ()
@@ -47,71 +46,40 @@ getSrcSpan = \case
4746

4847
-- | Find all literals in a Parsed Source File
4948
collectLiterals :: (Data ast, Typeable ast) => ast -> [Literal]
50-
collectLiterals = S.toList . collectLiterals'
51-
52-
collectLiterals' :: (Data ast, Typeable ast) => ast -> Set Literal
53-
collectLiterals' = everything (<>) (mkQ2 (S.empty :: Set Literal) traverseLExpr traverseLPat)
54-
55-
-- Located Patterns for whatever reason don't get picked up when using `(mkQ (S.empty :: Set Literal) traverseLExpr)
56-
-- as such we need to explicit traverse those in order to pull out any literals
57-
mkQ2 :: (Typeable a, Typeable b, Typeable c) => r -> (b -> r) -> (c -> r) -> a -> r
58-
mkQ2 def left right datum = case cast datum of
59-
Just datum' -> left datum'
60-
Nothing -> maybe def right (cast datum)
61-
62-
traverseLPat :: GenLocated SrcSpan (Pat GhcPs) -> Set Literal
63-
traverseLPat (L sSpan pat) = traversePat sSpan pat
64-
65-
traversePat :: SrcSpan -> Pat GhcPs -> Set Literal
66-
traversePat sSpan = \case
67-
LitPat _ lit -> getLiteralAsList sSpan lit
68-
NPat _ (L olSpan overLit) sexpr1 sexpr2 -> getOverLiteralAsList olSpan overLit
69-
<> collectLiterals' sexpr1
70-
<> collectLiterals' sexpr2
71-
NPlusKPat _ _ (L olSpan loverLit) overLit sexpr1 sexpr2 -> getOverLiteralAsList olSpan loverLit
72-
<> getOverLiteralAsList sSpan overLit
73-
<> collectLiterals' sexpr1
74-
<> collectLiterals' sexpr2
75-
ast -> collectLiterals' ast
76-
77-
traverseLExpr :: GenLocated SrcSpan (HsExpr GhcPs) -> Set Literal
78-
traverseLExpr (L sSpan hsExpr) = traverseExpr sSpan hsExpr
79-
80-
traverseExpr :: SrcSpan -> HsExpr GhcPs -> Set Literal
81-
traverseExpr sSpan = \case
82-
HsOverLit _ overLit -> getOverLiteralAsList sSpan overLit
83-
HsLit _ lit -> getLiteralAsList sSpan lit
84-
expr -> collectLiterals' expr
85-
86-
getLiteralAsList :: SrcSpan -> HsLit GhcPs -> Set Literal
87-
getLiteralAsList sSpan lit = case sSpan of
88-
RealSrcSpan rss _ -> getLiteralAsList' lit rss
89-
_ -> S.empty
90-
91-
getLiteralAsList' :: HsLit GhcPs -> RealSrcSpan -> Set Literal
92-
getLiteralAsList' lit = maybe S.empty S.singleton . flip getLiteral lit
93-
94-
-- Translate from Hs Type to our Literal type
95-
getLiteral :: RealSrcSpan -> HsLit GhcPs -> Maybe Literal
96-
getLiteral sSpan = \case
97-
HsInt _ val -> fromIntegralLit sSpan val
98-
HsRat _ val _ -> fromFractionalLit sSpan val
99-
_ -> Nothing
100-
101-
getOverLiteralAsList :: SrcSpan -> HsOverLit GhcPs -> Set Literal
102-
getOverLiteralAsList sSpan lit = case sSpan of
103-
RealSrcSpan rss _ -> getOverLiteralAsList' lit rss
104-
_ -> S.empty
105-
106-
getOverLiteralAsList' :: HsOverLit GhcPs -> RealSrcSpan -> Set Literal
107-
getOverLiteralAsList' lit sSpan = maybe S.empty S.singleton (getOverLiteral sSpan lit)
108-
109-
getOverLiteral :: RealSrcSpan -> HsOverLit GhcPs -> Maybe Literal
110-
getOverLiteral sSpan OverLit{..} = case ol_val of
111-
HsIntegral il -> fromIntegralLit sSpan il
112-
HsFractional fl -> fromFractionalLit sSpan fl
113-
_ -> Nothing
114-
getOverLiteral _ _ = Nothing
49+
collectLiterals = everything (<>) (maybeToList . (const Nothing `extQ` getLiteral `extQ` getPattern))
50+
51+
-- | Translate from HsLit and HsOverLit Types to our Literal Type
52+
getLiteral :: GenLocated SrcSpan (HsExpr GhcPs) -> Maybe Literal
53+
getLiteral (L (UnhelpfulSpan _) _) = Nothing
54+
getLiteral (L (RealSrcSpan sSpan _ ) expr) = case expr of
55+
HsLit _ lit -> fromLit lit sSpan
56+
HsOverLit _ overLit -> fromOverLit overLit sSpan
57+
_ -> Nothing
58+
59+
-- | Destructure Patterns to unwrap any Literals
60+
getPattern :: GenLocated SrcSpan (Pat GhcPs) -> Maybe Literal
61+
getPattern (L (UnhelpfulSpan _) _) = Nothing
62+
getPattern (L (RealSrcSpan patSpan _) pat) = case pat of
63+
LitPat _ lit -> case lit of
64+
HsInt _ val -> fromIntegralLit patSpan val
65+
HsRat _ val _ -> fromFractionalLit patSpan val
66+
_ -> Nothing
67+
NPat _ (L (RealSrcSpan sSpan _) overLit) _ _ -> fromOverLit overLit sSpan
68+
NPlusKPat _ _ (L (RealSrcSpan sSpan _) overLit1) _ _ _ -> fromOverLit overLit1 sSpan
69+
_ -> Nothing
70+
71+
fromLit :: HsLit p -> RealSrcSpan -> Maybe Literal
72+
fromLit lit sSpan = case lit of
73+
HsInt _ val -> fromIntegralLit sSpan val
74+
HsRat _ val _ -> fromFractionalLit sSpan val
75+
_ -> Nothing
76+
77+
fromOverLit :: HsOverLit p -> RealSrcSpan -> Maybe Literal
78+
fromOverLit OverLit{..} sSpan = case ol_val of
79+
HsIntegral il -> fromIntegralLit sSpan il
80+
HsFractional fl -> fromFractionalLit sSpan fl
81+
_ -> Nothing
82+
fromOverLit _ _ = Nothing
11583

11684
fromIntegralLit :: RealSrcSpan -> IntegralLit -> Maybe Literal
11785
fromIntegralLit s (IL txt _ val) = fmap (\txt' -> IntLiteral s txt' val) (fromSourceText txt)

0 commit comments

Comments
 (0)