#!/usr/bin/env stack

{-# LANGUAGE

DeriveFoldable

, DeriveFunctor

, DeriveTraversable

, FlexibleContexts

, LambdaCase

, NoImplicitPrelude

, OverloadedStrings

, PackageImports

, RecordWildCards

, TupleSections

, ViewPatterns

#-} -- Hlint requires this leading space

-- |

module Main (main) where

import Protolude hiding (intercalate, readFile, writeFile)

import qualified Protolude

import Control.Monad.Fail (fail)

import qualified Data.Aeson as JSON

import qualified Data.Aeson.KeyMap as KM

import Data.Attoparsec.ByteString (maybeResult, parse)

import "bifunctors"

Data.Bifunctor.Flip (Flip(..))

import qualified Data.ByteString as BS

import qualified Data.List.NonEmpty as NEL

import Data.String (String)

import qualified Data.String as String

import qualified Data.Text as T

import Data.Time.Clock (UTCTime)

import Data.Time.Format.ISO8601 (iso8601ParseM)

import Data.Time.LocalTime (zonedTimeToUTC)

import GitHub.REST (GHEndpoint(..), GitHubSettings(..), KeyValue(..), MonadGitHubREST, StdMethod(..), queryGitHub, runGitHubT)

import qualified SimpleCmd.Git as IOGit

import System.Directory (setCurrentDirectory)

import System.FilePath (normalise, takeFileName, (</>))

main = runGitHubT gitHubSettings $ do

git "rev-parse" ["--show-toplevel"] >>= liftIO . setCurrentDirectory

entries <- String.lines <$> git "ls-tree" ["--name-only", "HEAD", "CHANGELOG.d/"]

breaks <- processEntriesStartingWith "break" entries

features <- processEntriesStartingWith "feat" entries

fixes <- processEntriesStartingWith "fix" entries

internal <- processEntriesStartingWith "int" entries

misc <- processEntriesStartingWith "misc" entries

let entryFiles = ceFile <$> breaks <> features <> fixes <> internal <> misc

unless (null entryFiles) $ do

changes <- git "status" ("-s" : "--" : "CHANGELOG.md" : entryFiles)

unless (null changes) . liftIO . die $

"You have uncommitted changes to changelog files. " <>

"Please commit, stash, or revert them before running this script."

version <- getVersion

(changelogPreamble, changelogRest) <- T.breakOn "\n## " <$> readFile "CHANGELOG.md"

writeFile "CHANGELOG.md" $

changelogPreamble

<> "\n## " <> version <> "\n"

<> conditionalSection "Breaking changes" breaks

<> conditionalSection "New features" features

<> conditionalSection "Bugfixes" fixes

<> conditionalSection "Other improvements" misc

<> conditionalSection "Internal" internal

<> changelogRest

git_ "add" ["CHANGELOG.md"]

git_ "rm" $ "-q" : entryFiles

gitHubSettings :: GitHubSettings

gitHubSettings = GitHubSettings Nothing "purescript/purescript update-changelog.hs" "v3"

processEntriesStartingWith :: (MonadFail m, MonadGitHubREST m, MonadIO m) => String -> [String] -> m [ChangelogEntry]

processEntriesStartingWith prefix

= fmap (sortOn ceDate)

. traverse updateEntry

. filter ((prefix `isPrefixOf`) . map toLower . takeFileName)

updateEntry :: (MonadFail m, MonadGitHubREST m, MonadIO m) => String -> m ChangelogEntry

updateEntry file = do

(header, body) <- T.breakOn "\n" . T.strip <$> (readFile . normalise) file

allCommits <-

fmap (NEL.fromList . sortOn glcTime)

. traverse (\(T.breakOn " " -> (h, T.breakOn " " . T.tail -> (c, s))) ->

GitLogCommit (T.tail s) h . zonedTimeToUTC <$> iso8601ParseM (toS c))

=<< gitLines "log" ["-m", "--follow", "--format=%H %cI %s", file]

prCommits <-

filterM isInterestingCommit

. mapMaybe (traverse parsePRNumber)

$ NEL.toList allCommits

let prNumbers = map (snd . glcData) prCommits

prAuthors <- ordNub <$> traverse lookupPRAuthor prNumbers

let headerSuffix = if null prNumbers then "" else

" ("

<> commaSeparate (map (("#" <>) . show) prNumbers)

<> " by "

<> commaSeparate (map ("@" <>) prAuthors)

<> ")"

pure $ ChangelogEntry file (header <> headerSuffix <> body <> "\n") (glcTime $ NEL.head allCommits)

parsePRNumber :: Text -> Maybe (CommitType, Int)

parsePRNumber = liftA2 (<|>)

(fmap (MergeCommit, ) . readMaybe . (toS :: T.Text -> String) . fst . T.breakOn " " <=< T.stripPrefix "Merge pull request #")

(fmap (SquashCommit, ) . readMaybe . (toS :: T.Text -> String) <=< T.stripSuffix ")" . snd . T.breakOnEnd "(#")

-- |

isInterestingCommit :: MonadIO m => GitLogCommit (CommitType, Int) -> m Bool

isInterestingCommit GitLogCommit{..} = case fst glcData of

MergeCommit -> pure True

SquashCommit ->

not . all (\path -> "CHANGELOG.md" == path || "CHANGELOG.d/" `T.isPrefixOf` path)

<$> gitLines "show" ["--format=", "--name-only", toS glcHash]

lookupPRAuthor :: (MonadFail m, MonadGitHubREST m) => Int -> m Text

lookupPRAuthor prNum =

queryGitHub GHEndpoint{ method = GET

, endpoint = "/repos/purescript/purescript/pulls/:pr"

, endpointVals = ["pr" := prNum]

, ghData = []

}

>>= \case

JSON.Object (KM.lookup "user" -> Just (JSON.Object (KM.lookup "login" -> Just (JSON.String name)))) -> pure name

_ -> fail "error accessing GitHub API"

commaSeparate :: [Text] -> Text

commaSeparate = \case

[] -> ""

[a] -> a

[a, b] -> a <> " and " <> b

more | Just (init, last) <- unsnoc more -> T.intercalate ", " init <> ", and " <> last

getVersion :: (MonadFail m, MonadIO m) => m Text

getVersion =

(liftIO . BS.readFile) ("npm-package" </> "package.json") >>= \case

(maybeResult . parse JSON.json -> Just (JSON.Object (KM.lookup "version" -> Just (JSON.String v)))) -> pure v

_ -> fail "could not read version from npm-package/package.json"

conditionalSection :: Text -> [ChangelogEntry] -> Text

conditionalSection header = \case

[] -> ""

entries ->

"\n" <> header <> ":\n\n" <> T.intercalate "\n" (map ceContent entries)

git :: MonadIO m => String -> [String] -> m String

git cmd = liftIO . IOGit.git cmd

git_ :: MonadIO m => String -> [String] -> m ()

git_ cmd = liftIO . IOGit.git_ cmd

gitLines :: MonadIO m => String -> [String] -> m [Text]

gitLines cmd args = lines . toS <$> git cmd args

readFile :: MonadIO m => FilePath -> m Text

readFile = liftIO . Protolude.readFile

writeFile :: MonadIO m => FilePath -> Text -> m ()

writeFile path = liftIO . Protolude.writeFile path

data ChangelogEntry = ChangelogEntry

{ ceFile :: String

, ceContent :: Text

, ceDate :: UTCTime

}

data GitLogCommit a = GitLogCommit

{ glcData :: a

, glcHash :: Text

, glcTime :: UTCTime

}

deriving (Functor, Foldable, Traversable)

data CommitType = MergeCommit | SquashCommit