diff --git a/splint.cabal b/splint.cabal --- a/splint.cabal +++ b/splint.cabal @@ -1,5 +1,7 @@ +cabal-version: 2.2 + name: splint -version: 1.0.0.1 +version: 1.0.1.0 synopsis: HLint as a GHC source plugin. description: @@ -9,7 +11,6 @@ to ignore the "Use @concatMap@" suggestion. build-type: Simple -cabal-version: >= 1.10 category: Development extra-source-files: README.markdown license-file: LICENSE.markdown @@ -20,17 +21,38 @@ location: https://github.com/tfausak/splint type: git -library - build-depends: - base >= 4.14.0 && < 4.15 - , ghc >= 8.10.1 && < 8.11 - , hlint >= 3.0 && < 3.2 +common basics default-language: Haskell2010 - exposed-modules: Splint ghc-options: -Weverything + -Wno-all-missed-specialisations -Wno-implicit-prelude - -Wno-missing-safe-haskell-mode - -Wno-prepositive-qualified-module + -Wno-missing-exported-signatures + -Wno-missing-import-lists + -Wno-safe -Wno-unsafe + + if impl(ghc >= 8.8) + ghc-options: + -Wno-missing-deriving-strategies + + if impl(ghc >= 8.10) + ghc-options: + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module + +library + import: basics + + build-depends: + base >= 4.12.0 && < 4.15 + , ghc >= 8.6.1 && < 8.11 + , hlint >= 3.0 && < 3.2 + exposed-modules: Splint hs-source-dirs: src/lib + other-modules: Splint.Parser + + if impl(ghc == 8.10.*) + other-modules: Splint.Parser.Native + else + other-modules: Splint.Parser.Fallback diff --git a/src/lib/Splint.hs b/src/lib/Splint.hs --- a/src/lib/Splint.hs +++ b/src/lib/Splint.hs @@ -1,10 +1,14 @@ -module Splint ( plugin ) where +module Splint + ( plugin + ) +where import qualified Bag as GHC import qualified Data.IORef as IORef import qualified ErrUtils as GHC import qualified GhcPlugins as GHC import qualified Language.Haskell.HLint as HLint +import qualified Splint.Parser as Splint import qualified System.IO.Unsafe as Unsafe plugin :: GHC.Plugin @@ -18,25 +22,22 @@ -> GHC.ModSummary -> GHC.HsParsedModule -> GHC.Hsc GHC.HsParsedModule -action commandLineOptions _modSummary hsParsedModule = do +action commandLineOptions modSummary hsParsedModule = do + (parseFlags, classifies, hint) <- getSettings commandLineOptions + moduleEx <- Splint.parse parseFlags modSummary hsParsedModule dynFlags <- GHC.getDynFlags - GHC.liftIO $ do - (_parseFlags, classifies, hint) <- getSettings commandLineOptions - let - apiAnns = GHC.hpm_annotations hsParsedModule - hsModule = GHC.hpm_module hsParsedModule - moduleEx = HLint.createModuleEx apiAnns hsModule - ideas = HLint.applyHints classifies hint [moduleEx] - GHC.printOrThrowWarnings dynFlags - . GHC.listToBag - . fmap (ideaToWarnMsg dynFlags) - $ filter ((/= HLint.Ignore) . HLint.ideaSeverity) ideas + GHC.liftIO + . GHC.printOrThrowWarnings dynFlags + . GHC.listToBag + . fmap (ideaToWarnMsg dynFlags) + . filter ((/= HLint.Ignore) . HLint.ideaSeverity) + $ HLint.applyHints classifies hint [moduleEx] pure hsParsedModule type Settings = (HLint.ParseFlags, [HLint.Classify], HLint.Hint) -getSettings :: [GHC.CommandLineOption] -> IO Settings -getSettings commandLineOptions = do +getSettings :: [GHC.CommandLineOption] -> GHC.Hsc Settings +getSettings commandLineOptions = GHC.liftIO $ do maybeSettings <- IORef.readIORef settingsRef case maybeSettings of Just settings -> pure settings @@ -55,7 +56,12 @@ mkErrMsg = case HLint.ideaSeverity idea of HLint.Error -> GHC.mkPlainErrMsg _ -> GHC.mkPlainWarnMsg - srcSpan = HLint.ideaSpan idea + srcSpan = case HLint.unpackSrcSpan $ HLint.ideaSpan idea of + Nothing -> GHC.noSrcSpan + Just (file, (startLine, startColumn), (endLine, endColumn)) -> + GHC.mkSrcSpan + (GHC.mkSrcLoc (GHC.mkFastString file) startLine startColumn) + (GHC.mkSrcLoc (GHC.mkFastString file) endLine endColumn) msgDoc = ideaToMsgDoc idea in mkErrMsg dynFlags srcSpan msgDoc diff --git a/src/lib/Splint/Parser.hs b/src/lib/Splint/Parser.hs new file mode 100644 --- /dev/null +++ b/src/lib/Splint/Parser.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +-- | Starting with HLint 3, it's possible to re-use the parsed module that GHC +-- produces to avoid re-parsing the module. Unfortunately this is only possible +-- when the GHC version matches the version that HLint expects. Otherwise we +-- have to let HLint re-parse the module to produce it's expected AST. +-- +-- This module is responsible for picking that behavior. The so-called "native" +-- behavior is the one where GHC's parse module is re-used. The "fallback" +-- parser is the one that re-parses the module. +-- +-- Doing this requires a build-time decision, which means using CPP. Therefore +-- this module is kept as small as possible in order to make it easier to +-- reason about. +-- +-- It is expected that both the "native" and "fallback" parsers expose the +-- exact same interface. +-- +-- You could in theory always use the "fallback" parser, but that would mean +-- doing a lot of unnecessary work by re-parsing modules. Parsing is typically +-- fast and this is hard to quantify, so if you want to go that route you +-- should consider using Ollie Charles's hlint-source-plugin instead. +-- +module Splint.Parser + ( parse + ) +where + +#if (__GLASGOW_HASKELL__ == 810) +import Splint.Parser.Native (parse) +#else +import Splint.Parser.Fallback (parse) +#endif diff --git a/src/lib/Splint/Parser/Fallback.hs b/src/lib/Splint/Parser/Fallback.hs new file mode 100644 --- /dev/null +++ b/src/lib/Splint/Parser/Fallback.hs @@ -0,0 +1,35 @@ +module Splint.Parser.Fallback + ( parse + ) +where + +import qualified Control.Exception as Exception +import qualified GhcPlugins as GHC +import qualified Language.Haskell.HLint as HLint + +parse + :: HLint.ParseFlags + -> GHC.ModSummary + -> GHC.HsParsedModule + -> GHC.Hsc HLint.ModuleEx +parse parseFlags modSummary _ = GHC.liftIO $ do + let filePath = GHC.msHsFilePath modSummary + result <- HLint.parseModuleEx parseFlags filePath Nothing + case result of + Left parseError -> Exception.throwIO $ ParseError parseError + Right moduleEx -> pure moduleEx + +newtype ParseError = ParseError HLint.ParseError + +instance Exception.Exception ParseError + +instance Show ParseError where + show (ParseError parseError) = mconcat + [ "ParseError { parseErrorLocation = " + , show $ HLint.parseErrorLocation parseError + , ", parseErrorMessage = " + , show $ HLint.parseErrorMessage parseError + , ", parseErrorContents = " + , show $ HLint.parseErrorContents parseError + , " }" + ] diff --git a/src/lib/Splint/Parser/Native.hs b/src/lib/Splint/Parser/Native.hs new file mode 100644 --- /dev/null +++ b/src/lib/Splint/Parser/Native.hs @@ -0,0 +1,18 @@ +module Splint.Parser.Native + ( parse + ) +where + +import qualified GhcPlugins as GHC +import qualified Language.Haskell.HLint as HLint + +parse + :: HLint.ParseFlags + -> GHC.ModSummary + -> GHC.HsParsedModule + -> GHC.Hsc HLint.ModuleEx +parse _ _ hsParsedModule = do + let + apiAnns = GHC.hpm_annotations hsParsedModule + hsModule = GHC.hpm_module hsParsedModule + pure $ HLint.createModuleEx apiAnns hsModule