diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,18 @@ # Changelog All notable changes to this project will be documented in this file. +## 0.3.0.0 (released 2020-06-28) +- [#25] Extract _dynamic variables_ from Haskell source code files +- [#29] Add _dynamic variable_ for current year and add support for updating years +- [#30] Allow workflow without configuration and template files +- [#49] Microsite for documentation ([https://doc.norcane.com/headroom/latest/](https://doc.norcane.com/headroom/latest/)) +- [#51] Allow template variable values to be templates itself +- [#52] Post-processing functions for _license headers_ +- Various bugfixes and performance improvements +- Bump _LTS Haskell_ to `16.2` + ## 0.2.2.1 (released 2020-05-08) -- Minor improves in generated `.headroom.config` in `init` mode +- Minor improves in generated `.headroom.yaml` in `init` mode ## 0.2.2.0 (released 2020-05-04) - [#45] Add `-c|--check-headers` command line option diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,38 @@ -Would you like to have nice, up-to-date license/copyright headers in your source code files but hate to manage them by hand? Then __Headroom__ is the right tool for you! Now you can define your license header as [Mustache][web:mustache] template, put all the variables (such as author's name, year, etc.) into the [YAML][wiki:yaml] config file and Headroom will take care to add such license headers to all your source code files. +Would you like to have nice, up-to-date license/copyright headers in your source code files but hate to manage them manually? Then __Headroom__ is the right tool for you. Define your license header as [Mustache][web:mustache] template, put any template variables into [YAML][wiki:yaml] configuarion file, and you're ready to go! +__Headroom__ also offers much more than just [adding, replacing or dropping][doc:running-headroom] license headers. It can also [update years in copyrights][doc:post-processing] for you, provides [extended functionality][doc:extended-functionality] for some source code file types, and much more! + [![asciicast](https://asciinema.org/a/4Pfxdss0V4msFjjt2z6mgCZCp.svg)](https://asciinema.org/a/4Pfxdss0V4msFjjt2z6mgCZCp) -See the [GitHub project page](https://github.com/vaclavsvejcar/headroom/) for more details. +## Main Features +- __License Header Management__ - [Add, replace or drop license headers][doc:running-headroom] in your source code files with a single command. What's more, contrary to many similar tools, _Headroom_ allows you to also replace/drop headers that weren't previously generated by _Headroom_, using smart header auto-detection. +- __Powerful Customization__ - Default [configuration][doc:configuration] should cover most use-cases, but if you need to put empty lines before/after generated header, use different comment style of headers, you can customize the configuration to match exactly your needs. +- __Built-in OSS License Headers__ - If you want to use license header for one of the popular OSS licenses, then __Headroom__ can [generate them for you][doc:running-headroom#gen-command] - no need to search for them on web. +- __Automatic Initialization for OSS Projects__ - Setting up external tools like _Headroom_ for your project can be boring. Fortunately, _Headroom_ can [initialize itself][doc:running-headroom#init-command] for your project, by generating configuration file and template files. +- __Extended Functionality__ - _Headroom_ supports [extended functionality][doc:extended-functionality] for selected types of source code files, such as extracting extra data from processed source code files. +- __Copyright Year Updater__ - _Headroom_ is good not only for basic license header management, but also for further processing of generated headers. Do you need to [update years in your copyrights][doc:post-processing]? No problem! +## Adopters +Here is the list of projects using _Headroom_. If you're using _Headroom_ and aren't on the list, feel free to [submit new issue][meta:new-issue] or [pull request][meta:pulls]. + +- [kowainik/hit-on](https://github.com/kowainik/hit-on) - Kowainik Git Workflow Helper Tool +- [kowainik/summoner](https://github.com/kowainik/summoner) - Tool for scaffolding batteries-included production-level Haskell projects +- [wireapp/wire-server](https://github.com/wireapp/wire-server) - Wire back-end services (https://wire.com) + +## Documentation +* for end-user documentation, [official project microsite][web:headroom] +* for _Haskell API_ documentation, see [Headroom on Hackage][hackage:headroom] + +[i25]: https://github.com/vaclavsvejcar/headroom/issues/25 +[hackage:headroom]: https://hackage.haskell.org/package/headroom +[meta:new-issue]: https://github.com/vaclavsvejcar/headroom/issues/new +[meta:pulls]: https://github.com/vaclavsvejcar/headroom/pulls +[web:headroom]: https://doc.norcane.com/headroom/latest/ +[doc:configuration]: https://doc.norcane.com/headroom/latest/documentation/configuration/ +[doc:extended-functionality]: https://doc.norcane.com/headroom/latest/documentation/extended-functionality/ +[doc:post-processing]: https://doc.norcane.com/headroom/latest/documentation/post-processing/ +[doc:running-headroom]: https://doc.norcane.com/headroom/latest/documentation/running-headroom/ +[doc:running-headroom#gen-command]: https://doc.norcane.com/headroom/latest/documentation/running-headroom/#gen-command +[doc:running-headroom#init-command]: https://doc.norcane.com/headroom/latest/documentation/running-headroom/#init-command [web:mustache]: https://mustache.github.io +[wiki:yaml]: https://en.wikipedia.org/wiki/YAML diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -24,15 +24,15 @@ ) import Headroom.Command.Init ( commandInit ) import Headroom.Command.Run ( commandRun ) -import Headroom.Types ( ApplicationError(..) - , Command(..) +import Headroom.Command.Types ( Command(..) , CommandGenOptions(..) , CommandInitOptions(..) , CommandRunOptions(..) ) -import Options.Applicative -import Prelude ( putStrLn ) +import Headroom.Types ( HeadroomError(..) ) +import Options.Applicative ( execParser ) import RIO +import System.IO ( hPutStrLn ) main :: IO () @@ -41,7 +41,7 @@ catch (bootstrap command') (\ex -> do - putStrLn $ "ERROR: " <> displayException (ex :: ApplicationError) + hPutStrLn stderr $ "ERROR: " <> displayException (ex :: HeadroomError) exitWith $ ExitFailure 1 ) @@ -51,5 +51,5 @@ cgoGenMode <- parseGenMode c commandGen CommandGenOptions { .. } Init cioLicenseType cioSourcePaths -> commandInit CommandInitOptions { .. } - Run croSourcePaths croExcludedPaths croTemplatePaths croVariables croRunMode croDebug croDryRun + Run croSourcePaths croExcludedPaths croTemplateSource croVariables croRunMode croDebug croDryRun -> commandRun CommandRunOptions { .. } diff --git a/embedded/default-config.yaml b/embedded/default-config.yaml --- a/embedded/default-config.yaml +++ b/embedded/default-config.yaml @@ -36,10 +36,15 @@ ## Variables (key-value) to replace in templates, ## same as '-v|--variable="KEY=VALUE"' command line argument (can be used ## multiple times for more than one path). -## -## NOTE: Not defined in default configuration as this options must be defined by -## the user. -# variables: {} +variables: + _haskell_module_copyright: "!!! INSERT HASKELL MODULE COPYRIGHT !!!" + _haskell_module_name: "!!! INSERT HASKELL MODULE NAME !!!" + _haskell_module_license: "!!! INSERT MODULE LICENSE !!!" + _haskell_module_maintainer: "!!! INSERT MODULE MAINTAINER !!!" + _haskell_module_stability: "!!! INSERT MODULE STABILITY !!!" + _haskell_module_portability: "!!! INSERT MODULE PORTABILITY !!!" + _haskell_module_longdesc: "!!! INSERT MODULE LONG DESCRIPTION !!!" + _haskell_module_shortdesc: "!!! INSERT MODULE SHORT DESCRIPTION !!!" ## Allows to change behaviour of license header detection and placement. Such ## configuration is defined for every supported file type, where individual @@ -177,3 +182,21 @@ put-before: [] line-comment: prefixed-by: "#" + + +## Configuration for post-processing license header functions. These functions +## allows to modify/enhance already rendered license headers, e.g. update years +## in copyright statements, etc. Each function can be enabled/disabled using the +## 'enabled' key and eventually customized using the 'config' key. +post-process: + + ## License header function that updates years in copyright statements in + ## rendered license header. If you need to update copyright year only for + ## selected author(s), define them in 'selected-authors-only' key, otherwise + ## ommit/comment out this key completely and all copyright statements will be + ## updated. + update-copyright: + enabled: false + config: + ## If used, updates copyright statements of selected authors only. + # selected-authors-only: ["John Smith"] diff --git a/embedded/license/apache2/haskell.mustache b/embedded/license/apache2/haskell.mustache --- a/embedded/license/apache2/haskell.mustache +++ b/embedded/license/apache2/haskell.mustache @@ -1,11 +1,11 @@ {-| -Module : MODULE_NAME -Description : SHORT_DESC +Module : {{{ _haskell_module_name }}} +Description : {{{ _haskell_module_shortdesc }}} Copyright : (c) {{ year }} {{ author }} License : Apache License, version 2.0 Maintainer : {{ email }} Stability : experimental Portability : POSIX -LONG_DESC +{{{ _haskell_module_longdesc }}} -} diff --git a/embedded/license/bsd3/haskell.mustache b/embedded/license/bsd3/haskell.mustache --- a/embedded/license/bsd3/haskell.mustache +++ b/embedded/license/bsd3/haskell.mustache @@ -1,11 +1,11 @@ {-| -Module : MODULE_NAME -Description : SHORT_DESC +Module : {{{ _haskell_module_name }}} +Description : {{{ _haskell_module_shortdesc }}} Copyright : (c) {{ year }} {{ author }} License : BSD-3-Clause Maintainer : {{ email }} Stability : experimental Portability : POSIX -LONG_DESC +{{{ _haskell_module_longdesc }}} -} diff --git a/embedded/license/gpl2/haskell.mustache b/embedded/license/gpl2/haskell.mustache --- a/embedded/license/gpl2/haskell.mustache +++ b/embedded/license/gpl2/haskell.mustache @@ -1,11 +1,11 @@ {-| -Module : MODULE_NAME -Description : SHORT_DESC +Module : {{{ _haskell_module_name }}} +Description : {{{ _haskell_module_shortdesc }}} Copyright : (c) {{ year }} {{ author }} License : GNU GPL v.2 Maintainer : {{ email }} Stability : experimental Portability : POSIX -LONG_DESC +{{{ _haskell_module_longdesc }}} -} diff --git a/embedded/license/gpl3/haskell.mustache b/embedded/license/gpl3/haskell.mustache --- a/embedded/license/gpl3/haskell.mustache +++ b/embedded/license/gpl3/haskell.mustache @@ -1,11 +1,11 @@ {-| -Module : MODULE_NAME -Description : SHORT_DESC +Module : {{{ _haskell_module_name }}} +Description : {{{ _haskell_module_shortdesc }}} Copyright : (c) {{ year }} {{ author }} License : GNU GPL v.3 Maintainer : {{ email }} Stability : experimental Portability : POSIX -LONG_DESC +{{{ _haskell_module_longdesc }}} -} diff --git a/embedded/license/mit/haskell.mustache b/embedded/license/mit/haskell.mustache --- a/embedded/license/mit/haskell.mustache +++ b/embedded/license/mit/haskell.mustache @@ -1,11 +1,11 @@ {-| -Module : MODULE_NAME -Description : SHORT_DESC +Module : {{{ _haskell_module_name }}} +Description : {{{ _haskell_module_shortdesc }}} Copyright : (c) {{ year }} {{ author }} License : MIT Maintainer : {{ email }} Stability : experimental Portability : POSIX -LONG_DESC +{{{ _haskell_module_longdesc }}} -} diff --git a/embedded/license/mpl2/haskell.mustache b/embedded/license/mpl2/haskell.mustache --- a/embedded/license/mpl2/haskell.mustache +++ b/embedded/license/mpl2/haskell.mustache @@ -1,11 +1,11 @@ {-| -Module : MODULE_NAME -Description : SHORT_DESC +Module : {{{ _haskell_module_name }}} +Description : {{{ _haskell_module_shortdesc }}} Copyright : (c) {{ year }} {{ author }} License : MPL 2.0 Maintainer : {{ email }} Stability : experimental Portability : POSIX -LONG_DESC +{{{ _haskell_module_longdesc }}} -} diff --git a/headroom.cabal b/headroom.cabal --- a/headroom.cabal +++ b/headroom.cabal @@ -1,18 +1,19 @@ -cabal-version: 2.2 -name: headroom -version: 0.2.2.1 -license: BSD-3-Clause -license-file: LICENSE -copyright: Copyright (c) 2019-2020 Vaclav Svejcar -maintainer: vaclav.svejcar@gmail.com -author: Vaclav Svejcar -homepage: https://github.com/vaclavsvejcar/headroom -bug-reports: https://github.com/vaclavsvejcar/headroom/issues -synopsis: License Header Manager +cabal-version: 2.2 +name: headroom +version: 0.3.0.0 +license: BSD-3-Clause +license-file: LICENSE +copyright: Copyright (c) 2019-2020 Vaclav Svejcar +maintainer: vaclav.svejcar@gmail.com +author: Vaclav Svejcar +homepage: https://github.com/vaclavsvejcar/headroom +bug-reports: https://github.com/vaclavsvejcar/headroom/issues +synopsis: License Header Manager description: Would you like to have nice, up-to-date license/copyright headers in your source code files but hate to manage them by hand? Then Headroom is the right tool for you! Now you can define your license header as Mustache template, put all the variables (such as author's name, year, etc.) into the YAML config file and Headroom will take care to add such license headers to all your source code files. -category: Utils -build-type: Simple + +category: Utils +build-type: Simple extra-source-files: CHANGELOG.md LICENSE @@ -87,6 +88,7 @@ test-data/code-samples/css/sample1.css test-data/code-samples/css/sample2.css test-data/code-samples/haskell/full.hs + test-data/code-samples/haskell/header.hs test-data/code-samples/haskell/sample1.hs test-data/code-samples/haskell/sample2.hs test-data/code-samples/html/sample1.html @@ -100,13 +102,14 @@ test-data/code-samples/scala/sample2.scala test-data/code-samples/shell/sample1.sh test-data/configs/full.yaml + test-data/templates/haskell.mustache test-data/test-traverse/a.html test-data/test-traverse/foo/b.html test-data/test-traverse/foo/test.xml test-data/test-traverse/foo/bar/c.html source-repository head - type: git + type: git location: https://github.com/vaclavsvejcar/headroom library @@ -116,100 +119,135 @@ Headroom.Command.Init Headroom.Command.Readers Headroom.Command.Run + Headroom.Command.Types Headroom.Command.Utils Headroom.Configuration + Headroom.Configuration.Types Headroom.Data.EnumExtra Headroom.Data.Has + Headroom.Data.Lens + Headroom.Data.Regex + Headroom.Data.TextExtra Headroom.Embedded + Headroom.Ext + Headroom.Ext.Haskell + Headroom.Ext.Haskell.Haddock Headroom.FileSupport + Headroom.FileSupport.Types Headroom.FileSystem Headroom.FileType + Headroom.FileType.Types + Headroom.HeaderFn + Headroom.HeaderFn.Types + Headroom.HeaderFn.UpdateCopyright Headroom.Meta - Headroom.Regex Headroom.Serialization Headroom.Template Headroom.Template.Mustache Headroom.Types Headroom.UI Headroom.UI.Progress - hs-source-dirs: src - other-modules: - Paths_headroom - autogen-modules: - Paths_headroom + Headroom.Variables + Headroom.Variables.Types + + hs-source-dirs: src + other-modules: Paths_headroom + autogen-modules: Paths_headroom default-language: Haskell2010 - ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat - -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wpartial-fields -Wredundant-constraints - -Werror=incomplete-patterns + ghc-options: + -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities + -Wincomplete-record-updates -Wincomplete-uni-patterns + -Wpartial-fields -Wredundant-constraints + -Werror=incomplete-patterns + build-depends: aeson >=1.4.7.1, base >=4.7 && <5, + data-default-class >=0.1.2.0, either >=5.0.1.1, file-embed >=0.0.11.2, + microlens >=0.4.11.2, + microlens-th >=0.4.3.5, mustache >=2.3.1, optparse-applicative >=0.15.1.0, + pcre-heavy >=1.0.0.2, pcre-light >=0.4.1.0, - rio >=0.1.15.1, + rio >=0.1.17.0, + template-haskell >=2.15.0.0, time >=1.9.3, - yaml >=0.11.3.0 + yaml >=0.11.4.0 executable headroom - main-is: Main.hs - hs-source-dirs: app - other-modules: - Paths_headroom + main-is: Main.hs + hs-source-dirs: app + other-modules: Paths_headroom default-language: Haskell2010 - ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat - -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wpartial-fields -Wredundant-constraints - -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N + ghc-options: + -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities + -Wincomplete-record-updates -Wincomplete-uni-patterns + -Wpartial-fields -Wredundant-constraints + -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N + build-depends: base >=4.7 && <5, headroom -any, optparse-applicative >=0.15.1.0, - rio >=0.1.15.1 + rio >=0.1.17.0 test-suite doctest - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: doctest - other-modules: - Paths_headroom + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: doctest + other-modules: Paths_headroom default-language: Haskell2010 - ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat - -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wpartial-fields -Wredundant-constraints - -Werror=incomplete-patterns + ghc-options: + -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities + -Wincomplete-record-updates -Wincomplete-uni-patterns + -Wpartial-fields -Wredundant-constraints + -Werror=incomplete-patterns + build-depends: base >=4.7 && <5, doctest >=0.16.3, optparse-applicative >=0.15.1.0, - rio >=0.1.15.1 + rio >=0.1.17.0 test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test other-modules: Headroom.Command.InitSpec Headroom.Command.ReadersSpec + Headroom.Command.RunSpec Headroom.ConfigurationSpec Headroom.Data.EnumExtraSpec + Headroom.Data.RegexSpec + Headroom.Data.TextExtraSpec + Headroom.Ext.Haskell.HaddockSpec + Headroom.Ext.HaskellSpec + Headroom.ExtSpec Headroom.FileSupportSpec Headroom.FileSystemSpec Headroom.FileTypeSpec - Headroom.RegexSpec + Headroom.HeaderFn.TypesSpec + Headroom.HeaderFn.UpdateCopyrightSpec + Headroom.HeaderFnSpec Headroom.SerializationSpec Headroom.Template.MustacheSpec + Headroom.TypesSpec Headroom.UI.ProgressSpec + Headroom.VariablesSpec Test.Utils Paths_headroom + default-language: Haskell2010 - ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat - -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns - -Wpartial-fields -Wredundant-constraints - -Werror=incomplete-patterns + ghc-options: + -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities + -Wincomplete-record-updates -Wincomplete-uni-patterns + -Wpartial-fields -Wredundant-constraints + -Werror=incomplete-patterns + build-depends: QuickCheck >=2.13.2, aeson >=1.4.7.1, @@ -218,4 +256,5 @@ hspec >=2.7.1, optparse-applicative >=0.15.1.0, pcre-light >=0.4.1.0, - rio >=0.1.15.1 + rio >=0.1.17.0, + time >=1.9.3 diff --git a/src/Headroom/Command.hs b/src/Headroom/Command.hs --- a/src/Headroom/Command.hs +++ b/src/Headroom/Command.hs @@ -22,15 +22,17 @@ import Headroom.Command.Readers ( licenseReader , licenseTypeReader + , regexReader ) +import Headroom.Command.Types ( Command(..) ) +import Headroom.Configuration.Types ( LicenseType + , RunMode(..) + , TemplateSource(..) + ) import Headroom.Data.EnumExtra ( EnumExtra(..) ) import Headroom.Meta ( productDesc , productInfo ) -import Headroom.Types ( Command(..) - , LicenseType - , RunMode(..) - ) import Options.Applicative import RIO import qualified RIO.Text as T @@ -69,16 +71,28 @@ ) ) <*> many - (strOption + (option + regexReader (long "excluded-path" <> short 'e' <> metavar "REGEX" <> help "path to exclude from source code file paths" ) ) - <*> many - (strOption - (long "template-path" <> short 't' <> metavar "PATH" <> help - "path to header template file/directory" - ) + <*> optional + ( BuiltInTemplates + <$> option + licenseTypeReader + (long "builtin-templates" <> metavar "TYPE" <> help + ("use built-in templates for license type, available options: " + <> T.unpack (T.toLower (allValuesToText @LicenseType)) + ) + ) + <|> TemplateFiles + <$> some + (strOption + (long "template-path" <> short 't' <> metavar "PATH" <> help + "path to license template file/directory" + ) + ) ) <*> many (strOption diff --git a/src/Headroom/Command/Gen.hs b/src/Headroom/Command/Gen.hs --- a/src/Headroom/Command/Gen.hs +++ b/src/Headroom/Command/Gen.hs @@ -1,6 +1,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-| Module : Headroom.Command.Gen @@ -23,46 +25,77 @@ where +import Headroom.Command.Types ( Command(..) + , CommandGenOptions(..) + ) import Headroom.Command.Utils ( bootstrap ) +import Headroom.Configuration.Types ( GenMode(..) ) +import Headroom.Data.Lens ( suffixLensesFor ) import Headroom.Embedded ( configFileStub , licenseTemplate ) -import Headroom.Types ( ApplicationError(..) - , Command(..) - , CommandGenError(..) - , CommandGenOptions(..) - , GenMode(..) +import Headroom.Types ( fromHeadroomError + , toHeadroomError ) import Prelude ( putStrLn ) import RIO +import qualified RIO.Text as T data Env = Env - { envLogFunc :: !LogFunc -- ^ logging function - , envGenOptions :: !CommandGenOptions -- ^ options + { envLogFunc :: !LogFunc + -- ^ logging function + , envGenOptions :: !CommandGenOptions + -- ^ options } +suffixLensesFor ["envLogFunc"] ''Env + instance HasLogFunc Env where - logFuncL = lens envLogFunc (\x y -> x { envLogFunc = y }) + logFuncL = envLogFuncL env' :: CommandGenOptions -> LogFunc -> IO Env env' opts logFunc = pure $ Env { envLogFunc = logFunc, envGenOptions = opts } -- | Parses 'GenMode' from combination of options from given 'Command'. parseGenMode :: MonadThrow m - => Command -- ^ command from which to parse the 'GenMode' - -> m GenMode -- ^ parsed 'GenMode' + => Command + -- ^ command from which to parse the 'GenMode' + -> m GenMode + -- ^ parsed 'GenMode' parseGenMode = \case Gen True Nothing -> pure GenConfigFile Gen False (Just license) -> pure $ GenLicense license - _ -> throwM $ CommandGenError NoGenModeSelected + _ -> throwM NoGenModeSelected -- | Handler for /Generator/ command. -commandGen :: CommandGenOptions -- ^ /Generator/ command options - -> IO () -- ^ execution result +commandGen :: CommandGenOptions + -- ^ /Generator/ command options + -> IO () + -- ^ execution result commandGen opts = bootstrap (env' opts) False $ case cgoGenMode opts of GenConfigFile -> liftIO printConfigFile GenLicense (lType, fType) -> liftIO . putStrLn $ licenseTemplate lType fType printConfigFile :: IO () printConfigFile = putStrLn configFileStub + + +--------------------------------- Error Types -------------------------------- + +-- | Exception specific to the @gen@ command. +data CommandGenError = NoGenModeSelected + -- ^ no mode of /Gen/ command selected + deriving (Eq, Show) + +instance Exception CommandGenError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + +displayException' :: CommandGenError -> String +displayException' = T.unpack . \case + NoGenModeSelected -> mconcat + [ "Please select at least one option what to generate " + , "(see --help for details)" + ] diff --git a/src/Headroom/Command/Init.hs b/src/Headroom/Command/Init.hs --- a/src/Headroom/Command/Init.hs +++ b/src/Headroom/Command/Init.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -30,11 +31,16 @@ ) where +import Headroom.Command.Types ( CommandInitOptions(..) ) import Headroom.Command.Utils ( bootstrap ) import Headroom.Configuration ( makeHeadersConfig , parseConfiguration ) +import Headroom.Configuration.Types ( Configuration(..) + , LicenseType(..) + ) import Headroom.Data.Has ( Has(..) ) +import Headroom.Data.Lens ( suffixLenses ) import Headroom.Embedded ( configFileStub , defaultConfig , licenseTemplate @@ -45,15 +51,12 @@ , findFiles ) import Headroom.FileType ( fileTypeByExt ) +import Headroom.FileType.Types ( FileType(..) ) import Headroom.Meta ( TemplateType ) import Headroom.Serialization ( prettyPrintYAML ) import Headroom.Template ( Template(..) ) -import Headroom.Types ( ApplicationError(..) - , CommandInitError(..) - , CommandInitOptions(..) - , FileType(..) - , LicenseType(..) - , PartialConfiguration(..) +import Headroom.Types ( fromHeadroomError + , toHeadroomError ) import Headroom.UI ( Progress(..) , zipWithProgress @@ -68,7 +71,6 @@ import qualified RIO.Text.Partial as TP - -- | /RIO/ Environment for the @init@ command. data Env = Env { envLogFunc :: !LogFunc @@ -82,14 +84,16 @@ , pTemplatesDir :: !FilePath } +suffixLenses ''Env + instance HasLogFunc Env where - logFuncL = lens envLogFunc (\x y -> x { envLogFunc = y }) + logFuncL = envLogFuncL instance Has CommandInitOptions Env where - hasLens = lens envInitOptions (\x y -> x { envInitOptions = y }) + hasLens = envInitOptionsL instance Has Paths Env where - hasLens = lens envPaths (\x y -> x { envPaths = y }) + hasLens = envPathsL -------------------------------------------------------------------------------- @@ -101,8 +105,10 @@ pure $ Env { envLogFunc = logFunc, envInitOptions = opts, envPaths = paths } -- | Handler for @init@ command. -commandInit :: CommandInitOptions -- ^ @init@ command options - -> IO () -- ^ execution result +commandInit :: CommandInitOptions + -- ^ @init@ command options + -> IO () + -- ^ execution result commandInit opts = bootstrap (env' opts) False $ doesAppConfigExist >>= \case False -> do fileTypes <- findSupportedFileTypes @@ -111,7 +117,7 @@ createConfigFile True -> do paths <- viewL - throwM $ CommandInitError (AppConfigAlreadyExists $ pConfigFile paths) + throwM . AppConfigAlreadyExists $ pConfigFile paths -- | Recursively scans provided source paths for known file types for which -- templates can be generated. @@ -119,16 +125,16 @@ => RIO env [FileType] findSupportedFileTypes = do opts <- viewL - pHeadersConfig <- pcLicenseHeaders <$> parseConfiguration defaultConfig + pHeadersConfig <- cLicenseHeaders <$> parseConfiguration defaultConfig headersConfig <- makeHeadersConfig pHeadersConfig fileTypes <- do allFiles <- mapM (\path -> findFiles path (const True)) (cioSourcePaths opts) let allFileTypes = fmap (fileExtension >=> fileTypeByExt headersConfig) (concat allFiles) - pure $ L.nub . catMaybes $ allFileTypes + pure . L.nub . catMaybes $ allFileTypes case fileTypes of - [] -> throwM $ CommandInitError NoProvidedSourcePaths + [] -> throwM NoProvidedSourcePaths _ -> do logInfo $ "Found supported file types: " <> displayShow fileTypes pure fileTypes @@ -188,3 +194,32 @@ Paths {..} <- viewL logInfo $ "Creating directory for templates in " <> fromString pTemplatesDir createDirectory pTemplatesDir + + +--------------------------------- Error Types -------------------------------- + +-- | Exception specific to the "Headroom.Command.Init" module +data CommandInitError + = AppConfigAlreadyExists !FilePath + -- ^ application configuration file already exists + | NoProvidedSourcePaths + -- ^ no paths to source code files provided + | NoSupportedFileType + -- ^ no supported file types found on source paths + deriving (Eq, Show) + +instance Exception CommandInitError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + +displayException' :: CommandInitError -> String +displayException' = T.unpack . \case + AppConfigAlreadyExists path -> appConfigAlreadyExists path + NoProvidedSourcePaths -> noProvidedSourcePaths + NoSupportedFileType -> noSupportedFileType + where + appConfigAlreadyExists path = + mconcat ["Configuration file '", T.pack path, "' already exists"] + noProvidedSourcePaths = "No source code paths (files or directories) defined" + noSupportedFileType = "No supported file type found in scanned source paths" diff --git a/src/Headroom/Command/Readers.hs b/src/Headroom/Command/Readers.hs --- a/src/Headroom/Command/Readers.hs +++ b/src/Headroom/Command/Readers.hs @@ -18,22 +18,24 @@ module Headroom.Command.Readers ( licenseReader , licenseTypeReader + , regexReader , parseLicenseAndFileType ) where import Data.Either.Combinators ( maybeToRight ) +import Headroom.Configuration.Types ( LicenseType ) import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.Types ( FileType - , LicenseType +import Headroom.Data.Regex ( Regex(..) + , compile ) +import Headroom.FileType.Types ( FileType(..) ) import Options.Applicative import RIO import qualified RIO.Text as T import qualified RIO.Text.Partial as TP - -- | Reader for tuple of 'LicenseType' and 'FileType'. licenseReader :: ReadM (LicenseType, FileType) licenseReader = eitherReader parseLicense @@ -58,6 +60,12 @@ [ "invalid license type, available options: " , T.toLower (allValuesToText @LicenseType) ] + + +-- | Reader for 'Regex'. +regexReader :: ReadM Regex +regexReader = eitherReader parse + where parse input = mapLeft displayException (compile . T.pack $ input) -- | Parses 'LicenseType' and 'FileType' from the input string, diff --git a/src/Headroom/Command/Run.hs b/src/Headroom/Command/Run.hs --- a/src/Headroom/Command/Run.hs +++ b/src/Headroom/Command/Run.hs @@ -1,8 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -21,24 +23,53 @@ module Headroom.Command.Run ( commandRun + , loadBuiltInTemplates + , loadTemplateFiles + , typeOfTemplate + -- * License Header Post-processing + , postProcessHeader' + , sanitizeHeader ) where +import Data.Time.Calendar ( toGregorian ) +import Data.Time.Clock ( getCurrentTime ) import Data.Time.Clock.POSIX ( getPOSIXTime ) +import Data.Time.LocalTime ( getCurrentTimeZone + , localDay + , utcToLocalTime + ) +import Headroom.Command.Types ( CommandRunOptions(..) ) import Headroom.Command.Utils ( bootstrap ) import Headroom.Configuration ( loadConfiguration , makeConfiguration , parseConfiguration - , parseVariables ) +import Headroom.Configuration.Types ( Configuration(..) + , CtConfiguration + , CtHeaderFnConfigs + , HeaderConfig(..) + , HeaderSyntax(..) + , LicenseType(..) + , PtConfiguration + , RunMode(..) + , TemplateSource(..) + , cHeaderFnConfigsL + ) import Headroom.Data.EnumExtra ( EnumExtra(..) ) import Headroom.Data.Has ( Has(..) ) -import Headroom.Embedded ( defaultConfig ) +import Headroom.Data.Lens ( suffixLenses ) +import Headroom.Data.TextExtra ( mapLines ) +import Headroom.Embedded ( defaultConfig + , licenseTemplate + ) +import Headroom.Ext ( extractTemplateMeta ) import Headroom.FileSupport ( addHeader , dropHeader , extractFileInfo , replaceHeader ) +import Headroom.FileSupport.Types ( FileInfo(..) ) import Headroom.FileSystem ( excludePaths , fileExtension , findFilesByExts @@ -48,21 +79,25 @@ import Headroom.FileType ( configByFileType , fileTypeByExt ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.HeaderFn ( mkConfiguredEnv + , postProcessHeader + ) import Headroom.Meta ( TemplateType , productInfo ) import Headroom.Template ( Template(..) ) -import Headroom.Types ( CommandRunOptions(..) - , Configuration(..) - , FileInfo(..) - , FileType(..) - , PartialConfiguration(..) - , RunAction(..) - , RunMode(..) +import Headroom.Types ( CurrentYear(..) + , TemplateMeta(..) ) import Headroom.UI ( Progress(..) , zipWithProgress ) +import Headroom.Variables ( compileVariables + , dynamicVariables + , parseVariables + ) +import Headroom.Variables.Types ( Variables(..) ) import RIO import RIO.FilePath ( takeBaseName ) import qualified RIO.List as L @@ -70,59 +105,91 @@ import qualified RIO.Text as T +type TemplatesMap = Map FileType (Maybe TemplateMeta, TemplateType) +-- | Action to be performed based on the selected 'RunMode'. +data RunAction = RunAction + { raProcessed :: !Bool + -- ^ whether the given file was processed + , raFunc :: !(Text -> Text) + -- ^ function to process the file + , raProcessedMsg :: !Text + -- ^ message to show when file was processed + , raSkippedMsg :: !Text + -- ^ message to show when file was skipped + } + + -- | Initial /RIO/ startup environment for the /Run/ command. data StartupEnv = StartupEnv - { envLogFunc :: !LogFunc -- ^ logging function - , envRunOptions :: !CommandRunOptions -- ^ options + { envLogFunc :: !LogFunc + -- ^ logging function + , envRunOptions :: !CommandRunOptions + -- ^ options } +suffixLenses ''StartupEnv + -- | Full /RIO/ environment for the /Run/ command. data Env = Env - { envEnv :: !StartupEnv -- ^ startup /RIO/ environment - , envConfiguration :: !Configuration -- ^ application configuration + { envEnv :: !StartupEnv + -- ^ startup /RIO/ environment + , envConfiguration :: !CtConfiguration + -- ^ application configuration + , envCurrentYear :: !CurrentYear + -- ^ current year } -instance Has Configuration Env where - hasLens = lens envConfiguration (\x y -> x { envConfiguration = y }) +suffixLenses ''Env +instance Has CtConfiguration Env where + hasLens = envConfigurationL + +instance Has CtHeaderFnConfigs Env where + hasLens = envConfigurationL . cHeaderFnConfigsL + instance Has StartupEnv StartupEnv where hasLens = id instance Has StartupEnv Env where - hasLens = lens envEnv (\x y -> x { envEnv = y }) + hasLens = envEnvL instance HasLogFunc StartupEnv where - logFuncL = lens envLogFunc (\x y -> x { envLogFunc = y }) + logFuncL = envLogFuncL instance HasLogFunc Env where logFuncL = hasLens @StartupEnv . logFuncL instance Has CommandRunOptions StartupEnv where - hasLens = lens envRunOptions (\x y -> x { envRunOptions = y }) + hasLens = envRunOptionsL instance Has CommandRunOptions Env where hasLens = hasLens @StartupEnv . hasLens +instance Has CurrentYear Env where + hasLens = envCurrentYearL + env' :: CommandRunOptions -> LogFunc -> IO Env env' opts logFunc = do - let startupEnv = StartupEnv { envLogFunc = logFunc, envRunOptions = opts } - merged <- runRIO startupEnv finalConfiguration - pure $ Env { envEnv = startupEnv, envConfiguration = merged } + let envEnv = StartupEnv { envLogFunc = logFunc, envRunOptions = opts } + envConfiguration <- runRIO envEnv finalConfiguration + envCurrentYear <- currentYear + pure Env { .. } -- | Handler for /Run/ command. -commandRun :: CommandRunOptions -- ^ /Run/ command options - -> IO () -- ^ execution result +commandRun :: CommandRunOptions + -- ^ /Run/ command options + -> IO () + -- ^ execution result commandRun opts = bootstrap (env' opts) (croDebug opts) $ do CommandRunOptions {..} <- viewL - Configuration {..} <- viewL - logInfo $ display productInfo + Configuration {..} <- viewL @CtConfiguration let isCheck = cRunMode == Check warnOnDryRun startTS <- liftIO getPOSIXTime - templates <- loadTemplates + templates <- withTemplateMeta <$> loadTemplates sourceFiles <- findSourceFiles (M.keys templates) (total, processed) <- processSourceFiles templates sourceFiles endTS <- liftIO getPOSIXTime @@ -147,7 +214,7 @@ when croDryRun $ logWarn "[!] Running with '--dry-run', no files are changed!" -findSourceFiles :: (Has Configuration env, HasLogFunc env) +findSourceFiles :: (Has CtConfiguration env, HasLogFunc env) => [FileType] -> RIO env [FilePath] findSourceFiles fileTypes = do @@ -166,45 +233,59 @@ where findFiles' licenseHeaders = findFilesByTypes licenseHeaders fileTypes -processSourceFiles :: ( Has Configuration env - , HasLogFunc env +processSourceFiles :: ( Has CtConfiguration env + , Has CtHeaderFnConfigs env , Has CommandRunOptions env + , Has CurrentYear env + , HasLogFunc env ) - => Map FileType TemplateType + => TemplatesMap -> [FilePath] -> RIO env (Int, Int) processSourceFiles templates paths = do Configuration {..} <- viewL - let withFileType = mapMaybe (findFileType cLicenseHeaders) paths + year <- viewL + let dVars = dynamicVariables year + withFileType = mapMaybe (findFileType cLicenseHeaders) paths withTemplate = mapMaybe (uncurry findTemplate) withFileType - processed <- mapM process (zipWithProgress withTemplate) - logDebug "foo" + cVars <- compileVariables (dVars <> cVariables) + processed <- mapM (process cVars dVars) (zipWithProgress withTemplate) pure (L.length withTemplate, L.length . filter (== True) $ processed) where findFileType conf path = fmap (, path) (fileExtension path >>= fileTypeByExt conf) findTemplate ft p = (, ft, p) <$> M.lookup ft templates - process (pr, (tt, ft, p)) = processSourceFile pr tt ft p + process cVars dVars (pr, ((tm, tt), ft, p)) = + processSourceFile cVars dVars pr tm tt ft p -processSourceFile :: ( Has Configuration env +processSourceFile :: ( Has CommandRunOptions env + , Has CtConfiguration env + , Has CtHeaderFnConfigs env + , Has CurrentYear env , HasLogFunc env - , Has CommandRunOptions env ) - => Progress + => Variables + -> Variables + -> Progress + -> Maybe TemplateMeta -> TemplateType -> FileType -> FilePath -> RIO env Bool -processSourceFile progress template fileType path = do - Configuration {..} <- viewL +processSourceFile cVars dVars progress meta template fileType path = do + Configuration {..} <- viewL @CtConfiguration CommandRunOptions {..} <- viewL fileContent <- readFileUtf8 path - let fileInfo = extractFileInfo fileType - (configByFileType cLicenseHeaders fileType) - fileContent - variables = cVariables <> fiVariables fileInfo - header <- renderTemplate variables template + let fileInfo@FileInfo {..} = extractFileInfo + fileType + (configByFileType cLicenseHeaders fileType) + meta + fileContent + variables = dVars <> cVars <> fiVariables + syntax = hcHeaderSyntax fiHeaderConfig + header' <- renderTemplate variables template + header <- postProcessHeader' syntax variables header' RunAction {..} <- chooseAction fileInfo header let result = raFunc fileContent changed = raProcessed && (fileContent /= result) @@ -216,9 +297,12 @@ pure changed -chooseAction :: (Has Configuration env) => FileInfo -> Text -> RIO env RunAction +chooseAction :: (Has CtConfiguration env) + => FileInfo + -> Text + -> RIO env RunAction chooseAction info header = do - Configuration {..} <- viewL + Configuration {..} <- viewL @CtConfiguration let hasHeader = isJust $ fiHeaderPos info pure $ go cRunMode hasHeader where @@ -247,11 +331,14 @@ justify = T.justifyLeft 30 ' ' -loadTemplates :: (Has Configuration env, HasLogFunc env) - => RIO env (Map FileType TemplateType) -loadTemplates = do - Configuration {..} <- viewL - paths <- mconcat <$> mapM (`findFilesByExts` extensions) cTemplatePaths +-- | Loads templates from the given paths. +loadTemplateFiles :: (HasLogFunc env) + => [FilePath] + -- ^ paths to template files + -> RIO env (Map FileType TemplateType) + -- ^ map of file types and templates +loadTemplateFiles paths' = do + paths <- mconcat <$> mapM (`findFilesByExts` extensions) paths' logDebug $ "Using template paths: " <> displayShow paths withTypes <- catMaybes <$> mapM (\p -> fmap (, p) <$> typeOfTemplate p) paths parsed <- mapM (\(t, p) -> (t, ) <$> load p) withTypes @@ -264,7 +351,42 @@ liftIO $ (T.strip <$> loadFile path) >>= parseTemplate (Just $ T.pack path) -typeOfTemplate :: HasLogFunc env => FilePath -> RIO env (Maybe FileType) +-- | Loads built-in templates, stored in "Headroom.Embedded", for the given +-- 'LicenseType'. +loadBuiltInTemplates :: (HasLogFunc env) + => LicenseType + -- ^ license type for which to selected templates + -> RIO env (Map FileType TemplateType) + -- ^ map of file types and templates +loadBuiltInTemplates licenseType = do + logInfo $ "Using built-in templates for license: " <> displayShow licenseType + parsed <- mapM (\(t, r) -> (t, ) <$> parseTemplate Nothing r) rawTemplates + pure $ M.fromList parsed + where + rawTemplates = fmap (\ft -> (ft, template ft)) (allValues @FileType) + template = licenseTemplate licenseType + + +loadTemplates :: (Has CtConfiguration env, HasLogFunc env) + => RIO env (Map FileType TemplateType) +loadTemplates = do + Configuration {..} <- viewL @CtConfiguration + case cTemplateSource of + TemplateFiles paths -> loadTemplateFiles paths + BuiltInTemplates licenseType -> loadBuiltInTemplates licenseType + + +withTemplateMeta :: Map FileType TemplateType -> TemplatesMap +withTemplateMeta = M.fromList . go . M.toList + where go = fmap (\(k, v) -> (k, (extractTemplateMeta k v, v))) + + +-- | Takes path to the template file and returns detected type of the template. +typeOfTemplate :: HasLogFunc env + => FilePath + -- ^ path to the template file + -> RIO env (Maybe FileType) + -- ^ detected template type typeOfTemplate path = do let fileType = textToEnum . T.pack . takeBaseName $ path when (isNothing fileType) @@ -272,13 +394,33 @@ pure fileType +loadConfigurationSafe :: (HasLogFunc env) + => FilePath + -> RIO env (Maybe PtConfiguration) +loadConfigurationSafe path = catch (Just <$> loadConfiguration path) onError + where + onError err = do + logDebug $ displayShow (err :: IOException) + logInfo $ mconcat + [ "Configuration file '" + , fromString path + , "' not found. You can either specify all required parameter by " + , "command line arguments, or generate one using " + , "'headroom gen -c >.headroom.yaml'. See official documentation " + , "for more details." + ] + pure Nothing + + finalConfiguration :: (HasLogFunc env, Has CommandRunOptions env) - => RIO env Configuration + => RIO env CtConfiguration finalConfiguration = do - defaultConfig' <- parseConfiguration defaultConfig - cmdLineConfig <- optionsToConfiguration - yamlConfig <- loadConfiguration ".headroom.yaml" - let mergedConfig = defaultConfig' <> yamlConfig <> cmdLineConfig + logInfo $ display productInfo + defaultConfig' <- Just <$> parseConfiguration defaultConfig + cmdLineConfig <- Just <$> optionsToConfiguration + yamlConfig <- loadConfigurationSafe ".headroom.yaml" + let mergedConfig = + mconcat . catMaybes $ [defaultConfig', yamlConfig, cmdLineConfig] config <- makeConfiguration mergedConfig logDebug $ "Default config: " <> displayShow defaultConfig' logDebug $ "YAML config: " <> displayShow yamlConfig @@ -288,17 +430,65 @@ pure config -optionsToConfiguration :: (Has CommandRunOptions env) - => RIO env PartialConfiguration +optionsToConfiguration :: (Has CommandRunOptions env) => RIO env PtConfiguration optionsToConfiguration = do - runOptions <- viewL - variables <- parseVariables $ croVariables runOptions - pure PartialConfiguration - { pcRunMode = maybe mempty pure (croRunMode runOptions) - , pcSourcePaths = ifNot null (croSourcePaths runOptions) - , pcExcludedPaths = ifNot null (croExcludedPaths runOptions) - , pcTemplatePaths = ifNot null (croTemplatePaths runOptions) - , pcVariables = ifNot null variables - , pcLicenseHeaders = mempty - } + CommandRunOptions {..} <- viewL + variables <- parseVariables croVariables + pure Configuration { cRunMode = maybe mempty pure croRunMode + , cSourcePaths = ifNot null croSourcePaths + , cExcludedPaths = ifNot null croExcludedPaths + , cTemplateSource = maybe mempty pure croTemplateSource + , cVariables = variables + , cLicenseHeaders = mempty + , cHeaderFnConfigs = mempty + } where ifNot cond value = if cond value then mempty else pure value + + +currentYear :: (MonadIO m) => m CurrentYear +currentYear = do + now <- liftIO getCurrentTime + timezone <- liftIO getCurrentTimeZone + let zoneNow = utcToLocalTime timezone now + (year, _, _) = toGregorian $ localDay zoneNow + pure $ CurrentYear year + + +-- | Performs post-processing on rendered /license header/, based on given +-- configuration. Currently the main points are to: +-- +-- 1. sanitize possibly corrupted comment syntax ('sanitizeHeader') +-- 2. apply /license header functions/ ('postProcessHeader') +postProcessHeader' :: (Has CtHeaderFnConfigs env, Has CurrentYear env) + => HeaderSyntax + -- ^ syntax of the license header comments + -> Variables + -- ^ template variables + -> Text + -- ^ rendered /license header/ to post-process + -> RIO env Text + -- ^ post-processed /license header/ +postProcessHeader' syntax vars rawHeader = do + configs <- viewL @CtHeaderFnConfigs + year <- viewL + cEnv <- mkConfiguredEnv year vars configs + let processed = sanitizeHeader syntax . postProcessHeader cEnv $ rawHeader + pure processed + + +-- | Ensures that all lines in license header starts with /line-comment/ syntax +-- if such syntax is used for license header. +-- +-- >>> sanitizeHeader (LineComment "--") "-- foo\nbar\n-- baz" +-- "-- foo\n-- bar\n-- baz" +sanitizeHeader :: HeaderSyntax + -- ^ syntax of the license header comments + -> Text + -- ^ input text to sanitize + -> Text + -- ^ sanitized text +sanitizeHeader (BlockComment _ _ ) text = text +sanitizeHeader (LineComment prefixedBy) text = mapLines process text + where + process line | T.isPrefixOf prefixedBy line = line + | otherwise = prefixedBy <> " " <> line diff --git a/src/Headroom/Command/Types.hs b/src/Headroom/Command/Types.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Command/Types.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Headroom.Command.Types +Description : Data types for "Headroom.Command" +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types for "Headroom.Command" module. +-} + +module Headroom.Command.Types + ( Command(..) + , CommandGenOptions(..) + , CommandInitOptions(..) + , CommandRunOptions(..) + ) +where + +import Headroom.Configuration.Types ( GenMode + , LicenseType + , RunMode + , TemplateSource + ) +import Headroom.Data.Regex ( Regex ) +import Headroom.FileType.Types ( FileType ) +import RIO + + +-- | Application command. +data Command + = Run [FilePath] [Regex] (Maybe TemplateSource) [Text] (Maybe RunMode) Bool Bool + -- ^ @run@ command + | Gen Bool (Maybe (LicenseType, FileType)) + -- ^ @gen@ command + | Init LicenseType [FilePath] + -- ^ @init@ command + deriving (Show) + + +-- | Options for the @gen@ command. +newtype CommandGenOptions = CommandGenOptions + { cgoGenMode :: GenMode + -- ^ selected mode + } + deriving (Show) + +-- | Options for the @init@ command. +data CommandInitOptions = CommandInitOptions + { cioSourcePaths :: ![FilePath] + -- ^ paths to source code files + , cioLicenseType :: !LicenseType + -- ^ license type + } + deriving Show + +-- | Options for the @run@ command. +data CommandRunOptions = CommandRunOptions + { croRunMode :: !(Maybe RunMode) + -- ^ used /Run/ command mode + , croSourcePaths :: ![FilePath] + -- ^ source code file paths + , croExcludedPaths :: ![Regex] + -- ^ source paths to exclude + , croTemplateSource :: !(Maybe TemplateSource) + -- ^ source of license templates + , croVariables :: ![Text] + -- ^ raw variables + , croDebug :: !Bool + -- ^ whether to run in debug mode + , croDryRun :: !Bool + -- ^ whether to perform dry run + } + deriving (Eq, Show) diff --git a/src/Headroom/Command/Utils.hs b/src/Headroom/Command/Utils.hs --- a/src/Headroom/Command/Utils.hs +++ b/src/Headroom/Command/Utils.hs @@ -21,10 +21,14 @@ -- | Bootstraps /RIO/ application using provided environment data and flag -- whether to run in debug mode. -bootstrap :: (LogFunc -> IO env) -- ^ function returning environment data - -> Bool -- ^ whether to run in debug mode - -> RIO env a -- ^ /RIO/ application to execute - -> IO a -- ^ execution result +bootstrap :: (LogFunc -> IO env) + -- ^ function returning environment data + -> Bool + -- ^ whether to run in debug mode + -> RIO env a + -- ^ /RIO/ application to execute + -> IO a + -- ^ execution result bootstrap getEnv isDebug logic = do logOptions <- logOptionsHandle stderr isDebug let logOptions' = setLogUseLoc False logOptions diff --git a/src/Headroom/Configuration.hs b/src/Headroom/Configuration.hs --- a/src/Headroom/Configuration.hs +++ b/src/Headroom/Configuration.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -14,15 +15,13 @@ This module provides logic for working with the cofiguration data types. Headroom uses the -pattern for the configuration, where the 'Configuration' is the data type for -total configuration and 'PartialConfiguration' for the partial one. +pattern for the configuration. -} module Headroom.Configuration ( -- * Loading & Parsing Configuration loadConfiguration , parseConfiguration - , parseVariables -- * Processing Partial Configuration , makeConfiguration , makeHeadersConfig @@ -32,97 +31,143 @@ import Data.Monoid ( Last(..) ) import qualified Data.Yaml as Y -import Headroom.Types ( ApplicationError(..) - , Configuration(..) +import Headroom.Configuration.Types ( Configuration(..) , ConfigurationError(..) - , FileType(..) + , ConfigurationKey(..) + , CtConfiguration + , CtHeaderConfig + , CtHeaderFnConfig + , CtHeaderFnConfigs + , CtHeadersConfig + , CtUpdateCopyrightConfig , HeaderConfig(..) + , HeaderFnConfig(..) + , HeaderFnConfigs(..) , HeadersConfig(..) - , PartialConfiguration(..) - , PartialHeaderConfig(..) - , PartialHeadersConfig(..) + , Phase(..) + , PtConfiguration + , PtHeaderConfig + , PtHeaderFnConfig + , PtHeaderFnConfigs + , PtHeadersConfig + , PtUpdateCopyrightConfig + , UpdateCopyrightConfig(..) + , hfcConfigL + , hfcEnabledL + , hfcsUpdateCopyrightL + , hfcsUpdateCopyrightL + , uccSelectedAuthorsL ) +import Headroom.FileType.Types ( FileType(..) ) import RIO import qualified RIO.ByteString as B -import qualified RIO.HashMap as HM -import qualified RIO.Text as T - -- | Loads and parses application configuration from given /YAML/ file. loadConfiguration :: MonadIO m - => FilePath -- ^ path to /YAML/ configuration file - -> m PartialConfiguration -- ^ parsed configuration + => FilePath + -- ^ path to /YAML/ configuration file + -> m PtConfiguration + -- ^ parsed configuration loadConfiguration path = liftIO $ B.readFile path >>= parseConfiguration -- | Parses application configuration from given raw input in /YAML/ format. parseConfiguration :: MonadThrow m - => B.ByteString -- ^ raw input to parse - -> m PartialConfiguration -- ^ parsed application configuration + => B.ByteString + -- ^ raw input to parse + -> m PtConfiguration + -- ^ parsed application configuration parseConfiguration = Y.decodeThrow --- | Parses variables from raw input in @key=value@ format. --- --- >>> parseVariables ["key1=value1"] --- fromList [("key1","value1")] -parseVariables :: MonadThrow m - => [Text] -- ^ list of raw variables - -> m (HashMap Text Text) -- ^ parsed variables -parseVariables variables = fmap HM.fromList (mapM parse variables) - where - parse input = case T.split (== '=') input of - [key, value] -> pure (key, value) - _ -> throwM $ ConfigurationError (InvalidVariable input) - - --- | Makes full 'Configuration' from provided 'PartialConfiguration' (if valid). +-- | Makes full 'CtConfiguration' from provided 'PtConfiguration' (if valid). makeConfiguration :: MonadThrow m - => PartialConfiguration -- ^ source 'PartialConfiguration' - -> m Configuration -- ^ full 'Configuration' -makeConfiguration PartialConfiguration {..} = do - cRunMode <- lastOrError NoRunMode pcRunMode - cSourcePaths <- lastOrError NoSourcePaths pcSourcePaths - cExcludedPaths <- lastOrError NoExcludedPaths pcExcludedPaths - cTemplatePaths <- lastOrError NoTemplatePaths pcTemplatePaths - cVariables <- lastOrError NoVariables pcVariables - cLicenseHeaders <- makeHeadersConfig pcLicenseHeaders + => PtConfiguration + -- ^ source 'PtConfiguration' + -> m CtConfiguration + -- ^ full 'CtConfiguration' +makeConfiguration pt = do + cRunMode <- lastOrError CkRunMode (cRunMode pt) + cSourcePaths <- lastOrError CkSourcePaths (cSourcePaths pt) + cExcludedPaths <- lastOrError CkExcludedPaths (cExcludedPaths pt) + cTemplateSource <- lastOrError CkTemplateSource (cTemplateSource pt) + cLicenseHeaders <- makeHeadersConfig (cLicenseHeaders pt) + cHeaderFnConfigs <- makeHeaderFnConfigs (cHeaderFnConfigs pt) + cVariables <- pure $ cVariables pt pure Configuration { .. } --- | Makes full 'HeadersConfig' from provided 'PartialHeadersConfig' (if valid). +-- | Makes full 'CtHeadersConfig' from provided 'PtHeadersConfig' (if valid). makeHeadersConfig :: MonadThrow m - => PartialHeadersConfig -- ^ source 'PartialHeadersConfig' - -> m HeadersConfig -- ^ full 'HeadersConfig' -makeHeadersConfig PartialHeadersConfig {..} = do - hscC <- makeHeaderConfig C phscC - hscCpp <- makeHeaderConfig CPP phscCpp - hscCss <- makeHeaderConfig CSS phscCss - hscHaskell <- makeHeaderConfig Haskell phscHaskell - hscHtml <- makeHeaderConfig HTML phscHtml - hscJava <- makeHeaderConfig Java phscJava - hscJs <- makeHeaderConfig JS phscJs - hscRust <- makeHeaderConfig Rust phscRust - hscScala <- makeHeaderConfig Scala phscScala - hscShell <- makeHeaderConfig Shell phscShell + => PtHeadersConfig + -- ^ source 'PtHeadersConfig' + -> m CtHeadersConfig + -- ^ full 'CtHeadersConfig' +makeHeadersConfig pt = do + hscC <- makeHeaderConfig C (hscC pt) + hscCpp <- makeHeaderConfig CPP (hscCpp pt) + hscCss <- makeHeaderConfig CSS (hscCss pt) + hscHaskell <- makeHeaderConfig Haskell (hscHaskell pt) + hscHtml <- makeHeaderConfig HTML (hscHtml pt) + hscJava <- makeHeaderConfig Java (hscJava pt) + hscJs <- makeHeaderConfig JS (hscJs pt) + hscRust <- makeHeaderConfig Rust (hscRust pt) + hscScala <- makeHeaderConfig Scala (hscScala pt) + hscShell <- makeHeaderConfig Shell (hscShell pt) pure HeadersConfig { .. } --- | Makes full 'HeaderConfig' from provided 'PartialHeaderConfig' (if valid). +-- | Makes full 'CtHeaderConfig' from provided 'PtHeaderConfig' (if valid). makeHeaderConfig :: MonadThrow m - => FileType -- ^ determines for which file type this configuration is - -> PartialHeaderConfig -- ^ source 'PartialHeaderConfig' - -> m HeaderConfig -- ^ full 'HeaderConfig' -makeHeaderConfig fileType PartialHeaderConfig {..} = do - hcFileExtensions <- lastOrError (NoFileExtensions fileType) phcFileExtensions - hcMarginAfter <- lastOrError (NoMarginAfter fileType) phcMarginAfter - hcMarginBefore <- lastOrError (NoMarginBefore fileType) phcMarginBefore - hcPutAfter <- lastOrError (NoPutAfter fileType) phcPutAfter - hcPutBefore <- lastOrError (NoPutBefore fileType) phcPutBefore - hcHeaderSyntax <- lastOrError (NoHeaderSyntax fileType) phcHeaderSyntax + => FileType + -- ^ determines for which file type this configuration is + -> PtHeaderConfig + -- ^ source 'PtHeaderConfig' + -> m CtHeaderConfig + -- ^ full 'CtHeaderConfig' +makeHeaderConfig fileType pt = do + hcFileExtensions <- lastOrError (CkFileExtensions fileType) + (hcFileExtensions pt) + hcMarginAfter <- lastOrError (CkMarginAfter fileType) (hcMarginAfter pt) + hcMarginBefore <- lastOrError (CkMarginBefore fileType) (hcMarginBefore pt) + hcPutAfter <- lastOrError (CkPutAfter fileType) (hcPutAfter pt) + hcPutBefore <- lastOrError (CkPutBefore fileType) (hcPutBefore pt) + hcHeaderSyntax <- lastOrError (CkHeaderSyntax fileType) (hcHeaderSyntax pt) pure HeaderConfig { .. } -lastOrError :: MonadThrow m => ConfigurationError -> Last a -> m a -lastOrError err (Last x) = maybe (throwM $ ConfigurationError err) pure x +makeHeaderFnConfigs :: MonadThrow m => PtHeaderFnConfigs -> m CtHeaderFnConfigs +makeHeaderFnConfigs pt = do + hfcsUpdateCopyright <- makeHeaderFnConfig (pt ^. hfcsUpdateCopyrightL) + makeUpdateCopyrightConfig + pure HeaderFnConfigs { .. } + + +makeHeaderFnConfig :: MonadThrow m + => PtHeaderFnConfig c + -> (c 'Partial -> m (c 'Complete)) + -> m (CtHeaderFnConfig c) +makeHeaderFnConfig pt fn = do + hfcEnabled <- lastOrError CkEnabled (pt ^. hfcEnabledL) + hfcConfig <- fn $ pt ^. hfcConfigL + pure HeaderFnConfig { .. } + + +makeUpdateCopyrightConfig :: MonadThrow m + => PtUpdateCopyrightConfig + -> m CtUpdateCopyrightConfig +makeUpdateCopyrightConfig pt = do + let uccSelectedAuthors = lastOrNothing $ pt ^. uccSelectedAuthorsL + pure UpdateCopyrightConfig { .. } + + +------------------------------ Private Functions ----------------------------- + + +lastOrError :: MonadThrow m => ConfigurationKey -> Last a -> m a +lastOrError key (Last a) = maybe (throwM $ MissingConfiguration key) pure a + + +lastOrNothing :: Last (Maybe a) -> Maybe a +lastOrNothing (Last a) = fromMaybe Nothing a diff --git a/src/Headroom/Configuration/Types.hs b/src/Headroom/Configuration/Types.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Configuration/Types.hs @@ -0,0 +1,641 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module : Headroom.Configuration.Types +Description : Data types for /Headroom/ configuration +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types representing /Headroom/ configuration options. +Related logic is available in "Headroom.Configuration" module. + +Data types related to /Headroom/ configuration uses the + +pattern, but instead of defining separate data type for each /phase/ +(/partial/ or /complete/ configuration), the /phase/ is expressed by the 'Phase' +data type and related /closed type family/. +-} + +module Headroom.Configuration.Types + ( -- * Error Types + ConfigurationError(..) + , ConfigurationKey(..) + -- * Type Families + , Phase(..) + , (:::) + -- * Data Types + -- ** Top Level Configuration + , Configuration(..) + , CtConfiguration + , PtConfiguration + , HeadersConfig(..) + , CtHeadersConfig + , PtHeadersConfig + , HeaderConfig(..) + , CtHeaderConfig + , PtHeaderConfig + -- ** Header Functions + , CtUpdateCopyrightConfig + , PtUpdateCopyrightConfig + , UpdateCopyrightConfig(..) + , CtHeaderFnConfig + , PtHeaderFnConfig + , HeaderFnConfig(..) + , CtHeaderFnConfigs + , PtHeaderFnConfigs + , HeaderFnConfigs(..) + -- ** Additional Data Types + , HeaderSyntax(..) + , GenMode(..) + , LicenseType(..) + , RunMode(..) + , TemplateSource(..) + -- * Lenses + , cRunModeL + , cSourcePathsL + , cExcludedPathsL + , cTemplateSourceL + , cVariablesL + , cLicenseHeadersL + , cHeaderFnConfigsL + , uccSelectedAuthorsL + , hfcEnabledL + , hfcConfigL + , hfcsUpdateCopyrightL + ) +where + +import Control.Exception ( throw ) +import Data.Aeson ( FromJSON(..) + , Value(String) + , genericParseJSON + , withObject + , (.!=) + , (.:?) + ) +import Data.Monoid ( Last(..) ) +import Headroom.Data.EnumExtra ( EnumExtra(..) ) +import Headroom.Data.Lens ( suffixLenses ) +import Headroom.Data.Regex ( Regex(..) ) +import Headroom.FileType.Types ( FileType ) +import Headroom.Serialization ( aesonOptions ) +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +import Headroom.Variables.Types ( Variables(..) ) +import RIO +import qualified RIO.Text as T + + +------------------------------------ Phase ----------------------------------- + +-- | Data type representing state of given configuration data type. +data Phase + = Partial + -- ^ partial configuration, could be combined with another or validated to + -- produce the complete configuration + | Complete + -- ^ complete configuration, result of combining and validation of partial + -- configuration + + +-- | /Closed type family/ used to express the phase of given data type. +type family (p :: Phase) ::: a where + 'Partial ::: a = Last a + 'Complete ::: a = a + + +-------------------------------- HeaderSyntax -------------------------------- + +-- | Syntax of the license header comment. +data HeaderSyntax + = BlockComment !Text !Text + -- ^ block (multi-line) comment syntax (e.g. @/* */@) + | LineComment !Text + -- ^ single line comment syntax (e.g. @//@) + deriving (Eq, Show) + +-- | Internal representation of the block style of 'HeaderSyntax'. +data BlockComment' = BlockComment' + { bcStartsWith :: !Text + -- ^ starting pattern (e.g. @/*@) + , bcEndsWith :: !Text + -- ^ ending pattern (e.g. @*/@) + } + deriving (Eq, Generic, Show) + +instance FromJSON BlockComment' where + parseJSON = genericParseJSON aesonOptions + +-- | Internal representation of the line style of 'HeaderSyntax'. +newtype LineComment' = LineComment' + { lcPrefixedBy :: Text + -- ^ prefix of the comment line (e.g. @//@) + } + deriving (Eq, Generic, Show) + +instance FromJSON LineComment' where + parseJSON = genericParseJSON aesonOptions + + +--------------------------------- LicenseType -------------------------------- + +-- | Supported type of open source license. +data LicenseType + = Apache2 + -- ^ support for /Apache-2.0/ license + | BSD3 + -- ^ support for /BSD-3-Clause/ license + | GPL2 + -- ^ support for /GNU GPL2/ license + | GPL3 + -- ^ support for /GNU GPL3/ license + | MIT + -- ^ support for /MIT/ license + | MPL2 + -- ^ support for /MPL2/ license + deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) + +----------------------------------- RunMode ---------------------------------- + +-- | Represents what action should the @run@ command perform. +data RunMode + = Add + -- ^ /add mode/ for @run@ command + | Check + -- ^ /check mode/ for @run@ command + | Drop + -- ^ /drop mode/ for @run@ command + | Replace + -- ^ /replace mode/ for @run@ command + deriving (Eq, Show) + +instance FromJSON RunMode where + parseJSON = \case + String s -> case T.toLower s of + "add" -> pure Add + "check" -> pure Check + "drop" -> pure Drop + "replace" -> pure Replace + _ -> error $ "Unknown run mode: " <> T.unpack s + other -> error $ "Invalid value for run mode: " <> show other + + +----------------------------------- GenMode ---------------------------------- + +-- | Represents what action should the @gen@ command perform. +data GenMode + = GenConfigFile + -- ^ generate /YAML/ config file stub + | GenLicense !(LicenseType, FileType) + -- ^ generate license header template + deriving (Eq, Show) + + +------------------------------- TemplateSource ------------------------------- + +-- | Source of license templates +data TemplateSource + = TemplateFiles [FilePath] + -- ^ templates are stored as local files + | BuiltInTemplates LicenseType + -- ^ use built-in templates for selected license + deriving (Eq, Show) + + +---------------------------- UpdateCopyrightConfig --------------------------- + +-- | Main configuration for the "Headroom.HeaderFn.UpdateCopyright" +-- /license header function/. +data UpdateCopyrightConfig (p :: Phase) = UpdateCopyrightConfig + { uccSelectedAuthors :: !(p ::: Maybe (NonEmpty Text)) + -- ^ if specified, years will be updated only in copyright statements of + -- given authors + } + +-- | Alias for complete variant of 'UpdateCopyrightConfig'. +type CtUpdateCopyrightConfig = UpdateCopyrightConfig 'Complete + +-- | Alias for partial variant of 'UpdateCopyrightConfig'. +type PtUpdateCopyrightConfig = UpdateCopyrightConfig 'Partial + +deriving instance Eq CtUpdateCopyrightConfig +deriving instance Eq PtUpdateCopyrightConfig +deriving instance Show CtUpdateCopyrightConfig +deriving instance Show PtUpdateCopyrightConfig + +instance FromJSON PtUpdateCopyrightConfig where + parseJSON = withObject "PtUpdateCopyrightConfig" $ \obj -> do + uccSelectedAuthors <- Last <$> obj .:? "selected-authors-only" + pure UpdateCopyrightConfig { .. } + +instance Semigroup PtUpdateCopyrightConfig where + x <> y = UpdateCopyrightConfig + { uccSelectedAuthors = uccSelectedAuthors x <> uccSelectedAuthors y + } + +instance Monoid PtUpdateCopyrightConfig where + mempty = UpdateCopyrightConfig mempty + + +------------------------------- HeaderFnConfig ------------------------------- + +-- | Configuration for selected /license header function/. +data HeaderFnConfig (p :: Phase) c = HeaderFnConfig + { hfcEnabled :: !(p ::: Bool) + -- ^ whether this function is enabled or not + , hfcConfig :: !(c p) + -- ^ custom configuration of the /license header function/ + } + +-- | Alias for complete variant of 'HeaderFnConfig'. +type CtHeaderFnConfig c = HeaderFnConfig 'Complete c + +-- | Alias for partial variant of 'HeaderFnConfig'. +type PtHeaderFnConfig c = HeaderFnConfig 'Partial c + + +deriving instance (Eq (c 'Complete)) => Eq (CtHeaderFnConfig c) +deriving instance (Eq (c 'Partial)) => Eq (PtHeaderFnConfig c) +deriving instance (Show (c 'Complete)) => Show (CtHeaderFnConfig c) +deriving instance (Show (c 'Partial)) => Show (PtHeaderFnConfig c) + +instance Semigroup (c 'Partial) => Semigroup (PtHeaderFnConfig c) where + x <> y = HeaderFnConfig { hfcEnabled = hfcEnabled x <> hfcEnabled y + , hfcConfig = hfcConfig x <> hfcConfig y + } + +instance Monoid (c 'Partial) => Monoid (PtHeaderFnConfig c) where + mempty = HeaderFnConfig mempty mempty + +instance (FromJSON (c 'Partial), Monoid (c 'Partial)) => FromJSON (PtHeaderFnConfig c) where + parseJSON = withObject "PtHeaderFnConfig" $ \obj -> do + hfcEnabled <- Last <$> obj .:? "enabled" + hfcConfig <- obj .:? "config" .!= mempty + pure HeaderFnConfig { .. } + + +------------------------------- HeaderFnConfigs ------------------------------ + +-- | Configuration of all known /license header functions/. +data HeaderFnConfigs (p :: Phase) = HeaderFnConfigs + { hfcsUpdateCopyright :: !(HeaderFnConfig p UpdateCopyrightConfig) + -- ^ configuration for the "Headroom.HeaderFn.UpdateCopyright" + -- /license header function/ + } + +-- | Alias for complete variant of 'HeaderFnConfigs'. +type CtHeaderFnConfigs = HeaderFnConfigs 'Complete + +-- | Alias for partial variant of 'HeaderFnConfigs'. +type PtHeaderFnConfigs = HeaderFnConfigs 'Partial + +deriving instance Eq CtHeaderFnConfigs +deriving instance Eq PtHeaderFnConfigs +deriving instance Show CtHeaderFnConfigs +deriving instance Show PtHeaderFnConfigs + +instance Semigroup PtHeaderFnConfigs where + x <> y = HeaderFnConfigs + { hfcsUpdateCopyright = hfcsUpdateCopyright x <> hfcsUpdateCopyright y + } + +instance Monoid PtHeaderFnConfigs where + mempty = HeaderFnConfigs mempty + +instance FromJSON PtHeaderFnConfigs where + parseJSON = withObject "PtHeaderFnConfigs" $ \obj -> do + hfcsUpdateCopyright <- obj .:? "update-copyright" .!= mempty + pure HeaderFnConfigs { .. } + + +-------------------------------- Configuration ------------------------------- + +-- | Application configuration. +data Configuration (p :: Phase) = Configuration + { cRunMode :: !(p ::: RunMode) + -- ^ mode of the @run@ command + , cSourcePaths :: !(p ::: [FilePath]) + -- ^ paths to source code files + , cExcludedPaths :: !(p ::: [Regex]) + -- ^ excluded source paths + , cTemplateSource :: !(p ::: TemplateSource) + -- ^ source of license templates + , cVariables :: !Variables + -- ^ variable values for templates + , cLicenseHeaders :: !(HeadersConfig p) + -- ^ configuration of license headers + , cHeaderFnConfigs :: !(HeaderFnConfigs p) + -- ^ configuration of license header functions + } + +-- | Alias for complete variant of 'Configuration'. +type CtConfiguration = Configuration 'Complete + +-- | Alias for partial variant of 'Configuration'. +type PtConfiguration = Configuration 'Partial + +deriving instance Eq CtConfiguration +deriving instance Eq PtConfiguration +deriving instance Show CtConfiguration +deriving instance Show PtConfiguration + +instance FromJSON PtConfiguration where + parseJSON = withObject "PtConfiguration" $ \obj -> do + cRunMode <- Last <$> obj .:? "run-mode" + cSourcePaths <- Last <$> obj .:? "source-paths" + cExcludedPaths <- Last <$> obj .:? "excluded-paths" + cTemplateSource <- Last <$> get TemplateFiles (obj .:? "template-paths") + cVariables <- fmap Variables (obj .:? "variables" .!= mempty) + cLicenseHeaders <- obj .:? "license-headers" .!= mempty + cHeaderFnConfigs <- obj .:? "post-process" .!= mempty + pure Configuration { .. } + where get = fmap . fmap + +instance Semigroup PtConfiguration where + x <> y = Configuration + { cRunMode = cRunMode x <> cRunMode y + , cSourcePaths = cSourcePaths x <> cSourcePaths y + , cExcludedPaths = cExcludedPaths x <> cExcludedPaths y + , cTemplateSource = cTemplateSource x <> cTemplateSource y + , cVariables = cVariables x <> cVariables y + , cLicenseHeaders = cLicenseHeaders x <> cLicenseHeaders y + , cHeaderFnConfigs = cHeaderFnConfigs x <> cHeaderFnConfigs y + } + +instance Monoid PtConfiguration where + mempty = Configuration mempty mempty mempty mempty mempty mempty mempty + + +-------------------------------- HeaderConfig -------------------------------- + +-- | Configuration for specific license header. +data HeaderConfig (p :: Phase) = HeaderConfig + { hcFileExtensions :: !(p ::: [Text]) + -- ^ list of file extensions (without dot) + , hcMarginAfter :: !(p ::: Int) + -- ^ number of empty lines to put after header + , hcMarginBefore :: !(p ::: Int) + -- ^ number of empty lines to put before header + , hcPutAfter :: !(p ::: [Regex]) + -- ^ /regexp/ patterns after which to put the header + , hcPutBefore :: !(p ::: [Regex]) + -- ^ /regexp/ patterns before which to put the header + , hcHeaderSyntax :: !(p ::: HeaderSyntax) + -- ^ syntax of the license header comment + } + +-- | Alias for complete variant of 'HeaderConfig'. +type CtHeaderConfig = HeaderConfig 'Complete + +-- | Alias for partial variant of 'HeaderConfig'. +type PtHeaderConfig = HeaderConfig 'Partial + +deriving instance Eq CtHeaderConfig +deriving instance Eq PtHeaderConfig +deriving instance Show CtHeaderConfig +deriving instance Show PtHeaderConfig + +instance FromJSON PtHeaderConfig where + parseJSON = withObject "PartialHeaderConfig" $ \obj -> do + hcFileExtensions <- Last <$> obj .:? "file-extensions" + hcMarginAfter <- Last <$> obj .:? "margin-after" + hcMarginBefore <- Last <$> obj .:? "margin-before" + hcPutAfter <- Last <$> obj .:? "put-after" + hcPutBefore <- Last <$> obj .:? "put-before" + blockComment <- obj .:? "block-comment" + lineComment <- obj .:? "line-comment" + hcHeaderSyntax <- pure . Last $ headerSyntax blockComment lineComment + pure HeaderConfig { .. } + where + headerSyntax (Just (BlockComment' s e)) Nothing = Just $ BlockComment s e + headerSyntax Nothing (Just (LineComment' p)) = Just $ LineComment p + headerSyntax Nothing Nothing = Nothing + headerSyntax _ _ = throw MixedHeaderSyntax + +instance Monoid PtHeaderConfig where + mempty = HeaderConfig mempty mempty mempty mempty mempty mempty + +instance Semigroup PtHeaderConfig where + x <> y = HeaderConfig + { hcFileExtensions = hcFileExtensions x <> hcFileExtensions y + , hcMarginAfter = hcMarginAfter x <> hcMarginAfter y + , hcMarginBefore = hcMarginBefore x <> hcMarginBefore y + , hcPutAfter = hcPutAfter x <> hcPutAfter y + , hcPutBefore = hcPutBefore x <> hcPutBefore y + , hcHeaderSyntax = hcHeaderSyntax x <> hcHeaderSyntax y + } + + +-------------------------------- HeadersConfig ------------------------------- + +-- | Group of 'HeaderConfig' configurations for supported file types. +data HeadersConfig (p :: Phase) = HeadersConfig + { hscC :: !(HeaderConfig p) + -- ^ configuration for /C/ programming language + , hscCpp :: !(HeaderConfig p) + -- ^ configuration for /C++/ programming language + , hscCss :: !(HeaderConfig p) + -- ^ configuration for /CSS/ + , hscHaskell :: !(HeaderConfig p) + -- ^ configuration for /Haskell/ programming language + , hscHtml :: !(HeaderConfig p) + -- ^ configuration for /HTML/ + , hscJava :: !(HeaderConfig p) + -- ^ configuration for /Java/ programming language + , hscJs :: !(HeaderConfig p) + -- ^ configuration for /JavaScript/ programming language + , hscRust :: !(HeaderConfig p) + -- ^ configuration for /Rust/ programming language + , hscScala :: !(HeaderConfig p) + -- ^ configuration for /Scala/ programming language + , hscShell :: !(HeaderConfig p) + -- ^ configuration for /Shell/ + } + +-- | Alias for complete variant of 'HeadersConfig'. +type CtHeadersConfig = HeadersConfig 'Complete + +-- | Alias for partial variant of 'HeadersConfig'. +type PtHeadersConfig = HeadersConfig 'Partial + +deriving instance Eq CtHeadersConfig +deriving instance Eq PtHeadersConfig +deriving instance Show CtHeadersConfig +deriving instance Show PtHeadersConfig + +instance FromJSON PtHeadersConfig where + parseJSON = withObject "PartialHeadersConfig" $ \obj -> do + hscC <- obj .:? "c" .!= mempty + hscCpp <- obj .:? "cpp" .!= mempty + hscCss <- obj .:? "css" .!= mempty + hscHaskell <- obj .:? "haskell" .!= mempty + hscHtml <- obj .:? "html" .!= mempty + hscJava <- obj .:? "java" .!= mempty + hscJs <- obj .:? "js" .!= mempty + hscRust <- obj .:? "rust" .!= mempty + hscScala <- obj .:? "scala" .!= mempty + hscShell <- obj .:? "shell" .!= mempty + pure HeadersConfig { .. } + + +instance Semigroup PtHeadersConfig where + x <> y = HeadersConfig { hscC = hscC x <> hscC y + , hscCpp = hscCpp x <> hscCpp y + , hscCss = hscCss x <> hscCss y + , hscHaskell = hscHaskell x <> hscHaskell y + , hscHtml = hscHtml x <> hscHtml y + , hscJava = hscJava x <> hscJava y + , hscJs = hscJs x <> hscJs y + , hscRust = hscRust x <> hscRust y + , hscScala = hscScala x <> hscScala y + , hscShell = hscShell x <> hscShell y + } + + +instance Monoid PtHeadersConfig where + mempty = HeadersConfig mempty + mempty + mempty + mempty + mempty + mempty + mempty + mempty + mempty + mempty + + +--------------------------------- Error Types -------------------------------- + +-- | Represents single key in the configuration. +data ConfigurationKey + = CkFileExtensions !FileType + -- ^ no configuration for @file-extensions@ + | CkHeaderSyntax !FileType + -- ^ no configuration for header syntax + | CkMarginAfter !FileType + -- ^ no configuration for @margin-after@ + | CkMarginBefore !FileType + -- ^ no configuration for @margin-before@ + | CkPutAfter !FileType + -- ^ no configuration for @put-after@ + | CkPutBefore !FileType + -- ^ no configuration for @put-before@ + | CkRunMode + -- ^ no configuration for @run-mode@ + | CkSourcePaths + -- ^ no configuration for @source-paths@ + | CkExcludedPaths + -- ^ no configuration for @excluded-paths@ + | CkTemplateSource + -- ^ no configuration for template source + | CkVariables + -- ^ no configuration for @variables@ + | CkEnabled + -- ^ no configuration for @enabled@ + deriving (Eq, Show) + + +-- | Exception specific to the "Headroom.Configuration" module. +data ConfigurationError + = MissingConfiguration !ConfigurationKey + -- ^ some of the required configuration keys has not been specified + | MixedHeaderSyntax + -- ^ illegal configuration for 'HeaderSyntax' + deriving (Eq, Show, Typeable) + +instance Exception ConfigurationError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + +displayException' :: ConfigurationError -> String +displayException' = T.unpack . \case + MissingConfiguration key -> case key of + CkFileExtensions fileType -> missingConfig + (withFT "file-extensions" fileType) + (Just "file-extensions") + Nothing + CkHeaderSyntax fileType -> missingConfig + (withFT "comment-syntax" fileType) + (Just "block-comment|line-comment") + Nothing + CkMarginAfter fileType -> missingConfig (withFT "margin-after" fileType) + (Just "margin-after") + Nothing + CkMarginBefore fileType -> missingConfig + (withFT "margin-before" fileType) + (Just "margin-before") + Nothing + CkPutAfter fileType -> + missingConfig (withFT "put-after" fileType) (Just "put-after") Nothing + CkPutBefore fileType -> + missingConfig (withFT "put-before" fileType) (Just "put-before") Nothing + CkRunMode -> missingConfig + "mode of the run command" + (Just "run-mode") + (Just + "(-a|--add-headers)|(-c|--check-header)|(-d|--drop-header)|(-r|--replace-headers)" + ) + CkSourcePaths -> missingConfig "paths to source code files" + (Just "source-paths") + (Just "-s|--source-path") + CkExcludedPaths -> missingConfig "excluded paths" + (Just "excluded-paths") + (Just "-e|--excluded-path") + CkTemplateSource -> missingConfig + "template files source" + (Just "template-paths") + (Just "(-t|--template-path)|--builtin-templates") + CkVariables -> missingConfig "template variables" + (Just "variables") + (Just "-v|--variable") + CkEnabled -> missingConfig "enabled" (Just "enabled") Nothing + MixedHeaderSyntax -> mixedHeaderSyntax + where + withFT msg fileType = msg <> " (" <> T.pack (show fileType) <> ")" + mixedHeaderSyntax = mconcat + [ "Invalid configuration, combining 'block-comment' with 'line-comment' " + , "is not allowed. Either use 'block-comment' to define multi-line " + , "comment header, or 'line-comment' to define header composed of " + , "multiple single-line comments." + ] + + +missingConfig :: Text -> Maybe Text -> Maybe Text -> Text +missingConfig desc yaml cli = mconcat + [ "Missing configuration for '" + , desc + , "' (" + , options + , "). See official documentation for more details." + ] + where + cliText = fmap (\c -> "command line option '" <> c <> "'") cli + yamlText = fmap (\y -> "YAML option '" <> y <> "'") yaml + options = T.intercalate " or " . catMaybes $ [cliText, yamlText] + + +----------------------------------- LENSES ----------------------------------- + +suffixLenses ''Configuration +suffixLenses ''UpdateCopyrightConfig +suffixLenses ''HeaderFnConfig +suffixLenses ''HeaderFnConfigs diff --git a/src/Headroom/Data/EnumExtra.hs b/src/Headroom/Data/EnumExtra.hs --- a/src/Headroom/Data/EnumExtra.hs +++ b/src/Headroom/Data/EnumExtra.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-| -Module : Headroom.Types.EnumExtra +Module : Headroom.Data.EnumExtra Description : Extra functionality for enum types Copyright : (c) 2019-2020 Vaclav Svejcar License : BSD-3-Clause @@ -56,7 +56,7 @@ -- >>> enumToText Bar -- "Bar" enumToText :: a -> Text - enumToText = T.pack . show + enumToText = tshow -- | Returns enum value from its textual representation. diff --git a/src/Headroom/Data/Lens.hs b/src/Headroom/Data/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Data/Lens.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Headroom.Data.Lens +Description : Custom functionality related to /lens/ +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Provides customized versions of /lens/ functions. +-} + +module Headroom.Data.Lens + ( suffixLenses + , suffixLensesFor + ) +where + +import qualified Language.Haskell.TH.Lib as TH +import qualified Language.Haskell.TH.Syntax as TH +import Lens.Micro.TH ( DefName(..) + , lensField + , lensRules + , lensRulesFor + , makeLensesWith + ) +import RIO + + +-- | A template haskell function to build lenses for a record type. This +-- function differs from the 'Control.Lens.makeLenses' function in that +-- it does not require the record fields to be prefixed with underscores +-- and it adds an "L" suffix to lens names to make it clear that they +-- are lenses. +suffixLenses :: TH.Name -> TH.DecsQ +suffixLenses = makeLensesWith $ lensRules & lensField .~ withSuffix + where withSuffix _ _ name = [TopName . TH.mkName $ (TH.nameBase name <> "L")] + + +-- | Same as 'suffixLensesFor', but build lenses only for selected fields. +suffixLensesFor :: [String] -> TH.Name -> TH.DecsQ +suffixLensesFor fields = makeLensesWith $ lensRulesFor fields' + where fields' = fmap (\f -> (f, f <> "L")) fields diff --git a/src/Headroom/Data/Regex.hs b/src/Headroom/Data/Regex.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Data/Regex.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Headroom.Data.Regex +Description : Helper functions for regular expressions +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Extends functionalify provided by "Text.Regex.PCRE.Light" +and "Text.Regex.PCRE.Heavy" that more suits the needs of this application. +-} + +module Headroom.Data.Regex + ( -- * Data Types + Regex(..) + , RegexError(..) + -- * Regex Functions + , compile + , match + , re + , replace + , scan + ) +where + +import Data.Aeson ( FromJSON(..) + , Value(String) + ) +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +import Language.Haskell.TH hiding ( match ) +import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) +import RIO +import qualified RIO.Text as T +import qualified Text.Regex.PCRE.Heavy as PH +import qualified Text.Regex.PCRE.Light as PL +import qualified Text.Regex.PCRE.Light.Char8 as PLC + + +--------------------------------- DATA TYPES --------------------------------- + +-- | Represents compiled /regex/, encapsulates the actual implementation. +newtype Regex = Regex PL.Regex deriving (Eq, Show) + +instance FromJSON Regex where + parseJSON (String s) = pure . compileUnsafe $ s + parseJSON val = error $ "Invalid value: expected regex, found: " <> show val + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + + +-- | Compiles given /regex/ in /runtime/. If possible, prefer the 're' +-- /quasi quotation/ version that does the same at /compile time/. +compile :: MonadThrow m + => Text + -- ^ /regex/ to compile + -> m Regex + -- ^ compiled regex +compile raw = either (throwM . CompilationFailed raw . T.pack) pure compile' + where compile' = Regex <$> PH.compileM (encodeUtf8 raw) [PLC.utf8] + + +-- | Same as 'match', but works with 'Text' and uses no additional options. +match :: Regex + -- ^ a PCRE regular expression value produced by compile + -> Text + -- ^ the subject text to match against + -> Maybe [Text] + -- ^ the result value +match (Regex r) subject = fmap T.pack <$> PLC.match r (T.unpack subject) [] + + +-- | A QuasiQuoter for regular expressions that does a compile time check. +re :: QuasiQuoter +re = QuasiQuoter { quoteExp = quoteExpRegex + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + + +-- | Replaces all occurences of given /regex/. +replace :: Regex + -- ^ /regex/ to match what to replace + -> (Text -> [Text] -> Text) + -- ^ replacement function (as @fullMatch -> [groups] -> result@) + -> Text + -- ^ text to replace in + -> Text + -- ^ resulting text +replace (Regex regex) = PH.gsub regex + + +-- | Searches the text for all occurences of given /regex/. +scan :: Regex + -- ^ /regex/ to search for + -> Text + -- ^ input text + -> [(Text, [Text])] + -- ^ found occurences (as @[(fullMatch, [groups])]@) +scan (Regex regex) = PH.scan regex + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + + +compileUnsafe :: Text -> Regex +compileUnsafe raw = case compile raw of + Left err -> error . displayException $ err + Right res -> res + + +quoteExpRegex :: String -> ExpQ +quoteExpRegex txt = [| compileUnsafe . T.pack $ txt |] + where !_ = compileUnsafe . T.pack $ txt -- check at compile time + + +--------------------------------- Error Types -------------------------------- + +-- | Exception specific to the "Headroom.Data.Regex" module. +data RegexError = CompilationFailed !Text !Text + -- ^ given input cannot be compiled as /regex/ + deriving (Show, Typeable) + +instance Exception RegexError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + +displayException' :: RegexError -> String +displayException' = T.unpack . \case + CompilationFailed raw reason -> + mconcat ["Cannot compile regex from input '", raw, "', reason: ", reason] diff --git a/src/Headroom/Data/TextExtra.hs b/src/Headroom/Data/TextExtra.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Data/TextExtra.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Headroom.Data.TextExtra +Description : Additional utilities for text manipulation +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Module containing bunch of useful functions for working with text. +-} + +module Headroom.Data.TextExtra + ( read + -- * Working with text lines + , mapLines + , fromLines + , toLines + ) +where + +import RIO +import qualified RIO.Text as T + + +-- | Maps given function over individual lines of the given text. +-- +-- >>> mapLines ("T: " <>) "foo zz\nbar" +-- "T: foo zz\nT: bar" +mapLines :: (Text -> Text) + -- ^ function to map over individual lines + -> Text + -- ^ input text + -> Text + -- ^ result text +mapLines fn = fromLines . go . toLines + where + go [] = [] + go (x : xs) = fn x : go xs + + +-- | Same as 'readMaybe', but takes 'Text' as input instead of 'String'. +-- +-- >>> read "123" :: Maybe Int +-- Just 123 +read :: Read a + => Text + -- ^ input text to parse + -> Maybe a + -- ^ parsed value +read = readMaybe . T.unpack + + +-- | Similar to 'T.unlines', but does not automatically adds @\n@ at the end +-- of the text. Advantage is that when used together with 'toLines', it doesn't +-- ocassionaly change the newlines ad the end of input text: +-- +-- >>> fromLines . toLines $ "foo\nbar" +-- "foo\nbar" +-- +-- >>> fromLines . toLines $ "foo\nbar\n" +-- "foo\nbar\n" +-- +-- Other examples: +-- +-- >>> fromLines [] +-- "" +-- +-- >>> fromLines ["foo"] +-- "foo" +-- +-- >>> fromLines ["first", "second"] +-- "first\nsecond" +-- +-- >>> fromLines ["first", "second", ""] +-- "first\nsecond\n" +fromLines :: [Text] + -- ^ lines to join + -> Text + -- ^ text joined from individual lines +fromLines = T.intercalate "\n" + + +-- | Similar to 'T.lines', but does not drop trailing newlines from output. +-- Advantage is that when used together with 'fromLines', it doesn't ocassionaly +-- change the newlines ad the end of input text: +-- +-- >>> fromLines . toLines $ "foo\nbar" +-- "foo\nbar" +-- +-- >>> fromLines . toLines $ "foo\nbar\n" +-- "foo\nbar\n" +-- +-- Other examples: +-- +-- >>> toLines "" +-- [] +-- +-- >>> toLines "first\nsecond" +-- ["first","second"] +-- +-- >>> toLines "first\nsecond\n" +-- ["first","second",""] +toLines :: Text + -- ^ text to break into lines + -> [Text] + -- ^ lines of input text +toLines input | T.null input = [] + | otherwise = T.split (== '\n') input diff --git a/src/Headroom/Embedded.hs b/src/Headroom/Embedded.hs --- a/src/Headroom/Embedded.hs +++ b/src/Headroom/Embedded.hs @@ -21,9 +21,8 @@ where import Data.FileEmbed ( embedStringFile ) -import Headroom.Types ( FileType(..) - , LicenseType(..) - ) +import Headroom.Configuration.Types ( LicenseType(..) ) +import Headroom.FileType.Types ( FileType(..) ) import RIO @@ -40,9 +39,12 @@ -- | License template for given license. licenseTemplate :: IsString a - => LicenseType -- ^ license for which to return the template - -> FileType -- ^ license for which to return the template - -> a -- ^ template text + => LicenseType + -- ^ license for which to return the template + -> FileType + -- ^ license for which to return the template + -> a + -- ^ template text licenseTemplate licenseType fileType = case licenseType of Apache2 -> case fileType of C -> $(embedStringFile "embedded/license/apache2/c.mustache") diff --git a/src/Headroom/Ext.hs b/src/Headroom/Ext.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Ext.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Headroom.Ext +Description : Extended support for selected /file types/ +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +/Headroom/ provides /extended support/ for selected /file types/, which mean +not only basic management of /license headers/ based on /template files/ is +provided, but also some additional functionality is available. For example, +some extra data may be extracted from the processed /source code file/ and made +available to template via /template variables/ +(e.g. /module name/ for /Haskell source code files/). +-} + +module Headroom.Ext + ( extractVariables + , extractTemplateMeta + ) +where + +import Headroom.Configuration.Types ( CtHeaderConfig ) +import qualified Headroom.Ext.Haskell as Haskell +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Template ( Template(..) ) +import Headroom.Types ( TemplateMeta(..) ) +import Headroom.Variables.Types ( Variables(..) ) +import RIO + + +-- | Extracts variables specific to the file type (if supported), e.g. module +-- name for /Haskell/ source code. Currently supported file types are: +-- +-- * /Haskell/ - implemented in "Headroom.FileSupport.Haskell" +extractVariables :: FileType + -- ^ type of the file + -> CtHeaderConfig + -- ^ license header configuration + -> Maybe TemplateMeta + -- ^ extracted metadata from corresponding /template/ + -> Maybe (Int, Int) + -- ^ license header position @(startLine, endLine)@ + -> Text + -- ^ text of the source code file + -> Variables + -- ^ extracted variables +extractVariables fileType config meta headerPos text = case fileType of + Haskell -> Haskell.extractVariables config meta headerPos text + _ -> mempty + + +-- | Extracts medatata from given /template/ for selected /file type/, which +-- might be later required by the 'extractVariables' function. +extractTemplateMeta :: (Template t) + => FileType + -- ^ /file type/ for which this template will be used + -> t + -- ^ parsed /template/ + -> Maybe TemplateMeta + -- ^ extracted template metadata +extractTemplateMeta Haskell tmpl = Just $ Haskell.extractTemplateMeta tmpl +extractTemplateMeta _ _ = Nothing diff --git a/src/Headroom/Ext/Haskell.hs b/src/Headroom/Ext/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Ext/Haskell.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +{-| +Module : Headroom.Ext.Haskell +Description : Extraction of /Haskell/-specific template variables +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module provides support for extracting /Haskell/-specific info from the +parsed /source code files/ as /template variables/. Such info includes +/module name/ and selected fields from /Haddock module header/ +(see "Headroom.FileSupport.Haskell.Haddock"). +-} + +module Headroom.Ext.Haskell + ( -- * Variables Extraction + extractModuleName + , extractVariables + -- * Template Metadata Extraction + , extractTemplateMeta + ) +where + +import Headroom.Configuration.Types ( CtHeaderConfig ) +import Headroom.Data.Regex ( match + , re + ) +import Headroom.Data.TextExtra ( fromLines + , toLines + ) +import Headroom.Ext.Haskell.Haddock ( HaddockModuleHeader(..) + , extractFieldOffsets + , extractModuleHeader + ) +import Headroom.Template ( Template(..) ) +import Headroom.Types ( TemplateMeta(..) ) +import Headroom.Variables ( mkVariables ) +import Headroom.Variables.Types ( Variables(..) ) +import RIO +import RIO.Lens ( ix ) +import qualified RIO.List as L + + +-- | Extracts name of /Haskell/ module from given source code file content. +-- +-- >>> extractModuleName "{-# LANGUAGE OverloadedStrings #-}\nmodule Foo where" +-- Just "Foo" +extractModuleName :: Text + -- ^ input text + -> Maybe Text + -- ^ extracted module name +extractModuleName = go . toLines + where + go [] = Nothing + go (x : xs) = maybe (go xs) (^? ix 1) (match [re|^module\s+(\S+)|] x) + + +-- | Extracts variables from /Haskell/ source code. +-- +-- __List of Extracted Variables:__ +-- +-- * @___haskell_module_copyright__@ - @Copyright@ field of /Haddock/ module header +-- * @___haskell_module_license__@ - @License@ field of /Haddock/ module header +-- * @___haskell_module_maintainer__@ - @Maintainer@ field of /Haddock/ module header +-- * @___haskell_module_portability__@ - @Portability@ field of /Haddock/ module header +-- * @___haskell_module_stability__@ - @Stability@ field of /Haddock/ module header +-- * @___haskell_module_name__@ - name of the /Haskell/ module +-- * @___haskell_module_longdesc__@ - long description of /Haddock/ module +-- * @___haskell_module_shortdesc__@ - @Description@ field of /Haddock/ module header +extractVariables :: CtHeaderConfig + -- ^ license header configuration + -> Maybe TemplateMeta + -- ^ extracted metadata from corresponding /template/ + -> Maybe (Int, Int) + -- ^ license header position @(startLine, endLine)@ + -> Text + -- ^ input text + -> Variables + -- ^ extracted variables +extractVariables _ meta headerPos text = (mkVariables . catMaybes) + [ ("_haskell_module_copyright", ) <$> hmhCopyright + , ("_haskell_module_license", ) <$> hmhLicense + , ("_haskell_module_maintainer", ) <$> hmhMaintainer + , ("_haskell_module_name", ) <$> extractModuleName text + , ("_haskell_module_portability", ) <$> hmhPortability + , ("_haskell_module_stability", ) <$> hmhStability + , ("_haskell_module_longdesc", ) <$> hmhLongDesc + , ("_haskell_module_shortdesc", ) <$> hmhShortDesc + ] + where + HaddockModuleHeader {..} = extractModuleHeader headerText meta + headerText = maybe "" (\(s, e) -> cut s e text) headerPos + cut s e = fromLines . L.take (e - s) . L.drop s . toLines + + +-- | Extracts template metadata specific for /Haskell/. +extractTemplateMeta :: (Template t) + => t + -- ^ parsed /template/ + -> TemplateMeta + -- ^ extracted template metadata +extractTemplateMeta template = HaskellTemplateMeta offsets + where offsets = extractFieldOffsets template diff --git a/src/Headroom/Ext/Haskell/Haddock.hs b/src/Headroom/Ext/Haskell/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Ext/Haskell/Haddock.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} + +{-| +Module : Headroom.Ext.Haskell.Haddock +Description : Extraction of /Haddock module header/ fields +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Support for extracting data from /Haddock module headers/ present in +/Haskell source code files/ or /templates/. +-} + +module Headroom.Ext.Haskell.Haddock + ( HaddockModuleHeader(..) + , extractFieldOffsets + , extractModuleHeader + , indentField + , stripCommentSyntax + ) +where + +import Control.Applicative ( Alternative(..) ) +import Control.Monad ( ap ) +import Data.Default.Class ( Default(..) ) +import Headroom.Data.Regex ( re + , replace + , scan + ) +import Headroom.Data.TextExtra ( fromLines + , toLines + ) +import Headroom.Template ( Template(..) ) +import Headroom.Types ( HaddockFieldOffsets(..) + , TemplateMeta(..) + ) +import RIO +import qualified RIO.Char as C +import qualified RIO.Text as T + + +-- | Extracted fields from the /Haddock module header/. +data HaddockModuleHeader = HaddockModuleHeader + { hmhCopyright :: Maybe Text + -- ^ module copyright (content of the @Copyright@ field) + , hmhLicense :: Maybe Text + -- ^ module license (content of the @License@ field) + , hmhMaintainer :: Maybe Text + -- ^ module license (content of the @Maintainer@ field) + , hmhPortability :: Maybe Text + -- ^ module license (content of the @Portability@ field) + , hmhStability :: Maybe Text + -- ^ module license (content of the @Stability@ field) + , hmhShortDesc :: Maybe Text + -- ^ module short description (content of the @Description@ field) + , hmhLongDesc :: Maybe Text + -- ^ module long description (the text after module header fields) + } + deriving (Eq, Show) + + +-- | Extracts /offsets/ for selected haddock fields (i.e. number of chars +-- between start of line and field value). This is needed to properly format +-- multi-line field values rendered in new /license headers/. +extractFieldOffsets :: (Template t) + => t + -- ^ parsed /template/ + -> HaddockFieldOffsets + -- ^ extracted field offsets +extractFieldOffsets template = HaddockFieldOffsets { .. } + where + hfoCopyright = extractCopyrightOffset text + text = stripCommentSyntax . rawTemplate $ template + + +extractCopyrightOffset :: Text -> Maybe Int +extractCopyrightOffset text = case scan [re|\h*Copyright\h*:\h*|] text of + [(full, _)] -> Just . T.length $ full + _ -> Nothing + + +-- | Extracts metadata from given /Haddock/ module header. +extractModuleHeader :: Text + -- ^ text containing /Haddock/ module header + -> Maybe TemplateMeta + -- ^ extracted metadata from corresponding /template/ + -> HaddockModuleHeader + -- ^ extracted metadata +extractModuleHeader text meta = + let hmhCopyright = indent hfoCopyright <$> extractField "Copyright" + hmhLicense = extractField "License" + hmhMaintainer = extractField "Maintainer" + hmhPortability = extractField "Portability" + hmhStability = extractField "Stability" + hmhShortDesc = extractField "Description" + hmhLongDesc = if null rest' then Nothing else process rest' + in HaddockModuleHeader { .. } + where + (fields', rest') = fromMaybe ([], input) $ runP fields input + input = T.unpack . stripCommentSyntax $ text + extractField name = fmap (T.strip . T.pack) (lookup name fields') + process = Just . T.strip . T.pack + indent c t = T.strip $ indentField c t + HaddockFieldOffsets {..} = case meta of + Just (HaskellTemplateMeta offsets') -> offsets' + _ -> def + + +-- | Adds correct indentation to multi-line /Haddock/ field values. It's usually +-- desired to have such values indented like this: +-- +-- @ +-- Copyright : (c) 2020, 1st Author +-- (c) 2020, 2nd Author +-- @ +-- +-- This functions achieves that using the /offset/ value, which specifies number +-- of empty characters that should be placed before second (and any subsequent) +-- line. +-- +-- >>> indentField (Just 2) "foo\nbar\nbaz" +-- "foo\n bar\n baz" +indentField :: Maybe Int + -- ^ offset (in number of black chars) for 2nd and subsequent lines + -> Text + -- ^ input text to indent + -> Text + -- ^ processed text +indentField Nothing text = text +indentField (Just offset) text = fromLines . go . toLines $ text + where + go [] = [] + go [x ] = [x] + go (x : xs) = x : fmap ((prefix <>) . T.stripStart) xs + prefix = T.replicate offset " " + + +-- | Strips /Haskell/ comment syntax tokens (e.g. @{-@, @-}@) from input text. +-- +-- >>> stripCommentSyntax "{- foo -}\nbar\n" +-- "foo \nbar\n" +stripCommentSyntax :: Text + -- ^ input text to strip + -> Text + -- ^ resulting text without comment syntax tokens +stripCommentSyntax text = fromLines $ go (toLines text) [] + where + regex = [re|^(-- \||-{2,})|^\h*({-\h?\|?)|(-})\h*$|] + strip = replace regex (const . const $ "") + go [] acc = reverse acc + go (x : xs) acc = go xs (strip x : acc) + + +-------------------------------------------------------------------------------- +-- Below code is slightly modified version of code copied from: +-- https://github.com/haskell/haddock/blob/ghc-8.10/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +------------------------------------------------------------------------------- +-- Small parser to parse module header. +------------------------------------------------------------------------------- + +-- The below is a small parser framework how we read keys. +-- +-- all fields in the header are optional and have the form +-- +-- [spaces1][field name][spaces] ":" +-- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")* +-- where each [spaces2] should have [spaces1] as a prefix. +-- +-- Thus for the key "Description", +-- +-- > Description : this is a +-- > rather long +-- > +-- > description +-- > +-- > The module comment starts here +-- +-- the value will be "this is a .. description" and the rest will begin +-- at "The module comment". + +-- 'C' is a 'Char' carrying its column. +-- +-- This let us make an indentation-aware parser, as we know current indentation. +-- by looking at the next character in the stream ('curInd'). +-- +-- Thus we can munch all spaces but only not-spaces which are indented. +-- +data C = C {-# UNPACK #-} !Int Char + +newtype P a = P { unP :: [C] -> Maybe ([C], a) } + deriving Functor + +instance Applicative P where + pure x = P $ \s -> Just (s, x) + (<*>) = ap + +instance Monad P where + return = pure + m >>= k = P $ \s0 -> do + (s1, x) <- unP m s0 + unP (k x) s1 + +instance Alternative P where + empty = P $ const Nothing + a <|> b = P $ \s -> unP a s <|> unP b s + +runP :: P a -> String -> Maybe a +runP p input = fmap snd (unP p input') + where + input' = + concat [ zipWith C [0 ..] l <> [C (length l) '\n'] | l <- lines input ] + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +curInd :: P Int +curInd = P $ \s -> Just . (,) s $ case s of + [] -> 0 + C i _ : _ -> i + +rest :: P String +rest = P $ \cs -> Just ([], [ c | C _ c <- cs ]) + +munch :: (Int -> Char -> Bool) -> P String +munch p = P $ \cs -> let (xs, ys) = takeWhileMaybe p' cs in Just (ys, xs) + where + p' (C i c) | p i c = Just c + | otherwise = Nothing + +munch1 :: (Int -> Char -> Bool) -> P String +munch1 p = P $ \case + [] -> Nothing + (c : cs) + | Just c' <- p' c + -> let (xs, ys) = takeWhileMaybe p' cs in Just (ys, c' : xs) + | otherwise + -> Nothing + where + p' (C i c) | p i c = Just c + | otherwise = Nothing + +char :: Char -> P Char +char c = P $ \case + [] -> Nothing + (C _ c' : cs) | c == c' -> Just (cs, c) + | otherwise -> Nothing + +skipSpaces :: P () +skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> C.isSpace c) cs, ()) + +takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +takeWhileMaybe f = go where + go xs0@[] = ([], xs0) + go xs0@(x : xs) = case f x of + Just y -> let (ys, zs) = go xs in (y : ys, zs) + Nothing -> ([], xs0) + +------------------------------------------------------------------------------- +-- Fields +------------------------------------------------------------------------------- + +field :: Int -> P (String, String) +field i = do + fn <- munch1 $ \_ c -> C.isAlpha c || c == '-' + skipSpaces + _ <- char ':' + skipSpaces + val <- munch $ \j c -> C.isSpace c || j > i + return (fn, val) + +fields :: P ([(String, String)], String) +fields = do + skipSpaces + i <- curInd + fs <- many (field i) + r <- rest + return (fs, r) diff --git a/src/Headroom/FileSupport.hs b/src/Headroom/FileSupport.hs --- a/src/Headroom/FileSupport.hs +++ b/src/Headroom/FileSupport.hs @@ -32,42 +32,57 @@ ) where -import Headroom.Regex ( compile' - , joinPatterns - , match' - ) -import Headroom.Types ( FileInfo(..) - , FileType(..) +import Headroom.Configuration.Types ( CtHeaderConfig , HeaderConfig(..) , HeaderSyntax(..) ) +import Headroom.Data.Regex ( Regex + , match + ) +import Headroom.Data.TextExtra ( fromLines + , toLines + ) +import Headroom.Ext ( extractVariables ) +import Headroom.FileSupport.Types ( FileInfo(..) + , fiHeaderPosL + ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Types ( TemplateMeta(..) ) import RIO -import qualified RIO.HashMap as HM import qualified RIO.List as L import qualified RIO.Text as T -import Text.Regex.PCRE.Light ( Regex ) - -- | Extracts info about the processed file to be later used by the header -- detection/manipulation functions. -extractFileInfo :: FileType -- ^ type of the detected file - -> HeaderConfig -- ^ appropriate header configuration - -> Text -- ^ text used for detection - -> FileInfo -- ^ resulting file info -extractFileInfo fiFileType fiHeaderConfig input = - let fiHeaderPos = findHeader fiHeaderConfig input - fiVariables = extractVariables fiFileType fiHeaderConfig input +extractFileInfo :: FileType + -- ^ type of the detected file + -> CtHeaderConfig + -- ^ license header configuration + -> Maybe TemplateMeta + -- ^ metadata extracted from /template/ + -> Text + -- ^ text used for detection + -> FileInfo + -- ^ resulting file info +extractFileInfo fiFileType fiHeaderConfig meta text = + let fiHeaderPos = findHeader fiHeaderConfig text + fiVariables = + extractVariables fiFileType fiHeaderConfig meta fiHeaderPos text in FileInfo { .. } -- | Adds given header at position specified by the 'FileInfo'. Does nothing if -- any header is already present, use 'replaceHeader' if you need to -- override it. -addHeader :: FileInfo -- ^ info about file where header is added - -> Text -- ^ text of the new header - -> Text -- ^ text of the file where to add the header - -> Text -- ^ resulting text with added header +addHeader :: FileInfo + -- ^ info about file where header is added + -> Text + -- ^ text of the new header + -> Text + -- ^ text of the file where to add the header + -> Text + -- ^ resulting text with added header addHeader FileInfo {..} _ text | isJust fiHeaderPos = text addHeader FileInfo {..} header text = result where @@ -79,31 +94,38 @@ margin _ size = replicate size "" marginBefore = margin before' hcMarginBefore marginAfter = margin (middle' <> after) hcMarginAfter - result = T.unlines $ concat joined + result = fromLines $ concat joined joined = [before', marginBefore, [header], marginAfter, middle', after] -- | Drops header at position specified by the 'FileInfo' from the given text. -- Does nothing if no header is present. -dropHeader :: FileInfo -- ^ info about the file from which the header will be dropped - -> Text -- ^ text of the file from which to drop the header - -> Text -- ^ resulting text with dropped header +dropHeader :: FileInfo + -- ^ info about the file from which the header will be dropped + -> Text + -- ^ text of the file from which to drop the header + -> Text + -- ^ resulting text with dropped header dropHeader (FileInfo _ _ Nothing _) text = text dropHeader (FileInfo _ _ (Just (start, end)) _) text = result where before = take start inputLines after = drop (end + 1) inputLines - inputLines = T.lines text - result = T.unlines (stripLinesEnd before ++ stripLinesStart after) + inputLines = toLines text + result = fromLines (stripLinesEnd before <> stripLinesStart after) -- | Replaces existing header at position specified by the 'FileInfo' in the -- given text. Basically combines 'addHeader' with 'dropHeader'. If no header -- is present, then the given one is added to the text. -replaceHeader :: FileInfo -- ^ info about the file in which to replace the header - -> Text -- ^ text of the new header - -> Text -- ^ text of the file where to replace the header - -> Text -- ^ resulting text with replaced header +replaceHeader :: FileInfo + -- ^ info about the file in which to replace the header + -> Text + -- ^ text of the new header + -> Text + -- ^ text of the file where to replace the header + -> Text + -- ^ resulting text with replaced header replaceHeader fileInfo header = addHeader' . dropHeader' where addHeader' = addHeader infoWithoutPos header @@ -116,12 +138,17 @@ -- Based on the 'HeaderSyntax' specified in given 'HeaderConfig', this function -- delegates its work to either 'findBlockHeader' or 'findLineHeader'. -- +-- >>> :set -XFlexibleContexts +-- >>> :set -XTypeFamilies -- >>> let hc = HeaderConfig ["hs"] 0 0 [] [] (BlockComment "{-" "-}") -- >>> findHeader hc "foo\nbar\n{- HEADER -}\nbaz" -- Just (2,2) -findHeader :: HeaderConfig -- ^ appropriate header configuration - -> Text -- ^ text in which to detect the header - -> Maybe (Int, Int) -- ^ header position @(startLine, endLine)@ +findHeader :: CtHeaderConfig + -- ^ appropriate header configuration + -> Text + -- ^ text in which to detect the header + -> Maybe (Int, Int) + -- ^ header position @(startLine, endLine)@ findHeader HeaderConfig {..} input = case hcHeaderSyntax of BlockComment start end -> findBlockHeader start end inLines splitAt LineComment prefix -> findLineHeader prefix inLines splitAt @@ -136,11 +163,16 @@ -- -- >>> findBlockHeader "{-" "-}" ["", "{- HEADER -}", "", ""] 0 -- Just (1,1) -findBlockHeader :: Text -- ^ starting pattern (e.g. @{-@ or @/*@) - -> Text -- ^ ending pattern (e.g. @-}@ or @*/@) - -> [Text] -- ^ lines of text in which to detect the header - -> Int -- ^ line number offset (adds to resulting position) - -> Maybe (Int, Int) -- ^ header position @(startLine + offset, endLine + offset)@ +findBlockHeader :: Text + -- ^ starting pattern (e.g. @{-@ or @/*@) + -> Text + -- ^ ending pattern (e.g. @-}@ or @*/@) + -> [Text] + -- ^ lines of text in which to detect the header + -> Int + -- ^ line number offset (adds to resulting position) + -> Maybe (Int, Int) + -- ^ header position @(startLine + offset, endLine + offset)@ findBlockHeader startsWith endsWith = go Nothing Nothing where isStart = T.isPrefixOf startsWith @@ -157,10 +189,14 @@ -- -- >>> findLineHeader "--" ["", "a", "-- first", "-- second", "foo"] 0 -- Just (2,3) -findLineHeader :: Text -- ^ prefix pattern (e.g. @--@ or @//@) - -> [Text] -- ^ lines of text in which to detect the header - -> Int -- ^ line number offset (adds to resulting position) - -> Maybe (Int, Int) -- ^ header position @(startLine + offset, endLine + offset)@ +findLineHeader :: Text + -- ^ prefix pattern (e.g. @--@ or @//@) + -> [Text] + -- ^ lines of text in which to detect the header + -> Int + -- ^ line number offset (adds to resulting position) + -> Maybe (Int, Int) + -- ^ header position @(startLine + offset, endLine + offset)@ findLineHeader prefix = go Nothing where isPrefix = T.isPrefixOf prefix @@ -173,14 +209,19 @@ -- | Finds very first line that matches the given /regex/ (numbered from zero). -- --- >>> firstMatching (compile' "^foo") ["some text", "foo bar", "foo baz", "last"] +-- >>> import Headroom.Data.Regex (re) +-- >>> :set -XQuasiQuotes +-- >>> firstMatching [[re|^foo|]] ["some text", "foo bar", "foo baz", "last"] -- Just 1 -firstMatching :: Regex -- /regex/ used for matching - -> [Text] -- input lines - -> Maybe Int -- matching line number -firstMatching regex input = go input 0 +firstMatching :: [Regex] + -- ^ /regex/ used for matching + -> [Text] + -- ^ input lines + -> Maybe Int + -- ^ matching line number +firstMatching patterns input = go input 0 where - cond x = isJust $ match' regex x + cond x = any (\r -> isJust $ match r x) patterns go (x : _) i | cond x = Just i go (_ : xs) i = go xs (i + 1) go [] _ = Nothing @@ -188,14 +229,19 @@ -- | Finds very last line that matches the given /regex/ (numbered from zero). -- --- >>> lastMatching (compile' "^foo") ["some text", "foo bar", "foo baz", "last"] +-- >>> import Headroom.Data.Regex (re) +-- >>> :set -XQuasiQuotes +-- >>> lastMatching [[re|^foo|]] ["some text", "foo bar", "foo baz", "last"] -- Just 2 -lastMatching :: Regex -- /regex/ used for matching - -> [Text] -- input lines - -> Maybe Int -- matching line number -lastMatching regex input = go input 0 Nothing +lastMatching :: [Regex] + -- ^ /regex/ used for matching + -> [Text] + -- ^ input lines + -> Maybe Int + -- ^ matching line number +lastMatching patterns input = go input 0 Nothing where - cond x = isJust $ match' regex x + cond x = any (\r -> isJust $ match r x) patterns go (x : xs) i _ | cond x = go xs (i + 1) (Just i) go (_ : xs) i pos = go xs (i + 1) pos go [] _ pos = pos @@ -212,38 +258,39 @@ -- If both first and second patterns are empty, then all lines are returned in -- the middle list. -- --- >>> splitInput ["->"] ["<-"] "text\n->\nRESULT\n<-\nfoo" +-- >>> import Headroom.Data.Regex (re) +-- >>> :set -XQuasiQuotes +-- +-- >>> splitInput [[re|->|]] [[re|<-|]] "text\n->\nRESULT\n<-\nfoo" -- (["text","->"],["RESULT"],["<-","foo"]) -- --- >>> splitInput [] ["<-"] "text\n->\nRESULT\n<-\nfoo" +-- >>> splitInput [] [[re|<-|]] "text\n->\nRESULT\n<-\nfoo" -- ([],["text","->","RESULT"],["<-","foo"]) -- -- >>> splitInput [] [] "one\ntwo" -- ([],["one","two"],[]) -splitInput :: [Text] -> [Text] -> Text -> ([Text], [Text], [Text]) -splitInput [] [] input = ([], T.lines input, []) +splitInput :: [Regex] + -- ^ patterns for first split + -> [Regex] + -- ^ patterns for second split + -> Text + -- ^ text to split + -> ([Text], [Text], [Text]) + -- ^ result lines as @([before1stSplit], [middle], [after2ndSplit])@ +splitInput [] [] input = ([], toLines input, []) splitInput fstSplit sndSplit input = (before, middle, after) where (middle', after ) = L.splitAt sndSplitAt inLines (before , middle) = L.splitAt fstSplitAt middle' - fstSplitAt = maybe 0 (+ 1) (findSplit lastMatching fstSplit middle') - sndSplitAt = fromMaybe len (findSplit firstMatching sndSplit inLines) - inLines = T.lines input + fstSplitAt = maybe 0 (+ 1) (lastMatching fstSplit middle') + sndSplitAt = fromMaybe len (firstMatching sndSplit inLines) + inLines = toLines input len = L.length inLines - findSplit f ps i = joinPatterns ps >>= (`f` i) . compile' --- TODO: https://github.com/vaclavsvejcar/headroom/issues/25 -extractVariables :: FileType -> HeaderConfig -> Text -> HashMap Text Text -extractVariables _ _ _ = HM.empty - - stripLinesEnd :: [Text] -> [Text] -stripLinesEnd = takeWhile (not . T.null . T.strip) +stripLinesEnd = toLines . T.stripEnd . fromLines stripLinesStart :: [Text] -> [Text] -stripLinesStart = dropWhile (T.null . T.strip) - -fiHeaderPosL :: Lens' FileInfo (Maybe (Int, Int)) -fiHeaderPosL = lens fiHeaderPos (\x y -> x { fiHeaderPos = y }) +stripLinesStart = toLines . T.stripStart . fromLines diff --git a/src/Headroom/FileSupport/Types.hs b/src/Headroom/FileSupport/Types.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/Types.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Headroom.FileSupport.Types +Description : Data types for "Headroom.FileSupport" +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types for "Headroom.FileSupport" module. +-} + +module Headroom.FileSupport.Types + ( -- * Data Types + FileInfo(..) + -- * Lenses + , fiFileTypeL + , fiHeaderConfigL + , fiHeaderPosL + , fiVariablesL + ) +where + +import Headroom.Configuration.Types ( CtHeaderConfig ) +import Headroom.Data.Lens ( suffixLenses ) +import Headroom.FileType.Types ( FileType ) +import Headroom.Variables.Types ( Variables ) +import RIO + + +-- | Info extracted about the concrete source code file. +data FileInfo = FileInfo + { fiFileType :: !FileType + -- ^ type of the file + , fiHeaderConfig :: !CtHeaderConfig + -- ^ configuration for license header + , fiHeaderPos :: !(Maybe (Int, Int)) + -- ^ position of existing license header + , fiVariables :: !Variables + -- ^ additional extracted variables + } + deriving (Eq, Show) + +suffixLenses ''FileInfo diff --git a/src/Headroom/FileSystem.hs b/src/Headroom/FileSystem.hs --- a/src/Headroom/FileSystem.hs +++ b/src/Headroom/FileSystem.hs @@ -31,14 +31,12 @@ ) where -import Headroom.FileType ( listExtensions ) -import Headroom.Regex ( compile' - , joinPatterns - , match' - ) -import Headroom.Types ( FileType - , HeadersConfig(..) +import Headroom.Configuration.Types ( CtHeadersConfig ) +import Headroom.Data.Regex ( Regex + , match ) +import Headroom.FileType ( listExtensions ) +import Headroom.FileType.Types ( FileType ) import RIO import RIO.Directory ( createDirectory , doesDirectoryExist @@ -57,27 +55,37 @@ -- | Recursively finds files on given path whose filename matches the predicate. findFiles :: MonadIO m - => FilePath -- ^ path to search - -> (FilePath -> Bool) -- ^ predicate to match filename - -> m [FilePath] -- ^ found files + => FilePath + -- ^ path to search + -> (FilePath -> Bool) + -- ^ predicate to match filename + -> m [FilePath] + -- ^ found files findFiles path predicate = fmap (filter predicate) (listFiles path) -- | Recursively finds files on given path by file extensions. findFilesByExts :: MonadIO m - => FilePath -- ^ path to search - -> [Text] -- ^ list of file extensions (without dot) - -> m [FilePath] -- ^ list of found files + => FilePath + -- ^ path to search + -> [Text] + -- ^ list of file extensions (without dot) + -> m [FilePath] + -- ^ list of found files findFilesByExts path exts = findFiles path predicate where predicate p = any (`isExtensionOf` p) (fmap T.unpack exts) -- | Recursively find files on given path by their file types. findFilesByTypes :: MonadIO m - => HeadersConfig -- ^ configuration of license headers - -> [FileType] -- ^ list of file types - -> FilePath -- ^ path to search - -> m [FilePath] -- ^ list of found files + => CtHeadersConfig + -- ^ configuration of license headers + -> [FileType] + -- ^ list of file types + -> FilePath + -- ^ path to search + -> m [FilePath] + -- ^ list of found files findFilesByTypes headersConfig types path = findFilesByExts path (types >>= listExtensions headersConfig) @@ -85,8 +93,10 @@ -- | Recursively find all files on given path. If file reference is passed -- instead of directory, such file path is returned. listFiles :: MonadIO m - => FilePath -- ^ path to search - -> m [FilePath] -- ^ list of found files + => FilePath + -- ^ path to search + -> m [FilePath] + -- ^ list of found files listFiles fileOrDir = do isDir <- doesDirectoryExist fileOrDir if isDir then listDirectory fileOrDir else pure [fileOrDir] @@ -113,22 +123,27 @@ -- | Loads file content in UTF8 encoding. loadFile :: MonadIO m - => FilePath -- ^ file path - -> m Text -- ^ file content + => FilePath + -- ^ file path + -> m Text + -- ^ file content loadFile = readFileUtf8 -- | Takes list of patterns and file paths and returns list of file paths where -- those matching the given patterns are excluded. -- --- >>> excludePaths ["\\.hidden", "zzz"] ["foo/.hidden", "test/bar", "x/zzz/e"] +-- >>> import Headroom.Data.Regex (re) +-- >>> :set -XQuasiQuotes +-- >>> excludePaths [[re|\.hidden|], [re|zzz|]] ["foo/.hidden", "test/bar", "x/zzz/e"] -- ["test/bar"] -excludePaths :: [Text] -- ^ patterns describing paths to exclude - -> [FilePath] -- ^ list of file paths - -> [FilePath] -- ^ resulting list of file paths +excludePaths :: [Regex] + -- ^ patterns describing paths to exclude + -> [FilePath] + -- ^ list of file paths + -> [FilePath] + -- ^ resulting list of file paths excludePaths _ [] = [] excludePaths [] paths = paths -excludePaths patterns paths = go $ compile' <$> joinPatterns patterns - where - go Nothing = paths - go (Just regex) = L.filter (isNothing . match' regex . T.pack) paths +excludePaths patterns paths = L.filter excluded paths + where excluded item = all (\p -> isNothing $ match p (T.pack item)) patterns diff --git a/src/Headroom/FileType.hs b/src/Headroom/FileType.hs --- a/src/Headroom/FileType.hs +++ b/src/Headroom/FileType.hs @@ -22,11 +22,13 @@ ) where -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.Types ( FileType(..) +import Headroom.Configuration.Types ( CtHeaderConfig + , CtHeadersConfig , HeaderConfig(..) , HeadersConfig(..) ) +import Headroom.Data.EnumExtra ( EnumExtra(..) ) +import Headroom.FileType.Types ( FileType(..) ) import RIO import qualified RIO.List as L @@ -34,27 +36,36 @@ -- | Returns 'FileType' for given file extension (without dot), using configured -- values from the 'HeadersConfig'. -fileTypeByExt :: HeadersConfig -- ^ license headers configuration - -> Text -- ^ file extension (without dot) - -> Maybe FileType -- ^ found 'FileType' +fileTypeByExt :: CtHeadersConfig + -- ^ license headers configuration + -> Text + -- ^ file extension (without dot) + -> Maybe FileType + -- ^ found 'FileType' fileTypeByExt config ext = L.find (elem ext . listExtensions config) (allValues @FileType) -- | Lists all recognized file extensions for given 'FileType', using configured -- values from the 'HeadersConfig'. -listExtensions :: HeadersConfig -- ^ license headers configuration - -> FileType -- ^ 'FileType' for which to list extensions - -> [Text] -- ^ list of appropriate file extensions +listExtensions :: CtHeadersConfig + -- ^ license headers configuration + -> FileType + -- ^ 'FileType' for which to list extensions + -> [Text] + -- ^ list of appropriate file extensions listExtensions config fileType = hcFileExtensions (configByFileType config fileType) -- | Returns the proper 'HeaderConfig' for the given 'FileType', selected -- from the 'HeadersConfig'. -configByFileType :: HeadersConfig -- ^ license headers configuration - -> FileType -- ^ selected 'FileType' - -> HeaderConfig -- ^ appropriate 'HeaderConfig' +configByFileType :: CtHeadersConfig + -- ^ license headers configuration + -> FileType + -- ^ selected 'FileType' + -> CtHeaderConfig + -- ^ appropriate 'HeaderConfig' configByFileType HeadersConfig {..} fileType = case fileType of C -> hscC CPP -> hscCpp diff --git a/src/Headroom/FileType/Types.hs b/src/Headroom/FileType/Types.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileType/Types.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Headroom.FileType.Types +Description : Data types for "Headroom.FileType" +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types for "Headroom.FileType" modules. +-} + +module Headroom.FileType.Types where + +import Headroom.Data.EnumExtra ( EnumExtra(..) ) +import RIO + +-- | Supported type of source code file. +data FileType + = C + -- ^ support for /C/ programming language + | CPP + -- ^ support for /C++/ programming language + | CSS + -- ^ support for /CSS/ + | Haskell + -- ^ support for /Haskell/ programming language + | HTML + -- ^ support for /HTML/ + | Java + -- ^ support for /Java/ programming language + | JS + -- ^ support for /JavaScript/ programming language + | Rust + -- ^ support for /Rust/ programming language + | Scala + -- ^ support for /Scala/ programming language + | Shell + -- ^ support for /Shell/ + deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) diff --git a/src/Headroom/HeaderFn.hs b/src/Headroom/HeaderFn.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/HeaderFn.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : Headroom.HeaderFn +Description : Support for /license header functions/ +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +/License header functions/ are basically functions that allows to post-process +already rendered /license headers/. This is useful to perform some additional +operations such as some sort of text alignment, update some parts of the header, +etc. +-} + +module Headroom.HeaderFn + ( runHeaderFn + , configuredHeaderFn + , postProcessHeader + -- * Environment Data Types + , ConfiguredEnv(..) + , mkConfiguredEnv + -- * Lenses + , ceCurrentYearL + , ceHeaderFnConfigsL + , ceUpdateCopyrightModeL + ) +where + +import Headroom.Configuration.Types ( CtHeaderFnConfigs + , HeaderFnConfig(..) + , HeaderFnConfigs(..) + , hfcConfigL + , hfcsUpdateCopyrightL + , uccSelectedAuthorsL + ) +import Headroom.Data.Has ( Has(..) ) +import Headroom.Data.Lens ( suffixLenses ) +import Headroom.HeaderFn.Types ( HeaderFn(..) ) +import Headroom.HeaderFn.UpdateCopyright + ( SelectedAuthors(..) + , UpdateCopyrightMode(..) + , updateCopyright + ) +import Headroom.Meta ( TemplateType ) +import Headroom.Template ( Template(..) ) +import Headroom.Types ( CurrentYear(..) ) +import Headroom.Variables.Types ( Variables(..) ) +import Lens.Micro ( traverseOf ) +import RIO + + +-- | Runs the /license header function/ using the given /environment/ and text +-- of rendered /license header/ as input. +runHeaderFn :: HeaderFn env + -- ^ /license header function/ to run + -> env + -- ^ environment value + -> Text + -- ^ text of rendered /license header/ + -> Text + -- ^ processed text of /license header/ +runHeaderFn (HeaderFn fn) env input = runReader (fn input) env + + +-- | Composition of various /license header functions/, which environment is +-- based on /YAML/ configuration and which can be enabled/disabled to fit +-- end user's needs. +configuredHeaderFn :: (Has CurrentYear env, Has UpdateCopyrightMode env) + => CtHeaderFnConfigs + -- ^ configuration of /license header functions/ + -> HeaderFn env + -- ^ composed /license header function/ +configuredHeaderFn HeaderFnConfigs {..} = mconcat + [ifEnabled hfcsUpdateCopyright updateCopyright] + where + ifEnabled HeaderFnConfig {..} fn | hfcEnabled = fn + | otherwise = mempty + + +-- | Takes already rendered /license header/ and post-process it based on the +-- given configuration. +postProcessHeader :: ConfiguredEnv + -- ^ configuration used to define post-processing behaviour + -> Text + -- ^ rendered text of /license header/ + -> Text + -- ^ post-processed text of /license header/ +postProcessHeader env = runHeaderFn (configuredHeaderFn configs) env + where configs = ceHeaderFnConfigs env + + +-- | Environemnt data type for the composed /license header function/ +-- ('configuredHeaderFn'). +data ConfiguredEnv = ConfiguredEnv + { ceCurrentYear :: !CurrentYear + -- ^ current year + , ceHeaderFnConfigs :: !CtHeaderFnConfigs + -- ^ configuration of /license header functions/ + , ceUpdateCopyrightMode :: !UpdateCopyrightMode + -- ^ mode used by the 'updateCopyright' /license header function/ + } + deriving (Eq, Show) + +suffixLenses ''ConfiguredEnv + +instance Has CurrentYear ConfiguredEnv where + hasLens = ceCurrentYearL + +instance Has UpdateCopyrightMode ConfiguredEnv where + hasLens = ceUpdateCopyrightModeL + + +-- | Constructor function for 'ConfiguredEnv' data type. This function takes +-- 'Variables' as argument, because it performs template compilation on +-- selected fields of 'CtHeaderFnConfigs'. +mkConfiguredEnv :: (MonadThrow m) + => CurrentYear + -- ^ current year + -> Variables + -- ^ template variables + -> CtHeaderFnConfigs + -- ^ configuration of /license header functions/ + -> m ConfiguredEnv + -- ^ environment data type +mkConfiguredEnv ceCurrentYear vars configs = do + ceHeaderFnConfigs <- compileTemplates vars configs + let ceUpdateCopyrightMode = mode ceHeaderFnConfigs + pure ConfiguredEnv { .. } + where + authorsL = hfcsUpdateCopyrightL . hfcConfigL . uccSelectedAuthorsL + mode configs' = maybe UpdateAllAuthors + (UpdateSelectedAuthors . SelectedAuthors) + (configs' ^. authorsL) + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +compileTemplates :: (MonadThrow m) + => Variables + -> CtHeaderFnConfigs + -> m CtHeaderFnConfigs +compileTemplates vars configs = configs & traverseOf authorsL compileAuthors' + where + authorsL = hfcsUpdateCopyrightL . hfcConfigL . uccSelectedAuthorsL + compileAuthors' = mapM . mapM $ compileAuthor + compileAuthor author = do + parsed <- parseTemplate @TemplateType (Just $ "author " <> author) author + renderTemplate vars parsed + + + + diff --git a/src/Headroom/HeaderFn/Types.hs b/src/Headroom/HeaderFn/Types.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/HeaderFn/Types.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Headroom.HeaderFn.Types +Description : Data types for /license header functions/ +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types and /type class/ instances for the +/license header functions/. +-} + +module Headroom.HeaderFn.Types + ( HeaderFn(..) + ) +where + +import RIO + + +-- | Definition of /license header function/, i.e. function, that is applied to +-- already rendered /license header/, performs some logic and returns modified +-- text of /license header/. Given that the /reader monad/ and 'ReaderT' +-- transformer is used, any configuration is provided using the @env@ +-- environment. When combined with the "Headroom.Data.Has" monad, it provides +-- powerful way how to combine different /license header function/ and +-- environments. +-- +-- = Structure of License Header Function Type +-- +-- @ +-- __Text -> Reader env Text__ +-- │ │ │ +-- └─ rendered text of license header +-- │ │ +-- └─ environment holding possible configuration +-- │ +-- └─ modified license header text +-- @ +newtype HeaderFn env = HeaderFn (Text -> Reader env Text) + +instance Semigroup (HeaderFn env) where + HeaderFn fnX <> HeaderFn fnY = HeaderFn $ fnX >=> fnY + +instance Monoid (HeaderFn env) where + mempty = HeaderFn $ \input -> pure input diff --git a/src/Headroom/HeaderFn/UpdateCopyright.hs b/src/Headroom/HeaderFn/UpdateCopyright.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/HeaderFn/UpdateCopyright.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module : Headroom.HeaderFn.UpdateCopyright +Description : /License Header function/ for updating years in copyrights +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module provides functionality for updating years in copyright statements +in already rendered /license headers/. +-} + +module Headroom.HeaderFn.UpdateCopyright + ( -- * Data Types + SelectedAuthors(..) + , UpdateCopyrightMode(..) + -- * Header Functions + , updateCopyright + -- * Helper Functions + , updateYears + ) +where + +import Headroom.Data.Has ( Has(..) ) +import Headroom.Data.Regex ( re + , replace + ) +import Headroom.Data.TextExtra ( mapLines + , read + ) +import Headroom.HeaderFn.Types ( HeaderFn(..) ) +import Headroom.Types ( CurrentYear(..) ) +import RIO +import qualified RIO.NonEmpty as NE +import qualified RIO.Text as T + + +--------------------------------- DATA TYPES --------------------------------- + + +-- | Non-empty list of authors for which to update years in their copyrights. +newtype SelectedAuthors = SelectedAuthors (NonEmpty Text) deriving (Eq, Show) + + +-- | Mode that changes behaviour of the 'updateCopyright' function. +data UpdateCopyrightMode + = UpdateAllAuthors + -- ^ updates years in copyrights for all authors + | UpdateSelectedAuthors !SelectedAuthors + -- ^ updates years in copyrights only for selected authors + deriving (Eq, Show) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + + +-- | /License header function/ that updates years and year ranges in any +-- present copyright statements. +-- +-- = Reader Environment Parameters +-- ['CurrentYear'] value of the current year +-- ['UpdateCopyrightMode'] mode specifying the behaviour of the updater +updateCopyright :: (Has CurrentYear env, Has UpdateCopyrightMode env) + => HeaderFn env +updateCopyright = HeaderFn $ \input -> do + currentYear <- viewL + mode <- viewL + pure $ mapLines (update mode currentYear) input + where + update mode year line | shouldUpdate mode line = updateYears year line + | otherwise = line + shouldUpdate UpdateAllAuthors _ = True + shouldUpdate (UpdateSelectedAuthors (SelectedAuthors authors)) input = + any (`T.isInfixOf` input) (NE.toList authors) + + +-- | Updates years and years ranges in given text. +-- +-- >>> updateYears (CurrentYear 2020) "Copyright (c) 2020" +-- "Copyright (c) 2020" +-- +-- >>> updateYears (CurrentYear 2020) "Copyright (c) 2019" +-- "Copyright (c) 2019-2020" +-- +-- >>> updateYears (CurrentYear 2020) "Copyright (c) 2018-2020" +-- "Copyright (c) 2018-2020" +-- +-- >>> updateYears (CurrentYear 2020) "Copyright (c) 2018-2019" +-- "Copyright (c) 2018-2020" +updateYears :: CurrentYear + -- ^ current year + -> Text + -- ^ text to update + -> Text + -- ^ text with updated years +updateYears (CurrentYear year) = processYear . processRange + where + processYear = replace [re|(?!\d{4}-)(? Regex -- ^ compiled regular expression -compile' regex = compile (encodeUtf8 regex) [utf8] - - --- | Joins list of patterns into single regex string. If the input list is --- empty, 'Nothing' is returned. --- --- >>> joinPatterns ["^foo", "^bar"] --- Just "^foo|^bar" -joinPatterns :: [Text] -- ^ list of patterns to join - -> Maybe Text -- ^ joined patterns -joinPatterns [] = Nothing -joinPatterns ps = Just $ T.intercalate "|" ps - - --- | Same as 'match', but works with 'Text' and uses no additional options. -match' :: Regex -- ^ a PCRE regular expression value produced by compile - -> Text -- ^ the subject text to match against - -> Maybe [Text] -- ^ the result value -match' regex subject = fmap T.pack <$> match regex (T.unpack subject) [] diff --git a/src/Headroom/Serialization.hs b/src/Headroom/Serialization.hs --- a/src/Headroom/Serialization.hs +++ b/src/Headroom/Serialization.hs @@ -60,9 +60,12 @@ -- -- >>> symbolCase '-' "fooBar" -- "foo-bar" -symbolCase :: Char -- ^ word separator symbol - -> String -- ^ input text - -> String -- ^ processed text +symbolCase :: Char + -- ^ word separator symbol + -> String + -- ^ input text + -> String + -- ^ processed text symbolCase sym = \case [] -> [] (x : xs) | C.isUpper x -> sym : C.toLower x : symbolCase sym xs @@ -71,7 +74,9 @@ -- | Pretty prints given data as /YAML/. prettyPrintYAML :: ToJSON a - => a -- ^ data to pretty print - -> Text -- ^ pretty printed /YAML/ output + => a + -- ^ data to pretty print + -> Text + -- ^ pretty printed /YAML/ output prettyPrintYAML = decodeUtf8Lenient . YP.encodePretty prettyConfig where prettyConfig = YP.setConfCompare compare YP.defConfig diff --git a/src/Headroom/Template.hs b/src/Headroom/Template.hs --- a/src/Headroom/Template.hs +++ b/src/Headroom/Template.hs @@ -1,5 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-| Module : Headroom.Template @@ -14,27 +16,77 @@ the 'Template' /type class/. -} -module Headroom.Template where +module Headroom.Template + ( Template(..) + , TemplateError(..) + ) +where +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +import Headroom.Variables.Types ( Variables(..) ) import RIO +import qualified RIO.Text as T + -- | Type class representing generic license header template support. class Template t where -- | Returns list of supported file extensions for this template type. - templateExtensions :: NonEmpty Text -- ^ list of supported file extensions + templateExtensions :: NonEmpty Text + -- ^ list of supported file extensions -- | Parses template from given raw text. parseTemplate :: MonadThrow m - => Maybe Text -- ^ name of the template (optional) - -> Text -- ^ raw template text - -> m t -- ^ parsed template + => Maybe Text + -- ^ name of the template (optional) + -> Text + -- ^ raw template text + -> m t + -- ^ parsed template -- | Renders parsed template and replaces all variables with actual values. renderTemplate :: MonadThrow m - => HashMap Text Text -- ^ values of variables to replace - -> t -- ^ parsed template to render - -> m Text -- ^ rendered template text + => Variables + -- ^ values of variables to replace + -> t + -- ^ parsed template to render + -> m Text + -- ^ rendered template text + + + -- | Returns the raw text of the template, same that has been parsed by + -- 'parseTemplate' method. + rawTemplate :: t + -- ^ template for which to return raw template text + -> Text + -- ^ raw template text + + +--------------------------------- Error Types -------------------------------- + +-- | Error during processing template. +data TemplateError + = MissingVariables !Text ![Text] + -- ^ missing variable values + | ParseError !Text + -- ^ error parsing raw template text + deriving (Eq, Show, Typeable) + +instance Exception TemplateError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + +displayException' :: TemplateError -> String +displayException' = T.unpack . \case + MissingVariables name variables -> missingVariables name variables + ParseError msg -> parseError msg + where + missingVariables name variables = + mconcat ["Missing variables for '", name, "': ", T.pack $ show variables] + parseError msg = "Error parsing template: " <> msg diff --git a/src/Headroom/Template/Mustache.hs b/src/Headroom/Template/Mustache.hs --- a/src/Headroom/Template/Mustache.hs +++ b/src/Headroom/Template/Mustache.hs @@ -19,10 +19,10 @@ ) where -import Headroom.Template ( Template(..) ) -import Headroom.Types ( ApplicationError(..) +import Headroom.Template ( Template(..) , TemplateError(..) ) +import Headroom.Variables.Types ( Variables(..) ) import RIO import qualified RIO.Text as T import qualified Text.Mustache as MU @@ -30,7 +30,8 @@ -- | The /Mustache/ template. -newtype Mustache = Mustache MU.Template deriving (Show) +data Mustache = Mustache MU.Template Text + deriving Show -- | Support for /Mustache/ templates. @@ -38,27 +39,30 @@ templateExtensions = "mustache" :| [] parseTemplate = parseTemplate' renderTemplate = renderTemplate' + rawTemplate = rawTemplate' parseTemplate' :: MonadThrow m => Maybe Text -> Text -> m Mustache parseTemplate' name raw = case MU.compileTemplate templateName raw of - Left err -> throwM $ TemplateError (ParseError (T.pack . show $ err)) - Right res -> pure $ Mustache res + Left err -> throwM . ParseError $ tshow err + Right res -> pure $ Mustache res raw where templateName = T.unpack . fromMaybe "" $ name -renderTemplate' :: MonadThrow m => HashMap Text Text -> Mustache -> m Text -renderTemplate' variables (Mustache t@(MU.Template name _ _)) = +renderTemplate' :: MonadThrow m => Variables -> Mustache -> m Text +renderTemplate' (Variables variables) (Mustache t@(MU.Template name _ _) _) = case MU.checkedSubstitute t variables of ([], rendered) -> pure rendered (errs, rendered) -> - let errs' = missingVariables errs + let errs' = missingVariables errs + missingVariables = concatMap $ \case + (VariableNotFound ps) -> ps + _ -> [] in if length errs == length errs' - then throwM $ TemplateError (MissingVariables (T.pack name) errs') + then throwM $ MissingVariables (T.pack name) errs' else pure rendered - where - missingVariables = concatMap - (\case - (VariableNotFound ps) -> ps - _ -> [] - ) + + +rawTemplate' :: Mustache -> Text +rawTemplate' (Mustache _ raw) = raw + diff --git a/src/Headroom/Types.hs b/src/Headroom/Types.hs --- a/src/Headroom/Types.hs +++ b/src/Headroom/Types.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-| Module : Headroom.Types @@ -18,460 +15,72 @@ -} module Headroom.Types - ( - -- * Configuration Data Types - -- ** Total Configuration - Configuration(..) - , HeaderConfig(..) - , HeadersConfig(..) - -- ** Partial Configuration - , PartialConfiguration(..) - , PartialHeaderConfig(..) - , PartialHeadersConfig(..) - -- ** Other Configuration Data Types - , HeaderSyntax(..) - -- * Command Data Types - , Command(..) - , CommandGenOptions(..) - , CommandInitOptions(..) - , CommandRunOptions(..) - , ConfigurationError(..) - , RunAction(..) - , RunMode(..) - , GenMode(..) - -- * Error Data Types - , ApplicationError(..) - , CommandGenError(..) - , CommandInitError(..) - , TemplateError(..) + ( -- * Error Data Types + HeadroomError(..) + -- ** Helper Functions + , fromHeadroomError + , toHeadroomError -- * Other Data Types - , LicenseType(..) - , FileType(..) - , FileInfo(..) + , TemplateMeta(..) + , HaddockFieldOffsets(..) + , CurrentYear(..) ) where -import Control.Exception ( throw ) -import Data.Aeson ( FromJSON(..) - , Value(String) - , genericParseJSON - , withObject - , (.!=) - , (.:?) - ) -import Data.Monoid ( Last(..) ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.Serialization ( aesonOptions ) +import Data.Default.Class ( Default(..) ) +import Data.Typeable ( cast ) import RIO -import qualified RIO.Text as T --- | Action to be performed based on the selected 'RunMode'. -data RunAction = RunAction - { raProcessed :: !Bool -- ^ whether the given file was processed - , raFunc :: !(Text -> Text) -- ^ function to process the file - , raProcessedMsg :: !Text -- ^ message to show when file was processed - , raSkippedMsg :: !Text -- ^ message to show when file was skipped - } +-- | Top-level of the /Headroom/ exception hierarchy. +data HeadroomError = forall e . Exception e => HeadroomError e --- | Represents what action should the @run@ command perform. -data RunMode - = Add -- ^ /add mode/ for @run@ command - | Check -- ^ /check mode/ for @run@ command - | Drop -- ^ /drop mode/ for @run@ command - | Replace -- ^ /replace mode/ for @run@ command - deriving (Eq, Show) +instance Show HeadroomError where + show (HeadroomError he) = show he -instance FromJSON RunMode where - parseJSON = \case - String s -> case T.toLower s of - "add" -> pure Add - "check" -> pure Check - "drop" -> pure Drop - "replace" -> pure Replace - _ -> error $ "Unknown run mode: " <> T.unpack s - other -> error $ "Invalid value for run mode: " <> show other +instance Exception HeadroomError where + displayException (HeadroomError he) = displayException he --- | Represents what action should the @gen@ command perform. -data GenMode - = GenConfigFile -- ^ generate /YAML/ config file stub - | GenLicense !(LicenseType, FileType) -- ^ generate license header template - deriving (Eq, Show) --- | Represents error that can occur during the application execution. -data ApplicationError - = CommandGenError !CommandGenError -- ^ error specific for the @gen@ command - | CommandInitError !CommandInitError -- ^ error specific for the @init@ command - | ConfigurationError !ConfigurationError -- ^ error processing configuration - | TemplateError !TemplateError -- ^ error processing template - deriving (Eq, Show) +-- | Wraps given exception into 'HeadroomError'. +toHeadroomError :: Exception e + => e + -- ^ exception to wrap + -> SomeException + -- ^ wrapped exception +toHeadroomError = toException . HeadroomError -instance Exception ApplicationError where - displayException = T.unpack . \case - CommandGenError error' -> commandGenError error' - CommandInitError error' -> commandInitError error' - ConfigurationError error' -> configurationError error' - TemplateError error' -> templateError error' --- | Error specific for the @gen@ command. -data CommandGenError = NoGenModeSelected -- ^ no mode of /Gen/ command selected - deriving (Eq, Show) +-- | Unwraps given exception from 'HeadroomError'. +fromHeadroomError :: Exception e + => SomeException + -- ^ exception to unwrap + -> Maybe e + -- ^ unwrapped exception +fromHeadroomError e = do + HeadroomError he <- fromException e + cast he --- | Error specific for the @init@ command. -data CommandInitError - = AppConfigAlreadyExists !FilePath -- ^ application configuration file already exists - | NoProvidedSourcePaths -- ^ no paths to source code files provided - | NoSupportedFileType -- ^ no supported file types found on source paths - deriving (Eq, Show) --- | Error during processing configuration. -data ConfigurationError - = InvalidVariable !Text -- ^ invalid variable input (as @key=value@) - | MixedHeaderSyntax -- ^ illegal configuration for 'HeaderSyntax' - | NoFileExtensions !FileType -- ^ no configuration for @file-extensions@ - | NoHeaderSyntax !FileType -- ^ no configuration for header syntax - | NoMarginAfter !FileType -- ^ no configuration for @margin-after@ - | NoMarginBefore !FileType -- ^ no configuration for @margin-before@ - | NoPutAfter !FileType -- ^ no configuration for @put-after@ - | NoPutBefore !FileType -- ^ no configuration for @put-before@ - | NoRunMode -- ^ no configuration for @run-mode@ - | NoSourcePaths -- ^ no configuration for @source-paths@ - | NoExcludedPaths -- ^ no configuration for @excluded-paths@ - | NoTemplatePaths -- ^ no configuration for @template-paths@ - | NoVariables -- ^ no configuration for @variables@ - deriving (Eq, Show) - --- | Error during processing template. -data TemplateError - = MissingVariables !Text ![Text] -- ^ missing variable values - | ParseError !Text -- ^ error parsing raw template text - deriving (Eq, Show) - --------------------------------------------------------------------------------- - --- | Application command. -data Command - = Run [FilePath] [Text] [FilePath] [Text] (Maybe RunMode) Bool Bool -- ^ @run@ command - | Gen Bool (Maybe (LicenseType, FileType)) -- ^ @gen@ command - | Init LicenseType [FilePath] -- ^ @init@ command - deriving (Show) - --------------------------------------------------------------------------------- - --- | Options for the @gen@ command. -newtype CommandGenOptions = CommandGenOptions - { cgoGenMode :: GenMode -- ^ selected mode - } - deriving (Show) - --- | Options for the @init@ command. -data CommandInitOptions = CommandInitOptions - { cioSourcePaths :: ![FilePath] -- ^ paths to source code files - , cioLicenseType :: !LicenseType -- ^ license type - } - deriving Show - --- | Options for the @run@ command. -data CommandRunOptions = CommandRunOptions - { croRunMode :: !(Maybe RunMode) -- ^ used /Run/ command mode - , croSourcePaths :: ![FilePath] -- ^ source code file paths - , croExcludedPaths :: ![Text] -- ^ source paths to exclude - , croTemplatePaths :: ![FilePath] -- ^ template file paths - , croVariables :: ![Text] -- ^ raw variables - , croDebug :: !Bool -- ^ whether to run in debug mode - , croDryRun :: !Bool -- ^ whether to perform dry run +-- | Wraps the value of current year. +newtype CurrentYear = CurrentYear + { unCurrentYear :: Integer + -- ^ value of current year } deriving (Eq, Show) --------------------------------------------------------------------------------- --- | Supported type of source code file. -data FileType - = C -- ^ support for /C/ programming language - | CPP -- ^ support for /C++/ programming language - | CSS -- ^ support for /CSS/ - | Haskell -- ^ support for /Haskell/ programming language - | HTML -- ^ support for /HTML/ - | Java -- ^ support for /Java/ programming language - | JS -- ^ support for /JavaScript/ programming language - | Rust -- ^ support for /Rust/ programming language - | Scala -- ^ support for /Scala/ programming language - | Shell -- ^ support for /Shell/ - deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) - --------------------------------------------------------------------------------- - --- | Supported type of open source license. -data LicenseType - = Apache2 -- ^ support for /Apache-2.0/ license - | BSD3 -- ^ support for /BSD-3-Clause/ license - | GPL2 -- ^ support for /GNU GPL2/ license - | GPL3 -- ^ support for /GNU GPL3/ license - | MIT -- ^ support for /MIT/ license - | MPL2 -- ^ support for /MPL2/ license - deriving (Bounded, Enum, EnumExtra, Eq, Ord, Show) - --------------------------------------------------------------------------------- - --- | Info extracted about the concrete source code file. -data FileInfo = FileInfo - { fiFileType :: !FileType -- ^ type of the file - , fiHeaderConfig :: !HeaderConfig -- ^ configuration for license header - , fiHeaderPos :: !(Maybe (Int, Int)) -- ^ position of existing license header - , fiVariables :: !(HashMap Text Text) -- ^ additional extracted variables - } - deriving (Eq, Show) - --------------------------------------------------------------------------------- - --- | Syntax of the license header comment. -data HeaderSyntax - = BlockComment !Text !Text -- ^ block (multi-line) comment syntax (e.g. @/* */@) - | LineComment !Text -- ^ single line comment syntax (e.g. @//@) - deriving (Eq, Show) - --- | Application configuration. -data Configuration = Configuration - { cRunMode :: !RunMode -- ^ mode of the @run@ command - , cSourcePaths :: ![FilePath] -- ^ paths to source code files - , cExcludedPaths :: ![Text] -- ^ excluded source paths - , cTemplatePaths :: ![FilePath] -- ^ paths to template files - , cVariables :: !(HashMap Text Text) -- ^ variable values for templates - , cLicenseHeaders :: !HeadersConfig -- ^ configuration of license headers +-- | Offsets for selected fields extracted from /Haddock module header/. +data HaddockFieldOffsets = HaddockFieldOffsets + { hfoCopyright :: !(Maybe Int) + -- ^ offset for /Copyright/ field } deriving (Eq, Show) --- | Configuration for specific license header. -data HeaderConfig = HeaderConfig - { hcFileExtensions :: ![Text] -- ^ list of file extensions (without dot) - , hcMarginAfter :: !Int -- ^ number of empty lines to put after header - , hcMarginBefore :: !Int -- ^ number of empty lines to put before header - , hcPutAfter :: ![Text] -- ^ /regexp/ patterns after which to put the header - , hcPutBefore :: ![Text] -- ^ /regexp/ patterns before which to put the header - , hcHeaderSyntax :: !HeaderSyntax -- ^ syntax of the license header comment - } - deriving (Eq, Show) +instance Default HaddockFieldOffsets where + def = HaddockFieldOffsets { hfoCopyright = Nothing } --- | Group of 'HeaderConfig' configurations for supported file types. -data HeadersConfig = HeadersConfig - { hscC :: !HeaderConfig -- ^ configuration for /C/ programming language - , hscCpp :: !HeaderConfig -- ^ configuration for /C++/ programming language - , hscCss :: !HeaderConfig -- ^ configuration for /CSS/ - , hscHaskell :: !HeaderConfig -- ^ configuration for /Haskell/ programming language - , hscHtml :: !HeaderConfig -- ^ configuration for /HTML/ - , hscJava :: !HeaderConfig -- ^ configuration for /Java/ programming language - , hscJs :: !HeaderConfig -- ^ configuration for /JavaScript/ programming language - , hscRust :: !HeaderConfig -- ^ configuration for /Rust/ programming language - , hscScala :: !HeaderConfig -- ^ configuration for /Scala/ programming language - , hscShell :: !HeaderConfig -- ^ configuration for /Shell/ - } +-- | Metadata parsed from raw /template/, specific for selected /file type/. +data TemplateMeta = HaskellTemplateMeta !HaddockFieldOffsets deriving (Eq, Show) --------------------------------------------------------------------------------- - --- | Internal representation of block comment style of 'HeaderSyntax'. -data BlockComment' = BlockComment' - { bcStartsWith :: !Text -- ^ starting pattern (e.g. @/*@) - , bcEndsWith :: !Text -- ^ ending pattern (e.g. @*/@) - } - deriving (Eq, Generic, Show) - --- | Internal representation of the line style of 'HeaderSyntax'. -newtype LineComment' = LineComment' - { lcPrefixedBy :: Text -- ^ prefix of the comment line (e.g. @//@) - } - deriving (Eq, Generic, Show) - --- | Partial (possibly incomplete) version of 'Configuration'. -data PartialConfiguration = PartialConfiguration - { pcRunMode :: !(Last RunMode) -- ^ mode of the @run@ command - , pcSourcePaths :: !(Last [FilePath]) -- ^ paths to source code files - , pcExcludedPaths :: !(Last [Text]) -- ^ excluded source paths - , pcTemplatePaths :: !(Last [FilePath]) -- ^ paths to template files - , pcVariables :: !(Last (HashMap Text Text)) -- ^ variable values for templates - , pcLicenseHeaders :: !PartialHeadersConfig -- ^ configuration of license headers - } - deriving (Eq, Generic, Show) - --- | Partial (possibly incomplete) version of 'HeaderConfig'. -data PartialHeaderConfig = PartialHeaderConfig - { phcFileExtensions :: !(Last [Text]) -- ^ list of file extensions (without dot) - , phcMarginAfter :: !(Last Int) -- ^ number of empty lines to put after header - , phcMarginBefore :: !(Last Int) -- ^ number of empty lines to put before header - , phcPutAfter :: !(Last [Text]) -- ^ /regexp/ patterns after which to put the header - , phcPutBefore :: !(Last [Text]) -- ^ /regexp/ patterns before which to put the header - , phcHeaderSyntax :: !(Last HeaderSyntax) -- ^ syntax of the license header comment - } - deriving (Eq, Generic, Show) - --- | Partial (possibly incomplete) version of 'HeadersConfig'. -data PartialHeadersConfig = PartialHeadersConfig - { phscC :: !PartialHeaderConfig -- ^ configuration for /C/ programming language - , phscCpp :: !PartialHeaderConfig -- ^ configuration for /C++/ programming language - , phscCss :: !PartialHeaderConfig -- ^ configuration for /CSS/ - , phscHaskell :: !PartialHeaderConfig -- ^ configuration for /Haskell/ programming language - , phscHtml :: !PartialHeaderConfig -- ^ configuration for /HTML/ - , phscJava :: !PartialHeaderConfig -- ^ configuration for /Java/ programming language - , phscJs :: !PartialHeaderConfig -- ^ configuration for /JavaScript/ programming language - , phscRust :: !PartialHeaderConfig -- ^ configuration for /Rust/ programming language - , phscScala :: !PartialHeaderConfig -- ^ configuration for /Scala/ programming language - , phscShell :: !PartialHeaderConfig -- ^ configuration for /Shell/ - } - deriving (Eq, Generic, Show) - -instance FromJSON BlockComment' where - parseJSON = genericParseJSON aesonOptions - -instance FromJSON LineComment' where - parseJSON = genericParseJSON aesonOptions - -instance FromJSON PartialConfiguration where - parseJSON = withObject "PartialConfiguration" $ \obj -> do - pcRunMode <- Last <$> obj .:? "run-mode" - pcSourcePaths <- Last <$> obj .:? "source-paths" - pcExcludedPaths <- Last <$> obj .:? "excluded-paths" - pcTemplatePaths <- Last <$> obj .:? "template-paths" - pcVariables <- Last <$> obj .:? "variables" - pcLicenseHeaders <- obj .:? "license-headers" .!= mempty - pure PartialConfiguration { .. } - -instance FromJSON PartialHeaderConfig where - parseJSON = withObject "PartialHeaderConfig" $ \obj -> do - phcFileExtensions <- Last <$> obj .:? "file-extensions" - phcMarginAfter <- Last <$> obj .:? "margin-after" - phcMarginBefore <- Last <$> obj .:? "margin-before" - phcPutAfter <- Last <$> obj .:? "put-after" - phcPutBefore <- Last <$> obj .:? "put-before" - blockComment <- obj .:? "block-comment" - lineComment <- obj .:? "line-comment" - let phcHeaderSyntax = Last $ headerSyntax blockComment lineComment - pure PartialHeaderConfig { .. } - where - headerSyntax (Just (BlockComment' s e)) Nothing = Just $ BlockComment s e - headerSyntax Nothing (Just (LineComment' p)) = Just $ LineComment p - headerSyntax Nothing Nothing = Nothing - headerSyntax _ _ = throw error' - error' = ConfigurationError MixedHeaderSyntax - -instance FromJSON PartialHeadersConfig where - parseJSON = withObject "PartialHeadersConfig" $ \obj -> do - phscC <- obj .:? "c" .!= mempty - phscCpp <- obj .:? "cpp" .!= mempty - phscCss <- obj .:? "css" .!= mempty - phscHaskell <- obj .:? "haskell" .!= mempty - phscHtml <- obj .:? "html" .!= mempty - phscJava <- obj .:? "java" .!= mempty - phscJs <- obj .:? "js" .!= mempty - phscRust <- obj .:? "rust" .!= mempty - phscScala <- obj .:? "scala" .!= mempty - phscShell <- obj .:? "shell" .!= mempty - pure PartialHeadersConfig { .. } - -instance Semigroup PartialConfiguration where - x <> y = PartialConfiguration - { pcRunMode = pcRunMode x <> pcRunMode y - , pcSourcePaths = pcSourcePaths x <> pcSourcePaths y - , pcExcludedPaths = pcExcludedPaths x <> pcExcludedPaths y - , pcTemplatePaths = pcTemplatePaths x <> pcTemplatePaths y - , pcVariables = pcVariables x <> pcVariables y - , pcLicenseHeaders = pcLicenseHeaders x <> pcLicenseHeaders y - } - -instance Semigroup PartialHeaderConfig where - x <> y = PartialHeaderConfig - { phcFileExtensions = phcFileExtensions x <> phcFileExtensions y - , phcMarginAfter = phcMarginAfter x <> phcMarginAfter y - , phcMarginBefore = phcMarginBefore x <> phcMarginBefore y - , phcPutAfter = phcPutAfter x <> phcPutAfter y - , phcPutBefore = phcPutBefore x <> phcPutBefore y - , phcHeaderSyntax = phcHeaderSyntax x <> phcHeaderSyntax y - } - -instance Semigroup PartialHeadersConfig where - x <> y = PartialHeadersConfig { phscC = phscC x <> phscC y - , phscCpp = phscCpp x <> phscCpp y - , phscCss = phscCss x <> phscCss y - , phscHaskell = phscHaskell x <> phscHaskell y - , phscHtml = phscHtml x <> phscHtml y - , phscJava = phscJava x <> phscJava y - , phscJs = phscJs x <> phscJs y - , phscRust = phscRust x <> phscRust y - , phscScala = phscScala x <> phscScala y - , phscShell = phscShell x <> phscShell y - } - -instance Monoid PartialConfiguration where - mempty = PartialConfiguration mempty mempty mempty mempty mempty mempty - -instance Monoid PartialHeaderConfig where - mempty = PartialHeaderConfig mempty mempty mempty mempty mempty mempty - -instance Monoid PartialHeadersConfig where - mempty = PartialHeadersConfig mempty - mempty - mempty - mempty - mempty - mempty - mempty - mempty - mempty - mempty - --------------------------------------------------------------------------------- - -commandGenError :: CommandGenError -> Text -commandGenError = \case - NoGenModeSelected -> noGenModeSelected - where - noGenModeSelected = mconcat - [ "Please select at least one option what to generate " - , "(see --help for details)" - ] - -commandInitError :: CommandInitError -> Text -commandInitError = \case - AppConfigAlreadyExists path -> appConfigAlreadyExists path - NoProvidedSourcePaths -> noProvidedSourcePaths - NoSupportedFileType -> noSupportedFileType - where - appConfigAlreadyExists path = - mconcat ["Configuration file '", T.pack path, "' already exists"] - noProvidedSourcePaths = "No source code paths (files or directories) defined" - noSupportedFileType = "No supported file type found in scanned source paths" - -configurationError :: ConfigurationError -> Text -configurationError = \case - InvalidVariable input -> invalidVariable input - MixedHeaderSyntax -> mixedHeaderSyntax - NoFileExtensions fileType -> noProp "file-extensions" fileType - NoHeaderSyntax fileType -> noProp "block-comment/line-comment" fileType - NoMarginAfter fileType -> noProp "margin-after" fileType - NoMarginBefore fileType -> noProp "margin-before" fileType - NoPutAfter fileType -> noProp "put-after" fileType - NoPutBefore fileType -> noProp "put-before" fileType - NoRunMode -> noFlag "run-mode" - NoSourcePaths -> noFlag "source-paths" - NoExcludedPaths -> noFlag "excluded-paths" - NoTemplatePaths -> noFlag "template-paths" - NoVariables -> noFlag "variables" - where - invalidVariable = ("Cannot parse variable key=value from: " <>) - noProp prop fileType = T.pack $ mconcat - ["Missing '", prop, "' configuration key for file type", show fileType] - noFlag flag = mconcat ["Missing configuration key: ", flag] - mixedHeaderSyntax = mconcat - [ "Invalid configuration, combining 'block-comment' with 'line-comment' " - , "is not allowed. Either use 'block-comment' to define multi-line " - , "comment header, or 'line-comment' to define header composed of " - , "multiple single-line comments." - ] - -templateError :: TemplateError -> Text -templateError = \case - MissingVariables name variables -> missingVariables name variables - ParseError msg -> parseError msg - where - missingVariables name variables = mconcat - ["Missing variables for template '", name, "': ", T.pack $ show variables] - parseError msg = "Error parsing template: " <> msg diff --git a/src/Headroom/UI/Progress.hs b/src/Headroom/UI/Progress.hs --- a/src/Headroom/UI/Progress.hs +++ b/src/Headroom/UI/Progress.hs @@ -43,8 +43,10 @@ -- -- >>> zipWithProgress ["a", "b"] -- [(Progress 1 2,"a"),(Progress 2 2,"b")] -zipWithProgress :: [a] -- ^ list to zip with progress - -> [(Progress, a)] -- ^ zipped result +zipWithProgress :: [a] + -- ^ list to zip with progress + -> [(Progress, a)] + -- ^ zipped result zipWithProgress list = zip progresses list where listLength = L.length list diff --git a/src/Headroom/Variables.hs b/src/Headroom/Variables.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Variables.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module : Headroom.Variables +Description : Support for template variables +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Module containing costructor and useful functions for the 'Variables' data type. +-} + +module Headroom.Variables + ( -- * Constructing Variables + mkVariables + , dynamicVariables + -- * Parsing Variables + , parseVariables + -- * Processing Variables + , compileVariables + ) +where + +import Headroom.Meta ( TemplateType ) +import Headroom.Template ( Template(..) ) +import Headroom.Types ( CurrentYear(..) + , fromHeadroomError + , toHeadroomError + ) +import Headroom.Variables.Types ( Variables(..) ) +import RIO +import qualified RIO.HashMap as HM +import qualified RIO.Text as T + + +-- | Constructor function for 'Variables' data type. +-- +-- >>> mkVariables [("key1", "value1")] +-- Variables (fromList [("key1","value1")]) +mkVariables :: [(Text, Text)] + -- ^ pairs of /key-value/ + -> Variables + -- ^ constructed variables +mkVariables = Variables . HM.fromList + + +-- | /Dynamic variables/ that are common for all parsed files. +-- +-- * @___current_year__@ - current year +dynamicVariables :: CurrentYear + -- ^ current year + -> Variables + -- ^ map of /dynamic variables/ +dynamicVariables (CurrentYear year) = + mkVariables [("_current_year", tshow year)] + + +-- | Parses variables from raw input in @key=value@ format. +-- +-- >>> parseVariables ["key1=value1"] +-- Variables (fromList [("key1","value1")]) +parseVariables :: MonadThrow m + => [Text] + -- ^ list of raw variables + -> m Variables + -- ^ parsed variables +parseVariables variables = fmap mkVariables (mapM parse variables) + where + parse input = case T.split (== '=') input of + [key, value] -> pure (key, value) + _ -> throwM $ InvalidVariable input + + +-- | Compiles variable values that are itself mini-templates, where their +-- variables will be substituted by other variable values (if possible). +-- Note that recursive variable reference and/or cyclic references are not +-- supported. +-- +-- >>> compileVariables $ mkVariables [("name", "John"), ("msg", "Hello, {{ name }}")] +-- Variables (fromList [("msg","Hello, John"),("name","John")]) +compileVariables :: (MonadThrow m) + => Variables + -- ^ input variables to compile + -> m Variables + -- ^ compiled variables +compileVariables variables@(Variables kvs) = do + compiled <- mapM compileVariable (HM.toList kvs) + pure $ mkVariables compiled + where + compileVariable (key, value) = do + parsed <- parseTemplate @TemplateType (Just $ "variable " <> key) value + rendered <- renderTemplate variables parsed + pure (key, rendered) + + +--------------------------------- Error Types -------------------------------- + +-- | Exception specific to the "Headroom.Variables" module. +data VariablesError = InvalidVariable !Text + -- ^ invalid variable input (as @key=value@) + deriving (Eq, Show) + + +instance Exception VariablesError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + + +displayException' :: VariablesError -> String +displayException' = T.unpack . \case + InvalidVariable raw -> ("Cannot parse variable key=value from: " <> raw) diff --git a/src/Headroom/Variables/Types.hs b/src/Headroom/Variables/Types.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Variables/Types.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Headroom.Variables.Types +Description : Data types for "Headroom.Variables" +Copyright : (c) 2019-2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types for "Headroom.Variables" module. +-} + +module Headroom.Variables.Types + ( Variables(..) + ) +where + +import RIO + +-- | Map of /static/ and /dynamic variables/. Use 'Headroom.Variables.mkVariables' function for +-- more convenient construction of this data type. +newtype Variables = Variables (HashMap Text Text) deriving (Eq, Show) + +instance Semigroup Variables where + (Variables x) <> (Variables y) = Variables (y <> x) + +instance Monoid Variables where + mempty = Variables mempty diff --git a/test-data/code-samples/haskell/full.hs b/test-data/code-samples/haskell/full.hs --- a/test-data/code-samples/haskell/full.hs +++ b/test-data/code-samples/haskell/full.hs @@ -1,6 +1,6 @@ {-| -Module : W +Module : Test Description : Short description Copyright : (c) Some Guy, 2013 Someone Else, 2014 @@ -9,8 +9,8 @@ Stability : experimental Portability : POSIX -Here is a longer description of this module, containing some -commentary with @some markup@. +long +description -} {-# LANGUAGE OverloadedStrings #-} diff --git a/test-data/code-samples/haskell/header.hs b/test-data/code-samples/haskell/header.hs new file mode 100644 --- /dev/null +++ b/test-data/code-samples/haskell/header.hs @@ -0,0 +1,13 @@ +{-| +Module : Test +Description : Short description +Copyright : (c) Some Guy, 2013 + Someone Else, 2014 +License : GPL-3 +Maintainer : sample@email.com +Stability : experimental +Portability : POSIX + +Here is a longer description of this module, containing some +commentary with @some markup@. +-} diff --git a/test-data/templates/haskell.mustache b/test-data/templates/haskell.mustache new file mode 100644 --- /dev/null +++ b/test-data/templates/haskell.mustache @@ -0,0 +1,1 @@ +Hello, {{ name }} diff --git a/test/Headroom/Command/InitSpec.hs b/test/Headroom/Command/InitSpec.hs --- a/test/Headroom/Command/InitSpec.hs +++ b/test/Headroom/Command/InitSpec.hs @@ -5,10 +5,9 @@ where import Headroom.Command.Init -import Headroom.Types ( CommandInitOptions(..) - , FileType(HTML) - , LicenseType(..) - ) +import Headroom.Command.Types ( CommandInitOptions(..) ) +import Headroom.Configuration.Types ( LicenseType(..) ) +import Headroom.FileType.Types ( FileType(..) ) import RIO import RIO.FilePath ( () ) import qualified RIO.List as L diff --git a/test/Headroom/Command/ReadersSpec.hs b/test/Headroom/Command/ReadersSpec.hs --- a/test/Headroom/Command/ReadersSpec.hs +++ b/test/Headroom/Command/ReadersSpec.hs @@ -8,10 +8,9 @@ where import Headroom.Command.Readers +import Headroom.Configuration.Types ( LicenseType ) import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.Types ( FileType - , LicenseType - ) +import Headroom.FileType.Types ( FileType ) import RIO import qualified RIO.Text as T import Test.Hspec diff --git a/test/Headroom/Command/RunSpec.hs b/test/Headroom/Command/RunSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Command/RunSpec.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Headroom.Command.RunSpec + ( spec + ) +where + +import Headroom.Command.Run +import Headroom.Configuration.Types ( CtHeaderFnConfigs + , HeaderFnConfig(..) + , HeaderFnConfigs(..) + , HeaderSyntax(..) + , LicenseType(..) + , UpdateCopyrightConfig(..) + ) +import Headroom.Data.EnumExtra ( EnumExtra(..) ) +import Headroom.Data.Has ( Has(..) ) +import Headroom.Data.Lens ( suffixLenses ) +import Headroom.Data.TextExtra ( fromLines ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Meta ( TemplateType ) +import Headroom.Template ( Template(..) ) +import Headroom.Types ( CurrentYear(..) ) +import Headroom.Variables ( mkVariables ) +import RIO hiding ( assert ) +import RIO.FilePath ( () ) +import qualified RIO.Map as M +import qualified RIO.NonEmpty as NE +import qualified RIO.Text as T +import Test.Hspec +import Test.Hspec.QuickCheck ( prop ) +import Test.QuickCheck hiding ( sample ) +import Test.QuickCheck.Monadic + + +spec :: Spec +spec = do + describe "loadBuiltInTemplates" $ do + it "should load correct number of built-in templates" $ do + templates <- runRIO env $ loadBuiltInTemplates BSD3 + M.size templates `shouldBe` 10 + + + describe "loadTemplateFiles" $ do + it "should load templates from given paths" $ do + templates <- runRIO env $ loadTemplateFiles ["test-data" "templates"] + M.size templates `shouldBe` 1 + M.member Haskell templates `shouldBe` True + + + describe "typeOfTemplate" $ do + let fileTypes = fmap (T.toLower . enumToText) (allValues @FileType) + templateExt = NE.head $ templateExtensions @TemplateType + pathGen = elements $ fmap (<> "." <> templateExt) fileTypes + prop_typeOfTemplate = monadicIO $ do + path <- T.unpack <$> pick pathGen + result <- run (runRIO env $ typeOfTemplate path) + assert $ isJust result + + prop "should detect type of template from template path" prop_typeOfTemplate + + + describe "postProcessHeader'" $ do + it "should perform expected post-processing on license header" $ do + let sample = fromLines + [ "-- Copyright (c) 2018-2019 1st Author" + , "Copyright (c) 2017 2nd Author" + ] + expected = fromLines + [ "-- Copyright (c) 2018-2019 1st Author" + , "-- Copyright (c) 2017-2020 2nd Author" + ] + vars = mkVariables [("sndAuthor", "2nd Author")] + syntax = LineComment "--" + actual <- runRIO env $ postProcessHeader' syntax vars sample + actual `shouldBe` expected + + describe "sanitizeHeader" $ do + it "does nothing when block comment syntax used" $ do + let sample = fromLines ["{-", "foo", "bar", "-}"] + syntax = BlockComment "{-" "-}" + sanitizeHeader syntax sample `shouldBe` sample + + it "adds missing single-line comment syntax" $ do + let sample = fromLines ["-- first", "second", "-- third"] + syntax = LineComment "--" + expected = fromLines ["-- first", "-- second", "-- third"] + sanitizeHeader syntax sample `shouldBe` expected + + +env :: TestEnv +env = TestEnv { .. } + where + envLogFunc = mkLogFunc (\_ _ _ _ -> pure ()) + envCurrentYear = CurrentYear 2020 + envHeaderFnConfigs = HeaderFnConfigs + { hfcsUpdateCopyright = HeaderFnConfig + { hfcEnabled = True + , hfcConfig = UpdateCopyrightConfig + { uccSelectedAuthors = + Just $ "{{ sndAuthor }}" :| [] + } + } + } + +data TestEnv = TestEnv + { envLogFunc :: !LogFunc + , envHeaderFnConfigs :: !CtHeaderFnConfigs + , envCurrentYear :: !CurrentYear + } +suffixLenses ''TestEnv + +instance HasLogFunc TestEnv where + logFuncL = envLogFuncL + +instance Has CtHeaderFnConfigs TestEnv where + hasLens = envHeaderFnConfigsL + +instance Has CurrentYear TestEnv where + hasLens = envCurrentYearL diff --git a/test/Headroom/Data/RegexSpec.hs b/test/Headroom/Data/RegexSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Data/RegexSpec.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Headroom.Data.RegexSpec + ( spec + ) +where + +import Headroom.Data.Regex +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + describe "match" $ do + it "matches regular expression against given sample" $ do + let regex = [re|foo|bar|] + match regex "xxx" `shouldSatisfy` isNothing + match regex "foz" `shouldSatisfy` isNothing + match regex "foosdas" `shouldSatisfy` isJust + match regex "barfoo" `shouldSatisfy` isJust diff --git a/test/Headroom/Data/TextExtraSpec.hs b/test/Headroom/Data/TextExtraSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Data/TextExtraSpec.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module Headroom.Data.TextExtraSpec + ( spec + ) +where + +import Headroom.Data.TextExtra +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + describe "mapLines" $ do + it "should return same output for identity function" $ do + let sample = fromLines ["foo zz", "bar", "xx"] + mapLines id sample `shouldBe` sample + + it "should map all lines using the function" $ do + let sample = fromLines ["foo zz", "bar", "xx"] + fn = ("L: " <>) + expected = fromLines ["L: foo zz", "L: bar", "L: xx"] + mapLines fn sample `shouldBe` expected + + + describe "read" $ do + it "parses value from given text using Read instance" $ do + read @Int "123" `shouldBe` Just 123 + + + describe "fromLines" $ do + it "handles correctly empty linex" $ do + fromLines [] `shouldBe` "" + + it "handles correctly single line text" $ do + fromLines ["foo"] `shouldBe` "foo" + + it "joins lines of text" $ do + fromLines ["first", "second"] `shouldBe` "first\nsecond" + fromLines ["first", "second", ""] `shouldBe` "first\nsecond\n" + + + describe "toLines" $ do + it "handles correctly empty text" $ do + toLines "" `shouldBe` [] + + it "splits lines of text to list" $ do + toLines "first\nsecond" `shouldBe` ["first", "second"] + toLines "first\nsecond\n" `shouldBe` ["first", "second", ""] + + + describe "toLines . fromLines" $ do + it "does not alter newlines in processed text" $ do + (fromLines . toLines $ "first\nsecond") `shouldBe` "first\nsecond" + (fromLines . toLines $ "first\nsecond\n") `shouldBe` "first\nsecond\n" diff --git a/test/Headroom/Ext/Haskell/HaddockSpec.hs b/test/Headroom/Ext/Haskell/HaddockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Ext/Haskell/HaddockSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module Headroom.Ext.Haskell.HaddockSpec + ( spec + ) +where + +import Headroom.Configuration.Types ( LicenseType(..) ) +import Headroom.Data.TextExtra ( fromLines ) +import Headroom.Embedded ( licenseTemplate ) +import Headroom.Ext.Haskell.Haddock +import Headroom.FileSystem ( loadFile ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Template ( Template(..) ) +import Headroom.Template.Mustache ( Mustache(..) ) +import Headroom.Types ( HaddockFieldOffsets(..) ) +import RIO +import RIO.FilePath ( () ) +import Test.Hspec + + +spec :: Spec +spec = do + let codeSamples = "test-data" "code-samples" + + describe "extractFieldOffsets" $ do + it "extract offsets for selected fields of module header" $ do + template <- parseTemplate @Mustache Nothing $ licenseTemplate BSD3 Haskell + let expected = HaddockFieldOffsets { hfoCopyright = Just 14 } + extractFieldOffsets template `shouldBe` expected + + describe "extractModuleHeader" $ do + it "extracts fields from Haddock module header" $ do + let + expected = HaddockModuleHeader + { hmhCopyright = Just + "(c) Some Guy, 2013\n Someone Else, 2014" + , hmhLicense = Just "GPL-3" + , hmhMaintainer = Just "sample@email.com" + , hmhPortability = Just "POSIX" + , hmhStability = Just "experimental" + , hmhShortDesc = Just "Short description" + , hmhLongDesc = + Just + "Here is a longer description of this module, containing some\n\ + \commentary with @some markup@." + } + sample <- loadFile $ codeSamples "haskell" "header.hs" + extractModuleHeader sample Nothing `shouldBe` expected + + + describe "stripCommentSyntax" $ do + it "strips single-line or block comment syntax from input" $ do + let sample1 = fromLines ["{-|", "Hello1", "foo", "-}"] + sample2 = fromLines ["{- |", "Hello2", "foo", "-}"] + sample3 = fromLines ["-- | Hello3", "-- foo"] + stripCommentSyntax sample1 `shouldBe` fromLines ["", "Hello1", "foo", ""] + stripCommentSyntax sample2 `shouldBe` fromLines ["", "Hello2", "foo", ""] + stripCommentSyntax sample3 `shouldBe` fromLines [" Hello3", " foo"] + + + describe "indentField" $ do + it "does nothing with single line text" $ do + let sample = fromLines ["hello"] + offset = Just 2 + indentField offset sample `shouldBe` sample + + it "indents all but first line using given offset" $ do + let sample = fromLines ["first", "second", "third"] + expected = fromLines ["first", " second", " third"] + offset = Just 2 + indentField offset sample `shouldBe` expected + + it "intents correctly previously indented text" $ do + let sample = fromLines ["first", "second", " third"] + expected = fromLines ["first", " second", " third"] + offset = Just 2 + indentField offset sample `shouldBe` expected + + diff --git a/test/Headroom/Ext/HaskellSpec.hs b/test/Headroom/Ext/HaskellSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Ext/HaskellSpec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Headroom.Ext.HaskellSpec + ( spec + ) +where + +import Headroom.Configuration.Types ( HeaderConfig(..) + , HeaderSyntax(..) + ) +import Headroom.Ext.Haskell +import Headroom.FileSystem ( loadFile ) +import Headroom.Variables ( mkVariables ) +import RIO +import RIO.FilePath ( () ) +import Test.Hspec + + +spec :: Spec +spec = do + let codeSamples = "test-data" "code-samples" + + describe "extractModuleName" $ do + it "extracts module name from Haskell file content" $ do + sample1 <- loadFile $ codeSamples "haskell" "full.hs" + sample2 <- loadFile $ codeSamples "html" "sample2.html" + extractModuleName sample1 `shouldBe` Just "Test" + extractModuleName sample2 `shouldBe` Nothing + + + describe "extractVariables" $ do + it "extracts variables from Haskell source code with Haddock header" $ do + let config = HeaderConfig ["hs"] 0 0 [] [] (BlockComment "{-|" "-}") + meta = Nothing + headerPos = Just (1, 13) + expected = mkVariables + [ ( "_haskell_module_copyright" + , "(c) Some Guy, 2013\n Someone Else, 2014" + ) + , ("_haskell_module_license" , "GPL-3") + , ("_haskell_module_maintainer" , "sample@email.com") + , ("_haskell_module_name" , "Test") + , ("_haskell_module_stability" , "experimental") + , ("_haskell_module_portability", "POSIX") + , ("_haskell_module_longdesc" , "long\ndescription") + , ("_haskell_module_shortdesc" , "Short description") + ] + sample <- loadFile $ codeSamples "haskell" "full.hs" + extractVariables config meta headerPos sample `shouldBe` expected + + it "extracts variables from Haskell source code without Haddock header" $ do + let config = HeaderConfig ["hs"] 0 0 [] [] (BlockComment "{-|" "-}") + meta = Nothing + headerPos = Nothing + expected = mkVariables [("_haskell_module_name", "Test")] + sample <- loadFile $ codeSamples "haskell" "full.hs" + extractVariables config meta headerPos sample `shouldBe` expected + diff --git a/test/Headroom/ExtSpec.hs b/test/Headroom/ExtSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/ExtSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Headroom.ExtSpec + ( spec + ) +where + +import Headroom.Configuration.Types ( HeaderConfig(..) + , HeaderSyntax(..) + ) +import Headroom.Ext +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Variables ( mkVariables ) +import RIO +import RIO.FilePath ( () ) +import Test.Hspec + + +spec :: Spec +spec = do + describe "extractVariables" $ do + it "extracts variables specific for Haskell file type" $ do + let samplesDir = "test-data" "code-samples" + config = HeaderConfig ["hs"] 0 0 [] [] (LineComment "--") + meta = Nothing + expected = mkVariables + [ ( "_haskell_module_copyright" + , "(c) Some Guy, 2013\n Someone Else, 2014" + ) + , ("_haskell_module_license" , "GPL-3") + , ("_haskell_module_maintainer" , "sample@email.com") + , ("_haskell_module_name" , "Test") + , ("_haskell_module_stability" , "experimental") + , ("_haskell_module_portability", "POSIX") + , ("_haskell_module_longdesc" , "long\ndescription") + , ("_haskell_module_shortdesc" , "Short description") + ] + sample <- readFileUtf8 $ samplesDir "haskell" "full.hs" + extractVariables Haskell config meta (Just (1, 13)) sample + `shouldBe` expected diff --git a/test/Headroom/FileSupportSpec.hs b/test/Headroom/FileSupportSpec.hs --- a/test/Headroom/FileSupportSpec.hs +++ b/test/Headroom/FileSupportSpec.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Headroom.FileSupportSpec ( spec ) @@ -9,22 +12,21 @@ import Headroom.Configuration ( makeHeadersConfig , parseConfiguration ) -import Headroom.Embedded ( defaultConfig ) -import Headroom.FileSupport -import Headroom.FileSystem ( loadFile ) -import Headroom.Types ( FileInfo(..) - , FileType(..) +import Headroom.Configuration.Types ( Configuration(..) , HeaderConfig(..) , HeaderSyntax(..) , HeadersConfig(..) - , PartialConfiguration(..) ) +import Headroom.Data.Regex ( re ) +import Headroom.Embedded ( defaultConfig ) +import Headroom.FileSupport +import Headroom.FileSupport.Types ( FileInfo(..) ) +import Headroom.FileSystem ( loadFile ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Variables ( mkVariables ) import RIO import RIO.FilePath ( () ) -import qualified RIO.HashMap as HM import Test.Hspec -import Text.Regex.PCRE.Light ( compile ) -import Text.Regex.PCRE.Light.Char8 ( utf8 ) spec :: Spec @@ -36,7 +38,7 @@ HeaderConfig ["hs"] mb ma pb pa (BlockComment "{-|" "-}") describe "addHeader" $ do - let fileInfo config = FileInfo Haskell config Nothing HM.empty + let fileInfo config = FileInfo Haskell config Nothing mempty it "adds header at the beginning of text" $ do let info = fileInfo $ bHeaderConfig [] [] @@ -53,30 +55,30 @@ addHeader info header sample `shouldBe` expected it "adds header at correct position" $ do - let info = fileInfo $ bHeaderConfig ["^before"] ["^after"] + let info = fileInfo $ bHeaderConfig [[re|^before|]] [[re|^after|]] header = "{-| HEADER -}" sample = "1\n2\nbefore\nafter\n4\n" expected = "1\n2\nbefore\n{-| HEADER -}\nafter\n4\n" addHeader info header sample `shouldBe` expected it "adds header at correct position (with correct margins)" $ do - let info = fileInfo $ bHeaderConfigM 2 2 ["^before"] ["^after"] + let info = fileInfo $ bHeaderConfigM 2 2 [[re|^before|]] [[re|^after|]] header = "{-| HEADER -}" sample = "1\n2\nbefore\nafter\n4\n" expected = "1\n2\nbefore\n\n\n{-| HEADER -}\n\n\nafter\n4\n" addHeader info header sample `shouldBe` expected it "adds header at the end of text (with correct margins)" $ do - let info = fileInfo $ bHeaderConfigM 2 2 ["^before"] [] + let info = fileInfo $ bHeaderConfigM 2 2 [[re|^before|]] [] header = "{-| HEADER -}" sample = "1\n2\nbefore" - expected = "1\n2\nbefore\n\n\n{-| HEADER -}\n" + expected = "1\n2\nbefore\n\n\n{-| HEADER -}" addHeader info header sample `shouldBe` expected it "does nothing if header is already present" $ do - let config = bHeaderConfig ["^before"] [] + let config = bHeaderConfig [[re|^before|]] [] header = "{-| HEADER -}" - info = FileInfo Haskell config (Just (3, 3)) HM.empty + info = FileInfo Haskell config (Just (3, 3)) mempty sample = "1\n2\nbefore\n{-| OLDHEADER -}\nafter\n4" addHeader info header sample `shouldBe` sample @@ -84,20 +86,20 @@ describe "dropHeader" $ do it "does nothing if no header is present" $ do let config = bHeaderConfig [] [] - info = FileInfo Haskell config Nothing HM.empty + info = FileInfo Haskell config Nothing mempty sample = "1\n2\nbefore\nafter\n4\n" dropHeader info sample `shouldBe` sample it "drops existing single line header" $ do let config = bHeaderConfig [] [] - info = FileInfo Haskell config (Just (3, 3)) HM.empty + info = FileInfo Haskell config (Just (3, 3)) mempty sample = "1\n2\nbefore\n{-| HEADER -}\nafter\n4\n" expected = "1\n2\nbefore\nafter\n4\n" dropHeader info sample `shouldBe` expected it "drops existing multi line header" $ do let config = bHeaderConfig [] [] - info = FileInfo Haskell config (Just (3, 4)) HM.empty + info = FileInfo Haskell config (Just (3, 4)) mempty sample = "1\n2\nbefore\n{-| HEADER\nHERE -}\nafter\n4\n" expected = "1\n2\nbefore\nafter\n4\n" dropHeader info sample `shouldBe` expected @@ -105,16 +107,16 @@ describe "replaceHeader" $ do it "adds header if there's none present" $ do - let config = bHeaderConfig ["^before"] [] - info = FileInfo Haskell config Nothing HM.empty + let config = bHeaderConfig [[re|^before|]] [] + info = FileInfo Haskell config Nothing mempty header = "{-| NEWHEADER -}" sample = "1\n2\nbefore\nafter\n4\n" expected = "1\n2\nbefore\n{-| NEWHEADER -}\nafter\n4\n" replaceHeader info header sample `shouldBe` expected it "replaces header if there's existing one" $ do - let config = bHeaderConfig ["^before"] [] - info = FileInfo Haskell config (Just (3, 4)) HM.empty + let config = bHeaderConfig [[re|^before|]] [] + info = FileInfo Haskell config (Just (3, 4)) mempty header = "{-| NEWHEADER -}" sample = "1\n2\nbefore\n{-| OLD\nHEADER -}\nafter\n4\n" expected = "1\n2\nbefore\n{-| NEWHEADER -}\nafter\n4\n" @@ -124,9 +126,26 @@ describe "extractFileInfo" $ do it "extracts FileInfo from given raw input" $ do let config = bHeaderConfig [] [] - expected = FileInfo Haskell config (Just (1, 13)) HM.empty + meta = Nothing + expected = FileInfo + Haskell + config + (Just (1, 13)) + (mkVariables + [ ( "_haskell_module_copyright" + , "(c) Some Guy, 2013\n Someone Else, 2014" + ) + , ("_haskell_module_license" , "GPL-3") + , ("_haskell_module_maintainer" , "sample@email.com") + , ("_haskell_module_name" , "Test") + , ("_haskell_module_stability" , "experimental") + , ("_haskell_module_portability", "POSIX") + , ("_haskell_module_longdesc" , "long\ndescription") + , ("_haskell_module_shortdesc" , "Short description") + ] + ) sample <- readFileUtf8 $ samplesDir "haskell" "full.hs" - extractFileInfo Haskell config sample `shouldBe` expected + extractFileInfo Haskell config meta sample `shouldBe` expected describe "findHeader" $ do @@ -142,22 +161,22 @@ it "finds block comment header put after 'putAfter' constraint" $ do let sample = "{-| 1 -}\nfoo\n{-| 2\n2 -}\nbar\n{-| 3\n3 -}" - config = bHeaderConfig ["^foo"] [] + config = bHeaderConfig [[re|^foo|]] [] findHeader config sample `shouldBe` Just (2, 3) it "finds line comment header put after 'putAfter' constraint" $ do let sample = "-- 1\nfoo\n-- 2\n-- 2\nbar\n-- 3\n-- 3" - config = lHeaderConfig ["^foo"] [] + config = lHeaderConfig [[re|^foo|]] [] findHeader config sample `shouldBe` Just (2, 3) it "finds block comment header put after composed constraint" $ do let sample = "{-| 1 -}\nfoo\n{-| 2\n2 -}\nbar\n{-| 3\n3 -}" - config = bHeaderConfig ["^bar", "^foo"] [] + config = bHeaderConfig [[re|^bar|^foo|]] [] findHeader config sample `shouldBe` Just (5, 6) it "finds line comment header put after composed constraint" $ do let sample = "-- 1\nfoo\n-- 2\n-- 2\nbar\n-- 3\n-- 3" - config = lHeaderConfig ["^bar", "^foo"] [] + config = lHeaderConfig [[re|^bar|^foo|]] [] findHeader config sample `shouldBe` Just (5, 6) it "finds nothing if no header present" $ do @@ -167,13 +186,13 @@ it "finds nothing if header is present before 'putAfter' constraint" $ do let sample = "foo\n{-| 1 -}\nbar\nsome text" - config = bHeaderConfig ["^bar"] [] + config = bHeaderConfig [[re|^bar|]] [] findHeader config sample `shouldBe` Nothing it "correctly detects headers using default YAML configuration" $ do let path = "test-data" "code-samples" defaultConfig' <- parseConfiguration defaultConfig - HeadersConfig {..} <- makeHeadersConfig (pcLicenseHeaders defaultConfig') + HeadersConfig {..} <- makeHeadersConfig (cLicenseHeaders defaultConfig') sampleC1 <- loadFile $ path "c" "sample1.c" sampleC2 <- loadFile $ path "c" "sample2.c" sampleCpp1 <- loadFile $ path "cpp" "sample1.cpp" @@ -255,35 +274,35 @@ describe "lastMatching" $ do - let regex = compile "^foo" [utf8] + let patterns = [[re|^foo|]] - it "finds very last line that matches given regex" $ do + it "finds very last line that matches given patterns" $ do let sample = ["some text", "hello", "foo bar", "foo baz", "last one"] - lastMatching regex sample `shouldBe` Just 3 + lastMatching patterns sample `shouldBe` Just 3 it "returns Nothing if no matching input found" $ do let sample = ["some text", "hello", "last one"] - lastMatching regex sample `shouldBe` Nothing + lastMatching patterns sample `shouldBe` Nothing it "returns Nothing the input is empty" $ do - lastMatching regex [] `shouldBe` Nothing + lastMatching patterns [] `shouldBe` Nothing describe "firstMatching" $ do - let regex = compile "^foo" [utf8] + let patterns = [[re|^foo|]] - it "finds very first line that matches given regex" $ do + it "finds very first line that matches given patterns" $ do let sample = ["some text", "hello", "foo bar", "foo baz", "last one"] - firstMatching regex sample `shouldBe` Just 2 + firstMatching patterns sample `shouldBe` Just 2 it "returns Nothing if the input is empty" $ do - firstMatching regex [] `shouldBe` Nothing + firstMatching patterns [] `shouldBe` Nothing describe "splitInput" $ do let sample = "text\n->\nRESULT\n<-\nfoo" - fstSplit = ["->"] - sndSplit = ["<-"] + fstSplit = [[re|->|]] + sndSplit = [[re|<-|]] it "handles empty input and conditions" $ do splitInput [] [] "" `shouldBe` ([], [], []) diff --git a/test/Headroom/FileSystemSpec.hs b/test/Headroom/FileSystemSpec.hs --- a/test/Headroom/FileSystemSpec.hs +++ b/test/Headroom/FileSystemSpec.hs @@ -1,10 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Headroom.FileSystemSpec ( spec ) where +import Headroom.Data.Regex ( re ) import Headroom.FileSystem import RIO import RIO.List ( sort ) @@ -50,7 +52,7 @@ describe "excludePaths" $ do it "excludes paths matching selected pattern from input list" $ do - let patterns = ["\\.stack-work", "remove\\.txt"] + let patterns = [[re|\.stack-work|], [re|remove\.txt|]] sample = [ "/foo/bar/.stack-work/xx" , "/hello/world" diff --git a/test/Headroom/FileTypeSpec.hs b/test/Headroom/FileTypeSpec.hs --- a/test/Headroom/FileTypeSpec.hs +++ b/test/Headroom/FileTypeSpec.hs @@ -8,11 +8,10 @@ import Headroom.Configuration ( makeHeadersConfig , parseConfiguration ) +import Headroom.Configuration.Types ( Configuration(..) ) import Headroom.Embedded ( defaultConfig ) import Headroom.FileType -import Headroom.Types ( FileType(..) - , PartialConfiguration(..) - ) +import Headroom.FileType.Types ( FileType(..) ) import RIO import Test.Hspec @@ -21,6 +20,6 @@ spec = do describe "fileTypeByExt" $ do it "parses FileType from file extension" $ do - pHeadersConfig <- pcLicenseHeaders <$> parseConfiguration defaultConfig + pHeadersConfig <- cLicenseHeaders <$> parseConfiguration defaultConfig headersConfig <- makeHeadersConfig pHeadersConfig fileTypeByExt headersConfig "hs" `shouldBe` Just Haskell diff --git a/test/Headroom/HeaderFn/TypesSpec.hs b/test/Headroom/HeaderFn/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/HeaderFn/TypesSpec.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Headroom.HeaderFn.TypesSpec + ( spec + ) +where + +import Headroom.Data.Has ( Has(..) ) +import Headroom.HeaderFn ( runHeaderFn ) +import Headroom.HeaderFn.Types +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + describe "Semigroup HeaderFn" $ do + it "combines two values together" $ do + let fooEnv = FooEnv "_FOO_ENV" + barEnv = BarEnv "_BAR_ENV" + combinedEnv = CombinedEnv fooEnv barEnv + input = "input" + combinedFn = fooFn <> barFn + expected = "input_FOO_ENV_BAR_ENV" + actual = runHeaderFn combinedFn combinedEnv input + actual `shouldBe` expected + + describe "Monoid HeaderFn" $ do + it "does nothing with the input" $ do + let input = "input" + testEnv = undefined + testFn = mempty + actual = runHeaderFn testFn testEnv input + actual `shouldBe` input + + +------------------------------- Test Data Types ------------------------------ + + +data FooEnv = FooEnv + { feValue :: !Text + } + +data BarEnv = BarEnv + { beValue :: !Text + } + +data CombinedEnv = CombinedEnv + { ceFooEnv :: !FooEnv + , ceBarEnv :: !BarEnv + } + + +instance Has FooEnv FooEnv where + hasLens = id + +instance Has FooEnv CombinedEnv where + hasLens = lens ceFooEnv (\x y -> x { ceFooEnv = y }) + +instance Has BarEnv CombinedEnv where + hasLens = lens ceBarEnv (\x y -> x { ceBarEnv = y }) + + +fooFn :: (Has FooEnv env) => HeaderFn env +fooFn = HeaderFn $ \input -> do + FooEnv {..} <- viewL + pure $ input <> feValue + +barFn :: (Has BarEnv env) => HeaderFn env +barFn = HeaderFn $ \input -> do + BarEnv {..} <- viewL + pure $ input <> beValue diff --git a/test/Headroom/HeaderFn/UpdateCopyrightSpec.hs b/test/Headroom/HeaderFn/UpdateCopyrightSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/HeaderFn/UpdateCopyrightSpec.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Headroom.HeaderFn.UpdateCopyrightSpec + ( spec + ) +where + +import Headroom.Data.Has ( Has(..) ) +import Headroom.Data.TextExtra ( fromLines ) +import Headroom.HeaderFn ( runHeaderFn ) +import Headroom.HeaderFn.UpdateCopyright +import Headroom.Types ( CurrentYear(..) ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + let currYear = CurrentYear 2020 + + + describe "updateCopyright" $ do + it "updates all authors when such mode selected" $ do + let + sample = fromLines + [ "Copyright (c) 2019 1st Author" + , "Copyright (c) 2017-2019 2nd Author" + ] + expected = fromLines + [ "Copyright (c) 2019-2020 1st Author" + , "Copyright (c) 2017-2020 2nd Author" + ] + testEnv = TestEnv currYear UpdateAllAuthors + runHeaderFn updateCopyright testEnv sample `shouldBe` expected + + it "updates only selected authors in such mode" $ do + let sample = fromLines + [ "Copyright (c) 2019 1st Author" + , "Copyright (c) 2017-2019 2nd Author" + ] + expected = fromLines + [ "Copyright (c) 2019 1st Author" + , "Copyright (c) 2017-2020 2nd Author" + ] + mode = UpdateSelectedAuthors . SelectedAuthors $ "2nd Author" :| [] + testEnv = TestEnv currYear mode + runHeaderFn updateCopyright testEnv sample `shouldBe` expected + + + describe "updateYears" $ do + it "does nothing on up-to-date year" $ do + let sample = "Copyright (c) 2020" + updateYears currYear sample `shouldBe` sample + + it "does nothing on up-to-date year range" $ do + let sample = "Copyright (c) 2018-2020" + updateYears currYear sample `shouldBe` sample + + it "updates outdated year" $ do + let sample = "Copyright (c) 2019" + expected = "Copyright (c) 2019-2020" + updateYears currYear sample `shouldBe` expected + + it "updates outdated year range" $ do + let sample = "Copyright (c) 2017-2019" + expected = "Copyright (c) 2017-2020" + updateYears currYear sample `shouldBe` expected + + it "updates complex multi-line text" $ do + let sample = fromLines + [ "Copyright (c) 2019" + , "Copyright (c) 2020" + , "Copyright (c) 2019-2020" + , "Copyright (c) 2017-2019" + ] + expected = fromLines + [ "Copyright (c) 2019-2020" + , "Copyright (c) 2020" + , "Copyright (c) 2019-2020" + , "Copyright (c) 2017-2020" + ] + updateYears currYear sample `shouldBe` expected + + +------------------------------- TEST DATA TYPES ------------------------------ + + +data TestEnv = TestEnv + { teCurrentYear :: !CurrentYear + , teMode :: !UpdateCopyrightMode + } + deriving (Eq, Show) + +instance Has CurrentYear TestEnv where + hasLens = lens teCurrentYear (\x y -> x { teCurrentYear = y }) + +instance Has UpdateCopyrightMode TestEnv where + hasLens = lens teMode (\x y -> x { teMode = y }) + diff --git a/test/Headroom/HeaderFnSpec.hs b/test/Headroom/HeaderFnSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/HeaderFnSpec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +module Headroom.HeaderFnSpec + ( spec + ) +where + +import Headroom.Configuration.Types ( HeaderFnConfig(..) + , HeaderFnConfigs(..) + , UpdateCopyrightConfig(..) + ) +import Headroom.Data.Has ( Has(..) ) +import Headroom.Data.TextExtra ( fromLines ) +import Headroom.HeaderFn +import Headroom.HeaderFn.Types +import Headroom.HeaderFn.UpdateCopyright +import Headroom.Types ( CurrentYear(..) ) +import Headroom.Variables ( mkVariables ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + let currentYear = CurrentYear 2020 + mode = UpdateSelectedAuthors . SelectedAuthors $ "2nd Author" :| [] + vars = mkVariables [("sndAuthor", "2nd Author")] + configs a = HeaderFnConfigs + { hfcsUpdateCopyright = HeaderFnConfig + { hfcEnabled = True + , hfcConfig = UpdateCopyrightConfig + { uccSelectedAuthors = Just + $ a + :| [] + } + } + } + configuredEnv a = ConfiguredEnv { ceCurrentYear = currentYear + , ceHeaderFnConfigs = configs a + , ceUpdateCopyrightMode = mode + } + + + describe "runHeaderFn" $ do + it "executes the function for given environment" $ do + let testEnv = TestEnv "ENV" + input = "input" + actual = runHeaderFn testFn testEnv input + expected = "input_ENV" + actual `shouldBe` expected + + + describe "postProcessHeader" $ do + it "post-processes given license header using given configuration" $ do + let header = fromLines + [ "License header" + , "Copyright (c) 2019 1st Author" + , "Copyright (c) 2018-2019 2nd Author" + ] + expected = fromLines + [ "License header" + , "Copyright (c) 2019 1st Author" + , "Copyright (c) 2018-2020 2nd Author" + ] + env = configuredEnv "2nd Author" + postProcessHeader env header `shouldBe` expected + + + describe "mkConfiguredEnv" $ do + it "makes ConfiguredEnv from input parameters" $ do + let configsIn = configs "{{ sndAuthor }}" + envOut = configuredEnv "2nd Author" + mkConfiguredEnv currentYear vars configsIn `shouldBe` Just envOut + +------------------------------- Test Data Types ------------------------------ + +newtype TestEnv = TestEnv Text + +instance Has TestEnv TestEnv where + hasLens = id + +testFn :: (Has TestEnv env) => HeaderFn env +testFn = HeaderFn $ \input -> do + TestEnv text <- viewL + pure $ input <> "_" <> text diff --git a/test/Headroom/RegexSpec.hs b/test/Headroom/RegexSpec.hs deleted file mode 100644 --- a/test/Headroom/RegexSpec.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Headroom.RegexSpec - ( spec - ) -where - -import Headroom.Regex -import RIO -import Test.Hspec - - -spec :: Spec -spec = do - describe "joinPatterns" $ do - it "returns Nothing for empty input" $ do - joinPatterns [] `shouldBe` Nothing - - it "handles single item list input" $ do - joinPatterns ["foo"] `shouldBe` Just "foo" - - it "handles multiple item list input" $ do - joinPatterns ["^foo", "^bar"] `shouldBe` Just "^foo|^bar" - - - describe "match'" $ do - it "matches regular expression against given sample" $ do - let regex = compile' <$> joinPatterns ["foo", "bar"] - (regex >>= (`match'` "xxx")) `shouldSatisfy` isNothing - (regex >>= (`match'` "foz")) `shouldSatisfy` isNothing - (regex >>= (`match'` "foosdas")) `shouldSatisfy` isJust - (regex >>= (`match'` "barfoo")) `shouldSatisfy` isJust diff --git a/test/Headroom/Template/MustacheSpec.hs b/test/Headroom/Template/MustacheSpec.hs --- a/test/Headroom/Template/MustacheSpec.hs +++ b/test/Headroom/Template/MustacheSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Headroom.Template.MustacheSpec ( spec ) @@ -8,38 +9,55 @@ import Headroom.Template import Headroom.Template.Mustache -import Headroom.Types ( ApplicationError(..) - , TemplateError(..) - ) +import Headroom.Variables ( mkVariables ) import RIO -import qualified RIO.HashMap as HM import Test.Hspec import Test.Utils ( matchesException ) + spec :: Spec spec = do describe "parseTemplate" $ do it "parses Mustache template from raw text" $ do let template = "Hello, {{ name }}" - parsed = parseTemplate (Just "template") template :: Maybe Mustache + parsed = parseTemplate @Mustache (Just "template") template parsed `shouldSatisfy` isJust + describe "renderTemplate" $ do - it "renders Mustache template with given variables" $ do + it "renders template with given variables" $ do let template = "Hello, {{ name }}" - variables = HM.fromList [("name", "John")] - parsed = parseTemplate (Just "template") template :: Maybe Mustache - rendered = parsed >>= renderTemplate variables :: Maybe Text + variables = mkVariables [("name", "John")] + parsed = parseTemplate @Mustache (Just "template") template + rendered = parsed >>= renderTemplate variables rendered `shouldBe` Just "Hello, John" it "fails if not enough variables is provided" $ do - let - template = "Hello, {{ name }} {{ surname }}" - variables = HM.fromList [("name", "John")] - parsed :: Either SomeException Mustache - parsed = parseTemplate (Just "test") template - rendered = parsed >>= renderTemplate variables - check (Just (TemplateError (MissingVariables "test" ["surname"]))) = - True - check _ = False + let template = "Hello, {{ name }} {{ surname }}" + variables = mkVariables [("name", "John")] + parsed = parseTemplate @Mustache (Just "test") template + rendered = parsed >>= renderTemplate variables + check (Just (MissingVariables "test" ["surname"])) = True + check _ = False rendered `shouldSatisfy` matchesException check + + it "renders template with conditionally set variable" $ do + let template = "Foo {{#bar}}{{bar}}{{/bar}}{{^bar}}BAR{{/bar}}" + variables = mempty + parsed = parseTemplate @Mustache (Just "template") template + rendered = parsed >>= renderTemplate variables + rendered `shouldBe` Just "Foo BAR" + + it "fails if non-existing variable is used with inverted sections" $ do + let template = "Foo {{bar}}{{^bar}}BAR{{/bar}}" + variables = mkVariables [("xx", "yy")] + parsed = parseTemplate @Mustache (Just "template") template + rendered = parsed >>= renderTemplate variables + rendered `shouldBe` Nothing + + + describe "rawTemplate" $ do + it "returns raw template text for already parsed template" $ do + let template = "Hello, {{ name }}" + parsed = parseTemplate @Mustache (Just "template") template + fmap rawTemplate parsed `shouldBe` Just template diff --git a/test/Headroom/TypesSpec.hs b/test/Headroom/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/TypesSpec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Headroom.TypesSpec + ( spec + ) +where + +import Headroom.Variables ( mkVariables ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + describe "Semigroup Variables" $ do + it "combines two instances of variables" $ do + let sample1 = mkVariables [("fst", "v1"), ("snd", "v1")] + sample2 = mkVariables [("snd", "v2"), ("trd", "v1")] + expected = mkVariables [("trd", "v1"), ("snd", "v2"), ("fst", "v1")] + (sample1 <> sample2) `shouldBe` expected diff --git a/test/Headroom/VariablesSpec.hs b/test/Headroom/VariablesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/VariablesSpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Headroom.VariablesSpec + ( spec + ) +where + +import Headroom.Types ( CurrentYear(..) ) +import Headroom.Variables +import Headroom.Variables.Types ( Variables(..) ) +import RIO +import qualified RIO.HashMap as HM +import Test.Hspec + + +spec :: Spec +spec = do + describe "mkVariables" $ do + it "constructs new Variables" $ do + let sample = [("key1", "value1")] + expected = Variables $ HM.fromList sample + mkVariables sample `shouldBe` expected + + + describe "parseVariables" $ do + it "parses variables from key=value textual representation" $ do + let sample = ["key1=value1", "key2=value2"] + expected = mkVariables [("key1", "value1"), ("key2", "value2")] + parseVariables sample `shouldBe` Just expected + + + describe "compileVariables" $ do + it "compiles template-like variable values" $ do + let sample1 = mkVariables + [("name", "John Smith"), ("greeting", "Hello, {{ name }}")] + expected = mkVariables + [("name", "John Smith"), ("greeting", "Hello, John Smith")] + result <- compileVariables sample1 + result `shouldBe` expected + + it "doesn't get stuck in infinite loop on invalid recursive variable" $ do + let sample1 = mkVariables [("greeting", "Hello, {{ greeting }}")] + expected = mkVariables [("greeting", "Hello, Hello, {{ greeting }}")] + result <- compileVariables sample1 + result `shouldBe` expected + + + describe "dynamicVariables" $ do + it "returns map of all expected dynamic variables" $ do + let year = CurrentYear 2020 + expected = mkVariables [("_current_year", "2020")] + dynamicVariables year `shouldBe` expected