diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,32 +1,31 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} import Control.Applicative (optional) +import Control.Exception (catch) import Control.Monad.Reader import qualified Data.Map as Map +import Data.Maybe import qualified Data.Text as Text +import GHC.Exception import Krank import Krank.Types +import Options.Applicative (many, (<**>)) import qualified Options.Applicative as Opt -import Options.Applicative ((<**>), many) import PyF (fmt) import System.Console.Pretty (supportsPretty) +import System.Environment (lookupEnv) import System.Exit (exitFailure) +import System.Process import Text.Regex.PCRE.Heavy import Version (displayVersion) -import System.Environment (lookupEnv) -import Data.Maybe -import System.Process -import Control.Exception (catch) -import GHC.Exception -data KrankOpts - = KrankOpts - { codeFilePaths :: [FilePath], - krankConfig :: KrankConfig - } +data KrankOpts = KrankOpts + { codeFilePaths :: [FilePath], + krankConfig :: KrankConfig + } filesToParse :: Opt.Parser [FilePath] filesToParse = many (Opt.argument Opt.str (Opt.metavar "FILES..." <> Opt.help "List of file to check. If empty, it will try to use `git ls-files`.")) @@ -110,9 +109,9 @@ -- If files are not explicitly listed, try `git ls-files` and `find`. files <- case codeFilePaths config of - [] -> (lines <$> readProcess "git" ["ls-files"] "") `catch` (\(e :: SomeException) -> noGitFailure e) - l -> pure l - + [] -> (lines <$> readProcess "git" ["ls-files"] "") `catch` (\(e :: SomeException) -> noGitFailure e) + l -> pure l + success <- runReaderT (unKrank $ runKrank files) kConfig unless success exitFailure diff --git a/krank.cabal b/krank.cabal --- a/krank.cabal +++ b/krank.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: krank -version: 0.2.3 +version: 0.3.0 synopsis: Krank checks issue tracker link status in your source code -- description: bug-reports: https://github.com/guibou/krank/issues @@ -18,7 +18,7 @@ common shared-library build-depends: base >= 4.9 , PyF >= 0.8.1.0 - , aeson >= 1.4.4 + , aeson >= 2 , bytestring , containers , http-client >= 0.6 diff --git a/src/Krank.hs b/src/Krank.hs --- a/src/Krank.hs +++ b/src/Krank.hs @@ -79,16 +79,16 @@ krankMapConcurrently f l = Krank $ mapConcurrently (coerce . f) l -- This implements a Req REST request - krankRunRESTRequest url headers = Krank - $ Req.runReq Req.defaultHttpConfig - $ do - r <- - Req.req - Req.GET - url - Req.NoReqBody - Req.jsonResponse - ( Req.header "User-Agent" "krank" - <> headers - ) - pure $ Req.responseBody r + krankRunRESTRequest url headers = Krank $ + Req.runReq Req.defaultHttpConfig $ + do + r <- + Req.req + Req.GET + url + Req.NoReqBody + Req.jsonResponse + ( Req.header "User-Agent" "krank" + <> headers + ) + pure $ Req.responseBody r diff --git a/src/Krank/Checkers/Ignore.hs b/src/Krank/Checkers/Ignore.hs --- a/src/Krank/Checkers/Ignore.hs +++ b/src/Krank/Checkers/Ignore.hs @@ -7,8 +7,8 @@ ) where -import qualified Data.ByteString.Char8 as ByteString import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as ByteString import qualified Data.HashMap.Strict as HashM import qualified Data.List as DataL import Krank.Types diff --git a/src/Krank/Checkers/IssueTracker.hs b/src/Krank/Checkers/IssueTracker.hs --- a/src/Krank/Checkers/IssueTracker.hs +++ b/src/Krank/Checkers/IssueTracker.hs @@ -20,10 +20,10 @@ where import Control.Exception.Safe (catch) -import Data.Aeson ((.:), Value) +import Data.Aeson (Value, (.:)) import qualified Data.Aeson.Types as AesonT -import qualified Data.ByteString.Char8 as ByteString import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as ByteString import qualified Data.Map as Map import Data.Text (Text, pack) import qualified Data.Text.Encoding as Text.Encoding @@ -39,21 +39,19 @@ data IssueStatus = Open | Closed deriving (Eq, Show) -data GitIssueRef - = GitIssueRef - { server :: GitServer, - owner :: Text, - repo :: Text, - issueNum :: Int - } +data GitIssueRef = GitIssueRef + { server :: GitServer, + owner :: Text, + repo :: Text, + issueNum :: Int + } deriving (Eq, Show) -data GitIssueData - = GitIssueData - { gitIssue :: Localized GitIssueRef, - issueStatus :: IssueStatus, - issueTitle :: Text - } +data GitIssueData = GitIssueData + { gitIssue :: Localized GitIssueRef, + issueStatus :: IssueStatus, + issueTitle :: Text + } deriving (Eq, Show) serverDomain :: diff --git a/src/Krank/Types.hs b/src/Krank/Types.hs --- a/src/Krank/Types.hs +++ b/src/Krank/Types.hs @@ -28,48 +28,44 @@ data ViolationLevel = Info | Warning | Error deriving (Show) -data SourcePos - = SourcePos - { file :: FilePath, - lineNumber :: Int, - colNumber :: Int - } +data SourcePos = SourcePos + { file :: FilePath, + lineNumber :: Int, + colNumber :: Int + } deriving (Show, Eq, Ord) -- | Represents a localized chunk of information -- in a file -data Localized t - = Localized - { getLocation :: SourcePos, - unLocalized :: t - } +data Localized t = Localized + { getLocation :: SourcePos, + unLocalized :: t + } deriving (Show, Eq) -data Violation - = Violation - { -- | A textual representation of the checker. Most of the time that's - -- the chunck of text parsed - checker :: Text, - -- | The 'ViolationLevel' associated with the result - level :: ViolationLevel, - -- | A message describing the error - message :: Text, - -- | The position in the input sources of the chunck - location :: SourcePos - } +data Violation = Violation + { -- | A textual representation of the checker. Most of the time that's + -- the chunck of text parsed + checker :: Text, + -- | The 'ViolationLevel' associated with the result + level :: ViolationLevel, + -- | A message describing the error + message :: Text, + -- | The position in the input sources of the chunck + location :: SourcePos + } deriving (Show) -data KrankConfig - = KrankConfig - { -- | The github oAuth token - githubKey :: Maybe GithubKey, - -- | The gitlab oAuth token - gitlabKeys :: Map GitlabHost GitlabKey, - -- | If 'True', all IO operations, such as HTTP requests, are ignored - dryRun :: Bool, - -- | Use color for formatting - useColors :: Bool - } +data KrankConfig = KrankConfig + { -- | The github oAuth token + githubKey :: Maybe GithubKey, + -- | The gitlab oAuth token + gitlabKeys :: Map GitlabHost GitlabKey, + -- | If 'True', all IO operations, such as HTTP requests, are ignored + dryRun :: Bool, + -- | Use color for formatting + useColors :: Bool + } deriving (Show) -- | This monad represents all the effect that Krank needs diff --git a/src/Utils/Github.hs b/src/Utils/Github.hs --- a/src/Utils/Github.hs +++ b/src/Utils/Github.hs @@ -29,10 +29,9 @@ -- "message": "the error reason" -- } -- @ -newtype GithubError - = GithubError - { message :: Text - } +newtype GithubError = GithubError + { message :: Text + } deriving stock (Generic, Show) deriving anyclass (FromJSON, ToJSON) diff --git a/src/Utils/Gitlab.hs b/src/Utils/Gitlab.hs --- a/src/Utils/Gitlab.hs +++ b/src/Utils/Gitlab.hs @@ -29,10 +29,9 @@ -- "message": "the error reason" -- } -- @ -newtype GitlabError - = GitlabError - { message :: Text - } +newtype GitlabError = GitlabError + { message :: Text + } deriving stock (Generic, Show) deriving anyclass (FromJSON, ToJSON) diff --git a/tests/Test/Krank/Checkers/IssueTrackerSpec.hs b/tests/Test/Krank/Checkers/IssueTrackerSpec.hs --- a/tests/Test/Krank/Checkers/IssueTrackerSpec.hs +++ b/tests/Test/Krank/Checkers/IssueTrackerSpec.hs @@ -25,16 +25,14 @@ import PyF (fmt) import Test.Hspec -data TestEnv - = TestEnv - { envFiles :: Map FilePath Data.ByteString.ByteString, - envRestAnswers :: Map (Req.Url 'Req.Https) (Either Req.HttpException Value) - } +data TestEnv = TestEnv + { envFiles :: Map FilePath Data.ByteString.ByteString, + envRestAnswers :: Map (Req.Url 'Req.Https) (Either Req.HttpException Value) + } -newtype TestKrank t - = TestKrank - { unTestKrank :: WriterT ([Text], [Text]) (ReaderT (TestEnv, KrankConfig) (Either SomeException)) t - } +newtype TestKrank t = TestKrank + { unTestKrank :: WriterT ([Text], [Text]) (ReaderT (TestEnv, KrankConfig) (Either SomeException)) t + } deriving newtype (Monad, Applicative, Functor, MonadThrow, MonadCatch) -- | "pure" instance of 'MonadKrank' @@ -114,24 +112,24 @@ giturlTests Github describe "#githlabParser" $ giturlTests (Gitlab (GitlabHost "gitlab.com")) - describe "#extractIssues" - $ it "handles both github and gitlab" - $ do - let match = - extractIssues - "localFile" - [fmt|https://github.com/guibou/krank/issues/2 + describe "#extractIssues" $ + it "handles both github and gitlab" $ + do + let match = + extractIssues + "localFile" + [fmt|https://github.com/guibou/krank/issues/2 some text https://gitlab.com/gitlab-org/gitlab-foss/issues/67390 and more github https://github.com/guibou/krank/issues/1 lalala https://gitlab.haskell.org/ghc/ghc/issues/16955 |] - match - `shouldMatchList` [ Localized (SourcePos "localFile" 1 1) $ GitIssueRef Github "guibou" "krank" 2, - Localized (SourcePos "localFile" 3 9) $ GitIssueRef (Gitlab (GitlabHost "gitlab.com")) "gitlab-org" "gitlab-foss" 67390, - Localized (SourcePos "localFile" 4 25) $ GitIssueRef Github "guibou" "krank" 1, - Localized (SourcePos "localFile" 5 16) $ GitIssueRef (Gitlab (GitlabHost "gitlab.haskell.org")) "ghc" "ghc" 16955 - ] + match + `shouldMatchList` [ Localized (SourcePos "localFile" 1 1) $ GitIssueRef Github "guibou" "krank" 2, + Localized (SourcePos "localFile" 3 9) $ GitIssueRef (Gitlab (GitlabHost "gitlab.com")) "gitlab-org" "gitlab-foss" 67390, + Localized (SourcePos "localFile" 4 25) $ GitIssueRef Github "guibou" "krank" 1, + Localized (SourcePos "localFile" 5 16) $ GitIssueRef (Gitlab (GitlabHost "gitlab.haskell.org")) "ghc" "ghc" 16955 + ] describe "huge test" $ do let config = KrankConfig diff --git a/tests/Test/Utils/GithubSpec.hs b/tests/Test/Utils/GithubSpec.hs --- a/tests/Test/Utils/GithubSpec.hs +++ b/tests/Test/Utils/GithubSpec.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Test.Utils.GithubSpec ( spec, @@ -8,8 +8,8 @@ where import Data.Aeson (Value (..), encode) +import Data.Aeson.KeyMap (singleton) import Data.ByteString.Lazy (ByteString, toStrict) -import Data.HashMap.Strict (singleton) import Data.Text (Text, isInfixOf, isPrefixOf) import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), createCookieJar, defaultRequest) import Network.HTTP.Client.Internal (Response (..), ResponseClose (..)) diff --git a/tests/Test/Utils/GitlabSpec.hs b/tests/Test/Utils/GitlabSpec.hs --- a/tests/Test/Utils/GitlabSpec.hs +++ b/tests/Test/Utils/GitlabSpec.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -- Leaving unnecessary do because -- * they improve readability @@ -15,8 +15,8 @@ where import Data.Aeson (Value (..), encode) +import Data.Aeson.KeyMap (singleton) import Data.ByteString.Lazy (ByteString, toStrict) -import Data.HashMap.Strict (singleton) import Data.Text (Text, isInfixOf, isPrefixOf) import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), createCookieJar, defaultRequest) import Network.HTTP.Client.Internal (Response (..), ResponseClose (..))