{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.Conversion (
alternateFormat
, hexRegex
, hexFloatRegex
, binaryRegex
, octalRegex
, decimalRegex
, numDecimalRegex
, matchLineRegex
, toOctal
, toDecimal
, toBinary
, toHex
, toFloatDecimal
, toFloatExpDecimal
, toHexFloat
, AlternateFormat
, ExtensionNeeded(..)
) where
import Data.Char (toUpper)
import Data.List (delete)
import Data.List.Extra (enumerate, upper)
import Data.Maybe (mapMaybe)
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
| NoFormat
deriving (Show, Eq, Generic)
instance NFData FormatType
data IntFormatType = IntDecimalFormat
| HexFormat
| OctalFormat
| BinaryFormat
| NumDecimalFormat
deriving (Show, Eq, Generic, Bounded, Enum)
instance NFData IntFormatType
data FracFormatType = FracDecimalFormat
| HexFloatFormat
| ExponentFormat
deriving (Show, Eq, Generic, Bounded, Enum)
instance NFData FracFormatType
data ExtensionNeeded = NoExtension
| NeedsExtension Extension
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)
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 "")
toOctal :: (Integral a, Show a) => a -> String
toOctal = toBase showOct "0o"
toDecimal :: Integral a => a -> String
toDecimal = toBase showInt ""
toBinary :: (Integral a, Show a) => a -> String
toBinary = toBase showBin "0b"
where
-- this is not defined in versions of Base < 4.16-ish
showBin = showIntAtBase 2 intToDigit
toHex :: (Integral a, Show a) => a -> String
toHex = toBase showHex "0x"
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 ""