diff --git a/src/GitHub/UserSearch.hs b/src/GitHub/UserSearch.hs
index f30b3f2eb0ca447b29b2cb317c47dc313f4e09a2..f8414a53a8108859c84490f1f91cc9ea90ba9124 100644
--- a/src/GitHub/UserSearch.hs
+++ b/src/GitHub/UserSearch.hs
@@ -1,31 +1,31 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
-- | Provides missing user search functionality from the GitHub client.
module GitHub.UserSearch where
-import Control.Lens (makeLenses)
-import Data.Aeson (FromJSON, Value (Object), parseJSON, (.:))
-import Data.Aeson.Types (typeMismatch)
-import Data.Text (Text)
+import Control.Lens (makeLenses)
+import Data.Aeson (FromJSON, Value (Object), parseJSON, (.:))
+import Data.Aeson.Types (typeMismatch)
+import Data.Text (Text)
import qualified Data.Text.Encoding as TE
-
-import GitHub.Data
+import GitHub.Data (GenRequest (Query), Request, SearchResult)
data UserResult = UserResult
- { _urLogin :: Text
- , _urId :: Int
- , _urAvatarUrl :: Text
- , _urGravatarId :: Text
- , _urHtmlUrl :: Text
- , _urType :: Text
- , _urSiteAdmin :: Bool
- , _urScore :: Double
- } deriving (Show)
+ { _urLogin :: Text,
+ _urId :: Int,
+ _urAvatarUrl :: Text,
+ _urGravatarId :: Text,
+ _urHtmlUrl :: Text,
+ _urType :: Text,
+ _urSiteAdmin :: Bool,
+ _urScore :: Double
+ }
+ deriving (Show)
instance FromJSON UserResult where
- parseJSON (Object v)
- = UserResult
+ parseJSON (Object v) =
+ UserResult
<$> v .: "login"
<*> v .: "id"
<*> v .: "avatar_url"
@@ -39,7 +39,7 @@ instance FromJSON UserResult where
makeLenses ''UserResult
searchUsersR :: Text -> Request k (SearchResult UserResult)
-searchUsersR searchString = Query
- ["search", "users"]
- [("q", Just $ TE.encodeUtf8 searchString)]
-
+searchUsersR searchString =
+ Query
+ ["search", "users"]
+ [("q", Just $ TE.encodeUtf8 searchString)]
diff --git a/src/Shift.hs b/src/Shift.hs
index 61ea9fc5fdc2a5e15817a27eb0facf92f4a4cbf9..3abf5a72b5778ac55855890360ad0b62d68c0a97 100644
--- a/src/Shift.hs
+++ b/src/Shift.hs
@@ -9,11 +9,112 @@ where
import Control.Lens ((^.))
import Options.Applicative
+ ( execParser,
+ fullDesc,
+ header,
+ helper,
+ info,
+ progDesc,
+ )
import Shift.CLI as X
+ ( HostingType (..),
+ ShiftCommand (..),
+ ShiftOptions (..),
+ hostingType,
+ shiftCommand,
+ shiftOptions,
+ soCommand,
+ soFromRef,
+ soGitHubOwner,
+ soGitHubRepository,
+ soGitHubToken,
+ soHostingType,
+ soIncludeHead,
+ soToRef,
+ )
import Shift.Git as X
+ ( commitSummary,
+ lookupCommitsDiff,
+ lookupRawRef,
+ pairedTagsFromOpts,
+ parseAndSortRefs,
+ parseTag,
+ refsPairsFromRefs,
+ renderDiff,
+ renderToNode,
+ tempMain,
+ )
import Shift.Rendering as X
+ ( bold,
+ headerOne,
+ headerThree,
+ headerTwo,
+ indented,
+ indentedL,
+ leafNode,
+ listItemNode,
+ paragraphNode,
+ parentNode,
+ printReport,
+ renderAuthor,
+ renderConventionalCommit,
+ renderMergeCommit,
+ renderMiscCommit,
+ renderRange,
+ renderRef,
+ renderTagRef,
+ textNode,
+ )
import Shift.Server (runServer)
import Shift.Types as X
+ ( BreakingChange (..),
+ ChangeReport (..),
+ ClientState (..),
+ CommitType (..),
+ ConventionalCommit (..),
+ ConventionalGroup,
+ GitClientState (..),
+ GitHubClientState (..),
+ GitM,
+ HasRepositoryCache (..),
+ MergeCommit (..),
+ MergeGroup,
+ MiscCommit (..),
+ MiscGroup,
+ ParsedCommit (..),
+ ParsedGroup,
+ RepositoryCache (..),
+ ShiftException (..),
+ TagRef (..),
+ TicketChange,
+ bcBody,
+ bcSubject,
+ ccAffectedTickets,
+ ccBody,
+ ccBreakingChanges,
+ ccScope,
+ ccSubject,
+ ccType,
+ crAffectedTickets,
+ crBreakingChanges,
+ crChores,
+ crDocs,
+ crFeatures,
+ crFixes,
+ crMerges,
+ crMisc,
+ crRefactors,
+ crStyles,
+ crTests,
+ executeRequest_,
+ gcsAuth,
+ gcsCache,
+ gcsManager,
+ gcsOwner,
+ gcsRepository,
+ lookupUserOnGitHub,
+ lookupUserOnGitHubCommit,
+ )
-- | The main CLI entrypoint.
shiftMain :: IO ()
diff --git a/src/Shift/CLI.hs b/src/Shift/CLI.hs
index 92c9e4def09953157cbce122c93fac3dc591eb46..0fe8b16e68789bad559136eada5c88c0f206886b 100644
--- a/src/Shift/CLI.hs
+++ b/src/Shift/CLI.hs
@@ -6,6 +6,23 @@ module Shift.CLI where
import Control.Lens (makeLenses)
import Options.Applicative
+ ( Parser,
+ ReadM,
+ auto,
+ command,
+ eitherReader,
+ help,
+ info,
+ long,
+ metavar,
+ option,
+ optional,
+ progDesc,
+ short,
+ strOption,
+ subparser,
+ switch,
+ )
data ShiftOptions = ShiftOptions
{ _soCommand :: ShiftCommand,
diff --git a/src/Shift/Parsers.hs b/src/Shift/Parsers.hs
index ed47d3511b1ac12b699d92acafa7edb882574ef3..3668ccedd737ee48f1e1062e94ddabbc4c696ea9 100644
--- a/src/Shift/Parsers.hs
+++ b/src/Shift/Parsers.hs
@@ -11,7 +11,28 @@ import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Void (Void)
import Shift.Types
+ ( BreakingChange (BreakingChange),
+ CommitType (..),
+ ConventionalCommit (ConventionalCommit),
+ MergeCommit (..),
+ MiscCommit (..),
+ ParsedCommit (..),
+ TicketChange,
+ )
import Text.Megaparsec
+ ( MonadParsec (eof, lookAhead, try),
+ Parsec,
+ Stream (Token),
+ anySingle,
+ choice,
+ many,
+ manyTill,
+ skipMany,
+ skipSome,
+ some,
+ someTill,
+ (<|>),
+ )
import Text.Megaparsec.Char (char, eol, spaceChar, string)
type Parser = Parsec Void Text
diff --git a/src/Shift/Processing.hs b/src/Shift/Processing.hs
index 2a552c6558c9c022ad8d7f5d986f3341416cc896..2a30f625e42cc93bd1b0a24c575c387c6990c825 100644
--- a/src/Shift/Processing.hs
+++ b/src/Shift/Processing.hs
@@ -8,6 +8,29 @@ import Data.Text (Text)
import Data.Void (Void)
import qualified Shift.Parsers as P
import Shift.Types
+ ( ChangeReport,
+ CommitType
+ ( CTChore,
+ CTDocs,
+ CTFeature,
+ CTFix,
+ CTRefactor,
+ CTStyle,
+ CTTest
+ ),
+ ParsedCommit (PCConventional, PCMerge, PCMisc),
+ ParsedGroup,
+ ccType,
+ crChores,
+ crDocs,
+ crFeatures,
+ crFixes,
+ crMerges,
+ crMisc,
+ crRefactors,
+ crStyles,
+ crTests,
+ )
import Text.Megaparsec (ParseError, ParseErrorBundle, runParser)
parseCommit :: (Ref hash, Commit hash) -> Either (ParseErrorBundle Text Void) (ParsedGroup hash)
diff --git a/src/Shift/Rendering.hs b/src/Shift/Rendering.hs
index 710ff9d127f7ed71c3afeaa696f9151e3f0b2c26..1c1737add0e37d7c9c2879dc39435062b1f08caa 100644
--- a/src/Shift/Rendering.hs
+++ b/src/Shift/Rendering.hs
@@ -10,16 +10,36 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State (MonadState)
import Control.Monad.Trans.Writer (WriterT (runWriterT), execWriterT, runWriter)
import Control.Monad.Trans.Writer.Lazy (tell)
-import Data.Git (RefName(refNameRaw), RefName(refNameRaw), Commit, Ref, commitAuthor)
+import Data.Git (Commit, Ref, RefName (refNameRaw), commitAuthor)
import Data.List (sortOn)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.String.Conversions (cs)
import Data.Text (Text)
-import qualified Data.Text as T (pack, pack, take)
+import qualified Data.Text as T (pack, take)
import qualified Data.Text.IO as TIO (putStr, putStrLn)
import Data.Versions (prettyV)
import Shift.Types
+ ( ChangeReport,
+ ClientState (..),
+ ConventionalGroup,
+ MergeCommit (MergeCommit),
+ MergeGroup,
+ MiscCommit (MiscCommit),
+ MiscGroup,
+ TagRef (_tRef, _tVersioning),
+ ccScope,
+ ccSubject,
+ crChores,
+ crDocs,
+ crFeatures,
+ crFixes,
+ crMerges,
+ crMisc,
+ crRefactors,
+ crStyles,
+ crTests,
+ )
renderRef ::
(MonadIO m, MonadState s m, ClientState s, MonadThrow m) =>
@@ -111,7 +131,7 @@ renderRange tx ty =
mconcat
[renderTagRef tx, " to ", renderTagRef ty]
-renderTagRef :: TagRef -> Text
+renderTagRef :: TagRef -> Text
renderTagRef tr = case _tVersioning tr of
Just versioning -> prettyV versioning
Nothing -> T.pack . refNameRaw $ _tRef tr
diff --git a/src/Shift/Types.hs b/src/Shift/Types.hs
index bdbc49c13cbb4a743e2a112f50db583277ceb4b4..9c8cfc844baf3823e9b2080df254d5064512826b 100644
--- a/src/Shift/Types.hs
+++ b/src/Shift/Types.hs
@@ -1,59 +1,66 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
module Shift.Types where
import Control.Exception (Exception)
-import Prelude hiding (head, lookup)
-
-import Control.Lens (assign, makeClassy, makeLenses,
- view, (^.))
-import Control.Monad.Catch (MonadThrow)
-import Control.Monad.IO.Class (MonadIO)
-import Control.Monad.Reader (ReaderT)
-import Control.Monad.State (MonadState, StateT, gets)
-import Control.Monad.Trans (liftIO)
-import Data.Default (Default, def)
-import Data.Git (Commit, Person, Ref, RefName,
- personEmail, personName)
-import Data.HashMap.Strict (HashMap, insert, lookup)
-import Data.HashSet (HashSet)
-import Data.String.Conversions (cs)
-import Data.Text (Text)
-import qualified Data.Vector as V
-import Data.Versions (Versioning)
-import GitHub (Request, executeRequestWithMgr)
-import GitHub.Auth (Auth)
-import GitHub.Data.Definitions (simpleUserLogin, simpleUserUrl)
-import GitHub.Data.GitData (commitAuthor)
-import GitHub.Data.Name (Name (..), untagName)
-import GitHub.Data.Search (searchResultResults,
- searchResultTotalCount)
-import GitHub.Endpoints.Repos.Commits (commitR)
-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 Control.Lens
+ ( assign,
+ makeClassy,
+ makeLenses,
+ view,
+ (^.),
+ )
+import Control.Monad.Catch (MonadThrow)
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Reader (ReaderT)
+import Control.Monad.State (MonadState, StateT, gets)
+import Control.Monad.Trans (liftIO)
import Data.Aeson (FromJSON)
+import Data.Default (Default, def)
+import Data.Git
+ ( Commit,
+ Person,
+ Ref,
+ RefName,
+ personEmail,
+ personName,
+ )
+import Data.HashMap.Strict (HashMap, insert, lookup)
+import Data.HashSet (HashSet)
+import Data.String.Conversions (cs)
+import Data.Text (Text)
+import qualified Data.Vector as V
+import Data.Versions (Versioning)
+import GitHub (Request, URL (URL), executeRequestWithMgr, getUrl)
+import GitHub.Auth (Auth)
+import GitHub.Data.Definitions (simpleUserLogin, simpleUserUrl)
+import GitHub.Data.GitData (commitAuthor)
+import GitHub.Data.Name (Name (..), untagName)
+import GitHub.Data.Search
+ ( searchResultResults,
+ searchResultTotalCount,
+ )
+import GitHub.Endpoints.Repos.Commits (commitR)
+import GitHub.UserSearch (searchUsersR, urHtmlUrl, urLogin)
+import Network.HTTP.Client (Manager)
+import Shift.CLI (ShiftOptions)
+import Shift.Utilities (orThrow)
+import Prelude hiding (head, lookup)
class ClientState s where
- getRefURL
- :: (MonadIO m, MonadState s m, MonadThrow m)
- => Ref hash
- -> m (Maybe Text)
- getAuthorInfo
- :: (MonadIO m, MonadState s m, MonadThrow m)
- => Person
- -> Ref hash
- -> m (Maybe (Text, Text))
+ getRefURL ::
+ (MonadIO m, MonadState s m, MonadThrow m) =>
+ Ref hash ->
+ m (Maybe Text)
+ getAuthorInfo ::
+ (MonadIO m, MonadState s m, MonadThrow m) =>
+ Person ->
+ Ref hash ->
+ m (Maybe (Text, Text))
type GitM s a = StateT s (ReaderT ShiftOptions IO) a
@@ -84,23 +91,26 @@ data CommitType
deriving (Show)
data BreakingChange = BreakingChange
- { _bcSubject :: Text
- , _bcBody :: Text
- } deriving (Show)
+ { _bcSubject :: Text,
+ _bcBody :: Text
+ }
+ deriving (Show)
data ConventionalCommit = ConventionalCommit
- { _ccType :: CommitType
- , _ccScope :: Text
- , _ccSubject :: Text
- , _ccBody :: Text
- , _ccBreakingChanges :: [BreakingChange]
- , _ccAffectedTickets :: [HashSet TicketChange]
- } deriving (Show)
+ { _ccType :: CommitType,
+ _ccScope :: Text,
+ _ccSubject :: Text,
+ _ccBody :: Text,
+ _ccBreakingChanges :: [BreakingChange],
+ _ccAffectedTickets :: [HashSet TicketChange]
+ }
+ deriving (Show)
data TagRef = TagRef
- { _tRef :: RefName
- , _tVersioning :: Maybe Versioning
- } deriving (Show, Eq)
+ { _tRef :: RefName,
+ _tVersioning :: Maybe Versioning
+ }
+ deriving (Show, Eq)
instance Ord TagRef where
compare x y = compare (_tVersioning x) (_tVersioning y)
@@ -112,42 +122,47 @@ data ParsedCommit
deriving (Show)
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)
+ { _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 hash) where
- def = ChangeReport
- { _crFeatures = []
- , _crFixes = []
- , _crDocs = []
- , _crStyles = []
- , _crRefactors = []
- , _crTests = []
- , _crChores = []
- , _crMerges = []
- , _crMisc = []
- , _crBreakingChanges = []
- , _crAffectedTickets = mempty
- }
+ def =
+ ChangeReport
+ { _crFeatures = [],
+ _crFixes = [],
+ _crDocs = [],
+ _crStyles = [],
+ _crRefactors = [],
+ _crTests = [],
+ _crChores = [],
+ _crMerges = [],
+ _crMisc = [],
+ _crBreakingChanges = [],
+ _crAffectedTickets = mempty
+ }
data RepositoryCache = RepositoryCache
- { _rcRefURLs :: HashMap Text (Maybe Text)
- , _rcAuthorInfos :: HashMap Text (Maybe (Text, Text))
+ { _rcRefURLs :: HashMap Text (Maybe Text),
+ _rcAuthorInfos :: HashMap Text (Maybe (Text, Text))
}
instance Default RepositoryCache where
@@ -159,17 +174,18 @@ data GitClientState = GitClientState
instance ClientState GitClientState where
getRefURL _ = pure Nothing
- getAuthorInfo person _ = pure . Just $
- ( cs $ personName person
- , mconcat ["mailto://", cs $ personEmail person]
- )
+ getAuthorInfo person _ =
+ pure . Just $
+ ( cs $ personName person,
+ mconcat ["mailto://", cs $ personEmail person]
+ )
data GitHubClientState = GitHubClientState
- { _gcsCache :: RepositoryCache
- , _gcsAuth :: Auth
- , _gcsManager :: Manager
- , _gcsOwner :: Text
- , _gcsRepository :: Text
+ { _gcsCache :: RepositoryCache,
+ _gcsAuth :: Auth,
+ _gcsManager :: Manager,
+ _gcsOwner :: Text,
+ _gcsRepository :: Text
}
makeLenses ''GitHubClientState
@@ -180,12 +196,12 @@ instance ClientState GitHubClientState where
repositoryName <- gets (view gcsRepository)
pure . Just . mconcat $
- [ "https://github.com/"
- , owner
- , "/"
- , repositoryName
- , "/commit/"
- , cs . show $ ref
+ [ "https://github.com/",
+ owner,
+ "/",
+ repositoryName,
+ "/commit/",
+ cs . show $ ref
]
getAuthorInfo person ref = do
@@ -206,10 +222,10 @@ instance ClientState GitHubClientState where
pure result2
-lookupUserOnGitHubCommit
- :: (MonadIO m, MonadState GitHubClientState m, MonadThrow m, Show a)
- => a
- -> m (Maybe (Text, Text))
+lookupUserOnGitHubCommit ::
+ (MonadIO m, MonadState GitHubClientState m, MonadThrow m, Show a) =>
+ a ->
+ m (Maybe (Text, Text))
lookupUserOnGitHubCommit ref = do
owner <- gets (view gcsOwner)
repository <- gets (view gcsRepository)
@@ -220,10 +236,10 @@ lookupUserOnGitHubCommit ref = do
Nothing -> Nothing
Just user -> Just (untagName $ simpleUserLogin user, getUrl $ simpleUserUrl user)
-lookupUserOnGitHub
- :: (MonadIO m, MonadState GitHubClientState m, MonadThrow m)
- => Text
- -> m (Maybe (Text, Text))
+lookupUserOnGitHub ::
+ (MonadIO m, MonadState GitHubClientState m, MonadThrow m) =>
+ Text ->
+ m (Maybe (Text, Text))
lookupUserOnGitHub email = do
results <- executeRequest_ $ searchUsersR email
@@ -234,10 +250,10 @@ lookupUserOnGitHub email = do
pure $ Just (user ^. urLogin, user ^. urHtmlUrl)
False -> pure Nothing
-executeRequest_
- :: (MonadIO m, MonadState GitHubClientState m, MonadThrow m, FromJSON a)
- => Request k a
- -> m a
+executeRequest_ ::
+ (MonadIO m, MonadState GitHubClientState m, MonadThrow m, FromJSON a) =>
+ Request k a ->
+ m a
executeRequest_ x = do
manager <- gets (view gcsManager)
auth <- gets (view gcsAuth)
@@ -249,4 +265,3 @@ executeRequest_ x = do
makeLenses ''ConventionalCommit
makeLenses ''ChangeReport
makeLenses ''BreakingChange
-
diff --git a/src/Shift/Utilities.hs b/src/Shift/Utilities.hs
index 202c7a17ae1419d1dd20a25c9c310cf16b61fff5..83c53ca28ea4adc6db359ab79a12c96b9bc92b08 100644
--- a/src/Shift/Utilities.hs
+++ b/src/Shift/Utilities.hs
@@ -2,7 +2,6 @@
module Shift.Utilities where
import Control.Exception (Exception)
-
import Control.Monad.Catch (MonadThrow, throwM)
-- | Attempts to extract a value from a Maybe type. If it fails, the provided