diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for changelogged + +## Unreleased changes + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2017, GetShop.TV +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,246 @@ +# Changelogged + +## What and how to? + +### Purpose +This is the tool for tracking project history and release documentation. +It guides developer through writing changelogs are bump version in project files. +With proper usage it guarantees that every pull request or commit from git history is mentioned in project changelogs and that versions all over the project are up to date. +It can also write changelogs based on git history and infer new version from changelog if it contains rubrication by level of changes. + +### Configuration file +[example](changelogged.yaml.skel) +``` +changelogs: + main: + # You can simply use arrays here. + path: "CHANGELOG.md" + api: + path: "API_CHANGELOG.md" + indicator: + path: "file.json" + variable: "version" +versioned: + main: + - path: "file.cabal" + variable: "version" + - path: "file2.cabal" + variable: "version" + - path: "file3.hs" + variable: "version" + - path: "file4.json" + variable: "version" + api: + - path: "file.hs" + variable: "apiVersion" + - path: "file.json" + variable: "version" +``` + +Config is optional. +With no config tool will try to check file named `ChangeLog.md` as far as it's part of Stack project template and bump versions in `package.yaml` files all over the project. + +Config (named `changelogged.yaml`) is split in two sections. + +`changelogs` record contains records about each changelog to track. +Each changelog has a key - key of the record. Two keys are reserved - `main` and `api` for common project changelog and API changelog correspondingly. +For each key there is a value. `path` is path to changelog from directory where you intent to run `changelogged`. `indicator` is optional. +`indicator` is used e.g. for API changelogs - it's file such that changing this file is equivalent to change API. This record contains `path` to file and `variable` where version is stored. +Current version for parts tracked by local changelogs is known from `indicator`. That's why `variable` key persists. General version of project is known from latest git tag. + +`versioned` section contains same key-names as `changelogs`. Each key contains array of files with `path` to file and `variable` where version is stored. + +### Features reference + +#### Text of help message: +``` +This tool can check your changelogs and bump versions in project. +It assumes to be run in root directory of project and that changelog is here. +You can specify these levels of changes: app, major, minor, fix, doc. +It can infer version from changelog. +But it will refuse to do it if it's not sure changelogs are up to date. + +Usage: changelogged [-l|--level ARG] [-a|--api-level ARG] [--format ARG] + [-W|--with-api] [-m|--multiple] [-c|--no-check] + [-C|--no-bump] [-e|--from-bc] [-f|--force] [-y|--write] + +Available options: + -h,--help Show this help text + -l,--level ARG Level of changes (for packages). One of (app major + minor fix doc) + -a,--api-level ARG Level of changes (for API). One of (app major minor + fix doc) + --format ARG Warning format. One of (simple + suggest) (default: simple) + -W,--with-api Assume there is changelog for API. + -m,--multiple Assume there is more than one changelog. + -c,--no-check Do not check changelogs. + -C,--no-bump Do not bump versions. Only check changelogs. + -e,--from-bc Check changelogs from start of project. + -f,--force Bump version even if changelogs are outdated. Cannot + be mixed with -c. + -y,--write Write changelog suggestions to changelog directly. + Available with --format suggest. +``` + +See examples [below](#guiding-examples) + +#### Checking changelogs +This is default feature. Changelogged will output all missing pull requests and commits with their messages. +It ignores commits and pull requests affecting only `.md` files. + +You can skip it with `-c` option or ignore results with `-f` option. Also you can check changelog from the first commit with `-e`. + +#### Bumping versions +This is also default feature. In default way if changelogs are up to day changelogged will bump versions all over the project. + +You can variously combine changelog checking and bumping versions. For example you may just want to be sure changelogs are up to date. There is `-C` option for that. +By default new version is inferred from changelog. It will work if you have some of `* App...` `* Major...`, `* Minor...`, `* Fix...`, and `* Doc...` sections in changelog and name versions correspondingly. +Suggested versioning: `app.major.minor.fix.doc`. +Otherwise you can specify new version explicitly with `-l` option. It's also the only way to work with `-c` option. + +#### Multiple changelogs and subversions +This feature requires `changelogged.yaml`. + +With `-m` option tool will assume there is more than one changelog and check all of them by keys from configuration file. Here is also subversioning from the box. +Current version is known from indicator file and new version is known from changelog. + +You cannot explicitly set new version for arbitrary changelog but `-W` option provides special checking of API changelog. And you can set new version with `-a`. +It's impossible to check only API changelog for now. See [issue](https://github.com/GetShopTV/changelogged/issues/54). + +#### Writing changelogs. +`--format suggest` provides another format for records you see on the screen. +It can be used with `-y` option to write these strings to the top of changelog they are relevant to. +This option cannot be used with `--format simple` which is default. + +### Guiding examples: + +#### Common run: +``` +changelogged (master):$ changelogged +``` +![image1](example_images/common_run.png) + +#### Suggest changelog entries: +``` +changelogged (master):$ changelogged --format suggest +``` +![image2](example_images/suggest.png) + +Force with no entries in changelog: +``` +changelogged (master):$ changelogged --format suggest -f +``` +![image3](example_images/no_force.png) + +Force with explicit version: +``` +changelogged (master):$ changelogged -f -l major +``` +![image4](example_images/force.png) + +#### Write suggested entries to changelog (works only with `--format suggest`) +``` +changelogged (master):$ changelogged --format suggest -y +``` +![image5](example_images/suggest.png) +``` +changelogged (master):$ git diff ChangeLog.md +``` +![image6](example_images/chlog_diff.png) +It requires some manual editing after. And it will not bump version immediately. + +#### Bump version infering it from changelog: +``` +changelogged (master):$ changelogged --format suggest -y +``` +![image7](example_images/bump.png) +``` +changelogged (master):$ git diff ChangeLog.md +``` +![image8](example_images/release.png) + +Do not bump even if changelogs are up to date +``` +changelogged -C +``` +![image9](example_images/no_bump.png) + +Try to bump without checking changelogs. Seems that `-f` option is always preferrable. But it waits for use cases. +``` +chagelogged -c +``` +![image10](example_images/no_check.png) + +### Typical daily workflow to keep project and API changelogs up to date (assuming existing changelogged.yaml): +See missing entries: +``` +changelogged -C --format suggest -W +``` +Record these changes. +``` +changelogged --format suggest -W -y +``` +And then edit changelogs manually. + +### Suggested simple workflow on release (for project with no `changelogged.yaml` and API changelog): +See missing entries: +``` +changelogged -C +``` +Record these changes: +``` +changelogged --format suggest -y +``` +Manually edit changelog + +Bump versions: +``` +changelogged +``` +_Next part is subject to change:_ + +Commit files with bumped versions. + +Record commit with version bumps: +``` +changelogged --format suggest -y +``` +Edit changelog - move new entry under version milestone. +Note: changes in `.md` files are ignored. + +Commit changelog, push and release. + +## Setting up + +### Requirements +It works with git projects only. +It was never tested on Windows. Ideally it will work if you have Git Bash installed. +As tool was designed for Haskell ecosystem first there are these extensions supported: `.hs`, `.cabal`, `.yaml` and `.json`. You cannot bump version in any other file. +But new extensions can be easily provided as far as changelogged aims to have the most wide users community. See [Add new extension](#add-new-extension) section. + +### Getting and building +First of all you should go to project [Github](https://github.com/GetShopTV/changelogged) + +Then you can simply download it - there is a binary in `bin` directory. After execute something like `cp bin/changelogged ~/.local/bin`. + +Or you can clone repo and build it from source. You need latest [Stack](https://docs.haskellstack.org/en/stable/README/) installed. +To build run +``` +stack install +``` + +## Contributing + +### Common +Bug reports and feature requests are welcome on [Github](https://github.com/GetShopTV/changelogged/issues) + +You are free to fork project and make a pull request. + +### Add new extension +You may want to use this tool inside project written not in Haskell. You are very welcome. + +Version bumping is restricted with extension of file. There is no euristic rules like "version is placed in `version = `" to have determined behaviour. +You may request for extension you want to be supported in [special issue](https://github.com/GetShopTV/changelogged/issues/35). It will be here ASAP. +Or you may write it yourself. +You are welcome to ask about how in comments in that issue (or browse comments). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + +import Distribution.Simple + +main :: IO () +main = defaultMain + +#endif diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Prelude hiding (FilePath) +import Turtle + +import Control.Exception +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) + +import System.Console.ANSI (Color(..)) + +import Changelogged.CheckLog.Check +import Changelogged.Bump.Local +import Changelogged.Bump.Common +import Changelogged.Bump.General +import Changelogged.Types +import Changelogged.Git +import Changelogged.Options +import Changelogged.Utils +import Changelogged.Pure (showPath, fromJustCustom, defaultedEmpty, showText) +import Changelogged.Settings + +commonMain :: Paths -> Options -> Git -> IO () +commonMain paths opts@Options{..} git = do + coloredPrint Green ("Checking " <> showPath (taggedLogPath $ chLog paths) <> " and creating it if missing.\n") + touch $ taggedLogPath (chLog paths) + + bump <- checkChangelogWrap opts git optNoCheck (chLog paths) + + (when (bump && not optNoBump) $ do + newVersion <- case optPackagesLevel of + Nothing -> generateVersionByChangelog optNoCheck (taggedLogPath $ chLog paths) (gitRevision git) + Just lev -> Just <$> generateVersion lev (gitRevision git) + + case newVersion of + Nothing -> return () + Just version -> case HM.lookup "main" (defaultedEmpty (versioned paths)) of + Just files -> do + printf ("Version: "%s%" -> ") (gitRevision git) + coloredPrint Yellow (version <> "\n") + mapM_ (bumpPart version) files + headChangelog version (taggedLogPath $ chLog paths) + Nothing -> coloredPrint Yellow "WARNING: no files to bump project version in specified.\n" + ) `catch` (\(ex :: PatternMatchFail) -> coloredPrint Red (showText ex)) + where + chLog cfg = HM.lookupDefault (TaggedLog "ChangeLog.md" Nothing) "main" + (fromMaybe (HM.singleton "main" (TaggedLog "ChangeLog.md" Nothing)) (changelogs cfg)) + +apiMain :: Paths -> Options -> Git -> IO () +apiMain paths opts@Options{..} git = do + coloredPrint Green ("Checking " <> showPath (taggedLogPath $ chLog paths) + <> " and creating it if missing.\nIf no indicator exists it will be checked as global changelog.\n") + touch $ taggedLogPath (chLog paths) + + bump <- checkChangelogWrap opts git optNoCheck (chLog paths) + + (when (bump && not optNoBump) $ do + newVersion <- case optApiLevel of + Nothing -> generateLocalVersionByChangelog optNoCheck (chLog paths) + Just lev -> Just <$> generateLocalVersion lev (fromJustCustom "No file with current API version specified." (taggedLogIndicator (chLog paths))) + + case newVersion of + Nothing -> return () + Just version -> case HM.lookup "api" (defaultedEmpty (versioned paths)) of + Just files -> do + mapM_ (bumpPart version) files + headChangelog version (taggedLogPath $ chLog paths) + Nothing -> coloredPrint Yellow "WARNING: no files to bump API version in specified.\n" + ) `catch` (\(ex :: PatternMatchFail) -> coloredPrint Red (showText ex)) + where + chLog cfg = HM.lookupDefault (TaggedLog "ApiChangeLog.md" Nothing) "api" + (fromMaybe (HM.singleton "api" (TaggedLog "ApiChangeLog.md" Nothing)) (changelogs cfg)) + +otherMain :: Paths -> Options -> Git -> IO () +otherMain paths opts@Options{..} git = do + mapM_ act (entries (changelogs paths)) + where + entries :: Maybe (HM.HashMap Text TaggedLog) -> [(Text, TaggedLog)] + entries (Just a) = HM.toList $ HM.delete "main" $ HM.delete "api" a + entries Nothing = [] + + act (key, changelog) = do + coloredPrint Green ("Checking " <> showPath (taggedLogPath changelog) <> " and creating it if missing.\n") + touch (taggedLogPath changelog) + + bump <- checkChangelogWrap opts git optNoCheck changelog + + (when (bump && not optNoBump) $ do + newVersion <- generateLocalVersionByChangelog optNoCheck changelog + + case newVersion of + Nothing -> return () + Just version -> case HM.lookup key (defaultedEmpty (versioned paths)) of + Just files -> do + mapM_ (bumpPart version) files + headChangelog version (taggedLogPath changelog) + Nothing -> coloredPrint Yellow "WARNING: no files to bump version in specified.\n" + ) `catch` (\(ex :: PatternMatchFail) -> coloredPrint Red (showText ex)) + +main :: IO () +main = do + opts@Options{..} <- options welcome parser + + defaultPaths <- makeDefaultPaths + + paths <- fromMaybe defaultPaths <$> loadPaths + + git <- gitData optFromBC + + commonMain paths opts git + + when optWithAPI $ apiMain paths opts git + + when optDifferentChlogs $ otherMain paths opts git + + sh $ rm $ gitHistory git diff --git a/changelogged.cabal b/changelogged.cabal new file mode 100644 --- /dev/null +++ b/changelogged.cabal @@ -0,0 +1,103 @@ +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 603efc893dd29ab0891f45438ea57f2caee1d8d76eb24a1e2aa0677b19bf8c3b + +name: changelogged +version: 0.1.0 +synopsis: Tool to manage project publishing history. +description: Please see README.md +category: Development +homepage: https://github.com/GetShopTV/changelogged#readme +bug-reports: https://github.com/GetShopTV/changelogged/issues +author: Vitalii Guzeev +maintainer: Vitalii Guzeev +copyright: (c) 2017-2018, GetShop.TV +license: BSD3 +license-file: LICENSE +build-type: Custom +cabal-version: >= 1.10 + +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/GetShopTV/changelogged + +custom-setup + setup-depends: + Cabal + , base + , cabal-doctest >=1.0.2 && <1.1 + +library + hs-source-dirs: + src + default-extensions: OverloadedStrings RecordWildCards + build-depends: + aeson + , ansi-terminal + , base >=4.7 && <5 + , either + , exceptions + , foldl + , mtl + , optparse-applicative + , system-filepath + , text + , turtle >=1.5.0 + , unordered-containers + , vector + , yaml + exposed-modules: + Changelogged + Changelogged.Bump.Common + Changelogged.Bump.General + Changelogged.Bump.Local + Changelogged.CheckLog.Check + Changelogged.CheckLog.Common + Changelogged.Git + Changelogged.Options + Changelogged.Pattern + Changelogged.Pure + Changelogged.Settings + Changelogged.Types + Changelogged.Utils + other-modules: + Paths_changelogged + default-language: Haskell2010 + +executable changelogged + main-is: Main.hs + hs-source-dirs: + app + default-extensions: OverloadedStrings RecordWildCards + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + ansi-terminal + , base >=4.7 && <5 + , changelogged + , turtle >=1.5.0 + , unordered-containers + other-modules: + Paths_changelogged + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: + test + default-extensions: OverloadedStrings RecordWildCards + build-depends: + Glob + , QuickCheck + , ansi-terminal + , base + , doctest + , turtle >=1.5.0 + , unordered-containers + default-language: Haskell2010 diff --git a/src/Changelogged.hs b/src/Changelogged.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged.hs @@ -0,0 +1,1 @@ +module Changelogged where diff --git a/src/Changelogged/Bump/Common.hs b/src/Changelogged/Bump/Common.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/Bump/Common.hs @@ -0,0 +1,90 @@ +module Changelogged.Bump.Common where + +import Prelude hiding (FilePath) +import Turtle + +import Control.Exception +import qualified Control.Foldl as Fold + +import Data.Functor (($>)) +import Data.Text (Text) + +import Filesystem.Path.CurrentOS (encodeString) + +import Changelogged.Types +import Changelogged.Pattern + +-- |Add version label to changelog. +headChangelog :: Text -> FilePath -> IO () +headChangelog version changelog = do + currentLogs <- fold (input changelog) Fold.list + output changelog (return $ unsafeTextToLine version) + append changelog "---" + append changelog "" + append changelog (select currentLogs) + +-- |Bump version in any supported file. +-- Unlike sed it reads all the file and is less memory efficient. +bumpAny :: (Text -> Pattern Text) -> TaggedFile -> Text -> Shell () +bumpAny extGrep TaggedFile{..} version = do + file <- fold (input taggedFilePath) Fold.list + matched <- fold (grep (extGrep taggedFileVariable) (select file)) Fold.list + when (null matched) $ + throw (PatternMatchFail ("ERROR: Cannot bump. Cannot detect version in file " <> encodeString taggedFilePath <> ". Check config.\n")) + changed <- fold (sed (versionExactRegex $> version) (select matched)) Fold.list + output taggedFilePath (select $ generateVersionedFile file changed matched) + +-- |Replace given lines in the file. +-- Here is used and called to write new lines wih versions. +generateVersionedFile + -- template file + :: [Line] + -- new lines + -> [Line] + -- lines to be replaced + -> [Line] + --result + -> [Line] +generateVersionedFile file [] [] = file +generateVersionedFile _ [] _ = error "internal sed error" +generateVersionedFile _ _ [] = error "internal sed error" +generateVersionedFile file (new:news) (old:olds) = generateVersionedFile (replaceLine file new old) news olds + where + replaceLine [] _ _ = [] + replaceLine (xvar:xvars) newLine oldLine + | xvar == oldLine = newLine:xvars + | otherwise = xvar : replaceLine xvars newLine oldLine + +-- |Bump version in file regarding extension. +bumpPart :: Text -> TaggedFile -> IO () +bumpPart version file@TaggedFile{..} = do + printf ("- Updating version for "%fp%"\n") taggedFilePath + case extension taggedFilePath of + Just "hs" -> sh $ bumpAny hsGrep file version + Just "json" -> sh $ bumpAny jsonGrep file version + Just "yaml" -> sh $ bumpAny yamlGrep file version + Just "cabal" -> sh $ bumpAny cabalGrep file version + _ -> throw (PatternMatchFail ("ERROR: Cannot bump version. Unsupported extension in file " <> encodeString taggedFilePath <> ". Check config.")) + +-- |Get level of changes from changelog. +getChangelogEntries :: FilePath -> IO (Maybe Level) +getChangelogEntries changelogFile = do + app <- fold (grep (prefix "* App") unreleased) countLines + major <- fold (grep (prefix "* Major") unreleased) countLines + minor <- fold (grep (prefix "* Minor") unreleased) countLines + fixes <- fold (grep (prefix "* Fix") unreleased) countLines + docs <- fold (grep (prefix "* Doc") unreleased) countLines + + return $ case app of + 0 -> case major of + 0 -> case minor of + 0 -> case fixes of + 0 -> case docs of + 0 -> Nothing + _ -> Just Doc + _ -> Just Fix + _ -> Just Minor + _ -> Just Major + _ -> Just App + where + unreleased = limitWhile (null . match (prefix versionExactRegex) . lineToText) (input changelogFile) diff --git a/src/Changelogged/Bump/General.hs b/src/Changelogged/Bump/General.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/Bump/General.hs @@ -0,0 +1,30 @@ +module Changelogged.Bump.General where + +import Turtle +import Prelude hiding (FilePath) + +import Data.Text (Text) + +import System.Console.ANSI (Color(..)) + +import Changelogged.Types +import Changelogged.Pure +import Changelogged.Utils +import Changelogged.Bump.Common + +-- |Generate new version based on given level and current version. +generateVersion :: Level -> Text -> IO Text +generateVersion lev current = return $ bump (delimited current) lev + +-- |Infer version from changelog. +generateVersionByChangelog :: Bool -> FilePath -> Text -> IO (Maybe Text) +generateVersionByChangelog True _ _ = do + coloredPrint Yellow "You are bumping version with no explicit version modifiers and changelog checks. It can result in anything. Please retry.\n" + return Nothing +generateVersionByChangelog False changelogFile curVersion = do + versionedChanges <- getChangelogEntries changelogFile + case versionedChanges of + Just lev -> Just <$> generateVersion lev curVersion + Nothing -> do + coloredPrint Yellow ("WARNING: keep old version since " <> showPath changelogFile <> " apparently does not contain any new entries.\n") + return Nothing diff --git a/src/Changelogged/Bump/Local.hs b/src/Changelogged/Bump/Local.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/Bump/Local.hs @@ -0,0 +1,58 @@ +module Changelogged.Bump.Local where + +import Turtle +import Prelude hiding (FilePath) + +import Control.Exception +import qualified Control.Foldl as Fold + +import Data.Maybe (fromMaybe) +import Data.Text (Text) + +import Filesystem.Path.CurrentOS (encodeString) +import System.Console.ANSI (Color(..)) + +import Changelogged.Types +import Changelogged.Utils +import Changelogged.Pure +import Changelogged.Pattern +import Changelogged.Bump.Common + +-- |Get current local version. +currentLocalVersion :: TaggedFile -> IO Text +currentLocalVersion TaggedFile{..} = do + ver <- case extension taggedFilePath of + Just "json" -> fold (grep (has $ jsonVarGrep taggedFileVariable) (input taggedFilePath)) Fold.head + Just "hs" -> fold (grep (has $ hsVarGrep taggedFileVariable) (input taggedFilePath)) Fold.head + Just "yaml" -> fold (grep (has $ yamlVarGrep taggedFileVariable) (input taggedFilePath)) Fold.head + Just "cabal" -> fold (grep (has $ cabalVarGrep taggedFileVariable) (input taggedFilePath)) Fold.head + _ -> throw (PatternMatchFail $ "ERROR: Cannot get local version. Unsupported extension in indicator file " <> encodeString taggedFilePath <> ". Check config.\n") + return $ case ver of + Just realVer -> fromMaybe + (throw (PatternMatchFail $ "ERROR: Cannot get local version. Given variable " <> show taggedFileVariable <> " doesn't store version. Check config.\n")) + (versionMatch . lineToText $ realVer) + Nothing -> throw (PatternMatchFail $ "ERROR: Cannot get local version. Cannot find given variable " <> show taggedFileVariable <> " in file " <> encodeString taggedFilePath <> ". Check config.\n") + +-- |Generate new local version. +generateLocalVersion :: Level -> TaggedFile -> IO Text +generateLocalVersion lev indicator = do + current <- currentLocalVersion indicator + -- This print must not be here but I think it's better than throw current vrsion to main. + printf ("Version: "%s%" -> ") current + coloredPrint Yellow (new current <> "\n") + return (new current) + where + new current = bump (delimited current) lev + +-- |Infer new local version. +generateLocalVersionByChangelog :: Bool -> TaggedLog -> IO (Maybe Text) +generateLocalVersionByChangelog True _ = do + coloredPrint Yellow "You are bumping API version with no explicit version modifiers and changelog checks. It can result in anything. Please retry.\n" + return Nothing +generateLocalVersionByChangelog False TaggedLog{..} = do + versionedChanges <- getChangelogEntries taggedLogPath + case versionedChanges of + Just lev -> Just <$> generateLocalVersion lev (fromJustCustom "No file with current local version specified." taggedLogIndicator) + Nothing -> do + coloredPrint Yellow ("WARNING: keep old API version since " <> showPath taggedLogPath <> " apparently does not contain any new entries.\n") + return Nothing diff --git a/src/Changelogged/CheckLog/Check.hs b/src/Changelogged/CheckLog/Check.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/CheckLog/Check.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Changelogged.CheckLog.Check where + +import Turtle hiding (stdout, stderr) +import Prelude hiding (FilePath) + +import qualified Control.Foldl as Fold +import Control.Monad (when, filterM) + +import System.Console.ANSI (Color(..)) + +import Changelogged.Types +import Changelogged.Options +import Changelogged.Utils +import Changelogged.Pure +import Changelogged.Pattern +import Changelogged.CheckLog.Common + +-- |This is actually part if '@Main@' +-- Check common changelog. +checkCommonChangelogF :: WarningFormat -> Bool -> Git -> FilePath -> IO Bool +checkCommonChangelogF fmt writeLog Git{..} changelog = do + printf ("Checking "%fp%"\n") changelog + + pullCommits <- map (fromJustCustom "Cannot find commit hash in git log entry" . hashMatch . lineToText) + <$> fold (grep githubRefGrep (input gitHistory)) Fold.list + pulls <- map (fromJustCustom "Cannot find pull request number in git log entry" . githubRefMatch . lineToText) + <$> fold (grep githubRefGrep (input gitHistory)) Fold.list + singles <- map (fromJustCustom "Cannot find commit hash in git log entry" . hashMatch . lineToText) + <$> fold (grep hashGrepExclude (input gitHistory)) Fold.list + + filteredSingles <- filterM noMarkdown singles + + pullHeaders <- mapM (commitMessage PR) pullCommits + singleHeaders <- mapM (commitMessage Commit) filteredSingles + flagsPR <- mapM (\(i,m) -> changelogIsUp fmt writeLog gitLink i PR m changelog) (zip pulls pullHeaders) + flagsCommit <- mapM (\(i, m) -> changelogIsUp fmt writeLog gitLink i Commit m changelog) (zip filteredSingles singleHeaders) + return $ and (flagsPR ++ flagsCommit) + +-- |This is actually part if '@Main@' +-- Check local changelog - local means what changelog is specific and has some indicator file. If file is changed changelog must change. +checkLocalChangelogF :: WarningFormat -> Bool -> Git -> FilePath -> FilePath -> IO Bool +checkLocalChangelogF fmt writeLog Git{..} path indicator = do + printf ("Checking "%fp%"\n") path + + commits <- map (fromJustCustom "Cannot find commit hash in git log entry" . hashMatch . lineToText) + <$> fold (input gitHistory) Fold.list + + flags <- mapM (eval gitHistory) commits + return $ and flags + where + eval hist commit = do + linePresent <- fold + (grep (has $ text $ showPath indicator) + (inproc "git" ["show", "--stat", commit] empty)) + countLines + case linePresent of + 0 -> return True + _ -> do + pull <- fmap (fromJustCustom "Cannot find commit hash in git log entry" . githubRefMatch . lineToText) <$> + fold (grep githubRefGrep (grep (has (text commit)) (input hist))) Fold.head + case pull of + Nothing -> do + message <- commitMessage Commit commit + changelogIsUp fmt writeLog gitLink commit Commit message path + Just pnum -> do + message <- commitMessage PR commit + changelogIsUp fmt writeLog gitLink pnum PR message path + +-- |This is actually part if '@Main@' +-- Check given changelog regarding options. +checkChangelogWrap :: Options -> Git -> Bool -> TaggedLog -> IO Bool +checkChangelogWrap _ _ True _ = do + coloredPrint Yellow "WARNING: skipping checks for API changelog.\n" + return True +checkChangelogWrap Options{..} git False TaggedLog{..} = do + when optFromBC $ printf ("Checking "%fp%" from start of project\n") taggedLogPath + upToDate <- case taggedLogIndicator of + Nothing -> checkCommonChangelogF optFormat optWrite git taggedLogPath + Just ind -> checkLocalChangelogF optFormat optWrite git taggedLogPath (taggedFilePath ind) + if upToDate + then coloredPrint Green (showPath taggedLogPath <> " is up to date.\n") + else coloredPrint Yellow ("WARNING: " <> showPath taggedLogPath <> " is out of date.\n") + if upToDate + then return True + else do + coloredPrint Red ("ERROR: " <> showPath taggedLogPath <> " is not up-to-date. Use -c or --no-check options if you want to ignore changelog checks and -f to bump anyway.\n") + return optForce diff --git a/src/Changelogged/CheckLog/Common.hs b/src/Changelogged/CheckLog/Common.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/CheckLog/Common.hs @@ -0,0 +1,96 @@ +module Changelogged.CheckLog.Common where + +import Prelude hiding (FilePath) +import Turtle + +import qualified Control.Foldl as Fold + +import Data.Text (Text) +import qualified Data.Text as Text + +import System.Console.ANSI (Color(..)) + +import Changelogged.Types +import Changelogged.Utils +import Changelogged.Pure + +-- |Check if commit/pr is present in changelog. Return '@True@' if present. +changelogIsUp :: WarningFormat -> Bool -> Text -> Text -> Mode -> Text -> FilePath -> IO Bool +changelogIsUp fmt writeSug link item mode message changelog = do + grepLen <- fold (grep (has (text item)) (input changelog)) countLines + case grepLen of + 0 -> do + case fmt of + WarnSimple -> warnMissing item mode message + WarnSuggest -> do + suggestMissing link item mode message + when writeSug $ addMissing link item mode message changelog + return False + _ -> return True + +-- |Ignore commits which only affect '.md' files +noMarkdown :: Text -> IO Bool +noMarkdown commit = do + statCommit <- fold (inproc "git" ["show", "--stat", commit] empty) Fold.list + chLogUpdated <- fold + (grep (has $ text ".md ") + (select statCommit)) countLines + onlyChLogUpdated <- fold + (grep (has $ text "|") + (select statCommit)) countLines + return $ chLogUpdated /= onlyChLogUpdated + +-- | +warnMissing :: Text -> Mode -> Text -> IO () +warnMissing item mode message = do + printf ("- "%s%" ") (showText mode) + coloredPrint Cyan item + printf (" is missing: "%s%".\n") message + +-- | +-- >>> prLink "https://github.com/GetShopTV/changelogged" "#13" +-- "https://github.com/GetShopTV/changelogged/pull/13" +prLink :: Text -> Text -> Text +prLink link num = link <> "/pull/" <> Text.drop 1 num + +-- | +-- >>> commitLink "https://github.com/GetShopTV/changelogged" "9e14840" +-- "https://github.com/GetShopTV/changelogged/commit/9e14840" +commitLink :: Text -> Text -> Text +commitLink link sha = link <> "/commit/" <> sha + +-- | +suggestMissing :: Text -> Text -> Mode -> Text -> IO () +suggestMissing link item mode message = do + printf ("- "%s%" (see ") message + case mode of + PR -> do + coloredPrint Cyan ("[" <> item <> "]") + printf ("("%s%")") (prLink link item) + Commit -> do + coloredPrint Cyan ("[`" <> item <> "`]") + printf ("("%s%")") (commitLink link item) + printf ");\n" + +-- |Add generated suggestion directly to changelog. +addMissing :: Text -> Text -> Mode -> Text -> FilePath -> IO () +addMissing link item mode message changelog = do + currentLogs <- fold (input changelog) Fold.list + output changelog (return $ unsafeTextToLine entry) + append changelog (select currentLogs) + where + entry = prolog <> sense <> epilog + prolog = "- " <> message <> " (see " + sense = case mode of + PR -> "[" <> item <> "]" <> "(" <> prLink link item <> ")" + Commit -> "[`" <> item <> "`]" <> "(" <> commitLink link item <> ")" + epilog = ");" + +-- |Get commit message for any entry in history. +commitMessage :: Mode -> Text -> IO Text +commitMessage _ "" = return "" +commitMessage mode commit = do + summary <- fold (inproc "git" ["show", commit] empty) Fold.list + return $ Text.stripStart $ lineToText $ case mode of + PR -> summary !! 7 + Commit -> summary !! 4 diff --git a/src/Changelogged/Git.hs b/src/Changelogged/Git.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/Git.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Changelogged.Git where + +import qualified Control.Foldl as Fold +import Control.Monad.Catch (catch) + +import Data.Char (isDigit) +import Data.Either.Combinators (fromRight) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text + +import Turtle + +import Changelogged.Types + +-- |Get latest git tag in origin/master if present. +latestGitTag :: Text -> IO Text +latestGitTag repl = do + ver <- fold ((fromRight "" <$> inprocWithErr "git" ["describe", "--tags", "origin/master"] empty) `catch` \ (_ :: ExitCode) -> empty) Fold.head + return $ case ver of + Nothing -> repl + Just v -> lineToText v + +-- |Get link to origin and strip '.git' to get valid url to project page. +getLink :: IO Text +getLink = do + raw <- strict $ inproc "git" ["remote", "get-url", "origin"] empty + return $ fromMaybe (Text.stripEnd raw) (Text.stripSuffix ".git\n" raw) + +-- |Extract latest history and origin link from git through temporary file and store it in '@Git@'. +gitData :: Bool -> IO Git +gitData start = do + curDir <- pwd + tmpFile <- with (mktempfile curDir "tmp_") return + latestTag <- latestGitTag "" + link <- getLink + hist <- if start || (latestTag == "") + then fold (grep (invert (has (text "Merge branch"))) (inproc "git" ["log", "--oneline", "--first-parent"] empty)) Fold.list + else fold (grep (invert (has (text "Merge branch"))) (inproc "git" ["log", "--oneline", "--first-parent", latestTag <> "..HEAD"] empty)) Fold.list + liftIO $ append tmpFile (select hist) + return $ Git tmpFile link (version latestTag) + where + version tag = case tag of + "" -> "0.0.0.0.0" + v -> Text.dropWhile (not . isDigit) v diff --git a/src/Changelogged/Options.hs b/src/Changelogged/Options.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/Options.hs @@ -0,0 +1,107 @@ +module Changelogged.Options where + +import Data.Char (toLower) + +import Options.Applicative hiding (switch) +import Turtle hiding (option) + +import Changelogged.Types + +availableWarningFormats :: [WarningFormat] +availableWarningFormats = [minBound..maxBound] + +availableWarningFormatsStr :: String +availableWarningFormatsStr + = "(" <> unwords (map (map toLower . show) availableWarningFormats) <> ")" + +readWarningFormat :: ReadM WarningFormat +readWarningFormat = eitherReader (r . map toLower) + where + r "simple" = Right WarnSimple + r "suggest" = Right WarnSuggest + r fmt = Left $ + "Unknown warning format: " <> show fmt <> ".\n" + <> "Use one of " <> availableWarningFormatsStr <> ".\n" + +-- | +-- >>> availableLevels +-- [App,Major,Minor,Fix,Doc] +availableLevels :: [Level] +availableLevels = [minBound..maxBound] + +-- | +-- >>> availableLevelsStr +-- "(app major minor fix doc)" +availableLevelsStr :: String +availableLevelsStr + = "(" <> unwords (map (map toLower . show) availableLevels) <> ")" + +readLevel :: ReadM Level +readLevel = eitherReader (r . map toLower) + where + r "app" = Right App + r "major" = Right Major + r "minor" = Right Minor + r "fix" = Right Fix + r "doc" = Right Doc + r lvl = Left $ + "Unknown level of changes: " <> show lvl <> ".\n" + <> "Use one of " <> availableLevelsStr <> ".\n" + +parser :: Parser Options +parser = Options + <$> optional packagesLevel + <*> optional apiLevel + <*> warningFormat + <*> switch "with-api" 'W' "Assume there is changelog for API." + <*> switch "multiple" 'm' "Assume there is more than one changelog." + <*> switch "no-check" 'c' "Do not check changelogs." + <*> switch "no-bump" 'C' "Do not bump versions. Only check changelogs." + <*> switch "from-bc" 'e' "Check changelogs from start of project." + <*> switch "force" 'f' "Bump version even if changelogs are outdated. Cannot be mixed with -c." + <*> switch "write" 'y' "Write changelog suggestions to changelog directly. Available with --format suggest." + where + packagesLevel = option readLevel $ + long "level" + <> short 'l' + <> help ("Level of changes (for packages). One of " <> availableLevelsStr) + apiLevel = option readLevel $ + long "api-level" + <> short 'a' + <> help ("Level of changes (for API). One of " <> availableLevelsStr) + warningFormat = option readWarningFormat $ + long "format" + <> help ("Warning format. One of " <> availableWarningFormatsStr) + <> value WarnSimple + <> showDefault + +welcome :: Description +welcome = Description $ "---\n" + <> "This tool can check your changelogs and bump versions in project.\n" + <> "It assumes to be run in root directory of project and that changelog is here.\n" + <> "You can specify these levels of changes: app, major, minor, fix, doc.\n" + <> "It can infer version from changelog.\n" + <> "But it will refuse to do it if it's not sure changelogs are up to date." + +data Options = Options + { -- |Explicit level of changes for files with common versioning. + optPackagesLevel :: Maybe Level + -- |Explicit level of changes in API. + , optApiLevel :: Maybe Level + -- |Output formatting. + , optFormat :: WarningFormat + -- |Assume there is API to check and bump. + , optWithAPI :: Bool + -- |Assume there is some changelogs with unpredicted meanings. + , optDifferentChlogs :: Bool + -- |Do not check changelogs. + , optNoCheck :: Bool + -- |Do not bump versions. + , optNoBump :: Bool + -- |Check changelogs from start of project. + , optFromBC :: Bool + -- |Bump versions even if changelogs are outdated. + , optForce :: Bool + -- |Write suggestions to changelog directly. + , optWrite :: Bool + } diff --git a/src/Changelogged/Pattern.hs b/src/Changelogged/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/Pattern.hs @@ -0,0 +1,158 @@ +-- |Common regexps in Turtle syntax. +module Changelogged.Pattern where + +import Turtle.Pattern +import Turtle ((<>), (<|>)) +import Data.Text (Text, intercalate) + +import Changelogged.Pure + +-- >>> match versionExactRegex "version: 1.1.1" +-- [] +-- >>> match versionExactRegex "1.1.1" +-- ["1.1.1"] +-- >>> match versionExactRegex "1.1.1 yy" +-- [] +versionExactRegex :: Pattern Text +versionExactRegex = once digit <> "." <> (intercalate "." <$> plus digit `sepBy1` ".") + +-- >>> versionMatch "\"version\": \"1.1.1\"" +-- Just "1.1.1" +-- >>> versionMatch "version = 1.1.1" +-- Just "1.1.1" +-- >>> versionMatch "version = v1.1.1" +-- Just "1.1.1" +-- >>> versionMatch "version = v1.1." +-- Just "1.1" +-- >>> versionMatch "version = v.1." +-- Nothing +-- >>> versionMatch "version = .1." +-- Nothing +-- >>> versionMatch "version = 1.1." +-- Just "1.1" +versionMatch :: Text -> Maybe Text +versionMatch str = maxByLen $ match (has versionExactRegex) str + +-- >>> match hashRegex "f4875f4 Update changelog" +-- ["f4875f4","f4875f","f4875","f487","f48","f4","f"] +-- >>> match hashRegex "f4875f4 Update changelog d1123d" +-- ["f4875f4","f4875f","f4875","f487","f48","f4","f"] +-- >>> match hashRegex "f4875f423d Update changelog d1123d" +-- ["f4875f423d","f4875f423","f4875f42","f4875f4","f4875f","f4875","f487","f48","f4","f"] +-- >>> match hashRegex "fE4875f423d Update changelog" +-- [] +-- >>> match hashRegex "Update changelog" +-- [] +hashRegex :: Pattern Text +hashRegex = prefix $ between (within 0 chars) spaces1 (plus (digit <|> lower)) + +-- >>> match hashGrepExclude "ee17741 Merge pull request #38 from GetShopTV/redesign-strategies" +-- [] +-- >>> match hashGrepExclude "ee17741 Reference pull request #38 from GetShopTV/redesign-strategies" +-- [()] +hashGrepExclude :: Pattern () +hashGrepExclude = invert (hashRegex <> spaces <> text "Merge") + +-- >>> hashMatch "f4875f4 Update changelog" +-- Just "f4875f4" +-- >>> hashMatch "Update changelog" +-- Nothing +hashMatch :: Text -> Maybe Text +hashMatch str = maxByLen $ match hashRegex str + +-- >>> match githubRefRegex "d #444 f" +-- ["#444","#44","#4"] +-- >>> match githubRefRegex "d 444 f" +-- [] +-- >>> match githubRefRegex "d # f" +-- [] +-- >>> match githubRefRegex "d (#444) f" +-- ["#444","#44","#4"] +githubRefRegex :: Pattern Text +githubRefRegex = has $ "#" <> plus digit + +-- >>> match githubRefGrep "pull request #44" +-- ["pull request #"] +-- >>> match githubRefGrep "pull request" +-- [] +-- >>> match githubRefGrep "#44" +-- [] +githubRefGrep :: Pattern Text +githubRefGrep = has (text "pull request #") + +-- >>> githubRefMatch "text #444 text" +-- Just "#444" +githubRefMatch :: Text -> Maybe Text +githubRefMatch str = maxByLen $ match githubRefRegex str + +-- >>> match (jsonGrep "var") "\"var\" : \"1.1.1\"" +-- ["\"var\" : \"1.1.1\""] +-- >>> match (jsonGrep "v") "\"var\" : \"1.1.1\"" +-- [] +-- >>> match (jsonGrep "v") "\"v\" : 1.1.1\"" +-- [] +-- >>> match (jsonGrep "v") "\"v\":\"1.1.1\"" +-- ["\"v\":\"1.1.1\""] +-- >>> match (jsonGrep "v") "\"v\"=\"1.1.1\"" +-- [] +jsonGrep :: Text -> Pattern Text +jsonGrep var = has $ jsonVarGrep var <> spaces <> "\"" <> versionExactRegex <> "\"" + +-- >>> match (cabalGrep "var") "var: 1.1.1" +-- ["var: 1.1.1","var: 1.1"] +-- >>> match (cabalGrep "var") "v: 1.1.1" +-- [] +-- >>> match (cabalGrep "var") "var: (1.1.1)" +-- [] +-- >>> match (cabalGrep "var") "var: 1.1.1 2.2.2.2 " +-- ["var: 1.1.1","var: 1.1"] +-- >>> match (cabalGrep "var") "var: 1.1.1" +-- ["var: 1.1.1"] +-- >>> match (cabalGrep "var") "var: 1.1.1 " +-- ["var:1.1.1"] +-- >>> match (cabalGrep "var") "var: 1.1.1h " +-- [] +cabalGrep :: Text -> Pattern Text +cabalGrep var = choice [has $ cabalVarGrep var <> between spaces spaces1 versionExactRegex, suffix $ cabalVarGrep var <> spaces <> versionExactRegex] + +-- >>> match (hsGrep "var") "var= \"1.1.1\" " +-- ["var= \"1.1.1\""] +-- >>> match (hsGrep "var") "v= \"1.1.1\" " +-- [] +-- >>> match (hsGrep "var") "var= 1.1.1 " +-- [] +hsGrep :: Text -> Pattern Text +hsGrep var = has $ hsVarGrep var <> spaces <> "\"" <> versionExactRegex <> "\"" + +yamlGrep :: Text -> Pattern Text +yamlGrep = cabalGrep + +-- >>> match (jsonVarGrep "var") "var :" +-- [] +-- >>> match (jsonVarGrep "var") "var =" +-- [] +-- >>> match (jsonVarGrep "var") "\"var\" :" +-- ["\"var\" :"] +jsonVarGrep :: Text -> Pattern Text +jsonVarGrep var = "\"" <> text var <> "\"" <> spaces <> ":" + +-- >>> match (hsVarGrep "var") "var =" +-- ["var ="] +-- >>> match (hsVarGrep "var") "var :" +-- [] +-- >>> match (hsVarGrep "var") "\"var\" :" +-- [] +cabalVarGrep :: Text -> Pattern Text +cabalVarGrep var = text var <> spaces <> ":" + +-- >>> match (cabalVarGrep "var") "\"var\" :" +-- [] +-- >>> match (cabalVarGrep "var") "var :" +-- ["var :"] +-- >>> match (cabalVarGrep "var") "var =" +-- [] +hsVarGrep :: Text -> Pattern Text +hsVarGrep var = text var <> spaces <> "=" + +yamlVarGrep :: Text -> Pattern Text +yamlVarGrep = cabalVarGrep diff --git a/src/Changelogged/Pure.hs b/src/Changelogged/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/Pure.hs @@ -0,0 +1,52 @@ +module Changelogged.Pure where + +import Prelude hiding (FilePath) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text + +import Filesystem.Path.CurrentOS (encodeString, FilePath) + +import Changelogged.Types + +-- | Maximum in list ordered by length. +maxByLen :: [Text] -> Maybe Text +maxByLen [] = Nothing +maxByLen hs = Just $ foldl1 (\left right -> if Text.length left > Text.length right then left else right) hs + +-- +defaultedEmpty :: Maybe (HM.HashMap k v) -> HM.HashMap k v +defaultedEmpty = fromMaybe HM.empty + +-- |'@fromJust@' function with custom error message. +fromJustCustom :: String -> Maybe a -> a +fromJustCustom msg Nothing = error msg +fromJustCustom _ (Just a) = a + +-- I leave tuple here cause it's all functions for internal usage only (tuplify, delimited, bump). +tuplify :: [Int] -> (Int, Int, Int, Int, Int) +tuplify [] = (0,0,0,0,0) +tuplify [a1] = (a1,0,0,0,0) +tuplify [a1,a2] = (a1,a2,0,0,0) +tuplify [a1,a2,a3] = (a1,a2,a3,0,0) +tuplify [a1,a2,a3,a4] = (a1,a2,a3,a4,0) +tuplify [a1,a2,a3,a4,a5] = (a1,a2,a3,a4,a5) +tuplify (a1:a2:a3:a4:a5:_) = (a1,a2,a3,a4,a5) + +delimited :: Text -> (Int, Int, Int, Int, Int) +delimited ver = tuplify $ map (read . Text.unpack) (Text.split (=='.') ver) + +bump :: (Int, Int, Int, Int, Int) -> Level -> Text +bump (app, major, minor, fix, doc) lev = Text.intercalate "." $ map showText $ case lev of + App -> [app + 1, 0] + Major -> [app, major + 1, 0] + Minor -> [app, major, minor + 1, 0] + Fix -> [app, major, minor, fix + 1, 0] + Doc -> [app, major, minor, fix, doc + 1] + +showPath :: FilePath -> Text +showPath = Text.pack . encodeString + +showText :: Show a => a -> Text +showText = Text.pack . show diff --git a/src/Changelogged/Settings.hs b/src/Changelogged/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/Settings.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Changelogged.Settings where + +import Prelude hiding (FilePath) +import Turtle + +import qualified Control.Foldl as Fold +import Filesystem.Path.CurrentOS ((<.>), encodeString, decodeString) + +import Data.Aeson.Types (typeMismatch) +import qualified Data.HashMap.Strict as HM +import Data.List (isInfixOf) +import Data.Text (Text) +import qualified Data.Yaml as Yaml +import Data.Vector ((!)) +import Data.Yaml ((.:), (.:?)) + +import GHC.Generics + +import Changelogged.Types + +data Paths = Paths { + -- Changelogs data + changelogs :: Maybe (HM.HashMap Text TaggedLog) + -- Files to bump data + , versioned :: Maybe (HM.HashMap Text [TaggedFile]) + } deriving (Show, Generic) + +makeDefaultPaths :: IO Paths +makeDefaultPaths = do + cabals <- fold (find (suffix (text "package.yaml")) ".") Fold.list + let textualCabals = map encodeString cabals + filedCabals = map decodeString + taggedFiles = map (`TaggedFile` "version") (filedCabals $ filter (not . isInfixOf "/.") textualCabals) + defaultChLog = TaggedLog ("ChangeLog" <.> "md") Nothing + return $ Paths (Just $ HM.singleton "main" defaultChLog) (Just $ HM.singleton "main" taggedFiles) + +instance Yaml.FromJSON Paths + +instance Yaml.FromJSON TaggedFile where + parseJSON (Yaml.Object v) = TaggedFile + <$> v .: "path" + <*> v .: "variable" + parseJSON (Yaml.Array v) = TaggedFile + <$> Yaml.parseJSON (v ! 0) + <*> Yaml.parseJSON (v ! 1) + parseJSON invalid = typeMismatch "TaggedFile" invalid + +instance Yaml.FromJSON TaggedLog where + parseJSON (Yaml.Object v) = TaggedLog + <$> v .: "path" + <*> v .:? "indicator" + parseJSON (Yaml.Array v) = TaggedLog + <$> Yaml.parseJSON (v ! 0) + <*> Yaml.parseJSON (v ! 1) + parseJSON invalid = typeMismatch "TaggedLog" invalid + +instance Yaml.FromJSON FilePath where + parseJSON = fmap fromText . Yaml.parseJSON + +loadPaths :: IO (Maybe Paths) +loadPaths = do + ms <- Yaml.decodeFileEither "./changelogged.yaml" + return $ case ms of + Left _wrong -> Nothing + Right paths -> Just paths diff --git a/src/Changelogged/Types.hs b/src/Changelogged/Types.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/Types.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveGeneric #-} +module Changelogged.Types where + +import Data.Text (Text) + +import Prelude hiding (FilePath) +import Turtle + +import GHC.Generics + +type Variable = Text +type Key = Text + +-- |Level of changes to bump to. +data Level = App | Major | Minor | Fix | Doc + deriving (Show, Enum, Bounded) + +-- |Type of entry in git history. +data Mode = PR | Commit + +-- |Structure to save once token git data. +data Git = Git + { gitHistory :: FilePath + , gitLink :: Text + , gitRevision :: Text + } + +-- |File with identifier of version to bump. +data TaggedFile = TaggedFile + { taggedFilePath :: FilePath + , taggedFileVariable :: Variable + } deriving (Show, Generic) + +-- |Changelog with optional file indicating changes. +data TaggedLog = TaggedLog + { taggedLogPath :: FilePath + , taggedLogIndicator :: Maybe TaggedFile + } deriving (Show, Generic) + +instance Show Mode where + show PR = "Pull request" + show Commit = "Single commit" + +data WarningFormat + = WarnSimple + | WarnSuggest + deriving (Enum, Bounded) + +instance Show WarningFormat where + show WarnSimple = "simple" + show WarnSuggest = "suggest" diff --git a/src/Changelogged/Utils.hs b/src/Changelogged/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Changelogged/Utils.hs @@ -0,0 +1,14 @@ +module Changelogged.Utils where + +import Data.Text (Text) + +import System.Console.ANSI + +import Turtle.Format + +-- |Print '@text@' with ansi-terminal color. +coloredPrint :: Color -> Text -> IO () +coloredPrint color line = do + setSGR [SetColor Foreground Vivid color] + printf s line + setSGR [Reset] diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,12 @@ +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import Test.DocTest + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources