diff --git a/shift.cabal b/shift.cabal
index 5bcef314a2c5a5a6945eb84f7182fcdd0e367da2..523d573042d51cde5a7a3d25d73b7c248195f670 100644
--- a/shift.cabal
+++ b/shift.cabal
@@ -26,8 +26,8 @@ library
, GitHub.UserSearch
build-depends: base >= 4.7 && < 5
, versions
- , hit
, text
+ , hgit
, containers
, megaparsec
, unordered-containers
diff --git a/src/Shift/Git.hs b/src/Shift/Git.hs
index 8780720066fb2f2130b0562dd4ebd6cbfd36926f..1863b6c957da35e7216c32a28c5850148c80d4ac 100644
--- a/src/Shift/Git.hs
+++ b/src/Shift/Git.hs
@@ -1,45 +1,45 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes #-}
module Shift.Git where
-import Control.Monad (void)
-import Data.Either (rights)
-import Data.List (sortBy)
-import Data.Maybe (catMaybes)
-import Data.Set as S (toList)
-import Data.Tuple (swap)
-import System.Process
-
-import Control.Lens ((^.))
-import Control.Monad.Catch (throwM)
-import Control.Monad.Reader (runReaderT)
-import Control.Monad.State (runStateT)
-import Control.Monad.Trans (liftIO)
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as BS
-import Data.Default (def)
-import Data.Git
-import Data.Git.Ref (fromHex, isHex)
-import Data.Git.Storage.Object
-import Data.String.Conversions (cs)
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as TIO
-import Data.Versions (parseV)
-import GitHub.Auth (Auth (OAuth))
-import Network.HTTP.Client (newManager)
-import Network.HTTP.Client.TLS (tlsManagerSettings)
-import Text.Megaparsec (Dec, ParseError)
-
+import Control.Lens ((^.))
+import Control.Monad (void)
+import Control.Monad.Catch (throwM)
+import Control.Monad.Reader (runReaderT)
+import Control.Monad.State (runStateT)
+import Control.Monad.Trans (liftIO)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as BS
+import Data.Default (def)
+import Data.Either (rights)
+import Data.Git
+import Data.Git.Ref (HashAlgorithm, fromHex, isHex)
+import Data.Git.Storage.Object
+import Data.List (sortBy)
+import Data.Maybe (catMaybes)
+import Data.Set as S (toList)
+import Data.String.Conversions (cs)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import Data.Tuple (swap)
+import Data.Versions (versioning)
+import Data.Void (Void)
+import GitHub.Auth (Auth (OAuth))
+import Network.HTTP.Client (newManager)
+import Network.HTTP.Client.TLS (tlsManagerSettings)
import Shift.CLI
import Shift.Processing
import Shift.Rendering
import Shift.Types
-import Shift.Utilities (orError, pairs)
+import Shift.Utilities (orError, pairs)
+import System.Process
+import Text.Megaparsec (ParseError)
+import Text.Megaparsec.Error (ParseErrorBundle)
-parseTag :: RefName -> Either (ParseError Char Dec) TagRef
-parseTag ref = case parseV . cs . refNameRaw $ ref of
+parseTag :: RefName -> Either (ParseErrorBundle Text Void) TagRef
+parseTag ref = case versioning . cs . refNameRaw $ ref of
Left e -> Left e
Right v -> Right (TagRef ref v)
@@ -57,28 +57,30 @@ tempMain opts = withRepo ".git" $ \repo -> do
runReaderT
(void $ runStateT (mapM_ (renderDiff repo) pairedTags) state)
opts
- GitType -> runReaderT
- (void $ runStateT (mapM_ (renderDiff repo) pairedTags) GitClientState)
- opts
-
+ GitType ->
+ runReaderT
+ (void $ runStateT (mapM_ (renderDiff repo) pairedTags) GitClientState)
+ opts
where
initGitHubState = do
manager <- newManager tlsManagerSettings
token <- (opts ^. soGitHubToken) `orError` SEMissingGitHubToken
repositoryOwner <- (opts ^. soGitHubOwner) `orError` SEMissingGitHubOwner
- repositoryName <- (opts ^. soGitHubRepository)
- `orError` SEMissingGitHubRepository
-
- pure GitHubClientState
- { _gcsCache = def
- , _gcsAuth = OAuth (cs token)
- , _gcsManager = manager
- , _gcsOwner = cs repositoryOwner
- , _gcsRepository = cs repositoryName
- }
-
-renderDiff :: ClientState s => Git -> (TagRef, TagRef) -> GitM s ()
+ repositoryName <-
+ (opts ^. soGitHubRepository)
+ `orError` SEMissingGitHubRepository
+
+ pure
+ GitHubClientState
+ { _gcsCache = def,
+ _gcsAuth = OAuth (cs token),
+ _gcsManager = manager,
+ _gcsOwner = cs repositoryOwner,
+ _gcsRepository = cs repositoryName
+ }
+
+renderDiff :: (ClientState s, HashAlgorithm hash) => Git hash -> (TagRef, TagRef) -> GitM s ()
renderDiff repo (tx, ty) = do
liftIO . TIO.putStrLn . headerOne $ renderRange tx ty
@@ -88,34 +90,35 @@ renderDiff repo (tx, ty) = do
[] -> throwM SEUnableToComputeDiff
diff_ -> printReport (generateReport . rights $ parseCommit <$> diff_)
-lookupCommitsDiff :: Git -> TagRef -> TagRef -> GitM s [(Ref, Commit)]
+lookupCommitsDiff :: (HashAlgorithm hash) => Git hash -> TagRef -> TagRef -> GitM s [(Ref hash, Commit hash)]
lookupCommitsDiff repo x y = do
rawOutput <- liftIO $ readCreateProcess (shell gitCommand) ""
- catMaybes <$> mapM
- (lookupRawRef repo)
- (filter (not . T.null) . T.splitOn "\n" . cs $ rawOutput)
-
+ catMaybes
+ <$> mapM
+ (lookupRawRef repo)
+ (filter (not . T.null) . T.splitOn "\n" . cs $ rawOutput)
where
- gitCommand = mconcat
- [ "git rev-list "
- , refNameRaw . _tRef $ x
- , "..."
- , refNameRaw . _tRef $ y
- ]
-
-lookupRawRef :: Git -> Text -> GitM s (Maybe (Ref, Commit))
-lookupRawRef repo rr
- = if isHex . cs $ rr
+ gitCommand =
+ mconcat
+ [ "git rev-list ",
+ refNameRaw . _tRef $ x,
+ "...",
+ refNameRaw . _tRef $ y
+ ]
+
+lookupRawRef :: (HashAlgorithm hash) => Git hash -> Text -> GitM s (Maybe (Ref hash, Commit hash))
+lookupRawRef repo rr =
+ if isHex . cs $ rr
then do
- let ref = fromHex . cs $ rr
+ let ref = fromHex . cs $ rr
- object <- liftIO $ getObject repo ref True
+ object <- liftIO $ getObject repo ref True
- case object of
- Just (ObjCommit commit) -> pure $ Just (ref, commit)
- _ -> pure Nothing
+ case object of
+ Just (ObjCommit commit) -> pure $ Just (ref, commit)
+ _ -> pure Nothing
else pure Nothing
-commitSummary :: Commit -> ByteString
+commitSummary :: Commit hash -> ByteString
commitSummary = head . BS.split '\n' . commitMessage
diff --git a/src/Shift/Parsers.hs b/src/Shift/Parsers.hs
index d305d4bae4d5331ff0858b62b3211411a1723347..ed47d3511b1ac12b699d92acafa7edb882574ef3 100644
--- a/src/Shift/Parsers.hs
+++ b/src/Shift/Parsers.hs
@@ -1,36 +1,38 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
module Shift.Parsers where
-import Control.Monad (void)
-import Data.List.NonEmpty (NonEmpty ((:|)))
+import Control.Monad (void)
+import Data.HashSet (HashSet, fromList)
+import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
-
-import Data.HashSet (HashSet, fromList)
import Data.String.Conversions (cs)
+import Data.Text (Text)
+import Data.Void (Void)
+import Shift.Types
import Text.Megaparsec
-import Text.Megaparsec.Text
+import Text.Megaparsec.Char (char, eol, spaceChar, string)
-import Shift.Types
+type Parser = Parsec Void Text
commit :: Parser ParsedCommit
-commit
- = (PCConventional <$> conventionalCommit)
- <|> try (PCMerge <$> mergeCommit)
- <|> (PCMisc <$> miscCommit)
+commit =
+ (PCConventional <$> conventionalCommit)
+ <|> try (PCMerge <$> mergeCommit)
+ <|> (PCMisc <$> miscCommit)
spaced :: Parser a -> Parser a
-spaced = (*>) $ many (some spaceChar <|> eol)
+spaced = (*>) $ many (void (some spaceChar) <|> void eol)
oneParserOf :: NE.NonEmpty (Parser a) -> Parser a
oneParserOf (NE.reverse -> (x :| xs)) = foldl (\acc y -> try y <|> acc) x xs
-manyCharsTill :: Parser end -> Parser [Char]
-manyCharsTill = manyTill anyChar
+manyCharsTill :: Parser end -> Parser [Token Text]
+manyCharsTill = manyTill anySingle
-someCharsTill :: Parser end -> Parser [Char]
-someCharsTill = someTill anyChar
+someCharsTill :: Parser end -> Parser [Token Text]
+someCharsTill = someTill anySingle
conventionalCommit :: Parser ConventionalCommit
conventionalCommit = do
@@ -48,21 +50,30 @@ conventionalCommit = do
cBreakingChanges <- many (try breakingChange)
cTicketChanges <- many (try ticketChange)
- pure $ ConventionalCommit
- cType
- (cs cScope)
- (cs cSubject)
- (cs cBody)
- cBreakingChanges
- cTicketChanges
+ pure $
+ ConventionalCommit
+ cType
+ (cs cScope)
+ (cs cSubject)
+ (cs cBody)
+ cBreakingChanges
+ cTicketChanges
commitType :: Parser CommitType
commitType = do
- cType <- oneParserOf . fmap string $
- "feat" :|
- [ "fix", "bug", "docs", "doc", "style", "refactor", "ref", "test"
- , "chore"
- ]
+ cType <-
+ oneParserOf . fmap string $
+ "feat"
+ :| [ "fix",
+ "bug",
+ "docs",
+ "doc",
+ "style",
+ "refactor",
+ "ref",
+ "test",
+ "chore"
+ ]
pure $ case cType of
"feat" -> CTFeature
@@ -88,13 +99,14 @@ breakingChange = do
ticketChange :: Parser (HashSet TicketChange)
ticketChange = do
tcAction <- spaced $ manyCharsTill (string ": ")
- tcTickets <- some (char '#' *> manyCharsTill (some spaceChar <|> eol))
+ tcTickets <- some (char '#' *> manyCharsTill (void (some spaceChar) <|> void eol))
pure . fromList $ (\x -> (cs tcAction, cs x)) <$> tcTickets
mergeCommit :: Parser MergeCommit
-mergeCommit = MergeCommit . cs
- <$> (string "Merge " *> manyCharsTill (skipSome eol <|> eof))
+mergeCommit =
+ MergeCommit . cs
+ <$> (string "Merge " *> manyCharsTill (skipSome eol <|> eof))
miscCommit :: Parser MiscCommit
miscCommit = MiscCommit . cs <$> manyCharsTill (skipSome eol <|> eof)
diff --git a/src/Shift/Processing.hs b/src/Shift/Processing.hs
index cd3036e2c7e374f0bd666b5066b76f81eeac9e84..2a552c6558c9c022ad8d7f5d986f3341416cc896 100644
--- a/src/Shift/Processing.hs
+++ b/src/Shift/Processing.hs
@@ -1,31 +1,36 @@
module Shift.Processing where
-import Control.Lens ((<>~), (^.))
-import Data.Default (def)
-import Data.Git (Commit, Ref, commitMessage)
+import Control.Lens ((<>~), (^.))
+import Data.Default (def)
+import Data.Git (Commit, Ref, commitMessage)
import Data.String.Conversions (cs)
-import Text.Megaparsec (Dec, ParseError, runParser)
-
+import Data.Text (Text)
+import Data.Void (Void)
import qualified Shift.Parsers as P
-import Shift.Types
+import Shift.Types
+import Text.Megaparsec (ParseError, ParseErrorBundle, runParser)
-parseCommit :: (Ref, Commit) -> Either (ParseError Char Dec) ParsedGroup
+parseCommit :: (Ref hash, Commit hash) -> Either (ParseErrorBundle Text Void) (ParsedGroup hash)
parseCommit (r, c) = do
pc <- runParser P.commit "git" . cs . commitMessage $ c
pure (r, c, pc)
-generateReport :: [ParsedGroup] -> ChangeReport
+generateReport :: [ParsedGroup hash] -> ChangeReport hash
generateReport = foldl inner def
where
inner acc (r, c, x) = case x of
PCMisc miscCommit -> crMisc <>~ [(r, c, miscCommit)] $ acc
PCMerge mergeCommit -> crMerges <>~ [(r, c, mergeCommit)] $ acc
- PCConventional commit -> (case commit ^. ccType of
- CTFeature -> crFeatures
- CTFix -> crFixes
- CTDocs -> crDocs
- CTStyle -> crStyles
- CTRefactor -> crRefactors
- CTChore -> crChores
- CTTest -> crTests) <>~ [(r, c, commit)] $ acc
+ PCConventional commit ->
+ ( case commit ^. ccType of
+ CTFeature -> crFeatures
+ CTFix -> crFixes
+ CTDocs -> crDocs
+ CTStyle -> crStyles
+ CTRefactor -> crRefactors
+ CTChore -> crChores
+ CTTest -> crTests
+ )
+ <>~ [(r, c, commit)]
+ $ acc
diff --git a/src/Shift/Rendering.hs b/src/Shift/Rendering.hs
index 27f382b98d0c8e9bb237541d8c255a6cc384f923..1242ad215ecea749fe8465b42d64ad3c2d2ab5dd 100644
--- a/src/Shift/Rendering.hs
+++ b/src/Shift/Rendering.hs
@@ -21,7 +21,7 @@ import Shift.Types
renderRef
:: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
- => Ref
+ => Ref hash
-> m Text
renderRef ref = do
url <- getRefURL ref
@@ -34,7 +34,7 @@ renderRef ref = do
renderConventionalCommit
:: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
- => ConventionalGroup
+ => ConventionalGroup hash
-> m Text
renderConventionalCommit (ref, commit, pc) = do
renderedRef <- renderRef ref
@@ -52,8 +52,8 @@ renderConventionalCommit (ref, commit, pc) = do
renderAuthor
:: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
- => Commit
- -> Ref
+ => Commit hash
+ -> Ref hash
-> m Text
renderAuthor commit ref = do
authorInfo <- getAuthorInfo (commitAuthor commit) ref
@@ -64,7 +64,7 @@ renderAuthor commit ref = do
renderMiscCommit
:: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
- => MiscGroup
+ => MiscGroup hash
-> m Text
renderMiscCommit (ref, commit, MiscCommit subject) = do
renderedRef <- renderRef ref
@@ -74,7 +74,7 @@ renderMiscCommit (ref, commit, MiscCommit subject) = do
renderMergeCommit
:: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
- => MergeGroup
+ => MergeGroup hash
-> m Text
renderMergeCommit (ref, commit, MergeCommit subject) = do
renderedRef <- renderRef ref
@@ -109,7 +109,7 @@ headerThree = linePadded . (<>) "### "
printReport
:: (MonadIO m, MonadState s m, ClientState s, MonadThrow m)
- => ChangeReport
+ => ChangeReport hash
-> m ()
printReport report = do
-- Print conventional commits
diff --git a/src/Shift/Types.hs b/src/Shift/Types.hs
index 047ddfa40faf7e08fded594d6c124eeb13d09378..c31b0aaccd038677ea9c74660dde0393b932f624 100644
--- a/src/Shift/Types.hs
+++ b/src/Shift/Types.hs
@@ -38,16 +38,22 @@ import Network.HTTP.Client (Manager)
import GitHub.UserSearch
import Shift.CLI (ShiftOptions)
import Shift.Utilities (orThrow)
+import GitHub (URL(URL))
+import GitHub (URL(URL))
+import GitHub (getUrl)
+import GitHub (getUrl)
+import Data.Aeson (FromJSON)
+import Data.Aeson (FromJSON)
class ClientState s where
getRefURL
:: (MonadIO m, MonadState s m, MonadThrow m)
- => Ref
+ => Ref hash
-> m (Maybe Text)
getAuthorInfo
:: (MonadIO m, MonadState s m, MonadThrow m)
=> Person
- -> Ref
+ -> Ref hash
-> m (Maybe (Text, Text))
type GitM s a = StateT s (ReaderT ShiftOptions IO) a
@@ -106,26 +112,26 @@ data ParsedCommit
| PCMisc MiscCommit
deriving (Show)
-type ParsedGroup = (Ref, Commit, ParsedCommit)
-type ConventionalGroup = (Ref, Commit, ConventionalCommit)
-type MergeGroup = (Ref, Commit, MergeCommit)
-type MiscGroup = (Ref, Commit, MiscCommit)
-
-data ChangeReport = ChangeReport
- { _crFeatures :: [ConventionalGroup]
- , _crFixes :: [ConventionalGroup]
- , _crDocs :: [ConventionalGroup]
- , _crStyles :: [ConventionalGroup]
- , _crRefactors :: [ConventionalGroup]
- , _crTests :: [ConventionalGroup]
- , _crChores :: [ConventionalGroup]
- , _crMerges :: [MergeGroup]
- , _crMisc :: [MiscGroup]
+type ParsedGroup hash = (Ref hash, Commit hash, ParsedCommit)
+type ConventionalGroup hash = (Ref hash, Commit hash, ConventionalCommit)
+type MergeGroup hash = (Ref hash, Commit hash, MergeCommit)
+type MiscGroup hash = (Ref hash, Commit hash, MiscCommit)
+
+data ChangeReport hash = ChangeReport
+ { _crFeatures :: [ConventionalGroup hash]
+ , _crFixes :: [ConventionalGroup hash]
+ , _crDocs :: [ConventionalGroup hash]
+ , _crStyles :: [ConventionalGroup hash]
+ , _crRefactors :: [ConventionalGroup hash]
+ , _crTests :: [ConventionalGroup hash]
+ , _crChores :: [ConventionalGroup hash]
+ , _crMerges :: [MergeGroup hash]
+ , _crMisc :: [MiscGroup hash]
, _crBreakingChanges :: [BreakingChange]
, _crAffectedTickets :: HashSet TicketChange
} deriving (Show)
-instance Default ChangeReport where
+instance Default (ChangeReport hash) where
def = ChangeReport
{ _crFeatures = []
, _crFixes = []
@@ -213,7 +219,7 @@ lookupUserOnGitHubCommit ref = do
pure $ case commitAuthor result of
Nothing -> Nothing
- Just user -> Just (untagName $ simpleUserLogin user, simpleUserUrl user)
+ Just user -> Just (untagName $ simpleUserLogin user, getUrl $ simpleUserUrl user)
lookupUserOnGitHub
:: (MonadIO m, MonadState GitHubClientState m, MonadThrow m)
@@ -230,7 +236,7 @@ lookupUserOnGitHub email = do
False -> pure Nothing
executeRequest_
- :: (MonadIO m, MonadState GitHubClientState m, MonadThrow m)
+ :: (MonadIO m, MonadState GitHubClientState m, MonadThrow m, FromJSON a)
=> Request k a
-> m a
executeRequest_ x = do
diff --git a/stack.yaml b/stack.yaml
index 2e48a0c3a138ceb447e9d3a44d401ffa4d135ca5..453158da0df599346fd8618f89cfd044af53aec9 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -2,7 +2,7 @@
# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
-resolver: lts-7.0
+resolver: nightly-2020-12-12
# Local packages, usually specified by relative directory name
packages:
@@ -12,8 +12,8 @@ allow-newer: true
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps:
-- github-0.14.1
-- versions-3.0.0
+ - git: https://gitlab.chromabits.com/etcinit/hgit.git
+ commit: 4f39d0dff5cb96995b3a49f2d115caab3da246be
# Override default flag values for local packages and extra-deps
flags: {}
@@ -21,11 +21,11 @@ flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
-image:
- container:
- base: "fpco/ubuntu-with-libgmp:14.04"
- entrypoints:
- - shift
+# image:
+# container:
+# base: "fpco/ubuntu-with-libgmp:14.04"
+# entrypoints:
+# - shift
# Control whether we use the GHC we find on the path
# system-ghc: true
diff --git a/stack.yaml.lock b/stack.yaml.lock
new file mode 100644
index 0000000000000000000000000000000000000000..ed1197830f082a7034736a15e76bf4afc6ba0423
--- /dev/null
+++ b/stack.yaml.lock
@@ -0,0 +1,23 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+# https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+ name: hgit
+ version: 0.4.0
+ git: https://gitlab.chromabits.com/etcinit/hgit.git
+ pantry-tree:
+ size: 2382
+ sha256: 674d4d24286e3a1b80209899056ad1eda2574c5d3c1782935d47af5d890b31c4
+ commit: 4f39d0dff5cb96995b3a49f2d115caab3da246be
+ original:
+ git: https://gitlab.chromabits.com/etcinit/hgit.git
+ commit: 4f39d0dff5cb96995b3a49f2d115caab3da246be
+snapshots:
+- completed:
+ size: 556770
+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/12/12.yaml
+ sha256: 168062744e171ba6949149ee702483d2186ddfbb6038508576d6c5093245f534
+ original: nightly-2020-12-12