diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,15 @@ # Changelog All notable changes to this project will be documented in this file. +## 0.4.0.0 (in development) +- [#57] FIXED: put-before/put-after in commented code breaks header detection +- [#58] BREAKING CHANGE: Extend configuration for defining header margins +- [#59] Check compatibility of loaded YAML configuration +- [#61] BREAKING CHANGE: Use regular expressions to specify headers start/end +- [#62] Sanitize block comment headers with line prefixes +- [#64] Add command line option for displaying version +- Bump _LTS Haskell_ to `17.5` + ## 0.3.2.0 (released 2020-11-26) - [#56] Move CI from Travis to GitHub Actions - Minor improvements & bugfixes diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2019-2020, Vaclav Svejcar +Copyright (c) 2019-2021, Vaclav Svejcar All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ 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! +__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 [content-aware templates][doc:templates] for some source code file types, and much more! [![asciicast](https://asciinema.org/a/4Pfxdss0V4msFjjt2z6mgCZCp.svg)](https://asciinema.org/a/4Pfxdss0V4msFjjt2z6mgCZCp) @@ -9,9 +9,15 @@ - __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. +- __Content-aware Templates__ - for selected file types, _Headroom_ [exposes additional info][doc:templates] about processed file using template variables, so you can use info like _Java_ package name in your templates. - __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! +## Installation +You can get _Headroom_ via one of the following options: +1. download pre-built binary for _GNU/Linux_ or _macOS_ (x64) from [releases page][meta:releases] +1. install using [Homebrew][web:homebrew]: `brew install norcane/tools/headroom` +1. build from source code - see [project microsite][web:headroom] for more details + ## 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]. @@ -23,16 +29,29 @@ * for end-user documentation, [official project microsite][web:headroom] * for _Haskell API_ documentation, see [Headroom on Hackage][hackage:headroom] +### Running microsite locally +If you need to show microsite documetation for unreleased version of _Headroom_ (e.g. for `master` branch), you can run it locally using [MkDocs][web:mkdocs] tool: + +``` +$ cd doc/microsite/ +$ mkdcs serve +``` + +Documentation is then available on http://127.0.0.1:8000. + [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 +[meta:releases]: https://github.com/vaclavsvejcar/headroom/releases [web:headroom]: https://doc.norcane.com/headroom/latest/ +[web:homebrew]: https://brew.sh [doc:configuration]: https://doc.norcane.com/headroom/latest/documentation/configuration/ -[doc:extended-functionality]: https://doc.norcane.com/headroom/latest/documentation/extended-functionality/ +[doc:templates]: https://doc.norcane.com/headroom/latest/documentation/templates/ [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:mkdocs]: https://www.mkdocs.org [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 @@ -6,7 +6,7 @@ {-| Module : Main Description : Main application launcher -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -18,21 +18,21 @@ module Main where -import Headroom.Command ( commandParser ) -import Headroom.Command.Gen ( commandGen - , parseGenMode - ) -import Headroom.Command.Init ( commandInit ) -import Headroom.Command.Run ( commandRun ) -import Headroom.Command.Types ( Command(..) - , CommandGenOptions(..) - , CommandInitOptions(..) - , CommandRunOptions(..) - ) -import Headroom.Types ( HeadroomError(..) ) -import Options.Applicative ( execParser ) +import Headroom.Command ( commandParser ) +import Headroom.Command.Gen ( commandGen + , parseGenMode + ) +import Headroom.Command.Init ( commandInit ) +import Headroom.Command.Run ( commandRun ) +import Headroom.Command.Types ( Command(..) + , CommandGenOptions(..) + , CommandInitOptions(..) + , CommandRunOptions(..) + ) +import Headroom.Types ( HeadroomError(..) ) +import Options.Applicative ( execParser ) import RIO -import System.IO ( hPutStrLn ) +import System.IO ( hPutStrLn ) main :: IO () diff --git a/embedded/config-file.yaml b/embedded/config-file.yaml --- a/embedded/config-file.yaml +++ b/embedded/config-file.yaml @@ -1,6 +1,13 @@ ## This is the configuration file for Headroom. ## See https://github.com/vaclavsvejcar/headroom for more details. +## Defines with which version of Headroom this configuration is compatible. +## Headroom uses this field to detect whether your configuration doesn't need +## any manual migration steps in case that it's older than your current Headroom +## version. You don't need to touch this field unless explicitly stated in +## migration guide during upgrading Headroom to new version. +version: "" + ## Defines the behaviour how to handle license headers, possible options are: ## ## - add = (default) adds license header to files with no existing header diff --git a/embedded/default-config.yaml b/embedded/default-config.yaml --- a/embedded/default-config.yaml +++ b/embedded/default-config.yaml @@ -1,6 +1,13 @@ ## This is the configuration file for Headroom. ## See https://github.com/vaclavsvejcar/headroom for more details. +## Defines with which version of Headroom this configuration is compatible. +## Headroom uses this field to detect whether your configuration doesn't need +## any manual migration steps in case that it's older than your current Headroom +## version. You don't need to touch this field unless explicitly stated in +## migration guide during upgrading Headroom to new version. +# version: "" + ## Defines the behaviour how to handle license headers, possible options are: ## ## - add = (default) adds license header to files with no existing header @@ -53,10 +60,18 @@ ## configuration keys are: ## ## - file-extensions = List of file extensions valid for given file type. -## - margin-after = Number of blank lines to put AFTER the rendered -## license header text. -## - margin-before = Number of blank lines to put BEFORE the rendered -## license header text. +## - margin-top-code = Margin (in no. of empty lines) between generated +## header and code above it, but only IF header is NOT +## the first thing in file. +## - margin-top-file = Margin (in no. of empty lines) between generated +## header the very top of the file, but only IF header +## IS the first thing in file. +## - margin-bottom-code = Margin (in no. of empty lines) between generated +## header and code below it, but only IF header is NOT +## the last thing in file. +## - margin-bottom-file = Margin (in no. of empty lines) between generated +## header the very end of the file, but only IF header +## IS the last thing in file. ## - put-after = List of regexp patterns, where the license header is ## placed AFTER the very last line matching one of the ## given regular expressions. If no match found, header @@ -69,131 +84,156 @@ ## multi-line (block) comment syntax (such as '/* */'). ## Has two mandatory fields: ## starts-with = Defines how the license header comment starts. +## Expects valid regular expression. ## ends-with = Defines how the license header comment ends. +## Expects valid regular expression. ## NOTE: cannot be used together with 'line-comment'. ## - line-comment = Defines that the license header is rendered using the ## single-line comment syntax (such as '//'). ## Has one mandatory field: ## prefixed-by = Defines how the license header comment starts. +## Expects valid regular expression. license-headers: ## C configuration c: file-extensions: ["c"] - margin-after: 0 - margin-before: 0 + margin-top-code: 0 + margin-top-file: 0 + margin-bottom-code: 0 + margin-bottom-file: 0 put-after: [] put-before: ["^#include"] block-comment: - starts-with: "/*" - ends-with: "*/" + starts-with: ^\/\* + ends-with: \*\/$ ## C++ configuration cpp: file-extensions: ["cpp"] - margin-after: 0 - margin-before: 0 + margin-top-code: 0 + margin-top-file: 0 + margin-bottom-code: 0 + margin-bottom-file: 0 put-after: [] put-before: ["^#include"] block-comment: - starts-with: "/*" - ends-with: "*/" + starts-with: ^\/\* + ends-with: \*\/$ ## CSS configuration css: file-extensions: ["css"] - margin-after: 0 - margin-before: 0 + margin-top-code: 0 + margin-top-file: 0 + margin-bottom-code: 0 + margin-bottom-file: 0 put-after: [] put-before: ['([^\r\n,{}]+)(,(?=[^}]*{)|\s*{)'] block-comment: - starts-with: "/*" - ends-with: "*/" + starts-with: ^\/\* + ends-with: \*\/$ ## Haskell configuration haskell: file-extensions: ["hs"] - margin-after: 0 - margin-before: 0 + margin-top-code: 0 + margin-top-file: 0 + margin-bottom-code: 0 + margin-bottom-file: 0 put-after: [] put-before: ["^module"] block-comment: - starts-with: "{-|" - ends-with: "-}" + starts-with: ^{-\| + ends-with: (?" + starts-with: ^$ ## Java configuration java: file-extensions: ["java"] - margin-after: 0 - margin-before: 0 + margin-top-code: 0 + margin-top-file: 0 + margin-bottom-code: 0 + margin-bottom-file: 0 put-after: [] put-before: ["^package"] block-comment: - starts-with: "/*" - ends-with: "*/" + starts-with: ^\/\* + ends-with: \*\/$ ## JS configuration js: file-extensions: ["js"] - margin-after: 0 - margin-before: 0 + margin-top-code: 0 + margin-top-file: 0 + margin-bottom-code: 0 + margin-bottom-file: 0 put-after: [] put-before: [] block-comment: - starts-with: "/*" - ends-with: "*/" + starts-with: ^\/\* + ends-with: \*\/$ ## PureScript configuration purescript: file-extensions: ["purs"] - margin-after: 0 - margin-before: 0 + margin-top-code: 0 + margin-top-file: 0 + margin-bottom-code: 0 + margin-bottom-file: 0 put-after: [] put-before: ["^module"] line-comment: - prefixed-by: "--" + prefixed-by: ^-- ## Rust configuration rust: file-extensions: ["rs"] - margin-after: 0 - margin-before: 0 + margin-top-code: 0 + margin-top-file: 0 + margin-bottom-code: 0 + margin-bottom-file: 0 put-after: [] put-before: ["^use"] block-comment: - starts-with: "/*" - ends-with: "*/" + starts-with: ^\/\* + ends-with: \*\/$ ## Scala configuration scala: file-extensions: ["scala"] - margin-after: 0 - margin-before: 0 + margin-top-code: 0 + margin-top-file: 0 + margin-bottom-code: 0 + margin-bottom-file: 0 put-after: [] put-before: ["^package"] block-comment: - starts-with: "/*" - ends-with: "*/" + starts-with: ^\/\* + ends-with: \*\/$ ## Shell configuration shell: file-extensions: ["sh"] - margin-after: 1 - margin-before: 1 + margin-top-code: 1 + margin-top-file: 0 + margin-bottom-code: 1 + margin-bottom-file: 0 put-after: ["^#!"] put-before: [] line-comment: - prefixed-by: "#" + prefixed-by: ^# ## Configuration for post-processing license header functions. These functions ## allows to modify/enhance already rendered license headers, e.g. update years @@ -208,5 +248,8 @@ update-copyright: enabled: false config: - ## If used, updates copyright statements of selected authors only. + ## If used, updates copyright statements of selected authors only. You can + ## not only use list of concrete names, but also any variable defined in + ## 'variables' section. # selected-authors-only: ["John Smith"] + # selected-authors-only: ["{{ author }}"] diff --git a/headroom.cabal b/headroom.cabal --- a/headroom.cabal +++ b/headroom.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 3ad29fd26d8cdd22903560fba5cdce69121c53c5065bb10a4a63978bc1d139a7 +-- hash: 4c5eb45fc45946807c2cbd5814cbf57038cb7e09f142e29767fede026dbdd86f name: headroom -version: 0.3.2.0 +version: 0.4.0.0 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 @@ -15,7 +15,7 @@ bug-reports: https://github.com/vaclavsvejcar/headroom/issues author: Vaclav Svejcar maintainer: vaclav.svejcar@gmail.com -copyright: Copyright (c) 2019-2020 Vaclav Svejcar +copyright: Copyright (c) 2019-2021 Vaclav Svejcar license: BSD-3-Clause license-file: LICENSE build-type: Simple @@ -102,6 +102,7 @@ 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/haskell/sample3.hs test-data/code-samples/html/sample1.html test-data/code-samples/html/sample2.html test-data/code-samples/java/sample1.java @@ -134,29 +135,45 @@ Headroom.Command.Types Headroom.Command.Utils Headroom.Configuration + Headroom.Configuration.Compat + Headroom.Configuration.Enrich Headroom.Configuration.Types + Headroom.Data.Coerce Headroom.Data.EnumExtra Headroom.Data.Has Headroom.Data.Lens Headroom.Data.Regex - Headroom.Data.TextExtra + Headroom.Data.Text Headroom.Embedded Headroom.Embedded.TH - Headroom.Ext - Headroom.Ext.Haskell - Headroom.Ext.Haskell.Haddock - Headroom.Ext.Java - Headroom.Ext.PureScript Headroom.FileSupport + Headroom.FileSupport.C + Headroom.FileSupport.CPP + Headroom.FileSupport.CSS + Headroom.FileSupport.Haskell + Headroom.FileSupport.Haskell.Haddock + Headroom.FileSupport.HTML + Headroom.FileSupport.Java + Headroom.FileSupport.JS + Headroom.FileSupport.PureScript + Headroom.FileSupport.Rust + Headroom.FileSupport.Scala + Headroom.FileSupport.Shell + Headroom.FileSupport.TemplateData Headroom.FileSupport.Types Headroom.FileSystem Headroom.FileType Headroom.FileType.Types + Headroom.Header + Headroom.Header.Sanitize + Headroom.Header.Types Headroom.HeaderFn Headroom.HeaderFn.Types Headroom.HeaderFn.UpdateCopyright Headroom.Meta + Headroom.Meta.Version Headroom.Serialization + Headroom.SourceCode Headroom.Template Headroom.Template.Mustache Headroom.Types @@ -174,16 +191,18 @@ build-depends: aeson , base >=4.7 && <5 - , data-default-class , either , file-embed + , generic-data , microlens , microlens-th + , mtl , mustache , optparse-applicative , pcre-heavy , pcre-light , rio + , string-interpolate , template-haskell , time , yaml @@ -225,22 +244,36 @@ Headroom.Command.InitSpec Headroom.Command.ReadersSpec Headroom.Command.RunSpec + Headroom.Configuration.CompatSpec + Headroom.Configuration.EnrichSpec Headroom.ConfigurationSpec + Headroom.Data.CoerceSpec Headroom.Data.EnumExtraSpec Headroom.Data.RegexSpec - Headroom.Data.TextExtraSpec - Headroom.Ext.Haskell.HaddockSpec - Headroom.Ext.HaskellSpec - Headroom.Ext.JavaSpec - Headroom.Ext.PureScriptSpec - Headroom.ExtSpec + Headroom.Data.TextSpec + Headroom.FileSupport.CPPSpec + Headroom.FileSupport.CSpec + Headroom.FileSupport.CSSSpec + Headroom.FileSupport.Haskell.HaddockSpec + Headroom.FileSupport.HaskellSpec + Headroom.FileSupport.HTMLSpec + Headroom.FileSupport.JavaSpec + Headroom.FileSupport.JSSpec + Headroom.FileSupport.PureScriptSpec + Headroom.FileSupport.RustSpec + Headroom.FileSupport.ScalaSpec + Headroom.FileSupport.ShellSpec Headroom.FileSupportSpec Headroom.FileSystemSpec Headroom.FileTypeSpec + Headroom.Header.SanitizeSpec Headroom.HeaderFn.TypesSpec Headroom.HeaderFn.UpdateCopyrightSpec Headroom.HeaderFnSpec + Headroom.HeaderSpec + Headroom.Meta.VersionSpec Headroom.SerializationSpec + Headroom.SourceCodeSpec Headroom.Template.MustacheSpec Headroom.TypesSpec Headroom.UI.ProgressSpec @@ -257,8 +290,10 @@ , base >=4.7 && <5 , headroom , hspec + , mtl , optparse-applicative , pcre-light , rio + , string-interpolate , time default-language: Haskell2010 diff --git a/src/Headroom/Command.hs b/src/Headroom/Command.hs --- a/src/Headroom/Command.hs +++ b/src/Headroom/Command.hs @@ -5,7 +5,7 @@ {-| Module : Headroom.Command Description : Support for parsing command line arguments -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -20,31 +20,50 @@ ) where -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.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 ( buildVersion + , productDesc + , productInfo + ) +import Headroom.Meta.Version ( printVersion ) import Options.Applicative import RIO -import qualified RIO.Text as T +import qualified RIO.Text as T +------------------------------ PUBLIC FUNCTIONS ------------------------------ + -- | Parses command line arguments. commandParser :: ParserInfo Command commandParser = info - (commands <**> helper) + (helper <*> versionP <*> commandP) (fullDesc <> progDesc (T.unpack productDesc) <> header (T.unpack productInfo)) + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +versionP :: Parser (a -> a) +versionP = versionInfoP <*> versionNumP where - commands = subparser (runCommand <> genCommand <> initCommand) + versionInfoP = infoOption (T.unpack productInfo) + (long "version" <> help "show version info") + versionNumP = infoOption + (T.unpack . printVersion $ buildVersion) + (long "numeric-version" <> help "show only version number") + + +commandP :: Parser Command +commandP = subparser (runCommand <> genCommand <> initCommand) + where runCommand = command "run" (info (runOptions <**> helper) @@ -61,6 +80,7 @@ (progDesc "initialize current project for Headroom") ) + runOptions :: Parser Command runOptions = Run @@ -125,6 +145,7 @@ <*> switch (long "debug" <> help "produce more verbose output") <*> switch (long "dry-run" <> help "execute dry run (no changes to files)") + genOptions :: Parser Command genOptions = Gen @@ -141,6 +162,7 @@ <> help "generate template for license and file type" ) ) + initOptions :: Parser Command initOptions = 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 @@ -2,12 +2,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-| Module : Headroom.Command.Gen Description : Handler for the @gen@ command. -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -25,23 +26,33 @@ 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 ( fromHeadroomError - , toHeadroomError - ) -import Prelude ( putStrLn ) +import Data.String.Interpolate ( iii ) +import Headroom.Command.Types ( Command(..) + , CommandGenOptions(..) + ) +import Headroom.Command.Utils ( bootstrap ) +import Headroom.Configuration.Enrich ( Enrich(..) + , replaceEmptyValue + , withText + ) +import Headroom.Configuration.Types ( GenMode(..) ) +import Headroom.Data.Lens ( suffixLensesFor ) +import Headroom.Embedded ( configFileStub + , licenseTemplate + ) +import Headroom.Meta ( buildVersion ) +import Headroom.Meta.Version ( printVersion ) +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +import Prelude ( putStrLn ) import RIO -import qualified RIO.Text as T +import qualified RIO.Text as T + +--------------------------------- DATA TYPES --------------------------------- + data Env = Env { envLogFunc :: !LogFunc -- ^ logging function @@ -51,12 +62,17 @@ suffixLensesFor ["envLogFunc"] ''Env + instance HasLogFunc Env where logFuncL = envLogFuncL + env' :: CommandGenOptions -> LogFunc -> IO Env env' opts logFunc = pure $ Env { envLogFunc = logFunc, envGenOptions = opts } + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + -- | Parses 'GenMode' from combination of options from given 'Command'. parseGenMode :: MonadThrow m => Command @@ -68,6 +84,7 @@ Gen False (Just license) -> pure $ GenLicense license _ -> throwM NoGenModeSelected + -- | Handler for /Generator/ command. commandGen :: CommandGenOptions -- ^ /Generator/ command options @@ -77,11 +94,17 @@ GenConfigFile -> liftIO printConfigFile GenLicense (lType, fType) -> liftIO . putStrLn $ licenseTemplate lType fType + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + printConfigFile :: IO () -printConfigFile = putStrLn configFileStub +printConfigFile = putStrLn . T.unpack $ enrich modify configFileStub + where + modify = replaceEmptyValue "version" $ withText ver + ver = printVersion buildVersion ---------------------------------- Error Types -------------------------------- +--------------------------------- ERROR TYPES -------------------------------- -- | Exception specific to the @gen@ command. data CommandGenError = NoGenModeSelected @@ -94,8 +117,9 @@ fromException = fromHeadroomError displayException' :: CommandGenError -> String -displayException' = T.unpack . \case - NoGenModeSelected -> mconcat - [ "Please select at least one option what to generate " - , "(see --help for details)" - ] +displayException' = \case + NoGenModeSelected -> [iii| + 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 MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -13,7 +14,7 @@ {-| Module : Headroom.Command.Init Description : Handler for the @init@ command -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -33,46 +34,55 @@ ) 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 - ) -import Headroom.FileSystem ( FileSystem(..) - , fileExtension - , findFiles - , mkFileSystem - ) -import Headroom.FileType ( fileTypeByExt ) -import Headroom.FileType.Types ( FileType(..) ) -import Headroom.Meta ( TemplateType ) -import Headroom.Serialization ( prettyPrintYAML ) -import Headroom.Template ( Template(..) ) -import Headroom.Types ( fromHeadroomError - , toHeadroomError - ) -import Headroom.UI ( Progress(..) - , zipWithProgress - ) +import Data.String.Interpolate ( iii ) +import Headroom.Command.Types ( CommandInitOptions(..) ) +import Headroom.Command.Utils ( bootstrap ) +import Headroom.Configuration ( makeHeadersConfig + , parseConfiguration + ) +import Headroom.Configuration.Enrich ( Enrich(..) + , replaceEmptyValue + , withArray + , withText + ) +import Headroom.Configuration.Types ( Configuration(..) + , LicenseType(..) + ) +import Headroom.Data.Has ( Has(..) ) +import Headroom.Data.Lens ( suffixLenses ) +import Headroom.Embedded ( configFileStub + , defaultConfig + , licenseTemplate + ) +import Headroom.FileSystem ( FileSystem(..) + , fileExtension + , findFiles + , mkFileSystem + ) +import Headroom.FileType ( fileTypeByExt ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Meta ( TemplateType + , buildVersion + , configFileName + ) +import Headroom.Meta.Version ( printVersion ) +import Headroom.Template ( Template(..) ) +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +import Headroom.UI ( Progress(..) + , zipWithProgress + ) import RIO -import qualified RIO.Char as C -import RIO.FilePath ( () ) -import qualified RIO.List as L -import qualified RIO.Map as M -import qualified RIO.NonEmpty as NE -import qualified RIO.Text as T -import qualified RIO.Text.Partial as TP +import qualified RIO.Char as C +import RIO.FilePath ( () ) +import qualified RIO.List as L +import qualified RIO.NonEmpty as NE +import qualified RIO.Text as T +--------------------------------- DATA TYPES --------------------------------- + -- | /RIO/ Environment for the @init@ command. data Env = Env { envLogFunc :: LogFunc @@ -81,6 +91,7 @@ , envPaths :: Paths } + -- | Paths to various locations of file system. data Paths = Paths { pConfigFile :: FilePath @@ -89,23 +100,26 @@ suffixLenses ''Env + instance HasLogFunc Env where logFuncL = envLogFuncL + instance Has CommandInitOptions Env where hasLens = envInitOptionsL + instance Has (FileSystem (RIO Env)) Env where hasLens = envFileSystemL + instance Has Paths Env where hasLens = envPathsL --------------------------------------------------------------------------------- env' :: CommandInitOptions -> LogFunc -> IO Env env' opts logFunc = do - let paths = Paths { pConfigFile = ".headroom.yaml" + let paths = Paths { pConfigFile = configFileName , pTemplatesDir = "headroom-templates" } pure $ Env { envLogFunc = logFunc @@ -114,6 +128,9 @@ , envPaths = paths } + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + -- | Handler for @init@ command. commandInit :: CommandInitOptions -- ^ @init@ command options @@ -129,6 +146,7 @@ paths <- viewL throwM . AppConfigAlreadyExists $ pConfigFile paths + -- | Recursively scans provided source paths for known file types for which -- templates can be generated. findSupportedFileTypes :: (Has CommandInitOptions env, HasLogFunc env) @@ -149,6 +167,22 @@ logInfo $ "Found supported file types: " <> displayShow fileTypes pure fileTypes + +-- | Checks whether application config file already exists. +doesAppConfigExist :: ( HasLogFunc env + , Has (FileSystem (RIO env)) env + , Has Paths env + ) + => RIO env Bool +doesAppConfigExist = do + FileSystem {..} <- viewL + Paths {..} <- viewL + logInfo "Verifying that there's no existing Headroom configuration..." + fsDoesFileExist pConfigFile + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + createTemplates :: (Has CommandInitOptions env, HasLogFunc env, Has Paths env) => [FileType] -> RIO env () @@ -158,6 +192,7 @@ mapM_ (\(p, lf) -> createTemplate pTemplatesDir lf p) (zipWithProgress $ fmap (cioLicenseType opts, ) fileTypes) + createTemplate :: (HasLogFunc env) => FilePath -> (LicenseType, FileType) @@ -172,38 +207,22 @@ [display progress, " Creating template file in ", fromString filePath] writeFileUtf8 filePath template + createConfigFile :: (Has CommandInitOptions env, HasLogFunc env, Has Paths env) => RIO env () createConfigFile = do opts <- viewL p@Paths {..} <- viewL logInfo $ "Creating YAML config file in " <> fromString pConfigFile - writeFileUtf8 pConfigFile (configuration opts p) + writeFileUtf8 pConfigFile $ enrich (modify opts p) configFileStub where - configuration opts paths = - let withSourcePaths = TP.replace - "source-paths: []" - (toYamlList "source-paths" $ cioSourcePaths opts) - withTemplatePaths = TP.replace - "template-paths: []" - (toYamlList "template-paths" [pTemplatesDir paths]) - in withTemplatePaths . withSourcePaths $ configFileStub - toYamlList field list = - T.stripEnd . prettyPrintYAML $ M.fromList [(field :: Text, list)] + modify opts paths = mconcat + [ replaceEmptyValue "version" $ withText (printVersion buildVersion) + , replaceEmptyValue "source-paths" $ withArray (cioSourcePaths opts) + , replaceEmptyValue "template-paths" $ withArray [pTemplatesDir paths] + ] --- | Checks whether application config file already exists. -doesAppConfigExist :: ( HasLogFunc env - , Has (FileSystem (RIO env)) env - , Has Paths env - ) - => RIO env Bool -doesAppConfigExist = do - FileSystem {..} <- viewL - Paths {..} <- viewL - logInfo "Verifying that there's no existing Headroom configuration..." - fsDoesFileExist pConfigFile --- | Creates directory for template files. makeTemplatesDir :: ( HasLogFunc env , Has (FileSystem (RIO env)) env , Has Paths env @@ -216,7 +235,7 @@ fsCreateDirectory pTemplatesDir ---------------------------------- Error Types -------------------------------- +--------------------------------- ERROR TYPES -------------------------------- -- | Exception specific to the "Headroom.Command.Init" module data CommandInitError @@ -228,18 +247,21 @@ -- ^ 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" +displayException' = \case + AppConfigAlreadyExists path -> [iii| + Configuration file '#{path}' already exists + |] + NoProvidedSourcePaths -> [iii| + No source code paths (files or directories) defined + |] + NoSupportedFileType -> [iii| + 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 @@ -5,7 +5,7 @@ {-| Module : Headroom.Command.Readers Description : Custom readers for /optparse-applicative/ library -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -19,28 +19,28 @@ ( licenseReader , licenseTypeReader , regexReader - , parseLicenseAndFileType + , parseLicense ) where -import Data.Either.Combinators ( maybeToRight ) -import Headroom.Configuration.Types ( LicenseType ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.Data.Regex ( Regex(..) - , compile - ) -import Headroom.FileType.Types ( FileType(..) ) +import Data.Either.Combinators ( maybeToRight ) +import Headroom.Configuration.Types ( LicenseType ) +import Headroom.Data.EnumExtra ( EnumExtra(..) ) +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 +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 +licenseReader = eitherReader parseLicense' where - parseLicense raw = maybeToRight errMsg (parseLicenseAndFileType $ T.pack raw) + parseLicense' raw = maybeToRight errMsg (parseLicense $ T.pack raw) errMsg = T.unpack $ mconcat [ "invalid license/file type, must be in format 'licenseType:fileType' " , "(e.g. bsd3:haskell)" @@ -64,19 +64,17 @@ -- | Reader for 'Regex'. regexReader :: ReadM Regex -regexReader = eitherReader parse - where parse input = mapLeft displayException (compile . T.pack $ input) +regexReader = + let parse input = mapLeft displayException (compile . T.pack $ input) + in eitherReader parse -- | Parses 'LicenseType' and 'FileType' from the input string, -- formatted as @licenseType:fileType@. -- --- >>> parseLicenseAndFileType "bsd3:haskell" +-- >>> parseLicense "bsd3:haskell" -- Just (BSD3,Haskell) -parseLicenseAndFileType :: Text -> Maybe (LicenseType, FileType) -parseLicenseAndFileType raw - | [rawLicenseType, rawFileType] <- TP.splitOn ":" raw = do - licenseType <- textToEnum rawLicenseType - fileType <- textToEnum rawFileType - pure (licenseType, fileType) - | otherwise = Nothing +parseLicense :: Text -> Maybe (LicenseType, FileType) +parseLicense raw + | [lt, ft] <- TP.splitOn ":" raw = (,) <$> textToEnum lt <*> textToEnum ft + | otherwise = Nothing 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 @@ -12,7 +12,7 @@ {-| Module : Headroom.Command.Run Description : Handler for the @run@ command. -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -29,93 +29,95 @@ , 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 - ) -import Headroom.Configuration.Types ( Configuration(..) - , CtConfiguration - , CtHeaderFnConfigs - , HeaderConfig(..) - , HeaderSyntax(..) - , LicenseType(..) - , PtConfiguration - , RunMode(..) - , TemplateSource(..) - ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Lens ( suffixLenses - , suffixLensesFor - ) -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 ( FileSystem(..) - , excludePaths - , fileExtension - , mkFileSystem - ) -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 ( CurrentYear(..) - , TemplateMeta(..) - ) -import Headroom.UI ( Progress(..) - , zipWithProgress - ) -import Headroom.Variables ( compileVariables - , dynamicVariables - , parseVariables - ) -import Headroom.Variables.Types ( Variables(..) ) +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 + ) +import Headroom.Configuration.Types ( Configuration(..) + , CtConfiguration + , CtHeaderFnConfigs + , HeaderConfig(..) + , HeaderSyntax(..) + , LicenseType(..) + , PtConfiguration + , RunMode(..) + , TemplateSource(..) + ) +import Headroom.Data.EnumExtra ( EnumExtra(..) ) +import Headroom.Data.Has ( Has(..) ) +import Headroom.Data.Lens ( suffixLenses + , suffixLensesFor + ) +import Headroom.Embedded ( defaultConfig + , licenseTemplate + ) +import Headroom.FileSupport ( analyzeSourceCode + , fileSupport + ) +import Headroom.FileSystem ( FileSystem(..) + , excludePaths + , fileExtension + , mkFileSystem + ) +import Headroom.FileType ( fileTypeByExt ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Header ( addHeader + , dropHeader + , extractHeaderInfo + , extractHeaderTemplate + , replaceHeader + ) +import Headroom.Header.Sanitize ( sanitizeSyntax ) +import Headroom.Header.Types ( HeaderInfo(..) + , HeaderTemplate(..) + ) +import Headroom.HeaderFn ( mkConfiguredEnv + , postProcessHeader + ) +import Headroom.Meta ( TemplateType + , configFileName + , productInfo + ) +import Headroom.SourceCode ( SourceCode + , toText + ) +import Headroom.Template ( Template(..) ) +import Headroom.Types ( CurrentYear(..) ) +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 -import qualified RIO.Map as M -import qualified RIO.Text as T +import RIO.FilePath ( takeBaseName ) +import qualified RIO.List as L +import qualified RIO.Map as M +import qualified RIO.Text as T suffixLensesFor ["cHeaderFnConfigs"] ''Configuration -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 + , raFunc :: SourceCode -> SourceCode -- ^ function to process the file , raProcessedMsg :: Text -- ^ message to show when file was processed @@ -199,7 +201,7 @@ let isCheck = cRunMode == Check warnOnDryRun startTS <- liftIO getPOSIXTime - templates <- withTemplateMeta <$> loadTemplates + templates <- loadTemplates sourceFiles <- findSourceFiles (M.keys templates) (total, processed) <- processSourceFiles templates sourceFiles endTS <- liftIO getPOSIXTime @@ -253,24 +255,21 @@ , Has CurrentYear env , HasLogFunc env ) - => TemplatesMap + => Map FileType HeaderTemplate -> [FilePath] -> RIO env (Int, Int) processSourceFiles templates paths = do Configuration {..} <- viewL year <- viewL let dVars = dynamicVariables year - withFileType = mapMaybe (findFileType cLicenseHeaders) paths - withTemplate = mapMaybe (uncurry findTemplate) withFileType + withTemplate = mapMaybe (template cLicenseHeaders) paths 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 cVars dVars (pr, ((tm, tt), ft, p)) = - processSourceFile cVars dVars pr tm tt ft p + fileType c p = fileExtension p >>= fileTypeByExt c + template c p = (, p) <$> (fileType c p >>= \ft -> M.lookup ft templates) + process cVars dVars (pr, (ht, p)) = processSourceFile cVars dVars pr ht p processSourceFile :: ( Has CommandRunOptions env @@ -282,42 +281,39 @@ => Variables -> Variables -> Progress - -> Maybe TemplateMeta - -> TemplateType - -> FileType + -> HeaderTemplate -> FilePath -> RIO env Bool -processSourceFile cVars dVars progress meta template fileType path = do +processSourceFile cVars dVars progress ht@HeaderTemplate {..} path = do Configuration {..} <- viewL @CtConfiguration CommandRunOptions {..} <- viewL fileContent <- readFileUtf8 path - let fileInfo@FileInfo {..} = extractFileInfo - fileType - (configByFileType cLicenseHeaders fileType) - meta - fileContent - variables = dVars <> cVars <> fiVariables - syntax = hcHeaderSyntax fiHeaderConfig - header' <- renderTemplate variables template + let fs = fileSupport htFileType + source = analyzeSourceCode fs fileContent + headerInfo@HeaderInfo {..} = extractHeaderInfo ht source + variables = dVars <> cVars <> hiVariables + syntax = hcHeaderSyntax hiHeaderConfig + header' <- renderTemplate variables htTemplate header <- postProcessHeader' syntax variables header' - RunAction {..} <- chooseAction fileInfo header - let result = raFunc fileContent - changed = raProcessed && (fileContent /= result) + RunAction {..} <- chooseAction headerInfo header + let result = raFunc source + changed = raProcessed && (source /= result) message = if changed then raProcessedMsg else raSkippedMsg isCheck = cRunMode == Check - logDebug $ "File info: " <> displayShow fileInfo + logDebug $ "Header info: " <> displayShow headerInfo logInfo $ mconcat [display progress, " ", display message, fromString path] - when (not croDryRun && not isCheck && changed) (writeFileUtf8 path result) + when (not croDryRun && not isCheck && changed) + (writeFileUtf8 path $ toText result) pure changed chooseAction :: (Has CtConfiguration env) - => FileInfo + => HeaderInfo -> Text -> RIO env RunAction chooseAction info header = do Configuration {..} <- viewL @CtConfiguration - let hasHeader = isJust $ fiHeaderPos info + let hasHeader = isJust $ hiHeaderPos info pure $ go cRunMode hasHeader where go runMode hasHeader = case runMode of @@ -358,7 +354,7 @@ withTypes <- catMaybes <$> mapM (\p -> fmap (, p) <$> typeOfTemplate p) paths parsed <- mapM (\(t, p) -> - (t, ) <$> ((T.strip <$> fsLoadFile p) >>= parseTemplate (Just $ T.pack p)) + (t, ) <$> (fsLoadFile p >>= parseTemplate (Just $ T.pack p) . T.strip) ) withTypes logInfo @@ -387,17 +383,13 @@ , Has (FileSystem (RIO env)) env , HasLogFunc env ) - => RIO env (Map FileType TemplateType) + => RIO env (Map FileType HeaderTemplate) loadTemplates = do Configuration {..} <- viewL @CtConfiguration - case cTemplateSource of + templates <- 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))) + pure $ M.mapWithKey (extractHeaderTemplate cLicenseHeaders) templates -- | Takes path to the template file and returns detected type of the template. @@ -425,7 +417,9 @@ , 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 " + , "'headroom gen -c >" + , configFileName + , "'. See official documentation " , "for more details." ] pure Nothing @@ -437,7 +431,7 @@ logInfo $ display productInfo defaultConfig' <- Just <$> parseConfiguration defaultConfig cmdLineConfig <- Just <$> optionsToConfiguration - yamlConfig <- loadConfigurationSafe ".headroom.yaml" + yamlConfig <- loadConfigurationSafe configFileName let mergedConfig = mconcat . catMaybes $ [defaultConfig', yamlConfig, cmdLineConfig] config <- makeConfiguration mergedConfig @@ -476,7 +470,7 @@ -- | Performs post-processing on rendered /license header/, based on given -- configuration. Currently the main points are to: -- --- 1. sanitize possibly corrupted comment syntax ('sanitizeHeader') +-- 1. sanitize possibly corrupted comment syntax ('sanitizeSyntax') -- 2. apply /license header functions/ ('postProcessHeader') postProcessHeader' :: (Has CtHeaderFnConfigs env, Has CurrentYear env) => HeaderSyntax @@ -491,23 +485,4 @@ 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 + pure . sanitizeSyntax syntax . postProcessHeader cEnv $ rawHeader diff --git a/src/Headroom/Command/Types.hs b/src/Headroom/Command/Types.hs --- a/src/Headroom/Command/Types.hs +++ b/src/Headroom/Command/Types.hs @@ -4,7 +4,7 @@ {-| Module : Headroom.Command.Types Description : Data types for "Headroom.Command" -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -21,13 +21,13 @@ ) where -import Headroom.Configuration.Types ( GenMode - , LicenseType - , RunMode - , TemplateSource - ) -import Headroom.Data.Regex ( Regex ) -import Headroom.FileType.Types ( FileType ) +import Headroom.Configuration.Types ( GenMode + , LicenseType + , RunMode + , TemplateSource + ) +import Headroom.Data.Regex ( Regex ) +import Headroom.FileType.Types ( FileType ) import RIO 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 @@ -3,7 +3,7 @@ {-| Module : Headroom.Command.Utils Description : Shared code for individual command handlers -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental diff --git a/src/Headroom/Configuration.hs b/src/Headroom/Configuration.hs --- a/src/Headroom/Configuration.hs +++ b/src/Headroom/Configuration.hs @@ -7,7 +7,7 @@ {-| Module : Headroom.Configuration Description : Configuration handling (loading, parsing, validating) -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -30,34 +30,38 @@ ) where -import Data.Monoid ( Last(..) ) -import qualified Data.Yaml as Y -import Headroom.Configuration.Types ( Configuration(..) - , ConfigurationError(..) - , ConfigurationKey(..) - , CtConfiguration - , CtHeaderConfig - , CtHeaderFnConfig - , CtHeaderFnConfigs - , CtHeadersConfig - , CtUpdateCopyrightConfig - , HeaderConfig(..) - , HeaderFnConfig(..) - , HeaderFnConfigs(..) - , HeadersConfig(..) - , Phase(..) - , PtConfiguration - , PtHeaderConfig - , PtHeaderFnConfig - , PtHeaderFnConfigs - , PtHeadersConfig - , PtUpdateCopyrightConfig - , UpdateCopyrightConfig(..) - ) -import Headroom.Data.Lens ( suffixLenses ) -import Headroom.FileType.Types ( FileType(..) ) +import Data.Monoid ( Last(..) ) +import qualified Data.Yaml as Y +import Headroom.Configuration.Compat ( checkCompatibility ) +import Headroom.Configuration.Types ( Configuration(..) + , ConfigurationError(..) + , ConfigurationKey(..) + , CtConfiguration + , CtHeaderConfig + , CtHeaderFnConfig + , CtHeaderFnConfigs + , CtHeadersConfig + , CtUpdateCopyrightConfig + , HeaderConfig(..) + , HeaderFnConfig(..) + , HeaderFnConfigs(..) + , HeadersConfig(..) + , Phase(..) + , PtConfiguration + , PtHeaderConfig + , PtHeaderFnConfig + , PtHeaderFnConfigs + , PtHeadersConfig + , PtUpdateCopyrightConfig + , UpdateCopyrightConfig(..) + ) +import Headroom.Data.Lens ( suffixLenses ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Meta ( buildVersion + , configBreakingChanges + ) import RIO -import qualified RIO.ByteString as B +import qualified RIO.ByteString as B suffixLenses ''HeaderFnConfig @@ -65,18 +69,19 @@ suffixLenses ''UpdateCopyrightConfig +------------------------------ PUBLIC FUNCTIONS ------------------------------ + -- | Loads and parses application configuration from given /YAML/ file. -loadConfiguration :: MonadIO m - => FilePath - -- ^ path to /YAML/ configuration file - -> m PtConfiguration - -- ^ parsed configuration -loadConfiguration path = liftIO $ B.readFile path >>= parseConfiguration +loadConfiguration :: (MonadIO m, MonadThrow m) => FilePath -> m PtConfiguration +loadConfiguration path = do + content <- liftIO $ B.readFile path + _ <- checkCompatibility configBreakingChanges buildVersion content + parseConfiguration content -- | Parses application configuration from given raw input in /YAML/ format. parseConfiguration :: MonadThrow m - => B.ByteString + => ByteString -- ^ raw input to parse -> m PtConfiguration -- ^ parsed application configuration @@ -132,14 +137,20 @@ makeHeaderConfig fileType pt = do hcFileExtensions <- lastOrError (CkFileExtensions fileType) (hcFileExtensions pt) - hcMarginAfter <- lastOrError (CkMarginAfter fileType) (hcMarginAfter pt) - hcMarginBefore <- lastOrError (CkMarginBefore fileType) (hcMarginBefore pt) + hcMarginTopCode <- lastOrError (CkMarginTopCode fileType) (hcMarginTopCode pt) + hcMarginTopFile <- lastOrError (CkMarginTopFile fileType) (hcMarginTopFile pt) + hcMarginBottomCode <- lastOrError (CkMarginBottomCode fileType) + (hcMarginBottomCode pt) + hcMarginBottomFile <- lastOrError (CkMarginBottomFile fileType) + (hcMarginBottomFile pt) hcPutAfter <- lastOrError (CkPutAfter fileType) (hcPutAfter pt) hcPutBefore <- lastOrError (CkPutBefore fileType) (hcPutBefore pt) hcHeaderSyntax <- lastOrError (CkHeaderSyntax fileType) (hcHeaderSyntax pt) pure HeaderConfig { .. } +------------------------------ PRIVATE FUNCTIONS ----------------------------- + makeHeaderFnConfigs :: MonadThrow m => PtHeaderFnConfigs -> m CtHeaderFnConfigs makeHeaderFnConfigs pt = do hfcsUpdateCopyright <- makeHeaderFnConfig (pt ^. hfcsUpdateCopyrightL) @@ -163,9 +174,6 @@ makeUpdateCopyrightConfig pt = do let uccSelectedAuthors = lastOrNothing $ pt ^. uccSelectedAuthorsL pure UpdateCopyrightConfig { .. } - - ------------------------------- Private Functions ----------------------------- lastOrError :: MonadThrow m => ConfigurationKey -> Last a -> m a diff --git a/src/Headroom/Configuration/Compat.hs b/src/Headroom/Configuration/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Configuration/Compat.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} + +{-| +Module : Headroom.Configuration.Compat +Description : Compatibility checks for YAML configuration +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains functions and data types used for checking compatibility of +user's YAML configuration with current version of Headroom. +-} + +module Headroom.Configuration.Compat + ( VersionError(..) + , checkCompatibility + ) +where + +import Data.Aeson ( FromJSON(..) + , withObject + , (.:) + ) +import Data.String.Interpolate ( iii ) +import qualified Data.Yaml as Y +import Headroom.Meta ( buildVersion + , configFileName + , productName + , webDocMigration + ) +import Headroom.Meta.Version ( Version(..) + , printVersionP + , pvp + ) +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +import RIO +import qualified RIO.List as L + + +--------------------------------- DATA TYPES --------------------------------- + +newtype VersionObj = VersionObj Version deriving (Eq, Show) + +instance FromJSON VersionObj where + parseJSON = withObject "VersionObj" $ \obj -> do + version <- obj .: "version" + pure $ VersionObj version + + +--------------------------------- ERROR TYPES -------------------------------- + +-- | Exception specific to the "Headroom.Configuration.Compat" module. +data VersionError + = CannotParseVersion + -- ^ cannot parse version info from given YAML configuration + | NewerVersionDetected Version + -- ^ configuration has newer version than Headroom + | UnsupportedVersion [Version] Version + -- ^ given YAML configuration is not compatible + deriving (Eq, Show) + + +instance Exception VersionError where + displayException = displayException' + toException = toHeadroomError + fromException = fromHeadroomError + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Checks whether the given not yet parsed YAML configuration is compatible, +-- using list of versions that caused breaking changes into configuration. +checkCompatibility :: MonadThrow m + => [Version] + -- ^ list of versions with breaking changes in configuration + -> Version + -- ^ current Headroom version + -> ByteString + -- ^ raw, not yet parsed YAML configuration + -> m Version + -- ^ detected compatible version or error +checkCompatibility breakingVersions current raw = do + VersionObj version <- parseObj + _ <- checkBreakingChanges breakingVersions version + _ <- checkNewerVersion current version + pure version + where + parseObj = either (const . throwM $ CannotParseVersion) pure decoded + decoded = Y.decodeEither' raw + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +checkBreakingChanges :: MonadThrow m => [Version] -> Version -> m () +checkBreakingChanges vs v = case L.filter (v <) . L.sort $ vs of + [] -> pure () + newer -> throwM $ UnsupportedVersion newer v + + +checkNewerVersion :: MonadThrow m => Version -> Version -> m () +checkNewerVersion current checked = + if current < checked then throwM $ NewerVersionDetected checked else pure () + + +displayException' :: VersionError -> String +displayException' = \case + CannotParseVersion -> [iii| + Cannot find 'version' key in #{configFileName :: String} configuration + file. This field is required to check whether your current configuration + is compatible with installed version of #{productName}. This functionality + has been added in version 0.4.0.0, please see following migration guide + for more details on how to proceed: + #{"\n\t" <> webDocMigration v0400} + |] + NewerVersionDetected version -> [iii| + The version set in your #{configFileName :: String} configuration file + (#{printVersionP version}) is newer than version of installed + #{productName} (#{printVersionP buildVersion}). Please upgrade + #{productName} first. + |] + UnsupportedVersion versions version -> [iii| + Your #{configFileName :: String} configuration file has version + #{printVersionP version}, which is incompatible with current version of + #{productName} (#{printVersionP buildVersion}). Please perform steps + described in these migration guides first (in given order): + #{migrationGuides versions} + |] + where + v0400 = [pvp|0.4.0.0|] + migrationGuides = mconcat . fmap (\v -> "\n\t- " <> webDocMigration v) diff --git a/src/Headroom/Configuration/Enrich.hs b/src/Headroom/Configuration/Enrich.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Configuration/Enrich.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} + +{-| +Module : Headroom.Configuration.Enrich +Description : Simple enrichment of YAML configuration stubs +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains mini-DSL for enrichment of generated /YAML/ configurations, +i.e. replacing default values with real ones, etc. This is intentionally done +without the "Data.Yaml" and parsing, because that way all comments inside YAML +file would be lost. +-} + +module Headroom.Configuration.Enrich + ( -- * Data Types + Enrich(..) + , ValueType(..) + -- * Field Generators + , withArray + , withText + -- * Field Manipulation + , replaceEmptyValue + ) +where + +import Data.Aeson ( ToJSON(..) ) +import Headroom.Serialization ( prettyPrintYAML ) +import RIO +import qualified RIO.Map as M +import qualified RIO.Text as T +import qualified RIO.Text.Partial as TP + + +--------------------------------- DATA TYPES --------------------------------- + +-- | Simple wrapper representing single step of enrichment. +newtype Enrich = Enrich + { enrich :: Text -> Text + -- ^ takes input text and does enrichment + } + + +instance Semigroup Enrich where + Enrich fnA <> Enrich fnB = Enrich $ fnA . fnB + + +instance Monoid Enrich where + mempty = Enrich id + + +-- | Represents type of the field value. +data ValueType + = Array + -- ^ type of /YAML/ array + | String + -- ^ type of /YAML/ string + deriving (Eq, Show) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Generates /YAML/ array field from given list and field name. +withArray :: ToJSON a + => [a] + -- ^ input list used as value + -> Text + -- ^ field name + -> (ValueType, Text) + -- ^ generated fields as @(valueType, generatedField)@ +withArray list field = (Array, asYAML field list) + + +-- | Generates /YAML/ string from given text value and field name. +withText :: Text + -- ^ input text value + -> Text + -- ^ field name + -> (ValueType, Text) + -- ^ generated fields as @(valueType, generatedField)@ +withText text field = (String, asYAML field text) + + +-- | Replaces empty value of given field with actual generated value. +replaceEmptyValue :: Text + -- ^ field name + -> (Text -> (ValueType, Text)) + -- ^ field value generator function + -> Enrich + -- ^ resulting enrichment step +replaceEmptyValue field replaceFn = Enrich $ \doc -> do + TP.replace old new doc + where + (tpe, new) = replaceFn field + old = field <> ": " <> emptyValue tpe + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +asYAML :: ToJSON a => Text -> a -> Text +asYAML field value = T.stripEnd . prettyPrintYAML $ M.fromList [(field, value)] + + +emptyValue :: ValueType -> Text +emptyValue Array = "[]" +emptyValue String = "\"\"" diff --git a/src/Headroom/Configuration/Types.hs b/src/Headroom/Configuration/Types.hs --- a/src/Headroom/Configuration/Types.hs +++ b/src/Headroom/Configuration/Types.hs @@ -1,11 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} @@ -16,7 +18,7 @@ {-| Module : Headroom.Configuration.Types Description : Data types for /Headroom/ configuration -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -69,25 +71,30 @@ ) 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.Regex ( Regex(..) ) -import Headroom.FileType.Types ( FileType ) -import Headroom.Serialization ( aesonOptions ) -import Headroom.Types ( fromHeadroomError - , toHeadroomError - ) -import Headroom.Variables.Types ( Variables(..) ) +import Control.Exception ( throw ) +import Data.Aeson ( FromJSON(..) + , Value(String) + , genericParseJSON + , withObject + , (.!=) + , (.:?) + ) +import Data.Monoid ( Last(..) ) +import Data.String.Interpolate ( i + , iii + ) +import Generic.Data ( Generically(..) ) +import Headroom.Data.EnumExtra ( EnumExtra(..) ) +import Headroom.Data.Regex ( Regex(..) ) +import Headroom.FileType.Types ( FileType ) +import Headroom.Meta ( webDocConfigCurr ) +import Headroom.Serialization ( aesonOptions ) +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +import Headroom.Variables.Types ( Variables(..) ) import RIO -import qualified RIO.Text as T +import qualified RIO.Text as T ------------------------------------ Phase ----------------------------------- @@ -112,17 +119,17 @@ -- | Syntax of the license header comment. data HeaderSyntax - = BlockComment Text Text + = BlockComment Regex Regex (Maybe Text) -- ^ block (multi-line) comment syntax (e.g. @/* */@) - | LineComment Text + | LineComment Regex (Maybe Text) -- ^ single line comment syntax (e.g. @//@) deriving (Eq, Show) -- | Internal representation of the block style of 'HeaderSyntax'. data BlockComment' = BlockComment' - { bcStartsWith :: Text + { bcStartsWith :: Regex -- ^ starting pattern (e.g. @/*@) - , bcEndsWith :: Text + , bcEndsWith :: Regex -- ^ ending pattern (e.g. @*/@) } deriving (Eq, Generic, Show) @@ -132,7 +139,7 @@ -- | Internal representation of the line style of 'HeaderSyntax'. newtype LineComment' = LineComment' - { lcPrefixedBy :: Text + { lcPrefixedBy :: Regex -- ^ prefix of the comment line (e.g. @//@) } deriving (Eq, Generic, Show) @@ -226,21 +233,18 @@ deriving instance Eq PtUpdateCopyrightConfig deriving instance Show CtUpdateCopyrightConfig deriving instance Show PtUpdateCopyrightConfig +deriving instance Generic PtUpdateCopyrightConfig +deriving via (Generically PtUpdateCopyrightConfig) + instance Semigroup PtUpdateCopyrightConfig +deriving via (Generically PtUpdateCopyrightConfig) + instance Monoid 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/. @@ -262,14 +266,12 @@ 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 - } +deriving instance Generic (PtHeaderFnConfig c) -instance Monoid (c 'Partial) => Monoid (PtHeaderFnConfig c) where - mempty = HeaderFnConfig mempty mempty +deriving via (Generically (PtHeaderFnConfig c)) + instance Semigroup (c 'Partial) => Semigroup (PtHeaderFnConfig c) +deriving via (Generically (PtHeaderFnConfig c)) + instance Monoid (c 'Partial) => Monoid (PtHeaderFnConfig c) instance (FromJSON (c 'Partial), Monoid (c 'Partial)) => FromJSON (PtHeaderFnConfig c) where parseJSON = withObject "PtHeaderFnConfig" $ \obj -> do @@ -297,14 +299,12 @@ deriving instance Eq PtHeaderFnConfigs deriving instance Show CtHeaderFnConfigs deriving instance Show PtHeaderFnConfigs - -instance Semigroup PtHeaderFnConfigs where - x <> y = HeaderFnConfigs - { hfcsUpdateCopyright = hfcsUpdateCopyright x <> hfcsUpdateCopyright y - } +deriving instance Generic PtHeaderFnConfigs -instance Monoid PtHeaderFnConfigs where - mempty = HeaderFnConfigs mempty +deriving via (Generically PtHeaderFnConfigs) + instance Semigroup PtHeaderFnConfigs +deriving via (Generically PtHeaderFnConfigs) + instance Monoid PtHeaderFnConfigs instance FromJSON PtHeaderFnConfigs where parseJSON = withObject "PtHeaderFnConfigs" $ \obj -> do @@ -342,7 +342,14 @@ deriving instance Eq PtConfiguration deriving instance Show CtConfiguration deriving instance Show PtConfiguration +deriving instance Generic PtConfiguration +deriving via (Generically PtConfiguration) + instance Semigroup PtConfiguration +deriving via (Generically PtConfiguration) + instance Monoid PtConfiguration + + instance FromJSON PtConfiguration where parseJSON = withObject "PtConfiguration" $ \obj -> do cRunMode <- Last <$> obj .:? "run-mode" @@ -355,36 +362,26 @@ 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] + { 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] + , hcMarginTopCode :: p ::: Int + -- ^ margin between header top and preceding code (if present) + , hcMarginTopFile :: p ::: Int + -- ^ margin between header top and start of file (if no code is between) + , hcMarginBottomCode :: p ::: Int + -- ^ margin between header bottom and following code (if present) + , hcMarginBottomFile :: p ::: Int + -- ^ margin between header bottom and end of file (if no code is between) + , hcPutAfter :: p ::: [Regex] -- ^ /regexp/ patterns after which to put the header - , hcPutBefore :: p ::: [Regex] + , hcPutBefore :: p ::: [Regex] -- ^ /regexp/ patterns before which to put the header - , hcHeaderSyntax :: p ::: HeaderSyntax + , hcHeaderSyntax :: p ::: HeaderSyntax -- ^ syntax of the license header comment } @@ -398,37 +395,31 @@ deriving instance Eq PtHeaderConfig deriving instance Show CtHeaderConfig deriving instance Show PtHeaderConfig +deriving instance Generic PtHeaderConfig +deriving via (Generically PtHeaderConfig) + instance Semigroup PtHeaderConfig +deriving via (Generically PtHeaderConfig) + instance Monoid 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 + hcFileExtensions <- Last <$> obj .:? "file-extensions" + hcMarginTopCode <- Last <$> obj .:? "margin-top-code" + hcMarginTopFile <- Last <$> obj .:? "margin-top-file" + hcMarginBottomCode <- Last <$> obj .:? "margin-bottom-code" + hcMarginBottomFile <- Last <$> obj .:? "margin-bottom-file" + hcPutAfter <- Last <$> obj .:? "put-after" + hcPutBefore <- Last <$> obj .:? "put-before" + blockComment <- obj .:? "block-comment" + lineComment <- obj .:? "line-comment" + hcHeaderSyntax <- pure . Last $ syntax 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 - } - + syntax (Just (BlockComment' s e)) Nothing = Just $ BlockComment s e Nothing + syntax Nothing (Just (LineComment' p)) = Just $ LineComment p Nothing + syntax Nothing Nothing = Nothing + syntax _ _ = throw MixedHeaderSyntax -------------------------------- HeadersConfig ------------------------------- @@ -468,7 +459,13 @@ deriving instance Eq PtHeadersConfig deriving instance Show CtHeadersConfig deriving instance Show PtHeadersConfig +deriving instance Generic PtHeadersConfig +deriving via (Generically PtHeadersConfig) + instance Semigroup PtHeadersConfig +deriving via (Generically PtHeadersConfig) + instance Monoid PtHeadersConfig + instance FromJSON PtHeadersConfig where parseJSON = withObject "PartialHeadersConfig" $ \obj -> do hscC <- obj .:? "c" .!= mempty @@ -485,35 +482,6 @@ 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 - , hscPureScript = hscPureScript x <> hscPureScript 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 - mempty - - --------------------------------- Error Types -------------------------------- -- | Represents single key in the configuration. @@ -522,10 +490,14 @@ -- ^ 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@ + | CkMarginTopCode FileType + -- ^ no configuration for margin between header top and preceding code + | CkMarginTopFile FileType + -- ^ no configuration for margin between header top and start of file + | CkMarginBottomCode FileType + -- ^ no configuration for margin between header bottom and following code + | CkMarginBottomFile FileType + -- ^ no configuration for margin between header bottom and end of file | CkPutAfter FileType -- ^ no configuration for @put-after@ | CkPutBefore FileType @@ -558,6 +530,7 @@ toException = toHeadroomError fromException = fromHeadroomError + displayException' :: ConfigurationError -> String displayException' = T.unpack . \case MissingConfiguration key -> case key of @@ -569,13 +542,22 @@ (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") + CkMarginTopCode fileType -> missingConfig + (withFT "margin-top-code" fileType) + (Just "margin-top-code") Nothing + CkMarginTopFile fileType -> missingConfig + (withFT "margin-top-file" fileType) + (Just "margin-top-file") + Nothing + CkMarginBottomCode fileType -> missingConfig + (withFT "margin-bottom-code" fileType) + (Just "margin-bottom-code") + Nothing + CkMarginBottomFile fileType -> missingConfig + (withFT "margin-bottom-file" fileType) + (Just "margin-bottom-file") + Nothing CkPutAfter fileType -> missingConfig (withFT "put-after" fileType) (Just "put-after") Nothing CkPutBefore fileType -> @@ -602,24 +584,21 @@ 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." - ] + withFT msg fileType = [i|#{msg :: Text} (#{fileType})|] + mixedHeaderSyntax = [iii| + 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." - ] +missingConfig desc yaml cli = [iii| + Missing configuration for '#{desc}' (#{options}). See following page for + more details: #{webDocConfigCurr} + |] where - cliText = fmap (\c -> "command line option '" <> c <> "'") cli - yamlText = fmap (\y -> "YAML option '" <> y <> "'") yaml + cliText = fmap (\c -> [i|command line option '#{c}'|]) cli + yamlText = fmap (\c -> [i|YAML option '#{c}'|]) yaml options = T.intercalate " or " . catMaybes $ [cliText, yamlText] diff --git a/src/Headroom/Data/Coerce.hs b/src/Headroom/Data/Coerce.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Data/Coerce.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Headroom.Data.Coerce +Description : Extra functionality for coercion +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module provides some extra functionality extending the "Data.Coerce" +module. +-} + +module Headroom.Data.Coerce + ( coerce + , inner + ) +where + +import Data.Coerce ( Coercible + , coerce + ) +import RIO + + +-- | Allows to map the coercible value. This might be useful for example to +-- change the value within @newtype@, without manually unwrapping and wrapping +-- the value. +-- +-- >>> import qualified RIO.Text as T +-- >>> newtype Foo = Foo Text deriving (Eq, Show) +-- >>> inner T.toUpper (Foo "hello") +-- Foo "HELLO" +inner :: (Coercible a b) + => (b -> b) + -- ^ function to modify coerced value + -> a + -- ^ value to modify + -> a + -- ^ modified value +inner f = coerce . f . coerce 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 @@ -6,21 +6,22 @@ {-| Module : Headroom.Data.EnumExtra Description : Extra functionality for enum types -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental Portability : POSIX -Provides extended functionality for enum-like types, e.g. reading/writing +Provides extra functionality for enum-like types, e.g. reading/writing from/to textual representation, etc. -} module Headroom.Data.EnumExtra where import RIO -import qualified RIO.List as L -import qualified RIO.Text as T +import qualified RIO.List as L +import qualified RIO.Text as T + -- | Enum data type, capable to (de)serialize itself from/to string -- representation. Can be automatically derived by /GHC/ using the diff --git a/src/Headroom/Data/Has.hs b/src/Headroom/Data/Has.hs --- a/src/Headroom/Data/Has.hs +++ b/src/Headroom/Data/Has.hs @@ -4,7 +4,7 @@ {-| Module : Headroom.Data.Has Description : Simplified variant of @Data.Has@ -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -21,17 +21,24 @@ import RIO + -- | Implementation of the /Has type class/ pattern. class Has a t where + {-# MINIMAL getter, modifier | hasLens #-} + + getter :: t -> a getter = getConst . hasLens Const + modifier :: (a -> a) -> t -> t modifier f t = runIdentity (hasLens (Identity . f) t) + hasLens :: Lens' t a hasLens afa t = (\a -> modifier (const a) t) <$> afa (getter t) + viewL :: MonadReader t m => m a viewL = view hasLens diff --git a/src/Headroom/Data/Lens.hs b/src/Headroom/Data/Lens.hs --- a/src/Headroom/Data/Lens.hs +++ b/src/Headroom/Data/Lens.hs @@ -3,7 +3,7 @@ {-| Module : Headroom.Data.Lens Description : Custom functionality related to /lens/ -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -18,14 +18,14 @@ ) 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 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 diff --git a/src/Headroom/Data/Regex.hs b/src/Headroom/Data/Regex.hs --- a/src/Headroom/Data/Regex.hs +++ b/src/Headroom/Data/Regex.hs @@ -9,7 +9,7 @@ {-| Module : Headroom.Data.Regex Description : Helper functions for regular expressions -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -26,34 +26,48 @@ -- * Regex Functions , compile , match + , isMatch , re , replace + , replaceFirst , scan -- * Unsafe Functions , compileUnsafe ) 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 Data.Aeson ( FromJSON(..) + , Value(String) + ) +import Data.String.Interpolate ( iii ) +import Headroom.Data.Coerce ( coerce ) +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +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 +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.Base as PL + ( Regex(..) ) +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) +newtype Regex = Regex PL.Regex + +instance Eq Regex where + Regex (PL.Regex _ r1) == Regex (PL.Regex _ r2) = r1 == r2 + + +instance Show Regex where + show (Regex (PL.Regex _ r)) = show r + + instance FromJSON Regex where parseJSON (String s) = pure . compileUnsafe $ s parseJSON val = error $ "Invalid value: expected regex, found: " <> show val @@ -73,7 +87,7 @@ where compile' = Regex <$> PH.compileM (encodeUtf8 raw) [PLC.utf8] --- | Same as 'match', but works with 'Text' and uses no additional options. +-- | Same as 'PLC.match', but works with 'Text' and uses no additional options. match :: Regex -- ^ a PCRE regular expression value produced by compile -> Text @@ -83,6 +97,17 @@ match (Regex r) subject = fmap T.pack <$> PLC.match r (T.unpack subject) [] +-- | Same as 'match', but instead of returning matched text it only indicates +-- whether the given text matches the pattern or not. +isMatch :: Regex + -- ^ a PCRE regular expression value produced by compile + -> Text + -- ^ the subject text to match against + -> Bool + -- ^ the result value +isMatch regex subject = isJust $ match regex subject + + -- | A QuasiQuoter for regular expressions that does a compile time check. re :: QuasiQuoter re = QuasiQuoter { quoteExp = quoteExpRegex @@ -90,20 +115,35 @@ , quoteType = undefined , quoteDec = undefined } + where + quoteExpRegex txt = [| compileUnsafe . T.pack $ txt |] + where !_ = compileUnsafe . T.pack $ txt -- check at compile time -- | Replaces all occurences of given /regex/. replace :: Regex - -- ^ /regex/ to match what to replace + -- ^ pattern 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 +replace = PH.gsub . coerce +-- | Replaces only first occurence of given /regex/. +replaceFirst :: Regex + -- ^ pattern to replace + -> (Text -> [Text] -> Text) + -- ^ replacement function (as @fullMatch -> [groups] -> result@) + -> Text + -- ^ text to replace in + -> Text + -- ^ resulting text +replaceFirst = PH.sub . coerce + + -- | Searches the text for all occurences of given /regex/. scan :: Regex -- ^ /regex/ to search for @@ -111,7 +151,7 @@ -- ^ input text -> [(Text, [Text])] -- ^ found occurences (as @[(fullMatch, [groups])]@) -scan (Regex regex) = PH.scan regex +scan = PH.scan . coerce -- | Compiles the given text into /regex/ in runtime. Note that if the /regex/ @@ -126,14 +166,7 @@ Right res -> res ------------------------------- PRIVATE FUNCTIONS ----------------------------- - -quoteExpRegex :: String -> ExpQ -quoteExpRegex txt = [| compileUnsafe . T.pack $ txt |] - where !_ = compileUnsafe . T.pack $ txt -- check at compile time - - ---------------------------------- Error Types -------------------------------- +--------------------------------- ERROR TYPES -------------------------------- -- | Exception specific to the "Headroom.Data.Regex" module. data RegexError = CompilationFailed Text Text @@ -146,6 +179,7 @@ fromException = fromHeadroomError displayException' :: RegexError -> String -displayException' = T.unpack . \case - CompilationFailed raw reason -> - mconcat ["Cannot compile regex from input '", raw, "', reason: ", reason] +displayException' = \case + CompilationFailed raw reason -> [iii| + Cannot compile regex from input '#{raw}', reason: #{reason} + |] diff --git a/src/Headroom/Data/Text.hs b/src/Headroom/Data/Text.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Data/Text.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Headroom.Data.Text +Description : Additional utilities for text manipulation +Copyright : (c) 2019-2021 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.Text + ( read + , commonLinesPrefix + , replaceFirst + -- * Working with text lines + , mapLines + , mapLinesF + , fromLines + , toLines + ) +where + +import RIO +import qualified RIO.Text as T +import qualified RIO.Text.Partial as TP + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Similar to 'T.commonPrefixes', but tries to find common prefix for all +-- lines in given text. +-- +-- >>> commonLinesPrefix "-- first\n-- second\n-- third" +-- Just "-- " +commonLinesPrefix :: Text + -- ^ lines of text to find prefix for + -> Maybe Text + -- ^ found longest common prefixs +commonLinesPrefix text = go (toLines text) Nothing + where + go [] acc = acc + go (x : xs) Nothing = go xs (Just x) + go (x : xs) (Just acc) = case T.commonPrefixes x acc of + Just (n, _, _) -> go xs (Just n) + _ -> Nothing + + +-- | Similar to 'T.replace', but replaces only very first occurence of pattern. +-- +-- >>> replaceFirst ":" "/" "a : b : c" +-- "a / b : c" +replaceFirst :: Text -> Text -> Text -> Text +replaceFirst ptrn substitution text | T.null ptrn || T.null back = text + | otherwise = processed + where + (front, back) = TP.breakOn ptrn text + processed = mconcat [front, substitution, T.drop (T.length ptrn) back] + + +-- | 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 + -- ^ resulting text +mapLines fn = mapLinesF (Just <$> fn) + + +-- | Similar to 'mapLines', but the mapping function returns 'Foldable', which +-- gives some more control over outcome. After mapping over all individual +-- lines, results are folded and concatenated, which allows for example +-- filtering out some lines. +-- +-- >>> mapLinesF (\l -> if l == "bar" then Nothing else Just l) "foo\nbar" +-- "foo" +mapLinesF :: Foldable t + => (Text -> t Text) + -- ^ function to map over inividual lines + -> Text + -- ^ input text + -> Text + -- ^ resulting text +mapLinesF f = fromLines . concat . (toList <$>) . go . toLines + where + go [] = [] + go (x : xs) = f 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/Data/TextExtra.hs b/src/Headroom/Data/TextExtra.hs deleted file mode 100644 --- a/src/Headroom/Data/TextExtra.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# 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 @@ -5,7 +5,7 @@ {-| Module : Headroom.Embedded Description : Embedded files -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -21,12 +21,12 @@ ) where -import Headroom.Configuration.Types ( LicenseType(..) ) -import Headroom.Embedded.TH ( embedConfigFile - , embedDefaultConfig - , embedTemplate - ) -import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Configuration.Types ( LicenseType(..) ) +import Headroom.Embedded.TH ( embedConfigFile + , embedDefaultConfig + , embedTemplate + ) +import Headroom.FileType.Types ( FileType(..) ) import RIO diff --git a/src/Headroom/Embedded/TH.hs b/src/Headroom/Embedded/TH.hs --- a/src/Headroom/Embedded/TH.hs +++ b/src/Headroom/Embedded/TH.hs @@ -4,7 +4,7 @@ {-| Module : Headroom.Embedded.TH Description : /Template Haskell/ functions for "Headroom.Embedded" -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -22,18 +22,18 @@ ) where -import Data.FileEmbed ( embedStringFile ) -import Headroom.Configuration.Types ( LicenseType(..) ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.FileType.Types ( FileType(..) ) -import Headroom.Meta ( TemplateType ) -import Headroom.Template ( Template(..) ) -import Language.Haskell.TH.Syntax ( Exp - , Q - ) +import Data.FileEmbed ( embedStringFile ) +import Headroom.Configuration.Types ( LicenseType(..) ) +import Headroom.Data.EnumExtra ( EnumExtra(..) ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Meta ( TemplateType ) +import Headroom.Template ( Template(..) ) +import Language.Haskell.TH.Syntax ( Exp + , Q + ) import RIO -import qualified RIO.NonEmpty as NE -import qualified RIO.Text as T +import qualified RIO.NonEmpty as NE +import qualified RIO.Text as T -- | Embeds stub configuration file to source code. diff --git a/src/Headroom/Ext.hs b/src/Headroom/Ext.hs deleted file mode 100644 --- a/src/Headroom/Ext.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# 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 qualified Headroom.Ext.Java as Java -import qualified Headroom.Ext.PureScript as PureScript -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.Ext.Haskell" --- * /Java/ - implemented in "Headroom.Ext.Java" --- * /PureScript/ - implemented in "Headroom.Ext.PureScript" -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 = case fileType of - Haskell -> Haskell.extractVariables - Java -> Java.extractVariables - PureScript -> PureScript.extractVariables - _ -> 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 deleted file mode 100644 --- a/src/Headroom/Ext/Haskell.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} - -{-| -Module : Headroom.Ext.Haskell -Description : Extended support for /Haskell/ source code files -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 deleted file mode 100644 --- a/src/Headroom/Ext/Haskell/Haddock.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# 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/Ext/Java.hs b/src/Headroom/Ext/Java.hs deleted file mode 100644 --- a/src/Headroom/Ext/Java.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TupleSections #-} - -{-| -Module : Headroom.Ext.Java -Description : Extended support for /Java/ source code files -Copyright : (c) 2019-2020 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module provides /extended support/ for /Java/ source code files. Current -implementation includes extracting of /package name/ from currently processed -/Java/ source code file. --} - -module Headroom.Ext.Java - ( extractVariables - , extractPackageName - ) -where - -import Headroom.Configuration.Types ( CtHeaderConfig ) -import Headroom.Data.Regex ( match - , re - ) -import Headroom.Data.TextExtra ( toLines ) -import Headroom.Types ( TemplateMeta(..) ) -import Headroom.Variables ( mkVariables ) -import Headroom.Variables.Types ( Variables(..) ) -import RIO -import RIO.Lens ( ix ) - - --- | Extracts name of /Java/ package from given source code file content. --- --- >>> extractPackageName "package mypackage;\nclass Foo {}" --- Just "mypackage" -extractPackageName :: Text - -- ^ input text - -> Maybe Text - -- ^ extracted package name -extractPackageName = go . toLines - where - go [] = Nothing - go (x : xs) = maybe (go xs) (^? ix 1) (match [re|^package (.*);$|] x) - - --- | Extracts variables from /Java/ source code. --- --- __List of Extracted Variables:__ --- --- * @___java_package_name__@ - name of the /Java/ package -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 _ _ _ text = (mkVariables . catMaybes) - [("_java_package_name", ) <$> extractPackageName text] diff --git a/src/Headroom/Ext/PureScript.hs b/src/Headroom/Ext/PureScript.hs deleted file mode 100644 --- a/src/Headroom/Ext/PureScript.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - -{-| -Module : Headroom.Ext.PureScript -Description : Extended support for /PureScript/ source code files -Copyright : (c) 2019-2020 Vaclav Svejcar -License : BSD-3-Clause -Maintainer : vaclav.svejcar@gmail.com -Stability : experimental -Portability : POSIX - -This module provides /extended support/ for /PureScript/ source code files. -Current implementation includes extracting of /module name/ from currently -processed /PureScript/ source code file. --} - -module Headroom.Ext.PureScript where - -import Headroom.Configuration.Types ( CtHeaderConfig ) -import Headroom.Ext.Haskell ( extractModuleName ) -import Headroom.Types ( TemplateMeta(..) ) -import Headroom.Variables ( mkVariables ) -import Headroom.Variables.Types ( Variables(..) ) -import RIO - - --- | Extracts variables from /PureScript/ source code. --- --- __List of Extracted Variables:__ --- --- * @___purescript_module_name__@ - name of the /PureScript/ module -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 _ _ _ text = (mkVariables . catMaybes) - [("_purescript_module_name", ) <$> extractModuleName text] - - diff --git a/src/Headroom/FileSupport.hs b/src/Headroom/FileSupport.hs --- a/src/Headroom/FileSupport.hs +++ b/src/Headroom/FileSupport.hs @@ -1,299 +1,95 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-| Module : Headroom.FileSupport -Description : License header manipulation -Copyright : (c) 2019-2020 Vaclav Svejcar +Description : Support for handling various source code file types +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental Portability : POSIX -This module is the heart of /Headroom/ as it contains functions for working with -the /license headers/ and the /source code files/. +/Headroom/ currently supports working with file types defined in 'FileType' +type, and because every type of source code file requires different handling of +some aspects, this file type specific support is implemented for every supported +file type and exposed as instance of 'FileSupport' data type. -} module Headroom.FileSupport - ( -- * File info extraction - extractFileInfo - -- * License header manipulation - , addHeader - , dropHeader - , replaceHeader - -- * License header detection - , findHeader - , findBlockHeader - , findLineHeader - , firstMatching - , lastMatching - , splitInput + ( fileSupport + , analyzeSourceCode ) where -import Headroom.Configuration.Types ( CtHeaderConfig - , HeaderConfig(..) - , HeaderSyntax(..) - ) -import Headroom.Data.Lens ( suffixLensesFor ) -import Headroom.Data.Regex ( Regex - , match - ) -import Headroom.Data.TextExtra ( fromLines - , toLines - ) -import Headroom.Ext ( extractVariables ) -import Headroom.FileSupport.Types ( FileInfo(..) ) -import Headroom.FileType.Types ( FileType(..) ) -import Headroom.Types ( TemplateMeta(..) ) +import Control.Monad.State ( get + , put + ) +import qualified Headroom.FileSupport.C as C +import qualified Headroom.FileSupport.CPP as CPP +import qualified Headroom.FileSupport.CSS as CSS +import qualified Headroom.FileSupport.Haskell as Haskell +import qualified Headroom.FileSupport.HTML as HTML +import qualified Headroom.FileSupport.Java as Java +import qualified Headroom.FileSupport.JS as JS +import qualified Headroom.FileSupport.PureScript as PureScript +import qualified Headroom.FileSupport.Rust as Rust +import qualified Headroom.FileSupport.Scala as Scala +import qualified Headroom.FileSupport.Shell as Shell +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.SourceCode ( LineType(..) + , SourceCode + , fromText + ) import RIO -import qualified RIO.List as L -import qualified RIO.Text as T - - -suffixLensesFor ["fiHeaderPos"] ''FileInfo - - --- | Extracts info about the processed file to be later used by the header --- detection/manipulation functions. -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 {..} _ text | isJust fiHeaderPos = text -addHeader FileInfo {..} header text = result - where - (before, middle, after) = splitInput hcPutAfter hcPutBefore text - HeaderConfig {..} = fiHeaderConfig - before' = stripLinesEnd before - middle' = stripLinesStart middle - margin [] _ = [] - margin _ size = replicate size "" - marginBefore = margin before' hcMarginBefore - marginAfter = margin (middle' <> after) hcMarginAfter - 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 _ _ Nothing _) text = text -dropHeader (FileInfo _ _ (Just (start, end)) _) text = result - where - before = take start inputLines - after = drop (end + 1) inputLines - 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 header = addHeader' . dropHeader' - where - addHeader' = addHeader infoWithoutPos header - dropHeader' = dropHeader fileInfo - infoWithoutPos = set fiHeaderPosL Nothing fileInfo - - --- | Finds header position in given text, where position is represented by --- line number of first and last line of the header (numbered from zero). --- 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 :: 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 - where - (before, headerArea, _) = splitInput hcPutAfter hcPutBefore input - splitAt = L.length before - inLines = T.strip <$> headerArea - - --- | Finds header in the form of /multi-line comment/ syntax, which is delimited --- with starting and ending pattern. --- --- >>> 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 startsWith endsWith = go Nothing Nothing - where - isStart = T.isPrefixOf startsWith - isEnd = T.isSuffixOf endsWith - go _ _ (x : _) i | isStart x && isEnd x = Just (i, i) - go _ _ (x : xs) i | isStart x = go (Just i) Nothing xs (i + 1) - go (Just start) _ (x : _) i | isEnd x = Just (start, i) - go start end (_ : xs) i = go start end xs (i + 1) - go _ _ [] _ = Nothing - - --- | Finds header in the form of /single-line comment/ syntax, which is --- delimited with the prefix pattern. --- --- >>> 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 prefix = go Nothing - where - isPrefix = T.isPrefixOf prefix - go Nothing (x : xs) i | isPrefix x = go (Just i) xs (i + 1) - go Nothing (_ : xs) i = go Nothing xs (i + 1) - go (Just start) (x : xs) i | isPrefix x = go (Just start) xs (i + 1) - go (Just start) _ i = Just (start, i - 1) - go _ [] _ = Nothing +import qualified RIO.Text as T --- | Finds very first line that matches the given /regex/ (numbered from zero). --- --- >>> 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 patterns input = go input 0 - where - 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 - +------------------------------ PUBLIC FUNCTIONS ------------------------------ --- | Finds very last line that matches the given /regex/ (numbered from zero). --- --- >>> 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 patterns input = go input 0 Nothing - where - 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 +-- | Returns 'FileSupport' for corresponding 'FileType'. +fileSupport :: FileType -> FileSupport +fileSupport C = C.fileSupport +fileSupport CPP = CPP.fileSupport +fileSupport CSS = CSS.fileSupport +fileSupport Haskell = Haskell.fileSupport +fileSupport HTML = HTML.fileSupport +fileSupport Java = Java.fileSupport +fileSupport JS = JS.fileSupport +fileSupport PureScript = PureScript.fileSupport +fileSupport Rust = Rust.fileSupport +fileSupport Scala = Scala.fileSupport +fileSupport Shell = Shell.fileSupport --- | Splits input lines into three parts: --- --- 1. list of all lines located before the very last occurence of one of --- the conditions from the first condition list --- 2. list of all lines between the first and last lists --- 3. list of all lines located after the very first occurence of one of --- the conditions from the second condition list --- --- If both first and second patterns are empty, then all lines are returned in --- the middle list. --- --- >>> import Headroom.Data.Regex (re) --- >>> :set -XQuasiQuotes --- --- >>> splitInput [[re|->|]] [[re|<-|]] "text\n->\nRESULT\n<-\nfoo" --- (["text","->"],["RESULT"],["<-","foo"]) --- --- >>> splitInput [] [[re|<-|]] "text\n->\nRESULT\n<-\nfoo" --- ([],["text","->","RESULT"],["<-","foo"]) --- --- >>> splitInput [] [] "one\ntwo" --- ([],["one","two"],[]) -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) +-- | Analyzes the raw source code of given type using provided 'FileSupport'. +analyzeSourceCode :: FileSupport + -- ^ 'FileSupport' implementation used for analysis + -> Text + -- ^ raw source code to analyze + -> SourceCode + -- ^ analyzed source code +analyzeSourceCode fs = fromText state0 process where - (middle', after ) = L.splitAt sndSplitAt inLines - (before , middle) = L.splitAt fstSplitAt middle' - fstSplitAt = maybe 0 (+ 1) (lastMatching fstSplit middle') - sndSplitAt = fromMaybe len (firstMatching sndSplit inLines) - inLines = toLines input - len = L.length inLines - - -stripLinesEnd :: [Text] -> [Text] -stripLinesEnd = toLines . T.stripEnd . fromLines + SyntaxAnalysis {..} = fsSyntaxAnalysis fs + state0 = 0 :: Int + process (T.strip -> l) = do + cs <- get + let isStart = saIsCommentStart + isEnd = saIsCommentEnd + tpe = \c -> if c > 0 then Comment else Code + (ns, res) = if + | isStart l && isEnd l -> (cs, Comment) + | isStart l -> (cs + 1, Comment) + | isEnd l -> (cs - 1, tpe cs) + | cs > 0 -> (cs, Comment) + | otherwise -> (0, Code) + put ns + pure res -stripLinesStart :: [Text] -> [Text] -stripLinesStart = toLines . T.stripStart . fromLines diff --git a/src/Headroom/FileSupport/C.hs b/src/Headroom/FileSupport/C.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/C.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : Headroom.FileSupport.C +Description : Support for /C/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Basic support for /C/ source code files. This implementation doesn't extract any +variables or template data. +-} + +module Headroom.FileSupport.C + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , re + ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + , defaultFileSupport + ) +import Headroom.FileType.Types ( FileType(..) ) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /C/. +fileSupport :: FileSupport +fileSupport = defaultFileSupport C syntaxAnalysis + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/CPP.hs b/src/Headroom/FileSupport/CPP.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/CPP.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : Headroom.FileSupport.CPP +Description : Support for /C++/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Basic support for /C++/ source code files. This implementation doesn't extract +any variables or template data. +-} + +module Headroom.FileSupport.CPP + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , re + ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + , defaultFileSupport + ) +import Headroom.FileType.Types ( FileType(..) ) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /C++/. +fileSupport :: FileSupport +fileSupport = defaultFileSupport CPP syntaxAnalysis + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/CSS.hs b/src/Headroom/FileSupport/CSS.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/CSS.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : Headroom.FileSupport.CSS +Description : Support for /CSS/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Basic support for /CSS/ source code files. This implementation doesn't extract +any variables or template data. +-} + +module Headroom.FileSupport.CSS + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , re + ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + , defaultFileSupport + ) +import Headroom.FileType.Types ( FileType(..) ) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /CSS/. +fileSupport :: FileSupport +fileSupport = defaultFileSupport CSS syntaxAnalysis + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|] + , saIsCommentEnd = isMatch [re|\*\/$|] + } diff --git a/src/Headroom/FileSupport/HTML.hs b/src/Headroom/FileSupport/HTML.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/HTML.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : Headroom.FileSupport.HTML +Description : Support for /HTML/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Basic support for /HTML/ source code files. This implementation doesn't extract +any variables or template data. +-} + +module Headroom.FileSupport.HTML + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , re + ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + , defaultFileSupport + ) +import Headroom.FileType.Types ( FileType(..) ) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /HTML/. +fileSupport :: FileSupport +fileSupport = defaultFileSupport HTML syntaxAnalysis + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^$|] + } diff --git a/src/Headroom/FileSupport/Haskell.hs b/src/Headroom/FileSupport/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/Haskell.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module : Headroom.FileSupport.Haskell +Description : Support for /Haskell/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Support for /Haskell/ source code files. This implementation extracts module +name and /Haddock/ fields as variables (see below). For more details about +/Haddock/ extraction, see "Headroom.FileSupport.Haskell.Haddock" module. + += Extracted Variables for Templates +This implementation extracts following variables from source code file: + +* @___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 + += Extracted Custom Data +This implementation extracts custom data from used template, represented by the +'HaskellTemplateData'' data type. +-} + +module Headroom.FileSupport.Haskell + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , match + , re + ) +import Headroom.FileSupport.Haskell.Haddock + ( HaddockModuleHeader(..) + , extractModuleHeader + , extractOffsets + ) +import Headroom.FileSupport.TemplateData ( HaskellTemplateData'(..) + , TemplateData(..) + ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) + +import Headroom.Configuration.Types ( HeaderConfig(..) + , HeaderSyntax + ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Header.Types ( HeaderTemplate(..) ) +import Headroom.SourceCode ( LineType(..) + , SourceCode(..) + , cut + , firstMatching + ) +import Headroom.Template ( Template(..) ) +import Headroom.Variables ( mkVariables ) +import Headroom.Variables.Types ( Variables(..) ) +import RIO +import RIO.Lens ( ix ) + + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /Haskell/. +fileSupport :: FileSupport +fileSupport = FileSupport { fsSyntaxAnalysis = syntaxAnalysis + , fsExtractTemplateData = extractTemplateData + , fsExtractVariables = extractVariables + , fsFileType = Haskell + } + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis + { saIsCommentStart = isMatch [re|^{-(?!\h*#)|^--|] + , saIsCommentEnd = isMatch [re|^\h*-}|\w+\h*-}|^--|] + } + + +extractTemplateData :: Template a => a -> HeaderSyntax -> TemplateData +extractTemplateData template syntax = + let htdHaddockOffsets = extractOffsets template syntax + templateData = HaskellTemplateData' { .. } + in HaskellTemplateData templateData + + +extractVariables :: HeaderTemplate + -> Maybe (Int, Int) + -> SourceCode + -> Variables +extractVariables HeaderTemplate {..} headerPos source = + (mkVariables . catMaybes) + [ ("_haskell_module_copyright", ) <$> hmhCopyright + , ("_haskell_module_license", ) <$> hmhLicense + , ("_haskell_module_maintainer", ) <$> hmhMaintainer + , ("_haskell_module_name", ) <$> extractModuleName source + , ("_haskell_module_portability", ) <$> hmhPortability + , ("_haskell_module_stability", ) <$> hmhStability + , ("_haskell_module_longdesc", ) <$> hmhLongDesc + , ("_haskell_module_shortdesc", ) <$> hmhShortDesc + ] + where + HaddockModuleHeader {..} = extractModuleHeader header htTemplateData syntax + header = maybe mempty (\(s, e) -> cut s e source) headerPos + syntax = hcHeaderSyntax htConfig + + +extractModuleName :: SourceCode -> Maybe Text +extractModuleName = fmap snd . firstMatching f + where + f (lt, l) | lt == Code = match [re|^module\s+(\S+)|] l >>= (^? ix 1) + | otherwise = Nothing + diff --git a/src/Headroom/FileSupport/Haskell/Haddock.hs b/src/Headroom/FileSupport/Haskell/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/Haskell/Haddock.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} + +{-| +Module : Headroom.FileSupport.Haskell.Haddock +Description : Extraction of /Haddock module header/ fields +Copyright : (c) 2019-2021 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.FileSupport.Haskell.Haddock + ( HaddockModuleHeader(..) + , extractOffsets + , extractModuleHeader + , indentField + ) +where + +import Control.Applicative ( Alternative(..) ) +import Control.Monad ( ap ) +import Headroom.Configuration.Types ( HeaderSyntax ) +import Headroom.Data.Regex ( re + , scan + ) +import Headroom.Data.Text ( fromLines + , toLines + ) +import Headroom.FileSupport.TemplateData ( HaddockOffsets(..) + , HaskellTemplateData'(..) + , TemplateData(..) + ) +import Headroom.Header.Sanitize ( stripCommentSyntax ) +import Headroom.SourceCode ( SourceCode(..) + , toText + ) +import Headroom.Template ( Template(..) ) +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/. +extractOffsets :: Template a + => a + -- ^ parsed /template/ + -> HeaderSyntax + -- ^ copyright header syntax + -> HaddockOffsets + -- ^ extracted offsets +extractOffsets template syntax = + let hoCopyright = extractCopyrightOffset templateText + in HaddockOffsets { .. } + where templateText = stripCommentSyntax syntax . 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 :: SourceCode + -- ^ source code containing /Haddock/ module header + -> TemplateData + -- ^ extracted metadata from corresponding /template/ + -> HeaderSyntax + -- ^ copyright header syntax + -> HaddockModuleHeader + -- ^ extracted metadata +extractModuleHeader source templateData syntax = + let hmhCopyright = indent hoCopyright <$> 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 syntax . toText $ source + extractField name = fmap (T.strip . T.pack) (lookup name fields') + process = Just . T.strip . T.pack + indent c t = T.strip $ indentField c t + HaddockOffsets {..} = case templateData of + HaskellTemplateData (HaskellTemplateData' offsets') -> offsets' + _ -> HaddockOffsets Nothing + + +-- | 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 " " + + +-------------------------------------------------------------------------------- +-- 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/JS.hs b/src/Headroom/FileSupport/JS.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/JS.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : Headroom.FileSupport.JS +Description : Support for /Javascript/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Basic support for /Javascript/ source code files. This implementation doesn't +extract any variables or template data. +-} + +module Headroom.FileSupport.JS + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , re + ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + , defaultFileSupport + ) +import Headroom.FileType.Types ( FileType(..) ) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /Javascript/. +fileSupport :: FileSupport +fileSupport = defaultFileSupport JS syntaxAnalysis + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/Java.hs b/src/Headroom/FileSupport/Java.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/Java.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module : Headroom.FileSupport.Java +Description : Support for /Java/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Support for /Java/ source code files. This implementation extracts /Java/ +package name as variable. + += Extracted Variables for Templates +This implementation extracts following variables from source code file: + +* @___java_package_name__@ - name of the /Java/ package + += Extracted Custom Data +This implementation does not extract any custom data from template file. +-} + +module Headroom.FileSupport.Java + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , match + , re + ) +import Headroom.FileSupport.TemplateData ( TemplateData(..) ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Header.Types ( HeaderTemplate ) +import Headroom.SourceCode ( LineType(..) + , SourceCode(..) + , firstMatching + ) +import Headroom.Variables ( mkVariables ) +import Headroom.Variables.Types ( Variables(..) ) +import RIO +import RIO.Lens ( ix ) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /Java/. +fileSupport :: FileSupport +fileSupport = FileSupport + { fsSyntaxAnalysis = syntaxAnalysis + , fsExtractTemplateData = const . const $ NoTemplateData + , fsExtractVariables = extractVariables + , fsFileType = Java + } + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } + + +extractVariables :: HeaderTemplate + -> Maybe (Int, Int) + -> SourceCode + -> Variables +extractVariables _ _ source = (mkVariables . catMaybes) + [("_java_package_name", ) <$> extractPackageName source] + + +extractPackageName :: SourceCode -> Maybe Text +extractPackageName = fmap snd . firstMatching f + where + f (lt, l) | lt == Code = match [re|^package (.*);$|] l >>= (^? ix 1) + | otherwise = Nothing diff --git a/src/Headroom/FileSupport/PureScript.hs b/src/Headroom/FileSupport/PureScript.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/PureScript.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module : Headroom.FileSupport.PureScript +Description : Support for /PureScript/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Support for /PureScript/ source code files. This implementation extracts +/PureScript/ module name as variable. + += Extracted Variables for Templates +This implementation extracts following variables from source code file: + +* @___purescript_module_name__@ - name of the /PureScript/ module + += Extracted Custom Data +This implementation does not extract any custom data from template file. +-} + +module Headroom.FileSupport.PureScript + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , match + , re + ) +import Headroom.FileSupport.TemplateData ( TemplateData(..) ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Header.Types ( HeaderTemplate ) +import Headroom.SourceCode ( LineType(..) + , SourceCode(..) + , firstMatching + ) +import Headroom.Variables ( mkVariables ) +import Headroom.Variables.Types ( Variables(..) ) +import RIO +import RIO.Lens ( ix ) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /PureScript/. +fileSupport :: FileSupport +fileSupport = FileSupport + { fsSyntaxAnalysis = syntaxAnalysis + , fsExtractTemplateData = const . const $ NoTemplateData + , fsExtractVariables = extractVariables + , fsFileType = PureScript + } + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis + { saIsCommentStart = isMatch [re|^{-(?!\h*#)|^--|] + , saIsCommentEnd = isMatch [re|^\h*-}|\w+\h*-}|^--|] + } + + +extractVariables :: HeaderTemplate + -> Maybe (Int, Int) + -> SourceCode + -> Variables +extractVariables _ _ source = (mkVariables . catMaybes) + [("_purescript_module_name", ) <$> extractModuleName source] + + +extractModuleName :: SourceCode -> Maybe Text +extractModuleName = fmap snd . firstMatching f + where + f (lt, l) | lt == Code = match [re|^module\s+(\S+)|] l >>= (^? ix 1) + | otherwise = Nothing diff --git a/src/Headroom/FileSupport/Rust.hs b/src/Headroom/FileSupport/Rust.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/Rust.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : Headroom.FileSupport.Rust +Description : Support for /Rust/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Basic support for /Rust/ source code files. This implementation doesn't extract +any variables or template data. +-} + +module Headroom.FileSupport.Rust + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , re + ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + , defaultFileSupport + ) +import Headroom.FileType.Types ( FileType(..) ) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /Rust/. +fileSupport :: FileSupport +fileSupport = defaultFileSupport Rust syntaxAnalysis + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/Scala.hs b/src/Headroom/FileSupport/Scala.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/Scala.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : Headroom.FileSupport.Scala +Description : Support for /Scala/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Basic support for /Scala/ source code files. This implementation doesn't extract +any variables or template data. +-} + +module Headroom.FileSupport.Scala + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , re + ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + , defaultFileSupport + ) +import Headroom.FileType.Types ( FileType(..) ) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /Scala/. +fileSupport :: FileSupport +fileSupport = defaultFileSupport Scala syntaxAnalysis + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^\/\*|^\/\/|] + , saIsCommentEnd = isMatch [re|\*\/$|^\/\/|] + } diff --git a/src/Headroom/FileSupport/Shell.hs b/src/Headroom/FileSupport/Shell.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/Shell.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : Headroom.FileSupport.Shell +Description : Support for /Shell/ source code files +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Basic support for /Shell/ source code files. This implementation doesn't extract +any variables or template data. +-} + +module Headroom.FileSupport.Shell + ( fileSupport + ) +where + +import Headroom.Data.Regex ( isMatch + , re + ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + , defaultFileSupport + ) +import Headroom.FileType.Types ( FileType(..) ) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Implementation of 'FileSupport' for /Shell/. +fileSupport :: FileSupport +fileSupport = defaultFileSupport Shell syntaxAnalysis + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +syntaxAnalysis :: SyntaxAnalysis +syntaxAnalysis = SyntaxAnalysis { saIsCommentStart = isMatch [re|^#(?!!)|] + , saIsCommentEnd = isMatch [re|^#(?!!)|] + } diff --git a/src/Headroom/FileSupport/TemplateData.hs b/src/Headroom/FileSupport/TemplateData.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/FileSupport/TemplateData.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StrictData #-} + +{-| +Module : Headroom.FileSupport.TemplateData +Description : Custom data specific to file support implementations +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +Because each implementation of file support might require some custom data +extracted for example from the template file, this module exposes data types +specific for individual implementations. +-} + +module Headroom.FileSupport.TemplateData + ( TemplateData(..) + , HaddockOffsets(..) + , HaskellTemplateData'(..) + ) +where +import RIO + + +-- | Additional template data extracted from the template file. +data TemplateData + = HaskellTemplateData HaskellTemplateData' + -- ^ additional template data for /Haskell/ + | NoTemplateData + -- ^ no additional template data provided + deriving (Eq, Show) + +-- | Offsets for selected fields extracted from /Haddock module header/. +data HaddockOffsets = HaddockOffsets + { hoCopyright :: Maybe Int + -- ^ offset for /Copyright/ field + } + deriving (Eq, Show) + + +-- | Additional template data required by /Haskell/ file support +data HaskellTemplateData' = HaskellTemplateData' + { htdHaddockOffsets :: HaddockOffsets + -- ^ offsets for /Haddock/ fields + } + deriving (Eq, Show) diff --git a/src/Headroom/FileSupport/Types.hs b/src/Headroom/FileSupport/Types.hs --- a/src/Headroom/FileSupport/Types.hs +++ b/src/Headroom/FileSupport/Types.hs @@ -1,39 +1,93 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StrictData #-} {-| Module : Headroom.FileSupport.Types -Description : Data types for "Headroom.FileSupport" -Copyright : (c) 2019-2020 Vaclav Svejcar +Description : Data types for "Headroom.FileSupport" module +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental Portability : POSIX -This module contains data types for "Headroom.FileSupport" module. +Data types for "Headroom.FileSupport" module in separated module +(to avoid cyclic dependencies). -} module Headroom.FileSupport.Types ( -- * Data Types - FileInfo(..) + FileSupport(..) + , SyntaxAnalysis(..) + -- * Smart Constructors + , defaultFileSupport + -- * Function Type Aliases + , ExtractTemplateDataFn + , ExtractVariablesFn ) where -import Headroom.Configuration.Types ( CtHeaderConfig ) -import Headroom.FileType.Types ( FileType ) -import Headroom.Variables.Types ( Variables ) +import Headroom.Configuration.Types ( HeaderSyntax ) +import Headroom.FileSupport.TemplateData ( TemplateData(..) ) +import Headroom.FileType.Types ( FileType ) +import Headroom.Header.Types ( HeaderTemplate ) +import Headroom.SourceCode ( SourceCode ) +import Headroom.Template ( Template ) +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 +-- | Set of functions that every file support needs to implement. +data FileSupport = FileSupport + { fsSyntaxAnalysis :: SyntaxAnalysis + , fsExtractTemplateData :: ExtractTemplateDataFn + , fsExtractVariables :: ExtractVariablesFn + , fsFileType :: FileType } - deriving (Eq, Show) + + +-- | Set of functions used to analyze source code. +data SyntaxAnalysis = SyntaxAnalysis + { saIsCommentStart :: Text -> Bool + , saIsCommentEnd :: Text -> Bool + } + + +-- | Type of a function that extracts additional template data from template. +type ExtractTemplateDataFn + = forall a + . Template a + => a + -- ^ template to use for extraction + -> HeaderSyntax + -- ^ copyright header syntax + -> TemplateData + -- ^ extracted template data + + +-- | Type of a function that extracts variables from analyzed source code file. +type ExtractVariablesFn + = HeaderTemplate + -- ^ header template + -> Maybe (Int, Int) + -- ^ header position as @(startLine, endLine)@ + -> SourceCode + -- ^ analyzed source code file + -> Variables + -- ^ extracted variables + + +-- | Default implementation of 'FileSupport' that doesn't extract any variables +-- or template data. +defaultFileSupport :: FileType + -- ^ type of the source code file + -> SyntaxAnalysis + -- ^ function that analyzes source code + -> FileSupport + -- ^ resulting 'FileSupport' +defaultFileSupport fileType syntaxAnalysis = FileSupport + { fsSyntaxAnalysis = syntaxAnalysis + , fsExtractTemplateData = const . const $ NoTemplateData + , fsExtractVariables = const . const . const $ mempty + , fsFileType = fileType + } diff --git a/src/Headroom/FileSystem.hs b/src/Headroom/FileSystem.hs --- a/src/Headroom/FileSystem.hs +++ b/src/Headroom/FileSystem.hs @@ -4,7 +4,7 @@ {-| Module : Headroom.FileSystem Description : Operations related to files and file system -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -40,25 +40,25 @@ ) where -import Headroom.Configuration.Types ( CtHeadersConfig ) -import Headroom.Data.Regex ( Regex - , match - ) -import Headroom.FileType ( listExtensions ) -import Headroom.FileType.Types ( FileType ) +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 - , doesFileExist - , getCurrentDirectory - , getDirectoryContents - ) -import RIO.FilePath ( isExtensionOf - , takeExtension - , () - ) -import qualified RIO.List as L -import qualified RIO.Text as T +import RIO.Directory ( createDirectory + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , getDirectoryContents + ) +import RIO.FilePath ( isExtensionOf + , takeExtension + , () + ) +import qualified RIO.List as L +import qualified RIO.Text as T -------------------------------- TYPE ALIASES -------------------------------- @@ -235,8 +235,8 @@ -- | Takes list of patterns and file paths and returns list of file paths where -- those matching the given patterns are excluded. -- --- >>> import Headroom.Data.Regex (re) -- >>> :set -XQuasiQuotes +-- >>> import Headroom.Data.Regex (re) -- >>> excludePaths [[re|\.hidden|], [re|zzz|]] ["foo/.hidden", "test/bar", "x/zzz/e"] -- ["test/bar"] excludePaths :: [Regex] diff --git a/src/Headroom/FileType.hs b/src/Headroom/FileType.hs --- a/src/Headroom/FileType.hs +++ b/src/Headroom/FileType.hs @@ -5,7 +5,7 @@ {-| Module : Headroom.FileType Description : Logic for handlig supported file types -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -22,15 +22,15 @@ ) where -import Headroom.Configuration.Types ( CtHeaderConfig - , CtHeadersConfig - , HeaderConfig(..) - , HeadersConfig(..) - ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.FileType.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 +import qualified RIO.List as L diff --git a/src/Headroom/FileType/Types.hs b/src/Headroom/FileType/Types.hs --- a/src/Headroom/FileType/Types.hs +++ b/src/Headroom/FileType/Types.hs @@ -4,7 +4,7 @@ {-| Module : Headroom.FileType.Types Description : Data types for "Headroom.FileType" -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -15,7 +15,7 @@ module Headroom.FileType.Types where -import Headroom.Data.EnumExtra ( EnumExtra(..) ) +import Headroom.Data.EnumExtra ( EnumExtra(..) ) import RIO -- | Supported type of source code file. diff --git a/src/Headroom/Header.hs b/src/Headroom/Header.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Header.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : Headroom.Header +Description : Operations with copyright/license headers +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module is the heart of /Headroom/ as it contains functions for working with +the /license headers/ and the /source code files/. +-} + +module Headroom.Header + ( -- * Header Info Extraction + extractHeaderInfo + , extractHeaderTemplate + -- * License header manipulation + , addHeader + , dropHeader + , replaceHeader + -- * Copyright Header Detection + , findHeader + , findBlockHeader + , findLineHeader + , splitSource + ) +where + +import Headroom.Configuration.Types ( CtHeaderConfig + , CtHeaderConfig + , CtHeadersConfig + , HeaderConfig(..) + , HeaderConfig(..) + , HeaderSyntax(..) + , HeaderSyntax(..) + ) +import Headroom.Data.Coerce ( coerce + , inner + ) +import Headroom.Data.Lens ( suffixLensesFor ) +import Headroom.Data.Regex ( Regex + , isMatch + ) +import Headroom.FileSupport ( fileSupport ) +import Headroom.FileSupport.Types ( FileSupport(..) ) +import Headroom.FileType ( configByFileType ) +import Headroom.FileType.Types ( FileType ) +import Headroom.Header.Sanitize ( findPrefix ) +import Headroom.Header.Types ( HeaderInfo(..) + , HeaderTemplate(..) + ) +import Headroom.Meta ( TemplateType ) +import Headroom.SourceCode ( CodeLine + , LineType(..) + , SourceCode(..) + , firstMatching + , fromText + , lastMatching + , stripEnd + , stripStart + ) +import Headroom.Template ( Template(..) ) +import RIO +import qualified RIO.List as L +import qualified RIO.Text as T + + + +suffixLensesFor ["hcHeaderSyntax"] ''HeaderConfig +suffixLensesFor ["hiHeaderPos"] ''HeaderInfo + + +-- | Extracts info about the processed file to be later used by the header +-- detection/manipulation functions. +extractHeaderInfo :: HeaderTemplate + -- ^ template info + -> SourceCode + -- ^ text used for detection + -> HeaderInfo + -- ^ resulting file info +extractHeaderInfo ht@HeaderTemplate {..} source = + let hiFileType = htFileType + hiHeaderConfig = htConfig + hiHeaderPos = findHeader hiHeaderConfig source + hiVariables = fsExtractVariables ht hiHeaderPos source + in HeaderInfo { .. } + where FileSupport {..} = fileSupport htFileType + + +-- | Constructs new 'HeaderTemplate' from provided data. +extractHeaderTemplate :: CtHeadersConfig + -- ^ configuration for license headers + -> FileType + -- ^ type of source code files this template is for + -> TemplateType + -- ^ parsed template + -> HeaderTemplate + -- ^ resulting template info +extractHeaderTemplate configs fileType template = + let htConfig = withP (configByFileType configs fileType) + htTemplateData = fsExtractTemplateData template (hcHeaderSyntax htConfig) + htFileType = fileType + htTemplate = template + in HeaderTemplate { .. } + where + FileSupport {..} = fileSupport fileType + withP = \config -> config & hcHeaderSyntaxL %~ headerSyntax + headerSyntax = \hs -> findPrefix hs (rawTemplate template) + + +-- | Adds given header at position specified by the 'HeaderInfo'. Does nothing +-- if any header is already present, use 'replaceHeader' if you need to +-- override it. +addHeader :: HeaderInfo + -- ^ additional info about the header + -> Text + -- ^ text of the new header + -> SourceCode + -- ^ source code where to add the header + -> SourceCode + -- ^ resulting source code with added header +addHeader HeaderInfo {..} _ source | isJust hiHeaderPos = source +addHeader HeaderInfo {..} header source = mconcat chunks + where + HeaderConfig {..} = hiHeaderConfig + (before, middle, after) = splitSource hcPutAfter hcPutBefore source + header' = fromText [] (const $ pure Comment) header + before' = stripEnd before + middle' = stripStart middle + margin (SourceCode ls) mInner mOuter + | L.null ls = coerce $ replicate mOuter (Code, T.empty) + | otherwise = coerce $ replicate mInner (Code, T.empty) + marginT = margin before' hcMarginTopCode hcMarginTopFile + marginB = margin (middle' <> after) hcMarginBottomCode hcMarginBottomFile + chunks = [before', marginT, header', marginB, middle', after] + + +-- | Drops header at position specified by the 'HeaderInfo' from the given +-- source code. Does nothing if no header is present. +dropHeader :: HeaderInfo + -- ^ additional info about the header + -> SourceCode + -- ^ text of the file from which to drop the header + -> SourceCode + -- ^ resulting text with dropped header +dropHeader (HeaderInfo _ _ Nothing _) source = source +dropHeader (HeaderInfo _ _ (Just (start, end)) _) source = result + where + before = inner @_ @[CodeLine] (take start) source + after = inner @_ @[CodeLine] (drop $ end + 1) source + result = stripEnd before <> stripStart after + + +-- | Replaces existing header at position specified by the 'HeaderInfo' in the +-- given text. Basically combines 'addHeader' with 'dropHeader'. If no header +-- is present, then the given one is added to the text. +replaceHeader :: HeaderInfo + -- ^ additional info about the header + -> Text + -- ^ text of the new header + -> SourceCode + -- ^ text of the file where to replace the header + -> SourceCode + -- ^ resulting text with replaced header +replaceHeader fileInfo header = addHeader' . dropHeader' + where + addHeader' = addHeader infoWithoutPos header + dropHeader' = dropHeader fileInfo + infoWithoutPos = fileInfo & hiHeaderPosL .~ Nothing + + +-- | Finds header position in given text, where position is represented by +-- line number of first and last line of the header (numbered from zero). +-- Based on the 'HeaderSyntax' specified in given 'HeaderConfig', this function +-- delegates its work to either 'findBlockHeader' or 'findLineHeader'. +-- +-- >>> :set -XFlexibleContexts -XTypeFamilies -XQuasiQuotes +-- >>> import Headroom.Data.Regex (re) +-- >>> let hc = HeaderConfig ["hs"] 0 0 0 0 [] [] (BlockComment [re|^{-|] [re|(?>> findHeader hc $ SourceCode [(Code, "foo"), (Code, "bar"), (Comment, "{- HEADER -}")] +-- Just (2,2) +findHeader :: CtHeaderConfig + -- ^ appropriate header configuration + -> SourceCode + -- ^ 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 headerArea splitAt + LineComment prefix _ -> findLineHeader prefix headerArea splitAt + where + (before, headerArea, _) = splitSource hcPutAfter hcPutBefore input + splitAt = length (coerce before :: [CodeLine]) + + +-- | Finds header in the form of /multi-line comment/ syntax, which is delimited +-- with starting and ending pattern. +-- +-- >>> :set -XQuasiQuotes +-- >>> import Headroom.Data.Regex (re) +-- >>> let sc = SourceCode [(Code, ""), (Comment, "{- HEADER -}"), (Code, ""), (Code,"")] +-- >>> findBlockHeader [re|^{-|] [re|(? Regex + -- ^ ending pattern (e.g. @-}@ or @*/@) + -> SourceCode + -- ^ source code in which to detect the header + -> Int + -- ^ line number offset (adds to resulting position) + -> Maybe (Int, Int) + -- ^ header position @(startLine + offset, endLine + offset)@ +findBlockHeader start end sc offset = mapT2 (+ offset) <$> position + where + ls = zip [0 ..] $ coerce sc + isMatch' = \p t -> isMatch p . T.strip $ t + allComments = all (\(_, (lt, _)) -> lt == Comment) + hasStart = maybe False (\(_, (_, t)) -> isMatch' start t) . L.headMaybe + hasEnd = maybe False (\(_, (_, t)) -> isMatch' end t) . L.lastMaybe + position = (,) <$> (header >>= L.headMaybe) <*> (header >>= L.lastMaybe) + header = + (fmap . fmap) fst + . L.find (\g -> allComments g && hasStart g && hasEnd g) + . L.groupBy (\(_, (lt1, _)) (_, (lt2, _)) -> lt1 == lt2) + $ ls + + +-- | Finds header in the form of /single-line comment/ syntax, which is +-- delimited with the prefix pattern. +-- +-- >>> :set -XQuasiQuotes +-- >>> import Headroom.Data.Regex (re) +-- >>> let sc = SourceCode [(Code, ""), (Code, "a"), (Comment, "-- first"), (Comment, "-- second"), (Code, "foo")] +-- >>> findLineHeader [re|^--|] sc 0 +-- Just (2,3) +findLineHeader :: Regex + -- ^ prefix pattern (e.g. @--@ or @//@) + -> SourceCode + -- ^ source code 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 sc offset = mapT2 (+ offset) <$> position + where + ls = zip [0 ..] $ coerce sc + isMatch' = \p t -> isMatch p . T.strip $ t + position = (,) <$> (header >>= L.headMaybe) <*> (header >>= L.lastMaybe) + header = + (fmap . fmap) fst + . L.find (all (\(_, (lt, t)) -> lt == Comment && isMatch' prefix t)) + . L.groupBy (\(_, (lt1, _)) (_, (lt2, _)) -> lt1 == lt2) + $ ls + + +-- | Splits input source code into three parts: +-- +-- 1. all lines located before the very last occurence of one of the +-- conditions from the first condition list +-- 2. all lines between the first and last lists +-- 3. all lines located after the very first occurence of one of the +-- conditions from the second condition list +-- +-- If both first and second patterns are empty, then all lines are returned in +-- the middle part. +-- +-- >>> :set -XQuasiQuotes +-- >>> import Headroom.Data.Regex (re) +-- +-- >>> let ls = [(Code, "text"), (Code, "->"), (Code, "RESULT"), (Code, "<-"), (Code, "foo")] +-- >>> splitSource [[re|->|]] [[re|<-|]] $ SourceCode ls +-- (SourceCode [(Code,"text"),(Code,"->")],SourceCode [(Code,"RESULT")],SourceCode [(Code,"<-"),(Code,"foo")]) +-- +-- >>> let ls = [(Code, "text"), (Code, "->"), (Code, "RESULT"), (Code, "<-"), (Code, "foo")] +-- >>> splitSource [] [[re|<-|]] $ SourceCode ls +-- (SourceCode [],SourceCode [(Code,"text"),(Code,"->"),(Code,"RESULT")],SourceCode [(Code,"<-"),(Code,"foo")]) +-- +-- >>> splitSource [] [] $ SourceCode [(Code,"foo"), (Code,"bar")] +-- (SourceCode [],SourceCode [(Code,"foo"),(Code,"bar")],SourceCode []) +splitSource :: [Regex] + -> [Regex] + -> SourceCode + -> (SourceCode, SourceCode, SourceCode) +splitSource [] [] sc = (mempty, sc, mempty) +splitSource fstPs sndPs sc = (before, middle, after) + where + allLines = coerce sc + (middle', after ) = mapT2 SourceCode $ L.splitAt sndSplit allLines + (before , middle) = mapT2 SourceCode $ L.splitAt fstSplitAt (coerce middle') + fstSplitAt = maybe 0 ((+ 1) . fst) $ lastMatching (cond fstPs) middle' + sndSplit = maybe len fst $ firstMatching (cond sndPs) sc + len = length allLines + cond = \ps cl@(lt, t) -> + if lt == Code && any (`isMatch` t) ps then Just cl else Nothing + + + +mapT2 :: (a -> b) -> (a, a) -> (b, b) +mapT2 = join (***) diff --git a/src/Headroom/Header/Sanitize.hs b/src/Headroom/Header/Sanitize.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Header/Sanitize.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Headroom.Header.Sanitize +Description : Logic for sanitizing license headers +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains functions related to sanitizing license headers. Because +license headers are just regular comments in given programming language, they +need to have correct syntax in order to avoid causing compile/runtime errors. +Because header manipulation done by /Headroom/ can disrupt the comment syntax +structure, sanitizing the header is the last step done in the flow, making +sure that license header syntax is not broken. +-} + +module Headroom.Header.Sanitize + ( findPrefix + , sanitizeSyntax + , stripCommentSyntax + ) +where + +import Headroom.Configuration.Types ( HeaderSyntax(..) ) +import qualified Headroom.Data.Regex as R +import qualified Headroom.Data.Text as T +import RIO +import qualified RIO.Text as T + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Tries to find comment prefix in given comment. By /prefix/ it's meant +-- either the line prefix used for block comment syntax (like @*@ at start of +-- each line between opening and closing pattern - @/* */@) or line comment +-- syntax (just the syntax for comment itself - like @//@ or @--@). If such +-- prefix is found, it's then added to the input 'HeaderSyntax'. +-- +-- >>> :set -XQuasiQuotes +-- >>> import Headroom.Data.Regex (re) +-- >>> findPrefix (BlockComment [re|^\/\*|] [re|\*\/$|] Nothing) "/*\n * foo\n * bar\n */" +-- BlockComment "^\\/\\*" "\\*\\/$" (Just " *") +findPrefix :: HeaderSyntax + -- ^ describes comment syntax of the header + -> Text + -- ^ text containint the comment + -> HeaderSyntax + -- ^ input 'HeaderSyntax' with added prefix (if found) +findPrefix syntax text = case syntax of + BlockComment s e _ -> BlockComment s e prefix + LineComment s _ -> LineComment s prefix + where + filtered = filter cond . T.toLines $ text + cond = \t -> (not . T.null . T.strip $ t) && isCommentBody syntax t + prefix = fmap T.stripEnd (T.commonLinesPrefix . T.fromLines $ filtered) + + +-- | Sanitizes given header text to make sure that each comment line starts with +-- appropriate prefix (if defined within given 'HeaderSyntax'). For block +-- comments, this is to make it visually unified, but for line comments it's +-- necessary in order not to break syntax of target source code file. +-- +-- >>> :set -XQuasiQuotes +-- >>> import Headroom.Data.Regex (re) +-- >>> sanitizeSyntax (LineComment [re|^--|] (Just "--")) "-- foo\nbar" +-- "-- foo\n-- bar" +sanitizeSyntax :: HeaderSyntax + -- ^ header syntax definition that may contain prefix + -> Text + -- ^ header to sanitize + -> Text + -- ^ sanitized header +sanitizeSyntax syntax = mapCommentLines syntax (addPrefix mPrefix) + where + addPrefix Nothing l = Just l + addPrefix (Just p) l | p `T.isPrefixOf` l = Just l + | otherwise = Just $ p <> " " <> l + mPrefix = case syntax of + BlockComment _ _ p -> p + LineComment _ p -> p + + +-- | Strips comment syntax from given text. +-- +-- >>> :set -XQuasiQuotes +-- >>> import Headroom.Data.Regex (re) +-- >>> stripCommentSyntax (LineComment [re|^--|] (Just "--")) "-- a\n-- b" +-- "a\n b" +stripCommentSyntax :: HeaderSyntax + -- ^ copyright header syntax + -> Text + -- ^ input text from which to strip the syntax + -> Text + -- ^ processed text +stripCommentSyntax syntax = T.strip . T.fromLines . go [] . T.toLines . T.strip + where + (s, e, p) = case syntax of + BlockComment s' e' p' -> (Just s', Just e', p') + LineComment s' p' -> (Just s', Nothing, p') + nil = const . const $ "" + rep = \pt l -> maybe l (\pt' -> R.replaceFirst pt' nil l) pt + dp = \pt l -> maybe l (\pt' -> T.replaceFirst pt' "" l) pt + go agg [] = reverse agg + go [] (x : xs) = go [rep s . rep e . dp p $ x] xs + go agg [x ] = go ((rep e . dp p $ x) : agg) [] + go agg (x : xs) = go (dp p x : agg) xs + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +mapCommentLines :: Foldable t + => HeaderSyntax + -> (Text -> t Text) + -> Text + -> Text +mapCommentLines syntax f = T.mapLinesF $ \case + line | isCommentBody syntax line -> toList . f $ line + | otherwise -> [line] + + +isCommentBody :: HeaderSyntax -> Text -> Bool +isCommentBody (LineComment _ _ ) _ = True +isCommentBody (BlockComment s e _) l = not $ R.isMatch s l || R.isMatch e l diff --git a/src/Headroom/Header/Types.hs b/src/Headroom/Header/Types.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Header/Types.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StrictData #-} + +{-| +Module : Headroom.Header.Types +Description : Data types for "Headroom.Header" +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types for "Headroom.Header" module. +-} + +module Headroom.Header.Types + ( -- * Data Types + HeaderInfo(..) + , HeaderTemplate(..) + ) +where + +import Headroom.Configuration.Types ( CtHeaderConfig ) +import Headroom.FileSupport.TemplateData ( TemplateData ) +import Headroom.FileType.Types ( FileType ) +import Headroom.Meta ( TemplateType ) +import Headroom.Variables.Types ( Variables ) +import RIO + + +-- | Info extracted about the source code file header. +data HeaderInfo = HeaderInfo + { hiFileType :: FileType + -- ^ type of the file + , hiHeaderConfig :: CtHeaderConfig + -- ^ configuration for license header + , hiHeaderPos :: Maybe (Int, Int) + -- ^ position of existing license header + , hiVariables :: Variables + -- ^ additional extracted variables + } + deriving (Eq, Show) + + +-- | Represents info about concrete header template. +data HeaderTemplate = HeaderTemplate + { htConfig :: CtHeaderConfig + -- ^ header configuration + , htTemplateData :: TemplateData + -- ^ extra template data extracted by the correcponding file type support + , htFileType :: FileType + -- ^ type of the file this template is for + , htTemplate :: TemplateType + -- ^ parsed template + } + deriving (Eq, Show) diff --git a/src/Headroom/HeaderFn.hs b/src/Headroom/HeaderFn.hs --- a/src/Headroom/HeaderFn.hs +++ b/src/Headroom/HeaderFn.hs @@ -12,7 +12,7 @@ {-| Module : Headroom.HeaderFn Description : Support for /license header functions/ -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -34,26 +34,25 @@ ) where -import Headroom.Configuration.Types ( CtHeaderFnConfigs - , HeaderFnConfig(..) - , HeaderFnConfigs(..) - , UpdateCopyrightConfig(..) - ) -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Lens ( suffixLenses - , suffixLensesFor - ) -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 Headroom.Configuration.Types ( CtHeaderFnConfigs + , HeaderFnConfig(..) + , HeaderFnConfigs(..) + , UpdateCopyrightConfig(..) + ) +import Headroom.Data.Has ( Has(..) ) +import Headroom.Data.Lens ( suffixLenses + , suffixLensesFor + ) +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 diff --git a/src/Headroom/HeaderFn/Types.hs b/src/Headroom/HeaderFn/Types.hs --- a/src/Headroom/HeaderFn/Types.hs +++ b/src/Headroom/HeaderFn/Types.hs @@ -3,7 +3,7 @@ {-| Module : Headroom.HeaderFn.Types Description : Data types for /license header functions/ -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental diff --git a/src/Headroom/HeaderFn/UpdateCopyright.hs b/src/Headroom/HeaderFn/UpdateCopyright.hs --- a/src/Headroom/HeaderFn/UpdateCopyright.hs +++ b/src/Headroom/HeaderFn/UpdateCopyright.hs @@ -8,7 +8,7 @@ {-| Module : Headroom.HeaderFn.UpdateCopyright Description : /License Header function/ for updating years in copyrights -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -29,18 +29,18 @@ ) 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 Headroom.Data.Has ( Has(..) ) +import Headroom.Data.Regex ( re + , replace + ) +import Headroom.Data.Text ( 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 +import qualified RIO.NonEmpty as NE +import qualified RIO.Text as T --------------------------------- DATA TYPES --------------------------------- diff --git a/src/Headroom/Meta.hs b/src/Headroom/Meta.hs --- a/src/Headroom/Meta.hs +++ b/src/Headroom/Meta.hs @@ -1,10 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-| Module : Headroom.Meta Description : Application metadata (name, vendor, etc.) -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -17,18 +18,29 @@ module Headroom.Meta ( TemplateType , buildVersion + , configBreakingChanges + , configFileName , productDesc , productInfo , productName - , website + , webDoc + , webDocConfigCurr + , webDocMigration + , webRepo ) where -import Data.Version ( showVersion ) -import Headroom.Template.Mustache ( Mustache ) -import Paths_headroom ( version ) +import Data.Version ( showVersion ) +import Headroom.Meta.Version ( Version(..) + , parseVersion + , printVersion + , pvp + ) +import Headroom.Template.Mustache ( Mustache ) +import Paths_headroom ( version ) import RIO -import qualified RIO.Text as T +import RIO.Partial ( fromJust ) +import qualified RIO.Text as T -- | Type of the template format used for license headers. @@ -36,10 +48,21 @@ -- | Application version, as specified in @headroom.cabal@ file. -buildVersion :: Text -buildVersion = T.pack . showVersion $ version +buildVersion :: Version +buildVersion = fromJust . parseVersion . T.pack . showVersion $ version +-- | List of versions that made breaking changes into YAML configuration and +-- require some migration steps to be performed by end-user. +configBreakingChanges :: [Version] +configBreakingChanges = [[pvp|0.4.0.0|]] + + +-- | Name of the YAML configuration file. +configFileName :: IsString a => a +configFileName = ".headroom.yaml" + + -- | Full product description. productDesc :: Text productDesc = "manage your source code license headers" @@ -47,7 +70,8 @@ -- | Product info. productInfo :: Text -productInfo = mconcat [productName, ", v", buildVersion, " :: ", website] +productInfo = + mconcat [productName, ", v", printVersion buildVersion, " :: ", webRepo] -- | Product name. @@ -55,6 +79,21 @@ productName = "headroom" --- | Homepage website of the product. -website :: Text -website = "https://github.com/vaclavsvejcar/headroom" +-- | Product documentation website for given version. +webDoc :: Version -> Text +webDoc v = "http://doc.norcane.com/headroom/v" <> printVersion v + + +-- | Link to configuration documentation for current version. +webDocConfigCurr :: Text +webDocConfigCurr = webDoc buildVersion <> "/documentation/configuration/" + + +-- | Product migration guide for given version. +webDocMigration :: Version -> Text +webDocMigration v = webDoc v <> "/migration-guide" + + +-- | Product source code repository. +webRepo :: Text +webRepo = "https://github.com/vaclavsvejcar/headroom" diff --git a/src/Headroom/Meta/Version.hs b/src/Headroom/Meta/Version.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/Meta/Version.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Headroom.Meta.Version +Description : Type safe representation of Haskell PVP version +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types and functions for working with +Haskell PVP versions () in type safe way. +-} + +module Headroom.Meta.Version + ( Version(..) + , parseVersion + , printVersion + , printVersionP + , pvp + ) +where + +import Data.Aeson ( FromJSON(..) + , Value(String) + ) +import Headroom.Data.Regex ( match + , re + ) +import qualified Headroom.Data.Text as T +import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) +import RIO +import qualified RIO.Text as T + + +--------------------------------- DATA TYPES --------------------------------- + +-- | Type safe representation of /PVP/ version. +data Version = Version + { vMajor1 :: Int + -- ^ first major version + , vMajor2 :: Int + -- ^ second major version + , vMinor :: Int + -- ^ minor version + , vPatch :: Int + -- ^ patch level version + } + deriving (Eq, Show) + + +instance Ord Version where + compare (Version a1 b1 c1 d1) (Version a2 b2 c2 d2) = go pairs + where + pairs = [(a1, a2), (b1, b2), (c1, c2), (d1, d2)] + go [] = EQ + go ((x, y) : xs) | x /= y = compare x y + | otherwise = go xs + + +instance FromJSON Version where + parseJSON (String s) = maybe (error . errorMsg $ s) pure (parseVersion s) + parseJSON other = error . errorMsg . tshow $ other + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Parses 'Version' from given text. +-- +-- >>> parseVersion "0.3.2.0" +-- Just (Version {vMajor1 = 0, vMajor2 = 3, vMinor = 2, vPatch = 0}) +parseVersion :: Text + -- ^ input text to parse version from + -> Maybe Version + -- ^ parsed 'Version' +parseVersion raw = do + groups <- match [re|^([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$|] raw + check . catMaybes $ T.read <$> groups + where + check [ma1, ma2, mi, p] = Just $ Version ma1 ma2 mi p + check _ = Nothing + + +-- | Prints 'Version' in @major1.major2.minor.patch@ format. +-- +-- >>> printVersion (Version 0 3 2 0) +-- "0.3.2.0" +printVersion :: Version + -- ^ 'Version' to print + -> Text + -- ^ textual representation +printVersion (Version ma1 ma2 mi p) = T.intercalate "." chunks + where chunks = tshow <$> [ma1, ma2, mi, p] + + +-- | Similar to 'printVersion', but adds the @v@ prefix in front of the version +-- number. +-- +-- >>> printVersionP (Version 0 3 2 0) +-- "v0.3.2.0" +printVersionP :: Version -> Text +printVersionP = ("v" <>) . printVersion + + +-- | QuasiQuoter for defining 'Version' values checked at compile time. +-- +-- >>> [pvp|1.2.3.4|] +-- Version {vMajor1 = 1, vMajor2 = 2, vMinor = 3, vPatch = 4} +pvp :: QuasiQuoter +pvp = QuasiQuoter { quoteExp = quoteExpVersion + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + where + quoteExpVersion txt = [| parseVersionUnsafe . T.pack $ txt |] + where !_ = parseVersionUnsafe . T.pack $ txt -- check at compile time + + +------------------------------ PRIVATE FUNCTIONS ----------------------------- + +parseVersionUnsafe :: Text -> Version +parseVersionUnsafe raw = case parseVersion raw of + Nothing -> error . errorMsg $ raw + Just res -> res + +errorMsg :: Text -> String +errorMsg raw = mconcat + [ "Value '" + , T.unpack raw + , "' is not valid PVP version string. Please define correct version in " + , "format 'MAJOR1.MAJOR2.MINOR.PATCH' (e.g. '0.4.1.2')." + ] diff --git a/src/Headroom/Serialization.hs b/src/Headroom/Serialization.hs --- a/src/Headroom/Serialization.hs +++ b/src/Headroom/Serialization.hs @@ -4,7 +4,7 @@ {-| Module : Headroom.Serialization Description : Various functions for data (de)serialization -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -24,14 +24,14 @@ ) where -import Data.Aeson ( Options - , ToJSON(..) - , defaultOptions - , fieldLabelModifier - ) -import qualified Data.Yaml.Pretty as YP +import Data.Aeson ( Options + , ToJSON(..) + , defaultOptions + , fieldLabelModifier + ) +import qualified Data.Yaml.Pretty as YP import RIO -import qualified RIO.Char as C +import qualified RIO.Char as C diff --git a/src/Headroom/SourceCode.hs b/src/Headroom/SourceCode.hs new file mode 100644 --- /dev/null +++ b/src/Headroom/SourceCode.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +{-| +Module : Headroom.SourceCode +Description : Type safe representation of analyzed source code +Copyright : (c) 2019-2021 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types and function used for analysis and type safe +representation of source code files. +-} + +module Headroom.SourceCode + ( -- * Data Types + LineType(..) + , CodeLine + , SourceCode(..) + -- * Functions + , fromText + , toText + , firstMatching + , lastMatching + , stripStart + , stripEnd + , cut + ) +where + +import Control.Monad.State ( State + , evalState + ) +import Headroom.Data.Coerce ( coerce + , inner + ) +import Headroom.Data.Text ( fromLines + , toLines + ) +import RIO +import qualified RIO.List as L +import qualified RIO.Text as T + + +--------------------------------- DATA TYPES --------------------------------- + +-- | Represents type of the line in source code. +data LineType + = Code -- ^ Line of code + | Comment -- ^ Line of comment + deriving (Eq, Show) + +-- | Type alias for analyzed line of code. +type CodeLine = (LineType, Text) + +-- | Represents analyzed source code. +newtype SourceCode + = SourceCode [CodeLine] + deriving stock (Eq, Show) + deriving newtype (Semigroup, Monoid) + + +------------------------------ PUBLIC FUNCTIONS ------------------------------ + +-- | Converts 'Text' into 'SourceCode' using the given function to analyze +-- each line's 'LineType'. The analyzing function can hold any state that is +-- accumulated as the text is processed, for example to hold some info about +-- already processed lines. +fromText :: a + -- ^ initial state of analyzing function + -> (Text -> State a LineType) + -- ^ function that analyzes currently processed line + -> Text + -- ^ raw source code to analyze + -> SourceCode + -- ^ analyzed 'SourceCode' +fromText s0 f (toLines -> ls) = coerce $ zip (evalState (mapM f ls) s0) ls + + +-- | Converts analyzed 'SourceCode' back into 'Text'. +toText :: SourceCode + -- ^ source code to convert back to plain text + -> Text + -- ^ resulting plain text +toText (SourceCode sc) = fromLines . fmap snd $ sc + + +-- | Finds very first line matching given predicate and optionally performs some +-- operation over it. +firstMatching :: (CodeLine -> Maybe a) + -- ^ predicate (and transform) function + -> SourceCode + -- ^ source code to search in + -> Maybe (Int, a) + -- ^ first matching line (if found) +firstMatching f sc = go (coerce sc) 0 + where + go [] _ = Nothing + go (x : xs) i | Just res <- f x = Just (i, res) + | otherwise = go xs (i + 1) + + +-- | Finds very last line matching given predicate and optionally performs some +-- operation over it. +lastMatching :: (CodeLine -> Maybe a) + -- ^ predicate (and transform) function + -> SourceCode + -- ^ source code to search in + -> Maybe (Int, a) + -- ^ last matching line (if found) +lastMatching f sc = + let matching = firstMatching f . inner @_ @[CodeLine] reverse $ sc + lastIdx = length (coerce sc :: [CodeLine]) - 1 + in fmap (first (lastIdx -)) matching + + +-- | Strips empty lines at the beginning of source code. +-- +-- >>> stripStart $ SourceCode [(Code, ""), (Code, "foo"), (Code, "")] +-- SourceCode [(Code,"foo"),(Code,"")] +stripStart :: SourceCode + -- ^ source code to strip + -> SourceCode + -- ^ stripped source code +stripStart = inner @_ @[CodeLine] (L.dropWhile (T.null . T.strip . snd)) + + +-- | Strips empty lines at the end of source code. +-- +-- >>> stripEnd $ SourceCode [(Code, ""), (Code, "foo"), (Code, "")] +-- SourceCode [(Code,""),(Code,"foo")] +stripEnd :: SourceCode + -- ^ source code to strip + -> SourceCode + -- ^ stripped source code +stripEnd = inner @_ @[CodeLine] (L.dropWhileEnd (T.null . T.strip . snd)) + + +-- | Cuts snippet from the source code using the given start and end position. +-- +-- >>> cut 1 3 $ SourceCode [(Code, "1"), (Code, "2"),(Code, "3"),(Code, "4")] +-- SourceCode [(Code,"2"),(Code,"3")] +cut :: Int + -- ^ index of first line to be included into the snippet + -> Int + -- ^ index of the first line after the snippet + -> SourceCode + -- ^ source code to cut + -> SourceCode + -- ^ cut snippet +cut s e = inner @_ @[CodeLine] (L.take (e - s) . L.drop s) diff --git a/src/Headroom/Template.hs b/src/Headroom/Template.hs --- a/src/Headroom/Template.hs +++ b/src/Headroom/Template.hs @@ -2,38 +2,43 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StrictData #-} {-| Module : Headroom.Template -Description : Generic representation of supported template type -Copyright : (c) 2019-2020 Vaclav Svejcar +Description : Extensible templating support +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental Portability : POSIX -Module providing generic representation of supported template type, using -the 'Template' /type class/. +Module providing interface for working with template files in extensible way. +Supported template is represented by the 'Template' /type class/. -} module Headroom.Template - ( Template(..) + ( -- * Extendable Template Support + Template(..) + -- * Helper Functions + , emptyTemplate + -- * Error Data Types , TemplateError(..) ) where -import Headroom.Types ( fromHeadroomError - , toHeadroomError - ) -import Headroom.Variables.Types ( Variables(..) ) +import Data.String.Interpolate ( iii ) +import Headroom.Types ( fromHeadroomError + , toHeadroomError + ) +import Headroom.Variables.Types ( Variables(..) ) import RIO -import qualified RIO.Text as T +import qualified RIO.Text as T --- | Type class representing generic license header template support. -class Template t where - +-- | /Type class/ representing supported template file. +class Template a where -- | Returns list of supported file extensions for this template type. templateExtensions :: NonEmpty Text @@ -46,7 +51,7 @@ -- ^ name of the template (optional) -> Text -- ^ raw template text - -> m t + -> m a -- ^ parsed template @@ -54,7 +59,7 @@ renderTemplate :: MonadThrow m => Variables -- ^ values of variables to replace - -> t + -> a -- ^ parsed template to render -> m Text -- ^ rendered template text @@ -62,14 +67,21 @@ -- | Returns the raw text of the template, same that has been parsed by -- 'parseTemplate' method. - rawTemplate :: t + rawTemplate :: a -- ^ template for which to return raw template text -> Text -- ^ raw template text ---------------------------------- Error Types -------------------------------- +------------------------------ PUBLIC FUNCTIONS ------------------------------ +-- | Returns empty template of selected type. +emptyTemplate :: (MonadThrow m, Template a) => m a +emptyTemplate = parseTemplate Nothing T.empty + + +--------------------------------- ERROR TYPES -------------------------------- + -- | Error during processing template. data TemplateError = MissingVariables Text [Text] @@ -78,16 +90,18 @@ -- ^ 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 +displayException' = \case + MissingVariables name variables -> [iii| + Missing variables for #{name}: #{variables} + |] + ParseError msg -> [iii| + 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 @@ -1,17 +1,19 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} {-| Module : Headroom.Template.Mustache Description : Implementation of /Mustache/ template support -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental Portability : POSIX -This module provides support for templates. +This module provides support for +templates. -} module Headroom.Template.Mustache @@ -19,34 +21,40 @@ ) where -import Headroom.Template ( Template(..) - , TemplateError(..) - ) -import Headroom.Variables.Types ( Variables(..) ) +import Headroom.Template ( Template(..) + , TemplateError(..) + ) +import Headroom.Variables.Types ( Variables(..) ) import RIO -import qualified RIO.Text as T -import qualified Text.Mustache as MU -import Text.Mustache.Render ( SubstitutionError(..) ) +import qualified RIO.Text as T +import qualified Text.Mustache as MU +import Text.Mustache.Render ( SubstitutionError(..) ) -- | The /Mustache/ template. -data Mustache = Mustache MU.Template Text +data Mustache = Mustache + { mCompiledTemplate :: MU.Template + , mRawTemplate :: Text + } deriving Show +instance Eq Mustache where + a == b = mRawTemplate a == mRawTemplate b + -- | Support for /Mustache/ templates. instance Template Mustache where templateExtensions = "mustache" :| [] parseTemplate = parseTemplate' renderTemplate = renderTemplate' - rawTemplate = rawTemplate' + rawTemplate = mRawTemplate parseTemplate' :: MonadThrow m => Maybe Text -> Text -> m Mustache parseTemplate' name raw = case MU.compileTemplate templateName raw of Left err -> throwM . ParseError $ tshow err Right res -> pure $ Mustache res raw - where templateName = T.unpack . fromMaybe "" $ name + where templateName = T.unpack . fromMaybe T.empty $ name renderTemplate' :: MonadThrow m => Variables -> Mustache -> m Text @@ -61,8 +69,3 @@ in if length errs == length errs' then throwM $ MissingVariables (T.pack name) errs' else pure rendered - - -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 @@ -6,7 +6,7 @@ {-| Module : Headroom.Types Description : Application data types -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -22,14 +22,11 @@ , fromHeadroomError , toHeadroomError -- * Other Data Types - , TemplateMeta(..) - , HaddockFieldOffsets(..) , CurrentYear(..) ) where -import Data.Default.Class ( Default(..) ) -import Data.Typeable ( cast ) +import Data.Typeable ( cast ) import RIO @@ -69,19 +66,3 @@ -- ^ value of current year } deriving (Eq, Show) - - --- | Offsets for selected fields extracted from /Haddock module header/. -data HaddockFieldOffsets = HaddockFieldOffsets - { hfoCopyright :: Maybe Int - -- ^ offset for /Copyright/ field - } - deriving (Eq, Show) - -instance Default HaddockFieldOffsets where - def = HaddockFieldOffsets { hfoCopyright = Nothing } - --- | Metadata parsed from raw /template/, specific for selected /file type/. -data TemplateMeta = HaskellTemplateMeta HaddockFieldOffsets - deriving (Eq, Show) - diff --git a/src/Headroom/UI.hs b/src/Headroom/UI.hs --- a/src/Headroom/UI.hs +++ b/src/Headroom/UI.hs @@ -3,7 +3,7 @@ {-| Module : Headroom.UI Description : UI Components -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental 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 @@ -4,7 +4,7 @@ {-| Module : Headroom.UI.Progress Description : UI component for displaying progress -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -20,9 +20,9 @@ where import RIO -import qualified RIO.List as L -import qualified RIO.Text as T -import Text.Printf ( printf ) +import qualified RIO.List as L +import qualified RIO.Text as T +import Text.Printf ( printf ) -- | Progress indication. First argument is current progress, second the maximum diff --git a/src/Headroom/Variables.hs b/src/Headroom/Variables.hs --- a/src/Headroom/Variables.hs +++ b/src/Headroom/Variables.hs @@ -1,13 +1,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeApplications #-} {-| Module : Headroom.Variables Description : Support for template variables -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental @@ -27,16 +28,17 @@ ) where -import Headroom.Meta ( TemplateType ) -import Headroom.Template ( Template(..) ) -import Headroom.Types ( CurrentYear(..) - , fromHeadroomError - , toHeadroomError - ) -import Headroom.Variables.Types ( Variables(..) ) +import Data.String.Interpolate ( iii ) +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 +import qualified RIO.HashMap as HM +import qualified RIO.Text as T -- | Constructor function for 'Variables' data type. @@ -114,5 +116,7 @@ displayException' :: VariablesError -> String -displayException' = T.unpack . \case - InvalidVariable raw -> ("Cannot parse variable key=value from: " <> raw) +displayException' = \case + InvalidVariable raw -> [iii| + Cannot parse variable in format KEY=VALUE from: #{raw} + |] diff --git a/src/Headroom/Variables/Types.hs b/src/Headroom/Variables/Types.hs --- a/src/Headroom/Variables/Types.hs +++ b/src/Headroom/Variables/Types.hs @@ -3,7 +3,7 @@ {-| Module : Headroom.Variables.Types Description : Data types for "Headroom.Variables" -Copyright : (c) 2019-2020 Vaclav Svejcar +Copyright : (c) 2019-2021 Vaclav Svejcar License : BSD-3-Clause Maintainer : vaclav.svejcar@gmail.com Stability : experimental diff --git a/test-data/code-samples/c/sample1.c b/test-data/code-samples/c/sample1.c --- a/test-data/code-samples/c/sample1.c +++ b/test-data/code-samples/c/sample1.c @@ -9,4 +9,8 @@ // printf() displays the string inside quotation printf("Hello, World!"); return 0; + + /* + * block comment + */ } diff --git a/test-data/code-samples/cpp/sample1.cpp b/test-data/code-samples/cpp/sample1.cpp --- a/test-data/code-samples/cpp/sample1.cpp +++ b/test-data/code-samples/cpp/sample1.cpp @@ -8,6 +8,11 @@ /* This is not header */ int main() { + // line comment std::cout << "Hello World!"; return 0; + + /* + * multiline block comment + */ } diff --git a/test-data/code-samples/css/sample1.css b/test-data/code-samples/css/sample1.css --- a/test-data/code-samples/css/sample1.css +++ b/test-data/code-samples/css/sample1.css @@ -10,3 +10,7 @@ } /* This is not header */ + +/* + * block comment + */ 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 @@ -11,10 +11,32 @@ long description + +== Code sample +@ +{-# LANGUAGE TypeApplications #-} + +module Data.VCS.Test where + +import Data.VCS.Ignore ( Git, Repo(..), listRepo ) + +example :: IO [FilePath] +example = do + repo <- scanRepo @Git "path/to/repo" + listRepo repo +@ -} {-# LANGUAGE OverloadedStrings #-} module Test where +{- single line block comment -} + +{- +multi line block comment +-} + foo :: String foo = "Hello, world!" + +-- line comment diff --git a/test-data/code-samples/haskell/sample3.hs b/test-data/code-samples/haskell/sample3.hs new file mode 100644 --- /dev/null +++ b/test-data/code-samples/haskell/sample3.hs @@ -0,0 +1,23 @@ +{-| +Module : Data.VCS.Ignore.Repo +Description : Type class representing the VCS repository +Copyright : (c) 2020 Vaclav Svejcar +License : BSD-3-Clause +Maintainer : vaclav.svejcar@gmail.com +Stability : experimental +Portability : POSIX + +This module contains /type class/ representing the selected type of /VCS/ +repository. + +@ + {-# LANGUAGE TypeApplications #-} +@ +-} + +{-# LANGUAGE OverloadedStrings #-} +module Test where + +foo :: String +foo = "Hello, World!" +{-# INLINE key_function #-} diff --git a/test-data/code-samples/html/sample1.html b/test-data/code-samples/html/sample1.html --- a/test-data/code-samples/html/sample1.html +++ b/test-data/code-samples/html/sample1.html @@ -13,4 +13,7 @@ Hello, World! + diff --git a/test-data/code-samples/java/sample1.java b/test-data/code-samples/java/sample1.java --- a/test-data/code-samples/java/sample1.java +++ b/test-data/code-samples/java/sample1.java @@ -10,5 +10,6 @@ /* This is not header */ public static void main(String[] args) { System.out.println("Hello, world!"); + // line header } } diff --git a/test-data/code-samples/js/sample1.js b/test-data/code-samples/js/sample1.js --- a/test-data/code-samples/js/sample1.js +++ b/test-data/code-samples/js/sample1.js @@ -5,4 +5,5 @@ function answer() { /* This is not header */ return 42; + // line comment } diff --git a/test-data/code-samples/purescript/full.purs b/test-data/code-samples/purescript/full.purs --- a/test-data/code-samples/purescript/full.purs +++ b/test-data/code-samples/purescript/full.purs @@ -5,5 +5,11 @@ module Test where +{- +block comment multi line +-} + foo :: String foo = "Hello, world!" + +{- block comment single line -} diff --git a/test-data/code-samples/rust/sample1.rs b/test-data/code-samples/rust/sample1.rs --- a/test-data/code-samples/rust/sample1.rs +++ b/test-data/code-samples/rust/sample1.rs @@ -5,4 +5,5 @@ fn main() { /* This is not header */ println!("Hello World!"); + // line comment } diff --git a/test-data/code-samples/scala/sample1.scala b/test-data/code-samples/scala/sample1.scala --- a/test-data/code-samples/scala/sample1.scala +++ b/test-data/code-samples/scala/sample1.scala @@ -8,4 +8,5 @@ object Hello extends App { println("Hello, world!") + // line comment } 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 @@ -11,17 +11,17 @@ where import Headroom.Command.Init -import Headroom.Command.Types ( CommandInitOptions(..) ) -import Headroom.Configuration.Types ( LicenseType(..) ) -import Headroom.Data.Has ( Has(..) ) -import Headroom.Data.Lens ( suffixLenses - , suffixLensesFor - ) -import Headroom.FileSystem ( FileSystem(..) ) -import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Command.Types ( CommandInitOptions(..) ) +import Headroom.Configuration.Types ( LicenseType(..) ) +import Headroom.Data.Has ( Has(..) ) +import Headroom.Data.Lens ( suffixLenses + , suffixLensesFor + ) +import Headroom.FileSystem ( FileSystem(..) ) +import Headroom.FileType.Types ( FileType(..) ) import RIO -import RIO.FilePath ( () ) -import qualified RIO.List as L +import RIO.FilePath ( () ) +import qualified RIO.List as L import Test.Hspec 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,26 +8,23 @@ where import Headroom.Command.Readers -import Headroom.Configuration.Types ( LicenseType ) -import Headroom.Data.EnumExtra ( EnumExtra(..) ) -import Headroom.FileType.Types ( FileType ) +import Headroom.Configuration.Types ( LicenseType ) +import Headroom.Data.EnumExtra ( EnumExtra(..) ) +import Headroom.FileType.Types ( FileType ) import RIO -import qualified RIO.Text as T +import qualified RIO.Text as T import Test.Hspec -import Test.Hspec.QuickCheck ( prop ) +import Test.Hspec.QuickCheck ( prop ) import Test.QuickCheck spec :: Spec spec = do - describe "parseLicenseAndFileType" $ do - prop "should parse license and file type from raw input" - prop_parseLicenseAndFileType - + describe "parseLicense" $ do + prop "should parse license and file type from raw input" prop_parseLicense where - licenseTypes = fmap (T.toLower . enumToText) (allValues @LicenseType) - fileTypes = fmap (T.toLower . enumToText) (allValues @FileType) - licenseAndFileTypesGen = elements - $ concatMap (\lt -> fmap (\ft -> lt <> ":" <> ft) fileTypes) licenseTypes - prop_parseLicenseAndFileType = - forAll licenseAndFileTypesGen (isJust . parseLicenseAndFileType) + licenseTypes = T.toLower . enumToText <$> allValues @LicenseType + fileTypes = T.toLower . enumToText <$> allValues @FileType + together = \lt -> fmap (\ft -> lt <> ":" <> ft) fileTypes + licenseAndFileTypesGen = elements $ concatMap together licenseTypes + prop_parseLicense = forAll licenseAndFileTypesGen (isJust . parseLicense) diff --git a/test/Headroom/Command/RunSpec.hs b/test/Headroom/Command/RunSpec.hs --- a/test/Headroom/Command/RunSpec.hs +++ b/test/Headroom/Command/RunSpec.hs @@ -2,44 +2,47 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# 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 - , suffixLensesFor - ) -import Headroom.Data.TextExtra ( fromLines ) -import Headroom.FileSystem ( FileSystem(..) ) -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 qualified RIO.Map as M -import qualified RIO.NonEmpty as NE -import qualified RIO.Text as T +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 + , suffixLensesFor + ) +import Headroom.Data.Regex ( re ) +import Headroom.Data.Text ( fromLines ) +import Headroom.FileSystem ( FileSystem(..) ) +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 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.Hspec.QuickCheck ( prop ) +import Test.QuickCheck hiding ( sample ) import Test.QuickCheck.Monadic @@ -111,21 +114,8 @@ , "-- Copyright (c) 2017-2020 2nd Author" ] vars = mkVariables [("sndAuthor", "2nd Author")] - syntax = LineComment "--" + syntax = LineComment [re|^--|] (Just "--") runRIO env (postProcessHeader' syntax vars sample) `shouldReturn` 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 diff --git a/test/Headroom/Configuration/CompatSpec.hs b/test/Headroom/Configuration/CompatSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Configuration/CompatSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Headroom.Configuration.CompatSpec + ( spec + ) +where + +import Headroom.Configuration.Compat +import Headroom.Meta.Version ( Version(..) + , pvp + ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + describe "checkCompatibility" $ do + it "passes when config version is compatible" $ do + let yaml = "version: 0.4.0.0" + curr = [pvp|0.4.0.0|] + version = [pvp|0.4.0.0|] + versions = [[pvp|0.1.0.0|], [pvp|0.2.1.0|], [pvp|0.4.0.0|]] + checkCompatibility versions curr yaml `shouldBe` Just version + + it "fails when config version is not compatible" $ do + let yaml = "version: 0.2.1.0" + curr = [pvp|0.2.1.0|] + versions = [[pvp|0.1.0.0|], [pvp|0.2.1.0|], [pvp|0.4.0.0|]] + let err (UnsupportedVersion [Version 0 4 0 0] (Version 0 2 1 0)) = True + err _ = False + checkCompatibility versions curr yaml `shouldThrow` err + + it "fails when version is newer than Headroom version" $ do + let yaml = "version: 0.2.1.0" + curr = [pvp|0.2.0.0|] + versions = [[pvp|0.1.0.0|]] + let err (NewerVersionDetected (Version 0 2 1 0)) = True + err _ = False + checkCompatibility versions curr yaml `shouldThrow` err + + it "fails when config version cannot be determined" $ do + let yaml = "" + curr = [pvp|0.2.0.0|] + versions = [[pvp|0.1.0.0|], [pvp|0.2.1.0|], [pvp|0.4.0.0|]] + let err CannotParseVersion = True + err _ = False + checkCompatibility versions curr yaml `shouldThrow` err diff --git a/test/Headroom/Configuration/EnrichSpec.hs b/test/Headroom/Configuration/EnrichSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Configuration/EnrichSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Headroom.Configuration.EnrichSpec + ( spec + ) +where + +import Headroom.Configuration.Enrich +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + describe "withArray" $ do + it "produces valid YAML array field" $ do + let field = "name" + values = ["foo", "bar"] :: [Text] + withArray values field `shouldBe` (Array, "name:\n- foo\n- bar") + + + describe "withText" $ do + it "produces valid YAML string from Text value" $ do + let field = "name" + value = "John Smith" :: Text + withText value field `shouldBe` (String, "name: John Smith") + + + describe "replaceEmptyValue" $ do + it "replaces YAML array field" $ do + let field = "name" + values = ["foo", "bar"] :: [Text] + yaml = "name: []" + action = replaceEmptyValue field $ withArray values + enrich action yaml `shouldBe` "name:\n- foo\n- bar" + + it "replaces multiple YAML array fields using Semigroup instance" $ do + let animalsF = "animals" + animals = ["dog", "cat"] :: [Text] + colorsF = "colors" + colors = ["blue", "red"] :: [Text] + yaml = "colors: []\nanimals: []" + enrichAnimals = replaceEmptyValue animalsF $ withArray animals + enrichColors = replaceEmptyValue colorsF (withArray colors) + action = enrichAnimals <> enrichColors + expected = "colors:\n- blue\n- red\nanimals:\n- dog\n- cat" + enrich action yaml `shouldBe` expected diff --git a/test/Headroom/ConfigurationSpec.hs b/test/Headroom/ConfigurationSpec.hs --- a/test/Headroom/ConfigurationSpec.hs +++ b/test/Headroom/ConfigurationSpec.hs @@ -6,7 +6,7 @@ where import Headroom.Configuration -import Headroom.Embedded ( defaultConfig ) +import Headroom.Embedded ( defaultConfig ) import RIO import Test.Hspec diff --git a/test/Headroom/Data/CoerceSpec.hs b/test/Headroom/Data/CoerceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Data/CoerceSpec.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Headroom.Data.CoerceSpec + ( spec + ) +where + +import Headroom.Data.Coerce +import RIO +import qualified RIO.Text as T +import Test.Hspec + + +spec :: Spec +spec = do + describe "inner" $ do + it "applies function to inner value of newtype" $ do + let sample = Foo "hello" + expected = Foo "HELLO" + inner T.toUpper sample `shouldBe` expected + + +newtype Foo = Foo Text deriving (Eq, Show) diff --git a/test/Headroom/Data/RegexSpec.hs b/test/Headroom/Data/RegexSpec.hs --- a/test/Headroom/Data/RegexSpec.hs +++ b/test/Headroom/Data/RegexSpec.hs @@ -20,3 +20,12 @@ match regex "foz" `shouldSatisfy` isNothing match regex "foosdas" `shouldSatisfy` isJust match regex "barfoo" `shouldSatisfy` isJust + + + describe "isMatch" $ do + it "checks if regular expression matches against given sample" $ do + let regex = [re|foo|bar|] + isMatch regex "foz" `shouldBe` False + isMatch regex "xxx" `shouldBe` False + isMatch regex "foosdas" `shouldBe` True + isMatch regex "barfoo" `shouldBe` True diff --git a/test/Headroom/Data/TextExtraSpec.hs b/test/Headroom/Data/TextExtraSpec.hs deleted file mode 100644 --- a/test/Headroom/Data/TextExtraSpec.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# 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/Data/TextSpec.hs b/test/Headroom/Data/TextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Data/TextSpec.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module Headroom.Data.TextSpec + ( spec + ) +where + +import Headroom.Data.Text +import RIO +import qualified RIO.Text as T +import Test.Hspec + + +spec :: Spec +spec = do + + describe "commonLinesPrefix" $ do + it "returns longest common prefix for lines of text" $ do + let text = fromLines ["-- foo", "-- bar", "-- xx"] + commonLinesPrefix text `shouldBe` Just "-- " + + it "returns Nothing if not all elements starts with same prefix" $ do + let text = fromLines ["-- foo", "bar", "-- xx"] + commonLinesPrefix text `shouldBe` Nothing + + it "returns Nothing if no common prefix found" $ do + let text = fromLines ["foo", "bar", "hello"] + commonLinesPrefix text `shouldBe` Nothing + + it "returns Nothing if input is empty" $ do + commonLinesPrefix T.empty `shouldBe` Nothing + + + describe "replaceFirst" $ do + it "does nothing on empty pattern" $ do + replaceFirst "" "/" "a :: b :: c" `shouldBe` "a :: b :: c" + + it "replaces only first pattern with substitute" $ do + replaceFirst "::" "/" "a :: b :: c" `shouldBe` "a / b :: c" + + + describe "mapLines" $ do + it "returns same output for identity function" $ do + let sample = fromLines ["foo zz", "bar", "xx"] + mapLines id sample `shouldBe` sample + + it "maps 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 "mapLinesF" $ do + it "returns same output for identity function" $ do + let sample = fromLines ["foo zz", "bar", "xx"] + mapLinesF (Just <$> id) sample `shouldBe` sample + + it "maps all lines using the function" $ do + let sample = fromLines ["foo zz", "bar", "xx"] + fn = \l -> if l == "bar" then Nothing else Just ("L: " <> l) + expected = fromLines ["L: foo zz", "L: xx"] + mapLinesF 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 deleted file mode 100644 --- a/test/Headroom/Ext/Haskell/HaddockSpec.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/Headroom/Ext/HaskellSpec.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# 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/Ext/JavaSpec.hs b/test/Headroom/Ext/JavaSpec.hs deleted file mode 100644 --- a/test/Headroom/Ext/JavaSpec.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Headroom.Ext.JavaSpec - ( spec - ) -where - -import Headroom.Configuration.Types ( HeaderConfig(..) - , HeaderSyntax(..) - ) -import Headroom.Ext.Java -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 "extractPackageName" $ do - it "extracts package name from Java source code" $ do - sample <- loadFile $ codeSamples "java" "sample1.java" - extractPackageName sample `shouldBe` Just "foo" - - - describe "extractVariables" $ do - it "extracts variables from Java source code" $ do - let config = HeaderConfig ["java"] 0 0 [] [] (BlockComment "/*" "*/") - meta = Nothing - headerPos = Just (0, 2) - expected = mkVariables [("_java_package_name", "foo")] - sample <- loadFile $ codeSamples "java" "sample1.java" - extractVariables config meta headerPos sample `shouldBe` expected diff --git a/test/Headroom/Ext/PureScriptSpec.hs b/test/Headroom/Ext/PureScriptSpec.hs deleted file mode 100644 --- a/test/Headroom/Ext/PureScriptSpec.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Headroom.Ext.PureScriptSpec - ( spec - ) -where - -import Headroom.Configuration.Types ( HeaderConfig(..) - , HeaderSyntax(..) - ) -import Headroom.Ext.PureScript -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 "extractVariables" $ do - it "extracts variables from PureScript source code" $ do - let config = HeaderConfig ["purs"] 0 0 [] [] (LineComment "--") - meta = Nothing - headerPos = Just (1, 13) - expected = mkVariables [("_purescript_module_name", "Test")] - sample <- loadFile $ codeSamples "purescript" "full.purs" - extractVariables config meta headerPos sample `shouldBe` expected diff --git a/test/Headroom/ExtSpec.hs b/test/Headroom/ExtSpec.hs deleted file mode 100644 --- a/test/Headroom/ExtSpec.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# 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 - - it "extracts variables specific for Java file type" $ do - let samplesDir = "test-data" "code-samples" - config = HeaderConfig ["java"] 0 0 [] [] (BlockComment "/*" "*/") - meta = Nothing - expected = mkVariables [("_java_package_name", "foo")] - sample <- readFileUtf8 $ samplesDir "java" "sample1.java" - extractVariables Java config meta (Just (0, 2)) sample `shouldBe` expected - - it "extracts variables specific for PureScript file type" $ do - let samplesDir = "test-data" "code-samples" - config = HeaderConfig ["purs"] 0 0 [] [] (LineComment "--") - meta = Nothing - expected = mkVariables [("_purescript_module_name", "Test")] - sample <- readFileUtf8 $ samplesDir "purescript" "full.purs" - extractVariables PureScript config meta (Just (1, 1)) sample - `shouldBe` expected - diff --git a/test/Headroom/FileSupport/CPPSpec.hs b/test/Headroom/FileSupport/CPPSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/CPPSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Headroom.FileSupport.CPPSpec + ( spec + ) +where + +import Headroom.FileSupport.CPP +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("// single line comment" , (True, True)) + , ("not // single line comment" , (False, False)) + , ("/* block comment start" , (True, False)) + , ("block comment end */" , (False, True)) + , ("/* block comment start/end */", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + where + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/CSSSpec.hs b/test/Headroom/FileSupport/CSSSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/CSSSpec.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Headroom.FileSupport.CSSSpec + ( spec + ) +where + +import Headroom.FileSupport.CSS +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("/* block comment start" , (True, False)) + , ("block comment end */" , (False, True)) + , ("/* block comment start/end */", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + where + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/CSpec.hs b/test/Headroom/FileSupport/CSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/CSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Headroom.FileSupport.CSpec + ( spec + ) +where + +import Headroom.FileSupport.C +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("// single line comment" , (True, True)) + , ("not // single line comment" , (False, False)) + , ("/* block comment start" , (True, False)) + , ("block comment end */" , (False, True)) + , ("/* block comment start/end */", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + where + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/HTMLSpec.hs b/test/Headroom/FileSupport/HTMLSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/HTMLSpec.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Headroom.FileSupport.HTMLSpec + ( spec + ) +where + +import Headroom.FileSupport.HTML +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("" , (False, True)) + , ("", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + where + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/Haskell/HaddockSpec.hs b/test/Headroom/FileSupport/Haskell/HaddockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/Haskell/HaddockSpec.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +module Headroom.FileSupport.Haskell.HaddockSpec + ( spec + ) +where + +import Headroom.Configuration.Types ( HeaderSyntax(..) + , LicenseType(..) + ) +import Headroom.Data.Regex ( re ) +import Headroom.Data.Text ( fromLines ) +import Headroom.Embedded ( licenseTemplate ) +import Headroom.FileSupport ( analyzeSourceCode + , fileSupport + ) +import Headroom.FileSupport.Haskell.Haddock +import Headroom.FileSupport.TemplateData ( HaddockOffsets(..) + , TemplateData(..) + ) +import Headroom.FileSystem ( loadFile ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Template ( Template(..) ) +import Headroom.Template.Mustache ( Mustache(..) ) +import RIO +import RIO.FilePath ( () ) +import Test.Hspec + + +spec :: Spec +spec = do + let codeSamples = "test-data" "code-samples" + + describe "extractOffsets" $ do + it "extract offsets for selected fields of module header" $ do + template <- parseTemplate @Mustache Nothing $ licenseTemplate BSD3 Haskell + let syntax = BlockComment [re|^{-\||] [re|(? "haskell" "header.hs" + 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 = analyzeSourceCode (fileSupport Haskell) raw + syntax = BlockComment [re|^{-\||] [re|(?) ) +import Test.Hspec + + +spec :: Spec +spec = do + let codeSamples = "test-data" "code-samples" "haskell" + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("-- single line comment" , (True, True)) + , ("not -- single line comment" , (False, False)) + , ("{- block comment start" , (True, False)) + , ("block comment end -}" , (False, True)) + , ("{- block comment start/end -}", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + + describe "fsExtractTemplateData" $ do + it "provides correct custom data for Haskell" $ do + template <- parseTemplate @Mustache Nothing (licenseTemplate BSD3 Haskell) + let o = Just 14 + td = HaskellTemplateData' HaddockOffsets { hoCopyright = o } + expected = HaskellTemplateData td + syntax = BlockComment [re|^{-\||] [re|(? "full.hs" + let ht = extractHeaderTemplate config Haskell template + headerPos = Just (1, 29) + longDesc = [__i| + long + description + + == Code sample + @ + {-\# LANGUAGE TypeApplications \#-} + + module Data.VCS.Test where + + import Data.VCS.Ignore ( Git, Repo(..), listRepo ) + + example :: IO [FilePath] + example = do + repo <- scanRepo @Git "path/to/repo" + listRepo repo + @ + |] + 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" , longDesc) + , ("_haskell_module_shortdesc" , "Short description") + ] + sample = analyzeSourceCode fileSupport' raw + fsExtractVariables fileSupport' ht headerPos sample `shouldBe` expected + + + describe "fsFileType" $ do + it "matches correct type for Haskell" $ do + fsFileType fileSupport' `shouldBe` Haskell + + where + fileSupport' = fileSupport Haskell + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport' + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/JSSpec.hs b/test/Headroom/FileSupport/JSSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/JSSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Headroom.FileSupport.JSSpec + ( spec + ) +where + +import Headroom.FileSupport.JS +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("// single line comment" , (True, True)) + , ("not // single line comment" , (False, False)) + , ("/* block comment start" , (True, False)) + , ("block comment end */" , (False, True)) + , ("/* block comment start/end */", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + where + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/JavaSpec.hs b/test/Headroom/FileSupport/JavaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/JavaSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Headroom.FileSupport.JavaSpec + ( spec + ) +where + +import Headroom.Configuration ( makeHeadersConfig + , parseConfiguration + ) +import Headroom.Configuration.Types ( Configuration(..) ) +import Headroom.Embedded ( defaultConfig ) +import Headroom.FileSupport ( analyzeSourceCode + , fileSupport + ) +import Headroom.FileSupport.TemplateData ( TemplateData(..) ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import Headroom.FileSystem ( loadFile ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Header ( extractHeaderTemplate ) +import Headroom.Template ( emptyTemplate ) +import Headroom.Template.Mustache ( Mustache ) +import Headroom.Variables ( mkVariables ) +import RIO +import RIO.FilePath ( () ) +import Test.Hspec + + +spec :: Spec +spec = do + let codeSamples = "test-data" "code-samples" "java" + + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("// single line comment" , (True, True)) + , ("not // single line comment" , (False, False)) + , ("/* block comment start" , (True, False)) + , ("block comment end */" , (False, True)) + , ("/* block comment start/end */", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + + describe "fsExtractTemplateData" $ do + it "doesn't provide any custom data for Java" $ do + template <- emptyTemplate @_ @Mustache + let syntax = undefined + expected = NoTemplateData + fsExtractTemplateData fileSupport' template syntax `shouldBe` expected + + + describe "fsExtractVariables" $ do + it "extract variables from Java source code" $ do + template <- emptyTemplate @_ @Mustache + defaultConfig' <- parseConfiguration defaultConfig + config <- makeHeadersConfig (cLicenseHeaders defaultConfig') + raw <- loadFile $ codeSamples "sample1.java" + let ht = extractHeaderTemplate config Java template + headerPos = Just (0, 2) + expected = mkVariables [("_java_package_name", "foo")] + sample = analyzeSourceCode fileSupport' raw + fsExtractVariables fileSupport' ht headerPos sample `shouldBe` expected + + + describe "fsFileType" $ do + it "matches correct type for Java" $ do + fsFileType fileSupport' `shouldBe` Java + + where + fileSupport' = fileSupport Java + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport' + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/PureScriptSpec.hs b/test/Headroom/FileSupport/PureScriptSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/PureScriptSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Headroom.FileSupport.PureScriptSpec + ( spec + ) +where + +import Headroom.Configuration ( makeHeadersConfig + , parseConfiguration + ) +import Headroom.Configuration.Types ( Configuration(..) ) +import Headroom.Embedded ( defaultConfig ) +import Headroom.FileSupport ( analyzeSourceCode + , fileSupport + ) +import Headroom.FileSupport.TemplateData ( TemplateData(..) ) +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import Headroom.FileSystem ( loadFile ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.Header ( extractHeaderTemplate ) +import Headroom.Template ( emptyTemplate ) +import Headroom.Template.Mustache ( Mustache ) +import Headroom.Variables ( mkVariables ) +import RIO +import RIO.FilePath ( () ) +import Test.Hspec + + +spec :: Spec +spec = do + let codeSamples = "test-data" "code-samples" "purescript" + + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("-- single line comment" , (True, True)) + , ("not -- single line comment" , (False, False)) + , ("{- block comment start" , (True, False)) + , ("block comment end -}" , (False, True)) + , ("{- block comment start/end -}", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + + describe "fsExtractTemplateData" $ do + it "doesn't provide any custom data for PureScript" $ do + template <- emptyTemplate @_ @Mustache + let syntax = undefined + expected = NoTemplateData + fsExtractTemplateData fileSupport' template syntax `shouldBe` expected + + + describe "fsExtractVariables" $ do + it "extract variables from PureScript source code" $ do + template <- emptyTemplate @_ @Mustache + defaultConfig' <- parseConfiguration defaultConfig + config <- makeHeadersConfig (cLicenseHeaders defaultConfig') + raw <- loadFile $ codeSamples "full.purs" + let ht = extractHeaderTemplate config PureScript template + headerPos = Just (1, 13) + expected = mkVariables [("_purescript_module_name", "Test")] + sample = analyzeSourceCode fileSupport' raw + fsExtractVariables fileSupport' ht headerPos sample `shouldBe` expected + + + describe "fsFileType" $ do + it "matches correct type for PureScript" $ do + fsFileType fileSupport' `shouldBe` PureScript + + where + fileSupport' = fileSupport PureScript + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport' + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/RustSpec.hs b/test/Headroom/FileSupport/RustSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/RustSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Headroom.FileSupport.RustSpec + ( spec + ) +where + +import Headroom.FileSupport.Rust +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("// single line comment" , (True, True)) + , ("not // single line comment" , (False, False)) + , ("/* block comment start" , (True, False)) + , ("block comment end */" , (False, True)) + , ("/* block comment start/end */", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + where + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/ScalaSpec.hs b/test/Headroom/FileSupport/ScalaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/ScalaSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Headroom.FileSupport.ScalaSpec + ( spec + ) +where + +import Headroom.FileSupport.Scala +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("// single line comment" , (True, True)) + , ("not // single line comment" , (False, False)) + , ("/* block comment start" , (True, False)) + , ("block comment end */" , (False, True)) + , ("/* block comment start/end */", (True, True)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + where + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupport/ShellSpec.hs b/test/Headroom/FileSupport/ShellSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/FileSupport/ShellSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Headroom.FileSupport.ShellSpec + ( spec + ) +where + +import Headroom.FileSupport.Shell +import Headroom.FileSupport.Types ( FileSupport(..) + , SyntaxAnalysis(..) + ) +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + + describe "fsSyntaxAnalysis" $ do + it "correctly detects comment starts/ends" $ do + let samples = + [ ("non comment line" , (False, False)) + , ("# single line comment" , (True, True)) + , ("not # single line comment", (False, False)) + ] + all checkSyntaxAnalysis samples `shouldBe` True + + where + checkSyntaxAnalysis (l, (s, e)) = + let SyntaxAnalysis {..} = fsSyntaxAnalysis fileSupport + in saIsCommentStart l == s && saIsCommentEnd l == e diff --git a/test/Headroom/FileSupportSpec.hs b/test/Headroom/FileSupportSpec.hs --- a/test/Headroom/FileSupportSpec.hs +++ b/test/Headroom/FileSupportSpec.hs @@ -1,345 +1,268 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} + module Headroom.FileSupportSpec ( spec ) where -import Headroom.Configuration ( makeHeadersConfig - , parseConfiguration - ) -import Headroom.Configuration.Types ( Configuration(..) - , HeaderConfig(..) - , HeaderSyntax(..) - , HeadersConfig(..) - ) -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 Headroom.FileSystem ( loadFile ) +import Headroom.FileType.Types ( FileType(..) ) +import Headroom.SourceCode ( LineType(..) + , SourceCode(..) + ) import RIO -import RIO.FilePath ( () ) +import RIO.FilePath ( () ) import Test.Hspec spec :: Spec spec = do - let samplesDir = "test-data" "code-samples" - lHeaderConfig pb pa = HeaderConfig ["hs"] 0 0 pb pa (LineComment "--") - bHeaderConfig = bHeaderConfigM 0 0 - bHeaderConfigM mb ma pb pa = - HeaderConfig ["hs"] mb ma pb pa (BlockComment "{-|" "-}") - - describe "addHeader" $ do - let fileInfo config = FileInfo Haskell config Nothing mempty - - it "adds header at the beginning of text" $ do - let info = fileInfo $ bHeaderConfig [] [] - header = "HEADER" - sample = "1\n2\nbefore\nafter\n4\n" - expected = "HEADER\n1\n2\nbefore\nafter\n4\n" - addHeader info header sample `shouldBe` expected - - it "adds header at the beginning of text (with correct margins)" $ do - let info = fileInfo $ bHeaderConfigM 2 2 [] [] - header = "HEADER" - sample = "1\n2\nbefore\nafter\n4\n" - expected = "HEADER\n\n\n1\n2\nbefore\nafter\n4\n" - addHeader info header sample `shouldBe` expected - - it "adds header at correct position" $ do - 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 [[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 [[re|^before|]] [] - header = "{-| HEADER -}" - sample = "1\n2\nbefore" - 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 [[re|^before|]] [] - header = "{-| HEADER -}" - info = FileInfo Haskell config (Just (3, 3)) mempty - sample = "1\n2\nbefore\n{-| OLDHEADER -}\nafter\n4" - addHeader info header sample `shouldBe` sample - - - describe "dropHeader" $ do - it "does nothing if no header is present" $ do - let config = bHeaderConfig [] [] - 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)) 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)) mempty - sample = "1\n2\nbefore\n{-| HEADER\nHERE -}\nafter\n4\n" - expected = "1\n2\nbefore\nafter\n4\n" - dropHeader info sample `shouldBe` expected - - - describe "replaceHeader" $ do - it "adds header if there's none present" $ do - 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 [[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" - replaceHeader info header sample `shouldBe` expected - - - describe "extractFileInfo" $ do - it "extracts FileInfo from given raw input" $ do - let config = bHeaderConfig [] [] - 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 meta sample `shouldBe` expected - - - describe "findHeader" $ do - it "finds block header (one line long)" $ do - let sample = "\n{-| single line -}\n\n" - config = bHeaderConfig [] [] - findHeader config sample `shouldBe` Just (1, 1) - - it "finds line header (one line long)" $ do - let sample = "\n-- single line\n\n" - config = lHeaderConfig [] [] - findHeader config sample `shouldBe` Just (1, 1) - - it "finds block comment header put after 'putAfter' constraint" $ do - let sample = "{-| 1 -}\nfoo\n{-| 2\n2 -}\nbar\n{-| 3\n3 -}" - 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 [[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 [[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 [[re|^bar|^foo|]] [] - findHeader config sample `shouldBe` Just (5, 6) - - it "finds nothing if no header present" $ do - let sample = "some\nrandom\text without header" - config = bHeaderConfig [] [] - findHeader config sample `shouldBe` Nothing - - it "finds nothing if header is present before 'putAfter' constraint" $ do - let sample = "foo\n{-| 1 -}\nbar\nsome text" - 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 (cLicenseHeaders defaultConfig') - sampleC1 <- loadFile $ path "c" "sample1.c" - sampleC2 <- loadFile $ path "c" "sample2.c" - sampleCpp1 <- loadFile $ path "cpp" "sample1.cpp" - sampleCpp2 <- loadFile $ path "cpp" "sample2.cpp" - sampleCss1 <- loadFile $ path "css" "sample1.css" - sampleCss2 <- loadFile $ path "css" "sample2.css" - sampleHs1 <- loadFile $ path "haskell" "sample1.hs" - sampleHs2 <- loadFile $ path "haskell" "sample2.hs" - sampleHtml1 <- loadFile $ path "html" "sample1.html" - sampleHtml2 <- loadFile $ path "html" "sample2.html" - sampleJava1 <- loadFile $ path "java" "sample1.java" - sampleJava2 <- loadFile $ path "java" "sample2.java" - sampleJs1 <- loadFile $ path "js" "sample1.js" - sampleRust1 <- loadFile $ path "rust" "sample1.rs" - sampleScala1 <- loadFile $ path "scala" "sample1.scala" - sampleScala2 <- loadFile $ path "scala" "sample2.scala" - sampleShell1 <- loadFile $ path "shell" "sample1.sh" - findHeader hscC sampleC1 `shouldBe` Just (1, 3) - findHeader hscC sampleC2 `shouldBe` Nothing - findHeader hscCpp sampleCpp1 `shouldBe` Just (1, 3) - findHeader hscCpp sampleCpp2 `shouldBe` Nothing - findHeader hscCss sampleCss1 `shouldBe` Just (1, 4) - findHeader hscCss sampleCss2 `shouldBe` Nothing - findHeader hscHaskell sampleHs1 `shouldBe` Just (1, 3) - findHeader hscHaskell sampleHs2 `shouldBe` Nothing - findHeader hscHtml sampleHtml1 `shouldBe` Just (1, 4) - findHeader hscHtml sampleHtml2 `shouldBe` Nothing - findHeader hscJava sampleJava1 `shouldBe` Just (0, 2) - findHeader hscJava sampleJava2 `shouldBe` Nothing - findHeader hscJs sampleJs1 `shouldBe` Just (0, 2) - findHeader hscRust sampleRust1 `shouldBe` Just (0, 2) - findHeader hscScala sampleScala1 `shouldBe` Just (0, 2) - findHeader hscScala sampleScala2 `shouldBe` Nothing - findHeader hscShell sampleShell1 `shouldBe` Just (2, 3) - - - describe "findBlockHeader" $ do - it "finds single line header" $ do - let sample = ["", "{-| single line -}", "", ""] - findBlockHeader "{-|" "-}" sample 0 `shouldBe` Just (1, 1) - - it "finds multi line header" $ do - let sample = ["", "{-| multi", "line -}", "", ""] - findBlockHeader "{-|" "-}" sample 0 `shouldBe` Just (1, 2) - - it "finds only the first occurence of header" $ do - let sample = ["{-| this", "and this -}", "", "{-| no this -}"] - findBlockHeader "{-|" "-}" sample 0 `shouldBe` Just (0, 1) - - it "finds nothing if no header is present" $ do - let sample = ["foo", "bar"] - findBlockHeader "{-|" "-}" sample 0 `shouldBe` Nothing - - - describe "findLineHeader" $ do - it "finds single line header" $ do - let sample = ["-- foo", ""] - findLineHeader "--" sample 0 `shouldBe` Just (0, 0) - - it "finds single line header with nothing surrounding it" $ do - let sample = ["-- foo"] - findLineHeader "--" sample 0 `shouldBe` Just (0, 0) - - it "finds multi line header with nothing surrounding it" $ do - let sample = ["-- 3", "-- 3"] - findLineHeader "--" sample 0 `shouldBe` Just (0, 1) - - it "finds multi line header" $ do - let sample = ["", "a", "-- first", "--second", "foo"] - findLineHeader "--" sample 0 `shouldBe` Just (2, 3) - - it "finds only the first occurence of header" $ do - let sample = ["a", "-- this one", "-- and this", "", "-- not this"] - findLineHeader "--" sample 0 `shouldBe` Just (1, 2) - - it "finds nothing if no header is present" $ do - let sample = ["foo", "bar"] - findLineHeader "--" sample 0 `shouldBe` Nothing - - - describe "lastMatching" $ do - let patterns = [[re|^foo|]] - - it "finds very last line that matches given patterns" $ do - let sample = ["some text", "hello", "foo bar", "foo baz", "last one"] - lastMatching patterns sample `shouldBe` Just 3 - - it "returns Nothing if no matching input found" $ do - let sample = ["some text", "hello", "last one"] - lastMatching patterns sample `shouldBe` Nothing - - it "returns Nothing the input is empty" $ do - lastMatching patterns [] `shouldBe` Nothing - - - describe "firstMatching" $ do - let patterns = [[re|^foo|]] - - it "finds very first line that matches given patterns" $ do - let sample = ["some text", "hello", "foo bar", "foo baz", "last one"] - firstMatching patterns sample `shouldBe` Just 2 - - it "returns Nothing if the input is empty" $ do - firstMatching patterns [] `shouldBe` Nothing - - - describe "splitInput" $ do - let sample = "text\n->\nRESULT\n<-\nfoo" - fstSplit = [[re|->|]] - sndSplit = [[re|<-|]] + let codeSamples = "test-data" "code-samples" - it "handles empty input and conditions" $ do - splitInput [] [] "" `shouldBe` ([], [], []) + describe "analyzeSourceCode" $ do + it "analyzes C source code" $ do + sample <- loadFile $ codeSamples "c" "sample1.c" + let expected = SourceCode + [ (Code , "") + , (Comment, "/*") + , (Comment, " * This is header") + , (Comment, " */") + , (Code , "") + , (Code , "#include ") + , (Comment, "/* This is not header */") + , (Code , "int main() {") + , (Comment, " // printf() displays the string inside quotation") + , (Code , " printf(\"Hello, World!\");") + , (Code , " return 0;") + , (Code , "") + , (Comment, " /*") + , (Comment, " * block comment") + , (Comment, " */") + , (Code , "}") + ] + analyzeSourceCode (fileSupport C) sample `shouldBe` expected - it "handles input and empty conditions" $ do - splitInput [] [] "one\ntwo" `shouldBe` ([], ["one", "two"], []) + it "analyzes C++ source code" $ do + sample <- loadFile $ codeSamples "cpp" "sample1.cpp" + let expected = SourceCode + [ (Code , "") + , (Comment, "/*") + , (Comment, " * This is header") + , (Comment, " */") + , (Code , "") + , (Code , "#include ") + , (Code , "") + , (Comment, "/* This is not header */") + , (Code , "") + , (Code , "int main() {") + , (Comment, " // line comment") + , (Code, " std::cout << \"Hello World!\";") + , (Code , " return 0;") + , (Code , "") + , (Comment, " /*") + , (Comment, " * multiline block comment") + , (Comment, " */") + , (Code , "}") + ] + analyzeSourceCode (fileSupport CPP) sample `shouldBe` expected - it "splits input with 1st split condition" $ do - let expected = (["text", "->"], ["RESULT", "<-", "foo"], []) - splitInput fstSplit [] sample `shouldBe` expected + it "analyzes CSS source code" $ do + sample <- loadFile $ codeSamples "css" "sample1.css" + let expected = SourceCode + [ (Code , "") + , (Comment, "/*") + , (Comment, " * This is") + , (Comment, " * the header") + , (Comment, " */") + , (Code , "") + , (Code , "body {") + , (Comment, " /* This is not header */") + , (Code , " color: black") + , (Code , "}") + , (Code , "") + , (Comment, "/* This is not header */") + , (Code , "") + , (Comment, "/*") + , (Comment, " * block comment") + , (Comment, " */") + ] + analyzeSourceCode (fileSupport CSS) sample `shouldBe` expected - it "splits input with 2nd split condition" $ do - let expected = ([], ["text", "->", "RESULT"], ["<-", "foo"]) - splitInput [] sndSplit sample `shouldBe` expected + it "analyzes Haskell source code" $ do + sample <- loadFile $ codeSamples "haskell" "full.hs" + let expected = SourceCode + [ (Code , "") + , (Comment, "{-|") + , (Comment, "Module : Test") + , (Comment, "Description : Short description") + , (Comment, "Copyright : (c) Some Guy, 2013") + , (Comment, " Someone Else, 2014") + , (Comment, "License : GPL-3") + , (Comment, "Maintainer : sample@email.com") + , (Comment, "Stability : experimental") + , (Comment, "Portability : POSIX") + , (Comment, "") + , (Comment, "long") + , (Comment, "description") + , (Comment, "") + , (Comment, "== Code sample") + , (Comment, "@") + , (Comment, "{-# LANGUAGE TypeApplications #-}") + , (Comment, "") + , (Comment, "module Data.VCS.Test where") + , (Comment, "") + , (Comment, "import Data.VCS.Ignore ( Git, Repo(..), listRepo )") + , (Comment, "") + , (Comment, "example :: IO [FilePath]") + , (Comment, "example = do") + , (Comment, " repo <- scanRepo @Git \"path/to/repo\"") + , (Comment, " listRepo repo") + , (Comment, "@") + , (Comment, "-}") + , (Code , "") + , (Code, "{-# LANGUAGE OverloadedStrings #-}") + , (Code , "module Test where") + , (Code , "") + , (Comment, "{- single line block comment -}") + , (Code , "") + , (Comment, "{-") + , (Comment, "multi line block comment") + , (Comment, "-}") + , (Code , "") + , (Code , "foo :: String") + , (Code , "foo = \"Hello, world!\"") + , (Code , "") + , (Comment, "-- line comment") + ] + analyzeSourceCode (fileSupport Haskell) sample `shouldBe` expected - it "splits input with both conditions" $ do - let expected = (["text", "->"], ["RESULT"], ["<-", "foo"]) - splitInput fstSplit sndSplit sample `shouldBe` expected + it "analyzes HTML source code" $ do + sample <- loadFile $ codeSamples "html" "sample1.html" + let expected = SourceCode + [ (Code , "") + , (Comment, "") + , (Code , "") + , (Comment, "") + , (Code , "") + , (Code , " ") + , (Code, " ") + , (Code, " Test title") + , (Code , " ") + , (Code , " ") + , (Code , " Hello, World!") + , (Code , " ") + , (Comment, " ") + , (Code , "") + ] + analyzeSourceCode (fileSupport HTML) sample `shouldBe` expected - it "splits input when nothing matches the 1st split condition" $ do - let expected = ([], ["text", "RESULT", "<-", "foo"], []) - splitInput fstSplit [] "text\nRESULT\n<-\nfoo" `shouldBe` expected + it "analyzes Java source code" $ do + sample <- loadFile $ codeSamples "java" "sample1.java" + let expected = SourceCode + [ (Comment, "/*") + , (Comment, " * This is header.") + , (Comment, " */") + , (Code , "") + , (Code , "package foo;") + , (Code , "") + , (Comment, "/* This is not header */") + , (Code , "") + , (Code , "class Hello {") + , (Comment, " /* This is not header */") + , (Code, " public static void main(String[] args) {") + , (Code, " System.out.println(\"Hello, world!\");") + , (Comment, " // line header") + , (Code , " }") + , (Code , "}") + ] + analyzeSourceCode (fileSupport Java) sample `shouldBe` expected - it "splits input when nothing matches the 2nd split condition" $ do - let expected = ([], ["text", "->", "RESULT", "foo"], []) - splitInput [] sndSplit "text\n->\nRESULT\nfoo" `shouldBe` expected + it "analyzes Javascript source code" $ do + sample <- loadFile $ codeSamples "js" "sample1.js" + let expected = SourceCode + [ (Comment, "/*") + , (Comment, " * This is header") + , (Comment, " */") + , (Code , "") + , (Code , "function answer() {") + , (Comment, " /* This is not header */") + , (Code , " return 42;") + , (Comment, " // line comment") + , (Code , "}") + ] + analyzeSourceCode (fileSupport JS) sample `shouldBe` expected - it "splits input when nothing matches both conditions" $ do - let expected = ([], ["text", "RESULT", "foo"], []) - splitInput fstSplit sndSplit "text\nRESULT\nfoo" `shouldBe` expected + it "analyzes PureScript source code" $ do + sample <- loadFile $ codeSamples "purescript" "full.purs" + let expected = SourceCode + [ (Code , "") + , (Comment, "-- Some module header here") + , (Code , "") + , (Comment, "-- Some comment here") + , (Code , "") + , (Code , "module Test where") + , (Code , "") + , (Comment, "{-") + , (Comment, "block comment multi line") + , (Comment, "-}") + , (Code , "") + , (Code , "foo :: String") + , (Code , "foo = \"Hello, world!\"") + , (Code , "") + , (Comment, "{- block comment single line -}") + ] + analyzeSourceCode (fileSupport PureScript) sample `shouldBe` expected - it "handles case when 2nd split is found before 1st split" $ do - let expected = ([], ["text"], ["->", "RESULT", "<-", "foo"]) - splitInput sndSplit fstSplit sample `shouldBe` expected + it "analyzes Rust source code" $ do + sample <- loadFile $ codeSamples "rust" "sample1.rs" + let expected = SourceCode + [ (Comment, "/*") + , (Comment, " * This is header") + , (Comment, " */") + , (Code , "") + , (Code , " fn main() {") + , (Comment, " /* This is not header */") + , (Code, " println!(\"Hello World!\");") + , (Comment, " // line comment") + , (Code , "}") + ] + analyzeSourceCode (fileSupport Rust) sample `shouldBe` expected - it "handles case when 1st split is also after 2nd split" $ do - let expected = (["foo", "->"], ["RESULT"], ["<-", "bar", "->", "end"]) - sample' = "foo\n->\nRESULT\n<-\nbar\n->\nend" - splitInput fstSplit sndSplit sample' `shouldBe` expected + it "analyzes Scala source code" $ do + sample <- loadFile $ codeSamples "scala" "sample1.scala" + let expected = SourceCode + [ (Comment, "/*") + , (Comment, " * This is header") + , (Comment, " */") + , (Code , "") + , (Code , "package foo") + , (Code , "") + , (Comment, "/* This is not header */") + , (Code , "") + , (Code , "object Hello extends App {") + , (Code , " println(\"Hello, world!\")") + , (Comment, " // line comment") + , (Code , "}") + ] + analyzeSourceCode (fileSupport Scala) sample `shouldBe` expected + it "analyzes Shell source code" $ do + sample <- loadFile $ codeSamples "shell" "sample1.sh" + let expected = SourceCode + [ (Code , "#!/bin/bash") + , (Code , "") + , (Comment, "# This is") + , (Comment, "# header") + , (Code , "") + , (Comment, "# This is not") + , (Code , "") + , (Code , "echo \"TEST\"") + ] + analyzeSourceCode (fileSupport Shell) sample `shouldBe` expected diff --git a/test/Headroom/FileSystemSpec.hs b/test/Headroom/FileSystemSpec.hs --- a/test/Headroom/FileSystemSpec.hs +++ b/test/Headroom/FileSystemSpec.hs @@ -1,17 +1,18 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} + module Headroom.FileSystemSpec ( spec ) where -import Headroom.Data.Regex ( re ) +import Headroom.Data.Regex ( re ) import Headroom.FileSystem import RIO -import RIO.FilePath ( () ) -import RIO.List ( sort ) -import qualified RIO.List as L +import RIO.FilePath ( () ) +import RIO.List ( sort ) +import qualified RIO.List as L import Test.Hspec diff --git a/test/Headroom/FileTypeSpec.hs b/test/Headroom/FileTypeSpec.hs --- a/test/Headroom/FileTypeSpec.hs +++ b/test/Headroom/FileTypeSpec.hs @@ -5,13 +5,13 @@ ) where -import Headroom.Configuration ( makeHeadersConfig - , parseConfiguration - ) -import Headroom.Configuration.Types ( Configuration(..) ) -import Headroom.Embedded ( defaultConfig ) +import Headroom.Configuration ( makeHeadersConfig + , parseConfiguration + ) +import Headroom.Configuration.Types ( Configuration(..) ) +import Headroom.Embedded ( defaultConfig ) import Headroom.FileType -import Headroom.FileType.Types ( FileType(..) ) +import Headroom.FileType.Types ( FileType(..) ) import RIO import Test.Hspec diff --git a/test/Headroom/Header/SanitizeSpec.hs b/test/Headroom/Header/SanitizeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Header/SanitizeSpec.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Headroom.Header.SanitizeSpec + ( spec + ) +where + +import Headroom.Configuration.Types ( HeaderSyntax(..) ) +import Headroom.Data.Regex ( re ) +import Headroom.Data.Text ( fromLines ) +import Headroom.Header.Sanitize +import RIO +import Test.Hspec + + +spec :: Spec +spec = do + + describe "findPrefix" $ do + it "finds and fills line prefix to LineComment header syntax" $ do + let s = [re|^--|] + sample = fromLines ["-- first", "", "-- second", "-- third"] + syntax = LineComment s Nothing + expected = LineComment s (Just "--") + findPrefix syntax sample `shouldBe` expected + + it "finds and fills line prefix to BlockComment header syntax" $ do + let s = [re|^{-\||] + e = [re|(?) ) +import Test.Hspec hiding ( after + , before + ) + + +spec :: Spec +spec = do + + let samplesDir = "test-data" "code-samples" + lHeaderConfig pb pa = + HeaderConfig ["hs"] 0 0 0 0 pb pa (LineComment [re|^--|] Nothing) + bHeaderConfig = bHeaderConfigM 0 0 0 0 + bHeaderConfigM mtc mtf mbc mbf pb pa = HeaderConfig + ["hs"] + mtc + mtf + mbc + mbf + pb + pa + (BlockComment [re|^{-\||] [re|(? + analyzeSourceCode (fileSupport ft) <$> loadFile (samplesDir p) + defaultConfig' <- parseConfiguration defaultConfig + HeadersConfig {..} <- makeHeadersConfig (cLicenseHeaders defaultConfig') + sampleC1 <- loadSample C $ "c" "sample1.c" + sampleC2 <- loadSample C $ "c" "sample2.c" + sampleCpp1 <- loadSample CPP $ "cpp" "sample1.cpp" + sampleCpp2 <- loadSample CPP $ "cpp" "sample2.cpp" + sampleCss1 <- loadSample CSS $ "css" "sample1.css" + sampleCss2 <- loadSample CSS $ "css" "sample2.css" + sampleHs1 <- loadSample Haskell $ "haskell" "sample1.hs" + sampleHs2 <- loadSample Haskell $ "haskell" "sample2.hs" + sampleHtml1 <- loadSample HTML $ "html" "sample1.html" + sampleHtml2 <- loadSample HTML $ "html" "sample2.html" + sampleJava1 <- loadSample Java $ "java" "sample1.java" + sampleJava2 <- loadSample Java $ "java" "sample2.java" + sampleJs1 <- loadSample JS $ "js" "sample1.js" + sampleRust1 <- loadSample Rust $ "rust" "sample1.rs" + sampleScala1 <- loadSample Scala $ "scala" "sample1.scala" + sampleScala2 <- loadSample Scala $ "scala" "sample2.scala" + sampleShell1 <- loadSample Shell $ "shell" "sample1.sh" + findHeader hscC sampleC1 `shouldBe` Just (1, 3) + findHeader hscC sampleC2 `shouldBe` Nothing + findHeader hscCpp sampleCpp1 `shouldBe` Just (1, 3) + findHeader hscCpp sampleCpp2 `shouldBe` Nothing + findHeader hscCss sampleCss1 `shouldBe` Just (1, 4) + findHeader hscCss sampleCss2 `shouldBe` Nothing + findHeader hscHaskell sampleHs1 `shouldBe` Just (1, 3) + findHeader hscHaskell sampleHs2 `shouldBe` Nothing + findHeader hscHtml sampleHtml1 `shouldBe` Just (1, 4) + findHeader hscHtml sampleHtml2 `shouldBe` Nothing + findHeader hscJava sampleJava1 `shouldBe` Just (0, 2) + findHeader hscJava sampleJava2 `shouldBe` Nothing + findHeader hscJs sampleJs1 `shouldBe` Just (0, 2) + findHeader hscRust sampleRust1 `shouldBe` Just (0, 2) + findHeader hscScala sampleScala1 `shouldBe` Just (0, 2) + findHeader hscScala sampleScala2 `shouldBe` Nothing + findHeader hscShell sampleShell1 `shouldBe` Just (2, 3) + + describe "findBlockHeader" $ do + let s = [re|^{-\||] + e = [re|(?") + , (Code , "->") + , (Code , "RESULT") + , (Comment, "<-") + , (Code , "<-") + , (Code , "also some code") + ] + fstSplit = [[re|->|]] + sndSplit = [[re|<-|]] + + it "handles empty source code and conditions" $ do + splitSource [] [] mempty `shouldBe` (mempty, mempty, mempty) + + it "handles source code and empty conditions" $ do + splitSource [] [] sample `shouldBe` (mempty, sample, mempty) + + it "splits source code with 1st split condition" $ do + let before = + SourceCode [(Code, "some code"), (Comment, "->"), (Code, "->")] + middle = SourceCode + [ (Code , "RESULT") + , (Comment, "<-") + , (Code , "<-") + , (Code , "also some code") + ] + after = mempty + expected = (before, middle, after) + splitSource fstSplit [] sample `shouldBe` expected + + it "splits source code with 2nd split condition" $ do + let before = mempty + middle = SourceCode + [ (Code , "some code") + , (Comment, "->") + , (Code , "->") + , (Code , "RESULT") + , (Comment, "<-") + ] + after = SourceCode [(Code, "<-"), (Code, "also some code")] + expected = (before, middle, after) + splitSource [] sndSplit sample `shouldBe` expected + + it "splits source code with both conditions" $ do + let before = + SourceCode [(Code, "some code"), (Comment, "->"), (Code, "->")] + middle = SourceCode [(Code, "RESULT"), (Comment, "<-")] + after = SourceCode [(Code, "<-"), (Code, "also some code")] + expected = (before, middle, after) + splitSource fstSplit sndSplit sample `shouldBe` expected + + it "splits source code when nothing matches the 1st split condition" $ do + let sample' = SourceCode + [ (Code , "some code") + , (Comment, "->") + , (Code , "RESULT") + , (Comment, "<-") + , (Code , "<-") + , (Code , "also some code") + ] + expected = (mempty, sample', mempty) + splitSource fstSplit [] sample' `shouldBe` expected + + it "splits source code when nothing matches the 2nd split condition" $ do + let sample' = SourceCode + [ (Code , "some code") + , (Comment, "->") + , (Code , "->") + , (Code , "RESULT") + , (Comment, "<-") + , (Code , "also some code") + ] + expected = (mempty, sample', mempty) + splitSource [] sndSplit sample' `shouldBe` expected + + it "splits source code when nothing matches both conditions" $ do + let sample' = SourceCode + [ (Code , "some code") + , (Comment, "->") + , (Code , "RESULT") + , (Comment, "<-") + , (Code , "also some code") + ] + expected = (mempty, sample', mempty) + splitSource fstSplit sndSplit sample' `shouldBe` expected + + it "handles case when 2nd split is found before 1st split" $ do + let before = mempty + middle = SourceCode [(Code, "some code"), (Comment, "->")] + after = SourceCode + [ (Code , "->") + , (Code , "RESULT") + , (Comment, "<-") + , (Code , "<-") + , (Code , "also some code") + ] + expected = (before, middle, after) + splitSource sndSplit fstSplit sample `shouldBe` expected + + it "handles case when 1st split is also after 2nd split" $ do + let + sample' = SourceCode + [ (Code , "some code") + , (Comment, "->") + , (Code , "->") + , (Code , "RESULT") + , (Comment, "<-") + , (Code , "<-") + , (Code , "->") + , (Code , "also some code") + ] + before = + SourceCode [(Code, "some code"), (Comment, "->"), (Code, "->")] + middle = SourceCode [(Code, "RESULT"), (Comment, "<-")] + after = + SourceCode [(Code, "<-"), (Code, "->"), (Code, "also some code")] + expected = (before, middle, after) + splitSource fstSplit sndSplit sample' `shouldBe` expected diff --git a/test/Headroom/Meta/VersionSpec.hs b/test/Headroom/Meta/VersionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/Meta/VersionSpec.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Headroom.Meta.VersionSpec + ( spec + ) +where + +import Headroom.Meta.Version +import RIO +import Test.Hspec + +spec :: Spec +spec = do + describe "Ord instance" $ do + it "correctly compare two values" $ do + compare (Version 1 2 3 4) (Version 1 2 3 4) `shouldBe` EQ + compare (Version 0 1 0 0) (Version 0 1 0 1) `shouldBe` LT + compare (Version 1 1 0 0) (Version 0 1 0 1) `shouldBe` GT + + + describe "parseVersion" $ do + it "parses valid Version from Text" $ do + parseVersion "0.1.2.3" `shouldBe` Just (Version 0 1 2 3) + + it "parses Nothing for invalid input" $ do + parseVersion "0.4" `shouldBe` Nothing + + + describe "printVersion" $ do + it "pretty prints given version" $ do + printVersion (Version 1 2 3 4) `shouldBe` "1.2.3.4" + + + describe "printVersionP" $ do + it "pretty prints given version (with 'v' prefix)" $ do + printVersionP (Version 1 2 3 4) `shouldBe` "v1.2.3.4" + + + describe "pvp" $ do + it "produces correct Version using QuasiQuotes" $ do + [pvp|0.1.2.3|] `shouldBe` Version 0 1 2 3 + diff --git a/test/Headroom/SerializationSpec.hs b/test/Headroom/SerializationSpec.hs --- a/test/Headroom/SerializationSpec.hs +++ b/test/Headroom/SerializationSpec.hs @@ -7,7 +7,7 @@ import Headroom.Serialization import RIO -import qualified RIO.Map as M +import qualified RIO.Map as M import Test.Hspec diff --git a/test/Headroom/SourceCodeSpec.hs b/test/Headroom/SourceCodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Headroom/SourceCodeSpec.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Headroom.SourceCodeSpec + ( spec + ) +where + +import Headroom.SourceCode +import RIO +import qualified RIO.Text as T +import Test.Hspec + + +spec :: Spec +spec = do + + describe "fromText" $ do + it "converts Text to SourceCode" $ do + let + expected = SourceCode + [ (Comment, "-- some comment") + , (Code , "some code") + , (Code , "another code") + ] + sample = "-- some comment\nsome code\nanother code" + f = \line -> pure $ if "--" `T.isPrefixOf` line then Comment else Code + fromText [] f sample `shouldBe` expected + + + describe "toText" $ do + it "converts SourceCode to Text" $ do + let expected = "-- some comment\nsome code\nanother code" + sample = SourceCode + [ (Comment, "-- some comment") + , (Code , "some code") + , (Code , "another code") + ] + toText sample `shouldBe` expected + + + describe "firstMatching" $ do + it "finds and transforms very first line matching the given predicate" $ do + let sample = SourceCode + [ (Comment, "/*") + , (Comment, "this is block comment") + , (Comment, "/* this is nested comment */") + , (Comment, "// also nested comment") + , (Comment, "/*") + , (Comment, "this is also nested comment") + , (Comment, "*/") + , (Comment, "this is still comment") + , (Comment, "*/") + , (Code , "this is some code") + , (Code , "this is code with // comment") + , (Comment, "// single line comment") + ] + expected = Just (9, "THIS IS SOME CODE") + f = \(lt, l) -> if lt == Code && "this" `T.isPrefixOf` l + then Just $ T.toUpper l + else Nothing + firstMatching f sample `shouldBe` expected + + + describe "lastMatching" $ do + it "finds and transforms very last line matching the given predicate" $ do + let sample = SourceCode + [ (Comment, "/*") + , (Comment, "this is block comment") + , (Comment, "/* this is nested comment */") + , (Comment, "// also nested comment") + , (Comment, "/*") + , (Comment, "this is also nested comment") + , (Comment, "*/") + , (Comment, "this is still comment") + , (Comment, "*/") + , (Code , "this is some code") + , (Code , "this is code with // comment") + , (Comment, "// single line comment") + ] + expected = Just (10, "THIS IS CODE WITH // COMMENT") + f = \(lt, l) -> if lt == Code && "this" `T.isPrefixOf` l + then Just $ T.toUpper l + else Nothing + lastMatching f sample `shouldBe` expected + + + describe "stripStart" $ do + it "strips empty lines from the start of the source code" $ do + let sample = SourceCode [(Code, ""), (Code, ""), (Code, "h"), (Code, "")] + expected = SourceCode [(Code, "h"), (Code, "")] + stripStart sample `shouldBe` expected + + + describe "stripEnd" $ do + it "strips empty lines from the start of the source code" $ do + let sample = SourceCode [(Code, ""), (Code, "h"), (Code, ""), (Code, "")] + expected = SourceCode [(Code, ""), (Code, "h")] + stripEnd sample `shouldBe` expected + + describe "cut" $ do + it "cuts source code using the given start and end positions" $ do + let sample = + SourceCode [(Code, "1"), (Code, "2"), (Code, "3"), (Code, "4")] + expected = SourceCode [(Code, "2"), (Code, "3")] + cut 1 3 sample `shouldBe` expected 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 @@ -9,7 +9,7 @@ import Headroom.Template import Headroom.Template.Mustache -import Headroom.Variables ( mkVariables ) +import Headroom.Variables ( mkVariables ) import RIO import Test.Hspec diff --git a/test/Headroom/TypesSpec.hs b/test/Headroom/TypesSpec.hs --- a/test/Headroom/TypesSpec.hs +++ b/test/Headroom/TypesSpec.hs @@ -5,7 +5,7 @@ ) where -import Headroom.Variables ( mkVariables ) +import Headroom.Variables ( mkVariables ) import RIO import Test.Hspec diff --git a/test/Headroom/VariablesSpec.hs b/test/Headroom/VariablesSpec.hs --- a/test/Headroom/VariablesSpec.hs +++ b/test/Headroom/VariablesSpec.hs @@ -5,16 +5,17 @@ ) where -import Headroom.Types ( CurrentYear(..) ) +import Headroom.Types ( CurrentYear(..) ) import Headroom.Variables -import Headroom.Variables.Types ( Variables(..) ) +import Headroom.Variables.Types ( Variables(..) ) import RIO -import qualified RIO.HashMap as HM +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")]