{-
    Suggest the usage of underscore when NumericUnderscores is enabled.

<TEST>
123456
{-# LANGUAGE NumericUnderscores #-} \
1234
{-# LANGUAGE NumericUnderscores #-} \
12345 -- @Suggestion 12_345 @NoRefactor
{-# LANGUAGE NumericUnderscores #-} \
123456789.0441234e-123456 -- @Suggestion 123_456_789.044_123_4e-123_456 @NoRefactor
{-# LANGUAGE NumericUnderscores #-} \
0x12abc.523defp+172345 -- @Suggestion 0x1_2abc.523d_efp+172_345 @NoRefactor
{-# LANGUAGE NumericUnderscores #-} \
3.14159265359 -- @Suggestion 3.141_592_653_59 @NoRefactor
{-# LANGUAGE NumericUnderscores #-} \
12_33574_56
</TEST>

-}

module Hint.NumLiteral (numLiteralHint) where

import GHC.Hs
import GHC.Data.FastString
import GHC.LanguageExtensions.Type (Extension (..))
import GHC.Types.SrcLoc
import GHC.Types.SourceText
import GHC.Util.ApiAnnotation (extensions)
import Data.Char (isDigit, isOctDigit, isHexDigit)
import Data.List (intercalate)
import Data.Set (union)
import Data.Generics.Uniplate.DataOnly (universeBi)
import Refact.Types

import Hint.Type (DeclHint, toSSA, modComments, firstDeclComments)
import Idea (Idea, suggest)

numLiteralHint :: DeclHint
numLiteralHint :: DeclHint
numLiteralHint Scope
_ ModuleEx
modu =
  -- Comments appearing without an empty line before the first
  -- declaration in a module are now associated with the declaration
  -- not the module so to be safe, look also at `firstDeclComments
  -- modu` (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).
  let exts :: Set Extension
exts = Set Extension -> Set Extension -> Set Extension
forall a. Ord a => Set a -> Set a -> Set a
union (EpAnnComments -> Set Extension
extensions (ModuleEx -> EpAnnComments
modComments ModuleEx
modu)) (EpAnnComments -> Set Extension
extensions (ModuleEx -> EpAnnComments
firstDeclComments ModuleEx
modu)) in
  if Extension
NumericUnderscores Extension -> Set Extension -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set Extension
exts then
     (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> [Idea])
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsExpr GhcPs -> [Idea]
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> [Idea]
suggestUnderscore ([GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> [Idea])
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs)
    -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [Idea]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall from to. Biplate from to => from -> [to]
universeBi
  else
     [Idea] -> GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [Idea]
forall a b. a -> b -> a
const []

suggestUnderscore :: LHsExpr GhcPs -> [Idea]
suggestUnderscore :: LHsExpr GhcPs -> [Idea]
suggestUnderscore x :: LHsExpr GhcPs
x@(L SrcSpanAnnA
_ (HsOverLit XOverLitE GhcPs
_ ol :: HsOverLit GhcPs
ol@(OverLit XOverLit GhcPs
_ (HsIntegral intLit :: IntegralLit
intLit@(IL (SourceText FastString
srcTxt) Bool
_ Integer
_))))) =
  [ String
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Use underscore" (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x) (LocatedAn Any (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LocatedAn Any (HsExpr GhcPs)
forall an. LocatedAn an (HsExpr GhcPs)
y) [Refactoring SrcSpan
r] | Char
'_' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
srcTxt', String
srcTxt' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
underscoredSrcTxt ]
  where
    srcTxt' :: String
srcTxt' = FastString -> String
unpackFS FastString
srcTxt
    underscoredSrcTxt :: String
underscoredSrcTxt = String -> String
addUnderscore String
srcTxt'
    y :: LocatedAn an (HsExpr GhcPs)
    y :: forall an. LocatedAn an (HsExpr GhcPs)
y = HsExpr GhcPs -> LocatedAn an (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcPs -> LocatedAn an (HsExpr GhcPs))
-> HsExpr GhcPs -> LocatedAn an (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOverLitE GhcPs -> HsOverLit GhcPs -> HsExpr GhcPs
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed (HsOverLit GhcPs -> HsExpr GhcPs)
-> HsOverLit GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsOverLit GhcPs
ol{ol_val = HsIntegral intLit{il_text = SourceText (fsLit underscoredSrcTxt)}}
    r :: Refactoring SrcSpan
r = RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x) [(String
"a", LocatedAn Any (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LocatedAn Any (HsExpr GhcPs)
forall an. LocatedAn an (HsExpr GhcPs)
y)] String
"a"
suggestUnderscore x :: LHsExpr GhcPs
x@(L SrcSpanAnnA
_ (HsOverLit XOverLitE GhcPs
_ ol :: HsOverLit GhcPs
ol@(OverLit XOverLit GhcPs
_ (HsFractional fracLit :: FractionalLit
fracLit@(FL (SourceText FastString
srcTxt) Bool
_ Rational
_ Integer
_ FractionalExponentBase
_))))) =
  [ String
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
String -> Located a -> Located b -> [Refactoring SrcSpan] -> Idea
suggest String
"Use underscore" (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x) (LocatedAn Any (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LocatedAn Any (HsExpr GhcPs)
forall an. LocatedAn an (HsExpr GhcPs)
y) [Refactoring SrcSpan
r] | Char
'_' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
srcTxt', String
srcTxt' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
underscoredSrcTxt ]
  where
    srcTxt' :: String
srcTxt' = FastString -> String
unpackFS FastString
srcTxt
    underscoredSrcTxt :: String
underscoredSrcTxt = String -> String
addUnderscore String
srcTxt'
    y :: LocatedAn an (HsExpr GhcPs)
    y :: forall an. LocatedAn an (HsExpr GhcPs)
y = HsExpr GhcPs -> LocatedAn an (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcPs -> LocatedAn an (HsExpr GhcPs))
-> HsExpr GhcPs -> LocatedAn an (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOverLitE GhcPs -> HsOverLit GhcPs -> HsExpr GhcPs
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit XOverLitE GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed (HsOverLit GhcPs -> HsExpr GhcPs)
-> HsOverLit GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ HsOverLit GhcPs
ol{ol_val = HsFractional fracLit{fl_text = SourceText (fsLit underscoredSrcTxt)}}
    r :: Refactoring SrcSpan
r = RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Expr (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x) [(String
"a", LocatedAn Any (HsExpr GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LocatedAn Any (HsExpr GhcPs)
forall an. LocatedAn an (HsExpr GhcPs)
y)] String
"a"
suggestUnderscore LHsExpr GhcPs
_ = [Idea]
forall a. Monoid a => a
mempty

addUnderscore :: String -> String
addUnderscore :: String -> String
addUnderscore String
intStr = NumLiteral -> String
numLitToStr NumLiteral
underscoredNumLit
 where
   numLit :: NumLiteral
numLit = String -> NumLiteral
toNumLiteral String
intStr
   underscoredNumLit :: NumLiteral
underscoredNumLit = NumLiteral
numLit{ nl_intPart = underscoreFromRight chunkSize $ nl_intPart numLit
                             , nl_fracPart = underscore chunkSize $ nl_fracPart numLit
                             , nl_exp = underscoreFromRight 3 $ nl_exp numLit -- Exponential part is always decimal
                             }
   chunkSize :: Int
chunkSize = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (NumLiteral -> String
nl_prefix NumLiteral
numLit) then Int
3 else Int
4

   underscore :: Int -> String -> String
underscore Int
chunkSize = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> [String]
forall {a}. Int -> [a] -> [[a]]
chunk Int
chunkSize
   underscoreFromRight :: Int -> String -> String
underscoreFromRight Int
chunkSize String
str
     | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5 = String
str
     | Bool
otherwise = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
underscore Int
chunkSize (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
str
   chunk :: Int -> [a] -> [[a]]
chunk Int
chunkSize [] = []
   chunk Int
chunkSize [a]
xs = [a]
a[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:Int -> [a] -> [[a]]
chunk Int
chunkSize [a]
b where ([a]
a, [a]
b) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
chunkSize [a]
xs

data NumLiteral = NumLiteral
  { NumLiteral -> String
nl_prefix :: String
  , NumLiteral -> String
nl_intPart :: String
  , NumLiteral -> String
nl_decSep :: String -- decimal separator
  , NumLiteral -> String
nl_fracPart :: String
  , NumLiteral -> String
nl_expSep :: String -- e, e+, e-, p, p+, p-
  , NumLiteral -> String
nl_exp :: String
  } deriving (Int -> NumLiteral -> String -> String
[NumLiteral] -> String -> String
NumLiteral -> String
(Int -> NumLiteral -> String -> String)
-> (NumLiteral -> String)
-> ([NumLiteral] -> String -> String)
-> Show NumLiteral
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> NumLiteral -> String -> String
showsPrec :: Int -> NumLiteral -> String -> String
$cshow :: NumLiteral -> String
show :: NumLiteral -> String
$cshowList :: [NumLiteral] -> String -> String
showList :: [NumLiteral] -> String -> String
Show, NumLiteral -> NumLiteral -> Bool
(NumLiteral -> NumLiteral -> Bool)
-> (NumLiteral -> NumLiteral -> Bool) -> Eq NumLiteral
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NumLiteral -> NumLiteral -> Bool
== :: NumLiteral -> NumLiteral -> Bool
$c/= :: NumLiteral -> NumLiteral -> Bool
/= :: NumLiteral -> NumLiteral -> Bool
Eq)

toNumLiteral :: String -> NumLiteral
toNumLiteral :: String -> NumLiteral
toNumLiteral String
str = case String
str of
  Char
'0':Char
'b':String
digits -> ((Char -> Bool) -> String -> NumLiteral
afterPrefix Char -> Bool
isBinDigit String
digits){nl_prefix = "0b"}
  Char
'0':Char
'B':String
digits -> ((Char -> Bool) -> String -> NumLiteral
afterPrefix Char -> Bool
isBinDigit String
digits){nl_prefix = "0B"}
  Char
'0':Char
'o':String
digits -> ((Char -> Bool) -> String -> NumLiteral
afterPrefix Char -> Bool
isOctDigit String
digits){nl_prefix = "0o"}
  Char
'0':Char
'O':String
digits -> ((Char -> Bool) -> String -> NumLiteral
afterPrefix Char -> Bool
isOctDigit String
digits){nl_prefix = "0O"}
  Char
'0':Char
'x':String
digits -> ((Char -> Bool) -> String -> NumLiteral
afterPrefix Char -> Bool
isHexDigit String
digits){nl_prefix = "0x"}
  Char
'0':Char
'X':String
digits -> ((Char -> Bool) -> String -> NumLiteral
afterPrefix Char -> Bool
isHexDigit String
digits){nl_prefix = "0X"}
  String
_              -> (Char -> Bool) -> String -> NumLiteral
afterPrefix Char -> Bool
isDigit String
str
  where
    isBinDigit :: Char -> Bool
isBinDigit Char
x = Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'1'

    afterPrefix :: (Char -> Bool) -> String -> NumLiteral
afterPrefix Char -> Bool
isDigit String
str = ((Char -> Bool) -> String -> NumLiteral
afterIntPart Char -> Bool
isDigit String
suffix){nl_intPart = intPart}
      where (String
intPart, String
suffix) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
str

    afterIntPart :: (Char -> Bool) -> String -> NumLiteral
afterIntPart Char -> Bool
isDigit (Char
'.':String
suffix) = ((Char -> Bool) -> String -> NumLiteral
afterDecSep Char -> Bool
isDigit String
suffix){nl_decSep = "."}
    afterIntPart Char -> Bool
isDigit String
str = String -> NumLiteral
afterFracPart String
str

    afterDecSep :: (Char -> Bool) -> String -> NumLiteral
afterDecSep Char -> Bool
isDigit String
str = (String -> NumLiteral
afterFracPart String
suffix){nl_fracPart = fracPart}
      where (String
fracPart, String
suffix) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
str

    afterFracPart :: String -> NumLiteral
afterFracPart String
str = String
-> String -> String -> String -> String -> String -> NumLiteral
NumLiteral String
"" String
"" String
"" String
"" String
expSep String
exp
      where (String
expSep, String
exp) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isDigit String
str

numLitToStr :: NumLiteral -> String
numLitToStr :: NumLiteral -> String
numLitToStr (NumLiteral String
p String
ip String
ds String
fp String
es String
e) = String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ip String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ds String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
es String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e