Add code action to introduce _ in numeric literals

haskell-language-server.cabal

@@ -1018,7 +1018,6 @@ library hls-alternate-number-format-plugin
     , lens
     , lsp                  ^>=2.7
     , mtl
-    , regex-tdfa
     , syb
     , text
 
@@ -1037,6 +1036,7 @@ test-suite hls-alternate-number-format-plugin-tests
   main-is:          Main.hs
   ghc-options:      -fno-ignore-asserts
   build-depends:
+    , containers
     , filepath
     , haskell-language-server:hls-alternate-number-format-plugin
     , hls-test-utils       == 2.11.0.0

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

@@ -23,7 +23,7 @@ import           Development.IDE.Spans.Pragmas    (NextPragmaInfo,
 import           GHC.Generics                     (Generic)
 import           Ide.Logger                       as Logger
 import           Ide.Plugin.Conversion            (AlternateFormat,
-                                                   ExtensionNeeded (NeedsExtension, NoExtension),
+                                                   ExtensionNeeded (..),
                                                    alternateFormat)
 import           Ide.Plugin.Error
 import           Ide.Plugin.Literals
@@ -93,7 +93,7 @@ codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = do
     pure $ InL actions
     where
         mkCodeAction :: NormalizedFilePath -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction
-        mkCodeAction nfp lit enabled npi af@(alt, ext) = InR CodeAction {
+        mkCodeAction nfp lit enabled npi af@(alt, ExtensionNeeded exts) = InR CodeAction {
             _title = mkCodeActionTitle lit af enabled
             , _kind = Just $ CodeActionKind_Custom "quickfix.literals.style"
             , _diagnostics = Nothing
@@ -104,28 +104,29 @@ codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = do
             , _data_ = Nothing
             }
             where
-                edits =  [TextEdit (realSrcSpanToRange $ getSrcSpan lit) alt] <> pragmaEdit
-                pragmaEdit = case ext of
-                    NeedsExtension ext' -> [insertNewPragma npi ext' | needsExtension ext' enabled]
-                    NoExtension         -> []
+                edits =  [TextEdit (realSrcSpanToRange $ getSrcSpan lit) alt] <> pragmaEdit exts
+                pragmaEdit ext = case ext of
+                    ext': exts -> [insertNewPragma npi ext' | needsExtension enabled ext'] <> pragmaEdit exts
+                    []         -> []
 
         mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
         mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing
             where
                 changes = Just $ Map.singleton (filePathToUri $ fromNormalizedFilePath nfp) edits
 
 mkCodeActionTitle :: Literal -> AlternateFormat -> [GhcExtension] -> Text
-mkCodeActionTitle lit (alt, ext) ghcExts
-    | (NeedsExtension ext') <- ext
-    , needsExtension ext' ghcExts = title <> " (needs extension: " <> T.pack (show ext') <> ")"
-    | otherwise = title
+mkCodeActionTitle lit (alt, ExtensionNeeded exts) ghcExts
+    | null necessaryExtensions = title
+    | otherwise = title <> " (needs extensions: " <> formattedExtensions <> ")"
     where
+        formattedExtensions = T.intercalate ", " $ map (T.pack . show) necessaryExtensions
+        necessaryExtensions = filter (needsExtension ghcExts) exts
         title = "Convert " <> getSrcText lit <> " into " <> alt
 
 
 -- | Checks whether the extension given is already enabled
-needsExtension :: Extension -> [GhcExtension] -> Bool
-needsExtension ext ghcExts = ext `notElem` map unExt ghcExts
+needsExtension :: [GhcExtension] -> Extension -> Bool
+needsExtension ghcExts ext = ext `notElem` map unExt ghcExts
 
 requestLiterals :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m CollectLiteralsResult
 requestLiterals (PluginId pId) state =

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

@@ -1,38 +1,36 @@
-{-# LANGUAGE CPP          #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE DerivingStrategies #-}
 module Ide.Plugin.Conversion (
     alternateFormat
-    , hexRegex
-    , hexFloatRegex
-    , binaryRegex
-    , octalRegex
-    , decimalRegex
-    , numDecimalRegex
-    , matchLineRegex
     , toOctal
     , toDecimal
     , toBinary
     , toHex
     , toFloatDecimal
     , toFloatExpDecimal
     , toHexFloat
+    , intFormats
+    , fracFormats
     , AlternateFormat
     , ExtensionNeeded(..)
+    , FormatType(..)
+    , IntFormatType(..)
+    , FracFormatType(..)
+    , UnderscoreFormatType(..)
 ) where
 
-import           Data.List                     (delete)
-import           Data.List.Extra               (enumerate, upper)
-import           Data.Maybe                    (mapMaybe)
+import           Data.List                     (intercalate)
+import           Data.List.Extra               (chunksOf, enumerate, nubOrdOn,
+                                                upper)
+import qualified Data.Map                      as Map
 import           Data.Ratio                    (denominator, numerator)
 import           Data.Text                     (Text)
 import qualified Data.Text                     as T
 import           Development.IDE.Graph.Classes (NFData)
 import           GHC.Generics                  (Generic)
 import           GHC.LanguageExtensions.Type   (Extension (..))
-import           GHC.Show                      (intToDigit)
 import           Ide.Plugin.Literals           (Literal (..), getSrcText)
 import           Numeric
-import           Text.Regex.TDFA               ((=~))
 
 data FormatType = IntFormat IntFormatType
                 | FracFormat FracFormatType
@@ -46,142 +44,130 @@ data IntFormatType = IntDecimalFormat
                    | OctalFormat
                    | BinaryFormat
                    | NumDecimalFormat
-                   deriving (Show, Eq, Generic, Bounded, Enum)
+                   deriving (Show, Eq, Generic, Ord, Bounded, Enum)
 
 instance NFData IntFormatType
 
 data FracFormatType = FracDecimalFormat
                     | HexFloatFormat
                     | ExponentFormat
-                    deriving (Show, Eq, Generic, Bounded, Enum)
+                    deriving (Show, Eq, Generic, Ord, Bounded, Enum)
 
 instance NFData FracFormatType
 
-data ExtensionNeeded = NoExtension
-                     | NeedsExtension Extension
+newtype ExtensionNeeded = ExtensionNeeded [Extension]
+    deriving newtype (Semigroup, Monoid)
 
 type AlternateFormat = (Text, ExtensionNeeded)
 
 -- | Generate alternate formats for a single Literal based on FormatType's given.
 alternateFormat :: Literal -> [AlternateFormat]
-alternateFormat lit = case lit of
-  IntLiteral _ _ val   -> map (alternateIntFormat val) (removeCurrentFormatInt lit)
+alternateFormat lit = nubOrdOn fst $ removeIdentical $ case lit of
+  IntLiteral _ _ val   -> alternateIntFormatsOf id val
   FracLiteral _ _  val -> if denominator val == 1 -- floats that can be integers we can represent as ints
-      then map (alternateIntFormat (numerator val)) (removeCurrentFormatInt lit)
-      else map (alternateFracFormat val) (removeCurrentFormatFrac lit)
-
-alternateIntFormat :: Integer -> IntFormatType -> AlternateFormat
-alternateIntFormat val = \case
-    IntDecimalFormat -> (T.pack $ toDecimal val, NoExtension)
-    HexFormat        -> (T.pack $ toHex val, NoExtension)
-    OctalFormat      -> (T.pack $ toOctal val, NoExtension)
-    BinaryFormat     -> (T.pack $ toBinary val, NeedsExtension BinaryLiterals)
-    NumDecimalFormat -> (T.pack $ toFloatExpDecimal (fromInteger @Double val), NeedsExtension NumDecimals)
-
-alternateFracFormat :: Rational -> FracFormatType -> AlternateFormat
-alternateFracFormat val = \case
-  FracDecimalFormat -> (T.pack $ toFloatDecimal (fromRational @Double val), NoExtension)
-  ExponentFormat    -> (T.pack $ toFloatExpDecimal (fromRational @Double val), NoExtension)
-  HexFloatFormat    -> (T.pack $ toHexFloat (fromRational @Double val), NeedsExtension HexFloatLiterals)
-
--- given a Literal compute it's current Format and delete it from the list of available formats
-removeCurrentFormat :: (Foldable t, Eq a) => [a] -> t a -> [a]
-removeCurrentFormat fmts toRemove = foldl (flip delete) fmts toRemove
-
-removeCurrentFormatInt :: Literal -> [IntFormatType]
-removeCurrentFormatInt (getSrcText -> srcText) = removeCurrentFormat intFormats (filterIntFormats $ sourceToFormatType srcText)
-
-removeCurrentFormatFrac :: Literal -> [FracFormatType]
-removeCurrentFormatFrac (getSrcText -> srcText) = removeCurrentFormat fracFormats (filterFracFormats $ sourceToFormatType srcText)
-
-filterIntFormats :: [FormatType] -> [IntFormatType]
-filterIntFormats = mapMaybe getIntFormat
-    where
-        getIntFormat (IntFormat f) = Just f
-        getIntFormat _             = Nothing
-
-filterFracFormats :: [FormatType] -> [FracFormatType]
-filterFracFormats = mapMaybe getFracFormat
-    where
-        getFracFormat (FracFormat f) = Just f
-        getFracFormat _              = Nothing
-
-intFormats :: [IntFormatType]
-intFormats = enumerate
-
-fracFormats :: [FracFormatType]
-fracFormats = enumerate
-
--- | Regex to match a Haskell Hex Literal
-hexRegex :: Text
-hexRegex = "0[xX][a-fA-F0-9]+"
-
--- | Regex to match a Haskell Hex Float Literal
-hexFloatRegex :: Text
-hexFloatRegex = "0[xX][a-fA-F0-9]+(\\.)?[a-fA-F0-9]*(p[+-]?[0-9]+)?"
-
--- | Regex to match a Haskell Binary Literal
-binaryRegex :: Text
-binaryRegex = "0[bB][0|1]+"
-
--- | Regex to match a Haskell Octal Literal
-octalRegex :: Text
-octalRegex = "0[oO][0-8]+"
-
--- | Regex to match a Haskell Decimal Literal (no decimal points)
-decimalRegex :: Text
-decimalRegex = "[0-9]+(\\.[0-9]+)?"
-
--- | Regex to match a Haskell Literal with an explicit exponent
-numDecimalRegex :: Text
-numDecimalRegex = "[0-9]+\\.[0-9]+[eE][+-]?[0-9]+"
-
--- we want to be explicit in our matches
--- so we need to match the beginning/end of the source text
--- | Wraps a Regex with a beginning ("^") and end ("$") token
-matchLineRegex :: Text -> Text
-matchLineRegex regex = "^" <> regex <> "$"
-
-sourceToFormatType :: Text -> [FormatType]
-sourceToFormatType srcText
-    | srcText =~ matchLineRegex hexRegex = [IntFormat HexFormat]
-    | srcText =~ matchLineRegex hexFloatRegex = [FracFormat HexFloatFormat]
-    | srcText =~ matchLineRegex octalRegex = [IntFormat OctalFormat]
-    | srcText =~ matchLineRegex binaryRegex = [IntFormat BinaryFormat]
-    -- can either be a NumDecimal or just a regular Fractional with an exponent
-    -- otherwise we wouldn't need to return a list
-    | srcText =~ matchLineRegex numDecimalRegex  = [IntFormat NumDecimalFormat, FracFormat ExponentFormat]
-    -- just assume we are in base 10 with no decimals
-    | otherwise = [IntFormat IntDecimalFormat, FracFormat FracDecimalFormat]
-
-toBase :: (Num a, Ord a) => (a -> ShowS) -> String -> a -> String
-toBase conv header n
-  | n < 0 = '-' : header <> upper (conv (abs n) "")
-  | otherwise = header <> upper (conv n "")
-
-#if MIN_VERSION_base(4,17,0)
-toOctal, toBinary, toHex :: Integral a => a -> String
-#else
-toOctal, toBinary, toHex:: (Integral a, Show a) => a -> String
-#endif
-
-toBinary = toBase showBin_ "0b"
+    then alternateIntFormatsOf numerator val
+    else alternateFracFormatsOf val
   where
-    -- this is not defined in base < 4.16
-    showBin_ = showIntAtBase 2 intToDigit
-
-toOctal = toBase showOct "0o"
-
-toHex = toBase showHex "0x"
-
-toDecimal :: Integral a => a -> String
-toDecimal = toBase showInt ""
-
-toFloatDecimal :: RealFloat a => a -> String
-toFloatDecimal val = showFFloat Nothing val ""
-
-toFloatExpDecimal :: RealFloat a => a -> String
-toFloatExpDecimal val = showEFloat Nothing val ""
-
-toHexFloat :: RealFloat a => a -> String
-toHexFloat val = showHFloat val ""
+    removeIdentical = filter ((/= getSrcText lit) . fst)
+    alternateIntFormatsOf with val = [ alternateIntFormat (with val) formatType f | (formatType, formats) <- Map.toList intFormats, f <- formats]
+    alternateFracFormatsOf val = [ alternateFracFormat val formatType f | (formatType, formats) <- Map.toList fracFormats, f <- formats]
+
+data UnderscoreFormatType
+    = NoUnderscores
+    | UseUnderscores Int
+    deriving (Show, Eq)
+
+underscoreExtensions :: UnderscoreFormatType -> ExtensionNeeded
+underscoreExtensions = \case
+    NoUnderscores -> mempty
+    UseUnderscores _ -> ExtensionNeeded [NumericUnderscores]
+
+alternateIntFormat :: Integer -> IntFormatType -> UnderscoreFormatType -> AlternateFormat
+alternateIntFormat val formatType underscoreFormat = case formatType of
+    IntDecimalFormat -> (T.pack $ toDecimal underscoreFormat val , underscoreExtensions underscoreFormat)
+    HexFormat        -> (T.pack $ toHex underscoreFormat val , underscoreExtensions underscoreFormat)
+    OctalFormat      -> (T.pack $ toOctal underscoreFormat val , underscoreExtensions underscoreFormat)
+    BinaryFormat     -> (T.pack $ toBinary underscoreFormat val , underscoreExtensions underscoreFormat <> ExtensionNeeded [BinaryLiterals])
+    NumDecimalFormat -> (T.pack $ toFloatExpDecimal underscoreFormat (fromInteger @Double val) , underscoreExtensions underscoreFormat <> ExtensionNeeded [NumDecimals])
+
+alternateFracFormat :: Rational -> FracFormatType -> UnderscoreFormatType -> AlternateFormat
+alternateFracFormat val formatType underscoreFormat = case formatType of
+  FracDecimalFormat -> (T.pack $ toFloatDecimal underscoreFormat (fromRational @Double val), mempty)
+  ExponentFormat    -> (T.pack $ toFloatExpDecimal underscoreFormat (fromRational @Double val), mempty)
+  HexFloatFormat    -> (T.pack $ toHexFloat underscoreFormat (fromRational @Double val), underscoreExtensions underscoreFormat <> ExtensionNeeded [HexFloatLiterals])
+
+intFormats :: Map.Map IntFormatType [UnderscoreFormatType]
+intFormats = Map.fromList $ map (\t -> (t, intFormatUnderscore t)) enumerate
+
+intFormatUnderscore :: IntFormatType -> [UnderscoreFormatType]
+intFormatUnderscore formatType = NoUnderscores : map UseUnderscores (case formatType of
+    IntDecimalFormat -> [3, 4]
+    HexFormat        -> [2, 4]
+    OctalFormat      -> [2, 4, 8]
+    BinaryFormat     -> [4]
+    NumDecimalFormat -> [3, 4])
+
+fracFormats :: Map.Map FracFormatType [UnderscoreFormatType]
+fracFormats = Map.fromList $ map (\t -> (t, fracFormatUnderscore t)) enumerate
+
+fracFormatUnderscore :: FracFormatType -> [UnderscoreFormatType]
+fracFormatUnderscore formatType = NoUnderscores : map UseUnderscores (case formatType of
+  FracDecimalFormat -> [3, 4]
+  ExponentFormat    -> [3, 4]
+  HexFloatFormat    -> [2, 4])
+
+addMinus :: (Ord n, Num n) => (n -> String) -> n -> String
+addMinus f n
+  | n < 0 = '-' : f (abs n)
+  | otherwise = f n
+
+toBase :: (a -> ShowS) -> a -> String
+toBase conv n = upper (conv n "")
+
+toBaseFmt :: (Ord a, Num a) => (a -> ShowS) -> [Char] -> UnderscoreFormatType ->  a -> [Char]
+toBaseFmt conv header underscoreFormat = addMinus $ \val ->
+    header ++ addUnderscoresInt underscoreFormat (toBase conv val)
+
+toBinary  :: Integral a => UnderscoreFormatType -> a -> String
+toBinary = toBaseFmt showBin "0b"
+
+toOctal  :: Integral a => UnderscoreFormatType -> a -> String
+toOctal = toBaseFmt showOct "0o"
+
+toHex :: Integral a => UnderscoreFormatType -> a -> String
+toHex = toBaseFmt showHex "0x"
+
+toDecimal :: Integral a => UnderscoreFormatType -> a -> String
+toDecimal = toBaseFmt showInt ""
+
+addUnderscoresInt :: UnderscoreFormatType -> String -> String
+addUnderscoresInt = \case
+    NoUnderscores -> id
+    -- Chunk starting from the least significant numeral.
+    UseUnderscores n -> reverse . intercalate "_" . chunksOf n . reverse
+
+toFracFormat :: (Ord t, Num t) => (t -> String) -> String -> UnderscoreFormatType -> t -> String
+toFracFormat f header underScoreFormat = addMinus $ \val ->
+    header <> addUnderscoresFloat underScoreFormat (f val)
+
+toFloatDecimal :: RealFloat a => UnderscoreFormatType -> a -> String
+toFloatDecimal = toFracFormat (\v -> showFFloat Nothing (abs v) "") ""
+
+toFloatExpDecimal :: RealFloat a => UnderscoreFormatType -> a -> String
+toFloatExpDecimal underscoreFormat val =
+    let (n, e) = break (=='e') $ showEFloat Nothing (abs val) ""
+    in toFracFormat (const n) "" underscoreFormat val <> e
+
+toHexFloat :: RealFloat a => UnderscoreFormatType -> a -> String
+toHexFloat underscoreFormat val =
+    let (header, n) = splitAt 2 $ showHFloat (abs val) ""
+        (n', e) = break (=='p') n
+    in toFracFormat (const n') header underscoreFormat val <> e
+
+addUnderscoresFloat :: UnderscoreFormatType -> String -> String
+addUnderscoresFloat = \case
+    NoUnderscores -> id
+    UseUnderscores n -> \s ->
+        let (integral, decimal) = break (=='.') s
+            addUnderscores = reverse . intercalate "_" . chunksOf n . reverse
+        in intercalate "." [addUnderscores integral, intercalate "_" $ chunksOf n $ drop 1 decimal]