diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +1.0.0 + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Mercury Technologies + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Mercury Technologies nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/ghc90/HLint/Plugin.hs b/ghc90/HLint/Plugin.hs new file mode 100644 --- /dev/null +++ b/ghc90/HLint/Plugin.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} + +-- | This module provides a GHC plugin that you can use to run HLint on a +-- module +-- +-- To do so, add this @hlint-plugin@ package as a build dependency of your +-- Haskell package and then add the GHC options @-fplugin HLint.Plugin@ +-- To use this plugin, add this package as a build dependency and then enable +-- the following GHC options (typically in the @ghc-options:@ field of your +-- @.cabal@ file): +-- +-- > -fplugin HLint.Plugin +-- +-- You can pass command-line options to @hlint@ using @-fplugin-opt@, like +-- this: +-- +-- > -fplugin HLint.Plugin -fplugin-opt='HLint.Plugin:--ignore=Redundant guard' +module HLint.Plugin + ( -- * Plugin + plugin + ) where + +import Control.Applicative (empty) +import GHC.Driver.Types (HsParsedModule(..)) +import GHC.Plugins (DynFlags, Plugin(..)) +import GHC.Utils.Error (WarnMsg) +import Language.Haskell.HLint (Idea(..)) + +import qualified GHC.Data.Bag as Bag +import qualified GHC.Plugins as Plugins +import qualified GHC.Utils.Error as Error +import qualified HLint.Plugin.Settings as Settings +import qualified Language.Haskell.HLint as HLint + +-- | GHC plugin that runs HLint on a Haskell module after parsing the module +plugin :: Plugin +plugin = Plugins.defaultPlugin + { parsedResultAction + , pluginRecompile = Plugins.purePlugin + } + where + parsedResultAction arguments _ hsParsedModule = do + (_parseFlags, classifies, hint) <- do + Plugins.liftIO (Settings.argsSettings arguments) + + let HsParsedModule{ hpm_annotations, hpm_module } = hsParsedModule + + dynFlags <- Plugins.getDynFlags + + let moduleEx = HLint.createModuleEx hpm_annotations hpm_module + + let ideas = HLint.applyHints classifies hint [moduleEx] + + let msgEnvelopes = concatMap (ideaToMsgEnvelope dynFlags) ideas + + let messages = Bag.listToBag msgEnvelopes + + Plugins.liftIO (Plugins.printOrThrowWarnings dynFlags messages) + + pure hsParsedModule + +ideaToMsgEnvelope :: DynFlags -> Idea -> [WarnMsg] +ideaToMsgEnvelope dynFlags Idea{..} = do + makeMessage <- case ideaSeverity of + HLint.Ignore -> empty + HLint.Suggestion -> pure Error.mkPlainWarnMsg + HLint.Warning -> pure Error.mkPlainWarnMsg + HLint.Error -> pure Error.mkPlainErrMsg + + return (makeMessage dynFlags ideaSpan sdoc) + where + sdoc = Plugins.vcat (sdocs0 <> sdocs1 <> sdocs2) + where + sdocs0 = [ Plugins.text ideaHint ] + + sdocs1 = + case ideaTo of + Nothing -> [] + Just "" -> [] + Just to -> [ Plugins.text ("Perhaps: " <> to) ] + + sdocs2 = do + note <- ideaNote + + pure (Plugins.text ("Note: " <> show note)) diff --git a/ghc92/HLint/Plugin.hs b/ghc92/HLint/Plugin.hs new file mode 100644 --- /dev/null +++ b/ghc92/HLint/Plugin.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} + +-- | This module provides a GHC plugin that you can use to run HLint on a +-- module +-- +-- To do so, add this @hlint-plugin@ package as a build dependency of your +-- Haskell package and then add the GHC options @-fplugin HLint.Plugin@ +-- To use this plugin, add this package as a build dependency and then enable +-- the following GHC options (typically in the @ghc-options:@ field of your +-- @.cabal@ file): +-- +-- > -fplugin HLint.Plugin +-- +-- You can pass command-line options to @hlint@ using @-fplugin-opt@, like +-- this: +-- +-- > -fplugin HLint.Plugin -fplugin-opt='HLint.Plugin:--ignore=Redundant guard' +module HLint.Plugin + ( -- * Plugin + plugin + ) where + +import GHC.Driver.Flags (WarnReason(..)) +import GHC.Hs (HsParsedModule(..)) +import GHC.Plugins (Plugin(..)) +import GHC.Types.Error (DecoratedSDoc, MsgEnvelope(..)) +import Language.Haskell.HLint (Idea(..)) + +import qualified GHC.Data.Bag as Bag +import qualified GHC.Driver.Errors as Errors +import qualified GHC.Plugins as Plugins +import qualified GHC.Types.Error as Error +import qualified GHC.Utils.Logger as Logger +import qualified GHC.Utils.Outputable as Outputable +import qualified HLint.Plugin.Settings as Settings +import qualified Language.Haskell.HLint as HLint + +-- | GHC plugin that runs HLint on a Haskell module after parsing the module +plugin :: Plugin +plugin = Plugins.defaultPlugin + { parsedResultAction + , pluginRecompile = Plugins.purePlugin + } + where + parsedResultAction arguments _ hsParsedModule = do + (_parseFlags, classifies, hint) <- do + Plugins.liftIO (Settings.argsSettings arguments) + + let HsParsedModule{ hpm_module } = hsParsedModule + + dynFlags <- Plugins.getDynFlags + + logger <- Logger.getLogger + + let moduleEx = HLint.createModuleEx hpm_module + + let ideas = HLint.applyHints classifies hint [moduleEx] + + let msgEnvelopes = map ideaToMsgEnvelope ideas + + let messages = Bag.listToBag msgEnvelopes + + Plugins.liftIO (Errors.printOrThrowWarnings logger dynFlags messages) + + pure hsParsedModule + +ideaToMsgEnvelope :: Idea -> MsgEnvelope DecoratedSDoc +ideaToMsgEnvelope Idea{..} = MsgEnvelope{..} + where + errMsgDiagnostic = + Error.mkDecorated [ Plugins.vcat (sdocs0 <> sdocs1 <> sdocs2) ] + where + sdocs0 = [ Plugins.text ideaHint ] + + sdocs1 = + case ideaTo of + Nothing -> [] + Just "" -> [] + Just to -> [ Plugins.text ("Perhaps: " <> to) ] + + sdocs2 = do + note <- ideaNote + + pure (Plugins.text ("Note: " <> show note)) + + errMsgSpan = ideaSpan + + errMsgContext = Outputable.alwaysQualify + + errMsgSeverity = + case ideaSeverity of + HLint.Ignore -> Error.SevDump + HLint.Suggestion -> Error.SevInfo + HLint.Warning -> Error.SevWarning + HLint.Error -> Error.SevError + + errMsgReason = NoReason diff --git a/ghc94/HLint/Plugin.hs b/ghc94/HLint/Plugin.hs new file mode 100644 --- /dev/null +++ b/ghc94/HLint/Plugin.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} + +-- | This module provides a GHC plugin that you can use to run HLint on a +-- module +-- +-- To do so, add this @hlint-plugin@ package as a build dependency of your +-- Haskell package and then add the GHC options @-fplugin HLint.Plugin@ +-- To use this plugin, add this package as a build dependency and then enable +-- the following GHC options (typically in the @ghc-options:@ field of your +-- @.cabal@ file): +-- +-- > -fplugin HLint.Plugin +-- +-- You can pass command-line options to @hlint@ using @-fplugin-opt@, like +-- this: +-- +-- > -fplugin HLint.Plugin -fplugin-opt='HLint.Plugin:--ignore=Redundant guard' +module HLint.Plugin + ( -- * Plugin + plugin + ) where + +import GHC.Driver.Errors.Types (GhcMessage) +import GHC.Hs (HsParsedModule(..)) +import GHC.Plugins (Plugin(..)) +import Language.Haskell.HLint (Idea(..)) + +import GHC.Types.Error + ( DiagnosticMessage(..) + , DiagnosticReason(..) + , MsgEnvelope(..) + ) + +import qualified GHC.Data.Bag as Bag +import qualified GHC.Driver.Config.Diagnostic as Diagnostic +import qualified GHC.Driver.Errors as Errors +import qualified GHC.Driver.Errors.Types as Errors.Types +import qualified GHC.Plugins as Plugins +import qualified GHC.Types.Error as Error +import qualified GHC.Utils.Logger as Logger +import qualified GHC.Utils.Outputable as Outputable +import qualified HLint.Plugin.Settings as Settings +import qualified Language.Haskell.HLint as HLint + +-- | GHC plugin that runs HLint on a Haskell module after parsing the module +plugin :: Plugin +plugin = Plugins.defaultPlugin + { parsedResultAction + , pluginRecompile = Plugins.purePlugin + } + where + parsedResultAction arguments _ parsedResult = do + (_parseFlags, classifies, hint) <- do + Plugins.liftIO (Settings.argsSettings arguments) + + dynFlags <- Plugins.getDynFlags + + logger <- Logger.getLogger + + let HsParsedModule{ hpm_module } = + Plugins.parsedResultModule parsedResult + + let moduleEx = HLint.createModuleEx hpm_module + + let ideas = HLint.applyHints classifies hint [moduleEx] + + let msgEnvelopes = map ideaToMsgEnvelope ideas + + let messages = Error.mkMessages (Bag.listToBag msgEnvelopes) + + let diagOpts = Diagnostic.initDiagOpts dynFlags + + Plugins.liftIO (Errors.printOrThrowDiagnostics logger diagOpts messages) + + pure parsedResult + +ideaToMsgEnvelope :: Idea -> MsgEnvelope GhcMessage +ideaToMsgEnvelope Idea{..} = MsgEnvelope{..} + where + sdoc = Plugins.vcat (sdocs0 <> sdocs1 <> sdocs2) + where + sdocs0 = [ Plugins.text ideaHint ] + + sdocs1 = + case ideaTo of + Nothing -> [] + Just "" -> [] + Just to -> [ Plugins.text ("Perhaps: " <> to) ] + + sdocs2 = do + note <- ideaNote + + pure (Plugins.text ("Note: " <> show note)) + + errMsgSpan = ideaSpan + + errMsgContext = Outputable.alwaysQualify + + diagnosticMessage = DiagnosticMessage{..} + where + diagMessage = Error.mkSimpleDecorated sdoc + diagReason = + case ideaSeverity of + HLint.Ignore -> WarningWithoutFlag + HLint.Suggestion -> WarningWithoutFlag + HLint.Warning -> WarningWithoutFlag + HLint.Error -> ErrorWithoutFlag + + diagHints = [] + + errMsgDiagnostic = + Errors.Types.ghcUnknownMessage diagnosticMessage + + errMsgSeverity = + case ideaSeverity of + HLint.Ignore -> Error.SevIgnore + HLint.Suggestion -> Error.SevWarning + HLint.Warning -> Error.SevWarning + HLint.Error -> Error.SevError diff --git a/ghc96/HLint/Plugin.hs b/ghc96/HLint/Plugin.hs new file mode 100644 --- /dev/null +++ b/ghc96/HLint/Plugin.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} + +-- | This module provides a GHC plugin that you can use to run HLint on a +-- module +-- +-- To do so, add this @hlint-plugin@ package as a build dependency of your +-- Haskell package and then add the GHC options @-fplugin HLint.Plugin@ +-- To use this plugin, add this package as a build dependency and then enable +-- the following GHC options (typically in the @ghc-options:@ field of your +-- @.cabal@ file): +-- +-- > -fplugin HLint.Plugin +-- +-- You can pass command-line options to @hlint@ using @-fplugin-opt@, like +-- this: +-- +-- > -fplugin HLint.Plugin -fplugin-opt='HLint.Plugin:--ignore=Redundant guard' +module HLint.Plugin + ( -- * Plugin + plugin + ) where + +import GHC.Driver.Errors.Types (GhcMessage) +import GHC.Hs (HsParsedModule(..)) +import GHC.Plugins (Plugin(..)) +import Language.Haskell.HLint (Idea(..)) + +import GHC.Types.Error + ( DiagnosticMessage(..) + , DiagnosticReason(..) + , MsgEnvelope(..) + ) + +import qualified GHC.Data.Bag as Bag +import qualified GHC.Driver.Config.Diagnostic as Diagnostic +import qualified GHC.Driver.Errors as Errors +import qualified GHC.Driver.Errors.Types as Errors.Types +import qualified GHC.Plugins as Plugins +import qualified GHC.Types.Error as Error +import qualified GHC.Utils.Logger as Logger +import qualified GHC.Utils.Outputable as Outputable +import qualified HLint.Plugin.Settings as Settings +import qualified Language.Haskell.HLint as HLint + +-- | GHC plugin that runs HLint on a Haskell module after parsing the module +plugin :: Plugin +plugin = Plugins.defaultPlugin + { parsedResultAction + , pluginRecompile = Plugins.purePlugin + } + where + parsedResultAction arguments _ parsedResult = do + (_parseFlags, classifies, hint) <- do + Plugins.liftIO (Settings.argsSettings arguments) + + dynFlags <- Plugins.getDynFlags + + logger <- Logger.getLogger + + let HsParsedModule{ hpm_module } = + Plugins.parsedResultModule parsedResult + + let moduleEx = HLint.createModuleEx hpm_module + + let ideas = HLint.applyHints classifies hint [moduleEx] + + let msgEnvelopes = map ideaToMsgEnvelope ideas + + let messages = Error.mkMessages (Bag.listToBag msgEnvelopes) + + let diagOpts = Diagnostic.initDiagOpts dynFlags + + let ghcMessageOpts = Diagnostic.initPrintConfig dynFlags + + Plugins.liftIO (Errors.printOrThrowDiagnostics logger ghcMessageOpts diagOpts messages) + + pure parsedResult + +ideaToMsgEnvelope :: Idea -> MsgEnvelope GhcMessage +ideaToMsgEnvelope Idea{..} = MsgEnvelope{..} + where + sdoc = Plugins.vcat (sdocs0 <> sdocs1 <> sdocs2) + where + sdocs0 = [ Plugins.text ideaHint ] + + sdocs1 = + case ideaTo of + Nothing -> [] + Just "" -> [] + Just to -> [ Plugins.text ("Perhaps: " <> to) ] + + sdocs2 = do + note <- ideaNote + + pure (Plugins.text ("Note: " <> show note)) + + errMsgSpan = ideaSpan + + errMsgContext = Outputable.alwaysQualify + + diagnosticMessage = DiagnosticMessage{..} + where + diagMessage = Error.mkSimpleDecorated sdoc + diagReason = + case ideaSeverity of + HLint.Ignore -> WarningWithoutFlag + HLint.Suggestion -> WarningWithoutFlag + HLint.Warning -> WarningWithoutFlag + HLint.Error -> ErrorWithoutFlag + + diagHints = [] + + errMsgDiagnostic = + Errors.Types.ghcUnknownMessage diagnosticMessage + + errMsgSeverity = + case ideaSeverity of + HLint.Ignore -> Error.SevIgnore + HLint.Suggestion -> Error.SevWarning + HLint.Warning -> Error.SevWarning + HLint.Error -> Error.SevError diff --git a/hlint-plugin.cabal b/hlint-plugin.cabal new file mode 100644 --- /dev/null +++ b/hlint-plugin.cabal @@ -0,0 +1,43 @@ +cabal-version: 3.0 +name: hlint-plugin +version: 1.0.0 +synopsis: GHC plugin for hlint +description: This package provides an GHC plugin that runs `hlint` on the + compiled module. The main advantages of doing this are: + . + * Better integration with GHC tooling + * You only have to lint modules that you rebuild + * You don't have to parse the module twice +license: BSD-3-Clause +license-file: LICENSE +author: Mercury Technologies +maintainer: gabriella@mercury.com +copyright: 2023 Mercury Technologies +build-type: Simple +extra-doc-files: CHANGELOG.md + +library + hs-source-dirs: src + build-depends: base >=4.15.0.0 && < 5 + , containers + exposed-modules: HLint.Plugin + , HLint.Plugin.Settings + default-language: Haskell2010 + ghc-options: -Wall + + if impl(ghc >= 9.0 && < 9.2) + hs-source-dirs: ghc90 + build-depends: hlint >= 3.3 && < 3.4 + , ghc >= 9.0.2 && < 9.2 + if impl(ghc >= 9.2 && < 9.4) + hs-source-dirs: ghc92 + build-depends: hlint >= 3.4 && < 3.5 + , ghc >= 9.2.1 && < 9.4 + if impl(ghc >= 9.4 && < 9.6) + hs-source-dirs: ghc94 + build-depends: hlint >= 3.5 && < 3.6 + , ghc >= 9.4.1 && < 9.6 + if impl(ghc >= 9.6 && < 9.8) + hs-source-dirs: ghc96 + build-depends: hlint >= 3.6 && < 3.7 + , ghc >= 9.6.1 && < 9.8 diff --git a/src/HLint/Plugin/Settings.hs b/src/HLint/Plugin/Settings.hs new file mode 100644 --- /dev/null +++ b/src/HLint/Plugin/Settings.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE BlockArguments #-} + +-- | This module is inspired by: +-- +-- https://github.com/tfausak/splint/blob/9028a8b631568dc5d16a74153b1a9b6e3cde0fe6/src/lib/Splint/Settings.hs +-- +-- … in order to work around this issue (just like @splint@ does): +-- +-- +-- +-- Without this workaround the GHC plugin will fail with something like this +-- error message: +-- +-- > ghc-9.6.2(82937,0x16e83b000) malloc: *** error for object 0x600000a4d5c0: pointer being freed was not allocated +-- > ghc-9.6.2(82937,0x16e83b000) malloc: *** set a breakpoint in malloc_error_break to debug + +module HLint.Plugin.Settings + ( -- * Settings + argsSettings + ) where + +import Control.Concurrent.MVar (MVar) +import Data.IORef (IORef) +import Data.Map (Map) +import Language.Haskell.HLint (Classify, Hint, ParseFlags) + +import qualified Control.Concurrent.MVar as MVar +import qualified Data.IORef as IORef +import qualified Data.Map as Map +import qualified Language.Haskell.HLint as HLint +import qualified System.IO.Unsafe as Unsafe + +cache :: IORef (Map [String] (IO (ParseFlags, [Classify], Hint))) +cache = Unsafe.unsafePerformIO (IORef.newIORef Map.empty) +{-# NOINLINE cache #-} + +semaphore :: MVar () +semaphore = Unsafe.unsafePerformIO (MVar.newMVar ()) +{-# NOINLINE semaphore #-} + +-- | This is a drop-in replacement for +-- "Language.Haskell.HLint".`HLint.argsSettings`, except that this is safe to +-- run in parallel. +argsSettings + :: [String] + -> IO (ParseFlags, [Classify], Hint) +argsSettings key = do + io <- IORef.atomicModifyIORef' cache \m -> do + case Map.lookup key m of + Nothing -> do + let io = + Unsafe.unsafeInterleaveIO do + MVar.withMVar semaphore \_ -> HLint.argsSettings key + + (Map.insert key io m, io) + + Just io -> + (m, io) + + io