krank 0.2.3 → 0.3.0
raw patch · 11 files changed
+103/−114 lines, 11 filesdep ~aeson
Dependency ranges changed: aeson
Files
- app/Main.hs +14/−15
- krank.cabal +2/−2
- src/Krank.hs +13/−13
- src/Krank/Checkers/Ignore.hs +1/−1
- src/Krank/Checkers/IssueTracker.hs +13/−15
- src/Krank/Types.hs +30/−34
- src/Utils/Github.hs +3/−4
- src/Utils/Gitlab.hs +3/−4
- tests/Test/Krank/Checkers/IssueTrackerSpec.hs +20/−22
- tests/Test/Utils/GithubSpec.hs +2/−2
- tests/Test/Utils/GitlabSpec.hs +2/−2
app/Main.hs view
@@ -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
krank.cabal view
@@ -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
src/Krank.hs view
@@ -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
src/Krank/Checkers/Ignore.hs view
@@ -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
src/Krank/Checkers/IssueTracker.hs view
@@ -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 ::
src/Krank/Types.hs view
@@ -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
src/Utils/Github.hs view
@@ -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)
src/Utils/Gitlab.hs view
@@ -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)
tests/Test/Krank/Checkers/IssueTrackerSpec.hs view
@@ -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
tests/Test/Utils/GithubSpec.hs view
@@ -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 (..))
tests/Test/Utils/GitlabSpec.hs view
@@ -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 (..))