diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ The alternate number format plugin provides alternative formatting for Numeric Literals in source code. These can be any numeric literal such as `123`, `0x45` or any of the other numeric formats. -The plugin is context aware and will provide suggestions based on currently active GHC extensions. +The Code Action will provide all possible formatting suggestions (and when required insert the associated Language Extension) ## Setup @@ -22,19 +22,25 @@ The plugin is relatively simple, it traverses a files source contents using the GHC API. As it encounters Literals (of the type `HsExpr` with the constructor of either `HsLit` or `HsOverLit`), it will construct an internal `Literal` datatype that has additional information for use to generate suggestions. Currently, the traversal is done in the file, `Literal.hs`, using the package [SYB](https://hackage.haskell.org/package/syb) for most of the heavy lifting. -The plugin extends on top of SYB as the traversal done by basic combinators is not perfect. For whatever reason, when starting at the root `ParsedModule` the SYB traversal ignores Pattern Binds (`LPat GhcPs`). As a result, a combinator was created to match on TWO separate underlying types to dispatch on. - -To generate suggestions, the plugin leverages the `Numeric` package which provides a multitude of conversion functions to and from strings/numerics. The only slight change is the addition of extra work when using `NumDecimals` extension. The plugin will attempt to generate 3 choices for the user (this choice is not given for `Fractional` numerics). +To generate suggestions, the plugin leverages the `Numeric` package which provides a multitude of conversion functions to and from strings/numerics. ### Known Quirks -- Currently (and probably inefficiently), a Set is used as general accumulator for all Literals being captured. This is because again, through the intricacies of using SYB, we somehow will traverse Source Text multiple times and collect duplicate literals. - -- In the Test Suite, we are required to be explicit in where our `codeActions` will occur. Otherwise, a simple call to `getAllCodeActions` will not work, for whatever reason, there is not enough time to generate the code actions. - -- `PrimLiterals` are currently ignored. GHC API does not attach Source Text to Primitive Literal Nodes. As such these are ignored in the plugin. - -- Similarly, anything that produces a bad Source Span (i.e. can't be easily replaced by an edit) is ignored as well. +- Anything that produces a bad Source Span (i.e. can't be easily replaced by an edit) is ignored as well. ## Changelog ### 1.0.0.0 - First Release + +### 1.0.1.0 +- Dependency upgrades + +### 1.0.1.1 +- Buildable with GHC 9.2 + +### 1.0.2.0 +- Test Suite upgraded for 9.2 semantics (GHC2021) +- Fix SYB parsing with GHC 9.2 + +### 1.1.0.0 +- Provide ALL possible formats as suggestions +- Insert Language Extensions when needed diff --git a/hls-alternate-number-format-plugin.cabal b/hls-alternate-number-format-plugin.cabal --- a/hls-alternate-number-format-plugin.cabal +++ b/hls-alternate-number-format-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-alternate-number-format-plugin -version: 1.0.1.0 +version: 1.1.0.0 synopsis: Provide Alternate Number Formats plugin for Haskell Language Server description: Please see the README on GitHub at @@ -21,14 +21,15 @@ exposed-modules: Ide.Plugin.AlternateNumberFormat, Ide.Plugin.Conversion other-modules: Ide.Plugin.Literals hs-source-dirs: src + ghc-options: -Wall build-depends: aeson , base >=4.12 && < 5 , containers - , ghcide ^>=1.6 + , ghcide ^>=1.6 || ^>=1.7 , ghc-boot-th , hls-graph - , hls-plugin-api ^>=1.3 + , hls-plugin-api ^>=1.3 || ^>=1.4 , hie-compat , lens , lsp @@ -56,7 +57,7 @@ , base >=4.12 && < 5 , filepath , hls-alternate-number-format-plugin - , hls-test-utils ^>=1.2 + , hls-test-utils ^>=1.3 , lsp , QuickCheck , regex-tdfa diff --git a/src/Ide/Plugin/AlternateNumberFormat.hs b/src/Ide/Plugin/AlternateNumberFormat.hs --- a/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/src/Ide/Plugin/AlternateNumberFormat.hs @@ -2,7 +2,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Ide.Plugin.AlternateNumberFormat (descriptor) where +{-# LANGUAGE ViewPatterns #-} +module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where import Control.Lens ((^.)) import Control.Monad.Except (ExceptT, MonadIO, liftIO) @@ -10,29 +11,42 @@ import Data.Text (Text) import qualified Data.Text as T import Development.IDE (GetParsedModule (GetParsedModule), + GhcSession (GhcSession), IdeState, RuleResult, Rules, - define, ideLogger, + define, getFileContents, + hscEnv, ideLogger, realSrcSpanToRange, runAction, - use) + use, useWithStale) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (getSrcSpan) import Development.IDE.GHC.Compat.Util (toList) -import Development.IDE.Graph.Classes (Hashable, NFData) +import Development.IDE.Graph.Classes (Hashable, NFData, rnf) +import Development.IDE.Spans.Pragmas (NextPragmaInfo, + getNextPragmaInfo, + insertNewPragma) import Development.IDE.Types.Logger as Logger import GHC.Generics (Generic) -import Ide.Plugin.Conversion (FormatType, alternateFormat, - toFormatTypes) -import Ide.Plugin.Literals (Literal (..), collectLiterals, - getSrcSpan, getSrcText) +import GHC.LanguageExtensions.Type (Extension) +import Ide.Plugin.Conversion (AlternateFormat, + ExtensionNeeded (NeedsExtension, NoExtension), + alternateFormat) +import Ide.Plugin.Literals import Ide.PluginUtils (handleMaybe, handleMaybeM, response) import Ide.Types import Language.LSP.Types import Language.LSP.Types.Lens (uri) -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler - , pluginRules = collectLiteralsRule + , pluginRules = collectLiteralsRule recorder } data CollectLiterals = CollectLiterals @@ -44,38 +58,42 @@ type instance RuleResult CollectLiterals = CollectLiteralsResult data CollectLiteralsResult = CLR - { literals :: [Literal] - , formatTypes :: [FormatType] + { literals :: [Literal] + , enabledExtensions :: [GhcExtension] } deriving (Generic) +newtype GhcExtension = GhcExtension { unExt :: Extension } + +instance NFData GhcExtension where + rnf x = x `seq` () + instance Show CollectLiteralsResult where show _ = "" instance NFData CollectLiteralsResult -collectLiteralsRule :: Rules () -collectLiteralsRule = define $ \CollectLiterals nfp -> do +collectLiteralsRule :: Recorder (WithPriority Log) -> Rules () +collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectLiterals nfp -> do pm <- use GetParsedModule nfp -- get the current extensions active and transform them into FormatTypes - let fmts = getFormatTypes <$> pm + let exts = getExtensions <$> pm -- collect all the literals for a file lits = collectLiterals . pm_parsed_source <$> pm - pure ([], CLR <$> lits <*> fmts) + pure ([], CLR <$> lits <*> exts) where - getFormatTypes = toFormatTypes . toList . extensionFlags . ms_hspp_opts . pm_mod_summary + getExtensions = map GhcExtension . toList . extensionFlags . ms_hspp_opts . pm_mod_summary codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction codeActionHandler state _ (CodeActionParams _ _ docId currRange _) = response $ do nfp <- getNormalizedFilePath docId CLR{..} <- requestLiterals state nfp + pragma <- getFirstPragma state nfp -- remove any invalid literals (see validTarget comment) let litsInRange = filter inCurrentRange literals -- generate alternateFormats and zip with the literal that generated the alternates - literalPairs = map (\lit -> (lit, alternateFormat formatTypes lit)) litsInRange + literalPairs = map (\lit -> (lit, alternateFormat lit)) litsInRange -- make a code action for every literal and its' alternates (then flatten the result) - actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit) alts) literalPairs - - logIO state $ "Literals: " <> show literals + actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit enabledExtensions pragma) alts) literalPairs pure $ List actions where @@ -83,24 +101,41 @@ inCurrentRange lit = let srcSpan = getSrcSpan lit in currRange `contains` srcSpan - mkCodeAction :: NormalizedFilePath -> Literal -> Text -> Command |? CodeAction - mkCodeAction nfp lit alt = InR CodeAction { - _title = "Convert " <> getSrcText lit <> " into " <> alt + mkCodeAction :: NormalizedFilePath -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction + mkCodeAction nfp lit enabled npi af@(alt, ext) = InR CodeAction { + _title = mkCodeActionTitle lit af enabled , _kind = Just $ CodeActionUnknown "quickfix.literals.style" , _diagnostics = Nothing , _isPreferred = Nothing , _disabled = Nothing - , _edit = Just $ mkWorkspaceEdit nfp lit alt + , _edit = Just $ mkWorkspaceEdit nfp edits , _command = Nothing , _xdata = Nothing } + where + edits = [TextEdit (realSrcSpanToRange $ getSrcSpan lit) alt] <> pragmaEdit + pragmaEdit = case ext of + NeedsExtension ext' -> [insertNewPragma npi ext' | needsExtension ext' enabled] + NoExtension -> [] - mkWorkspaceEdit :: NormalizedFilePath -> Literal -> Text -> WorkspaceEdit - mkWorkspaceEdit nfp lit alt = WorkspaceEdit changes Nothing Nothing + mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit + mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing where - txtEdit = TextEdit (realSrcSpanToRange $ getSrcSpan lit) alt - changes = Just $ HashMap.fromList [( filePathToUri $ fromNormalizedFilePath nfp, List [txtEdit])] + changes = Just $ HashMap.fromList [(filePathToUri $ fromNormalizedFilePath nfp, List 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 + where + 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 + -- from HaddockComments.hs contains :: Range -> RealSrcSpan -> Bool contains Range {_start, _end} x = isInsideRealSrcSpan _start x || isInsideRealSrcSpan _end x @@ -108,6 +143,15 @@ isInsideRealSrcSpan :: Position -> RealSrcSpan -> Bool p `isInsideRealSrcSpan` r = let (Range sp ep) = realSrcSpanToRange r in sp <= p && p <= ep +getFirstPragma :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo +getFirstPragma state nfp = handleMaybeM "Error: Could not get NextPragmaInfo" $ do + ghcSession <- liftIO $ runAction "AlternateNumberFormat.GhcSession" state $ useWithStale GhcSession nfp + (_, fileContents) <- liftIO $ runAction "AlternateNumberFormat.GetFileContents" state $ getFileContents nfp + case ghcSession of + Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents + Nothing -> pure Nothing + + getNormalizedFilePath :: Monad m => TextDocumentIdentifier -> ExceptT String m NormalizedFilePath getNormalizedFilePath docId = handleMaybe "Error: converting to NormalizedFilePath" $ uriToNormalizedFilePath @@ -118,8 +162,3 @@ . liftIO . runAction "AlternateNumberFormat.CollectLiterals" state . use CollectLiterals - - -logIO :: (MonadIO m, Show a) => IdeState -> a -> m () -logIO state = liftIO . Logger.logDebug (ideLogger state) . T.pack . show - diff --git a/src/Ide/Plugin/Conversion.hs b/src/Ide/Plugin/Conversion.hs --- a/src/Ide/Plugin/Conversion.hs +++ b/src/Ide/Plugin/Conversion.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Conversion ( alternateFormat , hexRegex @@ -8,20 +10,19 @@ , decimalRegex , numDecimalRegex , matchLineRegex - , toFormatTypes - , FormatType - , generateNumDecimal - , toNumDecimal - , toBinary , toOctal + , toDecimal + , toBinary , toHex - , toHexFloat , toFloatDecimal , toFloatExpDecimal + , toHexFloat + , AlternateFormat + , ExtensionNeeded(..) ) where import Data.Char (toUpper) -import Data.List (delete, dropWhileEnd) +import Data.List (delete) import Data.Maybe (mapMaybe) import Data.Ratio (denominator, numerator) import Data.Text (Text) @@ -36,60 +37,82 @@ data FormatType = IntFormat IntFormatType | FracFormat FracFormatType - | AnyFormat AnyFormatType | NoFormat deriving (Show, Eq, Generic) instance NFData FormatType -data IntFormatType = HexFormat +data IntFormatType = IntDecimalFormat + | HexFormat | OctalFormat | BinaryFormat | NumDecimalFormat - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, Bounded, Enum) instance NFData IntFormatType -data FracFormatType = HexFloatFormat +data FracFormatType = FracDecimalFormat + | HexFloatFormat | ExponentFormat - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, Bounded, Enum) instance NFData FracFormatType -data AnyFormatType = DecimalFormat - deriving (Show, Eq, Generic) +data ExtensionNeeded = NoExtension + | NeedsExtension Extension -instance NFData AnyFormatType +type AlternateFormat = (Text, ExtensionNeeded) -- | Generate alternate formats for a single Literal based on FormatType's given. -alternateFormat :: [FormatType] -> Literal -> [Text] -alternateFormat fmts lit = case lit of - IntLiteral _ _ val -> concatMap (alternateIntFormat val) (removeCurrentFormat lit fmts) +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 concatMap (alternateIntFormat (numerator val)) (removeCurrentFormat lit fmts) - else concatMap (alternateFracFormat val) (removeCurrentFormat lit fmts) + then map (alternateIntFormat (numerator val)) (removeCurrentFormatInt lit) + else map (alternateFracFormat val) (removeCurrentFormatFrac lit) -alternateIntFormat :: Integer -> FormatType -> [Text] -alternateIntFormat val fmt = case fmt of - IntFormat ift -> case ift of - HexFormat -> [T.pack $ toHex val] - OctalFormat -> [T.pack $ toOctal val] - BinaryFormat -> [T.pack $ toBinary val] - NumDecimalFormat -> generateNumDecimal val -- this is the only reason we return List of Text :/ - AnyFormat DecimalFormat -> [T.pack $ toDecimal val] - _ -> [] +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 -> FormatType -> [Text] -alternateFracFormat val fmt = case fmt of - AnyFormat DecimalFormat -> [T.pack $ toFloatDecimal (fromRational val)] - FracFormat ExponentFormat -> [T.pack $ toFloatExpDecimal (fromRational val)] - FracFormat HexFloatFormat -> [T.pack $ toHexFloat (fromRational val)] - _ -> [] +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) -removeCurrentFormat :: Literal -> [FormatType] -> [FormatType] -removeCurrentFormat lit fmts = let srcText = getSrcText lit - in foldl (flip delete) fmts (sourceToFormatType srcText) +-- 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 = [minBound .. maxBound] + +fracFormats :: [FracFormatType] +fracFormats = [minBound .. maxBound] + -- | Regex to match a Haskell Hex Literal hexRegex :: Text hexRegex = "0[xX][a-fA-F0-9]+" @@ -130,46 +153,7 @@ -- 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 = [AnyFormat DecimalFormat] - --- | Translate a list of Extensions into Format Types (plus a base set of Formats) -toFormatTypes :: [Extension] -> [FormatType] -toFormatTypes = (<>) baseFormatTypes . mapMaybe (`lookup` numericPairs) - where - baseFormatTypes = [IntFormat HexFormat, IntFormat OctalFormat, FracFormat ExponentFormat, AnyFormat DecimalFormat] - --- current list of Numeric related extensions --- LexicalNegation --- 9.0.1 > --- superset of NegativeLiterals -numericPairs :: [(Extension, FormatType)] -numericPairs = [(NumericUnderscores, NoFormat), (NegativeLiterals, NoFormat)] <> intPairs <> fracPairs - -intPairs :: [(Extension, FormatType)] -intPairs = [(BinaryLiterals, IntFormat BinaryFormat), (NumDecimals, IntFormat NumDecimalFormat)] - -fracPairs :: [(Extension, FormatType)] -fracPairs = [(HexFloatLiterals, FracFormat HexFloatFormat)] - --- Generate up to 3 possible choices where: --- dropWhile (\d -> val `div` d) > 1000) implies we want at MOST 3 digits to left of decimal --- takeWhile (val >) implies we want to stop once we start to get numbers like: 0.1e[N] --- take 3 implies we want at most three choices which will center around the format: --- - 500.123e4 --- - 50.0123e5 --- - 5e.00123e6 --- NOTE: showEFloat would also work, but results in only one option -generateNumDecimal :: Integer -> [Text] -generateNumDecimal val = map (toNumDecimal val) $ take 3 $ takeWhile (val >= ) $ dropWhile (\d -> (val `div` d) > 1000) divisors - where - divisors = 10 : map (*10) divisors - -toNumDecimal :: Integer -> Integer -> Text -toNumDecimal val divisor = let (q, r) = val `quotRem` divisor - numExponent = length $ filter (== '0') $ show divisor - -- remove unnecessary trailing zeroes from output - r' = dropWhileEnd (== '0') $ show r - -- but make sure there are still digits left!!! - r'' = if null r' then "0" else r' - in T.pack $ show q <> "." <> r'' <> "e" <> show numExponent + | otherwise = [IntFormat IntDecimalFormat, FracFormat FracDecimalFormat] toBase :: (Num a, Ord a) => (a -> ShowS) -> String -> a -> String toBase conv header n diff --git a/src/Ide/Plugin/Literals.hs b/src/Ide/Plugin/Literals.hs --- a/src/Ide/Plugin/Literals.hs +++ b/src/Ide/Plugin/Literals.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Literals ( collectLiterals , Literal(..) @@ -13,7 +15,6 @@ 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, everything, @@ -23,15 +24,19 @@ -- 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 +data Literal = IntLiteral LiteralSrcSpan Text Integer + | FracLiteral LiteralSrcSpan Text Rational deriving (GHC.Generic, Show, Ord, Eq, Data) -instance NFData RealSrcSpan where +newtype LiteralSrcSpan = LiteralSrcSpan { unLit :: RealSrcSpan } + deriving (GHC.Generic, Show, Ord, Eq, Data) + +instance NFData LiteralSrcSpan where rnf x = x `seq` () instance NFData Literal + -- | Return a Literal's Source representation getSrcText :: Literal -> Text getSrcText = \case @@ -41,32 +46,43 @@ -- | Return a Literal's Real Source location getSrcSpan :: Literal -> RealSrcSpan getSrcSpan = \case - IntLiteral ss _ _ -> ss - FracLiteral ss _ _ -> ss + IntLiteral ss _ _ -> unLit ss + FracLiteral ss _ _ -> unLit ss -- | Find all literals in a Parsed Source File collectLiterals :: (Data ast, Typeable ast) => ast -> [Literal] 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 +getLiteral :: LHsExpr GhcPs -> Maybe Literal +getLiteral (L (locA -> (RealSrcSpan sSpan _)) expr) = case expr of HsLit _ lit -> fromLit lit sSpan HsOverLit _ overLit -> fromOverLit overLit sSpan _ -> Nothing +getLiteral _ = Nothing + + +-- GHC 8.8 typedefs LPat = Pat +#if __GLASGOW_HASKELL__ == 808 +type LocPat a = GenLocated SrcSpan (Pat a) +#else +type LocPat a = LPat a +#endif + -- | 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 +getPattern :: LocPat GhcPs -> Maybe Literal +getPattern (L (locA -> (RealSrcSpan patSpan _)) pat) = case pat of LitPat _ lit -> case lit of HsInt _ val -> fromIntegralLit patSpan val HsRat _ val _ -> fromFractionalLit patSpan val _ -> Nothing + -- a located HsOverLit is (GenLocated SrcSpan HsOverLit) NOT (GenLocated SrcSpanAnn' a HsOverLit) NPat _ (L (RealSrcSpan sSpan _) overLit) _ _ -> fromOverLit overLit sSpan NPlusKPat _ _ (L (RealSrcSpan sSpan _) overLit1) _ _ _ -> fromOverLit overLit1 sSpan _ -> Nothing +getPattern _ = Nothing fromLit :: HsLit p -> RealSrcSpan -> Maybe Literal fromLit lit sSpan = case lit of @@ -82,39 +98,12 @@ fromOverLit _ _ = Nothing fromIntegralLit :: RealSrcSpan -> IntegralLit -> Maybe Literal -fromIntegralLit s IL{..} = fmap (\txt' -> IntLiteral s txt' il_value) (fromSourceText il_text) +fromIntegralLit s IL{..} = fmap (\txt' -> IntLiteral (LiteralSrcSpan s) txt' il_value) (fromSourceText il_text) fromFractionalLit :: RealSrcSpan -> FractionalLit -> Maybe Literal -fromFractionalLit s FL{..} = fmap (\txt' -> FracLiteral s txt' fl_value) (fromSourceText fl_text) +fromFractionalLit s fl@FL{fl_text} = fmap (\txt' -> FracLiteral (LiteralSrcSpan s) txt' (rationalFromFractionalLit fl)) (fromSourceText fl_text) fromSourceText :: SourceText -> Maybe Text fromSourceText = \case SourceText s -> Just $ T.pack s NoSourceText -> Nothing - --- mostly for debugging purposes -literalToString :: HsLit p -> String -literalToString = \case - HsChar _ c -> "Char: " <> show c - HsCharPrim _ c -> "CharPrim: " <> show c - HsString _ fs -> "String: " <> show fs - HsStringPrim _ bs -> "StringPrim: " <> show bs - HsInt _ il -> "Int: " <> show il - HsIntPrim _ n -> "IntPrim: " <> show n - HsWordPrim _ n -> "WordPrim: " <> show n - HsInt64Prim _ n -> "Int64Prim: " <> show n - HsWord64Prim _ n -> "Word64Prim: " <> show n - HsInteger _ n ty -> "Integer: " <> show n <> " Type: " <> tyToLiteral ty - HsRat _ fl ty -> "Rat: " <> show fl <> " Type: " <> tyToLiteral ty - HsFloatPrim _ fl -> "FloatPrim: " <> show fl - HsDoublePrim _ fl -> "DoublePrim: " <> show fl - _ -> "XHsLit" - where - tyToLiteral :: Type -> String - tyToLiteral = unsafePrintSDoc . ppr - -overLitToString :: OverLitVal -> String -overLitToString = \case - HsIntegral int -> case int of { IL{il_value} -> "IntegralOverLit: " <> show il_value} - HsFractional frac -> case frac of { FL{fl_value} -> "RationalOverLit: " <> show fl_value} - HsIsString _ str -> "HIsString: " <> show str diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -21,8 +21,7 @@ main = defaultTestRunner test alternateNumberFormatPlugin :: PluginDescriptor IdeState -alternateNumberFormatPlugin = AlternateNumberFormat.descriptor "alternateNumberFormat" - +alternateNumberFormatPlugin = AlternateNumberFormat.descriptor mempty "alternateNumberFormat" -- NOTE: For whatever reason, this plugin does not play nice with creating Code Actions on time. -- As a result tests will mostly pass if `import Prelude` is added at the top. We (mostly fendor) surmise this has something @@ -31,42 +30,26 @@ test = testGroup "alternateNumberFormat" [ codeActionHex "TIntDtoH" 3 13 , codeActionOctal "TIntDtoO" 3 13 - , codeActionBinary "TIntDtoB" 4 13 + , codeActionBinary "TIntDtoB" 4 12 , codeActionNumDecimal "TIntDtoND" 5 13 , codeActionFracExp "TFracDtoE" 3 13 , codeActionFloatHex "TFracDtoHF" 4 13 , codeActionDecimal "TIntHtoD" 3 13 , codeActionDecimal "TFracHFtoD" 4 13 - , codeActionProperties "TFindLiteralIntPattern" [(3, 25), (4,25)] $ \actions -> do + -- to test we don't duplicate pragmas + , codeActionFloatHex "TFracDtoHFWithPragma" 4 13 + , codeActionProperties "TFindLiteralIntPattern" [(4, 25), (5,25)] $ \actions -> do + liftIO $ length actions @?= 8 + , codeActionProperties "TFindLiteralIntCase" [(4, 29)] $ \actions -> do liftIO $ length actions @?= 4 - , codeActionProperties "TFindLiteralIntCase" [(3, 29)] $ \actions -> do - liftIO $ length actions @?= 2 - , codeActionProperties "TFindLiteralIntCase2" [(4, 21)] $ \actions -> do - liftIO $ length actions @?= 2 - , codeActionProperties "TFindLiteralDoReturn" [(5, 10)] $ \actions -> do - liftIO $ length actions @?= 2 - , codeActionProperties "TFindLiteralDoLet" [(5, 13), (6, 13)] $ \actions -> do + , codeActionProperties "TFindLiteralIntCase2" [(5, 21)] $ \actions -> do liftIO $ length actions @?= 4 - , codeActionProperties "TFindLiteralList" [(3, 28)] $ \actions -> do - liftIO $ length actions @?= 2 - , codeActionProperties "TExpectNoBinaryFormat" [(3, 12)] $ \actions -> do - liftIO $ length actions @?= 2 - liftIO $ actions `doesNotContain` binaryRegex @? "Contains binary codeAction" - , codeActionProperties "TExpectBinaryFormat" [(4, 10)] $ \actions -> do - liftIO $ length actions @?= 3 - liftIO $ actions `contains` binaryRegex @? "Does not contain binary codeAction" - , codeActionProperties "TExpectNoHexFloatFormat" [(3, 14)] $ \actions -> do - liftIO $ length actions @?= 1 - liftIO $ actions `doesNotContain` hexFloatRegex @? "Contains hex float codeAction" - , codeActionProperties "TExpectHexFloatFormat" [(4, 12)] $ \actions -> do - liftIO $ length actions @?= 2 - liftIO $ actions `contains` hexFloatRegex @? "Does not contain hex float codeAction" - , codeActionProperties "TExpectNoNumDecimalFormat" [(3, 16)] $ \actions -> do - liftIO $ length actions @?= 2 - liftIO $ actions `doesNotContain` numDecimalRegex @? "Contains numDecimal codeAction" - , codeActionProperties "TExpectNumDecimalFormat" [(4, 14)] $ \actions -> do - liftIO $ length actions @?= 5 - liftIO $ actions `contains` numDecimalRegex @? "Contains numDecimal codeAction" + , codeActionProperties "TFindLiteralDoReturn" [(6, 10)] $ \actions -> do + liftIO $ length actions @?= 4 + , codeActionProperties "TFindLiteralDoLet" [(6, 13), (7, 13)] $ \actions -> do + liftIO $ length actions @?= 8 + , codeActionProperties "TFindLiteralList" [(4, 28)] $ \actions -> do + liftIO $ length actions @?= 4 , conversions ] @@ -143,15 +126,16 @@ doesNotContain :: [CodeAction] -> Text -> Bool acts `doesNotContain` regex = not $ acts `contains` regex -convertPrefix, intoInfix, hexRegex, hexFloatRegex, binaryRegex, octalRegex, numDecimalRegex, decimalRegex :: Text +convertPrefix, intoInfix, maybeExtension, hexRegex, hexFloatRegex, binaryRegex, octalRegex, numDecimalRegex, decimalRegex :: Text convertPrefix = "Convert (" <> T.intercalate "|" [Conversion.hexRegex, Conversion.hexFloatRegex, Conversion.binaryRegex, Conversion.octalRegex, Conversion.numDecimalRegex, Conversion.decimalRegex] <> ")" intoInfix = " into " -hexRegex = intoInfix <> Conversion.hexRegex -hexFloatRegex = intoInfix <> Conversion.hexFloatRegex -binaryRegex = intoInfix <> Conversion.binaryRegex -octalRegex = intoInfix <> Conversion.octalRegex -numDecimalRegex = intoInfix <> Conversion.numDecimalRegex -decimalRegex = intoInfix <> Conversion.decimalRegex +maybeExtension = "( \\(needs extension: .*)?" +hexRegex = intoInfix <> Conversion.hexRegex <> maybeExtension +hexFloatRegex = intoInfix <> Conversion.hexFloatRegex <> maybeExtension +binaryRegex = intoInfix <> Conversion.binaryRegex <> maybeExtension +octalRegex = intoInfix <> Conversion.octalRegex <> maybeExtension +numDecimalRegex = intoInfix <> Conversion.numDecimalRegex <> maybeExtension +decimalRegex = intoInfix <> Conversion.decimalRegex <> maybeExtension isCodeAction :: Text -> Maybe Text -> Bool isCodeAction userRegex (Just txt) = txt =~ Conversion.matchLineRegex (convertPrefix <> userRegex) diff --git a/test/Properties/Conversion.hs b/test/Properties/Conversion.hs --- a/test/Properties/Conversion.hs +++ b/test/Properties/Conversion.hs @@ -17,7 +17,7 @@ ] prop_regexMatchesNumDecimal :: Integer -> Bool -prop_regexMatchesNumDecimal = all (=~ numDecimalRegex) . generateNumDecimal +prop_regexMatchesNumDecimal = (=~ numDecimalRegex) . toFloatExpDecimal . fromInteger prop_regexMatchesHex :: (Integral a, Show a) => a -> Bool prop_regexMatchesHex = (=~ hexRegex ) . toHex diff --git a/test/testdata/TExpectBinaryFormat.hs b/test/testdata/TExpectBinaryFormat.hs deleted file mode 100644 --- a/test/testdata/TExpectBinaryFormat.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE BinaryLiterals #-} -module TExpectBinaryFormat where - -binary = 459 diff --git a/test/testdata/TExpectHexFloatFormat.hs b/test/testdata/TExpectHexFloatFormat.hs deleted file mode 100644 --- a/test/testdata/TExpectHexFloatFormat.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE HexFloatLiterals #-} -module TExpectHexFloatFormat where - -hexFloat = 459.123 diff --git a/test/testdata/TExpectNoBinaryFormat.hs b/test/testdata/TExpectNoBinaryFormat.hs deleted file mode 100644 --- a/test/testdata/TExpectNoBinaryFormat.hs +++ /dev/null @@ -1,3 +0,0 @@ -module TExpectNoBinaryFormat where - -noBinary = 459 diff --git a/test/testdata/TExpectNoHexFloatFormat.hs b/test/testdata/TExpectNoHexFloatFormat.hs deleted file mode 100644 --- a/test/testdata/TExpectNoHexFloatFormat.hs +++ /dev/null @@ -1,3 +0,0 @@ -module TExpectNoHexFloatFormat where - -noHexFloat = 459.123 diff --git a/test/testdata/TExpectNoNumDecimalFormat.hs b/test/testdata/TExpectNoNumDecimalFormat.hs deleted file mode 100644 --- a/test/testdata/TExpectNoNumDecimalFormat.hs +++ /dev/null @@ -1,3 +0,0 @@ -module TExpectNoNumDecimalFormat where - -noNumDecimal = 499999 diff --git a/test/testdata/TExpectNumDecimalFormat.hs b/test/testdata/TExpectNumDecimalFormat.hs deleted file mode 100644 --- a/test/testdata/TExpectNumDecimalFormat.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE NumDecimals #-} -module TExpectNumDecimalFormat where - -numDecimal = 499999 diff --git a/test/testdata/TFindLiteralDoLet.hs b/test/testdata/TFindLiteralDoLet.hs --- a/test/testdata/TFindLiteralDoLet.hs +++ b/test/testdata/TFindLiteralDoLet.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralDoLet where doLet :: IO () diff --git a/test/testdata/TFindLiteralDoReturn.hs b/test/testdata/TFindLiteralDoReturn.hs --- a/test/testdata/TFindLiteralDoReturn.hs +++ b/test/testdata/TFindLiteralDoReturn.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralDoReturn where doReturn :: IO Integer diff --git a/test/testdata/TFindLiteralIntCase.hs b/test/testdata/TFindLiteralIntCase.hs --- a/test/testdata/TFindLiteralIntCase.hs +++ b/test/testdata/TFindLiteralIntCase.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralIntCase where caseExpression x = case x + 34 of diff --git a/test/testdata/TFindLiteralIntCase2.hs b/test/testdata/TFindLiteralIntCase2.hs --- a/test/testdata/TFindLiteralIntCase2.hs +++ b/test/testdata/TFindLiteralIntCase2.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralIntCase where caseExpression x = case x of diff --git a/test/testdata/TFindLiteralIntPattern.hs b/test/testdata/TFindLiteralIntPattern.hs --- a/test/testdata/TFindLiteralIntPattern.hs +++ b/test/testdata/TFindLiteralIntPattern.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralIntPattern where patternMatchingFunction 1 = "one" diff --git a/test/testdata/TFindLiteralList.hs b/test/testdata/TFindLiteralList.hs --- a/test/testdata/TFindLiteralList.hs +++ b/test/testdata/TFindLiteralList.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoBinaryLiterals #-} module TFindLiteralList where listTest = [reverse $ show 57] diff --git a/test/testdata/TFracDtoHF.expected.hs b/test/testdata/TFracDtoHF.expected.hs --- a/test/testdata/TFracDtoHF.expected.hs +++ b/test/testdata/TFracDtoHF.expected.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Haskell2010 #-} {-# LANGUAGE HexFloatLiterals #-} module TFracDtoHF where diff --git a/test/testdata/TFracDtoHF.hs b/test/testdata/TFracDtoHF.hs --- a/test/testdata/TFracDtoHF.hs +++ b/test/testdata/TFracDtoHF.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE HexFloatLiterals #-} +{-# LANGUAGE Haskell2010 #-} module TFracDtoHF where convertMe = 123.45 diff --git a/test/testdata/TFracDtoHFWithPragma.expected.hs b/test/testdata/TFracDtoHFWithPragma.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TFracDtoHFWithPragma.expected.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE HexFloatLiterals #-} +module TFracDtoHFWithPragma where + +convertMe = 0x1.edccccccccccdp6 diff --git a/test/testdata/TFracDtoHFWithPragma.hs b/test/testdata/TFracDtoHFWithPragma.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TFracDtoHFWithPragma.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE HexFloatLiterals #-} +module TFracDtoHFWithPragma where + +convertMe = 123.45 diff --git a/test/testdata/TIntDtoB.expected.hs b/test/testdata/TIntDtoB.expected.hs --- a/test/testdata/TIntDtoB.expected.hs +++ b/test/testdata/TIntDtoB.expected.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Haskell2010 #-} {-# LANGUAGE BinaryLiterals #-} module TIntDtoB where diff --git a/test/testdata/TIntDtoB.hs b/test/testdata/TIntDtoB.hs --- a/test/testdata/TIntDtoB.hs +++ b/test/testdata/TIntDtoB.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE Haskell2010 #-} module TIntDtoB where convertMe = 12 diff --git a/test/testdata/TIntDtoND.expected.hs b/test/testdata/TIntDtoND.expected.hs --- a/test/testdata/TIntDtoND.expected.hs +++ b/test/testdata/TIntDtoND.expected.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE Haskell2010 #-} {-# LANGUAGE NumDecimals #-} module TIntDtoND where convertMe :: Integer -convertMe = 125.345e3 +convertMe = 1.25345e5 diff --git a/test/testdata/TIntDtoND.hs b/test/testdata/TIntDtoND.hs --- a/test/testdata/TIntDtoND.hs +++ b/test/testdata/TIntDtoND.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NumDecimals #-} +{-# LANGUAGE Haskell2010 #-} module TIntDtoND where convertMe :: Integer diff --git a/test/testdata/hie.yaml b/test/testdata/hie.yaml --- a/test/testdata/hie.yaml +++ b/test/testdata/hie.yaml @@ -9,6 +9,7 @@ - TIntDtoND - TFracDtoE - TFracDtoHF + - TFracDtoHFWithPragma - TIntHtoD - TFracHFtoD - TFindLiteralIntPattern