Skip to content
Snippets Groups Projects
Unverified Commit b7d6ae78 authored by Eduardo Trujillo's avatar Eduardo Trujillo
Browse files

style(shift): Format most modules according to the style guide

parent d3abee5a
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 228 additions and 168 deletions
.stylish-haskell.yaml 0 → 100644
+ 21
− 0
View file @ b7d6ae78
steps:
# Import cleanup
- imports:
align: group
# Language pragmas
- language_pragmas:
style: vertical
remove_redundant: true
# Align the types in record declarations
- records: {}
# Remove trailing whitespace
- trailing_whitespace: {}
columns: 80
language_extensions:
- LambdaCase
- MultiParamTypeClasses
shift.cabal
+ 1
− 0
View file @ b7d6ae78
......@@ -46,6 +46,7 @@ library
, io-memoize
, vector
, exceptions
, semigroups
default-language: Haskell2010
executable shift
......
src/GitHub/UserSearch.hs
+ 11
− 12
View file @ b7d6ae78
......@@ -4,24 +4,23 @@
-- | 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
data UserResult = UserResult
{ _urLogin :: Text
, _urId :: Int
, _urAvatarUrl :: Text
{ _urLogin :: Text
, _urId :: Int
, _urAvatarUrl :: Text
, _urGravatarId :: Text
, _urHtmlUrl :: Text
, _urType :: Text
, _urSiteAdmin :: Bool
, _urScore :: Double
, _urHtmlUrl :: Text
, _urType :: Text
, _urSiteAdmin :: Bool
, _urScore :: Double
} deriving (Show)
instance FromJSON UserResult where
......
src/Shift.hs
+ 10
− 6
View file @ b7d6ae78
module Shift (shiftMain, module X) where
module Shift
( shiftMain
, module X
) where
import Shift.CLI as X
import Shift.Git as X
import Shift.Rendering as X
import Shift.Types as X
import Options.Applicative
import Control.Lens ((^.))
import Options.Applicative
import Shift.CLI as X
import Shift.Git as X
import Shift.Rendering as X
import Shift.Types as X
-- | The main CLI entrypoint.
shiftMain :: IO ()
......
src/Shift/CLI.hs
+ 7
− 6
View file @ b7d6ae78
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Shift.CLI where
import Control.Lens (makeLenses)
import Options.Applicative
import Control.Lens (makeLenses)
data ShiftOptions = ShiftOptions
{ _soCommand :: ShiftCommand
, _soHostingType :: HostingType
, _soGitHubOwner :: Maybe String
{ _soCommand :: ShiftCommand
, _soHostingType :: HostingType
, _soGitHubOwner :: Maybe String
, _soGitHubRepository :: Maybe String
, _soGitHubToken :: Maybe String
, _soGitHubToken :: Maybe String
} deriving (Show, Eq)
data ShiftCommand = GenerateCommand deriving (Show, Eq, Enum)
......
src/Shift/Git.hs
+ 30
− 29
View file @ b7d6ae78
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RankNTypes #-}
module Shift.Git where
import Data.Git
import Data.Git.Storage.Object
import Data.Git.Ref (fromHex, isHex)
import Data.Versions (parseV)
import Text.Megaparsec (ParseError)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Either (rights)
import Data.Set as S (toList)
import Data.Tuple (swap)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Maybe (catMaybes)
import Data.List (sortBy)
import Data.String.Conversions (cs)
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.Monad.State (runStateT)
import Data.Default (def)
import Control.Monad (void)
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import GitHub.Auth (Auth (OAuth))
import Control.Lens ((^.))
import Control.Monad.Trans (liftIO)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Catch (throwM)
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 (ParseError)
import Shift.CLI
import Shift.Types
import Shift.Processing
import Shift.Rendering
import Shift.Utilities (orError, pairs)
import Shift.Types
import Shift.Utilities (orError, pairs)
parseTag :: RefName -> Either ParseError TagRef
parseTag ref = case parseV . cs . refNameRaw $ ref of
......
src/Shift/Parsers.hs
+ 53
− 47
View file @ b7d6ae78
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Shift.Parsers where
import Control.Monad (void)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.HashSet (HashSet, fromList)
import Data.String.Conversions (cs)
import Text.Megaparsec
import Text.Megaparsec.Text
import Data.HashSet (HashSet, fromList)
import Data.String.Conversions (cs)
import Control.Monad (void)
import Shift.Types
commitP :: Parser ParsedCommit
commitP
= (PCConventional <$> conventionalCommitP)
<|> try (PCMerge <$> mergeCommitP)
<|> (PCMisc <$> miscCommitP)
commit :: Parser ParsedCommit
commit
= (PCConventional <$> conventionalCommit)
<|> try (PCMerge <$> mergeCommit)
<|> (PCMisc <$> miscCommit)
spaced :: Parser a -> Parser a
spaced = (*>) $ many (some spaceChar <|> eol)
conventionalCommitP :: Parser ConventionalCommit
conventionalCommitP = do
cType <- commitTypeP
oneParserOf :: NE.NonEmpty (Parser a) -> Parser a
oneParserOf (NE.reverse -> (x :| xs)) = foldl (\acc x -> try x <|> acc) x xs
manyCharsTill :: Parser end -> Parser [Char]
manyCharsTill = manyTill anyChar
someCharsTill :: Parser end -> Parser [Char]
someCharsTill = someTill anyChar
conventionalCommit :: Parser ConventionalCommit
conventionalCommit = do
cType <- commitType
void (char '(')
cScope <- someTill anyChar (try $ string "): ")
cSubject <- someTill anyChar (choice [eol >> pure (), eof])
cScope <- someCharsTill (try $ string "): ")
cSubject <- someCharsTill (choice [eol >> pure (), eof])
cBody <- spaced . manyTill anyChar . lookAhead $
( skipMany (try breakingChangeP)
*> skipMany (try ticketChangeP)
*> many eol
*> eof
)
cBody <- spaced . manyCharsTill . lookAhead $ do
skipMany (try breakingChange)
skipMany (try ticketChange)
many eol
eof
cBreakingChanges <- many (try breakingChangeP)
cTicketChanges <- many (try ticketChangeP)
cBreakingChanges <- many (try breakingChange)
cTicketChanges <- many (try ticketChange)
pure $ ConventionalCommit
cType
......@@ -44,18 +56,13 @@ conventionalCommitP = do
cBreakingChanges
cTicketChanges
commitTypeP :: Parser CommitType
commitTypeP = do
cType <- try (string "feat")
<|> try (string "fix")
<|> try (string "bug") -- Common typo
<|> try (string "docs")
<|> try (string "doc") -- Common typo
<|> try (string "style")
<|> try (string "refactor")
<|> try (string "ref") -- Common typo
<|> try (string "test")
<|> string "chore"
commitType :: Parser CommitType
commitType = do
cType <- oneParserOf . fmap string $
"feat" :|
[ "fix", "bug", "docs", "doc", "style", "refactor", "ref", "test"
, "chore"
]
pure $ case cType of
"feat" -> CTFeature
......@@ -70,25 +77,24 @@ commitTypeP = do
"chore" -> CTChore
_ -> CTFeature
breakingChangeP :: Parser BreakingChange
breakingChangeP = do
breakingChange :: Parser BreakingChange
breakingChange = do
void . spaced . string $ "BREAKING CHANGE: "
BreakingChange
<$> (cs <$> manyTill anyChar eol)
<*> (cs <$> manyTill anyChar
(spaced eof <|> (skipSome ticketChangeP *> eof))
)
<$> (cs <$> manyCharsTill eol)
<*> (cs <$> manyCharsTill (spaced eof <|> (skipSome ticketChange *> eof)))
ticketChangeP :: Parser (HashSet TicketChange)
ticketChangeP = do
tcAction <- spaced $ manyTill anyChar (string ": ")
tcTickets <- some (char '#' *> manyTill anyChar (some spaceChar <|> eol))
ticketChange :: Parser (HashSet TicketChange)
ticketChange = do
tcAction <- spaced $ manyCharsTill (string ": ")
tcTickets <- some (char '#' *> manyCharsTill (some spaceChar <|> eol))
pure . fromList $ (\x -> (cs tcAction, cs x)) <$> tcTickets
mergeCommitP :: Parser MergeCommit
mergeCommitP = MergeCommit . cs <$> (string "Merge " *> manyTill anyChar (skipSome eol <|> eof))
mergeCommit :: Parser MergeCommit
mergeCommit = MergeCommit . cs
<$> (string "Merge " *> manyCharsTill (skipSome eol <|> eof))
miscCommitP :: Parser MiscCommit
miscCommitP = MiscCommit . cs <$> manyTill anyChar (skipSome eol <|> eof)
miscCommit :: Parser MiscCommit
miscCommit = MiscCommit . cs <$> manyCharsTill (skipSome eol <|> eof)
src/Shift/Processing.hs
+ 7
− 7
View file @ b7d6ae78
module Shift.Processing where
import Control.Lens ((<>~), (^.))
import Shift.Types
import Data.Default (def)
import Text.Megaparsec (runParser, ParseError)
import Data.Git (commitMessage, Ref, Commit)
import Control.Lens ((<>~), (^.))
import Data.Default (def)
import Data.Git (Commit, Ref, commitMessage)
import Data.String.Conversions (cs)
import Text.Megaparsec (ParseError, runParser)
import Shift.Parsers
import qualified Shift.Parsers as P
import Shift.Types
parseCommit :: (Ref, Commit) -> Either ParseError ParsedGroup
parseCommit (r, c) = do
pc <- runParser commitP "git" . cs . commitMessage $ c
pc <- runParser P.commit "git" . cs . commitMessage $ c
pure (r, c, pc)
......
src/Shift/Rendering.hs
+ 21
− 12
View file @ b7d6ae78
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Shift.Rendering where
import Control.Lens ((^.))
import Data.Text (Text)
import qualified Data.Text as T (take)
import qualified Data.Text.IO as TIO (putStrLn)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Git (Ref, Commit, commitAuthor)
import Data.Monoid ((<>))
import Data.String.Conversions (cs)
import Data.List (sortOn)
import Control.Monad.State (MonadState)
import Data.Versions (prettyV)
import Control.Lens ((^.))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State (MonadState)
import Data.Git (Commit, Ref, commitAuthor)
import Data.Monoid ((<>))
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Data.Text as T (take)
import qualified Data.Text.IO as TIO (putStrLn)
import Data.Versions (prettyV)
import Shift.Types
......@@ -38,7 +39,15 @@ renderConventionalCommit (ref, commit, pc) = do
renderedRef <- renderRef ref
authorText <- renderAuthor commit
pure $ "- " <> renderedRef <> " " <> bold (pc ^. ccScope <> ":") <> " " <> (pc ^. ccSubject) <> authorText
pure . mconcat $
[ "- "
, renderedRef
, " "
, bold $ pc ^. ccScope <> ":"
, " "
, pc ^. ccSubject
, authorText
]
renderAuthor
:: (MonadIO m, MonadState s m, ClientState s)
......
src/Shift/Types.hs
+ 66
− 49
View file @ b7d6ae78
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Shift.Types where
import Prelude hiding (lookup, head)
import Data.Git (Commit, Ref, RefName, Person, personEmail)
import Control.Lens (makeLenses, makeClassy, (^.), view, assign)
import Data.Text (Text)
import Data.HashSet (HashSet)
import Data.HashMap.Strict (HashMap, insert, lookup)
import qualified Data.Vector as V
import Data.Default (Default, def)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.State (StateT, MonadState, gets)
import Control.Monad.Reader (ReaderT)
import Control.Monad.Trans (liftIO)
import GitHub.Auth (Auth)
import GitHub.Data.Search (searchResultTotalCount, searchResultResults)
import GitHub (executeRequestWithMgr)
import Data.String.Conversions (cs)
import Network.HTTP.Client (Manager)
import Control.Exception (Exception, throwIO)
import Data.Monoid ((<>))
import Data.Versions (Versioning)
import Data.Monoid ((<>))
import Prelude hiding (head, lookup)
import Control.Lens (assign, makeClassy, makeLenses, view,
(^.))
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)
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 (executeRequestWithMgr)
import GitHub.Auth (Auth)
import GitHub.Data.Search (searchResultResults,
searchResultTotalCount)
import Network.HTTP.Client (Manager)
import GitHub.UserSearch
import Shift.CLI (ShiftOptions)
import Shift.CLI (ShiftOptions)
class ClientState s where
getRefURL :: (MonadIO m, MonadState s m) => Ref -> m (Maybe Text)
getAuthorInfo :: (MonadIO m, MonadState s m) => Person -> m (Maybe (Text, Text))
getRefURL
:: (MonadIO m, MonadState s m)
=> Ref
-> m (Maybe Text)
getAuthorInfo
:: (MonadIO m, MonadState s m)
=> Person
-> m (Maybe (Text, Text))
type GitM a = forall s. ClientState s => StateT s (ReaderT ShiftOptions IO) a
......@@ -65,21 +74,21 @@ data CommitType
data BreakingChange = BreakingChange
{ _bcSubject :: Text
, _bcBody :: Text
, _bcBody :: Text
} deriving (Show)
data ConventionalCommit = ConventionalCommit
{ _ccType :: CommitType
, _ccScope :: Text
, _ccSubject :: Text
, _ccBody :: Text
{ _ccType :: CommitType
, _ccScope :: Text
, _ccSubject :: Text
, _ccBody :: Text
, _ccBreakingChanges :: [BreakingChange]
, _ccAffectedTickets :: [HashSet TicketChange]
} deriving (Show)
data TagRef = TagRef
{ _tRef :: RefName
{ _tRef :: RefName
, _tVersioning :: Versioning
} deriving (Show, Eq)
......@@ -98,15 +107,15 @@ 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]
{ _crFeatures :: [ConventionalGroup]
, _crFixes :: [ConventionalGroup]
, _crDocs :: [ConventionalGroup]
, _crStyles :: [ConventionalGroup]
, _crRefactors :: [ConventionalGroup]
, _crTests :: [ConventionalGroup]
, _crChores :: [ConventionalGroup]
, _crMerges :: [MergeGroup]
, _crMisc :: [MiscGroup]
, _crBreakingChanges :: [BreakingChange]
, _crAffectedTickets :: HashSet TicketChange
} deriving (Show)
......@@ -127,7 +136,7 @@ instance Default ChangeReport where
}
data RepositoryCache = RepositoryCache
{ _rcRefURLs :: HashMap Text (Maybe Text)
{ _rcRefURLs :: HashMap Text (Maybe Text)
, _rcAuthorInfos :: HashMap Text (Maybe (Text, Text))
}
......@@ -137,10 +146,10 @@ instance Default RepositoryCache where
makeClassy ''RepositoryCache
data GitHubClientState = GitHubClientState
{ _gcsCache :: RepositoryCache
, _gcsAuth :: Auth
, _gcsManager :: Manager
, _gcsOwner :: Text
{ _gcsCache :: RepositoryCache
, _gcsAuth :: Auth
, _gcsManager :: Manager
, _gcsOwner :: Text
, _gcsRepository :: Text
}
......@@ -151,7 +160,14 @@ instance ClientState GitHubClientState where
owner <- gets (view gcsOwner)
repositoryName <- gets (view gcsRepository)
pure . Just $ "https://github.com/" <> owner <> "/" <> repositoryName <> "/commit/" <> (cs . show $ ref)
pure . Just . mconcat $
[ "https://github.com/"
, owner
, "/"
, repositoryName
, "/commit/"
, cs . show $ ref
]
getAuthorInfo person = do
let email = cs $ personEmail person
......@@ -164,7 +180,8 @@ instance ClientState GitHubClientState where
manager <- gets (view gcsManager)
auth <- gets (view gcsAuth)
results <- liftIO $ executeRequestWithMgr manager auth $ searchUsersR email
results <- liftIO . executeRequestWithMgr manager auth
$ searchUsersR email
result <- case results of
Left e -> liftIO $ throwIO e
......
src/Shift/Utilities.hs
+ 1
− 0
View file @ b7d6ae78
......@@ -2,6 +2,7 @@
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
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment